Trailing-Edge
-
PDP-10 Archives
-
iqlv30
-
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 DECSYSTEM-10 VERSION THAT
000660 USES THE BUILT-IN TEXT EDITOR.
000700
000720 ENVIRONMENT DIVISION.
000740
000760 CONFIGURATION SECTION.
000780 SOURCE-COMPUTER. DECSYSTEM-10.
000800 OBJECT-COMPUTER. DECSYSTEM-10.
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 PPN '.
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 ' *PPN as [77777,77777]:_____________'.
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 PPN. 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-10 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 EDIT-ASK.
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.
024110 IF FOUND6-WORD-3 = 'SOS' GO TO SOS-ER.
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 PPN:'
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 PPN. 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 PPN 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 PPN: ' 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.