Google
 

Trailing-Edge - PDP-10 Archives - BB-H548B-BM - iql-source/iql.cbl
There are 2 other files named iql.cbl in the archive. Click here to see a list.
000100 IDENTIFICATION DIVISION.
000120
000140 PROGRAM-ID.     IQL.
000160
000180 DATE-WRITTEN.   1978.
000200 DATE-COMPILED.
000220 SECURITY.       COPYRIGHT 1978  1979 AZREX INC
000240                 ALL RIGHTS RESERVED.
000260
000280 REMARKS.        IQL IS THE INTERACTIVE FRONT END TO
000300                 THE IQL SYSTEM;.  SEE THE LIST OF FUNCTIONS UNDER
000320                 PARAGRAPH CENTRAL-CONTROL FOR THE CURRENT
000340                 FUNCTIONS;
000360*                THIS IS VERSION 3A;  EDIT 0.
000640*                IT IS A DECSYSTEM20 VERSION THAT
000660                 CONTAINS ? AND RECOGNITION AS WELL AS
000680                 CALLING THE SYSTEM EDITOR VIA INFERIOR FORK
000700
000720 ENVIRONMENT DIVISION.
000740
000760 CONFIGURATION SECTION.
000780 SOURCE-COMPUTER. DECSYSTEM-20.
000800 OBJECT-COMPUTER. DECSYSTEM-20.
000820 SPECIAL-NAMES.  CHANNEL (1) IS TOP-OF-PAGE
000840                 CONSOLE IS TTY.
000860
000880 INPUT-OUTPUT SECTION.
000900
000920 FILE-CONTROL.
000940     SELECT QPQRYS ASSIGN TO DSK.
000960     SELECT QLEXEC ASSIGN TO DSK.
000980     SELECT QTQRYS ASSIGN TO DSK.
001000     SELECT QCSTMT ASSIGN TO DSK.
001020     SELECT QCDICT ASSIGN TO DSK.
001040     SELECT QPDICT ASSIGN TO DSK.
001060     SELECT QPTEXT ASSIGN TO HLP.
001080     SELECT QTANLZ ASSIGN TO DSK.
001100 I-O-CONTROL.
001120     SAME AREA FOR QCSTMT QCDICT.
001140     SAME AREA FOR QPQRYS QPDICT QPTEXT
001160         QLEXEC QTANLZ.
001180
001200 DATA DIVISION.
001220 FILE SECTION.
001240
001260 FD  QLEXEC
001280     VALUE OF IDENTIFICATION IS QLNNNELPT
001300     LABEL RECORDS ARE STANDARD
001320     RECORD CONTAINS 132 CHARACTERS
001340     BLOCK CONTAINS 0 RECORDS
001360     DATA RECORD IS QLEXEC-LINE.
001380 01  QLEXEC-LINE USAGE IS DISPLAY-7.
001400     02  FILLER              PIC X(132).
001420
001440 FD  QCSTMT
001460     VALUE OF IDENTIFICATION IS QCNNNSTMP
001480     BLOCK CONTAINS 0 RECORDS
001500     LABEL RECORDS ARE STANDARD
001520     DATA RECORD IS QCSTMT-LINE.
001540 01  QCSTMT-LINE USAGE IS DISPLAY-7.
001560     02  COLS1-2             PIC XX.
001580     02  FILLER              PIC X(78).
001600
001620 FD  QTQRYS
001640     VALUE OF IDENTIFICATION IS QTNNNQTMP
001660     BLOCK CONTAINS 0 RECORDS
001680     LABEL RECORDS ARE STANDARD
001700     DATA RECORD IS TEMP-REC.
001720 01  TEMP-REC USAGE IS DISPLAY-7.
001740     02  TEMP-MARK           PIC XX.
001760     02  TEMP-NAME           PIC X(20).
001780     02  FILLER              PIC X(58).
001800
001820 FD  QPQRYS
001840     VALUE OF IDENTIFICATION IS QPQRYSSEQ
001860     BLOCK CONTAINS 0 RECORDS
001880     LABEL RECORDS ARE STANDARD
001900     DATA RECORD IS QPQRYS-LINE.
001920 01  QPQRYS-LINE USAGE IS DISPLAY-7.
001922     03  QPQRYS-LINE-1.
001940         05  STORE-MARK          PIC XX.
001960         05  STORE-NAME          PIC X(20).
001980         05  FILLER              PIC X(58).
001982     03  QPQRYS-LINE-ARRAY REDEFINES QPQRYS-LINE-1.
001984         05  QPQRYS-LINE-CHAR  PIC X  OCCURS 80 TIMES
001986                 INDEXED BY QLCX.
002000
002020 FD  QPTEXT
002040     VALUE OF IDENTIFICATION IS 'IQL   HLP'
002060     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS
002080     DATA RECORD IS HELP-TEXT-REC.
002100 01  HELP-TEXT-REC USAGE IS DISPLAY-7.
002120     02  FILLER              PIC X(80).
002140
002160 FD  QPDICT
002180     VALUE OF IDENTIFICATION IS QPDICTSEQ
002200     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS
002220     DATA RECORD IS DICT-REC.
002240 01  DICT-REC USAGE IS DISPLAY-7.
002260     02  DICT-IDNT           PIC XX.
002280     02  FILLER              PIC X(148).
002300
002320 FD  QCDICT
002340     VALUE OF IDENTIFICATION IS QCNNNDTMP
002360     LABEL RECORD IS STANDARD
002380     BLOCK CONTAINS 0 RECORDS
002400     DATA RECORD IS TRAN-REC.
002420 01  TRAN-REC  USAGE IS DISPLAY-7.
002440     02  FILLER              PIC X(120).
002460
002480 FD  QTANLZ
002500     VALUE OF IDENTIFICATION IS QTANLZ-ID
002520     LABEL RECORDS ARE STANDARD
002540     BLOCK CONTAINS 0 RECORDS
002560     DATA RECORD IS QTANLZ-REC.
002580 01  QTANLZ-REC.
002600     02  ANLZ-QRY-NAME       PIC X(9).
002620     02  FILLER              PIC XXX.
002640     02  ANLZ-QRY-PPN        PIC S9(10) COMP.
002660     02  ANLZ-IDENT          PIC X(72).
002680
002700 WORKING-STORAGE SECTION.
002710 01  UNIVERSAL-PASSWORD      PIC X(12)       VALUE 'DRAGON      '.
002715 01  MAX-BLKFACT             PIC S9(9) COMP  VALUE 10.
002720 01  AUTO-SW                 PIC 9.
002740 01  ASCII-SW                PIC 9.
002760 01  FIRST-POS-CTR           PIC 9(4).
002780 01  FP-QUO                  PIC 9999.
002800 01  FP-REM                  PIC 9.
002820 01  BINARY-CHARS            PIC 99.
002830 01  BLANK-OUT-FLAG          PIC 9    VALUE 0.
002840 01  ALL-FLAG                PIC 9      COMP VALUE 0.
002880 01  CONST1                  PIC S9(8)  COMP VALUE 1.
002900 01  COMMA-IS                PIC X           VALUE ','.
002920 01  CONST7                  PIC S9(8)  COMP VALUE 7.
002940 01  CONST3                  PIC S9(8)  COMP VALUE 3.
002960 01  CMND                    PIC S9(2)  COMP VALUE 1.
002980 01  CURRENCY-IS             PIC X           VALUE '$'.
003000 01  CURRENT-PW              PIC X(12)       VALUE SPACES.
003020 01  CURRENT-PW-REF          PIC 99          VALUE 0.
003040 01  CURRENT-RD-PW-REF       PIC 99          VALUE 0.
003060 01  DECIMAL-IS              PIC X           VALUE '.'.
003080 01  DELIM                   PIC X           VALUE ':'.
003100 01  DICT-LOCKED-FLAG        PIC 9      COMP VALUE  0.
003120 01  DISPLAY-JOB-NO          PIC 999         VALUE 0.
003140 01  EDIT                    PIC S9(2)  COMP VALUE 1.
003160 01  EDIT-DOT                PIC 9      COMP VALUE 0.
003180 01  STRING-ALL              PIC 9      COMP VALUE 1.
003200 01  STRING-NOP              PIC 9      COMP VALUE 0.
003220 01  STRING-FOUND            PIC 9      COMP VALUE 0.
003240 01  EDIT-SHIFT              PIC S9(2)  COMP VALUE 1.
003260 01  STNG                    PIC S9(2)  COMP VALUE 1.
003280 01  EDIT-DICT-SW            PIC 9      COMP VALUE 0.
003300 01  EDIT-EOF-SW             PIC 9      COMP VALUE 0.
003320 01  EDIT-FILE-IN            PIC 9      COMP VALUE 0.
003340 01  EDIT-LINE-CT            PIC 9(4)        VALUE 0.
003360 01  EDIT-SHOW-CT            PIC 9(4)        VALUE 0.
003380 01  EDIT-WRITE-SW           PIC 9      COMP VALUE 0.
003400 01  IN-HEADING-FLAG         PIC 9      COMP VALUE 0.
003420 01  I                       PIC S9(4)  COMP VALUE 0.
003422 01  INDEX-SHOW              PIC 99999 VALUE 0.
003440 01  J                       PIC S9(4)  COMP VALUE 0.
003460 01  K                       PIC S9(4)  COMP VALUE 0.
003480 01  L                       PIC S9(4)  COMP VALUE 0.
003490 01  M                       PIC S9(8)  COMP VALUE 0.
003540 01  FIRST-DEF-FLAG          PIC 9      COMP VALUE 1.
003560 01  FOUND-QUERY             PIC 9      COMP VALUE 0.
003580 01  TY-PEEL                 PIC ZZZ9   USAGE DISPLAY-7.
003600 01  ELEM-CHAR               PIC X           VALUE ' ' DISPLAY-7.
003620 01  DICT-LOCK               PIC 9      COMP VALUE 1.
003640 01  CONV-MODE-FLAG          PIC 9      COMP VALUE 1.
003660*01  MAX-RECSIZE             PIC 9(4)   COMP VALUE 2600.
003680*01  MIN-RECSIZE             PIC 9(4)   COMP VALUE 15.
003720 01  MAX-DICT-LIST           PIC 9(4)   COMP VALUE 26.
003730 01  MAX-FWX                 PIC S9(4)  COMP VALUE 72.
003740 01  EDIT-ERROR-FLAG         PIC 9      COMP VALUE 0.
003760 01  MAX-KEYLEN              PIC 999    COMP VALUE 60.
003780*01  MAX-ITEMLEN             PIC S9(4)  COMP VALUE 768.
003800 01  MAX-NAMELEN             PIC S9(4)  COMP VALUE 30.
003820 01  MAX-PRX                 PIC S9(4)  COMP VALUE 80.
003840 01  MAX-PX                  PIC S9(10) COMP VALUE 51.
003842 01  MAX-QLCX                PIC S9(4)  COMP VALUE 80.
003860 01  MAX-RWX                 PIC S9(4)  COMP VALUE 206.
003870 01  MAX-UIX                 PIC S9(4)  COMP VALUE 80.
003880 01  NAME-ERR-FLAG           PIC S9(4)  COMP VALUE 0.
003900 01  NEXT-FLAG               PIC 9      COMP VALUE 0.
003920 01  CURRENT-QUOTE           PIC X           VALUE ' '.
003940 01  NAME-HOLDER             PIC X(20)       VALUE SPACES.
003960 01  PX                      PIC S9(8)  COMP VALUE 1.
003980 01  PX-IN                   PIC S9(8)  COMP VALUE 1.
004000 01  WORK-1                  PIC 9(4)   COMP VALUE 0.
004040
004060 01  BINARY-ADJUST-TABLE     PIC 9(6)        VALUE 105432.
004080 01  BINARY-ADJUST REDEFINES BINARY-ADJUST-TABLE
004100                             OCCURS 6 TIMES PIC 9.
004120*   *PROGRAM AND FILE NAME CONSTRUCTORS FOLLOW*
004140 01  DUMMY                   PIC S9(10) COMP VALUE 0.
004160 01  CALLED-NAME REDEFINES DUMMY
004180                             PIC X(6)   USAGE IS DISPLAY-6.
004200 01  JOB-NO                  PIC S9(3)  COMP VALUE 0.
004220 01  ISAMF7-ID               PIC X(9) VALUE 'ISAMF7IDX'.
004240 01  ISAMF6-ID               PIC X(9) VALUE 'ISAMF6IDX'.
004260 01  QTNNNQTMP.
004280     02  FILLER              PIC XX     VALUE 'QT'.
004300     02  QTNNNQNO            PIC 999    VALUE 001.
004320     02  FILLER              PIC X(4)   VALUE 'QTMP'.
004380 01  EDITOR-RECORD  DISPLAY-7.
004400     02  EDITOR-FILE-NAME    PIC X(25).
004420     02  EDITOR-NULL         PIC X.
004440     02  EDITOR-PRG-NAME     PIC X(25).
004460     02  EDITOR-EFILE-NAME   PIC X(50).
004480     02  EDITOR-CR-LF        PIC X(3).
004500     02  EDITOR-STATUS       PIC X(4).
004520 01  QCNNNSTMP.
004540     02  QCNNNS-NAME.
004560       04  FILLER            PIC XX     VALUE 'QC'.
004580       04  QCNNNSNO          PIC 999    VALUE 001.
004600       04  FILLER            PIC X      VALUE 'S'.
004620     02  QCNNNS-EXT          PIC X(3)      VALUE 'TMP'.
004640 01  QCNNNSTMP1.
004660     02  QCNNNS-NAME1        PIC X(6).
004680     02  FILLER              PIC X      VALUE '.'.
004700     02  QCNNNS-EXT1         PIC X(3).
004720 01  QCNNNDTMP.
004740     02  FILLER              PIC XX     VALUE 'QC'.
004760     02  QCNNNDNO            PIC 999    VALUE 001.
004780     02  FILLER              PIC X(4)   VALUE 'DTMP'.
004800 01  QLNNNELPT.
004820     02  FILLER              PIC XX     VALUE 'QL'.
004840     02  QLNNNENO            PIC 999    VALUE 001.
004860     02  FILLER              PIC X(4)   VALUE 'ELPT'.
004880 01  QTNNNATMP.
004900     02  FILLER              PIC XX     VALUE 'QT'.
004920     02  QTNNNANO            PIC 999    VALUE 001.
004940     02  FILLER              PIC XXXX   VALUE 'ATMP'.
004960
004980 01  QTANLZ-NAME.
005000     02  QTANLZ-PREFIX       PIC X(6)   VALUE SPACES.
005020     02  QTANLZ-SUFFIX       PIC XXX    VALUE 'INQ'.
005040
005060 01  QTNNNITMP.
005080     02  QTNNNIPREFIX        PIC XX     VALUE 'QT'.
005100     02  QTNNNINO            PIC 999    VALUE 001.
005120     02  FILLER.
005122         04  QTNNNITYPE      PIC X      VALUE 'I'.
005124         04  QTNNNIEXT       PIC XXX    VALUE 'TMP'.
005126 01  SORT-TEMP-ID.
005128     02  SORT-JOB            PIC 999.
005130     02  FILLER              PIC X(6)   VALUE 'SRTTMP'.
005140
005160 01  QTANLZ-ID               PIC X(9)   VALUE ' '.
005180
005200 01  PARSED-FILE-NAME        PIC X(9)   VALUE ' '.
005220
005240
005260 01  QPQRYSSEQ               PIC X(9)   VALUE 'QPQRYSSEQ'.
005280 01  QPDICTSEQ               PIC X(9)   VALUE 'QPDICTSEQ'.
005300 01  DEVICER                 PIC X(6)   VALUE SPACE.
005320 01  PROJ                    PIC S9(8)  COMP VALUE 0.
005340 01  USER                    PIC S9(8)  COMP VALUE 0.
005360
005380 01  INFO-REC.
005400     02  INFO-QRY-NAME.
005420         04  FILLER              PIC X(6).
005440         04  INFO-QRY-SUFFIX.
005460             06  INFO-IDENT-FLAG PIC X.
005480             06  FILLER          PIC XX.
005500     02  INFO-DUMP-FLAG          PIC S9.
005520     02  INFO-MODE-FLAG  REDEFINES INFO-DUMP-FLAG PIC S9.
005540     02  INFO-EXECUTE-FLAG       PIC S9.
005560     02  INFO-SAVE-FLAG          PIC S9.
005580     02  INFO-LIST-FLAG          PIC S9.
005600     02  INFO-DICT-NAME          PIC X(30).
005620     02  INFO-CURRENT-QUERY      PIC X(30) VALUE SPACES.
005640     02  INFO-FILE-NAME          PIC X(9).
005660     02  FILLER                  PIC X(8).
005680
005700*   *EDITOR WORKING ITEMS FOLLOW*.
005720 01  EDIT-PRINT-CT           PIC 99     VALUE 0.
005740 01  EDIT-PRT-CT REDEFINES EDIT-PRINT-CT.
005760     02  PRINT-CT1           PIC X.
005780     02  PRINT-CT2           PIC X.
005800 01  EDIT-WORK.
005820     02  EDITOR1             PIC X.
005840     02  EDITOR2             PIC X.
005860     02  FILLER              PIC X(78).
005880 01  EDITOR REDEFINES EDIT-WORK
005900                             PIC X OCCURS 80 TIMES.
005920 01  FIND-LAST.
005940     02  FILLER              PIC X(80)    VALUE SPACE.
005960 01  STRING-WORK.
005980     02  FILLER              PIC X(80) VALUE SPACES.
006000     02  STRING-EXT          PIC X(120) VALUE SPACES.
006020 01  STRIING REDEFINES STRING-WORK
006040                             PIC X OCCURS 200 TIMES.
006060
006080*    *PASSWORD TRANSLATION WORK ITEMS FOLLOW*
006100 01  PW-WORKER USAGE IS DISPLAY-6.
006120     02  PW-CHAR             PIC X OCCURS 12 TIMES.
006140 01  FILLER REDEFINES PW-WORKER.
006160     02  PW-WORK1            PIC S9(10) COMP.
006180     02  PW-WORK2            PIC S9(10) COMP.
006200 01  PW-MASK1                PIC S9(10) COMP VALUE 14729163.
006220 01  PW-MASK2                PIC S9(10) COMP VALUE -24815212.
006240
006244 01  SIXBIT-SPACES PIC X(90) USAGE DISPLAY-6 VALUE SPACES.
006248 01  ASCII-NULLS REDEFINES SIXBIT-SPACES USAGE DISPLAY-7.
006252     02  ASCII-NULL          PIC X.
006256     02  FILLER              PIC X(74).
006260
006270*   *REPORT & QUERY DISPLAY LINES FOLLOW*
006280 01  HEADING-LINE USAGE IS DISPLAY-7.
006300     02  REPORT-DATE.
006320         04  FILLER          PIC X(3).
006340         04  SLASH-1         PIC X.
006360         04  FILLER          PIC XX.
006380         04  SLASH-2         PIC X.
006400         04  FILLER          PIC XX.
006420     02  FILLER              PIC X(30).
006440     02  REPORT-HEADING      PIC X(51).
006460     02  FILLER              PIC X(31).
006480     02  REPORT-PAGE.
006500         04  PAGE-WORD       PIC X(4).
006520         04  FILLER          PIC X.
006540         04  PAGE-NO         PIC X(4).
006560     02  FILLER              PIC XX.
006580 01  REPORT-LINE REDEFINES HEADING-LINE USAGE IS DISPLAY-7.
006600     02  SHORT-LINE          PIC X(71).
006620     02  FILLER              PIC X(61).
006640
006660 01  QUERY-LINE USAGE IS DISPLAY-7.
006680     02  QUERY-TEXT.
006700         04  QUERY-MARK      PIC XX.
006720         04  QUERY-NAME.
006740             06  CNTRL-CHAR  PIC X OCCURS 20 TIMES.
006760         04  HELP-NME REDEFINES QUERY-NAME.
006780             06  HELP-NME-7  PIC X(7).
006800             06  FILLER      PIC X(13).
006820         04  QUERY-MESSAGE   PIC X(58).
006840     02  FILLER REDEFINES QUERY-TEXT USAGE IS DISPLAY-7.
006860         04  SHORT-LINE-OUT.
006880             06  DATE-AREA   PIC X(9).
006900             06  SPACE-1     PIC X.
006920             06  HEAD-AREA   PIC X(51).
006940             06  SPACE-2     PIC X.
006960             06  PAGE-AREA   PIC X(9).
006980         04  FILLER          PIC X(9).
007000     02  FILLER REDEFINES QUERY-TEXT USAGE IS DISPLAY-7.
007020         04  PRINT-CHAR      PIC X
007040                             OCCURS 80 TIMES INDEXED BY PRX.
007060
007080 01  USER-INPUT  USAGE IS DISPLAY-7.
007100     02  USER-ANS.
007120       03  USER-ANS-50.
007140         04  USER-ANS-30.
007160           05  USER-ANS-19.
007180             06  USER-ANS-17.
007200               07  USER-ANS-10.
007220                 08 USER-ANS-9.
007240                   09  USER-ANS-8.
007260                     10  USER-ANS-7.
007280                       11  USER-ANS-6.
007300                         12  USER-ANS-5.
007320                           13  USER-ANS-4.
007340                             14  USER-ANS-3.
007360                               15  USER-ANS-2.
007380                                 16  USER-ANS-1 PIC X.
007400                                 16  FILLER     PIC X.
007420                               15  FILLER       PIC X.
007440                             14  FILLER         PIC X.
007460                           13  FILLER           PIC X.
007480                         12  FILLER             PIC X.
007500                       11  FILLER               PIC X.
007520                     10  FILLER                 PIC X.
007540                   09  FILLER                   PIC X.
007560                 08  FILLER                     PIC X.
007580               07  FILLER                       PIC X(7).
007600             06  FILLER                         PIC XX.
007620           05  FILLER                           PIC X(11).
007640         04  FILLER                             PIC X(20).
007660       03  FILLER                               PIC X(30).
007680 01  FILLER REDEFINES USER-INPUT USAGE IS DISPLAY-7.
007700     02  INPUT-CHAR          PIC X OCCURS 80 TIMES
007720                             INDEXED BY UIX.
007722 01  USER6-INPUT USAGE DISPLAY-6 PIC X(80).
007740
007760 01  FOUND-WORD USAGE IS DISPLAY-7.
007780     02  FOUND-CHAR          PIC X OCCURS 72 TIMES
007800                             INDEXED BY FWX.
007820 01  FOUND-WORD-REDEF REDEFINES FOUND-WORD USAGE IS DISPLAY-7.
007840     02  FOUND-WORD-72.
007860       03  FOUND-WORD-30.
007880         04  FOUND-WORD-20.
007900           05  FOUND-WORD-19.
007920             06  FOUND-WORD-18.
007940               07  FOUND-WORD-10.
007960                 08  FOUND-WORD-9.
007980                   09  FOUND-WORD-8.
008000                     10  FOUND-WORD-7.
008020                       11  FOUND-WORD-6.
008040                         12  FOUND-WORD-5.
008060                           13  FOUND-WORD-4.
008080                             14  FOUND-WORD-3.
008100                               15  FOUND-WORD-2.
008120                                 16  FOUND-WORD-1 PIC X.
008140                                 16  FILLER       PIC X.
008160                               15  FILLER         PIC X.
008180                             14  FILLER           PIC X.
008200                           13  FILLER             PIC X.
008220                         12  FILLER               PIC X.
008240                       11  FILLER                 PIC X.
008260                     10  FILLER                   PIC X.
008280                   09  FILLER                     PIC X.
008300                 08  FILLER                       PIC X.
008320               07  FILLER                         PIC X(8).
008340             06  FILLER                           PIC X.
008360           05  FILLER                             PIC X.
008380         04  FILLER                               PIC X(10).
008400       03  FILLER                                 PIC X(42).
008420
008440 01  FOUND6-WORD       USAGE IS DISPLAY-6.
008460     02  FOUND6-L1     PIC X.
008480     02  FOUND6-R19    PIC X(19).    
008484     02  FILLER        PIC X(52).
008484 01  FOUND6-WORD-REDEF REDEFINES FOUND6-WORD DISPLAY-6.
008486     02  FOUND6-WORD-72.
008488       03  FOUND6-WORD-30.
008490         04  FOUND6-WORD-20.
008492           05  FOUND6-WORD-19.
008494             06  FOUND6-WORD-18.
008496               07  FOUND6-WORD-10.
008498                 08  FOUND6-WORD-9.
008500                   09  FOUND6-WORD-8.
008502                     10  FOUND6-WORD-7.
008504                       11  FOUND6-WORD-6.
008506                         12  FOUND6-WORD-5.
008508                           13  FOUND6-WORD-4.
008510                             14  FOUND6-WORD-3.
008512                               15  FOUND6-WORD-2.
008514                                 16  FOUND6-WORD-1 PIC X.
008516                                 16  FILLER        PIC X.
008518                               15  FILLER          PIC X.
008520                             14  FILLER            PIC X.
008522                           13  FILLER              PIC X.
008524                         12  FILLER                PIC X.
008526                       11  FILLER                  PIC X.
008528                     10  FILLER                    PIC X.
008530                   09  FILLER                      PIC X.
008532                 08  FILLER                        PIC X.
008534               07  FILLER                          PIC X(8).
008536             06  FILLER                            PIC X.
008538           05  FILLER                              PIC X.
008540         04  FILLER                                PIC X(10).
008544       03  FILLER                                  PIC X(42).
008546
008548 01  FOUND6-WORD-REDEF1 REDEFINES FOUND6-WORD.
008550     02  FOUND6-CHAR        PIC X 
008552                            OCCURS 72 TIMES INDEXED BY F6IX.
008550 01  WORK6X                 PIC X(9) DISPLAY-6.
008554
008558 01  CURRENT-QUERY-NAME DISPLAY-6.
008560     02  QUERY-NAME-6       PIC X(6)  VALUE SPACES.
008562     02  FILLER             PIC X(14) VALUE SPACES.
008564
008580 01  WORD-HOLDER DISPLAY-7.
008600     02  WORD-HOLDER-30.
008620         04  WORD-HOLDER-3   PIC XXX.
008640         04  FILLER          PIC X(27).
008660
008664 01  WORD6-HOLDER DISPLAY-6.
008666     02  WORD6-HOLDER-3      PIC XXX.
008668     02  FILLER              PIC X(27).
008670
008680 01  JRIGHT-WORD USAGE IS DISPLAY-7.
008700     02  JRIGHT-CHAR         PIC X OCCURS 20 TIMES
008720                             INDEXED BY JRX.
008740 01  FILLER REDEFINES JRIGHT-WORD USAGE IS DISPLAY-7.
008760     02  FILLER              PIC X(16).
008780     02  JRIGHT-4.
008800         04  FILLER          PIC X.
008820         04  JRIGHT-3.
008840             06  FILLER      PIC X.
008860             06  JRIGHT-2.
008880                 08  FILLER      PIC X.
008900                 08  JRIGHT-1    PIC X.
008920
008940 01  CONSOLE-LINE USAGE IS DISPLAY-7.
008960     02  CONSOLE-CHAR        PIC X OCCURS 80 TIMES.
008970 01  MAX-CONSOLE-CHARS       PIC S9(10) COMP VALUE 80.
008980
009000 01  QUERY-NAME-MSG DISPLAY-7.
009020     02  FILLER              PIC X.
009040     02  LQ-NAME             PIC X(20).
009060     02  FILLER              PIC XXX.
009080     02  MQ-NAME             PIC X(20).
009100     02  FILLER              PIC XXX.
009120     02  RQ-NAME             PIC X(20).
009140     02  FILLER              PIC X(5).
009160 01  HELP-NME-MSG REDEFINES QUERY-NAME-MSG DISPLAY-7.
009180     02  FILLER              PIC X.
009200     02  LH-NAME             PIC X(20).
009220     02  FILLER              PIC X(3).
009240     02  MH-NAME             PIC X(20).
009260     02  FILLER              PIC X(3).
009280     02  RH-NAME             PIC X(20).
009300     02  FILLER              PIC X(5).
009320 01  FILE-NAME-MSG REDEFINES QUERY-NAME-MSG DISPLAY-7.
009340     02  FILE-NAME-SLOT.
009360         04  FILLER          PIC X(30).
009380     02  DIRECT-SLOT         PIC X(19).
009400     02  FILLER              PIC X(23).
009420 01  FILE-DATA-MSG REDEFINES FILE-NAME-MSG DISPLAY-7.
009440     02  FILLER              PIC X(11).
009460     02  FILE-TYPE-SLOT.      
009500         04  FILE-ORG-SLOT   PIC XX.
009520         04  FILLER          PIC X(5).
009540     02  FILLER              PIC X.
009560     02  FILE-IN-SLOT        PIC X(9).
009580     02  FILLER              PIC X(15).
009600     02  REC-SIZE-SLOT       PIC ZZZ9.
009620     02  FILLER              PIC X.
009640     02  BLOCK-FACT-SLOT     PIC ZZZ9.
009660     02  FILLER              PIC X.
009680     02  KEY-LOC-SLOT        PIC ZZZ9.
009700     02  FILLER              PIC X.
009720     02  KEY-LEN-SLOT        PIC Z9.
009740     02  FILLER              PIC X.
009760     02  KEY-TYPE-SLOT       PIC X.
009780     02  KEY-SIGN-SLOT       PIC X.
009800     02  FILLER              PIC X.
009820     02  RP-SLOT             PIC ZZ.
009840     02  RP-SLOT-X REDEFINES RP-SLOT
009860                             PIC XX.
009880     02  FILLER              PIC X.
009900     02  CP-SLOT             PIC ZZ.
009920     02  CP-SLOT-X REDEFINES CP-SLOT
009940                             PIC XX.
009960     02  FILLER              PIC X.
009980     02  RWP-SLOT            PIC ZZ.
010000     02  RWP-SLOT-X REDEFINES RWP-SLOT
010020                             PIC XX.
010040 01  TY-NAME-MSG  REDEFINES FILE-NAME-MSG DISPLAY-7.
010060     02  TY-DD-ID1           PIC XX.
010080     02  TY-NOUPD            PIC X.
010100     02  TY-NAME             PIC X(30).
010120     02  FILLER              PIC X(39).
010140 01  TY-ITEM-MSG REDEFINES FILE-NAME-MSG DISPLAY-7.
010160     02  FILLER              PIC X(12).
010180     02  TY-TITLE1           PIC X(10).
010200     02  FILLER              PIC X.
010220     02  TY-TITLE2           PIC X(10).
010240     02  FILLER              PIC X.
010260     02  TY-FCHAR            PIC X(4).
010280     02  FILLER              PIC X.
010300     02  TY-NCHARS           PIC X(4).
010320     02  FILLER              PIC X.
010340     02  TY-TYPE             PIC X.
010360     02  FILLER              PIC X.
010380     02  TY-SCALE            PIC X.
010400     02  FILLER              PIC X.
010420     02  TY-PICT.
010440         04  FILLER          PIC X(16).
010460         04  PICT-OFLOW      PIC X.
010480         04  TY-SCAN         PIC X(4).
010500     02  FILLER              PIC X.
010520     02  TY-PROT             PIC ZZ.
010540     02  TY-PROT-X REDEFINES TY-PROT
010560                             PIC XX.
010580 01  PW-DATA-MSG REDEFINES FILE-NAME-MSG DISPLAY-7.
010600     02  TY-PD-ID            PIC XXX.
010620     02  TY-PASSWORD.
010640         04  TY-PW-CHAR      PIC X OCCURS 12 TIMES.
010660     02  FILLER              PIC X(19).
010680     02  TY-PROTNO           PIC XX.
010700     02  FILLER              PIC X(36).
010720 01  RD-DATA-MESSAGE REDEFINES FILE-NAME-MSG DISPLAY-7.
010740     02  TY-RD-IDNT          PIC XX.
010760     02  FILLER              PIC X.
010780     02  TY-RD-NAME.
010800         04  TY-RD-NAME-SHRT PIC X(8).
010820         04  TY-RD-NAME-EXT  PIC X(22).
010840     02  FILLER              PIC X.
010860     02  TY-RD-ORIGIN        PIC ZZZ9.
010880     02  FILLER              PIC X.
010900     02  TY-RD-LENGTH        PIC ZZZ9.
010920     02  FILLER              PIC X.
010940     02  TY-RD-TYPE          PIC XXX.
010960     02  FILLER              PIC X.
010980     02  TY-RD-TEXT          PIC X(24).
011000 01  CD-DATA-MSG REDEFINES FILE-NAME-MSG DISPLAY-7.
011020     02  TY-CD-IDNT          PIC XX.
011040     02  FILLER              PIC X.
011060     02  TY-CD-NO            PIC ZZ.
011080     02  FILLER              PIC X.
011100     02  TY-CD-TEXT          PIC X(66).
011120
011140 01  TY-DICT-HEADERS USAGE IS DISPLAY-7.
011160     02  TY-DICT-HEAD1.
011180         04  FILLER          PIC X(36) VALUE
011200         'Dict       File    File-in          '.
011220         04  FILLER          PIC X(36) VALUE
011240         '        Rec  Blk  Key KY KY RD CP RW'.
011260     02  TY-DICT-HEAD2.
011280         04  FILLER          PIC X(36) VALUE
011300         'Name       Type    Name       Direct'.
011320         04  FILLER          PIC X(36) VALUE
011340         '        Len  Fac  Loc LN TP PW PW PW'.
011360     02  TY-DICT-HEAD3.
011380         04  FILLER          PIC X(36) VALUE
011400         '----       ----    ----       ------'.
011420         04  FILLER          PIC X(36) VALUE
011440         '        ---  ---  --- -- -- -- -- --'.
011460
011480 01  TY-ITEM-HEADERS USAGE IS DISPLAY-7.
011500     02  TY-ITEM-HEAD1.
011520         04  FILLER          PIC X(39) VALUE
011540             '   Item     Top        Bottom     1st '.
011560         04  FILLER          PIC X(33) VALUE
011580             '#    T S Printing         Scan   '.
011600     02  TY-ITEM-HEAD2.
011620         04  FILLER          PIC X(39) VALUE
011640             'ID Name     Title      Title      Char '.
011660         04  FILLER          PIC X(33) VALUE
011680             'Char Y C Picture          GNNS PT'.
011700     02  TY-ITEM-HEAD3.
011720         04  FILLER          PIC X(39) VALUE
011740             '-- -------- ---------- ---------- ---- '.
011760         04  FILLER          PIC X(33) VALUE
011780             '---- - - ---------------- ---- --'.
011800
011820 01  DICT-PROMPTS DISPLAY-7.
011840     02  FILLER              PIC X(37) VALUE
011860         ' *FD,DD,KD,PD,CD,RD,AD,SD,END,SCRUB:'.
011880     02  FILLER              PIC X(37) VALUE
011900         ' *Action code (A,C,D):______________'.
011920     02  FILLER              PIC X(37) VALUE ' '.
011940     02  FILLER              PIC X(37) VALUE
011960         ' *Action code (A,C,D or P):_________'.
011980     02  FILLER              PIC X(37) VALUE
012000         ' *Dict name - up to 30 chars:_______'.
012020     02  FILLER              PIC X(37) VALUE
012040         ' *Dict unlocking password, if any:__'.
012060     02  FILLER              PIC X(37) VALUE
012080         ' *File name as XXXXXX.EEE:__________'.
012100     02  FILLER              PIC X(37) VALUE
012120         ' *Directory:________________________'.
012140     02  FILLER              PIC X(37) VALUE
012160         ' *File type (TAPE,DISK6,DISK7,DBMS):'.
012180     02  FILLER              PIC X(37) VALUE
012200         ' *Record length in chars:___________'.
012220     02  FILLER              PIC X(37) VALUE
012240         ' *Blocking factor (recs/block):_____'.
012260     02  FILLER              PIC X(37) VALUE
012280         ' *Loc of ISAM key:__________________'.
012300     02  FILLER              PIC X(37) VALUE
012320         ' *ISAM key length:__________________'.
012340     02  FILLER              PIC X(37) VALUE
012360         ' *ISAM key type (A or N):___________'.
012380     02  FILLER              PIC X(37) VALUE
012400         ' *ISAM key sign (S or U):___________'.
012420     02  FILLER              PIC X(37) VALUE
012440         ' *Read password ref:________________'.
012460     02  FILLER              PIC X(37) VALUE
012480         ' *Copy password ref:________________'.
012500     02  FILLER              PIC X(37) VALUE
012520         ' *Rewrite password Ref:_____________'.
012540     02  FILLER              PIC X(37) VALUE ' '.
012560     02  FILLER              PIC X(37) VALUE
012580         ' *Item name (up to 30 chars):_______'.
012600     02  FILLER              PIC X(37) VALUE
012620         ' *Top column title (up to 10 chars):'.
012640     02  FILLER              PIC X(37) VALUE
012660         ' *Bottom title (up to 10 chars):____'.
012680     02  FILLER              PIC X(37) VALUE
012700         ' *Loc of first char of item:________'.
012720     02  FILLER              PIC X(37) VALUE
012740         ' *Length of item in digits or chars:'.
012760     02  FILLER              PIC X(37) VALUE
012780         ' *Item type (A,N or B):_____________'.
012800     02  FILLER              PIC X(37) VALUE
012820         ' *Scale (# of decimal places):______'.
012840     02  FILLER              PIC X(37) VALUE
012860         ' *Display picture (up to 19 chars):_'.
012880     02  FILLER             PIC X(37) VALUE
012900         ' *Input field? (Y = yes, N = no):___'.
012920     02  FILLER              PIC X(37) VALUE
012940         ' *Scan group name (A - Z):__________'.
012960     02  FILLER              PIC X(37) VALUE
012980         ' *# of repeats in group:____________'.
013000     02  FILLER              PIC X(37) VALUE
013020         ' *Scan stop character:______________'.
013040     02  FILLER              PIC X(37) VALUE
013060         ' *Password ref (2 digits):__________'.
013080     02  FILLER              PIC X(37) VALUE
013100         ' *Exclusivity (Y or N):_____________'.
013120     02  FILLER              PIC X(37) VALUE ' '.
013140     02  FILLER              PIC X(37) VALUE
013160         ' *Password ref # (2 digits):________'.
013180     02  FILLER              PIC X(37) VALUE
013200         ' *Password (6 chars):_______________'.
013220     02  FILLER              PIC X(37) VALUE ' '.
013240     02  FILLER              PIC X(37) VALUE
013260         ' *Record name:______________________'.
013280     02  FILLER              PIC X(37) VALUE
013300         ' *Record origin:____________________'.
013320     02  FILLER              PIC X(37) VALUE
013340         ' *Record length (chars):____________'.
013360     02  FILLER              PIC X(37) VALUE
013380         ' *Record type (ASCII or SIXBIT):____'.
013400     02  FILLER              PIC X(37) VALUE
013420         ' *Description (if any):_____________'.
013440     02  FILLER              PIC X(37) VALUE ' '.
013460     02  FILLER              PIC X(37) VALUE
013480         ' *Area name:________________________'.
013500*     02  FILLER              PIC X(37) VALUE
013520*         ' *Area origin:______________________'.
013540*     02  FILLER              PIC X(37) VALUE
013560*         ' *Area length:______________________'.
013580     02  FILLER              PIC X(37) VALUE
013600         ' *Description (if any):_____________'.
013620     02  FILLER              PIC X(37) VALUE ' '.
013640     02  FILLER              PIC X(37) VALUE
013660         ' *Set name:_________________________'.
013680*     02  FILLER              PIC X(37) VALUE
013700*         ' *Set owner record #:_______________'.
013720*     02  FILLER              PIC X(37) VALUE
013740*         ' *Set member record #:______________'.
013760     02  FILLER              PIC X(37) VALUE
013780         ' *Description (if any):_____________'.
013800     02  FILLER              PIC X(37) VALUE ' '.
013820     02  FILLER              PIC X(37) VALUE
013840         ' *Comment number (2 digits):________'.
013860     02  FILLER              PIC X(37) VALUE
013880         ' *Comment text:_____________________'.
013900 01  FILLER REDEFINES DICT-PROMPTS DISPLAY-7.
013920     02  PROMPT              PIC X(37) OCCURS 51 TIMES.
013940
013960 01  FILE-TYPE-LIST DISPLAY-7.
013980     02  FILLER              PIC X(7) VALUE 'MagTape'.
014000     02  FILLER              PIC X(7) VALUE 'illegal'.
014020     02  FILLER              PIC X(7) VALUE 'illegal'.
014040     02  FILLER              PIC X(7) VALUE 'illegal'.
014060     02  FILLER              PIC X(7) VALUE 'illegal'.
014080     02  FILLER              PIC X(7) VALUE 'SQ Dsk6'.
014100     02  FILLER              PIC X(7) VALUE 'SQ Dsk7'.
014120     02  FILLER              PIC X(7) VALUE 'DBMS   '.
014140     02  FILLER              PIC X(7) VALUE 'Srt Dsk'.
014160     02  FILLER              PIC X(7) VALUE 'illegal'.
014180 01  FILE-TYP REDEFINES FILE-TYPE-LIST DISPLAY-7.
014200     02  TYPE-LIST           PIC X(7) OCCURS 10 TIMES.
014220
014240 01  RESERVED-WORD-LIST.
014260     02  FILLER PIC X(18) VALUE 'ACCEPT '.
014280     02  FILLER PIC X(18) VALUE 'ACROSS '.
014300     02  FILLER PIC X(18) VALUE 'ALL '.
014320     02  FILLER PIC X(18) VALUE 'ALPHA '.
014340     02  FILLER PIC X(18) VALUE 'AND '.
014360     02  FILLER PIC X(18) VALUE 'ANY '.
014380     02  FILLER PIC X(18) VALUE 'APPEND '.
014400     02  FILLER PIC X(18) VALUE 'AREA '.
014402     02  FILLER PIC X(18) VALUE 'AREA-ID '.
014404     02  FILLER PIC X(18) VALUE 'AREA-NAME '.
014420     02  FILLER PIC X(18) VALUE 'ASAVE '.
014440     02  FILLER PIC X(18) VALUE 'ASCENDING '.
014450     02  FILLER PIC X(18) VALUE 'ASCII '.
014460     02  FILLER PIC X(18) VALUE 'AVERAGE '.
014480     02  FILLER PIC X(18) VALUE 'AUTHORITY '.
014500     02  FILLER PIC X(18) VALUE 'BEGINNING '.
014502     02  FILLER PIC X(18) VALUE 'BLANK '.
014504     02  FILLER PIC X(18) VALUE 'BLANKS '.
014520     02  FILLER PIC X(18) VALUE 'BOTTOM '.
014522     02  FILLER PIC X(18) VALUE 'BROWSE '.
014524     02  FILLER PIC X(18) VALUE 'BY '.
014526     02  FILLER PIC X(18) VALUE 'BYE '.
014540     02  FILLER PIC X(18) VALUE 'CALL '.
014560     02  FILLER PIC X(18) VALUE 'CHANGE '.
014580     02  FILLER PIC X(18) VALUE 'CLOSE '.
014600     02  FILLER PIC X(18) VALUE 'COLUMN '.
014602     02  FILLER PIC X(18) VALUE 'COMPILE '.
014620     02  FILLER PIC X(18) VALUE 'COMPUTE '.
014622     02  FILLER PIC X(18) VALUE 'CONTAINS '.
014640     02  FILLER PIC X(18) VALUE 'COPY '.
014660     02  FILLER PIC X(18) VALUE 'CREATE '.
014662     02  FILLER PIC X(18) VALUE 'CURRENT '.
014664     02  FILLER PIC X(18) VALUE 'CURRENT-RECORD-KEY'.
014680     02  FILLER PIC X(18) VALUE 'DATE '.
014700     02  FILLER PIC X(18) VALUE 'DELETE '.
014720     02  FILLER PIC X(18) VALUE 'DESCENDING '.
014740     02  FILLER PIC X(18) VALUE 'DISPLAY '.
014760     02  FILLER PIC X(18) VALUE 'DISPLAYALL '.
014780     02  FILLER PIC X(18) VALUE 'DISPLAYOFF '.
014800     02  FILLER PIC X(18) VALUE 'DISPLAYON '.
014802     02  FILLER PIC X(18) VALUE 'DO '.
014820     02  FILLER PIC X(18) VALUE 'DOWN '.
014822     02  FILLER PIC X(18) VALUE 'DUPLICATE '.
014824     02  FILLER PIC X(18) VALUE 'EBCDIC '.
014826     02  FILLER PIC X(18) VALUE 'EDIT '.
014840     02  FILLER PIC X(18) VALUE 'ELSE '.
014842     02  FILLER PIC X(18) VALUE 'EMPTY '.
014860     02  FILLER PIC X(18) VALUE 'END '.
014880     02  FILLER PIC X(18) VALUE 'EOF '.
014900     02  FILLER PIC X(18) VALUE 'EQ '.
014920     02  FILLER PIC X(18) VALUE 'EQUAL '.
014940     02  FILLER PIC X(18) VALUE 'EQUALS '.
014942     02  FILLER PIC X(18) VALUE 'ERASE '.
014960     02  FILLER PIC X(18) VALUE 'ERROR '.
014962     02  FILLER PIC X(18) VALUE 'ERROR-COUNT '.
014964     02  FILLER PIC X(18) VALUE 'ERROR-STATUS '.
014965     02  FILLER PIC X(18) VALUE 'EXCLUSIVE '.
014968     02  FILLER PIC X(18) VALUE 'EXECUTE '.
014980     02  FILLER PIC X(18) VALUE 'EXIT '.
015000     02  FILLER PIC X(18) VALUE 'FILLER '.
015020     02  FILLER PIC X(18) VALUE 'FIND '.
015040     02  FILLER PIC X(18) VALUE 'FIRST '.
015060     02  FILLER PIC X(18) VALUE 'FIRSTIME '.
015080     02  FILLER PIC X(18) VALUE 'FIRSTTIME '.
015082     02  FILLER PIC X(18) VALUE 'FOR '.
015100     02  FILLER PIC X(18) VALUE 'FORM-LINES '.
015120     02  FILLER PIC X(18) VALUE 'FROM '.
015140     02  FILLER PIC X(18) VALUE 'GE '.
015160     02  FILLER PIC X(18) VALUE 'GEQ '.
015162     02  FILLER PIC X(18) VALUE 'GET '.
015180     02  FILLER PIC X(18) VALUE 'GO '.
015200     02  FILLER PIC X(18) VALUE 'GQ '.
015220     02  FILLER PIC X(18) VALUE 'GR '.
015240     02  FILLER PIC X(18) VALUE 'GREATER '.
015260     02  FILLER PIC X(18) VALUE 'GT '.
015280     02  FILLER PIC X(18) VALUE 'HEADING '.
015300     02  FILLER PIC X(18) VALUE 'HOLD '.
015320     02  FILLER PIC X(18) VALUE 'HSPACE '.
015340     02  FILLER PIC X(18) VALUE 'IF '.
015360     02  FILLER PIC X(18) VALUE 'IN '.
015362     02  FILLER PIC X(18) VALUE 'INPUT '.
015380     02  FILLER PIC X(18) VALUE 'INSERT '.
015400     02  FILLER PIC X(18) VALUE 'IQL '.
015401     02  FILLER PIC X(18) VALUE 'IS '.
015402     02  FILLER PIC X(18) VALUE 'JOB '.
015404     02  FILLER PIC X(18) VALUE 'JUSTIFY '.
015420     02  FILLER PIC X(18) VALUE 'KEY '.
015440     02  FILLER PIC X(18) VALUE 'KEY1 '.
015460     02  FILLER PIC X(18) VALUE 'KEY2 '.
015480     02  FILLER PIC X(18) VALUE 'KEY3 '.
015500     02  FILLER PIC X(18) VALUE 'LAST '.
015520     02  FILLER PIC X(18) VALUE 'LASTIME '.
015540     02  FILLER PIC X(18) VALUE 'LASTTIME '.
015560     02  FILLER PIC X(18) VALUE 'LE '.
015580     02  FILLER PIC X(18) VALUE 'LEFT '.
015600     02  FILLER PIC X(18) VALUE 'LEQ '.
015620     02  FILLER PIC X(18) VALUE 'LESS '.
015640     02  FILLER PIC X(18) VALUE 'LIST '.
015660     02  FILLER PIC X(18) VALUE 'LMARGIN '.
015680     02  FILLER PIC X(18) VALUE 'LQ '.
015700     02  FILLER PIC X(18) VALUE 'LS '.
015720     02  FILLER PIC X(18) VALUE 'LT '.
015740     02  FILLER PIC X(18) VALUE 'MARGIN '.
015760     02  FILLER PIC X(18) VALUE 'MATCH '.
015762     02  FILLER PIC X(18) VALUE 'MEMBER '.
015780     02  FILLER PIC X(18) VALUE 'MERGE '.
015782     02  FILLER PIC X(18) VALUE 'NAVIGATE '.
015800     02  FILLER PIC X(18) VALUE 'NE '.
015820     02  FILLER PIC X(18) VALUE 'NEQ '.
015840     02  FILLER PIC X(18) VALUE 'NEW '.
015860     02  FILLER PIC X(18) VALUE 'NEWGROUP '.
015880     02  FILLER PIC X(18) VALUE 'NEWGRPV '.
015900     02  FILLER PIC X(18) VALUE 'NEWPAGE '.
015920     02  FILLER PIC X(18) VALUE 'NEXT '.
015940     02  FILLER PIC X(18) VALUE 'NO '.
015960     02  FILLER PIC X(18) VALUE 'NOHEADING '.
015962     02  FILLER PIC X(18) VALUE 'NOLIST '.
015980     02  FILLER PIC X(18) VALUE 'NOPAGING '.
016000     02  FILLER PIC X(18) VALUE 'NOT '.
016020     02  FILLER PIC X(18) VALUE 'NOTITLES '.
016040     02  FILLER PIC X(18) VALUE 'NQ '.
016060     02  FILLER PIC X(18) VALUE 'NR '.
016062     02  FILLER PIC X(18) VALUE 'OF '.
016080     02  FILLER PIC X(18) VALUE 'OFF '.
016100     02  FILLER PIC X(18) VALUE 'ON '.
016120     02  FILLER PIC X(18) VALUE 'OPEN '.
016140     02  FILLER PIC X(18) VALUE 'OR '.
016142     02  FILLER PIC X(18) VALUE 'OUTPUT '.
016160     02  FILLER PIC X(18) VALUE 'OWNER '.
016180     02  FILLER PIC X(18) VALUE 'PAGE '.
016200     02  FILLER PIC X(18) VALUE 'PAGE-LINES '.
016202     02  FILLER PIC X(18) VALUE 'PASSWORD '.
016220     02  FILLER PIC X(18) VALUE 'PIC '.
016222     02  FILLER PIC X(18) VALUE 'PICTURE '.
016240     02  FILLER PIC X(18) VALUE 'PRINT '.
016260     02  FILLER PIC X(18) VALUE 'PRIOR '.
016262     02  FILLER PIC X(18) VALUE 'PROTECTED '.
016264     02  FILLER PIC X(18) VALUE 'PUT '.
016280     02  FILLER PIC X(18) VALUE 'QT '.
016282     02  FILLER PIC X(18) VALUE 'QUERY-PIC '.
016284     02  FILLER PIC X(18) VALUE 'QUERY-PICTURE '.
016286     02  FILLER PIC X(18) VALUE 'QUERY-TITLE '.
016300     02  FILLER PIC X(18) VALUE 'QUIT '.
016318     02  FILLER PIC X(18) VALUE 'READ '.
016320     02  FILLER PIC X(18) VALUE 'RECORD '.
016340     02  FILLER PIC X(18) VALUE 'RECORD1 '.
016360     02  FILLER PIC X(18) VALUE 'RECORD2 '.
016380     02  FILLER PIC X(18) VALUE 'RECORD3 '.
016400     02  FILLER PIC X(18) VALUE 'RECORDS '.
016402     02  FILLER PIC X(18) VALUE 'RECORD-NAME '.
016403     02  FILLER PIC X(18) VALUE 'REMOVE '.
016404     02  FILLER PIC X(18) VALUE 'REPEAT '.
016408     02  FILLER PIC X(18) VALUE 'REPLACE '.
016420     02  FILLER PIC X(18) VALUE 'REPORT '.
016440     02  FILLER PIC X(18) VALUE 'RESET '.
016460     02  FILLER PIC X(18) VALUE 'RESUMEHEADING '.
016480     02  FILLER PIC X(18) VALUE 'RESUMEPAGING '.
016500     02  FILLER PIC X(18) VALUE 'RESUMETITLES '.
016502     02  FILLER PIC X(18) VALUE 'RETRIEVAL '.
016520     02  FILLER PIC X(18) VALUE 'REWIND '.
016540     02  FILLER PIC X(18) VALUE 'REWRITE '.
016560     02  FILLER PIC X(18) VALUE 'RIGHT '.
016580     02  FILLER PIC X(18) VALUE 'RMARGIN '.
016600     02  FILLER PIC X(18) VALUE 'RPTDATE '.
016620     02  FILLER PIC X(18) VALUE 'RPTHEAD '.
016622     02  FILLER PIC X(18) VALUE 'RUN '.
016624     02  FILLER PIC X(18) VALUE 'RUN-UNIT '.
016640     02  FILLER PIC X(18) VALUE 'SAME '.
016660     02  FILLER PIC X(18) VALUE 'SAVE '.
016662     02  FILLER PIC X(18) VALUE 'SCHEMA '.
016680     02  FILLER PIC X(18) VALUE 'SET '.
016682     02  FILLER PIC X(18) VALUE 'SHOW '.
016684     02  FILLER PIC X(18) VALUE 'SIXBIT '.
016700     02  FILLER PIC X(18) VALUE 'SORT '.
016702     02  FILLER PIC X(18) VALUE 'SPACE '.
016704     02  FILLER PIC X(18) VALUE 'SPACES '.
016706     02  FILLER PIC X(18) VALUE 'STATS '.
016708     02  FILLER PIC X(18) VALUE 'STATUS '.
016720     02  FILLER PIC X(18) VALUE 'STITLES '.
016740     02  FILLER PIC X(18) VALUE 'STORE '.
016742     02  FILLER PIC X(18) VALUE 'SUB-SCHEMA '.
016760     02  FILLER PIC X(18) VALUE 'SUMMARY '.
016762     02  FILLER PIC X(18) VALUE 'TAKE '.
016780     02  FILLER PIC X(18) VALUE 'TALLY '.
016800     02  FILLER PIC X(18) VALUE 'THEN '.
016820     02  FILLER PIC X(18) VALUE 'THRU '.
016822     02  FILLER PIC X(18) VALUE 'TIMES '.
016840     02  FILLER PIC X(18) VALUE 'TITLES '.
016860     02  FILLER PIC X(18) VALUE 'TO '.
016880     02  FILLER PIC X(18) VALUE 'TODAY '.
016900     02  FILLER PIC X(18) VALUE 'TOP '.
016920     02  FILLER PIC X(18) VALUE 'TOTAL '.
016922     02  FILLER PIC X(18) VALUE 'UNITL '.
016940     02  FILLER PIC X(18) VALUE 'UP '.
016942     02  FILLER PIC X(18) VALUE 'UPDATE '.
016944     02  FILLER PIC X(18) VALUE 'USING '.
016946     02  FILLER PIC X(18) VALUE 'VIA '.
016960     02  FILLER PIC X(18) VALUE 'VERIFY '.
016980     02  FILLER PIC X(18) VALUE 'VSPACE '.
017000     02  FILLER PIC X(18) VALUE 'WHEN '.
017020     02  FILLER PIC X(18) VALUE 'WHERE '.
017022     02  FILLER PIC X(18) VALUE 'WHILE '.
017024     02  FILLER PIC X(18) VALUE 'WRITE '.
017040     02  FILLER PIC X(18) VALUE 'XRANDOM '.
017060     02  FILLER PIC X(18) VALUE 'XT '.
017062     02  FILLER PIC X(18) VALUE 'ZERO '.
017064     02  FILLER PIC X(18) VALUE 'ZEROES '.
017080
017100 01  RESERVED-WORD-REDEF REDEFINES RESERVED-WORD-LIST.
017120     02  RESERVED-WORD PIC X(18) OCCURS 207 TIMES
017140                                     INDEXED BY RWX.
017160
017180 01  TRAN-WS DISPLAY-7.
017200     02  FD-TRAN.
017220         04  CF-IDNT         PIC XX.
017240         04  CF-ACT          PIC X.
017260         04  CF-NAME         PIC X(30).
017280         04  CF-INLABEL      PIC X(9).
017300         04  FILLER          PIC X(8).
017320         04  CF-DIRECT       PIC X(19).
017340         04  CF-FILETYPE-X   PIC X.
017360         04  CF-FILETYPE REDEFINES CF-FILETYPE-X
017380                             PIC 9.
017400         04  CF-RECSIZE-X    PIC X(4).
017420         04  CF-RECSIZE REDEFINES CF-RECSIZE-X
017440                             PIC 9(4).
017460         04  CF-BLKFACT-X    PIC X(4).
017480         04  CF-BLKFACT REDEFINES CF-BLKFACT-X
017500                             PIC S9(4).
017520         04  CF-KEYPOS-X     PIC X(4).
017540         04  CF-KEYPOS REDEFINES CF-KEYPOS-X
017560                             PIC 9(4).
017580         04  CF-KEYLEN-X     PIC XXX.
017600         04  CF-KEYLEN REDEFINES CF-KEYLEN-X
017620                             PIC 999.
017640         04  CF-KEYTYPE-X    PIC X.
017660         04  CF-KEYTYPE REDEFINES CF-KEYTYPE-X
017680                             PIC 9.
017700         04  CF-KEYSIGN-X    PIC X.
017720         04  CF-KEYSIGN REDEFINES CF-KEYSIGN-X
017740                             PIC 9.
017760         04  CF-PROT-READ    PIC XX.
017780         04  CF-PROT-COPY    PIC XX.
017800         04  CF-PROT-REWRITE PIC XX.
017820         04  FILLER          PIC X(21).
017840         04  CF-PASSWORD     PIC X(6).
017860     02  PD-TRAN REDEFINES FD-TRAN.
017880         04  CP-IDNT         PIC XX.
017900         04  CP-ACT          PIC X.
017920         04  CP-PROT-NO      PIC 99.
017940         04  CP-PROT-NO-X REDEFINES CP-PROT-NO
017960                             PIC XX.
017980         04  CP-DATE-FLAG    PIC X.
018000         04  CP-LINE         PIC X.
018020         04  CP-LINE-X REDEFINES CP-LINE
018040                             PIC X.
018060         04  CP-TEXT.
018080             06  CF-FIX-TEXT PIC X(6).
018100             06  CP-VAR-TEXT PIC X(67).
018120         04  FILLER          PIC X(40).
018140     02  DD-TRAN REDEFINES FD-TRAN.
018160         04  CD-IDNT         PIC XX.
018180         04  CD-ACT          PIC X.
018200         04  CD-NAME.
018220             06  CD-NME2.
018240                 08  CD-NME1 PIC X.
018260                 08  FILLER  PIC X.
018280             06  FILLER      PIC X(28).
018300         04  CD-TITLE1       PIC X(10).
018320         04  CD-TITLE2       PIC X(10).
018340         04  CD-FCHAR-X      PIC X(4).
018360         04  CD-FCHAR REDEFINES CD-FCHAR-X
018380                             PIC 9(4).
018400         04  CD-NCHARS-X     PIC X(4).
018420         04  CD-NCHARS REDEFINES CD-NCHARS-X
018440                             PIC 9(4).
018460         04  CD-TYPE         PIC 9.
018480         04  CD-TYPE-X REDEFINES CD-TYPE
018500                             PIC X.
018520         04  CD-SCALE        PIC 9.
018540         04  CD-SCALE-X REDEFINES CD-SCALE
018560                             PIC X.
018580         04  CD-OFFSET       PIC 9.
018600         04  CD-OFFSET-X REDEFINES CD-OFFSET
018620                             PIC X.
018640         04  CD-EDIT-X       PIC XX.
018660         04  CD-EDIT REDEFINES CD-EDIT-X
018680                             PIC 99.
018700         04  CD-PICT         PIC X(19).
018720         04  FILLER REDEFINES CD-PICT.
018740             06  CD-PICTCHAR PIC X OCCURS 19 TIMES
018760                             INDEXED BY PIX.
018780         04  CD-SCANINFO.
018800             06  CD-GRPNAME  PIC X.
018820             06  CD-NRPTS    PIC 99.
018840             06  CD-NRPTS-X REDEFINES CD-NRPTS
018860                             PIC XX.
018880             06  CD-STOPPER  PIC X.
018900         04  CD-PROTINFO.
018920             06  CD-PROT-NO  PIC 99.
018940             06  CD-PROT-NO-X REDEFINES CD-PROT-NO
018960                             PIC XX.
018980             06  CD-EXCLFLAG PIC X.
019000         04  CD-NOUPD        PIC X.
019020         04  FILLER          PIC X(27).
019040     02  RD-TRAN REDEFINES FD-TRAN.
019060         04  RD-IDNT         PIC XX.
019080         04  RD-ACT          PIC X.
019100         04  RD-NAME         PIC X(30).
019120         04  RD-ORIGIN       PIC X(4).
019140         04  RD-LENGTH       PIC X(4).
019160         04  RD-TYPE         PIC X(03).
019180         04  RD-TEXT         PIC X(76).
019200     02  AD-TRAN REDEFINES FD-TRAN.
019220         04  AD-IDNT         PIC XX.
019240         04  AD-ACT          PIC X.
019260         04  AD-NAME         PIC X(30).
019280         04  AD-ORIGIN       PIC X(4).
019300         04  AD-LENGTH       PIC X(4).
019320         04  FILLER          PIC XXX.
019340         04  AD-TEXT         PIC X(76).
019360     02  SD-TRAN REDEFINES FD-TRAN.
019380         04  SD-IDNT         PIC XX.
019400         04  SD-ACT          PIC X.
019420         04  SD-NAME         PIC X(30).
019440         04  SD-OWNER-REC    PIC X(4).
019460         04  SD-MEMBER-REC   PIC X(4).
019480         04  FILLER          PIC XXX.
019500         04  SD-TEXT         PIC X(76).
019520     02  CD-TRAN REDEFINES FD-TRAN.
019540         04  CC-IDNT         PIC XX.
019560         04  CC-ACT          PIC X.
019580         04  CC-NO           PIC XX.
019600         04  CC-TEXT         PIC X(115).
019620
019640 01  DICT-WS DISPLAY-7.
019660     02  DICT-FD.
019680         04  DF-IDNT         PIC XX.
019700         04  DF-NAME.
019720             06  FILLER      PIC X(10).
019740             06  DF-NAME-EXT PIC X(20).
019760         04  DF-NDICTS       PIC 9(3).
019780         04  DF-INLABEL.
019800             06  DF-INNAME   PIC X(6).
019820             06  FILLER      PIC X(11).
019840         04  DF-DIRECT.
019860             06  FILLER      PIC X(13).
019880             06  DF-DIR-EXT  PIC X(6).
019900         04  DF-FILETYPE     PIC 9.
019920         04  DF-RECSIZE      PIC 9(4).
019940         04  DF-BLKFACT      PIC S9(4).
019960         04  DF-KEYPOS       PIC 9(4).
019980         04  DF-KEYLEN       PIC 999.
020000         04  DF-KEYINFO.
020020             06  DF-KEYTYPE  PIC 9.
020040             06  DF-KEYSIGN  PIC 9.
020060         04  DF-PROT         PIC X.
020080         04  DF-PROT-READ    PIC 99.
020100         04  DF-PROT-COPY    PIC 99.
020120         04  DF-PROT-REWRITE PIC 99.
020140         04  FILLER          PIC X(48).
020160         04  DF-LAST-UPDATE  PIC X(6).
020180     02  DICT-DD REDEFINES DICT-FD.
020200         04  DD-IDNT         PIC XX.
020220         04  DD-NAME.
020240             06  FILLER      PIC X(8).
020260             06  DD-NAME-EXT PIC X(22).
020280         04  DD-TITLE1       PIC X(10).
020300         04  DD-TITLE2       PIC X(10).
020320         04  DD-NTCHARS      PIC 99.
020340         04  DD-NECHARS      PIC 9(4).
020360         04  DD-FCHAR        PIC 9(4).
020380         04  DD-NCHARS       PIC 9(4).
020400         04  DD-TYPE         PIC 9.
020420         04  DD-SCALE        PIC 9.
020440         04  DD-OFFSET       PIC 9.
020460         04  DD-EDIT         PIC 99.
020480         04  DD-PICT         PIC X(19).
020500         04  DD-SCANINFO.
020520             06  DD-GROUPLEN PIC 999.
020540             06  DD-SCAN.
020560                 08  DD-GRPNME PIC X.
020580                 08  DD-NRPTS  PIC 99.
020600                 08  DD-NRPTS-X REDEFINES DD-NRPTS
020620                               PIC XX.
020640                 08  DD-STOPPER PIC X.
020660         04  DD-PROTINFO.
020680             06  DD-PROT-NO  PIC 99.
020700             06  DD-EXCLFLAG PIC X.
020720         04  FILLER          PIC XXX.
020740         04  DD-NOUPD        PIC X.
020760         04  FILLER          PIC X(40).
020780         04  DD-LAST-UPDATE  PIC X(6).
020800     02  DICT-PD REDEFINES DICT-FD.
020820         04  DP-IDNT         PIC XX.
020840         04  DP-PROT-NO      PIC 99.
020860         04  DP-DATE-FLAG    PIC X.
020880         04  DP-LINE         PIC 9.
020900         04  DP-TEXT.
020920             06  DP-CHAR     PIC X OCCURS 12 TIMES.
020940         04  FILLER          PIC X(126).
020960         04  PD-LAST-UPDATE  PIC X(6).
020980     02  DICT-RD REDEFINES DICT-FD.
021000         04  DR-IDNT         PIC XX.
021020         04  DR-NAME         PIC X(30).
021040         04  DR-ORIGIN       PIC 9(4).
021060         04  DR-LENGTH       PIC 9(4).
021080         04  DR-TYPE         PIC XXX.
021100         04  DR-TEXT         PIC X(76).
021120         04  FILLER          PIC X(25).
021140         04  DR-LAST-UPDATE  PIC X(6).
021160     02  DICT-CD REDEFINES DICT-FD.
021180         04  DC-IDNT         PIC XX.
021200         04  DC-NO           PIC XX.
021220         04  DC-TEXT.
021240             06  DC-TXT-SHRT PIC X(66).
021260             06  FILLER      PIC X(49).
021280         04  FILLER          PIC X(25).
021300         04  DC-LAST-UPDATE  PIC X(6).
021320
021340 01  FD-ERROR-MESSAGES DISPLAY-7.
021360*    02  FD-MSG-1            PIC X(26) VALUE
021380*    ' %Record size too large'.
021400*    02  FD-MSG-2            PIC X(26) VALUE
021420*    ' %Record size too small'.
021440     02  FD-MSG-3            PIC X(54) VALUE
021460     ' %Warning - blocking factor exceeds MAX-BLKFACT of___ '.
021480     02  FD-MSG-4            PIC X(44) VALUE
021500     ' %Block factor must be non-0 for ISAM'.
021520     02  FD-MSG-5            PIC X(22) VALUE
021540     ' %File type illegal'.
021560     02  FD-MSG-6            PIC X(34) VALUE
021580     ' %No key position for ISAM file'.
021600     02  FD-MSG-7            PIC X(40) VALUE
021620     ' %Key position outside of ISAM record'.
021640     02  FD-MSG-8            PIC X(28) VALUE
021660     ' %No length for ISAM key'.
021680     02  FD-MSG-9            PIC X(36) VALUE
021700     ' %Length for ISAM key exceeds max'.
021760     02  FD-MSG-11           PIC X(17) VALUE
021780     ' %Name missing'.
021800     02  FD-MSG-12           PIC X(40) VALUE
021820     ' %ISAM key type not Alpha or Numeric'.
021840     02  FD-MSG-13           PIC X(40) VALUE
021860     ' %ISAM key sign not Signed or Unsigned'.
021880     02  FD-MSG-14           PIC X(36) VALUE
021900     ' %FD action type not A,C,D,S or P'.
021920     02  FD-MSG-15           PIC X(43) VALUE
021940     ' %Names may not contain spaces or commas'.
021960     02  FD-MSG-16           PIC X(40) VALUE
021980     ' %Names may contain only A-Z,0-9,dash'.
022000     02  FD-MSG-17           PIC X(37) VALUE
022020     ' %File name improperly formatted'.
022040     02  FD-MSG-18          PIC X(53) VALUE
022060     ' %This is a reserved word, change or use a suffix'.
022080
022100 01  DD-ERROR-MSGS DISPLAY-7.
022120     02  DD-MSG-1            PIC X(24) VALUE
022140     ' %Action code illegal'.
022160     02  DD-MSG-2            PIC X(47) VALUE
022180     ' %Item name starts with illegal "X" or "ZZ"'.
022200     02  DD-MSG-3            PIC X(27) VALUE
022220     ' %No first char location'.
022240     02  DD-MSG-4            PIC X(24) VALUE
022260     ' %Item outside of record'.
022280     02  DD-MSG-5            PIC X(19) VALUE
022300     ' %No item length'.
022320     02  DD-MSG-6            PIC X(26) VALUE
022340     ' %Item length too long'.
022360     02  DD-MSG-7            PIC X(22) VALUE
022380     ' %Item type illegal'.
022400     02  DD-MSG-8            PIC X(34) VALUE
022420     ' %Scale larger than item length'.
022440     02  DD-MSG-11           PIC X(36) VALUE
022460     ' %Pic positions/item mismatch'.
022480     02  DD-MSG-13           PIC X(24) VALUE
022500     ' %no scan group name'.
022520     02  DD-MSG-14           PIC X(36) VALUE
022540     ' %Scan repeats run out of record'.
022560     02  DD-MSG-15           PIC X(20) VALUE
022580     ' %No scan repeats'.
022600     02  DD-MSG-17           PIC X(31) VALUE
022620     ' %Illegal password excl flag'.
022640     02  DD-MSG-18.
022660         04  FILLER          PIC X(20) VALUE
022680         ' %not numeric'.
022700     02  DD-MSG-20           PIC X(35) VALUE
022720     ' %Titles may not exceed 10 chars'.
022740
022760
022780 PROCEDURE DIVISION.
022800*$$$$$$$$$$$$$$$$$$$$$$$$$$
022820 MAIN SECTION 0.
022840*$$$$$$$$$$$$$$$$$$$$$$$$$
022860 BEGIN.
022880     ENTER MACRO CLRTTY.
022900     ENTER MACRO IQGJOB USING JOB-NO.
022920     MOVE JOB-NO TO DISPLAY-JOB-NO.
022940     MOVE JOB-NO TO QCNNNSNO QCNNNDNO QTNNNQNO QLNNNENO
022960         QTNNNANO QTNNNINO.
022970     MOVE 'I' TO QTNNNITYPE.
022980     ENTER MACRO IQLOOK USING DEVICER ISAMF6-ID
023000         PROJ USER I.
023020     ENTER MACRO IQLOOK USING DEVICER ISAMF7-ID
023040         PROJ USER J.
023060     IF I NOT = -1 OR J NOT = -1 DISPLAY
023080         ' %Dummy files ISAMF6.IDX and/or ISAMF7.IDX are not'
023100         UPON CONSOLE DISPLAY
023120         '   in your directory. You need them to run a query'
023140         UPON CONSOLE.
023144*    *LOOK FOR INFO/STATUS FILE WRITTEN OUT LAST TIME
023148*      THIS MODULE WAS RUN; SAVES CURRENT-QUERY-NAME, ETC.*
023160     MOVE QTNNNITMP TO QTANLZ-ID.
023180     ENTER MACRO IQLOOK USING DEVICER QTANLZ-ID
023200         PROJ USER I.
023204*    *RESTORE REMEMBERED NAME OF CURRENT QUERY*.
023220     IF I NOT = -1 MOVE SPACES TO CURRENT-QUERY-NAME
023224*    *SEE IF WE JUST CAME BACK FROM IQA'S DUMPING A QUERY
023248*      AND IF SO, EXECUTE SAVED QUERY IQDUMP.INQ*.
023240         GO TO CENTRAL-CONTROL.
023260     OPEN INPUT QTANLZ.
023280     READ QTANLZ INTO INFO-REC AT END
023300         MOVE SPACES TO INFO-CURRENT-QUERY INFO-IDENT-FLAG.
023320     CLOSE QTANLZ.
023340     MOVE INFO-CURRENT-QUERY TO CURRENT-QUERY-NAME.
023360     IF INFO-DUMP-FLAG = 1 AND INFO-IDENT-FLAG = 'I'
023380         MOVE 'IQDUMP' TO FOUND-WORD FOUND6-WORD
023400         GO TO EXECUTOR1.
023420
023440
023460*******************************************************
023480* CENTRAL CONTROL LOGIC FOLLOWS *
023500*
023520* THE LIST OF FUNCTIONS BELOW PRESERVES THE ORIGINAL IQL
023540* FUNCTIONS WHILE ADDING NEW SYNONYMS TO ACCOMMODATE BASIC
023560* AND CENTRAL DECSYSTEM-20 EQUIVALENT COMMAND FORMATS.
023580*******************************************************
023600
023620 CENTRAL-CONTROL.
023640     ENTER MACRO CLRTTY.
023660     PERFORM ASKER.
023680 CENTRAL-CONTROL1.
023700     MOVE 1 TO K.
023720     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
023724     MOVE FOUND-WORD TO FOUND6-WORD.
023740     IF FOUND6-WORD-3 = 'BRO'         GO TO BROWSER.
023760     IF FOUND6-WORD-3 = 'DEF'         GO TO DEFINE-GEN.
023780     IF FOUND6-WORD-3 = 'DEL'         GO TO DELETER.
023800     IF FOUND6-WORD-3 = 'DIC'         GO TO DICT-NAMES.
023820     IF FOUND6-WORD-3 = 'DUM'         GO TO DUMPER.
023840     IF FOUND6-WORD-3 = 'EDI'         GO TO EDIT20.
023860     IF FOUND6-WORD-3 = 'EXI'         GO TO STOPPER.
023880     IF FOUND6-WORD-3 = 'END'         GO TO STOPPER.
023900     IF FOUND6-WORD-3 = 'EXE'         GO TO EXECUTOR.
023920     IF FOUND6-WORD-3 = 'GET'         GO TO GETTER.
023940     IF FOUND6-WORD-3 = 'HEL'         GO TO HELPER.
023960     IF FOUND6-WORD-3 = 'INP'         GO TO INPUTER.
023980     IF FOUND6-WORD-3 = 'ITE'         GO TO DATA-ITEMS.
024000     IF FOUND6-WORD-3 = 'JOB'         GO TO JOBBER.
024020     IF FOUND6-WORD-3 = 'LIS'         GO TO LISTER.
024040     IF FOUND6-WORD-3 = 'QUE'         GO TO FIND-QUERIES.
024060     IF FOUND6-WORD-3 = 'REP'         GO TO REPLACER.
024080     IF FOUND6-WORD-3 = 'RUN'         GO TO RUNNER.
024100     IF FOUND6-WORD-3 = 'SAV'         GO TO SAVER.
024120     IF FOUND6-WORD-3 = 'STO'         GO TO STORER.
024140     IF FOUND6-WORD-3 = 'TEC'         GO TO EDIT20-TECO.
024160     IF FOUND6-WORD-3 = 'TV '         GO TO EDIT20-TV.
024180*    IF FOUND6-WORD-3 = 'TYP'         GO TO TYPER-CALL.
024200     IF FOUND6-WORD-3 = 'UPD'         GO TO UPDATER.
024220     IF FOUND6-WORD-3 = 'WRI'         GO TO WRITER.
024240     IF FOUND6-WORD-3 = '?  '         GO TO HELPER.
024260
024280 CENTRAL-CONTROL-ERROR.
024300      MOVE
024320     ' %Invalid response - please reenter'
024340     TO CONSOLE-LINE. PERFORM DISPLAYER THRU DISPLAYER-EXIT.
024360     GO TO CENTRAL-CONTROL.
024380
024400*******************************************************
024420* SEQUENCES FOLLOW TO CONTROL SUBROUTINES
024440* TO PERFORM MAJOR FUNCTIONS
024460*******************************************************
024470
024580 EDIT20.
024584*     *SET UP PARAMS, THEN FORK TO DEC-20 SYSTEM EDITOR*.
024600	   PERFORM EDIT-ASK THROUGH EDIT-ASK2.
024620 EDIT201.
024640	   MOVE SPACES TO EDITOR-RECORD.
024660     MOVE 'SYS:EDIT.EXE' TO EDITOR-FILE-NAME.
024680	   MOVE 'EDIT /UNSEQUENCE' TO EDITOR-PRG-NAME.
024700 EDIT20-ATTABOY.
024720     MOVE QCNNNS-NAME TO QCNNNS-NAME1.
024740     MOVE QCNNNS-EXT TO QCNNNS-EXT1.
024760     MOVE QCNNNSTMP1 TO EDITOR-EFILE-NAME.
024780     ENTER MACRO GOEDIT USING
024800		EDITOR-FILE-NAME 
024820		EDITOR-NULL 
024840		EDITOR-PRG-NAME 
024860		EDITOR-EFILE-NAME 
024880		EDITOR-CR-LF 
024900		EDITOR-STATUS.
024920     GO TO CENTRAL-CONTROL.
024960
024980 EDIT20-TECO.
024984*    *SET UP TO FORK TO TECO*.
025000	  PERFORM EDIT-ASK THROUGH EDIT-ASK2.
025020	  MOVE SPACES TO EDITOR-RECORD.
025040    MOVE 'SYS:TECO.EXE' TO EDITOR-FILE-NAME.
025060	  MOVE 'TECO ' TO EDITOR-PRG-NAME.
025080	  GO TO EDIT20-ATTABOY.
025120
025140 EDIT20-TV.
025144*    *SET UP TO FORK TO TV EDITOR*.
025160	  PERFORM EDIT-ASK THROUGH EDIT-ASK2.
025180	  MOVE SPACES TO EDITOR-RECORD.
025200	  MOVE 'SYS:TV.EXE' TO EDITOR-FILE-NAME.
025220	  MOVE 'TV ' TO EDITOR-PRG-NAME.
025240	  GO TO EDIT20-ATTABOY.
025280
025290*************************************************************
025300* ON 'WRITE' OR 'CREATE' START A NEW QUERY.
025320* IF A WORD FOLLOWS THE COMMAND, USE IT AS THE NAME OF THE
025340* NEW QUERY.
025360*************************************************************
025380
025400 WRITER.
025420     MOVE SPACES TO CURRENT-QUERY-NAME.
025440     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
025460     IF FOUND-WORD-1 NOT = ' '
025480         PERFORM GET-QUERY-NAME THRU GET-QUERY-NAME-EXIT.
025500     ENTER MACRO IQLOOK USING DEVICER QCNNNSTMP PROJ USER
025520         I.
025540     IF I = -1
025560         OPEN OUTPUT QCSTMT
025580         CLOSE QCSTMT
025600         OPEN INPUT QCSTMT
025620         CLOSE QCSTMT WITH DELETE.
025640    GO TO EDIT201.
025660*    GO TO EDIT-CREATE.
025680
025700*******************************************************
025720* ON 'BROWSE', 'INPUT' OR 'UPDATE' SEND CONTROL TO PROG IQU*.
025740*******************************************************
025760 BROWSER.
025780     MOVE 'B' TO FOUND-WORD-1.
025800     GO TO UPDATER1.
025820
025840 INPUTER.
025860     MOVE 'I' TO FOUND-WORD-1.
025880     GO TO UPDATER1.
025900
025920 UPDATER.
025940     MOVE 'U' TO FOUND-WORD-1.
025960
025980 UPDATER1.
026000     MOVE QTNNNITMP TO QTANLZ-ID.
026020     OPEN OUTPUT QTANLZ.
026040     IF FOUND-WORD-1 = 'I' MOVE 2 TO INFO-MODE-FLAG
026060     ELSE IF FOUND-WORD-1 = 'B' MOVE 1 TO INFO-MODE-FLAG
026080     ELSE IF FOUND-WORD-1 = 'U' MOVE 3 TO INFO-MODE-FLAG.
026100     MOVE 'U' TO INFO-IDENT-FLAG.
026120
026140 UPDATER2.
026160     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
026180     IF FOUND-WORD-1 = ' '
026200         PERFORM GET-DICT-NAME THRU GET-DICT-NAME-EXIT.
026220     MOVE FOUND-WORD-30 TO INFO-DICT-NAME.
026240*    *LOOK FOR OVERRIDE OF DICT FILE NAME*
026260     MOVE SPACES TO INFO-FILE-NAME.
026280     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
026300     IF FOUND-WORD-1 NOT = SPACES
026320         PERFORM FILE-PARSER THRU FILE-PARSER-EXIT
026340         MOVE PARSED-FILE-NAME TO INFO-FILE-NAME.
026360     MOVE CURRENT-QUERY-NAME TO INFO-CURRENT-QUERY.
026380     WRITE QTANLZ-REC FROM INFO-REC.
026400     CLOSE QTANLZ.
026420     MOVE 'IQU   ' TO CALLED-NAME.
026440     ENTER MACRO IQNEXT USING CALLED-NAME.
026460
026480********************************************************
026500* ON 'EXECUTE' TAKE THE NEXT WORD AS THE NAME OF
026520* A PRE-ANALYZED QUERY TO BE EXECUTED.  PLANT THIS
026540* NAME EXTENDED BY '.INQ' IN A ONE-REC QTNNNA.TMP FILE
026560* FOR READ-IN BY IQE, WHICH WILL PICK OUT THE REAL
026580* NAME OF THE PRE-ANALYZED QUERY AND USE THAT AS INPUT.
026600**********************************************************
026620
026640 EXECUTOR.
026660     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
026664     IF FOUND6-WORD-4 = 'EXIT' OR 'END ' GO TO CENTRAL-CONTROL.
026680     IF FOUND-WORD-1 = ' '
026684         DISPLAY ' *Query name or EXIT: ' 
026686           UPON CONSOLE WITH NO ADVANCING
026688         ACCEPT USER-ANS FROM TTY
026672         SET UIX TO 1
026676         GO TO EXECUTOR.
026720 EXECUTOR1.
026724*    *WRITE OUT A 1 RECORD ANALYSIS FILE FOR IQE TO READ-
026728*      IQE WILL USE IT TO GET NAME OF REAL SAVED QUERY TO USE*.
026740     MOVE QTNNNATMP TO QTANLZ-ID.
026760     OPEN OUTPUT QTANLZ.
026780     MOVE FOUND6-WORD-6 TO QTANLZ-PREFIX.
026784     MOVE 'INQ' TO QTANLZ-SUFFIX.
026800     MOVE QTANLZ-NAME TO ANLZ-QRY-NAME.
026820     MOVE 0 TO ANLZ-QRY-PPN.
026840     MOVE 'POINTER ANALYSIS FILE' TO ANLZ-IDENT.
026860     WRITE QTANLZ-REC.
026880     CLOSE QTANLZ.
026900*    *CHECK TO SEE IF PRE-ANALYZED QUERY IS THERE*
026920     MOVE ' ' TO DEVICER.
026940     MOVE 0 TO PROJ USER.
026960     ENTER MACRO IQLOOK USING DEVICER
026980         QTANLZ-NAME PROJ USER I.
027000     IF I NOT = -1 MOVE ' %' TO QUERY-MARK
027020         MOVE ANLZ-QRY-NAME TO QUERY-NAME
027040         MOVE ' Saved query file not found'
027060             TO QUERY-MESSAGE
027080         PERFORM BLANK-PEELOUT THRU BLANK-PEELOUT-EXIT
027090         MOVE QUERY-TEXT TO CONSOLE-LINE
027100         PERFORM DISPLAYER THRU DISPLAYER-EXIT
027120         GO TO CENTRAL-CONTROL.
027124*    *WRITE OUT INFO/STATUS FILE SO NEXT TIME INTO IQL
027128*       CAN PICK UP CURRENT-QUERY-NAME, ETC*.
027140     MOVE QTNNNITMP TO QTANLZ-ID.
027160     OPEN OUTPUT QTANLZ.
027180     MOVE '      INQ' TO INFO-QRY-NAME.
027200     MOVE 0 TO INFO-DUMP-FLAG.
027220     MOVE CURRENT-QUERY-NAME TO INFO-CURRENT-QUERY.
027240     WRITE QTANLZ-REC FROM INFO-REC.
027260     CLOSE QTANLZ.
027260*     *GO DIRECTLY TO EXECUTION MODULE, IQE*.
027280     MOVE 'IQE   ' TO CALLED-NAME.
027300     ENTER MACRO IQNEXT USING CALLED-NAME.
027320
027340
027360*******************************************************
027380* ON 'SOS' CALL SOS TO EDIT CURRENT QUERY OR DICT*.
027400*******************************************************
027420 SOS-ER.
027440*   *BELOW TEMPORARILY SHUTS OFF THIS COMMAND*.
027460     MOVE ' %This version cannot link to SOS'
027480     TO CONSOLE-LINE. PERFORM DISPLAYER THRU DISPLAYER-EXIT.
027500     GO TO CENTRAL-CONTROL.
027520 SOS-ER1.
027540     MOVE 0 TO INFO-LIST-FLAG.
027560*   *WHEN SOSLNK IS READY, REMOVE ABOVE FOUR LINES, CHECK
027580*    LOGIC BELOW AND TEST*.
027600     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
027620     IF FOUND6-WORD-1 = SPACE GO TO SOS-CURRENT.
027640     IF FOUND6-WORD-9 = 'DICTIONAR' GO TO SOS-DICT.
027660     IF FOUND6-WORD-5 = 'LIST ' MOVE 1 TO INFO-LIST-FLAG
027680        PERFORM GET-CURRENT THRU GET-CURRENT-EXIT
027700        GO TO SOS-CURRENT.
027720     MOVE FOUND-WORD-20 TO NAME-HOLDER.
027740     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
027760     IF FOUND-WORD-5 = 'LIST '
027780        MOVE 1 TO INFO-LIST-FLAG
027800        ELSE MOVE 0 TO INFO-LIST-FLAG.
027820     MOVE NAME-HOLDER TO FOUND6-WORD-20 FOUND-WORD.
027840     PERFORM PULL-QUERY THRU PULL-QUERY-EXIT.
027860 SOS-CURRENT.
027880*    *QUERY IF ANY IS IN CURRENT AREA*.
027900     PERFORM LOOK-FOR-QCSTMT.
027920*    CALL IQLSOS USING QCNNNSTMP.
027940     GO TO CENTRAL-CONTROL.
027960 SOS-DICT.
027980*    *EDIT DICT TRANSACTIONS*.
028000     PERFORM LOOK-FOR-QCDICT.
028020*    CALL IQLSOS USING QCNNNDTMP.
028040     GO TO CENTRAL-CONTROL.
028060
028080
028100********************************************************
028120* ON 'HELP' GET EITHER MENU OF AVAILABLE HELPING WORDS
028140* OR STORED TEXT FOR A WORD - DEPENDING ON WHETHER A WORD
028160* FOLLOWED 'HELP' OR NOT
028180*******************************************************
028200 HELPER.
028220     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
028240     PERFORM GET-HELP THRU GET-HELP-EXIT.
028260     GO TO CENTRAL-CONTROL.
028280
028300********************************************************
028320* ON 'TYPE' DISPLAY CURRENT .LPT (PRINT) FILE WITH HEADING
028340* SQUEEZED FOR TERMINAL WIDTH.
028360********************************************************
028380 TYPER-CALL.
028400     PERFORM TYPER THRU TYPER-EXIT.
028420     GO TO CENTRAL-CONTROL.
028440
028460********************************************************
028480* LIST THE CURRENT QUERY IF NO QUERY NAME IS FURNISHED.
028500* OTHERWISE MOVE THE NAMED QUERY INTO THE CURRENT QUERY
028520* AREA AND LIST IT.
028540********************************************************
028560 LISTER.
028580     MOVE 1 TO INFO-LIST-FLAG.
028600     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
028620     IF FOUND-WORD-1 = ' '
028640         PERFORM GET-CURRENT THRU GET-CURRENT-EXIT
028660         ELSE PERFORM PULL-QUERY THRU PULL-QUERY-EXIT.
028680     GO TO CENTRAL-CONTROL.
028700
028720*********************************************************
028740* ON 'GET' MOVE THE NAMED QUERY FROM THE CATALOGED
028760* (STORED) QUERY FILE INTO THE CURRENT AREA. IF THE WORD
028780* 'LIST' OCCURS AS AN ARGUMENT, LIST THE QUERY AS IT IS
028800* GOTTEN.
028820*********************************************************
028840 GETTER.
028860     MOVE 0 TO INFO-LIST-FLAG.
028880 GETTER-CMN.
028900     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
028920     IF FOUND6-WORD-5 = 'LIST'
028940         MOVE 1 TO INFO-LIST-FLAG GO TO GETTER-CMN.
028960     MOVE FOUND-WORD-20 TO NAME-HOLDER.
028980     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
029000     IF FOUND6-WORD-5 = 'LIST ' MOVE 1 TO INFO-LIST-FLAG.
029020     MOVE NAME-HOLDER TO FOUND-WORD-20 FOUND6-WORD-20.
029040     IF FOUND-WORD-1 = ' '
029060         PERFORM GET-CURRENT THRU GET-CURRENT-EXIT
029080         GO TO CENTRAL-CONTROL.
029100     PERFORM PULL-QUERY THRU PULL-QUERY-EXIT.
029120     GO TO CENTRAL-CONTROL.
029140
029160********************************************************
029180* ON 'STORE' STORE THE CURRENT QUERY
029200* UNDER THE NAME WHICH FOLLOWS 'STORE'.
029220********************************************************
029240 STORER.
029260     PERFORM LOOK-FOR-QCSTMT.
029280     IF I NOT = -1 MOVE ' %There is no query to store'
029300         TO CONSOLE-LINE PERFORM DISPLAYER THRU DISPLAYER-EXIT
029320         GO TO CENTRAL-CONTROL.
029340     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
029360     IF FOUND-WORD-1 = ' '
029380         MOVE CURRENT-QUERY-NAME TO FOUND-WORD
029384         MOVE CURRENT-QUERY-NAME TO FOUND6-WORD.
029400     PERFORM STORE-QUERY THRU STORE-QUERY-EXIT.
029420     GO TO CENTRAL-CONTROL.
029440
029460********************************************************
029480* ON 'REPLACE' REPLACE THE QUERY STORED UNDER THE NAME
029500* WHICH FOLLOWS 'REPLACE' WITH THE CURRENT QUERY.
029520********************************************************
029540 REPLACER.
029560     PERFORM LOOK-FOR-QCSTMT.
029564     IF I NOT = -1
029580         MOVE ' %There is no current query with which to replace'
029600         TO CONSOLE-LINE PERFORM DISPLAYER THRU DISPLAYER-EXIT
029620         GO TO CENTRAL-CONTROL.
029640     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
029660     IF FOUND-WORD-1 = ' '
029680         MOVE CURRENT-QUERY-NAME TO FOUND-WORD
029690         MOVE CURRENT-QUERY-NAME TO FOUND6-WORD.
029700     IF FOUND-WORD-1 = ' '
029720         PERFORM GET-QUERY-NAME THRU GET-QUERY-NAME-EXIT.
029740     PERFORM REPLACE-QUERY THRU REPLACE-QUERY-EXIT.
029760     GO TO CENTRAL-CONTROL.
029780
029800********************************************************
029820* ON 'DELETE' DELETE THE STORED QUERY WHOSE NAME FOLLOWS
029840* 'DELETE'.
029860********************************************************
029880 DELETER.
029900     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
029920*    *DOES NOT CHECK NAME - SO CAN DELETE OLD QUERIES*
029940     IF FOUND-WORD-1 = ' '
029960         DISPLAY ' *Query name: ' UPON CONSOLE WITH NO ADVANCING
029980         ACCEPT USER-ANS FROM TTY
030000         SET UIX TO 1
030020         GO TO DELETER.
030040 DELETER1.
030060     PERFORM DELETE-QUERY THRU DELETE-QUERY-EXIT.
030080     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
030100     IF FOUND-WORD-1 NOT = ' ' GO TO DELETER1.
030120     GO TO CENTRAL-CONTROL.
030140
030160********************************************************
030180* ON 'DICTIONARIES' LIST FD DATA FOR ALL DICTIONARIES
030200********************************************************
030220 DICT-NAMES.
030240     PERFORM LIST-DICTS THRU LIST-DICTS-EXIT.
030260     GO TO CENTRAL-CONTROL.
030280
030300********************************************************
030320* ON 'ITEMS' LIST FD DATA FOLLOWED BY PD,DD,AD,SD, AND RD
030340* DATA FOR THE DICTIONARY WHOSE NAME FOLLOWS 'ITEMS'
030360********************************************************
030380 DATA-ITEMS.
030400     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
030420     PERFORM GET-DICT-NAME THRU GET-DICT-NAME-EXIT.
030440     PERFORM LIST-ITEMS THRU LIST-ITEMS-EXIT.
030460     GO TO CENTRAL-CONTROL.
030480
030500********************************************************
030520* ON 'DEFINE' BEGIN ACCEPTING AND CHECKING TRANSACTIONS TO
030540* DEFINE OR CHANGE DICTIONARIES. USE PROMPTING MODE UNLESS
030560* THE WORD 'SHORT' FOLLOWS 'DEFINE'.
030580********************************************************
030600 DEFINE-GEN.
030620     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
030640     IF FOUND6-WORD-5 = 'AUTO ' MOVE 1 TO AUTO-SW
030660                        ELSE  MOVE 0 TO AUTO-SW.
030680     MOVE 1 TO FIRST-DEF-FLAG.
030700     PERFORM DICT-DEFINER THRU DICT-DEFINER-EXIT.
030720     IF FOUND6-WORD-6 = 'SCRUB ' GO TO CENTRAL-CONTROL.
030740     MOVE QTNNNITMP TO QTANLZ-ID.
030760     OPEN OUTPUT QTANLZ.
030780     MOVE 'D' TO INFO-IDENT-FLAG.
030800     MOVE CURRENT-QUERY-NAME TO INFO-CURRENT-QUERY.
030820     WRITE QTANLZ-REC FROM INFO-REC.
030840     CLOSE QTANLZ.
030860     MOVE 'IQD   ' TO CALLED-NAME.
030880     ENTER MACRO IQNEXT USING CALLED-NAME.
030900
030920********************************************************
030940* ON 'QUERIES' LIST NAMES OF ALL STORED QUERIES.
030960********************************************************
030980 FIND-QUERIES.
031000     PERFORM LIST-QUERY-NAMES THRU LIST-QUERY-NAMES-EXIT.
031020     GO TO CENTRAL-CONTROL.
031040
031060**************************************************
031080* ON 'SAVE' SET TO CALL IQA TO SAVE THE QUERY UNDER EITHER
031100* THE FURNISHED OR THE CURRENT QUERY NAME. THE QUERY IS
031120* SAVED AS NAME.INQ; IE: THE EXTENSION '.INQ' IS ADDED
031140* TO THE FIRST SIX CHARACTERS OF THE NAME.
031160*********************************************************
031180 SAVER.
031200     MOVE 0 TO INFO-EXECUTE-FLAG INFO-DUMP-FLAG INFO-LIST-FLAG.
031220     MOVE 1 TO INFO-SAVE-FLAG  WORK-1.
031240     MOVE SPACES TO INFO-QRY-NAME  NAME-HOLDER.
031260     GO TO RUNNER-COMMON.
031280
031300*********************************************************
031320* ON 'DUMP' SET TO CALL IQA TO DUMP THE ANALYSIS FILE
031340* BY SAVING IT UNDER THE NAME 'IQDUMP.TMP'; TO GET A LOOK
031360* AT THE RESULTING FILE; RUN THE QUERY IQDUMP BY ENTERING
031380* EXE IQDUMP AS THE NEXT IQL COMMAND.
031400**********************************************************
031420 DUMPER.
031440     MOVE 0 TO INFO-EXECUTE-FLAG INFO-SAVE-FLAG INFO-LIST-FLAG.
031460     MOVE 1 TO INFO-DUMP-FLAG  WORK-1.
031480     MOVE SPACES TO INFO-QRY-NAME  NAME-HOLDER.
031500     GO TO RUNNER-COMMON.
031520
031540********************************************************
031560* ON 'RUN' PASS CONTROL ON TO IQA   ; IF A NAME OF
031580* A STORED QUERY FOLLOWS 'RUN', MOVE THAT QUERY INTO THE
031600* CURRENT QUERY BEFORE RUNNING.
031620********************************************************
031640 RUNNER.
031660     MOVE SPACES TO INFO-QRY-NAME  NAME-HOLDER.
031680     MOVE 0 TO INFO-DUMP-FLAG  INFO-SAVE-FLAG  INFO-LIST-FLAG.
031700     MOVE 1 TO INFO-EXECUTE-FLAG  WORK-1.
031720
031740 RUNNER-COMMON.
031760     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
031780     IF FOUND-WORD-1 = SPACE GO TO RUNNER1.
031800     IF FOUND6-WORD-5 = 'LIST ' MOVE 1 TO WORK-1
031820         GO TO RUNNER-COMMON.
031840     IF FOUND6-WORD-7 = 'NOLIST ' MOVE 0 TO WORK-1
031860         GO TO RUNNER-COMMON.
031880     IF FOUND6-WORD-5 = 'SAVE ' MOVE 1 TO INFO-SAVE-FLAG
031900         GO TO RUNNER-COMMON.
031920     IF FOUND6-WORD-5 = 'DUMP ' MOVE 1 TO INFO-DUMP-FLAG
031940         GO TO RUNNER-COMMON.
031960     IF FOUND6-WORD-5 = 'RUN  ' MOVE 1 TO INFO-EXECUTE-FLAG
031980         GO TO RUNNER-COMMON.
032000     MOVE FOUND-WORD-20 TO NAME-HOLDER.
032020     GO TO RUNNER-COMMON.
032040
032060 RUNNER1.
032080     MOVE NAME-HOLDER TO FOUND-WORD.
032084     MOVE NAME-HOLDER TO FOUND6-WORD.
032100     MOVE 1 TO FOUND-QUERY.
032120     IF FOUND-WORD-1 NOT = SPACE GO TO RUNNER1A.
032140     PERFORM LOOK-FOR-QCSTMT.
032160     IF I NOT = -1 MOVE ' %There is no current query to run'
032180         TO CONSOLE-LINE PERFORM DISPLAYER THRU DISPLAYER-EXIT
032200         GO TO CENTRAL-CONTROL.
032220
032240 RUNNER1A.
032260     IF FOUND-WORD-1 NOT = SPACE
032280         PERFORM PULL-QUERY THRU PULL-QUERY-EXIT
032282         IF FOUND-QUERY NOT = 1 GO TO CENTRAL-CONTROL.
032284     IF FOUND-WORD-1 = SPACE AND
032300         CURRENT-QUERY-NAME NOT = SPACES
032320         MOVE '**' TO QUERY-MARK
032340         MOVE CURRENT-QUERY-NAME TO QUERY-NAME
032360         MOVE ASCII-NULLS TO QUERY-MESSAGE
032380         DISPLAY ' ' QUERY-TEXT UPON CONSOLE.
032400     IF FOUND-QUERY = 0 GO TO CENTRAL-CONTROL.
032420
032440*    *IF SAVING AND NEITHER NAME FURNISHED NOR CURRENT-QUERY-NAME, 
032442*        GET ONE*.
032460     MOVE CURRENT-QUERY-NAME TO FOUND-WORD.
032464     MOVE CURRENT-QUERY-NAME TO FOUND6-WORD.
032480     IF FOUND-WORD-1 = SPACE AND INFO-SAVE-FLAG = 1
032500         PERFORM GET-QUERY-NAME THRU GET-QUERY-NAME-EXIT.
032520     MOVE WORK-1 TO INFO-LIST-FLAG.
032540*    *PLANT NAME IN HAND FOR POSSIBLE USE BY IQA.
032560     MOVE FOUND-WORD-9 TO INFO-QRY-NAME.
032580     MOVE 'INQ' TO INFO-QRY-SUFFIX.
032600*    *NOW TRICK QTANLZ INTO BECOMING INFO FILE*.
032620     MOVE QTNNNITMP TO QTANLZ-ID.
032640     OPEN OUTPUT QTANLZ.
032660     MOVE 'INQ' TO INFO-QRY-SUFFIX.
032680     MOVE CURRENT-QUERY-NAME TO INFO-CURRENT-QUERY.
032700     WRITE QTANLZ-REC FROM INFO-REC.
032720     CLOSE QTANLZ.
032740*    *HAVING WRITTEN INFO RECORD, GO TO ANALYSIS MODULE.
032760     MOVE 'IQA   ' TO CALLED-NAME.
032780     ENTER MACRO IQNEXT USING CALLED-NAME.
032800
032820********************************************************
032840* ON 'EXIT' CLOSE UP FILES, DELETE WORK FILES
032860* AND GO TO OPERATING SYSTEM.
032880********************************************************
032900 STOPPER.
032920*    *CLEAN OUT ANY LEFT OVER .TMP FILES.
032940*    *USE OPEN OUTPUT TO BE SURE THEY ARE THERE TO DELETE*
032960     MOVE QTNNNQTMP TO QTNNNITMP.
032980     PERFORM DELETE-TMP-FILE.
033060     MOVE QTNNNATMP TO QTNNNITMP.
033080     PERFORM DELETE-TMP-FILE.
033082     MOVE 'U' TO QTNNNITYPE.
033086     PERFORM DELETE-TMP-FILE.
022088     MOVE 'S' TO QTNNNITYPE.
033090     PERFORM DELETE-TMP-FILE.
033092     MOVE 'D' TO QTNNNITYPE.
033094     PERFORM DELETE-TMP-FILE.
033096     MOVE 'I' TO QTNNNITYPE.
033098     PERFORM DELETE-TMP-FILE.
033099     MOVE 'M' TO QTNNNITYPE. 
033100     PERFORM DELETE-TMP-FILE.
033101     MOVE 'S' TO QTNNNITYPE. MOVE 'QC' TO QTNNNIPREFIX.
033102     PERFORM DELETE-TMP-FILE.
033104     MOVE 'D' TO QTNNNITYPE.
033106     PERFORM DELETE-TMP-FILE.
033108     MOVE 'QL' TO QTNNNIPREFIX. MOVE 'U' TO QTNNNITYPE.
033110     MOVE 'LPT' TO QTNNNIEXT.
033112     PERFORM DELETE-TMP-FILE.
033114     MOVE 'IQDUMPTMP' TO QTNNNITMP.
033116     PERFORM DELETE-TMP-FILE.
033118     MOVE JOB-NO TO SORT-JOB.
033120     MOVE SORT-TEMP-ID TO QTNNNITMP.
033122     PERFORM DELETE-TMP-FILE.
033124     DISPLAY ' (End of IQL session) ' UPON CONSOLE.
033140     STOP RUN.
033160
033164 DELETE-TMP-FILE.
033168     MOVE QTNNNITMP TO QTANLZ-ID.
033169     ENTER MACRO IQLOOK USING  DEVICER QTANLZ-ID
033170         PROJ USER I.
033171     IF I = -1
033072         OPEN OUTPUT QTANLZ CLOSE QTANLZ
033074         OPEN INPUT QTANLZ CLOSE QTANLZ WITH DELETE.
033076
033180********************************************************
033200* ON 'JOB' DISPLAY CURRENT JOB NUMBER.
033220********************************************************
033240 JOBBER.
033260     ENTER MACRO IQGJOB USING JOB-NO.
033280     DISPLAY ' Job Number: ' UPON CONSOLE WITH NO ADVANCING.
033300     MOVE JOB-NO TO DISPLAY-JOB-NO.
033320     DISPLAY DISPLAY-JOB-NO UPON CONSOLE.
033340     GO TO CENTRAL-CONTROL.
033360
033380
033400*$$$$$$$$$$$$$$$$$$$$$$$$$
033420 HELPING SECTION 1.
033440*$$$$$$$$$$$$$$$$$$$$$$$$$
033460 GET-HELP.
033480     OPEN INPUT QPTEXT.
033500     IF FOUND-WORD-2 = '* ' NEXT SENTENCE ELSE
033520         IF FOUND-WORD-7 NOT = SPACES GO TO GET-HELP-1.
033540     MOVE ' Words for which you may get help are:'
033560         TO CONSOLE-LINE.
033580     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
033600     PERFORM SPACER.
033620 HELP-ASSEMBLE-1.
033640     MOVE SPACES TO HELP-NME-MSG.
033660     MOVE 1 TO I.
033680 HELP-ASSEMBLE-2.
033700     READ QPTEXT INTO QUERY-TEXT AT END GO TO
033720         HELP-ASSEMBLE-3.
033740     IF QUERY-MARK NOT = '**' GO TO HELP-ASSEMBLE-2.
033760     IF I = 1 MOVE HELP-NME TO LH-NAME
033780         MOVE 2 TO I
033800         GO TO HELP-ASSEMBLE-2.
033820     IF I = 2 MOVE HELP-NME TO MH-NAME
033840         MOVE 3 TO I
033860         GO TO HELP-ASSEMBLE-2.
033880     MOVE HELP-NME TO RH-NAME
033900     MOVE HELP-NME-MSG TO CONSOLE-LINE.
033920     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
033940     GO TO HELP-ASSEMBLE-1.
033960 HELP-ASSEMBLE-3.
033980     IF I NOT = 1 MOVE HELP-NME-MSG TO CONSOLE-LINE
034000         PERFORM DISPLAYER THRU DISPLAYER-EXIT.
034020     PERFORM SPACER.
034040     GO TO GET-HELP-DONE.
034060 GET-HELP-1.
034080     READ QPTEXT INTO QUERY-TEXT AT END GO TO GET-HELP-DONE.
034100     IF QUERY-MARK NOT EQUAL TO '**'
034120        GO TO GET-HELP-1.
034140     IF HELP-NME-7 NOT EQUAL TO FOUND6-WORD-7
034160        GO TO GET-HELP-1.
034180 GET-HELP-1A.
034200     READ QPTEXT INTO QUERY-TEXT AT END
034220         GO TO GET-HELP-DONE.
034240     IF QUERY-MARK = '**' GO TO GET-HELP-1A.
034260     GO TO GET-HELP-2A.
034280 GET-HELP-2.
034300     READ QPTEXT INTO QUERY-TEXT AT END GO TO GET-HELP-DONE.
034320     IF QUERY-MARK = '**' GO TO GET-HELP-DONE.
034340 GET-HELP-2A.
034260     DISPLAY HELP-TEXT-REC UPON CONSOLE.
034380     GO TO GET-HELP-2.
034400 GET-HELP-DONE.
034420     CLOSE QPTEXT.
034440 GET-HELP-EXIT.
034460     EXIT.
034480
034500
034520*$$$$$$$$$$$$$$$$$$$$$$$
034540 QUERY-PROCESSING SECTION 2.
034560*$$$$$$$$$$$$$$$$$$$$$$$$$
034580*******************************************************
034600*  **** - SUBROUTINES IN NEXT SECTION ALL
034620*  DEAL WITH WRITING, STORING, AND RETRIEVING QUERIES FROM
034640*  THE CONSOLE.
034660********************************************************
034680
034700***********************************************
034720* SUBROUTINE TO TYPE BACK CONTENTS OF CURRENT QUERY TRANS
034740************************************************
034760 GET-CURRENT.
034780     PERFORM LOOK-FOR-QCSTMT.
034800     IF I NOT = -1 MOVE ' %There is no current query'
034820         TO CONSOLE-LINE PERFORM DISPLAYER THRU DISPLAYER-EXIT
034840         GO TO GET-CURRENT-EXIT.
034860     OPEN INPUT QCSTMT.
034880     IF CURRENT-QUERY-NAME NOT = ' '
034920         MOVE '**' TO QUERY-MARK
034940         MOVE CURRENT-QUERY-NAME TO QUERY-NAME
034944         MOVE SPACES TO QUERY-MESSAGE
034948         MOVE QUERY-TEXT TO CONSOLE-LINE
034960         PERFORM DISPLAYER THRU DISPLAYER-EXIT.
034980     IF INFO-LIST-FLAG NOT = 1 CLOSE QCSTMT
035000         GO TO GET-CURRENT-EXIT.
035020 GET-CURRENT-1.
035040     MOVE SPACES TO QUERY-TEXT.
035060     READ QCSTMT INTO QUERY-TEXT AT END CLOSE QCSTMT
035080         GO TO GET-CURRENT-EXIT.
035100     MOVE QUERY-TEXT TO CONSOLE-LINE.
035104     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
035120     GO TO GET-CURRENT-1.
035140 GET-CURRENT-EXIT.
035160     EXIT.
035180
035200**************************************************
035220*  SUB-SUBROUTINE TO FIND A GIVEN QUERY IN STORED FILE.
035240*  ALL QUERIES IN FILE BEFORE SOUGHT ONE ARE COPIED INTO
035260*  THE WORK FILE. AT EXIT THE FILES ARE LEFT OPEN.
035280****************************************************
035300 FIND-QUERY.
035320     PERFORM LOOK-FOR-QPQRYS.
035340     OPEN INPUT QPQRYS.
035360     OPEN OUTPUT QTQRYS.
035380     MOVE 0 TO FOUND-QUERY.
035400 FIND-QUERY-1.
035420     READ QPQRYS INTO QUERY-TEXT AT END GO TO
035440         FIND-QUERY-EXIT.
035460     IF QUERY-MARK NOT = '**' 
035480         WRITE TEMP-REC FROM QUERY-TEXT
035500         GO TO FIND-QUERY-1.
035504     MOVE QUERY-NAME TO NAME-HOLDER.
035508     IF NAME-HOLDER NOT = FOUND6-WORD-20
035512         WRITE TEMP-REC FROM QUERY-TEXT
035516         GO TO FIND-QUERY-1.
035520     MOVE 1 TO FOUND-QUERY.
035540*    *DO NOT GIVE NAME TO CURRENT QUERY UNTIL REALLY HAVE ONE*.
035560     MOVE FOUND6-WORD-20 TO CURRENT-QUERY-NAME.
035580 FIND-QUERY-EXIT.
035600     EXIT.
035620
035640**************************************************
035660*  SUB-SUBROUTINE TO COPY WORK FILE INTO STORED QUERY FILE.
035680*  FILES ARE LEFT OPEN AT THE EXIT TO THIS SUBROUTINE.
035700**************************************************
035720 COPY-TEMP-FILE.
035740     OPEN INPUT QTQRYS.
035760     OPEN OUTPUT QPQRYS.
035780 COPY-TEMP-FILE-1.
035800     READ QTQRYS AT END GO TO COPY-TEMP-FILE-EXIT.
035801     MOVE TEMP-REC TO QPQRYS-LINE.
035802     PERFORM STRIP-QPQRYS-LINE THRU STRIP-QPQRYS-LINE-EXIT.
035804     ENTER MACRO IQWRTS USING QLCX.
035820     WRITE QPQRYS-LINE.
035840     GO TO COPY-TEMP-FILE-1.
035860 COPY-TEMP-FILE-EXIT.
035880     EXIT.
035900
035920*********************************************
035940* SUBROUTINE TO SAVE USER-WRITTEN QUERY UNDER FURNISHED NAME.
035960*********************************************
035980 STORE-QUERY.
036000     IF FOUND-WORD-2 = '  ' 
036020         MOVE CURRENT-QUERY-NAME TO FOUND-WORD
036024         MOVE CURRENT-QUERY-NAME TO FOUND6-WORD.
036040*    *GO TO SUBROUTINE ANYWAY SO CAN CHECK THE NAME*
036060     PERFORM GET-QUERY-NAME THRU GET-QUERY-NAME-EXIT.
036100     PERFORM FIND-QUERY THRU FIND-QUERY-EXIT.
036120     CLOSE QPQRYS QTQRYS.
036140     IF FOUND-QUERY = 1 MOVE ' %' TO QUERY-MARK
036160         MOVE FOUND6-WORD-20 TO QUERY-NAME
036180         MOVE ' is already stored. Please delete it,' 
036184             TO QUERY-MESSAGE
036200         PERFORM BLANK-PEELOUT THRU BLANK-PEELOUT-EXIT
036204         MOVE QUERY-TEXT TO CONSOLE-LINE
036208         PERFORM DISPLAYER THRU DISPLAYER-EXIT
036240         MOVE '   use REPLACE, or store under a new name'
036260         TO CONSOLE-LINE PERFORM DISPLAYER THRU DISPLAYER-EXIT
036280         GO TO STORE-QUERY-EXIT.
036300     PERFORM COPY-TEMP-FILE THRU COPY-TEMP-FILE-EXIT.
036320     CLOSE QTQRYS WITH DELETE.
036340     MOVE SPACES TO TEMP-REC.
036360     MOVE '**' TO TEMP-MARK.
036380     MOVE FOUND6-WORD-20 TO TEMP-NAME.
036381     MOVE TEMP-REC TO QPQRYS-LINE.
036382     PERFORM STRIP-QPQRYS-LINE THRU STRIP-QPQRYS-LINE-EXIT.
036384     ENTER MACRO IQWRTS USING QLCX.
036400     WRITE QPQRYS-LINE.
036420     OPEN INPUT QCSTMT.
036440 STORE-QUERY-3.
036460     READ QCSTMT AT END GO TO STORE-QUERY-4.
036470     IF COLS1-2 = '**' OR '*.' MOVE '* ' TO COLS1-2.
036480     IF COLS1-2 NOT = '++'
036481         MOVE QCSTMT-LINE TO QPQRYS-LINE
036482         PERFORM STRIP-QPQRYS-LINE THRU STRIP-QPQRYS-LINE-EXIT
036484         ENTER MACRO IQWRTS USING QLCX
036500         WRITE QPQRYS-LINE.
036520     GO TO STORE-QUERY-3.
036540 STORE-QUERY-4.
036560     MOVE ' (' TO QUERY-MARK.
036580     MOVE FOUND6-WORD-20 TO QUERY-NAME.
036600     MOVE ' stored)' TO QUERY-MESSAGE.
036620     PERFORM BLANK-PEELOUT THRU BLANK-PEELOUT-EXIT.
036640     MOVE QUERY-TEXT TO CONSOLE-LINE
036650     PERFORM DISPLAYER THRU DISPLAYER-EXIT
036660     CLOSE QCSTMT QPQRYS.
036680 STORE-QUERY-EXIT.
036700     EXIT.
036720
036722 STRIP-QPQRYS-LINE.
036724     SET QLCX TO MAX-QLCX.
036726 STRIP-QPQRYS-LINE-1.
036728     IF QLCX = 1 GO TO STRIP-QPQRYS-LINE-EXIT.
036730     IF QPQRYS-LINE-CHAR (QLCX) = SPACE OR ASCII-NULL
036732         SET QLCX DOWN BY 1
036734         GO TO STRIP-QPQRYS-LINE-1.
036736 STRIP-QPQRYS-LINE-EXIT.    EXIT.
036738 
036740**********************************************
036760*  SUBROUTINE TO DELETE A QUERY WHICH HAD BEEN STORED.
036780*  NOTE - DOES NOT AFFECT CURRENT QUERY*.
036800***********************************************
036820 DELETE-QUERY.
036830     MOVE CURRENT-QUERY-NAME TO WORD-HOLDER.
036840     IF FOUND-WORD-1 = ' '
036860         MOVE CURRENT-QUERY-NAME TO FOUND-WORD FOUND6-WORD.
036880     IF FOUND-WORD-1 = ' '
036900         PERFORM GET-QUERY-NAME THRU GET-QUERY-NAME-EXIT.
036920     PERFORM FIND-QUERY THRU FIND-QUERY-EXIT.
036940     IF FOUND-QUERY = 0 MOVE ' %' TO QUERY-MARK
036960         MOVE FOUND6-WORD-20 TO QUERY-NAME
036980         MOVE ' not found to delete' TO QUERY-MESSAGE
037000         PERFORM BLANK-PEELOUT THRU BLANK-PEELOUT-EXIT
037004         MOVE QUERY-TEXT TO CONSOLE-LINE
037020         PERFORM DISPLAYER THRU DISPLAYER-EXIT
037040         GO TO DELETE-QUERY-DONE.
037060 DELETE-QUERY-1.
037080     READ QPQRYS INTO QUERY-TEXT AT END GO TO
037100         DELETE-QUERY-COPY.
037120     IF QUERY-MARK NOT = '**' GO TO DELETE-QUERY-1.
037140     WRITE TEMP-REC FROM QUERY-TEXT.
037160 DELETE-QUERY-2.
037180     READ QPQRYS INTO QUERY-TEXT AT END GO TO
037200         DELETE-QUERY-COPY.
037220     WRITE TEMP-REC FROM QUERY-TEXT.
037240     GO TO DELETE-QUERY-2.
037260 DELETE-QUERY-COPY.
037280     CLOSE QPQRYS QTQRYS.
037300     PERFORM COPY-TEMP-FILE THRU COPY-TEMP-FILE-EXIT.
037320     MOVE FOUND6-WORD-20 TO QUERY-NAME.
037340     MOVE ' (' TO QUERY-MARK.
037360     MOVE ' deleted)' TO QUERY-MESSAGE.
037380     PERFORM BLANK-PEELOUT THRU BLANK-PEELOUT-EXIT.
037390     MOVE QUERY-TEXT TO CONSOLE-LINE
037400     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
037420 DELETE-QUERY-DONE.
037440     CLOSE QPQRYS.
037460     CLOSE QTQRYS.
037470     MOVE WORD-HOLDER TO CURRENT-QUERY-NAME.
037480 DELETE-QUERY-EXIT.
037500     EXIT.
037520
037540*********************************************************
037560* SUBROUTINE TO REPLACE QUERY IN STORED QUERY FILE
037580*********************************************************
037600 REPLACE-QUERY.
037620     IF FOUND-WORD-1 = ' ' 
037624         MOVE CURRENT-QUERY-NAME TO FOUND-WORD FOUND6-WORD.
037640     PERFORM GET-QUERY-NAME THRU GET-QUERY-NAME-EXIT.
037660     PERFORM FIND-QUERY THRU FIND-QUERY-EXIT.
037680     IF FOUND-QUERY NOT = 1 MOVE ' %' TO QUERY-MARK
037700         MOVE FOUND6-WORD-20 TO QUERY-NAME
037720         MOVE ' not found to replace' TO QUERY-MESSAGE
037740         PERFORM BLANK-PEELOUT THRU BLANK-PEELOUT-EXIT
037750         MOVE QUERY-TEXT TO CONSOLE-LINE
037760         PERFORM DISPLAYER THRU DISPLAYER-EXIT
037780         GO TO REPLACE-QUERY-DONE.
037800     OPEN INPUT QCSTMT.
037820     MOVE SPACES TO TEMP-REC.
037840     MOVE '**' TO TEMP-MARK.
037860     MOVE FOUND6-WORD-20 TO TEMP-NAME.
037880     WRITE TEMP-REC.
037900 REPLACE-QUERY-1.
037904*    *WRITE CURRENT QUERY TO STORED QUERY FILE*.
037920     READ QCSTMT AT END CLOSE QCSTMT GO TO REPLACE-QUERY-2.
037930     IF COLS1-2 = '**' OR '*.' MOVE '* ' TO COLS1-2.
037940     IF COLS1-2 NOT = '++'
037960         WRITE TEMP-REC FROM QCSTMT-LINE.
037980     GO TO REPLACE-QUERY-1.
038000 REPLACE-QUERY-2.
038004*    *SPACE OVER PRIOR VERSION OF QUERY BEING REPLACED*.
038020     IF FOUND-QUERY NOT = 1 GO TO REPLACE-QUERY-COPY.
038040     READ QPQRYS INTO QUERY-TEXT AT END GO TO
038060         REPLACE-QUERY-COPY.
038080     IF QUERY-MARK NOT = '**' GO TO REPLACE-QUERY-2.
038100     WRITE TEMP-REC FROM QUERY-TEXT.
038120 REPLACE-QUERY-3.
038124*    *COPY OUT REST OF STORED QUERIES*.
038140     READ QPQRYS INTO QUERY-TEXT AT END GO TO REPLACE-QUERY-COPY.
038160     WRITE TEMP-REC FROM QUERY-TEXT.
038180     GO TO REPLACE-QUERY-3.
038200 REPLACE-QUERY-COPY.
038220     CLOSE QPQRYS QTQRYS.
038240     PERFORM COPY-TEMP-FILE THRU COPY-TEMP-FILE-EXIT.
038260     MOVE ' (' TO QUERY-MARK.
038280     MOVE FOUND6-WORD-20 TO QUERY-NAME.
038300     MOVE ' replaced)' TO QUERY-MESSAGE.
038320     PERFORM BLANK-PEELOUT THRU BLANK-PEELOUT-EXIT.
038330     MOVE QUERY-TEXT TO CONSOLE-LINE.
038340     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
038360 REPLACE-QUERY-DONE.
038380     CLOSE QPQRYS.
038400     CLOSE QTQRYS WITH DELETE.
038420 REPLACE-QUERY-EXIT.
038440     EXIT.
038460
038480*****************************************************
038500* SUBROUTINE TO GET A USER-STORED QUERY AND DISPLAY
038520* IT TO CONSOLE IF INFO-LIST-FLAG IS ON.
038540*****************************************************
038560 PULL-QUERY.
038580     PERFORM LOOK-FOR-QPQRYS.
038600     MOVE 1 TO FOUND-QUERY.
038620     OPEN INPUT QPQRYS.
038640 PULL-QUERY-1.
038660     READ QPQRYS INTO QUERY-TEXT AT END
038680         GO TO PULL-QUERY-LOST.
038700     IF QUERY-MARK NOT = '**' GO TO PULL-QUERY-1.
038710     MOVE QUERY-NAME TO NAME-HOLDER.
038720     IF NAME-HOLDER NOT = FOUND6-WORD-20 GO TO PULL-QUERY-1.
038740     MOVE FOUND6-WORD-20 TO CURRENT-QUERY-NAME.
038750     MOVE QUERY-TEXT TO CONSOLE-LINE.
038760     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
038780     OPEN OUTPUT QCSTMT.
038800 PULL-QUERY-2.
038820     READ QPQRYS INTO QUERY-TEXT AT END
038840         GO TO PULL-QUERY-CLOSE.
038860     IF QUERY-MARK = '**' GO TO PULL-QUERY-CLOSE.
038864     PERFORM TRAILING-NULLS THRU TRAILING-NULLS-EXIT.
038880     WRITE QCSTMT-LINE FROM QUERY-TEXT.
038900     IF INFO-LIST-FLAG = 1 PERFORM DISPLAY-QUERY.
038920     GO TO PULL-QUERY-2.
038940 PULL-QUERY-LOST.
038960     MOVE 0 TO FOUND-QUERY.
038980     MOVE ' %' TO QUERY-MARK.
039000     MOVE FOUND6-WORD TO QUERY-NAME.
039020     MOVE ' not found' TO QUERY-MESSAGE.
039040     PERFORM BLANK-PEELOUT THRU BLANK-PEELOUT-EXIT.
039050     MOVE QUERY-TEXT TO CONSOLE-LINE.
039060     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
039080     CLOSE QPQRYS.
039100     GO TO PULL-QUERY-EXIT.
039120 PULL-QUERY-CLOSE.
039140     CLOSE QPQRYS QCSTMT.
039160 PULL-QUERY-EXIT.
039180     EXIT.
039182
039184******************************************************************
039186* SUBROUTINE TO TURN TRAILING SPACES INTO NULLS IN QUERY-TEXT.
039188******************************************************************
039190 TRAILING-NULLS.
039192     SET PRX TO MAX-PRX.
039194 TRAILING-NULLS1.
039196     IF PRINT-CHAR (PRX) NOT = ASCII-NULL AND NOT = SPACE
039198         GO TO TRAILING-NULLS-EXIT.
039200     MOVE ASCII-NULL TO PRINT-CHAR (PRX).
039202     IF PRX NOT < 2 SET PRX DOWN BY 1 GO TO TRAILING-NULLS1.
039204 TRAILING-NULLS-EXIT.
039204     EXIT.
039206
039220*$$$$$$$$$$$$$$$$$$$$$$$$$
039240 TYPING SECTION 3.
039260*$$$$$$$$$$$$$$$$$$$$$$$$$
039280******************************************************
039300* SUBROUTINE TO BRING REPORT PRODUCED BY EXECUTION
039320* BACK TO TERMINAL. IT COMPACTS THE HEADING LINE AND
039340* TRUNCATES THE REST OF THE LINES. THE ORIGINAL PRINT FILE
039360* IS LEFT IN THE QUEUE TO BE PRINTED IF THE USER DESIRES.
039380******************************************************
039400 TYPER.
039420     PERFORM LOOK-FOR-QLEXEC.
039440     OPEN INPUT QLEXEC.
039460     MOVE 0 TO IN-HEADING-FLAG.
039480 TYPER-1.
039500     MOVE SPACES TO SHORT-LINE.
039520     READ QLEXEC INTO REPORT-LINE AT END GO TO TYPER-DONE.
039540     IF SLASH-1 = '-' AND SLASH-2 = '-'
039560         AND PAGE-WORD = 'PAGE' GO TO TYPER-2.
039580     IF IN-HEADING-FLAG = 1 AND
039600         REPORT-LINE NOT = SPACES GO TO TYPER-2.
039620     MOVE 0 TO IN-HEADING-FLAG.
039640     GO TO TYPER-3.
039660 TYPER-2.
039680*   *CENTER HEADING LINES*.
039700     MOVE REPORT-DATE TO DATE-AREA.
039720     MOVE REPORT-HEADING TO HEAD-AREA.
039740     MOVE REPORT-PAGE TO PAGE-AREA.
039760     MOVE SPACE TO SPACE-1 SPACE-2.
039780     MOVE 1 TO IN-HEADING-FLAG.
039800     GO TO TYPER-4.
039820 TYPER-3.
039840*   *DISPLAY A DATA LINE; TRUNCATE IF TOO LONG*.
039860     MOVE 0 TO IN-HEADING-FLAG.
039880     MOVE SHORT-LINE TO SHORT-LINE-OUT.
039900 TYPER-4.
039920     MOVE SHORT-LINE-OUT TO CONSOLE-LINE.
039930     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
039940     GO TO TYPER-1.
039960 TYPER-DONE.
039980     CLOSE QLEXEC.
040000 TYPER-EXIT.
040020     EXIT.
040040
040060
040080*$$$$$$$$$$$$$$$$$$$$$$$$$
040100 DICT-DISPLAYING SECTION 4.
040120*$$$$$$$$$$$$$$$$$$$$$$$$$
040140
040160*********************************************
040180* SUBROUTINE TO LIST NAMES OF DICTIONARIES CURRENTLY DEFINED .
040200*********************************************
040220 LIST-DICTS.
040240     MOVE SPACE TO DEVICER.
040260     MOVE 0 TO PROJ USER.
040280     MOVE 1 TO ALL-FLAG.
040300     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
040320     IF FOUND-WORD-6 = UNIVERSAL-PASSWORD
040340         MOVE 99 TO CURRENT-PW-REF
040360         PERFORM FIND-WORD THRU FIND-WORD-EXIT
040380         ELSE MOVE 0 TO CURRENT-PW-REF.
040400     MOVE ' Dictionaries in your directory:'
040420         TO CONSOLE-LINE.
040440 LIST-DICTS-LOOP.
040460     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
040480     PERFORM SPACER.
040500     ENTER MACRO IQLOOK USING DEVICER QPDICTSEQ PROJ USER I.
040520     IF I NOT = -1 MOVE ' (none)' TO CONSOLE-LINE
040540         PERFORM DISPLAYER THRU DISPLAYER-EXIT 
040544         GO TO LIST-DICTS-EXIT.
040560     OPEN INPUT QPDICT.
040580     DISPLAY TY-DICT-HEAD1 UPON CONSOLE.
040600     DISPLAY TY-DICT-HEAD2 UPON CONSOLE.
040620     DISPLAY TY-DICT-HEAD3 UPON CONSOLE
040640     PERFORM SPACER.
040660 LIST-DICTS-1.
040680     READ QPDICT AT END CLOSE QPDICT
040700         GO TO LIST-DICTS-CLOSE.
040720     IF DICT-IDNT NOT = 'FD' GO TO LIST-DICTS-1.
040740     PERFORM DICT-DISPLAYER THRU DICT-DISPLAYER-EXIT.
040760     GO TO LIST-DICTS-1.
040780 LIST-DICTS-CLOSE.
040800     MOVE ' (End list of dictionaries)' TO CONSOLE-LINE.
040820     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
040840 LIST-DICTS-EXIT.
040860     EXIT.
040880
040900*********************************************************
040920* SUBROUTINE TO LIST ONE FD ENTRY FROM DICTIONARY
040940*********************************************************
040960 DICT-DISPLAYER.
040980     MOVE DICT-REC TO DICT-WS.
041000     MOVE SPACES TO FILE-NAME-MSG.
041020     MOVE DF-NAME TO FILE-NAME-SLOT.
041040     MOVE DF-DIRECT TO DIRECT-SLOT.
041060     IF DF-NAME-EXT = SPACES AND DF-DIR-EXT = SPACES
041080         NEXT SENTENCE ELSE
041100         DISPLAY FILE-NAME-MSG UPON CONSOLE
041120         MOVE SPACES TO FILE-DATA-MSG.
041140     MOVE DF-FILETYPE TO I.
041160     MOVE TYPE-LIST (I) TO FILE-TYPE-SLOT.
041180     IF I NOT = 6 AND I NOT = 7 NEXT SENTENCE
041200         ELSE IF DF-KEYPOS NOT = 0
041220         MOVE 'IS' TO FILE-ORG-SLOT.
041240     MOVE 1 TO DICT-LOCKED-FLAG.
041260     IF CURRENT-PW-REF LESS THAN DF-PROT-READ
041280         MOVE '**' TO RP-SLOT-X
041300         ELSE MOVE DF-PROT-READ TO RP-SLOT
041320               MOVE 0 TO DICT-LOCKED-FLAG.
041340     IF CURRENT-PW-REF LESS THAN DF-PROT-COPY
041360         MOVE '**' TO CP-SLOT-X
041380         ELSE MOVE DF-PROT-COPY TO CP-SLOT
041400              MOVE 0 TO DICT-LOCKED-FLAG.
041420     IF CURRENT-PW-REF LESS THAN DF-PROT-REWRITE
041440         MOVE '**' TO RWP-SLOT-X
041460         ELSE MOVE DF-PROT-REWRITE TO RWP-SLOT
041480              MOVE 0 TO DICT-LOCKED-FLAG.
041500     IF DICT-LOCKED-FLAG = 1 GO TO  DICT-DISPLAYER-1.
041520     MOVE DF-INLABEL TO FILE-IN-SLOT.
041540     MOVE DF-RECSIZE TO REC-SIZE-SLOT.
041560*    *IF BLKFACT > 0 HAVE OLD BLOCK LENGTH; IF < 0 HAVE
041580*    *  NEW BLOCKING FACTOR; CONVERT EITHER TO BLOCK FACTOR*.
041600     IF DF-BLKFACT LESS THAN 0
041620         SUBTRACT DF-BLKFACT FROM 0 GIVING WORK-1
041640         ELSE DIVIDE DF-RECSIZE INTO DF-BLKFACT GIVING WORK-1.
041660     MOVE WORK-1 TO BLOCK-FACT-SLOT.
041680     MOVE DF-KEYPOS  TO KEY-LOC-SLOT.
041700     MOVE DF-KEYLEN  TO KEY-LEN-SLOT.
041720     MOVE SPACES     TO KEY-TYPE-SLOT KEY-SIGN-SLOT.
041740     IF DF-KEYPOS = 0 GO TO DICT-DISPLAYER-1.
041760     MOVE DF-KEYTYPE TO KEY-TYPE-SLOT.
041780     IF DF-KEYTYPE = 0 MOVE 'A' TO KEY-TYPE-SLOT.
041800     IF DF-KEYTYPE = 1 MOVE 'N' TO KEY-TYPE-SLOT.
041820     IF DF-KEYTYPE = 2 MOVE 'N' TO KEY-TYPE-SLOT.
041840     MOVE DF-KEYSIGN TO KEY-SIGN-SLOT.
041860     IF DF-KEYSIGN = 0 MOVE 'S' TO KEY-SIGN-SLOT.
041880     IF DF-KEYSIGN = 1 MOVE 'U' TO KEY-SIGN-SLOT.
041900 DICT-DISPLAYER-1.
041910     MOVE FILE-DATA-MSG TO CONSOLE-LINE.
041920     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
041940 DICT-DISPLAYER-EXIT.
041960     EXIT.
041980
042000********************************************************
042020* SUBROUTINE TO LIST ITEMS IN A SPECIFIC DICTIONARY.
042040********************************************************
042060 LIST-ITEMS.
042080     PERFORM LOOK-FOR-QPDICT.
042100     OPEN INPUT QPDICT.
042120     PERFORM SPACER.
042140     MOVE SPACES TO CURRENT-PW.
042160     MOVE 1 TO DICT-LOCK.
042180     MOVE 0 TO CMND.
042200     MOVE FOUND6-WORD-30 TO WORD6-HOLDER.
042220 LIST-ITEMS-2.
042240     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
042260     IF FOUND-WORD-3 = SPACES GO TO LIST-ITEMS-3.
042280     IF CURRENT-PW = SPACES
042300         MOVE FOUND6-WORD-6 TO CURRENT-PW.
042320     GO TO LIST-ITEMS-2.
042340 LIST-ITEMS-3.
042360     READ QPDICT INTO DICT-WS AT END GO TO LIST-ITEMS-LOST.
042380     IF DF-IDNT NOT = 'FD' GO TO LIST-ITEMS-3.
042384     MOVE DF-NAME TO FOUND6-WORD-30.
042400     IF FOUND6-WORD-30 NOT = WORD6-HOLDER GO TO LIST-ITEMS-3.
042420     IF CURRENT-PW = UNIVERSAL-PASSWORD
042440         MOVE 99 TO CURRENT-PW-REF
042460         GO TO LIST-ITEMS-PW5.
042480     MOVE 0 TO CURRENT-PW-REF.
042500 LIST-ITEMS-PW1.
042520     READ QPDICT INTO DICT-WS AT END
042540         GO TO LIST-ITEMS-PW3.
042560     IF DF-IDNT = 'FD' GO TO LIST-ITEMS-PW1.
042580 LIST-ITEMS-PW2.
042600     IF DF-IDNT NOT = 'PD' GO TO LIST-ITEMS-PW3.
042620     PERFORM UNSCRAMBLE-PW THRU UNSCRAMBLE-PW-EXIT.
042640     IF DP-TEXT  = CURRENT-PW
042660         MOVE DP-PROT-NO TO CURRENT-PW-REF
042680         GO TO LIST-ITEMS-PW3.
042700     READ QPDICT INTO DICT-WS AT END GO TO LIST-ITEMS-LOST.
042720     GO TO LIST-ITEMS-PW2.
042740 LIST-ITEMS-PW3.
042760     CLOSE QPDICT.
042780     OPEN INPUT QPDICT.
042800 LIST-ITEMS-PW4.
042820     READ QPDICT INTO DICT-WS AT END
042840         GO TO LIST-ITEMS-LOST.
042860     IF DF-IDNT NOT = 'FD' GO TO LIST-ITEMS-PW4.
042870     MOVE DF-NAME TO FOUND6-WORD-30.
042880     IF FOUND6-WORD-30 NOT = WORD6-HOLDER GO TO LIST-ITEMS-PW4.
042900     MOVE DF-PROT-READ TO CURRENT-RD-PW-REF.
042920 LIST-ITEMS-PW5.
042940     DISPLAY TY-DICT-HEAD1 UPON CONSOLE.
042960     DISPLAY TY-DICT-HEAD2 UPON CONSOLE.
042980     DISPLAY TY-DICT-HEAD3 UPON CONSOLE.
043000     PERFORM SPACER.
043020 LIST-ITEMS-4.
043040     PERFORM DICT-DISPLAYER THRU DICT-DISPLAYER-EXIT.
043060     READ QPDICT INTO DICT-WS AT END GO TO LIST-ITEMS-CLOSE.
043080     IF DF-IDNT = 'FD' GO TO LIST-ITEMS-4.
043100     PERFORM SPACER.
043120     MOVE TY-ITEM-HEAD1 TO CONSOLE-LINE. 
043130     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
043140     MOVE TY-ITEM-HEAD2 TO CONSOLE-LINE. 
043150     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
043160     MOVE TY-ITEM-HEAD3 TO CONSOLE-LINE. 
043170     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
043180     MOVE 1 TO I.
043200     PERFORM SPACER.
043220     GO TO LIST-ITEMS-6.
043240 LIST-ITEMS-5.
043260     READ QPDICT INTO DICT-WS AT END GO TO LIST-ITEMS-CLOSE.
043280 LIST-ITEMS-6.
043300     MOVE SPACES TO FILE-NAME-MSG.
043320     IF DF-IDNT = 'FD' GO TO LIST-ITEMS-CLOSE.
043340     MOVE DF-IDNT TO TY-DD-ID1.
043360     IF DF-IDNT = 'PD' GO TO LIST-ITEMS-PD.
043380     IF DF-IDNT = 'DD' OR 'KD' GO TO LIST-ITEMS-DD.
043400     IF DF-IDNT = 'CD' GO TO LIST-ITEMS-CD.
043420     GO TO LIST-ITEMS-RD.
043440*    *LOGIC BELOW CHECKS FOR UNLOCKING PASSWORDS*
043460 LIST-ITEMS-PD.
043480     MOVE 'NOT UNLOCKED' TO  TY-PASSWORD.
043500     IF CURRENT-PW-REF LESS THAN DP-PROT-NO
043520         GO TO LIST-ITEMS-CMN.
043540     PERFORM UNSCRAMBLE-PW THRU UNSCRAMBLE-PW-EXIT.
043560     MOVE DP-TEXT TO TY-PASSWORD.
043580     MOVE DP-PROT-NO TO TY-PROTNO.
043600     GO TO LIST-ITEMS-CMN.
043620*    *LOGIC BELOW IS FOR RD, AD, AND SD SINCE SAME FORMAT*
043640 LIST-ITEMS-RD.
043660     DISPLAY ' ' UPON CONSOLE.
043680     MOVE DR-NAME TO TY-RD-NAME.
043700     MOVE DR-ORIGIN TO TY-RD-ORIGIN.
043720     MOVE DR-LENGTH TO TY-RD-LENGTH.
043740     MOVE DR-TYPE TO TY-RD-TYPE.
043760     MOVE DR-TEXT TO TY-RD-TEXT.
043780     GO TO LIST-ITEMS-CMN.
043800 LIST-ITEMS-CD.
043820     MOVE DC-NO TO TY-CD-NO.
043840     MOVE DC-TXT-SHRT TO TY-CD-TEXT.
043860     GO TO LIST-ITEMS-CMN.
043880 LIST-ITEMS-DD.
043900     MOVE DD-NAME TO TY-NAME.
043920     IF DD-NAME-EXT NOT = SPACES
043940         DISPLAY TY-NAME-MSG UPON CONSOLE
043960         MOVE SPACES TO TY-ITEM-MSG.
043980     MOVE DD-TITLE1 TO TY-TITLE1.
044000     MOVE DD-TITLE2 TO TY-TITLE2.
044020     IF DD-TYPE = 1 MOVE 'A' TO TY-TYPE.
044040     IF DD-TYPE = 2 MOVE 'N' TO TY-TYPE.
044060     IF DD-TYPE = 3 MOVE 'P' TO TY-TYPE.
044080     IF DD-TYPE = 6 MOVE 'B' TO TY-TYPE.
044100     MOVE DD-SCALE   TO TY-SCALE.
044120     MOVE DD-PICT    TO TY-PICT.
044140     IF CURRENT-PW-REF LESS THAN DD-PROT-NO
044160         MOVE '**' TO TY-PROT-X
044180         GO TO LIST-ITEMS-CMN.
044200     IF CURRENT-PW-REF LESS THAN CURRENT-RD-PW-REF
044220        GO TO LIST-ITEMS-CMN.
044240     MOVE DD-FCHAR   TO TY-PEEL.
044260     MOVE TY-PEEL    TO TY-FCHAR.
044280     IF DD-FCHAR = 0 MOVE 'DBMS' TO TY-FCHAR.
044300     MOVE DD-NCHARS  TO TY-PEEL.
044320     MOVE TY-PEEL    TO TY-NCHARS.
044340     IF DD-NOUPD = 'N' MOVE '*' TO TY-NOUPD.
044360     MOVE DD-PROT-NO TO TY-PROT.
044380     IF PICT-OFLOW = ' ' AND TY-SCAN = ' '
044400         GO TO LIST-ITEMS-DD1.
044420     MOVE TY-ITEM-MSG TO CONSOLE-LINE.
044440     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
044460     IF DD-NRPTS-X = '00' OR '  '
044480         GO TO LIST-ITEMS-CMN2.
044500     MOVE SPACES TO TY-ITEM-MSG.
044520 LIST-ITEMS-DD1.
044540     IF DD-NRPTS-X = '00' OR '  ' MOVE SPACES TO TY-SCAN
044560         ELSE MOVE DD-SCAN TO TY-SCAN.
044580 LIST-ITEMS-CMN.
044600     MOVE TY-ITEM-MSG TO CONSOLE-LINE. 
044610     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
044620 LIST-ITEMS-CMN2.
044640     ADD 1 TO I.
044660     IF I NOT = MAX-DICT-LIST GO TO LIST-ITEMS-5.
044680     IF CMND = 0 GO TO LIST-ITEMS-5.
044700     PERFORM SPACER.
044720     MOVE  ' **More? - YES, NO: ' TO CONSOLE-LINE.
044740     PERFORM DISPLAYER THRU DISPLAYER-EXIT. PERFORM ASKER.
044760     PERFORM SPACER.
044780     IF USER-ANS-1 = 'Y' MOVE 1 TO I GO TO LIST-ITEMS-5.
044800     GO TO LIST-ITEMS-CLOSE.
044820 LIST-ITEMS-LOST.
044840     MOVE ' %' TO QUERY-MARK.
044860     MOVE WORD-HOLDER TO QUERY-NAME.
044880     MOVE ' dictionary not found' TO QUERY-MESSAGE.
044900     PERFORM BLANK-PEELOUT THRU BLANK-PEELOUT-EXIT.
044920     DISPLAY ' ' QUERY-TEXT UPON CONSOLE.
044940 LIST-ITEMS-CLOSE.
044960     PERFORM SPACER.
044980     MOVE ' (End list of items)'  TO CONSOLE-LINE.
045000     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
045020     CLOSE QPDICT.
045040 LIST-ITEMS-EXIT.
045060     EXIT.
045080
045100
045120*$$$$$$$$$$$$$$$$$$$$$$$$$
045140 DICT-DEFINING SECTION 5.
045160*$$$$$$$$$$$$$$$$$$$$$$$$$
045180
045200************************************************************
045220* SUBROUTINE TO BUILD DICTIONARIES FROM CONSOLE-LINE.
045240************************************************************
045260 DICT-DEFINER.
045280     OPEN OUTPUT QCDICT.
045300
045320 DEF-CNV.
045340     MOVE 1 TO PX  PX-IN  K.
045360     IF CONV-MODE-FLAG = 0
045380         PERFORM ASKER.
045400     DISPLAY ' ' UPON CONSOLE.
045420     MOVE 0 TO NEXT-FLAG.
045440     GO TO DEF-ASK.
045460 DEF-CNV1.
045480     IF FOUND6-WORD-6 = 'SCRUB ' GO TO DICT-DEFINER-DONE.
045500     IF FOUND6-WORD-6 = 'END '   GO TO DICT-DEFINER-DONE.
045520     IF FIRST-DEF-FLAG = 1 AND FOUND6-WORD-3 NOT = 'FD'
045540         DISPLAY ' %First def was not FD; reenter'
045560         UPON CONSOLE
045580         GO TO DEF-CNV.
045600     MOVE SPACES TO FD-TRAN.
045620     MOVE 0 TO FIRST-DEF-FLAG.
045640     IF FOUND6-WORD-4 = 'END '
045660         GO TO DICT-DEFINER-DONE.
045680     MOVE FOUND6-WORD-2 TO CF-IDNT.
045700     IF CF-IDNT = 'FD' OR 'DD' OR 'KD' OR 'CD' OR 'PD' OR 'RD'
045720         OR 'SD' OR 'AD' NEXT SENTENCE ELSE
045740             GO TO DEF-BADENTRY.
045760 DEF-CNV2.
045780     IF CF-IDNT = 'FD ' GO TO DC-FD.
045800     GO TO DEF-ASK.
045820 DEF-CNV3.
045840     MOVE FOUND6-WORD-1 TO CF-ACT.
045860     IF CF-ACT = 'A' OR 'D' OR 'C' NEXT SENTENCE ELSE
045880         DISPLAY DD-MSG-1 UPON CONSOLE
045900         GO TO DEF-ASK-BACK.
045920     IF CF-IDNT = 'DD' OR 'KD' GO TO DC-DD.
045940     IF CF-IDNT = 'PD' GO TO DC-PD.
045960     IF CF-IDNT = 'RD' GO TO DC-RD.
045980     IF CF-IDNT = 'AD' GO TO DC-AD.
046000     IF CF-IDNT = 'SD' GO TO DC-SD.
046020     IF CF-IDNT = 'CD' GO TO DC-CD.
046040 DEF-BADENTRY.
046060     DISPLAY ' %Illegal entry code - rejected'
046080         UPON CONSOLE. GO TO DEF-CNV.
046100
046120 DC-FD.
046140*   *PROCESS FD TRANSACTION; CHECK EACH FIELD AS ENTERED*.
046160     MOVE 4 TO  PX  PX-IN.
046180     GO TO DEF-ASK.
046200 DC-FD1.
046220     MOVE FOUND6-WORD-1 TO CF-ACT.
046240     IF CF-ACT = 'A' AND AUTO-SW = 1 MOVE 2 TO AUTO-SW
046260                     MOVE 1 TO FIRST-POS-CTR.
046280     IF CF-ACT NOT = 'A' AND AUTO-SW > 1 MOVE 1 TO AUTO-SW.
046300     IF CF-ACT = 'A' OR 'C' OR 'D' OR 'S' OR 'P' OR 'N'
046320         NEXT SENTENCE ELSE DISPLAY FD-MSG-14 UPON CONSOLE
046325         MOVE SPACE TO CF-ACT
046340         GO TO DEF-ASK-BACK.
046360     IF CF-ACT NOT = 'S' GO TO DEF-ASK.
046380     DISPLAY ' ' UPON CONSOLE. DISPLAY
046400         ' %The "S" action code will destroy all current'
046420         UPON CONSOLE. DISPLAY
046440         ' dictionaries in your directory. Do you really want '
046460         UPON CONSOLE. DISPLAY
046480         ' to do this? If so, re-enter S;  If not, enter'
046500         UPON CONSOLE. DISPLAY
046520         ' the action code you really want'
046540         UPON CONSOLE.
046560     DISPLAY '*' UPON CONSOLE WITH NO ADVANCING.
046580     ACCEPT USER-ANS FROM TTY.
046584     MOVE USER-ANS-1 TO FOUND6-WORD-1.
046600     MOVE FOUND6-WORD-1 TO CF-ACT.
046620     GO TO DEF-ASK.
046640 DC-FD2.
046660     MOVE FOUND6-WORD-30 TO CF-NAME.
046680     IF CF-ACT = 'D' GO TO DEF-ASK.
046700     IF CF-ACT NOT = 'P' OR CF-NAME NOT = ' '
046720         MOVE 0 TO NAME-ERR-FLAG
046740         PERFORM CHECK-NAME THRU CHECK-NAME-EXIT.
046760     IF NAME-ERR-FLAG NOT = 1 GO TO DEF-ASK.
046765     MOVE SPACES TO CF-NAME.
046780     MOVE 0 TO NEXT-FLAG.
046800     GO TO DEF-ASK-BACK.
046820 DC-FD3.
046840     MOVE FOUND6-WORD-6 TO CF-PASSWORD.
046860     IF CF-ACT = 'D' OR 'P' OR 'N' GO TO TRAN-DONE.
046880     GO TO DEF-ASK.
046900 DC-FD4.
046920     IF FOUND6-WORD-9 = ' ' AND CF-ACT = 'C' GO TO DEF-ASK.
046940     MOVE FOUND6-WORD-9 TO CF-INLABEL.
046960*   *CHECK FILE NAME*.
046980     EXAMINE FOUND6-WORD-18 TALLYING ALL '.'.
047000     IF TALLY = 1 GO TO DC-FD4B.
047020     IF TALLY NOT = 0 GO TO DC-FD4A.
047040*   *NO IMBEDDED DECIMAL - CHECK LENGTH*.
047060     IF FOUND6-CHAR (9) = SPACE OR
047080        FOUND6-CHAR (10) NOT = SPACE GO TO DC-FD4A.
047100     MOVE SPACES TO FOUND6-WORD-9.
047120     IF FOUND6-WORD = SPACE GO TO DEF-ASK.
047140 DC-FD4A.
047160*   *COMPLAIN ABOUT FILE NAME FORMAT ERROR*.
047180     DISPLAY FD-MSG-17 UPON CONSOLE.
047185     MOVE SPACES TO CF-INLABEL.
047200     GO TO DEF-ASK-BACK.
047220 DC-FD4B.
047240*   *PROCESS AND ADJUST FILE NAME WITH DECIMAL IN IT*.
047280     EXAMINE FOUND6-WORD TALLYING UNTIL FIRST '.'.
047300     MOVE TALLY TO I.
047320     MOVE SPACES TO WORK6X.
047340     IF I GREATER THAN 6 GO TO DC-FD4A.
047360     ENTER MACRO IQSX66 USING I FOUND6-WORD CONST1
047380         WORK6X CONST1.
047400     ADD 2 TO I.
047420     ENTER MACRO IQSX66 USING CONST3 FOUND6-WORD I
047440         WORK6X CONST7.
047460     MOVE WORK6X TO CF-INLABEL.
047480     GO TO DEF-ASK.
047500 DC-FD5.
047520*    *IF <> LEFT OFF DIRECTORY PUT THEM IN*
047540     IF FOUND-WORD-1 = ' ' GO TO DC-FD5A.
047560     IF FOUND-WORD-19 = ALL '*' GO TO DC-FD5A.
047580     IF FOUND-WORD-1 NOT = '<'
047600         MOVE FOUND-WORD-19 TO FOUND6-R19
047620         MOVE '<' TO FOUND6-L1
047640         MOVE FOUND6-WORD TO FOUND-WORD-19.
047660     EXAMINE FOUND-WORD-19 TALLYING ALL '>'.
047680     IF TALLY NOT = 0 GO TO DC-FD5A.
047700     EXAMINE FOUND-WORD-19 REPLACING FIRST ' ' BY '>'.
047720 DC-FD5A.
047740     MOVE FOUND-WORD-19 TO CF-DIRECT.
047760     GO TO DEF-ASK.
047780 DC-FD6.
047800     IF FOUND-WORD-4 = ' ' AND CF-ACT = 'C' GO TO DEF-ASK.
047820     MOVE 0 TO JRIGHT-1.
047840     IF FOUND6-WORD-6 = 'TAPE  ' MOVE '1' TO JRIGHT-1.
047860     IF FOUND6-WORD-6 = 'DISK6 ' MOVE '6' TO JRIGHT-1.
047880     IF FOUND6-WORD-6 = 'DISK7 ' MOVE '7' TO JRIGHT-1.
047900     IF FOUND6-WORD-6 = 'DBMS  ' MOVE '8' TO JRIGHT-1.
047940     IF JRIGHT-1 = 0 OR
047960         JRIGHT-1 NOT NUMERIC
047980         DISPLAY FD-MSG-5 UPON CONSOLE
048000         GO TO DEF-ASK-BACK.
048010     MOVE JRIGHT-1 TO CF-FILETYPE-X.
048020     IF CF-FILETYPE  = 1 OR 6 OR 7 OR 8 NEXT SENTENCE
048040         ELSE DISPLAY FD-MSG-5 UPON CONSOLE GO TO DEF-ASK-BACK.
048060     IF JRIGHT-1 = 7 MOVE 1 TO ASCII-SW
048080             ELSE MOVE 0 TO ASCII-SW.
048100     GO TO DEF-ASK.
048120 DC-FD7.
048140     IF FOUND-WORD-4 = ' ' AND CF-ACT = 'C' GO TO DEF-ASK.
048180     IF JRIGHT-4 NOT NUMERIC GO TO DEF-ASK-NONUM.
048190     MOVE JRIGHT-4 TO CF-RECSIZE-X.
048200*    *NOTE - RECLENGTH CHECKS DISABLED THIS VERSION*.
048220*    IF CF-RECSIZE GREATER THAN MAX-RECSIZE
048240*        DISPLAY FD-MSG-1 UPON CONSOLE GO TO DEF-ASK-BACK.
048260*    IF CF-RECSIZE LESS THAN MIN-RECSIZE
048280*        DISPLAY FD-MSG-2 UPON CONSOLE GO TO DEF-ASK-BACK.
048300     GO TO DEF-ASK.
048320 DC-FD8.
048340     IF FOUND-WORD-4 = ' ' AND CF-ACT = 'C' GO TO DEF-ASK.
048380     IF JRIGHT-4 NOT NUMERIC GO TO DEF-ASK-NONUM.
048390     MOVE JRIGHT-4 TO CF-BLKFACT-X.
048400*    *NOTE - THIS VERSION HANDLES BLOCKING FACTORS*.
048420*    *   AND IMPOSES WARNING CHECKING ONLY ON THEM*.
048460     IF CF-BLKFACT GREATER THAN MAX-BLKFACT
048480         DISPLAY FD-MSG-3 MAX-BLKFACT UPON CONSOLE.
048510     SUBTRACT CF-BLKFACT FROM 0 GIVING CF-BLKFACT.
048520     GO TO DEF-ASK.
048540 DC-FD9.
048560     IF FOUND-WORD-4 = ' ' AND CF-ACT = 'C' GO TO DEF-ASK.
048600     IF JRIGHT-4 NOT NUMERIC GO TO DEF-ASK-NONUM.
048610     MOVE JRIGHT-4 TO CF-KEYPOS-X.
048620     IF CF-ACT = 'C' GO TO DEF-ASK.
048640     IF CF-BLKFACT = 0 AND CF-KEYPOS NOT = 0
048660        DISPLAY FD-MSG-4 UPON CONSOLE
048680        GO TO DEF-ASK-BACK.
048700     IF CF-KEYPOS GREATER THAN CF-RECSIZE
048720         DISPLAY FD-MSG-7 UPON CONSOLE GO TO DEF-ASK-BACK.
048740     GO TO DEF-ASK.
048760 DC-FD10.
048780     IF FOUND-WORD-4 = ' ' AND CF-ACT = 'C' GO TO DEF-ASK.
048820     IF JRIGHT-3 NOT NUMERIC GO TO DEF-ASK-NONUM.
048824     MOVE JRIGHT-3 TO CF-KEYLEN-X.
048840     IF CD-ACT = 'C' GO TO DEF-ASK.
048860     IF CF-KEYLEN NOT = 0 AND CF-KEYPOS = 0
048880         DISPLAY FD-MSG-6 UPON CONSOLE
048900         GO TO DEF-ASK-BACK.
048920     IF CF-KEYPOS NOT = 0 AND CF-KEYLEN = 0
048940         DISPLAY FD-MSG-8 UPON CONSOLE
048960         GO TO DEF-ASK-BACK.
048980     IF CF-KEYLEN GREATER THAN MAX-KEYLEN
049000         DISPLAY FD-MSG-9 UPON CONSOLE
049020         GO TO DEF-ASK-BACK.
049040     MOVE 0 TO WORK-1.
049060     IF CF-FILETYPE =  7  OR  6
049080         MOVE CF-KEYPOS TO WORK-1 ADD CF-KEYLEN TO WORK-1
049100         SUBTRACT 1 FROM  WORK-1.
049120     IF WORK-1 IS GREATER THAN CF-RECSIZE
049140         DISPLAY FD-MSG-7 UPON CONSOLE
049160         GO TO DEF-ASK-BACK.
049180     GO TO DEF-ASK.
049200 DC-FD11.
049220     IF FOUND-WORD-4 = ' ' AND CF-ACT = 'C' GO TO DEF-ASK.
049240     MOVE FOUND6-WORD-1 TO CF-KEYTYPE-X.
049250     IF CF-KEYTYPE-X = ' ' MOVE '0' TO CF-KEYTYPE.
049260     IF CF-KEYTYPE-X = 'A' OR 'N' OR '0' OR '1' OR '2'
049280         NEXT SENTENCE ELSE DISPLAY FD-MSG-12 UPON CONSOLE
049290         MOVE SPACE TO CF-KEYTYPE-X
049300         GO TO DEF-ASK-BACK.
049320     GO TO DEF-ASK.
049340 DC-FD12.
049360     IF FOUND-WORD-4 = ' ' AND CF-ACT = 'C' GO TO DEF-ASK.
049380     MOVE FOUND6-WORD-1 TO CF-KEYSIGN-X.
049390     IF CF-KEYSIGN-X = ' ' MOVE '0' TO CF-KEYSIGN-X.
049400     IF CF-KEYSIGN-X = 'S' OR 'U' OR '0' OR '1'
049420         NEXT SENTENCE ELSE DISPLAY FD-MSG-13 UPON CONSOLE
049430         MOVE SPACE TO CF-KEYSIGN-X
049440         GO TO DEF-ASK-BACK.
049460     GO TO DEF-ASK.
049480 DC-FD13.
049500     IF FOUND-WORD-4 = ' ' AND CF-ACT = 'C' GO TO DEF-ASK.
049540     IF JRIGHT-2 NOT NUMERIC GO TO DEF-ASK-NONUM.
049550     MOVE JRIGHT-2 TO CF-PROT-READ.
049560     GO TO DEF-ASK.
049580 DC-FD14.
049600     IF FOUND-WORD-4 = ' ' AND CF-ACT = 'C' GO TO DEF-ASK.
049640     IF JRIGHT-2 NOT NUMERIC GO TO DEF-ASK-NONUM.
049650     MOVE JRIGHT-2 TO CF-PROT-COPY.
049660     GO TO DEF-ASK.
049680 DC-FD15.
049700     IF FOUND-WORD-4 = ' ' AND CF-ACT = 'C' GO TO TRAN-DONE.
049740     IF JRIGHT-2 NOT NUMERIC GO TO DEF-ASK-NONUM.
049750     MOVE JRIGHT-2 TO CF-PROT-REWRITE.
049760     GO TO TRAN-DONE.
049780
049800 DC-DD.
049820     MOVE 20 TO  PX  PX-IN.
049840     GO TO DEF-ASK.
049860 DC-DD1.
049880     MOVE FOUND6-WORD-30 TO CD-NAME.
049900     PERFORM CHECK-NAME THRU CHECK-NAME-EXIT.
049920     IF NAME-ERR-FLAG = 1 GO TO DEF-ASK-BACK.
049940     IF FOUND6-WORD-1 = 'X' OR FOUND6-WORD-2 = 'ZZ'
049960         DISPLAY DD-MSG-2 UPON CONSOLE MOVE SPACES TO CD-NAME 
049970             GO TO DEF-ASK-BACK.
049980     IF CD-ACT = 'D' GO TO TRAN-DONE.
050000     GO TO DEF-ASK.
050020 DC-DD2.
050040     MOVE FOUND-WORD-10 TO CD-TITLE1.
050060     IF FOUND-WORD-10 = ALL '*' GO TO DEF-ASK.
050080     MOVE SPACES TO FOUND-WORD-10.
050100     IF FOUND-WORD NOT = SPACES
050120         DISPLAY DD-MSG-20 UPON CONSOLE
050140         SUBTRACT 1 FROM PX.
050160     GO TO DEF-ASK.
050180 DC-DD3.
050200     MOVE FOUND-WORD-10 TO CD-TITLE2.
050220     IF FOUND-WORD-10 = ALL '*' GO TO DEF-ASK.
050240     MOVE SPACES TO FOUND-WORD-10.
050260     IF FOUND-WORD NOT = SPACES
050280         DISPLAY DD-MSG-20 UPON CONSOLE
050300         SUBTRACT 1 FROM PX.
050320     IF AUTO-SW = 2 ADD 1 TO PX.
050340     GO TO DEF-ASK.
050360 DC-DD4.
050380     IF FOUND-WORD-4 = ' ' AND CD-ACT = 'C' GO TO DEF-ASK.
050400     IF FOUND6-WORD-5 = 'DBMS ' MOVE '0000' TO JRIGHT-4.
050440     IF JRIGHT-4 NOT NUMERIC GO TO DEF-ASK-NONUM.
050445     MOVE JRIGHT-4 TO CD-FCHAR-X.
050460*    IF CD-FCHAR = 0 DISPLAY DD-MSG-3 UPON CONSOLE
050470*        MOVE SPACES TO CD-FCHAR-X
050480*        GO TO DEF-ASK-BACK.
050500*    IF CD-FCHAR GREATER THAN MAX-RECSIZE
050510*        MOVE SPACES TO CD-FCHAR-X
050520*        DISPLAY DD-MSG-4 UPON CONSOLE GO TO DEF-ASK-BACK.
050540     GO TO DEF-ASK.
050560 DC-DD5.
050580     IF FOUND-WORD-4 = ' ' AND CD-ACT = 'C' GO TO DEF-ASK.
050620     IF JRIGHT-4 NOT NUMERIC GO TO DEF-ASK-NONUM.
050630     MOVE JRIGHT-4 TO CD-NCHARS-X.
050640     IF CD-NCHARS = 0 DISPLAY DD-MSG-5 UPON CONSOLE
050650         MOVE SPACES TO CD-NCHARS-X
050660         GO TO DEF-ASK-BACK.
050680*    IF CD-NCHARS GREATER THAN MAX-ITEMLEN
050690*        MOVE SPACES TO CD-NCHARS-X
050700*        DISPLAY DD-MSG-6 UPON CONSOLE GO TO DEF-ASK-BACK.
050720     GO TO DEF-ASK.
050740 DC-DD6.
050760     IF FOUND-WORD-4 = ' ' AND CD-ACT = 'C' GO TO DEF-ASK.
050780     MOVE FOUND6-WORD-1 TO CD-TYPE-X.
050800     IF CD-TYPE-X = 'A' MOVE 1 TO CD-TYPE.
050820     IF CD-TYPE-X = 'N' MOVE 2 TO CD-TYPE.
050840     IF CD-TYPE-X = 'B' MOVE 6 TO CD-TYPE.
050860     IF CD-TYPE = 6 AND CD-NCHARS > 18
050880                DISPLAY DD-MSG-6 UPON CONSOLE
050900                MOVE SPACE TO CD-TYPE-X
050920                GO TO DEF-ASK-BACK.
050940     IF (ASCII-SW = 1 AND CD-TYPE-X = '6') OR
050960        (CD-TYPE-X NOT = '1' AND NOT = '2' AND NOT = '6')
050980             DISPLAY DD-MSG-7 UPON CONSOLE
051000             MOVE SPACE TO CD-TYPE-X
051020             GO TO DEF-ASK-BACK.
051040     IF (AUTO-SW =2) AND (CD-TYPE-X NOT = 6)
051060            MOVE FIRST-POS-CTR TO CD-FCHAR
051080            ADD CD-NCHARS TO FIRST-POS-CTR
051100            GO TO DEF-ASK.
051120     IF (AUTO-SW =2) AND (CD-TYPE-X = '6')
051140            PERFORM CALCULATE-FIRST-POS
051160            MOVE FIRST-POS-CTR TO CD-FCHAR
051180            ADD BINARY-CHARS TO FIRST-POS-CTR.
051200     GO TO DEF-ASK.
051220 CALCULATE-FIRST-POS.
051240     DIVIDE FIRST-POS-CTR BY 6 GIVING FP-QUO
051260             REMAINDER FP-REM.
051280     ADD 1 TO FP-REM.
051300     ADD BINARY-ADJUST (FP-REM) TO FIRST-POS-CTR.
051320     IF CD-NCHARS > 10 MOVE 12 TO BINARY-CHARS
051340              ELSE    MOVE 6 TO BINARY-CHARS.
051360 DC-DD7.
051380     IF FOUND-WORD-4 = ' ' AND CD-ACT = 'C' GO TO DEF-ASK.
051420     IF JRIGHT-1 NOT NUMERIC GO TO DEF-ASK-NONUM.
051430     MOVE JRIGHT-1 TO CD-SCALE-X.
051440*    MOVE ' ' TO JRIGHT-1.
051460*    IF JRIGHT-WORD NOT = ' '
051480*        DISPLAY DD-MSG-8 UPON CONSOLE GO TO DEF-ASK-BACK.
051500     IF CD-ACT = 'C' GO TO DEF-ASK.
051520     IF CD-SCALE GREATER THAN CD-NCHARS
051540         DISPLAY DD-MSG-8 UPON CONSOLE
051560         GO TO DEF-ASK-BACK.
051580     GO TO DEF-ASK.
051600 DC-DD8.
051620     MOVE FOUND6-WORD-19 TO CD-PICT.
051640     IF CD-ACT = 'C' GO TO DEF-ASK.
051660     PERFORM CHECK-PICT THRU CHECK-PICT-EXIT.
051680     IF EDIT-ERROR-FLAG NOT = 0
051690         MOVE SPACES TO CD-PICT
051700         DISPLAY DD-MSG-11 UPON CONSOLE GO TO DEF-ASK-BACK.
051720     GO TO DEF-ASK.
051740 DC-DD8A.
051760     IF FOUND6-WORD-1 = 'N ' MOVE 'N' TO CD-NOUPD ELSE
051770     IF FOUND6-WORD-1 = 'Y ' MOVE 'Y' TO CD-NOUPD ELSE
051780         MOVE SPACE TO CD-NOUPD.
051800     GO TO DEF-ASK.
051820 DC-DD9.
051840     MOVE FOUND6-WORD-1 TO CD-GRPNAME.
051860     GO TO DEF-ASK.
051880 DC-DD10.
051900     IF FOUND-WORD-4 = ' ' AND CD-ACT = 'C' GO TO DEF-ASK.
051940     IF JRIGHT-2 NOT NUMERIC GO TO DEF-ASK-NONUM.
051950     MOVE JRIGHT-2 TO CD-NRPTS-X.
051960     IF CD-ACT = 'C' GO TO DEF-ASK.
051980     IF CD-NRPTS NOT = 0 AND CD-GRPNAME = ' '
052000         DISPLAY DD-MSG-13 UPON CONSOLE GO TO DEF-ASK-BACK.
052020     IF CD-GRPNAME NOT = ' ' AND CD-NRPTS = 0
052040         DISPLAY DD-MSG-15 UPON CONSOLE GO TO DEF-ASK-BACK.
052060     GO TO DEF-ASK.
052080 DC-DD11.
052100     MOVE FOUND-WORD-1 TO CD-STOPPER.
052120     GO TO DEF-ASK.
052140 DC-DD12.
052160     IF FOUND-WORD-4 = ' ' AND CD-ACT = 'C' GO TO DEF-ASK.
052200     IF JRIGHT-2 NOT NUMERIC GO TO DEF-ASK-NONUM.
052210     MOVE JRIGHT-2 TO CD-PROT-NO-X.
052220     GO TO DEF-ASK.
052240 DC-DD13.
052260     IF FOUND-WORD-1 = ' ' AND CD-ACT = 'C' GO TO TRAN-DONE.
052280     MOVE FOUND6-WORD-1 TO CD-EXCLFLAG.
052300     IF CD-EXCLFLAG = ' ' MOVE '0' TO CD-EXCLFLAG.
052320     IF CD-EXCLFLAG = 'Y' MOVE '1' TO CD-EXCLFLAG.
052340     IF CD-EXCLFLAG = 'N' MOVE '0' TO CD-EXCLFLAG.
052360     IF CD-EXCLFLAG NOT = '0' AND NOT = '1'
052370         MOVE SPACE TO CD-EXCLFLAG
052380         DISPLAY DD-MSG-17 UPON CONSOLE GO TO DEF-ASK-BACK.
052400     GO TO TRAN-DONE.
052420
052440 DC-PD.
052460     MOVE 35 TO  PX  PX-IN.
052480     GO TO DEF-ASK.
052500 DC-PD1.
052520     MOVE ' ' TO CP-DATE-FLAG  CP-LINE.
052560     IF JRIGHT-2 NOT NUMERIC GO TO DEF-ASK-NONUM.
052570     MOVE JRIGHT-2 TO CP-PROT-NO-X.
052580     GO TO DEF-ASK.
052600 DC-PD2.
052620     MOVE FOUND6-WORD-7 TO CF-FIX-TEXT.
052640     GO TO TRAN-DONE.
052660
052680 DC-RD.
052700     MOVE 38 TO  PX  PX-IN.
052720     GO TO DEF-ASK.
052740 DC-RD1.
052760     MOVE FOUND6-WORD-30 TO RD-NAME.
052780     PERFORM CHECK-NAME THRU CHECK-NAME-EXIT.
052800     IF NAME-ERR-FLAG = 1 MOVE SPACES TO RD-NAME
052810         GO TO DEF-ASK-BACK.
052820     IF RD-ACT = 'D' GO TO TRAN-DONE.
052840     GO TO DEF-ASK.
052860 DC-RD2.
052880     IF FOUND-WORD-4 = ' ' AND CD-ACT = 'C' GO TO DEF-ASK.
052920     IF JRIGHT-4 NOT NUMERIC GO TO DEF-ASK-NONUM.
052930     MOVE JRIGHT-4 TO RD-ORIGIN.
052940     GO TO DEF-ASK.
052960 DC-RD3.
052980     IF FOUND-WORD-4 = ' ' AND CD-ACT = 'C' GO TO DEF-ASK.
053020     IF JRIGHT-4 NOT NUMERIC GO TO DEF-ASK-NONUM.
053030     MOVE JRIGHT-4 TO RD-LENGTH.
053040     GO TO DEF-ASK.
053060 DC-RD4.
053080     IF FOUND-WORD-4 = ' ' AND CD-ACT = 'C' GO TO DEF-ASK.
053084     IF FOUND6-WORD-1 = 'A' MOVE '007' TO RD-TYPE
053088         ELSE IF FOUND6-WORD-1 = 'S' MOVE '006' TO RD-TYPE
053096         ELSE GO TO DEF-ASK-BACK.
053120     GO TO DEF-ASK.
053140 DC-RD5.
053150     IF BLANK-OUT-FLAG = 1 MOVE ALL '*' TO RD-TEXT
053160         ELSE MOVE FOUND-WORD TO RD-TEXT.
053180     GO TO TRAN-DONE.
053200
053220 DC-AD.
053240     MOVE 44 TO PX PX-IN.
053260     GO TO DEF-ASK.
053280 DC-AD1.
053300     MOVE FOUND6-WORD-30 TO AD-NAME.
053320     PERFORM CHECK-NAME THRU CHECK-NAME-EXIT.
053340     IF NAME-ERR-FLAG = 1 MOVE SPACES TO AD-NAME
053350         GO TO DEF-ASK-BACK.
053360     IF AD-ACT = 'D' GO TO TRAN-DONE.
053380     GO TO DEF-ASK.
053400* DC-AD2.
053420*     IF FOUND-WORD-4 = ' ' AND AD-ACT = 'C' GO TO DEF-ASK.
053460*     IF JRIGHT-4 NOT NUMERIC GO TO DEF-ASK-NONUM.
053470*     MOVE JRIGHT-4 TO AD-ORIGIN.
053480*     GO TO DEF-ASK.
053500* DC-AD3.
053520*     IF FOUND-WORD-4 = ' ' AND AD-ACT = 'C' GO TO DEF-ASK.
053560*     IF JRIGHT-4 NOT NUMERIC GO TO DEF-ASK-NONUM.
053570*     MOVE JRIGHT-4 TO AD-LENGTH.
053580*     GO TO DEF-ASK.
053600 DC-AD4.
053610     IF BLANK-OUT-FLAG = 1 MOVE ALL '*' TO AD-TEXT
053620         ELSE MOVE FOUND-WORD TO AD-TEXT.
053640     GO TO TRAN-DONE.
053660
053680 DC-SD.
053700     MOVE 47 TO PX PX-IN.
053720     GO TO DEF-ASK.
053740 DC-SD1.
053760     MOVE FOUND6-WORD-30 TO SD-NAME.
053780     PERFORM CHECK-NAME THRU CHECK-NAME-EXIT.
053800     IF NAME-ERR-FLAG = 1 MOVE SPACES TO SD-NAME
053810         GO TO DEF-ASK-BACK.
053820     IF SD-ACT = 'D' GO TO TRAN-DONE.
053840     GO TO DEF-ASK.
053860* DC-SD2.
053880*     IF FOUND-WORD-4 = ' ' AND CD-ACT = 'C' GO TO DEF-ASK.
053920*     IF JRIGHT-4 NOT NUMERIC GO TO DEF-ASK-NONUM.
053930*     MOVE JRIGHT-4 TO SD-OWNER-REC.
053940*     GO TO DEF-ASK.
053960* DC-SD3.
053980*     IF FOUND-WORD-4 = ' ' AND SD-ACT = 'C' GO TO DEF-ASK.
054020*     IF JRIGHT-4 NOT NUMERIC GO TO DEF-ASK-NONUM.
054030*     MOVE JRIGHT-4 TO SD-MEMBER-REC.
054040*     GO TO DEF-ASK.
054060 DC-SD4.
054070     IF BLANK-OUT-FLAG = 1 MOVE ALL '*' TO SD-TEXT
054080         ELSE MOVE FOUND-WORD TO SD-TEXT.
054100     GO TO TRAN-DONE.
054120
054140 DC-CD.
054160     MOVE 50 TO  PX  PX-IN.
054180     GO TO DEF-ASK.
054200 DC-CD1.
054240     IF JRIGHT-2 NOT NUMERIC GO TO DEF-ASK-NONUM.
054250     MOVE JRIGHT-2 TO CC-NO.
054260     IF CF-ACT = 'D' GO TO TRAN-DONE.
054280     GO TO DEF-ASK.
054300 DC-CD2.
054310     IF BLANK-OUT-FLAG = 1 MOVE ALL '*' TO CC-TEXT
054320         ELSE MOVE FOUND-WORD TO CC-TEXT.
054340     GO TO TRAN-DONE.
054360
054380 TRAN-DONE.
054400*    *TRANSACTION BUILD COMPLETED - WRITE IT OUT*.
054420     IF PX NOT = 1 WRITE TRAN-REC FROM FD-TRAN.
054440     IF FOUND6-WORD-6 = 'END ' OR 'SCRUB '
054460         GO TO DICT-DEFINER-DONE.
054480*    *NOW GO BACK FOR NEXT TRANSACTION*.
054500     MOVE 0 TO NEXT-FLAG.
054520     GO TO DEF-CNV.
054540
054560 TRAN-REJECT.
054580     DISPLAY ' %Transaction rejected - reenter'
054600         UPON CONSOLE.
054620     MOVE 0 TO NEXT-FLAG.
054640     GO TO DEF-CNV.
054660
054680 DEF-ASK-NONUM.
054700     DISPLAY DD-MSG-18 UPON CONSOLE.
054720
054740 DEF-ASK-BACK.
054760*    *HERE IF WANT TO BACK UP TO PRIOR FIELD*.
054780*    *HOWEVER, IF IN AUTO 'NEXT' MODE, GIVE UP ON XACTION*
054780     MOVE 0 TO BLANK-OUT-FLAG.
054800     IF NEXT-FLAG = 1 GO TO TRAN-REJECT.
054820     SUBTRACT 1 FROM PX.
054840     MOVE 0 TO NEXT-FLAG.
054860
054880 DEF-ASK.
054890     MOVE 0 TO BLANK-OUT-FLAG.
054900     IF NEXT-FLAG = 1 GO TO DEF-ASK-NEXT.
054920     PERFORM DEF-GET THRU DEF-GET-EXIT.
054940     PERFORM JUST-RIGHTER THRU JUST-RIGHTER-EXIT.
054960     EXAMINE JRIGHT-WORD REPLACING ALL ' ' BY '0'.
054980*   *TRAP AND ROUTE ON SPECIAL CONTROL WORDS*.
055000     IF FOUND6-WORD-6 = 'NEXT  '
055020         AND ( CF-ACT = 'A' OR 'S' )
055040         MOVE 1 TO NEXT-FLAG
055060         GO TO DEF-ASK-NEXT.
055080     IF FOUND6-WORD-6 = 'NEXT  ' OR 'END   ' OR 'SCRUB '
055100         GO TO TRAN-DONE.
055120     IF FOUND6-WORD-5 = 'KILL ' GO TO TRAN-REJECT.
055140     IF FOUND6-WORD-6 NOT = 'BLANK ' AND
055150        FOUND6-WORD-6 NOT = 'BLANKS'  GO TO DEF-ASK1A.
055160     IF CF-ACT = 'C'
055180         MOVE ALL '*' TO FOUND-WORD
055184         MOVE ALL '*' TO FOUND6-WORD
055200         MOVE ALL '0' TO JRIGHT-WORD
055210         MOVE 1 TO BLANK-OUT-FLAG
055220         GO TO DEF-ASK2.
055240     MOVE ALL ' ' TO FOUND-WORD.
055244     MOVE ALL ' ' TO FOUND6-WORD.
055260     MOVE ALL ' ' TO JRIGHT-WORD.
055280     GO TO DEF-ASK2.
055300 DEF-ASK1A.
055320     IF FOUND6-WORD-3 = 'UP '
055340         OR FOUND6-WORD-5 = 'DOWN '
055360         NEXT SENTENCE ELSE GO TO DEF-ASK2.
055380     MOVE FOUND-WORD-30 TO WORD-HOLDER-30 WORD6-HOLDER.
055400     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
055420     PERFORM JUST-RIGHTER THRU JUST-RIGHTER-EXIT.
055440     EXAMINE JRIGHT-4 REPLACING ALL ' ' BY '0'.
055460     IF JRIGHT-4 IS NOT NUMERIC MOVE 1 TO JRIGHT-4.
055480     MOVE JRIGHT-4 TO I.
055500     IF I = 0 MOVE 1 TO I.
055520     IF I GREATER THAN 15 MOVE 1 TO I.
055540     IF WORD6-HOLDER-3 = 'UP ' SUBTRACT I FROM PX
055560         ELSE ADD I TO PX.
055580     IF PX GREATER THAN MAX-PX COMPUTE PX = PX - I + 1.
055600     IF PX NOT LESS THAN PX-IN GO TO DEF-ASK.
055620     IF CF-IDNT = 'FD' GO TO DEF-CNV.
055640     SUBTRACT PX FROM PX-IN GIVING J.
055660     IF J = 1 MOVE 2 TO PX GO TO DEF-CNV2.
055680     GO TO DEF-CNV.
055700 DEF-ASK-NEXT.
055720     MOVE SPACES TO FOUND-WORD.
055724     MOVE SPACES TO FOUND6-WORD.
055740     MOVE ALL '0' TO JRIGHT-WORD.
055760 DEF-ASK2.
055780     ADD 1 TO PX.
055800     GO TO DEF-CNV DEF-CNV1 DEF-CNV3
055820           DC-FD DC-FD1 DC-FD2 DC-FD3 DC-FD4 DC-FD5 DC-FD6
055840           DC-FD7 DC-FD8 DC-FD9 DC-FD10 DC-FD11 DC-FD12
055860           DC-FD13 DC-FD14 DC-FD15
055880           DC-DD DC-DD1 DC-DD2 DC-DD3 DC-DD4 DC-DD5 DC-DD6
055900           DC-DD7 DC-DD8 DC-DD8A DC-DD9 DC-DD10 DC-DD11 DC-DD12
055920           DC-DD13
055940           DC-PD DC-PD1 DC-PD2
055960           DC-RD DC-RD1 DC-RD2 DC-RD3 DC-RD4 DC-RD5
055980           DC-AD DC-AD1 DC-AD4
056000           DC-SD DC-SD1 DC-SD4
056020           DC-CD DC-CD1 DC-CD2
056040           DEPENDING ON PX.
056060
056080 DEF-GET.
056100     DISPLAY PROMPT (PX) UPON CONSOLE WITH NO ADVANCING.
056120     SET UIX TO 1.
056140     MOVE SPACES TO USER-INPUT.
056160     ACCEPT USER-INPUT FROM TTY.
056180     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
056200     MOVE USER-INPUT TO FOUND-WORD.
056204     MOVE USER-INPUT TO FOUND6-WORD.
056220 DEF-GET-EXIT.
056240     EXIT.
056260
056280 DICT-DEFINER-DONE.
056300     PERFORM SPACER. MOVE
056320     ' (End of dictionary transaction input.)'
056340         TO CONSOLE-LINE.
056360     PERFORM DISPLAYER THRU DISPLAYER-EXIT. CLOSE QCDICT.
056380 DICT-DEFINER-EXIT.
056400     EXIT.
056420
056440*$$$$$$$$$$$$$$$$$$$$$$$$$
056460 NAME-DISPLAYING SECTION 6.
056480*$$$$$$$$$$$$$$$$$$$$$$$$$
056500*********************************************************
056520* SUBROUTINE TO LIST NAMES OF STORED QUERIES.
056540**********************************************************
056560 LIST-QUERY-NAMES.
056580     MOVE 0 TO FOUND-QUERY.
056600     MOVE SPACES TO QUERY-NAME-MSG.
056620     MOVE ' Queries stored in your directory: ' TO CONSOLE-LINE.
056640     PERFORM DISPLAYER THRU DISPLAYER-EXIT.  PERFORM SPACER.
056660     PERFORM LOOK-FOR-QPQRYS.
056680     IF I NOT = -1 GO TO LIST-QUERY-NAMES-MISSED.
056700     OPEN INPUT QPQRYS.
056720     MOVE 1 TO I.
056740 QUERY-NAMES-1.
056760     READ QPQRYS AT END
056780        GO TO QUERY-NAMES-END.
056800     IF STORE-MARK IS NOT = '**' GO TO QUERY-NAMES-1.
056820     MOVE 1 TO FOUND-QUERY.
056840     IF I = 1 MOVE STORE-NAME TO LQ-NAME MOVE 2 TO I
056860         GO TO QUERY-NAMES-1.
056880     IF I = 2 MOVE STORE-NAME TO MQ-NAME MOVE 3 TO I
056900         GO TO QUERY-NAMES-1.
056920     MOVE STORE-NAME TO RQ-NAME.
056940     MOVE 1 TO I.
056960     MOVE QUERY-NAME-MSG TO CONSOLE-LINE. 
056970     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
056980     MOVE SPACES TO QUERY-NAME-MSG.
057000     GO TO QUERY-NAMES-1.
057020 QUERY-NAMES-END.
057040     CLOSE QPQRYS.
057060     IF FOUND-QUERY = 0 GO TO LIST-QUERY-NAMES-MISSED.
057080     IF I IS NOT = 1 MOVE QUERY-NAME-MSG TO CONSOLE-LINE
057100         PERFORM DISPLAYER THRU DISPLAYER-EXIT.
057120     PERFORM SPACER.
057140     MOVE ' (End list of stored queries)' TO CONSOLE-LINE.
057160     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
057180     GO TO LIST-QUERY-NAMES-EXIT.
057200 LIST-QUERY-NAMES-MISSED.
057220     MOVE ' (none)' TO CONSOLE-LINE.
057240     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
057260 LIST-QUERY-NAMES-EXIT.
057280     EXIT.
057300
057320*$$$$$$$$$$$$$$$$$$$$$$$$$
057340 DICT-DEF-SUPPORT SECTION 5.
057360*$$$$$$$$$$$$$$$$$$$$$$$$$
057380*********************************************************
057400* SUBROUTINE TO RIGHT JUSTIFY A LEFT JUSTIFIED WORD.
057420*********************************************************
057440 JUST-RIGHTER.
057460     SET FWX TO 20.  SET JRX TO 20.
057480     MOVE SPACES TO JRIGHT-WORD.
057500 JUST-RIGHTER-1.
057520     IF FOUND-CHAR (FWX) NOT = SPACE GO TO JUST-RIGHTER-2.
057540     SET FWX DOWN BY 1.
057560     IF FWX NOT = 0 GO TO JUST-RIGHTER-1.
057580     GO TO JUST-RIGHTER-EXIT.
057600 JUST-RIGHTER-2.
057620     MOVE FOUND-CHAR (FWX) TO JRIGHT-CHAR (JRX).
057640     SET FWX DOWN BY 1.
057660     IF FWX NOT = 0 SET JRX DOWN BY 1
057680         GO TO JUST-RIGHTER-2.
057700 JUST-RIGHTER-EXIT.
057720     EXIT.
057740
057760*$$$$$$$$$$$$$$$$$$$$$$$$$
057780 DICT-DISP-SUPPORT SECTION 4.
057800*$$$$$$$$$$$$$$$$$$$$$$$$$
057820*********************************************************
057840* SUBROUTINE TO UNSCRAMBLE A PASSWORD.
057860*********************************************************
057880 UNSCRAMBLE-PW.
057900     MOVE DP-CHAR (1)  TO PW-CHAR (1).
057920     MOVE DP-CHAR (2)  TO PW-CHAR (2).
057940     MOVE DP-CHAR (3)  TO PW-CHAR (3).
057960     MOVE DP-CHAR (4)  TO PW-CHAR (4).
057980     MOVE DP-CHAR (5)  TO PW-CHAR (5).
058000     MOVE DP-CHAR (6)  TO PW-CHAR (6).
058020     MOVE DP-CHAR (7)  TO PW-CHAR (7).
058040     MOVE DP-CHAR (8)  TO PW-CHAR (8).
058060     MOVE DP-CHAR (9)  TO PW-CHAR (9).
058080     MOVE DP-CHAR (10) TO PW-CHAR (10).
058100     MOVE DP-CHAR (11) TO PW-CHAR (11).
058120     MOVE DP-CHAR (12) TO PW-CHAR (12).
058140     SUBTRACT PW-MASK1 FROM PW-WORK1.
058160     SUBTRACT PW-MASK2 FROM PW-WORK2.
058180     MOVE SPACES       TO DP-TEXT.
058200     MOVE PW-CHAR (10) TO DP-CHAR (1).
058220     MOVE PW-CHAR (9)  TO DP-CHAR (2).
058240     MOVE PW-CHAR (6)  TO DP-CHAR (3).
058260     MOVE PW-CHAR (12) TO DP-CHAR (4).
058280     MOVE PW-CHAR (3)  TO DP-CHAR (5).
058300     MOVE PW-CHAR (2)  TO DP-CHAR (6).
058320 UNSCRAMBLE-PW-EXIT.
058340     EXIT.
058360
058380*$$$$$$$$$$$$$$$$$$$$$$$$$
058400 MAIN-SUPPORT SECTION 0.
058420*$$$$$$$$$$$$$$$$$$$$$$$$$
058440*********************************************************
058460* SUBROUTINE TO PICK A WORD OUT OF INPUT STRING FROM CONSOLE-LINE
058480* DEPENDS ON INDEX UIX (TO USER INPUT) BEING SET AT
058500* PLACE IN USER INPUT THE SEARCH IS TO START.
058520* RESETS UIX TO WHERE LEFT OFF; READY FOR NEXT CYCLE.
058540*********************************************************
058560 FIND-WORD.
058580     MOVE SPACES TO FOUND-WORD.
058600     SET FWX TO 1.
058620     PERFORM READ-BLANKS THRU READ-BLANKS-EXIT.
058640     IF UIX GREATER THAN MAX-UIX GO TO FIND-WORD-DONE.
058660     MOVE INPUT-CHAR (UIX) TO ELEM-CHAR.
058680     IF ELEM-CHAR = ','
058700         SET UIX UP BY 1 GO TO FIND-WORD-DONE.
058720     IF ELEM-CHAR = '"' OR "'"
058740         MOVE ELEM-CHAR TO CURRENT-QUOTE
058760         GO TO FIND-QUOTE.
058780 FIND-WORD-LOOP.
058800     MOVE ELEM-CHAR TO FOUND-CHAR (FWX).
058820     SET UIX UP BY 1. SET FWX UP BY 1.
058840     IF FWX GREATER THAN MAX-FWX GO TO FIND-WORD-DONE.
058860     IF UIX GREATER THAN MAX-UIX GO TO FIND-WORD-DONE.
058880     MOVE INPUT-CHAR (UIX) TO ELEM-CHAR.
058900     IF ELEM-CHAR = ','
058920         SET UIX UP BY 1 GO TO FIND-WORD-DONE.
058940     IF ELEM-CHAR NOT = SPACE GO TO FIND-WORD-LOOP.
058960     GO TO FIND-WORD-OUT.
058980 FIND-QUOTE.
059000     SET UIX UP BY 1.
059020     IF UIX GREATER THAN MAX-UIX GO TO FIND-WORD-DONE.
059040     MOVE INPUT-CHAR (UIX) TO ELEM-CHAR.
059060     IF ELEM-CHAR = CURRENT-QUOTE SET UIX UP BY 1
059080         GO TO FIND-WORD-OUT.
059100     MOVE ELEM-CHAR TO FOUND-CHAR (FWX).
059120     SET FWX UP BY 1.
059140     IF FWX GREATER THAN MAX-FWX GO TO FIND-WORD-DONE.
059160     GO TO FIND-QUOTE.
059180 FIND-WORD-OUT.
059200     PERFORM READ-BLANKS THRU READ-BLANKS-EXIT.
059220     IF UIX GREATER THAN MAX-UIX GO TO FIND-WORD-DONE.
059240     IF INPUT-CHAR (UIX) = '.' OR ','
059260         SET UIX UP BY 1.
059264 FIND-WORD-DONE.
059268     MOVE FOUND-WORD TO FOUND6-WORD.
059280 FIND-WORD-EXIT.
059300     EXIT.
059320
059340*****************************************************
059360* SUBROUTINE TO READ OVER BLANK INPUT CHARACTERS
059380*****************************************************
059400 READ-BLANKS.
059420     IF UIX GREATER THAN MAX-UIX GO TO READ-BLANKS-EXIT.
059440     IF INPUT-CHAR (UIX) NOT = SPACE GO TO READ-BLANKS-EXIT.
059460     SET UIX UP BY 1. GO TO READ-BLANKS.
059480 READ-BLANKS-EXIT.
059500     EXIT.
059520
059540*****************************************************
059560* SUBROUTINE TO SPACE ONE LINE VERTICALLY ON CONSOLE-LINE. PERFORM
059580*****************************************************
059600 SPACER.
059620     MOVE ' ' TO CONSOLE-LINE. 
059622     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
059640
059660*****************************************************
059680* SUBROUTINE TO GET USERS RESPONSE FROM CONSOLE-LINE *.
059700*****************************************************
059720 ASKER.
059740     PERFORM SPACER.
059760     MOVE SPACES TO USER-INPUT.
059780*    DISPLAY '<QA> ' UPON CONSOLE WITH NO ADVANCING.
059800*    ACCEPT USER-INPUT FROM TTY.
059820	   ENTER MACRO PARSER USING USER-INPUT.
059840*    *NOTED OUT LINES BELOW WOULD ECHO USER INPUT*
059860*    DISPLAY ' ' UPON CONSOLE WITH NO ADVANCING.
059870*    DISPLAY USER-INPUT UPON CONSOLE.
059900     SET UIX TO 1.
059920
059940*****************************************************
059960* SUBROUTINE TO DISPLAY A LINE UPON CONSOLE.
059980*****************************************************
060000 DISPLAYER.
060004    MOVE MAX-CONSOLE-CHARS TO M.
060008 DISPLAYER1.
060010     IF CONSOLE-CHAR (M) = SPACE
060012         MOVE ASCII-NULL TO CONSOLE-CHAR (M)
060014         IF M NOT < 2 SUBTRACT 1 FROM M
060016             GO TO DISPLAYER1.
060020     DISPLAY CONSOLE-LINE UPON CONSOLE.
060024 DISPLAYER-EXIT.
060028     EXIT.
060040
060060*********************************************************
060080* DISPLAY SUBROUTINE.
060100*********************************************************
060120 DISPLAY-QUERY.
060140     IF QUERY-TEXT = SPACE PERFORM SPACER
060160         ELSE DISPLAY ' ' QUERY-TEXT UPON CONSOLE.
060180
060200*$$$$$$$$$$$$$$$$$$$$$$$$$
060220 EDITING SECTION 2.
060240*$$$$$$$$$$$$$$$$$$$$$$$$$
060260**********************************************************
060280* SUBROUTINE TO FIND OUT WHAT FILE TO EDIT
060300**********************************************************
060320 EDIT-ASK.
060340     ENTER MACRO CLRTTY.
060360     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
060380     IF FOUND-WORD-1 = ' ' GO TO EDIT-ASK2.
060440     IF FOUND6-WORD-5 = 'LIST ' MOVE 1 TO INFO-LIST-FLAG
060460         PERFORM GET-CURRENT THRU GET-CURRENT-EXIT
060480         DISPLAY ' ' UPON CONSOLE
060500         GO TO EDIT-ASK2.
060520     MOVE FOUND-WORD-20 TO NAME-HOLDER.
060540     PERFORM FIND-WORD THRU FIND-WORD-EXIT.
060560     IF FOUND6-WORD-5 = 'LIST ' MOVE 1 TO INFO-LIST-FLAG
060580         ELSE MOVE 0 TO INFO-LIST-FLAG.
060600     MOVE NAME-HOLDER TO FOUND-WORD-20.
060604     MOVE NAME-HOLDER TO FOUND6-WORD-20.
060620     PERFORM PULL-QUERY THRU PULL-QUERY-EXIT.
060640     DISPLAY ' ' UPON CONSOLE.
060660     IF FOUND-QUERY NOT = 1 GO TO CENTRAL-CONTROL.
060680 EDIT-ASK2.
060700     PERFORM LOOK-FOR-QCSTMT.
060720     IF I NOT = -1 MOVE '?There is no current query.'
060740         TO CONSOLE-LINE PERFORM DISPLAYER THRU DISPLAYER-EXIT
060760         GO TO CENTRAL-CONTROL.
060780     MOVE SPACE TO INPUT-CHAR (1).
060800     MOVE 0 TO EDIT-FILE-IN EDIT-EOF-SW EDIT-WRITE-SW.
060820     MOVE 0 TO EDIT-DICT-SW EDIT-LINE-CT.
060840 EDIT-ASK3.
060860     PERFORM EDIT-OPEN.
060880     GO TO EDIT-LINE-READ.
060900
060920 EDIT-READ.
060940     IF EDIT-EOF-SW = 1 GO TO EDIT-EOF.
060960     IF EDIT-FILE-IN = 0
060980        READ QCSTMT AT END GO TO EDIT-EOF
061000        ELSE
061020        READ QTQRYS AT END GO TO EDIT-EOF.
061040     IF EDIT-FILE-IN = 0
061060        MOVE QCSTMT-LINE TO EDIT-WORK
061080        ELSE MOVE TEMP-REC TO EDIT-WORK.
061100     MOVE 1 TO EDIT-WRITE-SW.
061120 EDIT-READ-EXIT.  EXIT.
061140
061160**********************************************************
061180* GENERAL PURPOSE EDIT ROUTINE
061200**********************************************************
061220 EDIT-COMMANDER.
061240     ENTER MACRO CLRTTY.
061260     DISPLAY '<QE> ' UPON CONSOLE WITH NO ADVANCING.
061280     MOVE SPACE TO USER-ANS. ACCEPT USER-ANS FROM TTY.
061282     MOVE USER-INPUT TO USER6-INPUT.
061284     MOVE USER6-INPUT TO USER-INPUT.
061300     IF USER-ANS-2 = 'B '    GO TO EDIT-BEGIN.
061320     IF USER-ANS-3 = 'BEG'   GO TO EDIT-BEGIN.
061340     IF USER-ANS-2 = 'E '    GO TO EDIT-END.
061360     IF USER-ANS-4 = 'END '  GO TO EDIT-END.
061380     IF USER-ANS-5 = 'EXIT ' GO TO EDIT-END.
061400     IF USER-ANS-4 = 'TOP '  GO TO EDIT-BEGIN.
061420     IF USER-ANS-4 = 'RUN '  GO TO EDIT-END.
061440     IF USER-ANS-2 = 'I '    GO TO EDIT-INSERT.
061460     IF USER-ANS-3 = 'I. '   GO TO EDIT-INSERT.
061480     IF USER-ANS-3 = 'INS'   GO TO EDIT-INSERT.
061500     IF USER-ANS-2 = 'P-'    GO TO EDIT-PRINT.
061520     IF USER-ANS-3 = 'P.-'   GO TO EDIT-PRINT.
061540     IF USER-ANS-2 = 'UP'    GO TO EDIT-UP.
061560     IF EDIT-EOF-SW = 1
061580         AND EDIT-WRITE-SW = 0
061600                            GO TO EDIT-EOF.
061620     IF USER-ANS-2 = 'BO'    GO TO EDIT-BOTTOM.
061640     IF USER-ANS-2 = 'D '    GO TO EDIT-DELETE.
061660     IF USER-ANS-3 = 'D. '   GO TO EDIT-DELETE.
061680     IF USER-ANS-3 = 'DEL'   GO TO EDIT-DELETE.
061700     IF USER-ANS-1 = 'F'     GO TO EDIT-FIND.
061720     IF USER-ANS-2 = 'L '    GO TO EDIT-LINE-FEED.
061740     IF USER-ANS-2 = 'LI'    GO TO EDIT-LINE-FEED.
061760     IF USER-ANS-1 = 'P'     GO TO EDIT-PRINT.
061780     IF USER-ANS-1 = 'R'     GO TO EDIT-REPLACE.
061800     IF USER-ANS-2 = 'DO'    GO TO EDIT-DOWN.
061820     IF USER-ANS-1 = 'S'     GO TO EDIT-STRING.
061840     IF USER-ANS-1 = SPACE  GO TO EDIT-PRINT.
061860 EDIT-ERROR.
061880     MOVE ' %Command error' TO CONSOLE-LINE.
061900     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
061920     GO TO EDIT-COMMANDER.
061940 EDIT-BEGIN.
061960     PERFORM EDIT-CLOSE.
061980     PERFORM EDIT-OPEN.
062000 EDIT-BEGIN1.
062020     GO TO EDIT-LINE-READ.
062040 EDIT-BOTTOM.
062060     PERFORM EDIT-WRITE THRU EDIT-WRITE-EXIT.
062080     PERFORM EDIT-READ THRU EDIT-READ-EXIT.
062100     IF EDIT-EOF-SW = 0 GO TO EDIT-BOTTOM.
062120     MOVE 'P-1' TO USER-ANS.
062140     GO TO EDIT-PRINT.
062160 EDIT-CLOSE.
062180     PERFORM EDIT-WRITE THRU EDIT-WRITE-EXIT.
062200     PERFORM EDIT-READ THRU EDIT-READ-EXIT.
062220     IF EDIT-EOF-SW = 0 GO TO EDIT-CLOSE.
062240     IF EDIT-FILE-IN = 0 MOVE 1 TO EDIT-FILE-IN
062260        ELSE MOVE 0 TO EDIT-FILE-IN.
062280     CLOSE QCSTMT QTQRYS.
062300     MOVE 0 TO EDIT-EOF-SW.
062320 EDIT-CREATE.
062340*    MOVE ' (File creation assumed)' TO CONSOLE-LINE.
062360*    PERFORM DISPLAYER THRU DISPLAYER-EXIT.
062380     MOVE ' ' TO USER-ANS.
062400     OPEN OUTPUT QCSTMT.
062420     CLOSE QCSTMT.
062440     PERFORM EDIT-ASK2.
062460     MOVE 1 TO EDIT-EOF-SW.
062480     MOVE 'B' TO INPUT-CHAR (1).
062500     PERFORM EDIT-OPEN.
062520     MOVE 'I' TO USER-ANS. MOVE SPACE TO INPUT-CHAR (2).
062540     GO TO EDIT-INSERT.
062560 EDIT-COPY.
062580     READ QTQRYS AT END GO TO EDIT-END1.
062600     IF EDIT-DICT-SW = 0 MOVE TEMP-REC TO QCSTMT-LINE
062620        WRITE QCSTMT-LINE
062640        ELSE MOVE TEMP-REC TO FD-TRAN WRITE TRAN-REC FROM FD-TRAN.
062660     GO TO EDIT-COPY.
062680 EDIT-DELETE.
062700     MOVE 0 TO EDIT-WRITE-SW.
062720     GO TO EDIT-READ.
062740 EDIT-DICTIONARY.
062760     MOVE 0 TO EDIT-FILE-IN EDIT-EOF-SW EDIT-WRITE-SW.
062780     MOVE 1 TO EDIT-DICT-SW.
062800     GO TO EDIT-ASK3.
062820 EDIT-DISPLAY.
062840     MOVE EDIT-WORK TO CONSOLE-LINE. 
062850     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
062860 EDIT-DOWN.
062880     MOVE 5 TO I J. PERFORM EDIT-NUMJUST.
062900     IF INPUT-CHAR (5) = SPACE AND INPUT-CHAR (6) = SPACE
062920        GO TO EDIT-LINE-FEED.
062940     MOVE INPUT-CHAR (5) TO INPUT-CHAR (3).
062960     MOVE INPUT-CHAR (6) TO INPUT-CHAR (4).
062980     MOVE 'P' TO INPUT-CHAR (1). MOVE '+' TO INPUT-CHAR (2).
063000     GO TO EDIT-PRINT.
063020 EDIT-END.
063040     PERFORM EDIT-CLOSE.
063060     IF EDIT-FILE-IN = 1 PERFORM EDIT-OPEN
063080        GO TO EDIT-COPY.
063100     GO TO EDIT-END2.
063120 EDIT-END1.
063140     MOVE 0 TO EDIT-WRITE-SW. MOVE 1 TO EDIT-EOF-SW.
063160     PERFORM EDIT-CLOSE.
063180 EDIT-END2.
063200     OPEN OUTPUT QTQRYS.
063220     MOVE ' (Editor is finished)' TO CONSOLE-LINE.
063240     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
063260     CLOSE QTQRYS WITH DELETE.
063280     IF USER-ANS-4 = 'RUN ' MOVE 'RUN ' TO FOUND-WORD
063300        SET UIX TO 4 GO TO RUNNER.
063320     GO TO CENTRAL-CONTROL.
063340 EDIT-EOF.
063360     MOVE 1 TO EDIT-EOF-SW.
063380     IF INPUT-CHAR (1) = 'B' OR = 'T' OR = 'E'
063400          GO TO EDIT-READ-EXIT.
063420     IF INPUT-CHAR (2) = '-' GO TO EDIT-READ-EXIT.
063440     IF USER-ANS-4 = 'RUN ' GO TO EDIT-READ-EXIT.
063460     MOVE ' (At end of query)' TO CONSOLE-LINE.
063480     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
063500     GO TO EDIT-READ-EXIT.
063520 EDIT-FIND.
063540     MOVE ' ' TO USER-ANS-1.
063560     IF USER-ANS NOT = SPACES
063580         PERFORM EDIT-DELIM THRU EDIT-DELIM-EXIT.
063600     MOVE 1 TO CMND.
063620     IF INPUT-CHAR (2) = DELIM GO TO EDIT-ERROR.
063640     MOVE SPACE TO INPUT-CHAR (1).
063660     IF USER-ANS = SPACE MOVE FIND-LAST TO USER-ANS
063680        ELSE MOVE USER-ANS TO FIND-LAST.
063700 EDIT-FINDS.
063720     ADD 1 TO CMND.
063740     IF INPUT-CHAR (CMND) = DELIM GO TO EDIT-FIND1.
063760     IF CMND > 40 GO TO EDIT-FIND-ERROR.
063780     GO TO EDIT-FINDS.
063800 EDIT-FIND1.
063820     PERFORM EDIT-WRITE THRU EDIT-WRITE-EXIT.
063840     PERFORM EDIT-READ THRU EDIT-READ-EXIT.
063860     IF EDIT-EOF-SW = 1 GO TO EDIT-STRING-ERROR.
063880     MOVE 1 TO EDIT STNG. MOVE 3 TO CMND.
063900 EDIT-FIND2.
063920     IF INPUT-CHAR (2) = EDITOR (EDIT) GO TO EDIT-FIND3.
063940     ADD 1 TO EDIT. IF EDIT > 73 GO TO EDIT-FIND1.
063960     GO TO EDIT-FIND2.
063980 EDIT-FIND3.
064000     IF INPUT-CHAR (CMND) = DELIM PERFORM EDIT-DISPLAY
064020                             GO TO EDIT-COMMANDER.
064040     ADD 1 TO EDIT. IF EDIT > 73 GO TO EDIT-FIND1.
064060     IF INPUT-CHAR (CMND) = EDITOR (EDIT) ADD 1 TO CMND
064080        ELSE MOVE 3 TO CMND GO TO EDIT-FIND2.
064100     GO TO EDIT-FIND3.
064120 EDIT-FIND-ERROR.
064140     MOVE ' %String longer than 40' TO CONSOLE-LINE.
064160     PERFORM DISPLAYER THRU DISPLAYER-EXIT. GO TO EDIT-COMMANDER.
064180 EDIT-INSERT.
064200     MOVE 0 TO EDIT-DOT.
064220     IF INPUT-CHAR (2) = '.' MOVE 1 TO EDIT-DOT.
064240 EDIT-INSERT1.
064260     DISPLAY ' *' UPON CONSOLE WITH NO ADVANCING.
064280     MOVE SPACE TO USER-ANS. ACCEPT USER-ANS FROM TTY.
064300     IF USER-ANS = SPACE GO TO EDIT-COMMANDER.
064320     IF USER-ANS-2 = 'E ' OR USER-ANS-3 = 'E. '
064340        GO TO EDIT-COMMANDER.
064360     IF USER-ANS-4 = 'END '
064380        GO TO EDIT-COMMANDER.
064400     IF USER-ANS-5 = 'EXIT ' GO TO EDIT-COMMANDER.
064420     PERFORM EDIT-WRITE THRU EDIT-WRITE-EXIT.
064440     MOVE USER-ANS TO EDIT-WORK.
064460     MOVE 1 TO EDIT-WRITE-SW.
064480     IF EDIT-DOT = 1 GO TO EDIT-COMMANDER.
064500     GO TO EDIT-INSERT1.
064520 EDIT-LINE-FEED.
064540     PERFORM EDIT-WRITE THRU EDIT-WRITE-EXIT.
064560 EDIT-LINE-READ.
064580     PERFORM EDIT-READ THRU EDIT-READ-EXIT.
064600     IF EDIT-EOF-SW = 1 GO TO EDIT-COMMANDER.
064620     PERFORM EDIT-DISPLAY.
064640     GO TO EDIT-COMMANDER.
064660 EDIT-NUMJUST.
064680     IF INPUT-CHAR (I) NOT EQUAL TO SPACE
064700        MOVE INPUT-CHAR (I) TO INPUT-CHAR (J)
064720         ADD 1 TO J
064740         IF J NOT GREATER THAN I
064760              MOVE ' ' TO INPUT-CHAR (I).
064780     ADD 1 TO I. IF I LESS THAN MAX-UIX GO TO EDIT-NUMJUST.
064800 EDIT-OPEN.
064820     IF EDIT-FILE-IN = 0
064840        OPEN INPUT QCSTMT OUTPUT QTQRYS
064860        ELSE OPEN INPUT QTQRYS OUTPUT QCSTMT.
064880     MOVE 0 TO EDIT-LINE-CT.
064900 EDIT-PRINT.
064920     MOVE 0 TO EDIT-SHOW-CT.
064940     IF INPUT-CHAR (2) = '.' GO TO EDIT-PRINT-SHIFT.
064960     IF INPUT-CHAR (2) = '+' GO TO EDIT-PRINT1.
064980     IF INPUT-CHAR (2) = '-' GO TO EDIT-PRINT1.
065000     IF INPUT-CHAR (2) = ';' GO TO EDIT-PRINT-LINES.
065020     PERFORM EDIT-DISPLAY.
065040     GO TO EDIT-COMMANDER.
065060 EDIT-PRINT1.
065080     IF INPUT-CHAR (3) NOT NUMERIC GO TO EDIT-ERROR.
065100     MOVE INPUT-CHAR (3) TO PRINT-CT1.
065120     IF INPUT-CHAR (4) IS NUMERIC MOVE INPUT-CHAR (4) TO PRINT-CT2
065140        ELSE MOVE 0 TO PRINT-CT1
065160             MOVE INPUT-CHAR (3) TO PRINT-CT2.
065180     IF EDIT-PRINT-CT = 0 GO TO EDIT-ERROR.
065200     IF INPUT-CHAR (2) = '-' GO TO EDIT-PRINT-PRIOR.
065220 EDIT-PRINT2.
065240     IF EDIT-PRINT-CT = EDIT-SHOW-CT PERFORM EDIT-DISPLAY
065260        GO TO EDIT-COMMANDER.
065280     IF INPUT-CHAR (2) = ';' PERFORM EDIT-DISPLAY.
065300     PERFORM EDIT-WRITE THRU EDIT-WRITE-EXIT.
065320     PERFORM EDIT-READ THRU EDIT-READ-EXIT.
065340     IF EDIT-EOF-SW = 1 GO TO EDIT-COMMANDER.
065360     ADD 1 TO EDIT-SHOW-CT.
065380     GO TO EDIT-PRINT2.
065400 EDIT-PRINT-LINES.
065420     IF INPUT-CHAR (3) NOT EQUAL TO 'A' GO TO EDIT-PRINT1.
065440     PERFORM EDIT-DISPLAY.
065460     PERFORM EDIT-WRITE THRU EDIT-WRITE-EXIT.
065480     PERFORM EDIT-READ THRU EDIT-READ-EXIT.
065500     IF EDIT-EOF-SW = 1 GO TO EDIT-COMMANDER.
065520     GO TO EDIT-PRINT-LINES.
065540 EDIT-PRINT-PRIOR.
065560     SUBTRACT EDIT-PRINT-CT FROM EDIT-LINE-CT
065580        GIVING EDIT-PRINT-CT.
065600     ADD 1 TO EDIT-PRINT-CT.
065620     IF EDIT-PRINT-CT > EDIT-LINE-CT
065640        MOVE 1 TO EDIT-PRINT-CT.
065660     IF EDIT-PRINT-CT LESS THAN 1 MOVE 1 TO EDIT-PRINT-CT.
065680     PERFORM EDIT-BEGIN.
065700     GO TO EDIT-PRINT2.
065720 EDIT-PRINT-SHIFT.
065740     MOVE INPUT-CHAR (3) TO INPUT-CHAR (2).
065760     MOVE INPUT-CHAR (4) TO INPUT-CHAR (3).
065780     MOVE INPUT-CHAR (5) TO INPUT-CHAR (4).
065800     GO TO EDIT-PRINT.
065820 EDIT-REPLACE.
065840     MOVE SPACE TO EDIT-WORK.
065860     DISPLAY ' *' UPON CONSOLE WITH NO ADVANCING.
065880     ACCEPT EDIT-WORK FROM TTY.
065900     GO TO EDIT-COMMANDER.
065920 EDIT-STRING.
065940     PERFORM EDIT-DELIM THRU EDIT-DELIM-EXIT.
065960     IF INPUT-CHAR (2) = DELIM GO TO EDIT-ERROR.
065980     MOVE 2 TO CMND.
066000 EDIT-STRINGS.
066020     ADD 1 TO CMND. IF CMND > 80 GO TO EDIT-FIND-ERROR.
066040     IF INPUT-CHAR (CMND) NOT EQUAL TO DELIM GO TO EDIT-STRINGS.
066060 EDIT-STRINGT.
066080     ADD 1 TO CMND. IF CMND > 80 GO TO EDIT-FIND-ERROR.
066100     IF INPUT-CHAR (CMND) NOT EQUAL TO DELIM GO TO EDIT-STRINGT.
066120     MOVE 0 TO STRING-ALL STRING-NOP.
066140     ADD 1 TO CMND. IF INPUT-CHAR (CMND) = 'A' ADD 1 TO STRING-ALL.
066160     IF INPUT-CHAR (CMND) = 'N' ADD 1 TO STRING-NOP.
066180     ADD 1 TO CMND. IF INPUT-CHAR (CMND) = 'L' ADD 1 TO STRING-ALL.
066200     IF INPUT-CHAR (CMND) = 'O' ADD 1 TO STRING-NOP.
066220     ADD 1 TO CMND. IF INPUT-CHAR (CMND) = 'L' ADD 1 TO STRING-ALL.
066240     IF INPUT-CHAR (CMND) = 'P' ADD 1 TO STRING-NOP.
066260     IF STRING-ALL = 3 MOVE 1 TO STRING-ALL
066280        ELSE MOVE 0 TO STRING-ALL.
066300     IF STRING-NOP = 3 MOVE 1 TO STRING-NOP
066320        ELSE MOVE 0 TO STRING-NOP.
066340     MOVE SPACE TO STRING-WORK.
066360     MOVE 0 TO EDIT STNG STRING-FOUND. MOVE 2 TO CMND.
066380 EDIT-STRING1.
066400     ADD 1 TO EDIT. IF EDIT > 73 GO TO EDIT-STRING7.
066420     IF INPUT-CHAR (2) = EDITOR (EDIT) MOVE EDIT TO EDIT-SHIFT
066440        GO TO EDIT-STRING2.
066460     ADD 1 TO STNG. IF STNG > 200 GO TO EDIT-STRING6.
066480     MOVE EDITOR (EDIT) TO STRIING (STNG).
066500     GO TO EDIT-STRING1.
066520 EDIT-STRING2.
066540     ADD 1 TO CMND.
066560     IF INPUT-CHAR (CMND) = DELIM MOVE 1 TO STRING-FOUND
066580        GO TO EDIT-STRING3.
066600     ADD 1 TO EDIT. IF EDIT > 73 GO TO EDIT-STRING7.
066620     IF INPUT-CHAR (CMND) = EDITOR (EDIT) GO TO EDIT-STRING2.
066640     MOVE EDIT-SHIFT TO EDIT.
066660     ADD 1 TO STNG. IF STNG > 200 GO TO EDIT-STRING6.
066680     MOVE EDITOR (EDIT) TO STRIING (STNG).
066700     MOVE 2 TO CMND.
066720     GO TO EDIT-STRING1.
066740 EDIT-STRING3.
066760     ADD 1 TO CMND.
066780     IF INPUT-CHAR (CMND) = DELIM MOVE 2 TO CMND
066800        GO TO EDIT-STRING1.
066820     ADD 1 TO STNG. IF STNG > 200 GO TO EDIT-STRING6.
066840     MOVE INPUT-CHAR (CMND) TO STRIING (STNG).
066860     GO TO EDIT-STRING3.
066880 EDIT-STRING4.
066900     MOVE 0 TO STRING-FOUND.
066920     IF STRING-EXT NOT = SPACES
066940         MOVE SPACES TO STRING-EXT GO TO EDIT-STRING6.
066960     MOVE STRING-WORK TO EDIT-WORK. MOVE SPACE TO STRING-WORK.
066980     IF STRING-NOP = 0 PERFORM EDIT-DISPLAY.
067000 EDIT-STRING5.
067020     IF STRING-ALL = 0 GO TO EDIT-COMMANDER.
067040     PERFORM EDIT-WRITE THRU EDIT-WRITE-EXIT.
067060     PERFORM EDIT-READ THRU EDIT-READ-EXIT.
067080     IF EDIT-EOF-SW = 1 GO TO EDIT-COMMANDER.
067100     MOVE 0 TO EDIT STNG. MOVE 2 TO CMND.
067120     GO TO EDIT-STRING1.
067140 EDIT-STRING6.
067160     IF STRING-NOP = 0
067180         MOVE ' %Possible string overflow' TO CONSOLE-LINE.
067200     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
067220     MOVE SPACES TO STRING-EXT.
067240     PERFORM EDIT-STRING4.
067260     GO TO EDIT-COMMANDER.
067280 EDIT-STRING7.
067300     IF STRING-FOUND = 1 GO TO EDIT-STRING4.
067320     IF STRING-ALL = 1 GO TO EDIT-STRING5.
067340 EDIT-STRING-ERROR.
067360     MOVE ' %String not found' TO CONSOLE-LINE.
067380     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
067400     GO TO EDIT-COMMANDER.
067420 EDIT-UP.
067440     MOVE 3 TO I J. PERFORM EDIT-NUMJUST.
067460     IF INPUT-CHAR (3) = SPACE AND INPUT-CHAR (4) = SPACE
067480        MOVE 1 TO INPUT-CHAR (3).
067500     MOVE 'P' TO INPUT-CHAR (1). MOVE '-' TO INPUT-CHAR (2).
067520     GO TO EDIT-PRINT.
067540 EDIT-WRITE.
067560     IF EDIT-WRITE-SW = 0 GO TO EDIT-WRITE-EXIT.
067580     IF EDITOR1 NUMERIC AND EDITOR2 NUMERIC GO TO EDIT-WRITE1.
067600     IF EDITOR1 = SPACE AND EDITOR2 = SPACE GO TO EDIT-WRITE1.
067620     IF EDITOR1 = 'F' AND EDITOR2 = 'D' GO TO EDIT-WRITE1.
067640     IF EDITOR1 = 'P' AND EDITOR2 = 'D' GO TO EDIT-WRITE1.
067660     IF EDITOR1 = 'D' AND EDITOR2 = 'D' GO TO EDIT-WRITE1.
067680     MOVE 78 TO I. MOVE 80 TO J.
067700 EDIT-WRITE-SHIFT.
067720     MOVE EDITOR (I) TO EDITOR (J).
067740     SUBTRACT 1 FROM I. SUBTRACT 1 FROM J.
067760     IF I NOT EQUAL TO 0 GO TO EDIT-WRITE-SHIFT.
067780     MOVE SPACE TO EDITOR (1). MOVE SPACE TO EDITOR (2).
067800 EDIT-WRITE1.
067820     IF EDIT-FILE-IN = 0
067840        WRITE TEMP-REC FROM EDIT-WORK
067860        ELSE WRITE QCSTMT-LINE FROM EDIT-WORK.
067880     MOVE 0 TO EDIT-WRITE-SW.
067900     ADD 1 TO EDIT-LINE-CT.
067920 EDIT-WRITE-EXIT.  EXIT.
067940
067960 EDIT-DELIM.
067980*    *IF ENDING DELIMITER LEFT OFF, FILL IT IN*
068000     MOVE 73 TO CMND.
068020 EDIT-DELIM1.
068040     IF CMND = 2 MOVE DELIM TO INPUT-CHAR (2)
068060         GO TO EDIT-DELIM-EXIT.
068080     IF INPUT-CHAR (CMND) = DELIM GO TO EDIT-DELIM-EXIT.
068100     IF INPUT-CHAR (CMND) = ' ' SUBTRACT 1 FROM CMND
068120         GO TO EDIT-DELIM1.
068140*    *FOUND END OF STRING BUT NO DELIM; PUT IT IN*
068160     ADD 1 TO CMND.
068180     IF CMND > 73 MOVE 73 TO CMND.
068200     MOVE DELIM TO INPUT-CHAR (CMND).
068220 EDIT-DELIM-EXIT.
068240     EXIT.
068260
068280 EDIT-EXIT. EXIT.
068300
068320***************************************************
068340* SUBROUTINE TO CHECK NAMES FOR ILLEGAL CHARS
068360* AND/OR RESERVED WORDS*
068380***************************************************
068400 CHECK-NAME.
068420     MOVE 0 TO NAME-ERR-FLAG.
068440     IF FOUND-WORD = SPACES DISPLAY FD-MSG-11 UPON CONSOLE
068460         MOVE 1 TO NAME-ERR-FLAG GO TO CHECK-NAME-EXIT.
068480     MOVE FOUND-WORD TO EDIT-WORK.
068500     IF CONV-MODE-FLAG = 1
068520         PERFORM FIND-WORD THRU FIND-WORD-EXIT
068540         IF FOUND-WORD-1 NOT = SPACES
068560             DISPLAY FD-MSG-15 UPON CONSOLE
068580             SUBTRACT 1 FROM PX
068600             GO TO CHECK-NAME-EXIT.
068620     MOVE EDIT-WORK TO FOUND-WORD.
068630     MOVE EDIT-WORK TO FOUND6-WORD.
068640     SET FWX TO 1.
068660 CHECK-NAME1.
068680     MOVE FOUND-CHAR (FWX) TO ELEM-CHAR.
068700     IF ELEM-CHAR = ' ' GO TO CHECK-NAME-RWD.
068720     IF ELEM-CHAR IS ALPHABETIC GO TO CHECK-NAME2.
068740     IF ELEM-CHAR IS NUMERIC GO TO CHECK-NAME2.
068760     IF ELEM-CHAR = '-' GO TO CHECK-NAME2.
068780     DISPLAY FD-MSG-16 UPON CONSOLE.
068800     MOVE 1 TO NAME-ERR-FLAG.
068820     GO TO CHECK-NAME-EXIT.
068840 CHECK-NAME2.
068860     SET FWX UP BY 1.
068880     IF FWX NOT GREATER THAN MAX-NAMELEN
068900         GO TO CHECK-NAME1.
068920
068940 CHECK-NAME-RWD.
068960     SET RWX TO 1.
068980 CHECK-NAME-RWD1.
069000     IF FOUND6-WORD-18 = RESERVED-WORD (RWX)
069020         DISPLAY FD-MSG-18 UPON CONSOLE
069040         MOVE 1 TO NAME-ERR-FLAG
069060         GO TO CHECK-NAME-EXIT.
069080     IF RWX LESS THAN MAX-RWX
069100         SET RWX UP BY 1 GO TO CHECK-NAME-RWD1.
069120
069140 CHECK-NAME-EXIT.
069160     EXIT.
069180
069200***************************************************
069220* SUBROUTINE TO CHECK AND/OR REQUEST QUERY NAMES;
069240* INPUT NAME (IF ANY) IS IN FOUND-WORD; ANY NAME
069260* OBTAINED BY THIS SUBROUTINE IS LEFT IN FOUND-WORD
069280* AND CURRENT-QUERY-NAME.
069300***************************************************
069320 GET-QUERY-NAME.
069340     IF FOUND-WORD-1 = ' '
069360         DISPLAY ' *Query name: ' UPON CONSOLE WITH NO ADVANCING
069380         ACCEPT USER-ANS FROM TTY
069400         SET UIX TO 1
069420         PERFORM FIND-WORD THRU FIND-WORD-EXIT
069440         GO TO GET-QUERY-NAME.
069460     PERFORM CHECK-NAME THRU CHECK-NAME-EXIT.
069480     IF NAME-ERR-FLAG = 1 MOVE ' ' TO FOUND-WORD-1
069500         GO TO GET-QUERY-NAME.
069520     MOVE FOUND6-WORD-20 TO CURRENT-QUERY-NAME.
069540 GET-QUERY-NAME-EXIT.
069560     EXIT.
069580
069600******************************************************
069620* SUBROUTINE TO GET A DICTIONARY NAME. NAME IS LEFT
069640* IN FOUND-WORD.
069660******************************************************
069680
069700 GET-DICT-NAME.
069720     IF FOUND-WORD-1 = ' ' DISPLAY
069740         ' *Dictionary name: ' UPON CONSOLE WITH NO ADVANCING
069760         ACCEPT USER-ANS FROM TTY
069780         SET UIX TO 1
069800         PERFORM FIND-WORD THRU FIND-WORD-EXIT
069820         GO TO GET-DICT-NAME.
069840 GET-DICT-NAME-EXIT.
069860     EXIT.
069880
069900*****************************************************
069920* SUBROUTINE TO CHECK PIC IN CD-PICT VERSUS
069940* ITEM TYPE SCALE AND INSERTION CHARACTERS. IF DISCREPANCY
069960* SET EDIT-ERROR-FLAG TO 1 .
069980*******************************************************
070000 CHECK-PICT.
070020     MOVE 0 TO J.
070040     MOVE 0 TO EDIT-ERROR-FLAG.
070060     IF CD-PICT = SPACES GO TO CHECK-PICT-EXIT.
070080     IF CD-TYPE-X = '1' OR = 'A'
070100         GO TO CHECK-PICT-ALPHA.
070120     GO TO CHECK-PICT-NUM.
070140 CHECK-PICT-ALPHA.
070160*   *CHECK INSERTION POSITIONS 'X' IN ALPHABETIC ITEM*
070180     EXAMINE CD-PICT TALLYING ALL 'X'.
070200     IF TALLY NOT = CD-NCHARS GO TO CHECK-PICT-ERROR.
070220     GO TO CHECK-PICT-EXIT.
070240 CHECK-PICT-NUM.
070260*   *CHECK INSERTION CHARS '9' 'Z' CURRENCY-IS FOR NUMERIC ITEM*
070280     MOVE 0 TO K  L.
070300     SET PIX TO 1.
070320 CHECK-PICT-DEC.
070340     IF PIX GREATER THAN 19 GO TO CHECK-PICT-DEC2.
070360     MOVE CD-PICTCHAR (PIX) TO ELEM-CHAR.
070380     IF ELEM-CHAR = ' ' GO TO CHECK-PICT-DEC2.
070400     IF ELEM-CHAR = '9' OR 'Z' OR 'R' ADD 1 TO L.
070420     IF ELEM-CHAR = CURRENCY-IS ADD 1 TO L MOVE 1 TO J.
070440     IF ELEM-CHAR NOT = DECIMAL-IS  SET PIX UP BY 1
070460         GO TO CHECK-PICT-DEC.
070480 CHECK-PICT-DEC1.
070500     IF ELEM-CHAR = '9' OR 'Z' OR 'R' OR CURRENCY-IS
070520         ADD 1 TO K  ADD 1 TO L.
070540     SET PIX UP BY 1.
070560     IF PIX GREATER THAN 19 GO TO CHECK-PICT-DEC2.
070580     MOVE CD-PICTCHAR (PIX) TO ELEM-CHAR.
070600     IF ELEM-CHAR NOT = ' ' GO TO CHECK-PICT-DEC1.
070620 CHECK-PICT-DEC2.
070640     SUBTRACT J FROM L.
070660*   *ABOVE TAKES ACCOUNT OF LEADING $*.
070680     IF L NOT = CD-NCHARS GO TO CHECK-PICT-ERROR.
070700     IF K NOT = CD-SCALE  GO TO CHECK-PICT-ERROR.
070720     GO TO CHECK-PICT-EXIT.
070740 CHECK-PICT-ERROR.
070760     MOVE 1 TO EDIT-ERROR-FLAG.
070780 CHECK-PICT-EXIT.
070800     EXIT.
070820*********************************************************
070840* SUBROUTINE TO PEEL EXTRA BLANKS OUT OF MESSAGES.
070860*********************************************************
070880 BLANK-PEELOUT.
070900     SET PRX TO 1.
070920     MOVE 1 TO I J.
070940
070960 BLANK-PEELOUT1.
070980     IF PRX GREATER THAN MAX-PRX
071000         SET PRX TO J GO TO BLANK-PEELOUT3.
071020     MOVE PRINT-CHAR (PRX) TO ELEM-CHAR.
071040     IF I = 0 AND ELEM-CHAR = ' ' NEXT SENTENCE
071060         ELSE MOVE ELEM-CHAR TO PRINT-CHAR (J)
071080         ADD 1 TO J
071100         IF ELEM-CHAR = SPACE MOVE 0 TO I
071120             ELSE MOVE 1 TO I.
071140     SET PRX UP BY 1.
071160     GO TO BLANK-PEELOUT1.
071180
071200 BLANK-PEELOUT3.
071220     IF PRX NOT GREATER THAN MAX-PRX
071240         MOVE ' ' TO PRINT-CHAR (PRX)
071260         SET PRX UP BY 1
071280         GO TO BLANK-PEELOUT3.
071300
071320 BLANK-PEELOUT-EXIT.
071340     EXIT.
071360
071380
071400
071420********************************************************
071440*    *SUBROUTINES TO LOOK FOR FILES*.
071460********************************************************
071480 LOOK-FOR-QCSTMT.
071500     MOVE ' ' TO DEVICER.   MOVE 0 TO PROJ USER.
071520     ENTER MACRO IQLOOK USING DEVICER QCNNNSTMP PROJ USER I.
071540 LOOK-FOR-QCDICT.
071560     MOVE ' ' TO DEVICER.   MOVE 0 TO PROJ USER.
071580     ENTER MACRO IQLOOK USING DEVICER QCNNNDTMP PROJ USER I.
071600     IF I NOT EQUAL TO -1 OPEN OUTPUT QCDICT
071620         MOVE SPACE TO TRAN-REC WRITE TRAN-REC
071640         CLOSE QCDICT.
071660 LOOK-FOR-QPQRYS.
071680     MOVE ' ' TO DEVICER.   MOVE 0 TO PROJ USER.
071700     ENTER MACRO IQLOOK USING DEVICER QPQRYSSEQ PROJ USER I.
071720     IF I NOT EQUAL TO -1 OPEN OUTPUT QPQRYS
071740         MOVE SPACE TO QPQRYS-LINE WRITE QPQRYS-LINE
071760         CLOSE QPQRYS.
071780 LOOK-FOR-QPDICT.
071800     MOVE ' ' TO DEVICER.   MOVE 0 TO PROJ USER.
071820     ENTER MACRO IQLOOK USING DEVICER QPDICTSEQ PROJ USER I.
071840     IF I NOT EQUAL TO -1 OPEN OUTPUT QPDICT
071860         MOVE SPACE TO DICT-REC WRITE DICT-REC
071880         CLOSE QPDICT.
071900 LOOK-FOR-QLEXEC.
071920     MOVE ' ' TO DEVICER.  MOVE 0 TO PROJ USER.
071940     ENTER MACRO IQLOOK USING DEVICER QLNNNELPT PROJ USER I.
071960     IF I NOT EQUAL TO -1 OPEN OUTPUT QLEXEC
071980         MOVE SPACE TO QLEXEC-LINE WRITE QLEXEC-LINE
072000         CLOSE QLEXEC.
072020 LOOK-FOR-EXIT.
072040     EXIT.
072060
072080*********************************************************
072100* SUBROUTINE 'FILE-PARSER' TO PARSE A FILE NAME FROM FORM
072120* FFF.EEE TO FFFBBBEEE FOR ANY LENGTH FFF 1 TO 6 CHARACTERS.
072140* RESULT IS LEFT IN PARSED-FILE-NAME; INPUT TAKEN FROM FOUND-WORD
072160*********************************************************
072180 FILE-PARSER.
072200     EXAMINE FOUND-WORD TALLYING UNTIL FIRST '.'.
072220     MOVE SPACES TO PARSED-FILE-NAME.
072240     IF TALLY GREATER THAN 6 MOVE FOUND-WORD-9 TO PARSED-FILE-NAME
072260         GO TO FILE-PARSER-EXIT.
072280     MOVE TALLY TO I.
072300     ENTER MACRO IQSX76 USING I FOUND-WORD
072320         CONST1 PARSED-FILE-NAME CONST1.
072340     ADD 2 TO I.
072360     ENTER MACRO IQSX76 USING CONST3 FOUND-WORD
072380         I PARSED-FILE-NAME CONST7.
072400 FILE-PARSER-EXIT.
072420     EXIT.