Trailing-Edge
-
PDP-10 Archives
-
BB-H548C-BM
-
iql-source/iqu.cbl
There are 2 other files named iqu.cbl in the archive. Click here to see a list.
000100 IDENTIFICATION DIVISION.
000120 PROGRAM-ID. IQU.
000140 DATE-WRITTEN.
000160 DATE-COMPILED.
000180
000200 SECURITY. COPYRIGHT 1981 AZREX INC
000220 ALL RIGHTS RESERVED.
000240
000260 REMARKS. STAND-ALONE MODULE FOR INPUT AND/OR
000280 UPDATE OF SEQUENTIAL OR ISAM FILES;
000300 VERSION 3A, EDIT 0.
000450
000400 ENVIRONMENT DIVISION.
000420 CONFIGURATION SECTION.
000440 SOURCE-COMPUTER. DECSYSTEM-20.
000460 OBJECT-COMPUTER. DECSYSTEM-20.
000480 SPECIAL-NAMES. CHANNEL (1) IS TOP-OF-PAGE
000500 CONSOLE IS TTY.
000520
000540 INPUT-OUTPUT SECTION.
000560 FILE-CONTROL.
000580 SELECT QPDICT ASSIGN TO DSK.
000600 SELECT QTDICT ASSIGN TO DSK.
000620 SELECT QIFLE7 ASSIGN TO DSK.
000640 SELECT QOFLE7 ASSIGN TO DSK.
000660 SELECT QIFLE6 ASSIGN TO DSK.
000680 SELECT QOFLE6 ASSIGN TO DSK.
000700 SELECT QISAM6 ASSIGN TO DSK
000720 ACCESS IS INDEXED
000760 RECORD KEY IS QISAM6-RECKEY
000780 SYMBOLIC KEY IS QISAM6-SYMKEY.
000800 SELECT QISAM7 ASSIGN TO DSK
000840 ACCESS IS INDEXED
000860 RECORD KEY IS QISAM7-RECKEY
000880 SYMBOLIC KEY IS QISAM7-SYMKEY.
000900 SELECT QLUPDT ASSIGN TO DSK.
000920 SELECT QTINFO ASSIGN TO DSK.
000940 I-O-CONTROL.
000960 SAME AREA FOR QIFLE7 QIFLE6 QISAM6 QISAM7 QTINFO.
000980 SAME AREA FOR QOFLE7 QOFLE6.
001000
001020 DATA DIVISION.
001040 FILE SECTION.
001060
001080 FD QPDICT
001100 VALUE OF IDENTIFICATION IS QPDICTSEQ
001120 LABEL RECORD IS STANDARD
001140 BLOCK CONTAINS 0 RECORDS
001160 RECORD CONTAINS 150 CHARACTERS
001180 DATA RECORD IS QPDICT-REC.
001200 01 QPDICT-REC PIC X(150)
001220 USAGE IS DISPLAY-7.
001240
001260 FD QTDICT
001280 VALUE OF IDENTIFICATION IS QTDICT-ID
001300 BLOCK CONTAINS 0 RECORDS
001320 RECORD CONTAINS 150 CHARACTERS
001340 DATA RECORD IS QTDICT-REC.
001360 01 QTDICT-REC PIC X(150)
001380 USAGE IS DISPLAY-7.
001400
001420 FD QIFLE7
001440 VALUE OF IDENTIFICATION IS QIFLE7-ID
001460 LABEL RECORD IS STANDARD
001480 BLOCK CONTAINS 0 RECORDS
001500 DATA RECORD IS QIFLE7-REC.
001520 01 QIFLE7-REC USAGE IS DISPLAY-7.
001540 02 FILLER PIC X(3410).
001560
001580 FD QIFLE6
001600 VALUE OF IDENTIFICATION IS QIFLE6-ID
001620 LABEL RECORD IS STANDARD
001640 BLOCK CONTAINS 0 RECORDS
001660 DATA RECORD IS QIFLE6-REC.
001680 01 QIFLE6-REC USAGE IS DISPLAY-6.
001690 02 FILLER PIC X(4092).
001760
001780 FD QOFLE7
001800 VALUE OF IDENTIFICATION IS QOFLE7-ID
001820 LABEL RECORD IS STANDARD
001840 BLOCK CONTAINS 0 RECORDS
001860 DATA RECORD IS QOFLE7-REC.
001880 01 QOFLE7-REC USAGE IS DISPLAY-7.
001900 02 FILLER PIC X(3410).
001920
001940 FD QOFLE6
001960 VALUE OF IDENTIFICATION IS QOFLE6-ID
001980 LABEL RECORD IS STANDARD
002000 BLOCK CONTAINS 0 RECORDS
002020 DATA RECORD IS QOFLE6-REC.
002040 01 QOFLE6-REC USAGE IS DISPLAY-6.
002060 02 FILLER PIC X(4092).
002080
002100 FD QLUPDT
002120 VALUE OF IDENTIFICATION IS QLNNNU-ID
002140 RECORD CONTAINS 132 CHARACTERS
002160 LABEL RECORDS ARE STANDARD
002180 BLOCK CONTAINS 0 RECORDS
002200 DATA RECORD IS QLUPDT-REC.
002220 01 QLUPDT-REC USAGE IS DISPLAY-7.
002240 02 FILLER PIC X(4092).
002260
002280 FD QISAM6
002300 VALUE OF IDENTIFICATION IS QIFLE6-ID
002320 LABEL RECORDS ARE STANDARD
002340 BLOCK CONTAINS 10 RECORDS
002360 DATA RECORD IS QISAM6-REC.
002370* *NOTE THAT BOTH RECORD AND KEY BELOW -MUST- BE WORD-ALIGNED
002380 01 QISAM6-REC DISPLAY-6.
002390 02 QISAM6-RECKEY PIC X(30).
002400 02 FILLER PIC X(4062).
002404
002440 FD QISAM7
002460 VALUE OF IDENTIFICATION IS QIFLE7-ID
002480 LABEL RECORDS ARE STANDARD
002500 BLOCK CONTAINS 10 RECORDS
002520 DATA RECORD IS QISAM7-REC.
002530* *NOTE THAT BOTH RECORD AND KEY BELOW -MUST- BE WORD-ALIGNED
002540 01 QISAM7-REC USAGE IS DISPLAY-7.
002550 02 QISAM7-RECKEY PIC X(30).
002560 02 FILLER PIC X(3380).
002600
002620 FD QTINFO
002640 VALUE OF ID IS QTINFO-ID
002660 LABEL RECORDS ARE STANDARD
002680 BLOCK CONTAINS 0 RECORDS
002700 DATA RECORD IS QTINFO-REC.
002720
002740 01 QTINFO-REC USAGE IS DISPLAY-6.
002760 02 FILLER PIC X(6).
002780 02 INFO-IQU-FLAG PIC X.
002800 02 FILLER PIC XX.
002820 02 INFO-MODE-FLAG PIC S9.
002840 88 NO-ACTION VALUE 0.
002860 88 READ-ONLY VALUE 1.
002880 88 DO-INPUT VALUE 2.
002900 88 DO-CHANGES VALUE 3.
002920 02 FILLER PIC XXX.
002940 02 INFO-DICT-NAME PIC X(30).
002960 02 FILLER PIC X(30).
002980 02 INFO-FILE-NAME PIC X(9).
003000 02 FILLER PIC X(8).
003040 WORKING-STORAGE SECTION.
000000*
000000 01 COPYRIGHT-NOTICE PIC X(50) VALUE
000000 "COPYRIGHT 1981 - AZREX, INC. - ALL RIGHTS RESERVED".
000000*
003050 01 UNIVERSAL-PASSWORD PIC X(6) VALUE 'DRAGON'.
003060
003080**FLAGS FOLLOW**
003100
003120 01 FLAGS.
003140 02 ALL-SPACES-FLAG PIC 9 COMP VALUE 0.
003160 02 ALL-FLAG PIC 9 COMP VALUE 0.
003180 02 CHANGES-FLAG PIC 9 COMP VALUE 0.
003200 02 DECIMAL-FLAG PIC 9 COMP VALUE 0.
003220 02 ENTRY-ERROR PIC 9 COMP VALUE 0.
003240 02 FIND-AHEAD-FLAG PIC 9 COMP VALUE 1.
003260 02 FIND-ERR-FLAG PIC 9 COMP VALUE 0.
003280 02 FINDING-FLAG PIC 9 COMP VALUE 0.
003300 02 FIND-WRITE-FLAG PIC 9 COMP VALUE 1.
003320 02 FIRST-FLAG PIC 9 COMP VALUE 0.
003360 02 INPUT-OPEN-FLAG PIC 9 COMP VALUE 0.
003380 88 INPUT-OPEN VALUE 1.
003400 88 INPUT-CLOSED VALUE 0.
003420 02 LITERAL-VAL-FLAG PIC 9 COMP VALUE 0.
003440 02 MINUS-FLAG PIC 9 COMP VALUE 0.
003460 02 MODE-FLAG PIC 9 COMP VALUE 0.
003480 02 MORE-DICT-FLAG PIC 9 COMP VALUE 0.
003500 02 MULT-RT-FLAG PIC 9 COMP VALUE 0.
003520 02 NON-FD-ENTRY PIC 9 COMP VALUE 0.
003540 02 NUM-VAL-FLAG PIC 9 COMP VALUE 0.
003560 02 OUTPUT-OPEN-FLAG PIC 9 COMP VALUE 0.
003580 88 OUTPUT-OPEN VALUE 1.
003600 88 OUTPUT-CLOSED VALUE 0.
003620 02 RANDOM-READ-FLAG PIC 9 COMP VALUE 0.
003640 88 SEQ-READ VALUE 0.
003660 88 RANDOM-READ VALUE 1.
003680 02 READ-FLAG PIC 9 COMP VALUE 0.
003700 88 AT-START-OF-FILE VALUE 3.
003720 88 AT-END-OF-FILE VALUE 2.
003740 88 GOOD-RECORD-READ VALUE 1.
003760 88 BAD-RECORD-READ VALUE 0.
003780 02 REC-FLAG PIC 9 COMP VALUE 0.
003800 88 END-OF-INPUT-NOWRITE VALUE 3.
003820 88 END-OF-INPUT-WRITE VALUE 2.
003840 88 GOOD-RECORD-WRITE VALUE 1.
003860 88 BAD-RECORD-IGNORE VALUE 0.
003900 02 SPECIAL-ITM-FLAG PIC 9 COMP VALUE 0.
003904 02 SUSPECT-COMMA-FLAG PIC 9 COMP VALUE 0.
003920 02 WRITE-FLAG PIC 9 COMP VALUE 0.
003940 88 OK-TO-WRITE VALUE 1.
003960 88 DO-NOT-WRITE VALUE 0.
003980 02 VERIFY-FLAG PIC 9 COMP VALUE 1.
004000
004020**WORKING COMPUTATIONAL ITEMS FOLLOW**
004040
004060 01 COMP-WORKERS.
004080 02 BLKFACT PIC S9(8) COMP VALUE 0.
004100 02 CONST-ZERO PIC S9(8) COMP VALUE 0.
004120 02 CONST1 PIC S9(8) COMP VALUE 1.
004140 02 CONST3 PIC S9(8) COMP VALUE 3.
004160 02 CONST6 PIC S9(8) COMP VALUE 6.
004180 02 CONST7 PIC S9(8) COMP VALUE 7.
004200 02 CONST12 PIC S9(8) COMP VALUE 12.
004204 02 CONST30 PIC S9(8) COMP VALUE 30.
004220 02 CORE-DATA-MODE PIC S9(8) COMP VALUE 0.
004240 02 CURRENT-COMMAND PIC S9(8) COMP VALUE 0.
004260 02 CURRENT-DD-NO PIC S9(8) COMP VALUE 1.
004280 02 DD-NO PIC S9(8) COMP VALUE 1.
004300 02 DICT-CAP PIC S9(8) COMP VALUE 99.
004320 02 DICT-ENTRIES PIC S9(8) COMP VALUE 0.
004340 02 DISPLAY-MAX PIC S9(8) COMP VALUE 72.
004380 02 DP PIC S9(8) COMP VALUE 0.
004400 02 END-COL PIC S9(8) COMP VALUE 768.
004420 02 FILE-RECORD-MODE PIC S9(8) COMP VALUE 0.
004500 02 I PIC S9(8) COMP VALUE 1.
004504 02 ITEMS-RECD-CTR PIC S9(8) COMP VALUE 0.
004560 02 J PIC S9(8) COMP VALUE 0.
004600 02 KEYLEN PIC S9(8) COMP VALUE 0.
004620 02 KEYLOC PIC S9(8) COMP VALUE 0.
004640 02 KEYSIGN PIC S9(8) COMP VALUE 0.
004660 02 KEYTYPE PIC S9(8) COMP VALUE 0.
004680 02 L PIC S9(8) COMP VALUE 1.
004684 02 LAST-LEGAL-ANX PIC S9(8) COMP VALUE 1.
004688 02 LAST-LEGAL-FWX PIC S9(8) COMP VALUE 1.
004690 02 M PIC S9(8) COMP VALUE 1.
004895 02 MAX-ANX PIC S9(8) COMP VALUE 72.
004700 02 MAX-CHG-ITEMS PIC S9(8) COMP VALUE 15.
004720 02 MAX-FIND-ITEMS PIC S9(8) COMP VALUE 15.
004740 02 MAX-ITEMLEN PIC S9(8) COMP VALUE 54.
004760 02 MAX-ITEMLEN-UP1 PIC S9(8) COMP VALUE 55.
004764 02 MAX-FWX PIC S9(8) COMP VALUE 72.
004764 02 MAX-LONG-ITEMLEN PIC S9(8) COMP VALUE 354.
004780 02 MAX-LST-ITEMS PIC S9(8) COMP VALUE 15.
004800 02 MAX-PRINT-CHARS PIC S9(8) COMP VALUE 80.
004840 02 NC PIC S9(8) COMP VALUE 1.
004860 02 NO-COLS PIC S9(8) COMP VALUE 72.
004880 02 PREV-START-ANX PIC S9(8) COMP VALUE 0.
004890 02 PICT-IN PIC X(19) DISPLAY-6 VALUE ' '.
004900 02 PROMPT-CAP PIC S9(8) COMP VALUE 64.
004902 02 RD-NO PIC S9(8) COMP VALUE 0.
004920 02 READ-COUNT PIC S9(8) COMP VALUE 0.
004924 02 REAL-FCHAR PIC S9(8) COMP VALUE 1.
004940 02 RECLEN PIC S9(8) COMP VALUE 0.
004960 02 REC-COUNT PIC S9(8) COMP VALUE 0.
004980 02 REC-COUNT1 PIC S9(8) COMP VALUE 0.
005000 02 REL-INCR PIC S9(8) COMP VALUE 0.
005040 02 START-ANX PIC S9(4) COMP VALUE 1.
005060 02 START-COL PIC S9(8) COMP VALUE 1.
005070 02 TMPWRK PIC S9(8) COMP VALUE 0.
005074 02 TERM-CHARS PIC S9(8) COMP VALUE 72.
005075 02 TRUE-TYPEV PIC S9(8) COMP VALUE 0.
005080 02 WORKDEX PIC S9(8) COMP VALUE 0.
005100 02 WORKX PIC S9(8) COMP VALUE 0.
005120 02 WRITE-COUNT PIC S9(8) COMP VALUE 0.
005140
005160**SYMBOLIC KEYS FOLLOW **
005180 01 QISAM6-SYMKEY PIC X(30) USAGE IS DISPLAY-6.
005200 01 QISAM7-SYMKEY PIC X(30) USAGE IS DISPLAY-7.
005220 01 LAST-QISAM6-SYMKEY PIC X(30) USAGE IS DISPLAY-6.
005240 01 LAST-QISAM7-SYMKEY PIC X(30) USAGE IS DISPLAY-7.
005260**MISC ALPHA & STRAIGHT NUM ITEMS FOLLOW**
005262
005264 01 HIDDEN-ASCII PIC S9(10) COMP VALUE 29691190.
005266 01 FILLER REDEFINES HIDDEN-ASCII DISPLAY-7.
005268 02 ASCII-NULL PIC X.
005270 02 ASCII-BELL PIC X.
005272 02 ASCII-LF PIC X.
005274 02 ASCII-CR PIC X.
005276 02 ASCII-ESC PIC X.
005278 01 MASK1-7 DISPLAY-7.
005280 02 MASK1-6.
005281 04 MASK1 PIC X.
005282 04 FILLER PIC XXXXX.
005283 02 MASK7 PIC X.
005300 01 ALPHA-WORKERS DISPLAY-7.
005320 02 ELEM-CHAR PIC X.
005224 02 PRIOR-ELEM-CHAR PIC X VALUE SPACE.
005340 02 CURRENT-QUOTE PIC X VALUE SPACE.
005360 02 SOUGHT-DICT-NAME PIC X(30) VALUE SPACES.
005380 02 CHAR-WORK.
005400 04 CHAR-WORK9.
005420 06 CHAR-WORK7.
005440 08 CHAR-WORK3 PIC XXX.
005500 08 FILLER PIC X(4).
005520 06 FILLER PIC XX.
005560 02 ABS-CHAR PIC 9 VALUE ZERO.
005600 02 WORK-FILENAME PIC X(9) VALUE SPACES.
005620 02 EOF-MSG PIC X(19) VALUE
005640 ' (At end of file)'.
005660 02 BEG-OF-FILE-MSG PIC X(24) VALUE
005680 ' (At beginning of file)'.
005700
005702 01 PICT-WORK PIC X(21).
005704
005720**MISCELLANEOUS BUFFERS FOLLOW**
005740
005760 01 DISPLAY-LINE-LONG DISPLAY-7.
005780 02 DISPLAY-CHAR PIC X OCCURS 144 TIMES
005800 INDEXED BY DIX.
005820 01 DISPLAY-LINE REDEFINES DISPLAY-LINE-LONG DISPLAY-7.
005840 02 DISPLAY-LINE72.
005860 04 DISPLAY-LINE-35 PIC X(35).
005880 04 FILLER PIC X(37).
005900 02 FILLER PIC X(72).
005920
005940 01 MSG-LINE DISPLAY-7.
005960 02 MSG-MARK PIC XX.
005980 02 MSG-NAME PIC X(31).
006000 02 MSG-TEXT PIC X(47).
006020 01 FILLER REDEFINES MSG-LINE DISPLAY-7.
006040 02 PRINT-CHAR PIC X OCCURS 80 TIMES
006060 INDEXED BY PRX.
006080
006100
006120 01 ANSWER-ASCII, PIC X(72), DISPLAY-7.
006140
006160 01 ANSWER DISPLAY-7.
006180 02 ANSWER-30.
006200 03 ANSWER-25.
006220 04 ANSWER-20.
006240 05 ANSWER-15.
006260 06 ANSWER-10.
006280 07 ANSWER-9.
006300 08 ANSWER-8.
006320 09 ANSWER-7.
006340 10 ANSWER-6.
006360 11 ANSWER-5.
006380 12 ANSWER-4.
006400 13 ANSWER-3.
006420 14 ANSWER-2.
006440 15 ANSWER-1 PIC X.
006460 15 FILLER PIC X.
006480 14 FILLER PIC X.
006500 13 FILLER PIC X.
006520 12 FILLER PIC X.
006540 11 FILLER PIC X.
006560 10 FILLER PIC X.
006580 09 FILLER PIC X.
006600 08 FILLER PIC X.
006620 07 FILLER PIC X.
006640 06 FILLER PIC X(5).
006660 05 FILLER PIC X(5).
006680 04 FILLER PIC X(5).
006700 03 FILLER PIC X(5).
006720 02 FILLER PIC X(42).
006740 01 FILLER REDEFINES ANSWER DISPLAY-7.
006760 02 ANS-CHAR PIC X OCCURS 72 TIMES
006780 INDEXED BY ANX.
006800
006804 01 PRIOR-ANSWER PIC X(72) VALUE SPACES DISPLAY-7.
006808
006820 01 FOUND-WORD DISPLAY-7.
006840 02 FOUND-WORD-30.
006860 03 FOUND-WORD-25.
006880 04 FOUND-WORD-20.
006900 05 FOUND-WORD-15.
006920 06 FOUND-WORD-10.
006940 07 FOUND-WORD-9.
006960 08 FOUND-WORD-8.
006980 09 FOUND-WORD-7.
007000 10 FOUND-WORD-6.
007020 11 FOUND-WORD-5.
007040 12 FOUND-WORD-4.
007060 13 FOUND-WORD-3.
007080 14 FOUND-WORD-2.
007100 15 FOUND-WORD-1 PIC X.
007120 15 FILLER PIC X.
007140 14 FILLER PIC X.
007160 13 FILLER PIC X.
007180 12 FILLER PIC X.
007200 11 FILLER PIC X.
007220 10 FILLER PIC X.
007240 09 FILLER PIC X.
007260 08 FILLER PIC X.
007280 07 FILLER PIC X.
007300 06 FILLER PIC X(5).
007320 05 FILLER PIC X(5).
007340 04 FILLER PIC X(5).
007360 03 FILLER PIC X(5).
007380 02 FILLER PIC X(42).
007400 01 FILLER REDEFINES FOUND-WORD DISPLAY-7.
007420 02 FOUND-CHAR PIC X OCCURS 72 TIMES
007440 INDEXED BY FWX.
007460
007462 01 FOUND6-WORD DISPLAY-6.
007464 02 FOUND6-WORD-30.
007466 03 FOUND6-WORD-25.
007468 04 FOUND6-WORD-20.
007470 05 FOUND6-WORD-15.
007472 06 FOUND6-WORD-10.
007474 07 FOUND6-WORD-9.
007476 08 FOUND6-WORD-8.
007478 09 FOUND6-WORD-7.
007480 10 FOUND6-WORD-6.
007482 11 FOUND6-WORD-5.
007484 12 FOUND6-WORD-4.
007486 13 FOUND6-WORD-3.
007488 14 FOUND6-WORD-2.
007490 15 FOUND6-WORD-1 PIC X.
007492 15 FILLER PIC X.
007494 14 FILLER PIC X.
007496 13 FILLER PIC X.
007498 12 FILLER PIC X.
007500 11 FILLER PIC X.
007502 10 FILLER PIC X.
007504 09 FILLER PIC X.
007506 08 FILLER PIC X.
007508 07 FILLER PIC X.
007510 06 FILLER PIC X(5).
007512 05 FILLER PIC X(5).
007514 04 FILLER PIC X(5).
007516 03 FILLER PIC X(5).
007518 02 FILLER PIC X(42).
007520
007522 01 PROMPT-LINE DISPLAY-7.
007524 02 BASIC-LINE-ASTERISK PIC X.
007526 02 BASIC-LINE-NAME PIC X(31).
007540 02 BASIC-LINE-LPAREN PIC X.
007560 02 BASIC-LINE-TITLE1 PIC X(11).
007580 02 BASIC-LINE-TITLE2 PIC X(11).
007600 02 BASIC-LINE-NCHAR PIC ZZZ9.
007620 02 BASIC-LINE-POINT PIC X.
007640 02 BASIC-LINE-DECIMALS PIC 9.
007660 02 BASIC-LINE-TYPEV PIC X.
007680 02 BASIC-LINE-RPAREN PIC X.
007700 02 BASIC-LINE-COLON PIC XX.
007720 01 FILLER REDEFINES PROMPT-LINE DISPLAY-7.
007740 02 PROMPT-CHAR PIC X OCCURS 64 TIMES
007760 INDEXED BY PRX.
007780
007800**WORKING REGISTERS FOR NUMBER CONVERSION FOLLOW**
007820
007840
007860 01 BHOLDER.
007880 02 BCOMP6 PIC S9(10) COMP.
007900 02 FILLER PIC X(6).
007920 01 BHOLDER1 REDEFINES BHOLDER.
007940 02 BCOMP12 PIC S9(18) COMP.
007960
007970 01 LONG-HOLDER DISPLAY-7.
007980 02 HOLDER.
008000 04 CHAR-HOLDER PIC X OCCURS 54 TIMES
008020 INDEXED BY HLX.
008040 02 AH3 REDEFINES HOLDER.
008060 04 AHOLDER3 PIC XXX.
008080 04 FILLER PIC X(51).
008100 02 AH5 REDEFINES HOLDER.
008120 04 AHOLDER5 PIC X(5).
008140 04 FILLER PIC X(49).
008160 02 AH6 REDEFINES HOLDER.
008180 04 AHOLDER6 PIC X(6).
008200 04 FILLER PIC X(48).
008220 02 UNPK1 REDEFINES HOLDER.
008240 04 FILLER PIC X(53).
008260 04 NHOLDER1 PIC S9.
008280 02 UNPK8 REDEFINES HOLDER.
008300 04 FILLER PIC X(46).
008320 04 NHOLDER8 PIC S9(8).
008340 02 UNPK10 REDEFINES HOLDER.
008360 04 FILLER PIC X(44).
008380 04 NHOLDER10 PIC S9(10).
008400 02 UNPK18 REDEFINES HOLDER.
008420 04 FILLER PIC X(36).
008440 04 NHOLDER18 PIC S9(18).
008460 04 NHOLDER REDEFINES NHOLDER18
008470 PIC S9(18).
008462 02 HOLDER-EXTENSION PIC X(300) VALUE SPACES.
008464
008468 01 LONG-HOLDER-SIX USAGE DISPLAY-6.
008472 02 HOLDER-SIX.
008473 04 FILLER PIC X(36) VALUE SPACES.
008474 04 NHOLDER18-SIX PIC S9(18) VALUE 0.
008476 02 FILLER PIC X(300) VALUE SPACES.
008480
008500**COMMAND VOCABULARY FOLLOWS**
008520
008540 01 VOCABULARY.
008560 02 FILLER PIC XXX VALUE 'APP'.
008580 02 FILLER PIC XXX VALUE 'BOT'.
008600 02 FILLER PIC XXX VALUE 'CHA'.
008620 02 FILLER PIC XXX VALUE 'COL'.
008640 02 FILLER PIC XXX VALUE 'DEL'.
008660 02 FILLER PIC XXX VALUE 'DOW'.
008680 02 FILLER PIC XXX VALUE 'END'.
008700 02 FILLER PIC XXX VALUE 'EXI'.
008720 02 FILLER PIC XXX VALUE 'EXT'.
008740 02 FILLER PIC XXX VALUE 'FIN'.
008760 02 FILLER PIC XXX VALUE 'INS'.
008780 02 FILLER PIC XXX VALUE 'LIS'.
008784 02 FILLER PIC XXX VALUE 'REP'.
008800 02 FILLER PIC XXX VALUE 'SAV'.
008820 02 FILLER PIC XXX VALUE 'TOP'.
008840 02 FILLER PIC XXX VALUE 'UP '.
008860 02 FILLER PIC XXX VALUE 'VER'.
008880 02 FILLER PIC XXX VALUE ' '.
008900 01 VOCABULARY-REDEF REDEFINES VOCABULARY.
008920 02 VOCAB PIC XXX OCCURS 18 TIMES
008940 INDEXED BY VOX.
008960 01 RELATIONSHIPS.
008980 02 FILLER PIC X(7) VALUE 'EQ '.
009000 02 FILLER PIC X(7) VALUE 'EQUAL '.
009020 02 FILLER PIC X(7) VALUE 'EQUALS '.
009040 02 FILLER PIC X(7) VALUE '= '.
009060 02 FILLER PIC X(7) VALUE 'IS '.
009080 02 FILLER PIC X(7) VALUE 'NE '.
009100 02 FILLER PIC X(7) VALUE 'NEQ '.
009120 02 FILLER PIC X(7) VALUE 'NQ '.
009140 02 FILLER PIC X(7) VALUE '<> '.
009160 02 FILLER PIC X(7) VALUE '# '.
009180 02 FILLER PIC X(7) VALUE 'GR '.
009200 02 FILLER PIC X(7) VALUE 'GREATER'.
009220 02 FILLER PIC X(7) VALUE 'GT '.
009240 02 FILLER PIC X(7) VALUE '> '.
009260 02 FILLER PIC X(7) VALUE 'LE '.
009280 02 FILLER PIC X(7) VALUE 'LEQ '.
009300 02 FILLER PIC X(7) VALUE 'LQ '.
009320 02 FILLER PIC X(7) VALUE '<= '.
009340 02 FILLER PIC X(7) VALUE 'LS '.
009360 02 FILLER PIC X(7) VALUE 'LESS '.
009380 02 FILLER PIC X(7) VALUE 'LT '.
009400 02 FILLER PIC X(7) VALUE '< '.
009420 02 FILLER PIC X(7) VALUE 'GE '.
009440 02 FILLER PIC X(7) VALUE 'GEQ '.
009460 02 FILLER PIC X(7) VALUE 'GQ '.
009480 02 FILLER PIC X(7) VALUE '>= '.
009500 02 FILLER PIC X(7) VALUE ' '.
009520
009540 01 RELATIONSHIPS-REDEF REDEFINES RELATIONSHIPS.
009560 02 RELAT PIC X(7) OCCURS 27 TIMES
009580 INDEXED BY REX.
009600 01 RELATION-NOS.
009620 02 FILLER PIC S9(4) COMP VALUE 1.
009640 02 FILLER PIC S9(4) COMP VALUE 1.
009660 02 FILLER PIC S9(4) COMP VALUE 1.
009680 02 FILLER PIC S9(4) COMP VALUE 1.
009700 02 FILLER PIC S9(4) COMP VALUE 1.
009720 02 FILLER PIC S9(4) COMP VALUE 2.
009740 02 FILLER PIC S9(4) COMP VALUE 2.
009760 02 FILLER PIC S9(4) COMP VALUE 2.
009780 02 FILLER PIC S9(4) COMP VALUE 2.
009800 02 FILLER PIC S9(4) COMP VALUE 2.
009820 02 FILLER PIC S9(4) COMP VALUE 4.
009840 02 FILLER PIC S9(4) COMP VALUE 4.
009860 02 FILLER PIC S9(4) COMP VALUE 4.
009880 02 FILLER PIC S9(4) COMP VALUE 4.
009900 02 FILLER PIC S9(4) COMP VALUE 5.
009920 02 FILLER PIC S9(4) COMP VALUE 5.
009940 02 FILLER PIC S9(4) COMP VALUE 5.
009960 02 FILLER PIC S9(4) COMP VALUE 5.
009980 02 FILLER PIC S9(4) COMP VALUE 7.
010000 02 FILLER PIC S9(4) COMP VALUE 7.
010020 02 FILLER PIC S9(4) COMP VALUE 7.
010040 02 FILLER PIC S9(4) COMP VALUE 7.
010060 02 FILLER PIC S9(4) COMP VALUE 8.
010080 02 FILLER PIC S9(4) COMP VALUE 8.
010100 02 FILLER PIC S9(4) COMP VALUE 8.
010120 02 FILLER PIC S9(4) COMP VALUE 8.
010140 02 FILLER PIC S9(4) COMP VALUE ZERO.
010160 01 RELATION-NOS-REDEF REDEFINES RELATION-NOS.
010180 02 RELAT-NO PIC S9(4) COMP OCCURS 27 TIMES.
010200
010220**DICTIONARY LAYOUTS FOLLOW**
010240
010260 01 DD-REC USAGE IS DISPLAY-7.
010280 02 IN-IDNT PIC XX.
010300 02 IN-NAME.
010302 04 DP-LEVEL PIC 99.
010304 04 FILLER PIC XX.
010306 04 DP-TEXT.
010308 06 DP-CHAR PIC X OCCURS 12.
010310 04 FILLER PIC X(14).
010320 02 IN-TITLE1 PIC X(10).
010340 02 IN-TITLE2 PIC X(10).
010360 02 IN-NTCHARS PIC 99.
010380 02 IN-ECHAR PIC 9(4).
010400 02 IN-FCHAR PIC 9(4).
010420 02 IN-NCHAR PIC 9(4).
010440 02 IN-TYPEV PIC X.
010460 02 IN-SCALE PIC 9.
010480 02 IN-OFFSET PIC 9.
010500 02 FILLER PIC XX.
010520 02 IN-PICT PIC X(19).
010540 02 FILLER PIC X(13).
010560 02 IN-UPFLAG PIC X.
010580 02 FILLER PIC X(46).
010600
010620 01 RD-REC REDEFINES DD-REC USAGE IS DISPLAY-7.
010640 02 FILLER PIC X(32).
010660 02 DR-ORIGIN PIC 9(4).
010680 02 DR-LENGTH PIC 9(4).
010700 02 DR-TYPE PIC XXX.
010720 02 FILLER PIC X(107).
010740
010760 01 DICT-INFO.
010780 02 FILLER PIC XX.
010800 02 DICT-NAME PIC X(30).
010820 02 DICT-NDICTS PIC X(3).
010840 02 DICT-FILENAME PIC X(9).
010860 02 FILLER PIC X(8).
010880 02 DICT-DIRECT PIC X(17).
010900 02 FILLER PIC XX.
010920 02 DICT-FILETYPE PIC X.
010940 02 DICT-RECLEN PIC 9(4).
010960 02 DICT-BLKFACT PIC S9(4).
010980 02 DICT-KEYLOC PIC 9(4).
011000 02 DICT-KEYLEN PIC 9(3).
011020 02 DICT-KEYTYPE PIC 9.
011040 02 DICT-KEYSIGN PIC 9.
011060 02 DICT-PROT PIC X.
011080 02 DICT-READPROT PIC 99.
011100 02 DICT-WRITEPROT PIC 99.
011120 02 DICT-REWRITEPROT PIC 99.
011121
011124 01 CURRENT-PASSWORD PIC X(6).
011130 01 CURRENT-LEVEL PIC 99.
011140
011160 01 DYNAMIC-DICTIONARY.
011180 02 DYN-DD-ENTRY OCCURS 101 TIMES
011200 INDEXED BY DX.
011220 04 IDNT PIC X DISPLAY-7.
011240 04 NAME PIC X(30) DISPLAY-7.
011260 04 TYPEV PIC X DISPLAY-7.
011280 04 IN-USE PIC X DISPLAY-7.
011300 04 PROMPT PIC X(38) DISPLAY-7.
011320 04 DPICT PIC X(19) DISPLAY-7.
011340 04 SCALE PIC 9(8) COMP.
011360 04 FCHAR PIC 9(8) COMP.
011380 04 NCHAR PIC 9(8) COMP.
011400 04 ECHAR PIC 9(8) COMP.
011420
011440 01 ELEM-DD-ENTRY.
011460 04 IDNT-ELEM PIC X DISPLAY-7.
011480 04 NAME-ELEM PIC X(30) DISPLAY-7.
011500 04 TYPEV-ELEM PIC X DISPLAY-7.
011505 04 TYPEVN-ELEM REDEFINES TYPEV-ELEM PIC 9 DISPLAY-7.
011520 04 IN-USE-ELEM PIC X DISPLAY-7.
011540 04 PROMPT-ELEM DISPLAY-7.
011560 06 RECTYPE-ELEM PIC XXX.
011580 06 FILLER PIC X(34).
011600 06 UPFLAG-ELEM PIC X.
011620 04 PICT-ELEM PIC X(19) DISPLAY-7.
011640 04 SCALE-ELEM PIC 9(8) COMP.
011660 04 FCHAR-ELEM PIC 9(8) COMP.
011680 04 NCHAR-ELEM PIC 9(8) COMP.
011700 04 ECHAR-ELEM PIC 9(8) COMP.
011702
011704* *STACKS FOR PASSWORD PROTECTION FOLLOW*
011706
011708 01 FILE-LEVEL-PROTECTION.
011710 02 READPROT PIC 99.
011712 02 WRITEPROT PIC 99.
011714 02 REWRITEPROT PIC 99.
011716
011718 01 DYNAMIC-PROTECTION.
011720 02 DYN-PW-ENTRY OCCURS 10 INDEXED BY DPX.
011722 04 PASSWORD PIC XXXXX.
011724 04 LEVEL PIC 99.
011726
011728 01 PW-TEXT DISPLAY-6.
011730 02 PW-CHAR PIC X OCCURS 12 TIMES.
011732 01 FILLER REDEFINES PW-TEXT.
011734 02 PW-WORK1 PIC S9(10) COMP.
011736 02 PW-WORK2 PIC S9(10) COMP.
011738 01 PW-MASK1 PIC S9(10) COMP VALUE 14729163.
011740 01 PW-MASK2 PIC S9(10) COMP VALUE -24815212.
011742
011750**STACKS FOR FIND, CHANGE, LIST COMMANDS FOLLOW**
011760
011764 01 PRIOR-DX-FIND-STACK.
011766 02 PRIOR-DX-FIND-PARAM OCCURS 16 TIMES.
011768 04 FILLER PIC S9(8) COMP.
011770 04 FILLER PIC S9(8) COMP.
011772 04 FILLER PIC X(54) DISPLAY-6.
011774
011776 01 PRIOR-LOCATING-FLAGS.
011777 02 PRIOR-FIND-AHEAD-FLAG PIC 9 COMP.
011778 02 PRIOR-ALL-FLAG PIC 9 COMP.
011779 02 PRIOR-FIRST-FLAG PIC 9 COMP.
011780 02 PRIOR-RANDOM-READ-FLAG PIC 9 COMP.
011782
011788 01 DX-FIND-STACK.
011800 02 DX-FIND-PARAM OCCURS 16 TIMES
011820 INDEXED BY FIX.
011840 04 DX-FIND-PTR PIC S9(8) COMP.
011860 04 FIND-TEST PIC S9(8) COMP.
011880 04 FIND-VALUE PIC X(54) DISPLAY-6.
011900
011920 01 DX-FIND-ELEM.
011940 02 DX-FIND-PTR-ELEM PIC S9(8) COMP.
011960 02 FIND-TEST-ELEM PIC S9(8) COMP.
011980 02 FIND-VALUE-ELEM PIC X(54) DISPLAY-6.
012000 02 FILLER REDEFINES FIND-VALUE-ELEM DISPLAY-6.
012020 04 FILLER PIC X(36).
012040 04 FIND-VALUEN-ELEM PIC S9(18).
012060
012080 01 DX-CHG-STACK DISPLAY-7.
012100 02 DX-CHG-PARAM OCCURS 16 TIMES
012120 INDEXED BY CHX.
012140 04 DX-CHG-PTR PIC S9(8) COMP.
012160 04 CHG-VALUE PIC X(54) DISPLAY-7.
012180
012200 01 DX-LST-STACK.
012220 02 DX-LST-PARAM OCCURS 16 TIMES
012240 INDEXED BY LSX.
012260 04 DX-LST-PTR PIC S9(8) COMP.
012280
012300**FILE NAME CONSTRUCTORS FOLLOW **
012320
012340 01 JOB-NO PIC S9(3) COMP VALUE 1.
012360 01 CALLED-NAME PIC X(6) USAGE IS DISPLAY-6
012380 VALUE SPACES.
012400 01 DEVICER PIC X(6) VALUE SPACE.
012420 01 PROJ PIC S9(8) COMP VALUE ZERO.
012440 01 USER PIC S9(8) COMP VALUE ZERO.
012460 01 FILENAMES.
012480
012500 02 QTDICT-ID.
012520 04 FILLER PIC XX VALUE 'QT'.
012540 04 QTNNND-NO PIC 999 VALUE 001.
012560 04 FILLER PIC X(4) VALUE 'DTMP'.
012580 02 QTINFO-ID.
012600 04 FILLER PIC XX VALUE 'QT'.
012620 04 QTNNNI-NO PIC 999 VALUE 001.
012640 04 FILLER PIC XXXX VALUE 'ITMP'.
012660 02 QTNNNU-ID.
012680 04 FILLER PIC XX VALUE 'QT'.
012700 04 QTNNNU-NO PIC 999 VALUE 001.
012720 04 FILLER PIC X(4) VALUE 'UTMP'.
012740 02 QLNNNU-ID.
012760 04 FILLER PIC XX VALUE 'QL'.
012780 04 QLNNNU-NO PIC 999 VALUE 001.
012800 04 FILLER PIC X(4) VALUE 'ULPT'.
012820 02 QIFLE7-ID.
012840 04 FILLER PIC X(6) VALUE 'ISAMF7'.
012860 04 QIFILE-EXT PIC XXX VALUE 'IDX'.
012880 02 QIFLE6-ID.
012900 04 FILLER PIC X(6) VALUE 'ISAMF6'.
012920 04 QIFILE6-EXT PIC XXX VALUE 'IDX'.
012940 02 QOFLE7-ID.
012960 04 FILLER PIC X(6) VALUE SPACES.
012980 04 QOFILE7-EXT PIC XXX.
013000 02 QOFLE6-ID.
013020 04 FILLER PIC X(6) VALUE SPACES.
013040 04 QOFLE6-EXT PIC XXX.
013060 02 EXTRACT-ID PIC X(9).
013080 02 EXTRACT-TEMP-ID.
013100 04 FILLER PIC XX VALUE 'QT'.
013120 04 QTNNNX-NO PIC 999 VALUE 001.
013140 04 FILLER PIC X(4) VALUE 'XTMP'.
013160 02 PARSED-FILE-NAME PIC X(9).
013180 02 CURRENT-ID-IN PIC X(9) VALUE SPACES.
013200 02 CURRENT-ID-OUT PIC X(9) VALUE SPACES.
013220 02 QPDICTSEQ PIC X(9) VALUE 'QPDICTSEQ'.
013240
013260 PROCEDURE DIVISION.
013280
013300
013320***********************************************************
013340* INITIALIZING SECTION. GETS DIRECTIVES FROM USER, BUILDS
013360* DYNAMIC DICTIONARY, ROUTES CONTROL TO INPUTING
013380* OR UPDATING LOGIC.
013400***********************************************************
013420 BEGIN.
013440 ENTER MACRO CLRTTY.
013460 MOVE 0 TO PROJ USER I.
013480 ENTER MACRO IQGJOB USING JOB-NO.
013500 MOVE JOB-NO TO QTNNNU-NO QLNNNU-NO QTNNNI-NO
013520 QTNNND-NO QTNNNX-NO.
013540 MOVE SPACES TO CURRENT-ID-IN.
013560 MOVE 0 TO MODE-FLAG.
013580
013600* *SEE IF THERE IS AN INFO (DIRECTIVE) FILE*
013620 ENTER MACRO IQLOOK USING DEVICER QTINFO-ID PROJ USER I.
013640 IF I = -1 GO TO CALLED.
013660* *NO - ASK FOR PARAMETERS*
013680 NOT-CALLED.
013700 DISPLAY ' BROWSE, INPUT or UPDATE [dict] [file]: '
013720 UPON CONSOLE WITH NO ADVANCING.
013740 PERFORM ACCEPTER THRU ACCEPTER-EXIT.
013760 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
013780 IF FOUND6-WORD-1 = 'B' MOVE 1 TO MODE-FLAG
013800 ELSE IF FOUND6-WORD-1 = 'I' MOVE 2 TO MODE-FLAG
013820 ELSE IF FOUND6-WORD-1 = 'U' MOVE 3 TO MODE-FLAG
013840 ELSE GO TO NOT-CALLED.
013860 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
013880 MOVE FOUND6-WORD-30 TO SOUGHT-DICT-NAME.
013900 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
013920 IF FOUND6-WORD-1 NOT = SPACES GO TO GET-FILE-NAME.
013940 IF SOUGHT-DICT-NAME NOT = ' ' GO TO BEGIN-COMMON.
013960
013980 GET-DICT-NAME.
014000 DISPLAY ' *Dictionary name or EXIT: '
014020 UPON CONSOLE WITH NO ADVANCING.
014040 PERFORM ACCEPTER THRU ACCEPTER-EXIT.
014060 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
014062 IF FOUND6-WORD-4 = 'EXIT' OR 'END ' GO TO COMPLETE-IU.
014080 MOVE FOUND6-WORD-30 TO SOUGHT-DICT-NAME.
014100 IF SOUGHT-DICT-NAME = ' ' GO TO GET-DICT-NAME.
014120 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
014140
014160 GET-FILE-NAME.
014180 IF FOUND6-WORD-1 = SPACES MOVE SPACES TO CURRENT-ID-IN
014200 ELSE PERFORM FILE-PARSER THRU FILE-PARSER-EXIT
014220 MOVE PARSED-FILE-NAME TO CURRENT-ID-IN.
014240 GO TO BEGIN-COMMON.
014260
014280 CALLED.
014300* *EXTRACT PASSED PARAMETERS FROM INFO FILE*
014320 OPEN INPUT QTINFO.
014340 READ QTINFO AT END CLOSE QTINFO GO TO NOT-CALLED.
014360 IF INFO-IQU-FLAG NOT = 'U' CLOSE QTINFO GO TO NOT-CALLED.
014380 MOVE INFO-MODE-FLAG TO MODE-FLAG.
014400 MOVE INFO-DICT-NAME TO SOUGHT-DICT-NAME.
014420 MOVE INFO-FILE-NAME TO CURRENT-ID-IN.
014440 CLOSE QTINFO.
014450 MOVE 'IQL ' TO CALLED-NAME.
014460 IF SOUGHT-DICT-NAME = ' ' GO TO GET-DICT-NAME.
014480
014500 BEGIN-COMMON.
014520* *MAKE SURE THERE ARE DICTIONARIES TO LOOK AT*.
014540 MOVE ' ' TO DEVICER.
014560 MOVE 0 TO PROJ USER.
014580 MOVE 0 TO I.
014600 ENTER MACRO IQLOOK USING DEVICER QPDICTSEQ PROJ USER I.
014620 IF I NOT = -1 DISPLAY
014640 ' %No dictionaries found in your directory; run ended'
014660 UPON CONSOLE
014680 GO TO COMPLETE-IU.
014700 OPEN INPUT QPDICT.
014720
014740 DICT-FINDER.
014760 READ QPDICT INTO DD-REC AT END
014780 MOVE ' %' TO MSG-MARK
014800 MOVE SOUGHT-DICT-NAME TO MSG-NAME
014820 MOVE ' Dictionary not found' TO MSG-TEXT
014840 PERFORM DISPLAY-MSG THRU DISPLAY-MSG-EXIT
014860 CLOSE QPDICT
014880 GO TO GET-DICT-NAME.
014900 IF IN-IDNT NOT = 'FD' GO TO DICT-FINDER.
014920 MOVE DD-REC TO DICT-INFO.
014940 IF DICT-NAME NOT = SOUGHT-DICT-NAME GO TO DICT-FINDER.
014942* *RECORD FILE LEVEL PASSWORD PROTECTION LEVELS*
014944 MOVE DICT-READPROT TO READPROT.
014946 MOVE DICT-WRITEPROT TO WRITEPROT.
014948 MOVE DICT-REWRITEPROT TO REWRITEPROT.
014950 SET DPX TO 1.
014960* *COPY DICT TO WORK FILE FOR FAST PROCESSING LATER*
014980 OPEN OUTPUT QTDICT.
015000 WRITE QTDICT-REC FROM DD-REC.
015020 MOVE 1 TO START-COL.
015040 MOVE DICT-RECLEN TO RECLEN END-COL NO-COLS.
015060 MOVE DICT-BLKFACT TO BLKFACT.
015080 MOVE DICT-KEYLOC TO KEYLOC.
015100 MOVE DICT-KEYLEN TO KEYLEN.
015120 MOVE DICT-KEYSIGN TO KEYSIGN.
015140 MOVE DICT-KEYTYPE TO KEYTYPE.
015160 IF BLKFACT < 0
015180 SUBTRACT BLKFACT FROM 0 GIVING BLKFACT
015200 ELSE DIVIDE BLKFACT BY RECLEN GIVING BLKFACT.
015220* *CHECK FOR ILLEGAL FILE TYPES*
015240 IF DICT-FILETYPE = '6' OR '7'
015260 NEXT SENTENCE ELSE
015280 MOVE ' %Only Seq or Isam disk files may be processed'
015300 TO DISPLAY-LINE
015320 PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT
015340 CLOSE QPDICT CLOSE QTDICT
015360 GO TO COMPLETE-IU.
015380 MOVE 0 TO NON-FD-ENTRY MORE-DICT-FLAG.
015400 SET DX TO 1.
015420 DYN-DICT-BUILDER.
015440 READ QPDICT INTO DD-REC AT END GO TO DYN-DICT-DONE.
015460 IF IN-IDNT NOT = 'FD' MOVE 1 TO NON-FD-ENTRY.
015480 IF IN-IDNT = 'FD' AND NON-FD-ENTRY = 1
015500 GO TO DYN-DICT-DONE.
015520 WRITE QTDICT-REC FROM DD-REC.
015522 IF IN-IDNT = 'PD' PERFORM UNSCRAMBLE-PW
015524 MOVE DP-TEXT TO PASSWORD (DPX)
015526 MOVE DP-LEVEL TO LEVEL (DPX)
015528 IF DPX LESS THAN 10 SET DPX UP BY 1
015530 GO TO DYN-DICT-BUILDER ELSE GO TO DYN-DICT-BUILDER.
015540 IF IN-IDNT = 'DD' OR 'KD' PERFORM DYN-DICT-DD
015560 GO TO DYN-DICT-COMMON.
015580 IF IN-IDNT = 'RD' PERFORM DYN-DICT-RD
015600 GO TO DYN-DICT-COMMON.
015620 GO TO DYN-DICT-BUILDER.
015640 DYN-DICT-COMMON.
015660 MOVE ELEM-DD-ENTRY TO DYN-DD-ENTRY (DX).
015680 IF DX LESS THAN DICT-CAP SET DX UP BY 1
015700 GO TO DYN-DICT-BUILDER.
015720 MOVE 1 TO MORE-DICT-FLAG.
015740 DYN-DICT-PASS.
015760* *COPY REST OF DICT TO WORK DICT*
015780 READ QPDICT INTO DD-REC AT END GO TO DYN-DICT-DONE.
015800 IF IN-IDNT = 'FD' GO TO DYN-DICT-DONE.
015820 WRITE QTDICT-REC FROM DD-REC.
015840 GO TO DYN-DICT-PASS.
015860 DYN-DICT-DONE.
015880 CLOSE QPDICT. CLOSE QTDICT.
015900 SET DICT-ENTRIES TO DX.
015920 SET DX UP BY 1.
015940 MOVE 0 TO FCHAR (DX).
015960 MOVE 0 TO DX-FIND-PTR (1) FIND-TEST (1)
015980 DX-CHG-PTR (1) DX-LST-PTR (1).
016000 SETUP-FILES.
016020 IF CURRENT-ID-IN = SPACES
016040 MOVE DICT-FILENAME TO CURRENT-ID-IN
016060 ELSE MOVE CURRENT-ID-IN TO DICT-FILENAME.
016080 MOVE QTNNNU-ID TO CURRENT-ID-OUT WORK-FILENAME.
016100 DISPLAY ' (Your diary file is: ' QLNNNU-ID
016120 ' )' UPON CONSOLE.
016140
016160* *SET UP FOR MACRO EDIT MODULE*.
016180 ENTER MACRO IQEBND USING TRUE-TYPEV PICT-WORK
016200 HOLDER-SIX PICT-IN ECHAR-ELEM
016220 NCHAR-ELEM SCALE-ELEM.
016240
016260 IF MODE-FLAG = 1 GO TO BROWSER.
016280 IF MODE-FLAG = 2 GO TO INPUTER.
016300 IF MODE-FLAG = 3 GO TO UPDATER.
016320 GO TO NOT-CALLED.
016340
016360 COMPLETE-IU.
016380*====*CONSIDER THE FOLLOWING TO DELETE TEMP FILES AT END*.
016400* IF DICT-FILETYPE = '6'
016420* IF QOFLE6-EXT = 'TMP'
016440* OPEN INPUT QIFLE6 CLOSE QIFLE6 WITH DELETE.
016460* IF DICT-FILETYPE = '7'
016480* IF QOFILE7-EXT = 'TMP'
016500* OPEN INPUT QIFLE7 CLOSE QIFLE7 WITH DELETE.
016520 IF CALLED-NAME NOT = SPACES
016540 MOVE 'IQL ' TO CALLED-NAME
016560 ENTER MACRO IQNEXT USING CALLED-NAME.
016580 STOP RUN.
016600
016620*******************************************************
016640* SET UP TO BROWSE ONLY.
016660*******************************************************
016680 BROWSER.
016700 MOVE 0 TO I.
016720 ENTER MACRO IQLOOK USING DEVICER CURRENT-ID-IN PROJ USER I.
016740 IF I NOT = -1 GO TO BROWSER2.
016742* *IF NECESSARY, GET A PASSWORD*
016743 BROWSER1.
016744 IF READPROT NOT = 0 OR DPX > 1
016746 PERFORM CONFIDENTIAL-ASK THRU CONFIDENTIAL-ASK-EXIT.
016747 IF CURRENT-PASSWORD = 'EXIT' OR 'END' GO TO COMPLETE-IU.
016748 IF CURRENT-LEVEL LESS THAN READPROT
016750 DISPLAY ' %Password not OK for read access' UPON CONSOLE
016752 DISPLAY ' Enter correct password or EXIT.' UPON CONSOLE
016854 GO TO BROWSER1.
016748 GO TO UPDATER2.
017450 BROWSER2.
016760 MOVE ' %' TO MSG-MARK.
016780 MOVE CURRENT-ID-IN TO MSG-NAME.
016800 MOVE ' data file not found' TO MSG-TEXT.
016820 PERFORM DISPLAY-MSG THRU DISPLAY-MSG-EXIT.
016840 GO TO COMPLETE-IU.
016860
016880***********************************************************
016900* SET UP TO INPUT A NEW FILE.
016920***********************************************************
016940 INPUTER.
016960* *CHECK TO MAKE SURE FILE NOT ALREADY THERE*.
016980 MOVE 0 TO I.
017000 ENTER MACRO IQLOOK USING DEVICER CURRENT-ID-IN
017020 PROJ USER I.
017040 IF I = -1 MOVE ' %' TO MSG-MARK
017060 MOVE CURRENT-ID-IN TO MSG-NAME
017080 MOVE ' File already there; entering update'
017100 TO MSG-TEXT PERFORM DISPLAY-MSG THRU DISPLAY-MSG-EXIT
017120 GO TO UPDATER1.
017140 INPUTER1.
017160 IF KEYLOC NOT EQUAL 0
017180 MOVE ' %' TO MSG-MARK
017200 MOVE ' This version cannot input ISAM'
017220 TO MSG-TEXT
017240 PERFORM DISPLAY-MSG THRU DISPLAY-MSG-EXIT
017260 GO TO NOT-CALLED.
017280 MOVE ' (' TO MSG-MARK.
017300 MOVE CURRENT-ID-IN TO MSG-NAME.
017320 MOVE ' file being created)' TO MSG-TEXT.
017340 PERFORM DISPLAY-MSG THRU DISPLAY-MSG-EXIT.
017360 PERFORM OPEN-OUT THRU OPEN-OUT-EXIT.
017380 MOVE 2 TO READ-FLAG.
017400 GO TO INSERTER.
017420
017440***********************************************************
017460* SET UP TO UPDATE AN EXISTING FILE.
017480***********************************************************
017500 UPDATER.
017520* *SEE IF INPUT FILE IS REALLY THERE*.
017540* *ONLY LOOKS IN CURRENT DSK: SEARCH PATH; UPDATING IN ANOTHER
017560* * DIRECTORY IS NOT PERMITTED*.
017580* * CAN BROWSE IN SEQUENTIAL OR ISAM FILE IN ANOTHER DIRECTORY.
017600* * IF TRY TO WRITE TO ISAM IN ANOTHER DIRECTORY WILL FAIL.
017620* * IF TRY TO UPDATE SEQ FILE FROM ANOTHER DIRECTORY
017640* * WILL WRITE UPDATED FILE IN LOGIN DIRECTORY AND LEAVE
017660* * ORIGINAL UNTOUCHED.
017680 MOVE 0 TO I.
017700 ENTER MACRO IQLOOK USING DEVICER CURRENT-ID-IN PROJ USER I.
017720 IF I NOT = -1 MOVE ' %' TO MSG-MARK
017740 MOVE CURRENT-ID-IN TO MSG-NAME
017760 MOVE ' File not found; entering input' TO MSG-TEXT
017780 PERFORM DISPLAY-MSG THRU DISPLAY-MSG-EXIT
017800 GO TO INPUTER1.
017820 UPDATER1.
017822* *IF NECESSARY GET A PASSWORD*
017823 UPDATER1A.
017824 IF READPROT NOT = 0 OR WRITEPROT NOT = 0
017826 OR REWRITEPROT NOT = 0 OR DPX > 1
017828 PERFORM CONFIDENTIAL-ASK THRU CONFIDENTIAL-ASK-EXIT.
017829 IF CURRENT-PASSWORD = 'EXIT' OR 'END' GO TO COMPLETE-IU.
017830 IF DICT-KEYLEN NOT = 0 IF CURRENT-LEVEL NOT < REWRITEPROT
017832 GO TO UPDATER2 ELSE GO TO UPDATER1AA.
017834 IF CURRENT-LEVEL NOT < WRITEPROT GO TO UPDATER2.
017835 UPDATER1AA.
017836 DISPLAY ' %Password not OK for update access' UPON CONSOLE
017838 DISPLAY ' Enter correct password or EXIT.' UPON CONSOLE
017040 GO TO UPDATER1A.
017860 UPDATER2.
017870 PERFORM OPEN-IN THRU OPEN-IN-EXIT.
017880 PERFORM OPEN-OUT THRU OPEN-OUT-EXIT.
017890
017900**********************************************************
017920**********************************************************
017970* MAIN UPDATE COMMAND PROCESSING LOOP *
017960**********************************************************
017980**********************************************************
018000 COMMAND-LOOP.
018020 PERFORM ASKER THRU ASKER-EXIT.
018024
018028 COMMAND-LOOP1.
018040 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
018060 PERFORM FIND-VOCAB THRU FIND-VOCAB-EXIT.
018080 IF VOX = 0 GO TO COMMAND-ERR.
018084 IF FOUND6-WORD-3 = 'REP' MOVE PRIOR-ANSWER TO ANSWER
018088 SET ANX TO 1 GO TO COMMAND-LOOP1.
018092 MOVE ANSWER TO PRIOR-ANSWER.
018100 SET CURRENT-COMMAND TO VOX.
018120 GO TO APPENDER BOTTOMER CHANGER COLSETTER DELETER
018140 DOWNER ENDER ENDER EXTRACTER FINDER
018160 INSERTER LISTER REPEATER SAVER
018180 TOPPER UPPER VERIFIER
018200 DEPENDING ON CURRENT-COMMAND.
018204 REPEATER.
018220 COMMAND-ERR.
018240 MOVE ' %Command error; please re-enter'
018260 TO DISPLAY-LINE.
018280 PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT.
018300 GO TO COMMAND-LOOP.
018320
018340**********************************************************
018360* SEQUENCE 'COLSETTER' TO SET COLUMNS FOR RECORD
018380* DISPLAYING.
018400**********************************************************
018420 COLSETTER.
018440 MOVE 1 TO START-COL.
018460 MOVE 72 TO END-COL NO-COLS.
018480 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
018500 IF FOUND6-WORD-1 = ' ' OR NUM-VAL-FLAG = 0
018520 GO TO COMMAND-ERR.
018540 PERFORM NUM-ARG THRU NUM-ARG-EXIT.
018560 MOVE NHOLDER8 TO START-COL.
018580 IF START-COL NOT GREATER THAN 0
018600 OR START-COL GREATER THAN DICT-RECLEN
018620 MOVE 1 TO START-COL
018640 MOVE ' %Outside of record' TO DISPLAY-LINE
018660 PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT
018680 GO TO COMMAND-ERR.
018700 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
018720 IF FOUND6-WORD-1 = ' '
018740 ADD START-COL 71 GIVING END-COL
018760 GO TO COLSETTER1.
018780 IF NUM-VAL-FLAG = 0 GO TO COMMAND-ERR.
018800 PERFORM NUM-ARG THRU NUM-ARG-EXIT.
018820 MOVE NHOLDER8 TO END-COL.
018840 IF END-COL NOT GREATER THAN 0 OR
018860 END-COL GREATER THAN DICT-RECLEN
018880 MOVE ' %Outside of record'
018900 TO DISPLAY-LINE
018920 PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT
018940 GO TO COMMAND-ERR.
018960 COLSETTER1.
018980 SUBTRACT START-COL FROM END-COL GIVING NO-COLS.
019000 ADD 1 TO NO-COLS.
019020 IF NO-COLS LESS THAN 1 OR GREATER THAN DICT-RECLEN
019040 MOVE DICT-RECLEN TO NO-COLS
019060 MOVE ' %Columns exceed record length' TO DISPLAY-LINE
019080 PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT.
019100 ADD NO-COLS START-COL GIVING END-COL.
019120 IF END-COL GREATER THAN DICT-RECLEN
019140 MOVE DICT-RECLEN TO END-COL
019160 SUBTRACT START-COL FROM END-COL GIVING NO-COLS
019180 ADD 1 TO NO-COLS.
019200 GO TO COMMAND-LOOP.
019220
019240***********************************************************
019260* SEQUENCE 'TOPPER' TO GO TO TOP OF FILE
019280***********************************************************
019300 TOPPER.
019320 IF KEYLOC = 0
019340 PERFORM SWITCH-INPUT THRU SWITCH-INPUT-EXIT
019360 ELSE PERFORM ISAM-TOPPER THRU ISAM-TOPPER-EXIT.
019380 PERFORM NOTIFY-BEGFILE THRU NOTIFY-BEGFILE-EXIT.
019400 GO TO COMMAND-LOOP.
019420
019440***********************************************************
019460* SEQUENCE 'BOTTOMER' TO GO TO BOTTOM (END) OF FILE
019480***********************************************************
019500 BOTTOMER.
019520 PERFORM GO-TO-END THRU GO-TO-END-EXIT.
019540 IF KEYLOC NOT = 0
019560 MOVE 0 TO READ-FLAG.
019580 GO TO COMMAND-LOOP.
019600
019620***********************************************************
019640* SEQUENCES 'UPPER' OR 'DOWNER' TO MOVE UP OR DOWN
019660* N RECORDS.
019680***********************************************************
019700 DOWNER.
019720 UPPER.
019740 MOVE FOUND6-WORD TO CHAR-WORK.
019760 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
019780 IF FOUND-WORD-1 = ' ' MOVE 1 TO WORKX
019800 GO TO UPDOWN.
019820 IF NUM-VAL-FLAG = 0 GO TO COMMAND-ERR.
019840 PERFORM NUM-ARG THRU NUM-ARG-EXIT.
019860 MOVE NHOLDER8 TO WORKX.
019880 IF WORKX NOT GREATER THAN 0 MOVE 1 TO WORKX.
019900 UPDOWN.
019920 IF CHAR-WORK = 'UP ' GO TO UPPER1.
019940 IF CHAR-WORK NOT = 'DOWN ' AND CHAR-WORK NOT = 'DOW '
019960 AND CHAR-WORK NOT = 'DO ' GO TO COMMAND-ERR.
019980 DOWNER1.
020000 IF READ-FLAG = 2 GO TO DOWNER2.
020020 IF WORKX NOT GREATER THAN 0 GO TO DOWNER3.
020040 SUBTRACT 1 FROM WORKX.
020060 IF READ-FLAG NOT = 3
020080 PERFORM WRITE-OUT THRU WRITE-OUT-EXIT.
020100 PERFORM READ-IN THRU READ-IN-EXIT.
020120 GO TO DOWNER1.
020140 DOWNER2.
020160 PERFORM NOTIFY-EOF THRU NOTIFY-EOF-EXIT.
020180 GO TO COMMAND-LOOP.
020200 UPPER1.
020220 IF READ-FLAG = 3
020240 PERFORM NOTIFY-BEGFILE THRU NOTIFY-BEGFILE-EXIT
020260 GO TO COMMAND-LOOP.
020280 IF KEYLOC = 0
020300 SUBTRACT WORKX FROM WRITE-COUNT GIVING WORKX
020320 PERFORM SWITCH-INPUT THRU SWITCH-INPUT-EXIT
020340 IF WORKX IS LESS THAN 0 GO TO UPPER1.
020360 UPPER2.
020380 IF KEYLOC NOT = 0
020400 PERFORM FIND-THIS-ISAM THRU
020420 FIND-THIS-ISAM-EXIT
020440 PERFORM ISAM-TOPPER THRU ISAM-TOPPER-EXIT.
020460 UPPER2-1.
020480 PERFORM READ-IN THRU READ-IN-EXIT.
020500 IF READ-COUNT GREATER THAN WORKX GO TO UPPER3.
020520 PERFORM WRITE-OUT THRU WRITE-OUT-EXIT.
020540 GO TO UPPER2-1.
020560 DOWNER3.
020580 UPPER3.
020600 IF VERIFY-FLAG = 1
020620 PERFORM DISPLAY-REC THRU DISPLAY-REC-EXIT.
020640 GO TO COMMAND-LOOP.
020660
020680***********************************************************
020700* SEQUENCE 'FINDER' TO FIND A RECORD
020720***********************************************************
020740 FINDER.
020760 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
020780* *IF USER INPUTS 'FIND' ALONE, USE LAST NON-EMPTY
020790* FINDLIST FURNISHED WITH A 'FIND' COMMAND*.
020794 IF FOUND-WORD-1 = ' '
020798 MOVE PRIOR-DX-FIND-STACK TO DX-FIND-STACK
020799 MOVE PRIOR-FIND-AHEAD-FLAG TO FIND-AHEAD-FLAG
020780 MOVE PRIOR-ALL-FLAG TO ALL-FLAG
020781 MOVE PRIOR-FIRST-FLAG TO FIRST-FLAG
020782 MOVE PRIOR-RANDOM-READ-FLAG TO RANDOM-READ-FLAG
020820 ELSE PERFORM CRACK-FINDLIST THRU CRACK-FINDLIST-EXIT
020840 IF FIND-ERR-FLAG NOT = 0 GO TO COMMAND-ERR
020844 ELSE MOVE DX-FIND-STACK TO PRIOR-DX-FIND-STACK
020845 MOVE FIND-AHEAD-FLAG TO PRIOR-FIND-AHEAD-FLAG
020846 MOVE ALL-FLAG TO PRIOR-ALL-FLAG
020847 MOVE FIRST-FLAG TO PRIOR-FIRST-FLAG
020848 MOVE RANDOM-READ-FLAG TO PRIOR-RANDOM-READ-FLAG.
020860* *FIND LIST IS NOW SET UP: LOOK FOR A RECORD
020880* * MATCHING IT*.
020900 FINDER1.
020920 PERFORM FIND-RECORD THRU FIND-RECORD-EXIT.
020940 IF READ-FLAG = 2
020960 PERFORM NOTIFY-EOF THRU NOTIFY-EOF-EXIT
020980 GO TO COMMAND-LOOP
021000 ELSE IF VERIFY-FLAG = 1
021020 PERFORM DISPLAY-REC THRU DISPLAY-REC-EXIT.
021040 IF ALL-FLAG = 1 GO TO FINDER1.
021060 GO TO COMMAND-LOOP.
021080
021100**********************************************************
021120* SEQUENCE 'INSERTER' TO INSERT RECORD(S).
021140* AFTER CURRENT ONE.
021160**********************************************************
021180 INSERTER.
021200 IF MODE-FLAG = 1
021220 DISPLAY ' %only browse permitted - rejected'
021240 UPON CONSOLE GO TO COMMAND-LOOP.
021260 IF READ-FLAG NOT = 2 AND READ-FLAG NOT = 3
021280 PERFORM WRITE-OUT THRU WRITE-OUT-EXIT.
021300 INSERTER1.
021320 PERFORM BUILD-REC THRU BUILD-REC-EXIT.
021322 IF ITEMS-RECD-CTR = 0
021324 DISPLAY ' %No items input; insert ended'
021326 UPON CONSOLE GO TO COMMAND-LOOP.
021340 IF REC-FLAG = 1
021360 MOVE 1 TO WRITE-FLAG
021364 IF KEYLOC = 0
021380 PERFORM WRITE-OUT THRU WRITE-OUT-EXIT
021384 GO TO INSERTER1
021388 ELSE
021420 PERFORM WRITE-ISAM THRU WRITE-ISAM-EXIT
021440 GO TO INSERTER1.
021480 IF REC-FLAG = 0 GO TO INSERTER1.
021500 IF REC-FLAG = 2 MOVE 1 TO WRITE-FLAG
021520 PERFORM WRITE-OUT THRU WRITE-OUT-EXIT
021540 IF KEYLOC NOT = 0
021560 PERFORM WRITE-ISAM THRU WRITE-ISAM-EXIT.
021580 MOVE 0 TO WRITE-FLAG.
021600* *ABOVE SETS SO WONT WRITE BLANK RECORD FROM 'END' *
021620 MOVE 1 TO CHANGES-FLAG.
021640 GO TO COMMAND-LOOP.
021660
021680**********************************************************
021700* SEQUENCE 'APPENDER' TO GO TO END OF FILE AND START
021720* RECEIVING NEW RECORDS.
021740**********************************************************
021760 APPENDER.
021780 IF KEYLOC NOT = 0
021840 GO TO INSERTER.
021860 IF MODE-FLAG = 1 DISPLAY
021880 ' %Only browse permitted - rejected'
021900 UPON CONSOLE GO TO COMMAND-LOOP.
021920 PERFORM GO-TO-END THRU GO-TO-END-EXIT.
021940 GO TO INSERTER.
021960
021980**********************************************************
022000* SEQUENCE 'DELETER' TO DELETE ONE OR MORE RECORDS.
022020* IF 'DELETE' ALONE, DELETES CURRENT RECORD;
022040* IF 'DELETE' FOLLOWED BY FINDLIST, DELETES EITHER
022060* NEXT RECORD LOCATED BY FIND LIST OR ALL SUCH
022080* RECORDS DEPENDING ON WHETHER LIST CONTAINS 'ALL'.
022100*********************************************************
022120 DELETER.
022140 IF MODE-FLAG = 1 DISPLAY
022160 ' %Only browse permitted - rejected'
022180 UPON CONSOLE GO TO COMMAND-LOOP.
022200 MOVE 0 TO REC-COUNT.
022220 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
022240 IF FOUND-WORD-1 = ' '
022260 MOVE 1 TO REC-COUNT1
022280 GO TO DELETER1.
022300* *NOW CRACK USER'S INPUT RECORD COUNT*.
022320* *IF NOT NUMERIC, MAY BE A FINDLIST*.
022340 IF NUM-VAL-FLAG NOT = 1 GO TO DELETER2.
022360 PERFORM NUM-ARG THRU NUM-ARG-EXIT.
022380 MOVE NHOLDER8 TO REC-COUNT1.
022400 DELETER1.
022420* *DELETE N RECORDS SEQUENTIALLY*
022440 IF READ-FLAG = 3 OR WRITE-FLAG = 0
022460 MOVE ' %No current record to delete'
022480 TO DISPLAY-LINE
022500 PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT
022520 GO TO COMMAND-LOOP.
022540 IF READ-FLAG = 2
022560 PERFORM NOTIFY-EOF THRU NOTIFY-EOF-EXIT
022580 GO TO DELETER4.
022600 IF KEYLOC NOT = 0
022620 PERFORM DELETE-ISAM THRU DELETE-ISAM-EXIT.
022640 PERFORM READ-IN THRU READ-IN-EXIT.
022660 ADD 1 TO REC-COUNT.
022680 IF REC-COUNT LESS THAN REC-COUNT1
022700 GO TO DELETER1.
022720 GO TO DELETER4.
022740 DELETER2.
022760* *IF USER FURNISHED A FINDLIST, CRACK IT*
022780 PERFORM CRACK-FINDLIST THRU CRACK-FINDLIST-EXIT.
022800 IF FIND-ERR-FLAG NOT = 0
022820 GO TO COMMAND-ERR.
022840 MOVE 1 TO FIND-AHEAD-FLAG.
022860 DELETER3.
022880* *FIND NEXT RECORD MATCHING FINDLIST AND DELETE IT*
022900 PERFORM FIND-RECORD THRU FIND-RECORD-EXIT.
022920 IF READ-FLAG = 2
022940 PERFORM NOTIFY-EOF THRU NOTIFY-EOF-EXIT
022960 GO TO DELETER4.
022980 PERFORM READ-IN THRU READ-IN-EXIT.
023000 IF KEYLOC NOT = 0
023020 PERFORM DELETE-ISAM THRU DELETE-ISAM-EXIT.
023040 ADD 1 TO REC-COUNT.
023060* *UNLESS USER SAID 'ALL' IN FINDLIST, ONLY DELETE
023080* * THE FIRST RECORD FOUND*
023100 IF ALL-FLAG = 1 MOVE 0 TO FIND-AHEAD-FLAG
023120 GO TO DELETER3.
023140 DELETER4.
023160 MOVE REC-COUNT TO NHOLDER8.
023180 DISPLAY ' (Records deleted: ' NHOLDER8 ')' UPON CONSOLE.
023200 MOVE 1 TO CHANGES-FLAG.
023220 GO TO COMMAND-LOOP.
023240
023260**********************************************************
023280* SEQUENCE 'CHANGER' TO CHANGE RECORDS
023300**********************************************************
023320 CHANGER.
023340 IF MODE-FLAG = 1 DISPLAY
023360 ' %Only browse permitted - rejected'
023380 UPON CONSOLE GO TO COMMAND-LOOP.
023400 SET CHX TO 1.
023420 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
023440 IF FOUND-WORD-1 = ' ' GO TO COMMAND-ERR.
023460* *HERE IF HAVE A CHANGELIST OR A FINDLIST*.
023480 CHANGER1.
023500* *SET UP CHANGELIST*.
023520 PERFORM FIND-DICT THRU FIND-DICT-EXIT.
023540 IF DX = 0
023560 MOVE 0 TO DX-CHG-PTR (1)
023580 PERFORM DICT-MISSED
023600 GO TO COMMAND-ERR.
023620 SET DX-CHG-PTR (CHX) TO DX.
023640 CHANGER2.
023660 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
023680 IF LITERAL-VAL-FLAG = 1 GO TO CHANGER3.
023700 IF FOUND-WORD-1 = ' ' GO TO COMMAND-ERR.
023720 IF FOUND6-WORD-7 = 'TO ' OR
023740 FOUND6-WORD-7 = '= ' OR
023760 FOUND6-WORD-7 = 'EQ ' OR
023780 FOUND6-WORD-7 = 'EQUAL ' OR
023800 FOUND6-WORD-7 = 'EQUALS ' OR
023820 FOUND6-WORD-7 = 'IS ' GO TO CHANGER2.
023840 CHANGER3.
023860 MOVE FOUND-WORD TO HOLDER.
023880 IF TYPEV-ELEM = '1'
023900 PERFORM ALPHA-LENGTH THRU ALPHA-LENGTH-EXIT
023920 ELSE PERFORM JUST-RIGHT THRU JUST-RIGHT-EXIT.
023940 IF ENTRY-ERROR NOT = 0
023960 PERFORM VALUE-ERR THRU VALUE-ERR-EXIT
023980 GO TO COMMAND-ERR.
024000 CHANGER4.
024020 MOVE HOLDER TO CHG-VALUE (CHX).
024040 SET CHX UP BY 1.
024060 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
024080 IF LITERAL-VAL-FLAG = 1 NEXT SENTENCE ELSE
024100 IF FOUND6-WORD-6 = ' ' OR 'IF ' OR 'IN ' OR 'FOR '
024120 OR 'WHERE ' OR 'WHEN '
024140 MOVE 0 TO DX-CHG-PTR (CHX)
024160 GO TO CHANGER5.
024180 IF CHX GREATER THAN MAX-CHG-ITEMS
024200 MOVE ' %Too many change items'
024220 TO DISPLAY-LINE
024240 PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT
024260 GO TO COMMAND-ERR.
024280 GO TO CHANGER1.
024300* *NOW LOOK FOR A FINDLIST; IF NONE UPDATE ONLY
024320* *CURRENT RECORD*.
024340 CHANGER5.
024360 MOVE 0 TO FIND-TEST (1) DX-FIND-PTR (1).
024380 MOVE 0 TO ALL-FLAG.
024400 IF FOUND-WORD-1 = ' ' SET CHX TO 1 GO TO CHANGER7.
024420 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
024440 PERFORM CRACK-FINDLIST THRU CRACK-FINDLIST-EXIT.
024460 IF FIND-ERR-FLAG NOT = 0 GO TO COMMAND-ERR.
024480* *LOOK FOR RECORD MATCHING FINDLIST*.
024500 CHANGER6.
024520 MOVE 1 TO FIND-AHEAD-FLAG.
024540 PERFORM FIND-RECORD THRU FIND-RECORD-EXIT.
024560 IF READ-FLAG = 2
024580 MOVE 1 TO CHANGES-FLAG
024600 PERFORM NOTIFY-EOF THRU NOTIFY-EOF-EXIT
024620 GO TO COMMAND-LOOP.
024640 SET CHX TO 1.
024660* *PERFORM ACTUAL CHANGE OF RECORD*.
024680 CHANGER7.
024700 IF READ-FLAG NOT = 1 OR WRITE-FLAG = 0
024720 DISPLAY ' %No current record to change'
024740 UPON CONSOLE GO TO COMMAND-LOOP.
024760 SET DX TO DX-CHG-PTR (CHX).
024780 IF DX = 0 GO TO CHANGER8.
024800 MOVE CHG-VALUE (CHX) TO HOLDER.
024820 MOVE DYN-DD-ENTRY (DX) TO ELEM-DD-ENTRY.
024840 PERFORM SET-VALUE THRU SET-VALUE-EXIT.
024860 SET CHX UP BY 1.
024880 GO TO CHANGER7.
024900 CHANGER8.
024920 IF KEYLOC NOT = 0
024940 PERFORM SET-SYMKEY THRU SET-SYMKEY-EXIT
024960 PERFORM REWRITE-ISAM THRU
024980 REWRITE-ISAM-EXIT.
025000 IF VERIFY-FLAG = 1
025020 PERFORM DISPLAY-REC THRU DISPLAY-REC-EXIT.
025040 IF ALL-FLAG = 1 GO TO CHANGER6.
025060 MOVE 1 TO CHANGES-FLAG.
025080 GO TO COMMAND-LOOP.
025100
025120********************************************************
025140* TREAT ANY UNIMPLEMENTED COMMANDS.
025160**********************************************************
025180 MISSING-COMMAND.
025200 MOVE ' %This command not implemented yet - ignored'
025220 TO DISPLAY-LINE.
025240 PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT.
025260 GO TO COMMAND-LOOP.
025280
025300**********************************************************
025320* SEQUENCE 'LISTER' TO LIST SELECTED COLUMNS OR ITEMS
025340* OF A RECORD.
025360**********************************************************
025380 LISTER.
025400 MOVE 1 TO REC-COUNT1 FINDING-FLAG.
025420 MOVE 0 TO DX-LST-PTR (1) ALL-FLAG.
025440 SET LSX TO 1. SET DIX TO 1.
025460 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
025480 IF FOUND-WORD-1 = ' ' MOVE 0 TO FINDING-FLAG
025500 GO TO LISTER-NAMES5A.
025520 IF NUM-VAL-FLAG = 0
025540 GO TO LISTER-NAMES.
025560 PERFORM NUM-ARG THRU NUM-ARG-EXIT.
025580 MOVE NHOLDER8 TO REC-COUNT1.
025600 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
025620 LISTER-NAMES.
025640* *PROCESS LIST OF ITEM NAMES TO BE DISPLAYED*.
025660 IF LITERAL-VAL-FLAG = 1 GO TO LISTER-NAMES1.
025680 IF FOUND-WORD-1 = ' ' MOVE 0 TO FINDING-FLAG
025700 GO TO LISTER-NAMES5A.
025720 IF FOUND6-WORD-6 = 'IF ' OR 'IN ' OR 'FOR '
025740 OR 'WHERE ' OR 'WHEN '
025760 GO TO LISTER-NAMES3.
025780 IF FOUND6-WORD-6 = 'ALL ' OR 'NEXT '
025800 OR 'FIRST ' GO TO LISTER-NAMES4.
025820 LISTER-NAMES1.
025840 PERFORM FIND-DICT THRU FIND-DICT-EXIT.
025860* *SEE IF HAVE A FINDLIST STARTED BY ITEM REL*.
025880 IF DX NOT = 0 GO TO LISTER-NAMES2.
025900 IF FOUND6-WORD-4 = 'NOT ' NEXT SENTENCE
025920 ELSE PERFORM FIND-REL THRU FIND-REL-EXIT
025940 IF REX = 0 PERFORM DICT-MISSED
025960 MOVE 0 TO DX-LST-PTR (1)
025980 GO TO COMMAND-ERR.
026000 IF LSX GREATER THAN 1 SET LSX DOWN BY 1.
026020 MOVE 0 TO DX-LST-PTR (LSX).
026040 SET ANX TO PREV-START-ANX.
026060 GO TO LISTER-NAMES3.
026080 LISTER-NAMES2.
026100 IF LSX GREATER THAN MAX-LST-ITEMS
026120 MOVE ' %Too many list items' TO DISPLAY-LINE
026140 PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT
026160 GO TO COMMAND-ERR.
026180 SET DX-LST-PTR (LSX) TO DX.
026200* *KEEP TRACK OF POSSIBLE OVERFLOW IN DISPLAY LINE*.
026220 IF DIX GREATER THAN DISPLAY-MAX
026240 PERFORM FIND-WORD THRU FIND-WORD-EXIT
026260 GO TO LISTER-NAMES.
026280 SET DIX UP BY NCHAR-ELEM.
026300 IF DIX GREATER THAN DISPLAY-MAX
026320 MOVE ' %Display line will be truncated'
026340 TO DISPLAY-LINE
026360 PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT.
026380 IF TYPEV-ELEM = '1' SET DIX UP BY 1
026400 ELSE SET DIX UP BY 2.
026420 SET LSX UP BY 1.
026440 MOVE 0 TO DX-LST-PTR (LSX).
026460 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
026480 GO TO LISTER-NAMES.
026500 LISTER-NAMES3.
026520* *NOW CRACK ANY FIND LIST PROVIDED*.
026540 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
026560 LISTER-NAMES4.
026580* *TEST FOR DISPLAY LINE OVERFLOW*.
026600 MOVE 0 TO FIND-AHEAD-FLAG.
026620 PERFORM CRACK-FINDLIST THRU CRACK-FINDLIST-EXIT.
026640 IF FIND-ERR-FLAG = 1 GO TO COMMAND-ERR.
026660 LISTER-NAMES5.
026680* *GET APPROPRIATE RECORD*.
026700 IF FINDING-FLAG NOT = 0
026720 PERFORM FIND-RECORD THRU FIND-RECORD-EXIT
026740 GO TO LISTER-NAMES5A.
026760 IF READ-FLAG NOT = 3
026780 PERFORM WRITE-OUT THRU WRITE-OUT-EXIT.
026800 PERFORM READ-IN THRU READ-IN-EXIT.
026820 LISTER-NAMES5A.
026840 IF READ-FLAG = 2
026860 PERFORM NOTIFY-EOF THRU NOTIFY-EOF-EXIT
026880 GO TO COMMAND-LOOP.
026900 IF READ-FLAG = 3 GO TO LISTER-NAMES5.
026920 IF DX-LST-PTR (1) NOT = 0
026940 GO TO LISTER-NAMES6.
026960 PERFORM DISPLAY-REC THRU DISPLAY-REC-EXIT.
026980 IF ALL-FLAG = 1 GO TO LISTER-NAMES5.
027000 SUBTRACT 1 FROM REC-COUNT1.
027020 IF REC-COUNT1 GREATER THAN 0 GO TO LISTER-NAMES5.
027040 GO TO COMMAND-LOOP.
027060 LISTER-NAMES6.
027080 SET LSX TO 1. SET DIX TO 1.
027100 MOVE SPACES TO DISPLAY-LINE.
027120 LISTER-NAMES7.
027140 SET DX TO DX-LST-PTR (LSX).
027160 IF DX = 0 GO TO LISTER-NAMES10.
027180 MOVE DYN-DD-ENTRY (DX) TO ELEM-DD-ENTRY.
027200 SET WORKDEX TO DIX.
027220
027940* *IF ALPHA AND NO EDIT MOVE DIRECTLY INTO IMAGE*
027960 IF TYPEV-ELEM = '1' AND PICT-ELEM = SPACES
027970 IF DICT-FILETYPE = '6'
027980 ENTER MACRO IQSX67 USING NCHAR-ELEM
028000 QIFLE6-REC FCHAR-ELEM DISPLAY-LINE WORKDEX
028020 GO TO LISTER-NAMES7A
028024 ELSE ENTER MACRO IQSX77 USING NCHAR-ELEM
028028 QIFLE7-REC FCHAR-ELEM DISPLAY-LINE WORKDEX
028032 GO TO LISTER-NAMES7A.
028060 MOVE TYPEVN-ELEM TO TRUE-TYPEV.
028080 PERFORM GET-VALUE THRU GET-VALUE-EXIT.
028090 MOVE HOLDER TO HOLDER-SIX.
028090 MOVE PICT-ELEM TO PICT-IN.
028100 ENTER MACRO IQPICT.
028120 ENTER MACRO IQSX67 USING ECHAR-ELEM PICT-WORK
028140 CONST1 DISPLAY-LINE WORKDEX.
028160
028180 LISTER-NAMES7A.
028200 SET DIX UP BY ECHAR-ELEM.
028240
028260 SET DIX UP BY 1.
028280 LISTER-NAMES9.
028300 SET DIX UP BY 1.
028320 IF DIX GREATER THAN DISPLAY-MAX GO TO LISTER-NAMES10.
028340 SET LSX UP BY 1.
028360 GO TO LISTER-NAMES7.
028380 LISTER-NAMES10.
028400 PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT.
028420 IF ALL-FLAG = 1 GO TO LISTER-NAMES5.
028440 SUBTRACT 1 FROM REC-COUNT1.
028460 IF REC-COUNT1 GREATER THAN 0 GO TO LISTER-NAMES5.
028480 GO TO COMMAND-LOOP.
028500
028520*****************************************************
028540* SEQUENCE 'EXTRACTER' TO EXTRACT A SUBSET OF RECORDS
028560* FROM THE CURRENT INPUT FILE AND WORK WITH THAT
028580* SUBSET FROM NOW ON.
028600* NOTE THAT EXTRACTER ALWAYS WORKS FROM THE START OF THE
028620* INPUT FILE*
028640*****************************************************
028660 EXTRACTER.
028680 IF KEYLOC NOT = 0
028700 DISPLAY ' %This version cannot extract ISAM files'
028720 UPON CONSOLE
028740 GO TO COMMAND-LOOP.
028760* *SEE IF USING OVER-RIDE FILE NAME OPTION*
028780 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
028800 IF FOUND6-WORD-3 NOT = 'TO '
028820 MOVE EXTRACT-TEMP-ID TO EXTRACT-ID
028840 ELSE PERFORM FIND-WORD THRU FIND-WORD-EXIT
028860 PERFORM FILE-PARSER THRU FILE-PARSER-EXIT
028880 MOVE PARSED-FILE-NAME TO EXTRACT-ID
028900 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
028920* *NOW CRACK FIND LIST CONTROLING EXTRACT*
028940*====* MAY WANT TO PUT A NO OF RECORD OPTION HERE*
028960 PERFORM CRACK-FINDLIST THRU CRACK-FINDLIST-EXIT.
028980 IF FIND-ERR-FLAG = 1 GO TO COMMAND-ERR.
029000 MOVE ' (' TO MSG-MARK.
029020 MOVE EXTRACT-ID TO MSG-NAME.
029040 MOVE ' is your extracted file)' TO MSG-TEXT.
029060 PERFORM DISPLAY-MSG THRU DISPLAY-MSG-EXIT.
029080* *NOW SAVE CURRENT FILE IF NECESSARY*
029100 PERFORM SAVE-FILE THRU SAVE-FILE-EXIT.
029120 MOVE 0 TO REC-COUNT.
029140* *SET UP FILE NAMES FOR EXTRACT PASS*
029160 MOVE EXTRACT-ID TO CURRENT-ID-OUT.
029180 PERFORM OPEN-IN THRU OPEN-IN-EXIT.
029200 PERFORM OPEN-OUT THRU OPEN-OUT-EXIT.
029220
029240 EXTRACTER3.
029260* *NOW DO THE EXTRACT*
029280*====*THINK ABOUT NOTIFY OR AUTO SET OF ALL IF DID NOT
029300*====* FIND ALL IN FIND LIST*
029320 PERFORM FIND-RECORD-NOWRITE THRU FIND-RECORD-EXIT.
029340 IF READ-FLAG = 2 GO TO EXTRACTER4.
029360 PERFORM WRITE-OUT THRU WRITE-OUT-EXIT.
029380 ADD 1 TO REC-COUNT.
029400 IF ALL-FLAG =1 GO TO EXTRACTER3.
029420
029440 EXTRACTER4.
029460* *NOW NOTIFY OF RECORDS EXTRACTED AND GET OUT*
029480 MOVE REC-COUNT TO NHOLDER8.
029500 MOVE ' (' TO MSG-MARK.
029520 MOVE 'Records extracted' TO MSG-NAME.
029540 MOVE NHOLDER8 TO MSG-TEXT.
029560 PERFORM DISPLAY-MSG THRU DISPLAY-MSG-EXIT.
029580 PERFORM CLOSE-IN THRU CLOSE-IN-EXIT.
029600 PERFORM CLOSE-OUT.
029620 MOVE EXTRACT-ID TO CURRENT-ID-IN.
029640 MOVE QTNNNU-ID TO CURRENT-ID-OUT.
029660 PERFORM OPEN-IN THRU OPEN-IN-EXIT.
029680 PERFORM OPEN-OUT THRU OPEN-OUT-EXIT.
029700 GO TO COMMAND-LOOP.
029720
029740********************************************************
029760* SEQUENCE 'SAVER' TO SAVE CURRENT VERSION OF FILE
029780********************************************************
029800 SAVER.
029820 IF KEYLOC NOT = 0
029840 DISPLAY ' %Save not meaningful for ISAM'
029860 UPON CONSOLE
029880 GO TO COMMAND-LOOP.
029900 PERFORM SAVE-FILE THRU SAVE-FILE-EXIT.
029920 PERFORM OPEN-IN THRU OPEN-IN-EXIT.
029940 PERFORM OPEN-OUT THRU OPEN-OUT-EXIT.
029960 GO TO COMMAND-LOOP.
029980
030000********************************************************
030020* SEQUENCE 'IQL-CALLER' TO CLOSE UP FILES AND GO TO IQL.
030040**********************************************************
030060 IQL-CALL.
030080 MOVE 'IQL ' TO CALLED-NAME.
030100 GO TO ENDER1.
030120
030140********************************************************
030160* SEQUENCE 'ENDER' TO CLOSE UP FILES AND END RUN.
030180**********************************************************
030200 ENDER.
030220* *THIS SET UP TO GO BACK TO IQL ALL THE TIME.
030240* *TO SET IT TO GO TO THE MONITOR, USE SPACES.
030260 MOVE 'IQL ' TO CALLED-NAME.
030280 ENDER1.
030300 PERFORM SAVE-FILE THRU SAVE-FILE-EXIT.
030320* *BELOW 2 LINES UPDATE DIARY FILE*.
030340 PERFORM OPEN-IN THRU OPEN-IN-EXIT.
030360 PERFORM CLOSE-IN THRU CLOSE-IN-EXIT.
030380 MOVE ' (End of Immediate Mode Session)'
030400 TO DISPLAY-LINE.
030420 PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT.
030440 GO TO COMPLETE-IU.
030460
030480**********************************************************
030500* SEQUENCE 'VERIFY' TO SET VERIFICATION MODE ON.
030520**********************************************************
030540 VERIFIER.
030560 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
030580 MOVE 1 TO VERIFY-FLAG.
030600 IF FOUND6-WORD-3 = ' ' OR 'ON '
030620 GO TO COMMAND-LOOP.
030640 IF FOUND6-WORD-4 = 'OFF '
030660 MOVE 0 TO VERIFY-FLAG
030680 GO TO COMMAND-LOOP.
030700 GO TO COMMAND-ERR.
030720
030740***********************************************************
030760* SUBROUTINE 'CRACK-FINDLIST' TO DECIPHER USER'S
030780* FIND LIST TO LOCATE A RECORD AND SET IT UP
030800* AS PARAMETERS IN DX-FIND-STACK*.
030820***********************************************************
030840 CRACK-FINDLIST.
030860 MOVE 0 TO FIND-ERR-FLAG ALL-FLAG FIRST-FLAG
030880 FIND-AHEAD-FLAG RANDOM-READ-FLAG.
030900 MOVE 0 TO DX-FIND-PTR (1) FIND-TEST (1).
030920 SET FIX TO 1.
030940 GO TO IGNORE-WORD-1.
030960** NOTE IGNORE WORD THRU VALUE STACKER2 IS BASIC LOOP **
030980 IGNORE-WORD.
031000 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
031020 IGNORE-WORD-1.
031040 IF LITERAL-VAL-FLAG = 1 GO TO DX-FIND-STACKER.
031060 IF FOUND-WORD-1 = ' ' GO TO CRACK-FINDLIST-OKAY.
031080 IF FOUND6-WORD-5 = 'WHEN ' OR
031100 FOUND6-WORD-7 = 'RECORD ' OR
031120 FOUND6-WORD-8 = 'RECORDS ' OR
031140 FOUND6-WORD-6 = 'WHERE ' OR
031160 FOUND6-WORD-4 = 'FOR ' OR
031180 FOUND6-WORD-4 = 'AND ' OR
031200 FOUND6-WORD-3 = 'IF '
031220 GO TO IGNORE-WORD.
031240 IF FOUND6-WORD-5 = 'NEXT ' MOVE 1 TO FIND-AHEAD-FLAG
031250 MOVE 0 TO ALL-FLAG FIRST-FLAG
031260 GO TO IGNORE-WORD.
031280 IF FOUND6-WORD-4 = 'ALL ' MOVE 1 TO ALL-FLAG
031290 MOVE 0 TO FIND-AHEAD-FLAG FIRST-FLAG
031300 GO TO IGNORE-WORD.
031320 IF FOUND6-WORD-6 = 'FIRST ' MOVE 1 TO FIRST-FLAG
031330 MOVE 0 TO ALL-FLAG FIND-AHEAD-FLAG
031340 GO TO IGNORE-WORD.
031360 START-DX-FIND-STACK.
031380* *HAVE SOUGHT ITEM NAME: LOOK IT UP IN DICTIONARY*.
031400 DX-FIND-STACKER.
031420* *IF HIT SPECIAL WORD 'KEY' MARK IT IN FINDLIST **
031440 MOVE 0 TO REL-INCR.
031460 IF FOUND6-WORD-4 NOT = 'KEY ' GO TO DX-FIND-STACKER1.
031480 IF FIX NOT = 1
031500 DISPLAY ' %Key entry must be at start of find list'
031520 UPON CONSOLE
031540 GO TO COMMAND-LOOP.
031560 MOVE 1 TO RANDOM-READ-FLAG.
031580 MOVE -1 TO DX-FIND-PTR(FIX).
031600
031620* BUILD DUMMY DICT ENTRY FOR KEY- JUST ALPHA FOR NOW*.
031680 MOVE 'KEY' TO NAME-ELEM.
031700 MOVE '1' TO TYPEV-ELEM.
031720 MOVE KEYLEN TO NCHAR-ELEM.
031740 MOVE 0 TO SCALE-ELEM.
031760 GO TO REL-STACKER.
031780 DX-FIND-STACKER1.
031800 PERFORM FIND-DICT THRU FIND-DICT-EXIT.
031820 IF DX = 0
031840 PERFORM DICT-MISSED
031860 GO TO CRACK-FINDLIST-ERROR.
031880 IF FIX IS GREATER THAN MAX-FIND-ITEMS
031900 MOVE ' %Too many find items'
031920 TO DISPLAY-LINE
031940 PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT
031960 GO TO CRACK-FINDLIST-ERROR.
031980 SET DX-FIND-PTR (FIX) TO DX.
032000 REL-STACKER.
032020* *NOW PROCESS RELATIONAL; IF NONE, ASSUME 'EQ'.
032040* * 'NOT' RELATIONSHIPS ARE KICKED BY ONE.*
032060 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
032080 IF LITERAL-VAL-FLAG = 1
032100 SET REX TO 1 SET REX UP BY REL-INCR GO TO REL-STACKER3.
032120 IF FOUND6-WORD-4 NOT = 'NOT ' GO TO REL-STACKER1.
032140 IF REL-INCR = 0 MOVE 1 TO REL-INCR
032160 ELSE MOVE 0 TO REL-INCR.
032180 GO TO REL-STACKER.
032200 REL-STACKER1.
032220 PERFORM FIND-REL THRU FIND-REL-EXIT.
032240 IF REX = 0 SET REX TO 1
032260 SET REX UP BY REL-INCR GO TO REL-STACKER3.
032280* *IF COULD NOT FIND WORD IN RELATIONALS, ASSUME
032300* * 'EQ' AND LOOK FOR WORD AS VALUE OF AN ITEM
032320* * TO BE TESTED.*
032340 SET REX UP BY REL-INCR.
032360 IF REX = 3 SET REX TO 1 GO TO REL-STACKER2.
032380 IF REX = 6 SET REX TO 4 GO TO REL-STACKER2.
032400 IF REX = 9 SET REX TO 7.
032420 REL-STACKER2.
032440 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
032460 REL-STACKER3.
032480 SET FIND-TEST (FIX) TO REX.
032500 VALUE-STACKER.
032520 MOVE FOUND-WORD TO HOLDER.
032540 IF TYPEV-ELEM = '1'
032560 PERFORM ALPHA-LENGTH THRU ALPHA-LENGTH-EXIT
032580 ELSE PERFORM JUST-RIGHT THRU JUST-RIGHT-EXIT.
032600 IF ENTRY-ERROR NOT = 0
032620 PERFORM VALUE-ERR THRU VALUE-ERR-EXIT
032640 GO TO CRACK-FINDLIST-ERROR.
032660 MOVE HOLDER TO FIND-VALUE (FIX).
032680 GO TO VALUE-STACKER2.
032700 VALUE-STACKER1.
032720* *BELOW IN RESERVE FOR POSSIBLE ITEM-ITEM TESTS
032740* IF LITERAL-VAL-FLAG = 1
032760* MOVE FOUND-WORD TO FIND-VALUE (FIX)
032780* GO TO VALUE-STACKER2.
032800* PERFORM FIND-DICT THRU FIND-DICT-EXIT.
032820* IF DX = 0
032840* MOVE FOUND-WORD-30 TO DISPLAY-LINE
032860* PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT
032880* MOVE ' (not an item name; taking as a value)'
032900* TO DISPLAY-LINE
032920* PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT
032940* MOVE FOUND-WORD TO FIND-VALUE (FIX)
032960* GO TO VALUE-STACKER2.
032980* MOVE ' %Item-item tests not in this version'
033000* TO DISPLAY-LINE.
033020* PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT.
033040* MOVE 1 TO FIND-ERR-FLAG.
033060* GO TO CRACK-FINDLIST-EXIT.
033080 VALUE-STACKER2.
033100 SET FIX UP BY 1.
033120 MOVE 0 TO FIND-TEST (FIX).
033140 MOVE 0 TO DX-FIND-PTR (FIX).
033160 GO TO IGNORE-WORD.
033180 CRACK-FINDLIST-ERROR.
033200 MOVE 0 TO ALL-FLAG FIRST-FLAG FIND-AHEAD-FLAG
033220 DX-FIND-PTR (1) FIND-TEST (1).
033240 MOVE 1 TO FIND-ERR-FLAG.
033260 GO TO CRACK-FINDLIST-EXIT.
033280 CRACK-FINDLIST-OKAY.
033300 IF ALL-FLAG = 0 AND FIRST-FLAG = 0
033320 MOVE 1 TO FIND-AHEAD-FLAG.
033340 CRACK-FINDLIST-EXIT.
033360 EXIT.
033380
033400**********************************************************
033420* SUBROUTINE 'FIND-RECORD' TO FIND NEXT RECORD WHICH
033440* SATISFIES CURRENT FIND LIST.
033460* IF FIND-AHEAD-FLAG IS 0, SEARCH STARTS WITH
033480* THE CURRENT RECORD; OTHERWISE STARTS WITH NEXT*
033500*********************************************************
033520 FIND-RECORD-NOWRITE.
033540 MOVE 0 TO FIND-WRITE-FLAG.
033560 GO TO FIND-RECORD-COMMON.
033580
033600 FIND-RECORD.
033620 MOVE 1 TO FIND-WRITE-FLAG.
033640
033660 FIND-RECORD-COMMON.
033680* *NOTE THAT 'ALL' LOOKS AT CURRENT AND DOWNSTREAM RECORDS
033700* * IT DOES NOT GO TO BEGINNING BEFORE STARTING SEARCH.
033720 IF FIRST-FLAG = 1
033740 PERFORM SWITCH-INPUT THRU SWITCH-INPUT-EXIT.
033760 FIND-RECORD1.
033780 SET FIX TO 1.
033800 MOVE DX-FIND-PARAM (FIX) TO DX-FIND-ELEM.
033820 IF DX-FIND-PTR-ELEM = -1 GO TO FIND-RECORD3.
033840 IF READ-FLAG = 2 GO TO FIND-RECORD-EXIT.
033860 IF READ-FLAG NOT = 3 AND
033880 FIND-AHEAD-FLAG = 0 GO TO FIND-RECORD3.
033900 IF READ-FLAG = 1 AND FIND-WRITE-FLAG = 1
033920 PERFORM WRITE-OUT THRU WRITE-OUT-EXIT.
033940 PERFORM READ-IN THRU READ-IN-EXIT.
033960 GO TO FIND-RECORD3.
033980 FIND-RECORD2.
034000 SET FIX UP BY 1.
034020 FIND-RECORD3.
034040 MOVE 1 TO FIND-AHEAD-FLAG.
034060 MOVE DX-FIND-PARAM (FIX) TO DX-FIND-ELEM.
034080 IF FIND-TEST-ELEM = 0 GO TO FIND-RECORD-EXIT.
034100 SET DX TO DX-FIND-PTR-ELEM.
034120
034140* *PROCESS ISAM KEYED READ*.
034180 IF DX = -1
034200 PERFORM ISAM-KEY-FIND THRU ISAM-KEY-FIND-EXIT
034220 GO TO FIND-RECORD-EXIT.
034240 IF DX = 0 GO TO FIND-RECORD-EXIT.
034260 MOVE DYN-DD-ENTRY (DX) TO ELEM-DD-ENTRY.
034280 PERFORM GET-VALUE THRU GET-VALUE-EXIT.
034300 IF TYPEV-ELEM = '1' GO TO FIND-RECORDA.
034320
034340 FIND-RECORDN.
034350 MOVE NHOLDER18 TO NHOLDER18-SIX.
034360 GO TO NVALUE-EQ NVALUE-NEQ NVALUE-ERR NVALUE-GR
034380 NVALUE-LEQ NVALUE-ERR NVALUE-LS NVALUE-GEQ
034400 DEPENDING ON FIND-TEST-ELEM.
034420 NVALUE-ERR. GO TO AVALUE-ERR.
034440 NVALUE-EQ.
034460 IF NHOLDER18-SIX = FIND-VALUEN-ELEM GO TO FIND-RECORD2.
034480 GO TO FIND-RECORD1.
034500 NVALUE-NEQ.
034520 IF NHOLDER18-SIX NOT = FIND-VALUEN-ELEM GO TO FIND-RECORD2.
034540 GO TO FIND-RECORD1.
034560 NVALUE-GR.
034580 IF NHOLDER18-SIX GREATER THAN FIND-VALUEN-ELEM
034600 GO TO FIND-RECORD2.
034620 GO TO FIND-RECORD1.
034640 NVALUE-LEQ.
034660 IF NHOLDER18-SIX NOT GREATER THAN FIND-VALUEN-ELEM
034680 GO TO FIND-RECORD2.
034700 GO TO FIND-RECORD1.
034720 NVALUE-LS.
034740 IF NHOLDER18-SIX LESS THAN FIND-VALUEN-ELEM
034760 GO TO FIND-RECORD2.
034780 GO TO FIND-RECORD1.
034800 NVALUE-GEQ.
034820 IF NHOLDER18-SIX NOT LESS THAN FIND-VALUEN-ELEM
034840 GO TO FIND-RECORD2.
034860 GO TO FIND-RECORD1.
034880
034900 FIND-RECORDA.
034910 MOVE HOLDER TO HOLDER-SIX.
034920 GO TO AVALUE-EQ AVALUE-NEQ AVALUE-ERR AVALUE-GR
034940 AVALUE-LEQ AVALUE-ERR AVALUE-LS AVALUE-GEQ
034960 DEPENDING ON FIND-TEST-ELEM.
034980 AVALUE-ERR.
035000 MOVE ' %value - relationship error'
035020 TO DISPLAY-LINE.
035040 PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT.
035060 GO TO FIND-RECORD-EXIT.
035080 AVALUE-EQ.
035100 IF HOLDER-SIX = FIND-VALUE-ELEM GO TO FIND-RECORD2.
035120 GO TO FIND-RECORD1.
035140 AVALUE-NEQ.
035160 IF HOLDER-SIX NOT = FIND-VALUE-ELEM GO TO FIND-RECORD2.
035180 GO TO FIND-RECORD1.
035200 AVALUE-GR.
035220 IF HOLDER-SIX IS GREATER THAN FIND-VALUE-ELEM
035240 GO TO FIND-RECORD2.
035260 GO TO FIND-RECORD1.
035280 AVALUE-LEQ.
035300 IF HOLDER-SIX NOT GREATER THAN FIND-VALUE-ELEM
035320 GO TO FIND-RECORD2.
035340 GO TO FIND-RECORD1.
035360 AVALUE-LS.
035380 IF HOLDER-SIX LESS THAN FIND-VALUE-ELEM
035400 GO TO FIND-RECORD2.
035420 GO TO FIND-RECORD1.
035440 AVALUE-GEQ.
035460 IF HOLDER-SIX NOT LESS THAN FIND-VALUE-ELEM
035480 GO TO FIND-RECORD2.
035500 GO TO FIND-RECORD1.
035520 FIND-RECORD-EXIT.
035540 EXIT.
035560
035580***********************************************************
035600* SUBROUTINE 'FIND-VOCAB' TO SEARCH COMMAND VOCABULARY
035620* FOR MATCH ON COMMAND FURNISHED BY USER.
035640* ONLY LOOKS AT FIRST THREE CHARACTERS.
035660* EXITS WITH VOX SET TO # OF VOCABWORD,
035680* VOX = 0 IF NO HIT.
035700***********************************************************
035720 FIND-VOCAB.
035740 SET VOX TO 1.
035760 FIND-VOCAB1.
035780 MOVE VOCAB (VOX) TO CHAR-WORK3.
035800 IF FOUND6-WORD-3 = CHAR-WORK3 GO TO FIND-VOCAB-EXIT.
035820 IF CHAR-WORK3 = ' ' GO TO FIND-VOCAB2.
035840 SET VOX UP BY 1.
035860 GO TO FIND-VOCAB1.
035880 FIND-VOCAB2.
035900* *IF NO HITS, SET VOX TO 0 AS INDICATOR*.
035920 SET VOX TO 0.
035940 FIND-VOCAB-EXIT.
035960 EXIT.
035980
036000**********************************************************
036020* SUBROUTINE 'FIND-REL' TO SEARCH LIST OF
036040* RELATIONSHIPS. IF HITS SETS RETURN VALUE IN REX;
036060* IF DOES NOT HIT SETS REX TO 0.
036080* VALUES RETURNED IN REX ARE:
036100* 1 = EQUALS
036120* 2 = IS NOT EQUAL TO
036140* 4 = GREATER THAN
036160* 5 = LESS THAN OR EQUAL TO
036180* 7 = LESS THAN
036200* 8 = GREATER THAN OR EQUAL TO
036220* *SEE TABLES 'RELATIONSHIPS' AND
036240* ** 'RELATION-NOS' IN WORKING STORAGE*.
036260**********************************************************
036280 FIND-REL.
036300 SET REX TO 1.
036320 FIND-REL1.
036340 MOVE RELAT (REX) TO CHAR-WORK7.
036360 IF CHAR-WORK7 = FOUND6-WORD-7
036380 SET WORKX TO REX
036400 SET REX TO RELAT-NO (WORKX)
036420 GO TO FIND-REL-EXIT.
036440 IF CHAR-WORK7 = ' ' SET REX TO 0
036460 GO TO FIND-REL-EXIT.
036480 SET REX UP BY 1.
036500 GO TO FIND-REL1.
036520 FIND-REL-EXIT.
036540 EXIT.
036560
036580***********************************************************
036600* SUBROUTINE 'FIND-DICT' TO FIND ITEM NAME IN
036620* DYNAMIC DICTIONARY. IF NOT FOUND, EXITS WITH DX = 0.
036640* IF FOUND, EXITS WITH DX = ENTRY IN DYNAMIC DICT.
036660* THIS SUBROUTINE
036680* IS SMART ENOUGH TO GET ENTRY OUT OF WORKING DICT
036700* FILE IF THE DYNAMIC DICT IN CORE IS FULL.
036720***********************************************************
036740 FIND-DICT.
036760 SET DX TO 1.
036780 FIND-DICT1.
036800* *LOOK FOR MATCH IN DYNAMIC DICTIONARY*.
036820 MOVE DYN-DD-ENTRY (DX) TO ELEM-DD-ENTRY.
036840 IF IDNT-ELEM = 'D' AND NAME-ELEM = FOUND6-WORD-30
036860 MOVE 1 TO IN-USE (DX) GO TO FIND-DICT-EXIT.
036880 IF FCHAR-ELEM NOT = 0 SET DX UP BY 1
036900 GO TO FIND-DICT1.
036920* *IF NOT FOUND IN DYN DICT (IN CORE) AND THERE WAS MORE
036940* * DICT ON DISK WHEN CREATED DYN DICT, LOOK ON DISK.
036960* * OTHERWISE EXIT WITH DX SET TO 0 AS AN INDICATOR*.
036980 IF MORE-DICT-FLAG = 0
037000 GO TO FIND-DICT-NOHIT1.
037020 OPEN INPUT QTDICT.
037040 FIND-DICT2.
037060 READ QTDICT INTO DD-REC AT END GO TO FIND-DICT-NOHIT.
037080 IF IN-IDNT = 'FD' GO TO FIND-DICT2.
037100 FIND-DICT4.
037120 IF ( IN-IDNT = 'DD' OR 'KD' ) AND
037140 IN-NAME = FOUND6-WORD-30 GO TO FIND-DICT5.
037160 READ QTDICT INTO DD-REC AT END GO TO FIND-DICT-NOHIT.
037180 GO TO FIND-DICT4.
037200 FIND-DICT5.
037220* *HERE IF DID FIND ENTRY ON EXTERNAL (DISK) DICTIONARY*.
037240 SET DX TO 1.
037260 FIND-DICT6.
037280* *FIND AN ITEM NOT YET USED IN DYN DICT AND REPLACE IT.
037300 IF IN-USE (DX) NOT = 1 GO TO FIND-DICT8.
037320 SET DX UP BY 1.
037340 IF FCHAR (DX) NOT = 0 GO TO FIND-DICT6.
037360 SET DX TO 1.
037380 FIND-DICT6A.
037400 IF DX GREATER THAN DICT-ENTRIES
037420 DISPLAY ' %Dict capacity exceeded' UPON CONSOLE
037440 GO TO FIND-DICT-NOHIT.
037460 SET FIX TO 1.
037480 SET CHX TO 1.
037500 SET LSX TO 1.
037520 FIND-DICT7.
037540* *IF STILL NO PLACE TO PUT IT, FIND FIRST ENTRY NOT BEING
037560* * USED BY A CURRENT LIST. -NOTE- SHOULD SELDOM
037580* * IF EVER GET TO THIS POINT*.
037600 IF DX-FIND-PTR (FIX) = DX SET DX UP BY 1
037620 GO TO FIND-DICT6A.
037640 IF DX-CHG-PTR (CHX) = DX SET DX UP BY 1
037660 GO TO FIND-DICT6A.
037680 IF DX-LST-PTR (LSX) = DX SET DX UP BY 1
037700 GO TO FIND-DICT6A.
037720 SET FIX UP BY 1.
037740 SET CHX UP BY 1.
037760 SET LSX UP BY 1.
037780 IF LSX NOT = MAX-LST-ITEMS GO TO FIND-DICT7.
037800 FIND-DICT8.
037820 PERFORM DYN-DICT-DD.
037840 MOVE 1 TO IN-USE-ELEM.
037860 MOVE ELEM-DD-ENTRY TO DYN-DD-ENTRY (DX).
037880 CLOSE QTDICT.
037900 GO TO FIND-DICT-EXIT.
037920 FIND-DICT-NOHIT.
037940 CLOSE QTDICT.
037960 FIND-DICT-NOHIT1.
037980 SET DX TO 0.
038000 FIND-DICT-EXIT.
038020 EXIT.
038040
038060**********************************************************
038080* SUBROUTINE TO NOTIFY OF ITEM NAME NOT FOUND IN DICT
038100**********************************************************
038120 DICT-MISSED.
038140 MOVE ' %' TO MSG-MARK.
038160 MOVE FOUND6-WORD-30 TO MSG-NAME.
038180 MOVE ' not found in dictionary' TO MSG-TEXT.
038200 PERFORM DISPLAY-MSG THRU DISPLAY-MSG-EXIT.
038220
038240***********************************************************
038260* SUBROUTINE TO BUILD A COMPLETE RECORD FROM INPUT.
038280* IT IS CALLED BY INPUT AND APPEND AND INSERT.
038300* BUILD-REC RETURNS VALUES IN REC-FLAG AS FOLLOWS:
038320* 0 = 'IGNORE RECORD; USER KILLED IT'
038340* 1 = 'RECORD IS OK; USE IT'
038360* 2 = 'END OF INPUT; WRITE RECORD AND QUIT INPUTING'
038380* 3 = 'END OF INPUT; IGNORE RECORD AND QUIT INPUTING'
038400***********************************************************
038420 BUILD-REC.
038440 IF MORE-DICT-FLAG = 1 OPEN INPUT QTDICT.
038460 MOVE 0 TO REC-FLAG CURRENT-DD-NO.
038480 DISPLAY ' ' UPON CONSOLE.
038500 DISPLAY ' (Next record)' UPON CONSOLE.
038520 BUILD-REC-FINDRD.
038540 MOVE 1 TO DD-NO.
038542 SET DX TO 1.
038544 MOVE 0 TO RD-NO.
038560 IF MULT-RT-FLAG NOT = 1 GO TO BUILD-REC-LOOP1.
038580 MOVE ' *Record name:' TO PROMPT-ELEM.
038600 DISPLAY ' ' PROMPT-ELEM UPON CONSOLE WITH NO ADVANCING.
038620 ACCEPT HOLDER FROM TTY.
038630 MOVE HOLDER TO FOUND6-WORD-30.
038632 IF HOLDER = SPACES GO TO BUILD-REC-FINDRD.
038640 IF FOUND6-WORD-6 = 'END ' OR 'EXIT '
038660 MOVE 3 TO REC-FLAG GO TO BUILD-REC-EXIT.
038680 BUILD-REC-FINDRD1.
038700 PERFORM GET-NEXT-RD THRU GET-NEXT-RD-EXIT.
038720 IF RD-NO = 0 GO TO BUILD-REC-FINDRD3.
038740 BUILD-REC-FINDRD2.
038780 IF IDNT-ELEM = 'R' AND NAME-ELEM = FOUND6-WORD-30
038800 GO TO BUILD-REC-LOOP1.
038820 IF FCHAR-ELEM NOT = 0 GO TO BUILD-REC-FINDRD1.
038822 BUILD-REC-FINDRD3.
038840 MOVE ' %' TO MSG-MARK.
038860 MOVE FOUND6-WORD-30 TO MSG-NAME.
038880 MOVE 'record not in dictionary' TO MSG-TEXT.
038900 PERFORM DISPLAY-MSG THRU DISPLAY-MSG-EXIT.
038920 IF MORE-DICT-FLAG = 1 CLOSE QTDICT.
038922 GO TO BUILD-REC.
038940* *TREAT 1ST ITEM SPECIALLY - DO NOT BLANK OUT RECORD
038960* * UNTIL HAVE 'END '*.
038980
039000 BUILD-REC-LOOP1.
039020 PERFORM GET-NEXT-DD THRU GET-NEXT-DD-EXIT.
039040 IF DD-NO = 0 GO TO BUILD-REC-DONE.
039060 BUILD-REC-LOOP1A.
039064 IF DICT-FILETYPE = '6' MOVE SPACES TO QIFLE6-REC
039066 ELSE IF DICT-FILETYPE = '7' MOVE SPACES TO QIFLE7-REC.
039068 MOVE 0 TO ITEMS-RECD-CTR.
039080 PERFORM RECEIVE-ITEM THRU RECEIVE-ITEM-EXIT.
039100 IF SPECIAL-ITM-FLAG = 1
039120 AND ( FOUND6-WORD-6 = 'END ' OR 'EXIT ' )
039140 MOVE 3 TO REC-FLAG
039160 GO TO BUILD-REC-DONE.
039170 IF SPECIAL-ITM-FLAG = 1 GO TO BUILD-REC-SPECIAL-ITM.
039200 GO TO BUILD-REC-LOOP3.
039220 BUILD-REC-LOOP2.
039240 IF REC-FLAG NOT = 1
039260 PERFORM RECEIVE-ITEM THRU RECEIVE-ITEM-EXIT
039280 ELSE MOVE SPACES TO HOLDER
039300 MOVE 1 TO ALL-SPACES-FLAG
039320 GO TO BUILD-REC-LOOP3.
039340 IF SPECIAL-ITM-FLAG NOT = 1 GO TO BUILD-REC-LOOP3.
039350 BUILD-REC-SPECIAL-ITM.
039360 IF FOUND6-WORD-5 = 'NEXT ' MOVE 1 TO REC-FLAG
039380 MOVE SPACES TO HOLDER
039400 MOVE 1 TO ALL-SPACES-FLAG
039420 GO TO BUILD-REC-LOOP3.
039440 IF FOUND6-WORD-5 = 'END ' OR 'EXIT ' MOVE 2 TO REC-FLAG
039460 GO TO BUILD-REC-DONE.
039480 IF FOUND6-WORD-5 = 'KILL ' MOVE 0 TO REC-FLAG
039500 MOVE ' %Record rejected' TO DISPLAY-LINE
039520 PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT
039540 GO TO BUILD-REC.
039560 IF FOUND6-WORD-6 = 'BLANK '
039580 MOVE SPACES TO HOLDER
039600 MOVE 1 TO ALL-SPACES-FLAG
039620 GO TO BUILD-REC-LOOP3.
039640 IF FOUND6-WORD-3 = 'UP '
039660 GO TO BUILD-REC-LOOP-NEWDX.
039680 IF FOUND6-WORD-5 = 'DOWN '
039700 GO TO BUILD-REC-LOOP-NEWDX.
039720 GO TO BUILD-REC-LOOP3.
039740 BUILD-REC-LOOP-NEWDX.
039750 MOVE HOLDER TO ANSWER.
039760 SET ANX TO 1.
039800 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
039820 PERFORM FIND-WORD THRU FIND-WORD-EXIT.
039840 IF FOUND-WORD-1 = ' ' OR NUM-VAL-FLAG = 0
039860 MOVE 1 TO NHOLDER8
039880 ELSE PERFORM NUM-ARG THRU NUM-ARG-EXIT.
039900 IF NHOLDER8 NOT GREATER THAN 0 MOVE 1 TO NHOLDER8.
039920 IF ANSWER-1 = 'U' OR 'u'
039922 SUBTRACT NHOLDER8 FROM ZERO GIVING NHOLDER8.
039924 BUILD-REC-LOOP-NEWDX-1.
039926 ADD NHOLDER8 TO DD-NO.
039928 IF NHOLDER8 LESS THAN ZERO MOVE -1 TO NHOLDER8
039930 ELSE MOVE 1 TO NHOLDER8.
039960 IF MORE-DICT-FLAG = 0 AND DD-NO GREATER THAN DICT-ENTRIES
039980 MOVE DICT-ENTRIES TO DD-NO.
039982 PERFORM GET-NEXT-DD THRU GET-NEXT-DD-EXIT.
039984 IF UPFLAG-ELEM = '*' GO TO BUILD-REC-LOOP-NEWDX-1.
040000 GO TO BUILD-REC3.
040020 BUILD-REC-LOOP3.
040040 IF UPFLAG-ELEM = '*' GO TO BUILD-REC1.
040060 IF TYPEV-ELEM = '1' NEXT SENTENCE ELSE
040080 IF ALL-SPACES-FLAG = 1 MOVE 0 TO HOLDER.
040100 PERFORM SET-VALUE THRU SET-VALUE-EXIT.
040120 BUILD-REC1.
040140 ADD 1 TO DD-NO.
040160 BUILD-REC2.
040180 PERFORM GET-NEXT-DD THRU GET-NEXT-DD-EXIT.
040190 BUILD-REC3.
040200 IF DD-NO NOT = 0 AND IDNT-ELEM NOT = 'R'
040220 AND FCHAR-ELEM NOT = 0 GO TO BUILD-REC-LOOP2.
040240 MOVE 1 TO REC-FLAG.
040260 BUILD-REC-DONE.
040264 IF ITEMS-RECD-CTR = 0
040268 DISPLAY ' %No items input; check dictionary to see'
040270 UPON CONSOLE
040272 DISPLAY ' if all items are flagged non-input.'
040274 UPON CONSOLE.
040280 IF MORE-DICT-FLAG = 1 CLOSE QTDICT.
040300 BUILD-REC-EXIT.
040320 EXIT.
040340
040360**********************************************************
040380* SUBROUTINE 'GET-NEXT-DD' TO SERVICE BUILD-REC.
040400* IT GETS THE NEXT REQUESTED DD, EITHER FROM THE IN-CORE
040420* DYNAMIC DICT OR THE EXTERNAL WORKING DICT FILE.
040440* HANDLES UP AND DOWN BY SEEKING A MATCH ON A DICT ENTRY
040460* NUMBER PLANTED IN DD-NO BY THE CALLER. THE CURRENT
040480* RECORD (OR DX) NUMBER IS KEPT IN CURRENT-DD-NO.
040500* IF RUNS OFF END OF EITHER KIND OF DICT, RETURNS
040520* A ZERO VALUE IN DD-NO.
040540**********************************************************
040560 GET-NEXT-DD.
040580 IF DD-NO LESS THAN 1 MOVE 1 TO DD-NO.
040600 IF MORE-DICT-FLAG = 1 GO TO GET-NEXT-DD1.
040620* *HERE IF ENTIRE DYNAMIC DICT IS IN CORE*
040640 IF DD-NO GREATER THAN DICT-ENTRIES
040660 MOVE 0 TO DD-NO
040680 GO TO GET-NEXT-DD-EXIT.
040700 SET DX TO DD-NO.
040720 MOVE DYN-DD-ENTRY (DX) TO ELEM-DD-ENTRY.
040740 GO TO GET-NEXT-DD-EXIT.
040760
040780 GET-NEXT-DD1.
040800* *HERE IF HAVE BIG DICT AND HAVE TO GO OUT TO DISK*.
040820 IF DD-NO LESS THAN CURRENT-DD-NO
040840 CLOSE QTDICT OPEN INPUT QTDICT
040860 MOVE 0 TO CURRENT-DD-NO.
040880
040900 GET-NEXT-DD2.
040920 IF DD-NO NOT = CURRENT-DD-NO GO TO GET-NEXT-DD3.
040940 IF IN-IDNT = 'DD' OR 'KD' PERFORM DYN-DICT-DD
040960 ELSE IF IN-IDNT = 'RD' PERFORM DYN-DICT-RD.
040980 GO TO GET-NEXT-DD-EXIT.
041000
041020 GET-NEXT-DD3.
041040 READ QTDICT AT END MOVE 0 TO DD-NO
041060 GO TO GET-NEXT-DD-EXIT.
041080 MOVE QTDICT-REC TO DD-REC.
041100 IF IN-IDNT NOT = 'DD' AND NOT = 'KD' GO TO GET-NEXT-DD3.
041120 ADD 1 TO CURRENT-DD-NO.
041140 GO TO GET-NEXT-DD2.
041160
041180 GET-NEXT-DD-EXIT.
041200 EXIT.
041202
041204 GET-NEXT-RD.
041206* *POSITION AT NEXT RD; IF NONE PUT 0 IN RD-NO*
041207 IF MORE-DICT-FLAG NOT = 1
041208 MOVE DYN-DD-ENTRY (DX) TO ELEM-DD-ENTRY
041210 SET DX UP BY 1
041211 ADD 1 TO DD-NO
041212 GO TO GET-NEXT-RD1.
041214 READ QTDICT INTO DD-REC AT END MOVE 0 TO RD-NO
041216 GO TO GET-NEXT-RD-EXIT.
041218 IF IN-IDNT NOT = "RD" GO TO GET-NEXT-RD.
041220 PERFORM DYN-DICT-RD.
041221
041222 GET-NEXT-RD1.
041224 IF FCHAR-ELEM = 0 MOVE 0 TO RD-NO
041226 GO TO GET-NEXT-RD-EXIT.
041228 IF IDNT-ELEM NOT = "R" GO TO GET-NEXT-RD.
041230 ADD 1 TO RD-NO.
041232 IF NAME-ELEM NOT = FOUND6-WORD-30 GO TO GET-NEXT-RD.
041234 MOVE 0 TO CURRENT-DD-NO.
041235
041236 GET-NEXT-RD-EXIT.
041238 EXIT.
041239
041240***********************************************************
041260* SUBROUTINE TO ISSUE PROMPT, AND
041280* PHYSICALLY GET AN ITEM VALUE FROM TERMINAL.
041300* DESTROYS I, J, L CONTENTS.
041320* MOVES DYN-DD-ENTRY TO ELEM-DD-ENTRY.
041340***********************************************************
041360 RECEIVE-ITEM.
041380 MOVE 0 TO ALL-SPACES-FLAG LITERAL-VAL-FLAG
041400 SPECIAL-ITM-FLAG ENTRY-ERROR.
041420 MOVE SPACES TO LONG-HOLDER.
041440 IF UPFLAG-ELEM = '*' GO TO RECEIVE-ITEM-EXIT.
041442 ADD 1 TO ITEMS-RECD-CTR.
041460 DISPLAY ' ' PROMPT-ELEM UPON CONSOLE WITH NO ADVANCING.
041480 ACCEPT LONG-HOLDER FROM TTY.
041500 IF CHAR-HOLDER (1) = '"' OR "'"
041520 MOVE HOLDER TO ANSWER
041540 SET ANX TO 1
041560 PERFORM FIND-WORD THRU FIND-WORD-EXIT
041580 MOVE FOUND-WORD TO LONG-HOLDER.
041600 IF LITERAL-VAL-FLAG = 1 GO TO RECEIVE-ITEM1.
041620 IF HOLDER = SPACES MOVE 1 TO ALL-SPACES-FLAG
041640 GO TO RECEIVE-ITEM-EXIT.
041644 MOVE HOLDER TO FOUND6-WORD-6.
041660 IF FOUND6-WORD-5 = 'NEXT ' OR 'END ' OR 'EXIT ' OR 'KILL '
041680 OR 'DOWN '
041700 MOVE 1 TO SPECIAL-ITM-FLAG
041720 GO TO RECEIVE-ITEM-EXIT.
041740 IF FOUND6-WORD-3 = 'UP ' MOVE 1 TO SPECIAL-ITM-FLAG
041760 GO TO RECEIVE-ITEM-EXIT.
041780 IF FOUND6-WORD-6 = 'BLANK ' MOVE 1 TO SPECIAL-ITM-FLAG
041800 GO TO RECEIVE-ITEM-EXIT.
041820 RECEIVE-ITEM1.
041840 IF TYPEV-ELEM = '1' SET HLX TO NCHAR-ELEM
041860 GO TO RECEIVE-ITEM-ALPHA.
041880 PERFORM JUST-RIGHT THROUGH JUST-RIGHT-EXIT.
041900 RECEIVE-ITEM-CHECK.
041920 IF ENTRY-ERROR NOT = 0
041940 PERFORM VALUE-ERR THRU VALUE-ERR-EXIT
041960 GO TO RECEIVE-ITEM.
041980 GO TO RECEIVE-ITEM-EXIT.
042000 RECEIVE-ITEM-ALPHA.
042020* *CHECK FOR TOO-LONG ALPHA VALUE*.
042040* IF HLX IS NOT LESS THAN MAX-LONG-ITEMLEN
042060* GO TO RECEIVE-ITEM-EXIT.
042080* SET HLX UP BY 1.
042100* IF CHAR-HOLDER (HLX) = ' ' GO TO RECEIVE-ITEM-ALPHA.
042120* MOVE 1 TO ENTRY-ERROR.
042140* GO TO RECEIVE-ITEM-CHECK.
042160 RECEIVE-ITEM-EXIT.
042180 EXIT.
042200
042220**********************************************************
042240* SUBROUTINE TO CONSTRUCT A PROMPT FOR ITEM VALUE
042260* WORKS FROM VALUES IN CURRENT DD-REC.
042280**********************************************************
042300 BUILD-PROMPT.
042310* *STUFF IN BASIC INFORMATION*.
042320 MOVE SPACES TO PROMPT-LINE.
042340 MOVE '(' TO BASIC-LINE-LPAREN.
042360 MOVE ')' TO BASIC-LINE-RPAREN.
042380 MOVE '*' TO BASIC-LINE-ASTERISK.
042400 MOVE ':' TO BASIC-LINE-COLON.
042420 MOVE IN-NAME TO BASIC-LINE-NAME.
042440 MOVE IN-TITLE1 TO BASIC-LINE-TITLE1.
042460 IF IN-TITLE1 = SPACES MOVE IN-TITLE2 TO BASIC-LINE-TITLE1
042480 ELSE MOVE IN-TITLE2 TO BASIC-LINE-TITLE2.
042500 IF IN-SCALE NOT = 0
042520 MOVE '.' TO BASIC-LINE-POINT
042540 MOVE IN-SCALE TO BASIC-LINE-DECIMALS
042560 MOVE IN-NCHAR TO L
042580 SUBTRACT IN-SCALE FROM L
042600 MOVE L TO BASIC-LINE-NCHAR
042620 ELSE MOVE IN-NCHAR TO BASIC-LINE-NCHAR.
042640 IF IN-TYPEV = '1' MOVE 'A' TO BASIC-LINE-TYPEV
042660 ELSE MOVE 'N' TO BASIC-LINE-TYPEV.
042680 MOVE 1 TO I. MOVE 1 TO J. MOVE 1 TO L.
042700 BUILD-PROMPT1.
042710* *SQUEEZE OUT ANY IMBEDDED SPACES*.
042720 IF PROMPT-CHAR (I) NOT = ' ' MOVE 0 TO L
042740 GO TO BUILD-PROMPT2.
042760 IF L = 0 MOVE 1 TO L
042780 GO TO BUILD-PROMPT2.
042800 ADD 1 TO I.
042820 IF I NOT GREATER THAN PROMPT-CAP GO TO BUILD-PROMPT1.
042840 GO TO BUILD-PROMPT3.
042860 BUILD-PROMPT2.
042880 MOVE PROMPT-CHAR (I) TO PROMPT-CHAR (J).
042900 ADD 1 TO I. ADD 1 TO J.
042920 IF I NOT GREATER THAN PROMPT-CAP GO TO BUILD-PROMPT1.
042940 BUILD-PROMPT3.
042950* *ADD TRAILING UNDERLINES*.
042960 IF J NOT GREATER THAN PROMPT-CAP
042980 MOVE '_' TO PROMPT-CHAR (J)
043000 ADD 1 TO J
043020 GO TO BUILD-PROMPT3.
043040 MOVE PROMPT-LINE TO PROMPT-ELEM.
043060 BUILD-PROMPT-EXIT.
043080 EXIT.
043100
043120********************************************************
043140* SUBROUTINE 'NUM-ARG' ADJUSTS A NUMERIC ARGUMENT.
043160* IT CHANGES SOME ITEMS IN ELEM-DD-ENTRY.
043180* TAKES INTEGER IN HOLDER AND RIGHT JUSTIFIES IN NHOLDER8.
043200********************************************************
043220 NUM-ARG.
043240 MOVE FOUND-WORD TO HOLDER.
043260 MOVE 0 TO SCALE-ELEM.
043280 MOVE '2' TO TYPEV-ELEM.
043300 MOVE 8 TO NCHAR-ELEM.
043320 PERFORM JUST-RIGHT THRU JUST-RIGHT-EXIT.
043340 IF ENTRY-ERROR NOT = 0
043360 PERFORM VALUE-ERR THRU VALUE-ERR-EXIT.
043380 NUM-ARG-EXIT.
043400 EXIT.
043420
043440***********************************************************
043460* SUBROUTINE BELOW RIGHT JUSTIFIES AN ITEM JUST RECEIVED
043480* FROM THE TERMINAL. PEELS OUT COMMAS, DECIMALS AND DOLLAR SIGNS.
043500* SCALES WITH FILLED IN 0ES FOR UNENTERED DECIMALS AND LEFT
043520* FILLS WITH LEADING 0ES IF NECESSARY. MINUS IN FRONT GIVES A
043540* NEGATIVE QUANTITY IN APPROPRIATE NHOLDER. THIS ROUTINE RELIES
043560* ON THE CURRENT DD BEING IN ELEM-DD-ENTRY.
043580* DESTROYS I, J, L CONTENTS.
043600***********************************************************
043620 JUST-RIGHT.
043640 MOVE 0 TO I J L DECIMAL-FLAG ENTRY-ERROR MINUS-FLAG.
043660 MOVE 0 TO NHOLDER18.
043680 JUST-RIGHT1.
043700* *PROCESS ANY LEADING NON NUMERIC CHARACTERS*.
043720 ADD 1 TO I.
043740 IF I GREATER THAN MAX-ITEMLEN GO TO JUST-RIGHT7.
043760 MOVE CHAR-HOLDER (I) TO ELEM-CHAR.
043780 IF ELEM-CHAR IS NUMERIC GO TO JUST-RIGHT3.
043800 IF ELEM-CHAR = '.' MOVE 1 TO DECIMAL-FLAG
043820 ADD 1 TO I
043840 GO TO JUST-RIGHT2.
043860 IF ELEM-CHAR = '$' OR ',' GO TO JUST-RIGHT1.
043880 IF ELEM-CHAR NOT = '-' AND NOT = '+'
043900 GO TO JUST-RIGHT-ERROR.
043920 IF MINUS-FLAG NOT = 0 GO TO JUST-RIGHT-ERROR.
043940 IF ELEM-CHAR = '-' MOVE 1 TO MINUS-FLAG
043960 ELSE MOVE 2 TO MINUS-FLAG.
043980 GO TO JUST-RIGHT1.
044000 JUST-RIGHT2.
044020* *PROCESS NUMERIC CHARACTERS*.
044040 MOVE CHAR-HOLDER (I) TO ELEM-CHAR.
044060 IF ELEM-CHAR NOT NUMERIC GO TO JUST-RIGHT5.
044080 JUST-RIGHT3.
044100 ADD 1 TO J.
044120 MOVE ELEM-CHAR TO CHAR-HOLDER (J).
044140 IF DECIMAL-FLAG = 1 ADD 1 TO L.
044160 JUST-RIGHT4.
044180 ADD 1 TO I.
044200 IF I GREATER THAN MAX-ITEMLEN GO TO JUST-RIGHT7.
044220 GO TO JUST-RIGHT2.
044240 JUST-RIGHT5.
044260 IF ELEM-CHAR = ' ' GO TO JUST-RIGHT7.
044280 IF ELEM-CHAR = '-' OR '+' GO TO JUST-RIGHT6.
044300 IF DECIMAL-FLAG = 1 GO TO JUST-RIGHT-ERROR.
044320 IF ELEM-CHAR = ',' GO TO JUST-RIGHT4.
044340 IF ELEM-CHAR = '.' MOVE 1 TO DECIMAL-FLAG
044360 GO TO JUST-RIGHT4.
044380 JUST-RIGHT6.
044400 IF MINUS-FLAG NOT = 0 GO TO JUST-RIGHT-ERROR.
044420 ADD 1 TO I.
044440 IF CHAR-HOLDER (I) NOT = ' ' GO TO JUST-RIGHT-ERROR.
044460 IF ELEM-CHAR = '-' MOVE 1 TO MINUS-FLAG
044480 ELSE MOVE 2 TO MINUS-FLAG.
044500 JUST-RIGHT7.
044520* *FILL IN ANY TRAILING (AFTER.) ZEROES NEEDED*.
044540 IF L = SCALE-ELEM GO TO JUST-RIGHT8.
044560 IF L GREATER THAN SCALE-ELEM GO TO JUST-RIGHT-ERROR.
044580 ADD 1 TO J.
044600 MOVE 0 TO CHAR-HOLDER (J).
044620 ADD 1 TO L.
044640 GO TO JUST-RIGHT7.
044660 JUST-RIGHT8.
044680* *SEE IF SUPPLIED NUMBER IS TOO LONG*.
044700 IF J GREATER THAN NCHAR-ELEM GO TO JUST-RIGHT-ERROR.
044720 SUBTRACT J FROM MAX-ITEMLEN-UP1 GIVING WORKDEX.
044740 ENTER MACRO IQSX77 USING J HOLDER CONST1
044760 HOLDER WORKDEX.
044780 IF MINUS-FLAG NOT = 1 GO TO JUST-RIGHT-EXIT.
044800* *IF (-) FURNISHED MAKE QUANTITY NEGATIVE*.
044820 SUBTRACT NHOLDER18 FROM 0 GIVING NHOLDER18.
044840 GO TO JUST-RIGHT-EXIT.
044860 JUST-RIGHT-ERROR.
044880 MOVE 0 TO NHOLDER18.
044900 MOVE 1 TO ENTRY-ERROR.
044920 JUST-RIGHT-EXIT.
044940 EXIT.
044960
044980**********************************************************
045000* SUBROUTINE TO CHECK LENGTH OF ALPHA FIELD VALUES.
045020* ASSUMES CORRECT DD IS IN ELEM-DD-ENTRY. SETS ENTRY-ERROR
045040**********************************************************
045060 ALPHA-LENGTH.
045080 MOVE 0 TO ENTRY-ERROR.
045100 SET HLX TO NCHAR-ELEM.
045120 ALPHA-LENGTH1.
045140 IF HLX NOT LESS THAN MAX-ITEMLEN GO TO ALPHA-LENGTH-EXIT.
045160 SET HLX UP BY 1.
045180 IF CHAR-HOLDER (HLX) = ' ' GO TO ALPHA-LENGTH1.
045200 MOVE 1 TO ENTRY-ERROR.
045220 ALPHA-LENGTH-EXIT.
045240 EXIT.
045260
045280***********************************************************
045300* SUBROUTINE TO COMPLAIN ABOUT BAD VALUES BEING ENTERED.
045320************************************************************
045340 VALUE-ERR.
045360 MOVE ' %' TO MSG-MARK.
045380 MOVE NAME-ELEM TO MSG-NAME.
045400 MOVE ' value too large or alpha in numeric field'
045402 TO MSG-TEXT.
045420 PERFORM DISPLAY-MSG THRU DISPLAY-MSG-EXIT.
045440 VALUE-ERR-EXIT.
045460 EXIT.
045480
045500**********************************************************
045520* SUBROUTINE TO EXTRACT AN ITEM VALUE FROM THE CURRENT
045540* RECORD; IT DOES THIS UNDER CONTROL OF
045560* THE DD DESCRIBED IN ELEM-DD-ENTRY
045564* AND THE FILE TYPE AS CONTAINED IN DICT-FILETYPE.
045580**********************************************************
045582 GET-VALUE.
045584 IF DICT-FILETYPE = '6' GO TO GET-VALUE-SIX.
045586 GET-VALUE-ASCII.
045588 IF TYPEV-ELEM = '1' MOVE SPACES TO HOLDER
045590 ENTER MACRO IQSX77 USING NCHAR-ELEM
045592 QIFLE7-REC FCHAR-ELEM HOLDER CONST1
045594 GO TO GET-VALUE-EXIT.
045596 IF TYPEV-ELEM NOT = '6' MOVE 0 TO NHOLDER
045598 SUBTRACT NCHAR-ELEM FROM MAX-ITEMLEN-UP1 GIVING NC
045600 ENTER MACRO IQSX77 USING NCHAR-ELEM
045602 QIFLE7-REC FCHAR-ELEM HOLDER NC
045604 GO TO GET-VALUE-EXIT.
045606 COMPUTE REAL-FCHAR = ((FCHAR-ELEM - 1) * 6 / 5) + 1.
045608 GO TO GET-VALUE-SIX-BIN.
045610 GET-VALUE-SIX.
045620 IF TYPEV-ELEM = '1' MOVE SPACES TO HOLDER
045640 ENTER MACRO IQSX67 USING NCHAR-ELEM
045660 QIFLE6-REC FCHAR-ELEM HOLDER CONST1
045680 GO TO GET-VALUE-EXIT.
045700 IF TYPEV-ELEM NOT = '6'
045720 MOVE 0 TO NHOLDER
045740 SUBTRACT NCHAR-ELEM FROM MAX-ITEMLEN-UP1 GIVING NC
045760 ENTER MACRO IQSX67 USING NCHAR-ELEM
045780 QIFLE6-REC FCHAR-ELEM HOLDER NC
045800 GO TO GET-VALUE-EXIT.
045804 MOVE FCHAR-ELEM TO REAL-FCHAR.
045808 GET-VALUE-SIX-BIN.
045812* *EXTRACT BINARY VALUE (USED BY BOTH SIX & ASCII).
045820 IF NCHAR-ELEM LESS THAN 11
045840 ENTER MACRO IQSX66 USING CONST6
045860 QIFLE6-REC FCHAR-ELEM BHOLDER CONST1
045880 MOVE BCOMP6 TO NHOLDER18
045900 GO TO GET-VALUE-EXIT.
045920 ENTER MACRO IQSX66 USING CONST12
045940 QIFLE6-REC FCHAR-ELEM BHOLDER CONST1.
045960 MOVE BCOMP12 TO NHOLDER18.
045980 GET-VALUE-EXIT.
046000 EXIT.
046020
046040**********************************************************
046060* SUBROUTINE TO SET ITEM VALUES IN IMAGE. DEPENDS ON
046080* PROPER ENTRY BEING IN ELEM-DD-ENTRY.
046100**********************************************************
046102 SET-VALUE.
046104 IF DICT-FILETYPE = '6' GO TO SET-VALUE-SIX.
046104 SET-VALUE-ASCII.
046106 IF TYPEV-ELEM = '1'
046108 ENTER MACRO IQSX77 USING NCHAR-ELEM
046110 HOLDER CONST1 QIFLE7-REC FCHAR-ELEM
046112 GO TO SET-VALUE-EXIT.
046114 IF TYPEV-ELEM NOT = '6'
046116 SUBTRACT NCHAR-ELEM FROM MAX-ITEMLEN-UP1 GIVING NC
046118 ENTER MACRO IQSX77 USING NCHAR-ELEM
046120 HOLDER NC QIFLE7-REC FCHAR-ELEM
046122 GO TO SET-VALUE-EXIT.
046124 COMPUTE REAL-FCHAR = ((FCHAR-ELEM - 1) * 6 / 5) + 1.
046126 GO TO SET-VALUE-SIX-BIN.
046128
046130 SET-VALUE-SIX.
046140 IF TYPEV-ELEM = '1'
046160 ENTER MACRO IQSX76 USING NCHAR-ELEM
046180 HOLDER CONST1 QIFLE6-REC FCHAR-ELEM
046200 GO TO SET-VALUE-EXIT.
046220 IF TYPEV-ELEM NOT = '6'
046240 SUBTRACT NCHAR-ELEM FROM MAX-ITEMLEN-UP1
046260 GIVING NC
046280 ENTER MACRO IQSX76 USING NCHAR-ELEM
046300 HOLDER NC QIFLE6-REC FCHAR-ELEM
046320 GO TO SET-VALUE-EXIT.
046330 MOVE FCHAR-ELEM TO REAL-FCHAR.
046334 SET-VALUE-SIX-BIN.
046340 IF NCHAR-ELEM LESS THAN 11
046360 MOVE NHOLDER10 TO BCOMP6
046380 ENTER MACRO IQSX66 USING CONST6
046400 BHOLDER CONST1 QIFLE6-REC FCHAR-ELEM
046420 GO TO SET-VALUE-EXIT.
046440 MOVE NHOLDER18 TO BCOMP12.
046460 ENTER MACRO IQSX66 USING CONST12
046480 BHOLDER CONST1 QIFLE6-REC FCHAR-ELEM.
046500 SET-VALUE-EXIT.
046520 EXIT.
046540
046560**********************************************************
046580* SUBROUTINE TO FIND THE NEXT WORD IN USER'S INPUT.
046600* ON ENTRY ANX MUST POINT TO LAST CHAR READ + 1. DESTROYS FWX.
046620***********************************************************
046640 FIND-WORD.
046660* *SAVE POSITIONS FOR LATER POSSIBLE BACKING UP*.
046680 MOVE START-ANX TO PREV-START-ANX.
046700 SET START-ANX TO ANX.
046720 MOVE 1 TO NUM-VAL-FLAG.
046740 MOVE 0 TO LITERAL-VAL-FLAG SUSPECT-COMMA-FLAG.
046760 MOVE SPACES TO FOUND-WORD.
046764 MOVE '0' TO PRIOR-ELEM-CHAR.
046780 SET FWX TO 1.
046800 FIND-WORD1.
046820* *READ OVER LEADING COMMAS OR SPACES; TRAP LEADING QUOTE*.
046840 PERFORM READ-BLANKS THROUGH READ-BLANKS-EXIT.
046860 IF ANX IS GREATER THAN MAX-ANX GO TO FIND-WORD-DONE.
046880 MOVE ANS-CHAR (ANX) TO ELEM-CHAR.
046960 IF ELEM-CHAR = '"' OR "'"
046980 MOVE ELEM-CHAR TO CURRENT-QUOTE
047000 MOVE 0 TO NUM-VAL-FLAG
047020 MOVE 1 TO LITERAL-VAL-FLAG
047040 GO TO FIND-QUOTE.
047060 FIND-WORD-LOOP.
047080* *MOVE NON-QUOTED WORD UNTIL GET SPACE - OR COMMA FOLLOWED
047090* OR PRECEDED BY A NON-NUMERIC*.
047092 IF ELEM-CHAR NOT = ',' GO TO FIND-WORD-NOT-COMMA.
047093 FIND-WORD-COMMA.
047094* *HERE IF ','; IF WORD NOT NUMERIC TREAT ',' AS END DELIM*.
047095 IF NUM-VAL-FLAG NOT = 1 GO TO FIND-WORD-DONE.
047096 IF PRIOR-ELEM-CHAR NOT NUMERIC GO TO FIND-WORD-DONE.
047098 SET LAST-LEGAL-ANX TO ANX.
047100 SET LAST-LEGAL-FWX TO FWX.
047102 MOVE 1 TO SUSPECT-COMMA-FLAG.
047103 SET ANX UP BY 1.
047104 IF ANX GREATER THAN MAX-ANX GO TO FIND-WORD-DONE.
047105 IF ANS-CHAR (ANX) NOT NUMERIC
047106 GO TO FIND-WORD-DONE.
047107 GO TO FIND-WORD-LOOP1.
047108 FIND-WORD-NOT-COMMA.
047109* *HERE IF CHARACTER WAS NOT A ','*.
047120 IF ELEM-CHAR = '$' OR '+' OR '-' OR
047140 '.' NEXT SENTENCE ELSE
047160 IF ELEM-CHAR IS NOT NUMERIC
047180 MOVE 0 TO NUM-VAL-FLAG.
047200 IF FWX IS GREATER THAN MAX-FWX GO TO FIND-WORD-DONE.
047220 MOVE ELEM-CHAR TO FOUND-CHAR (FWX).
047224 SET FWX UP BY 1.
047228 IF FWX GREATER THAN MAX-FWX GO TO FIND-WORD-DONE.
047240 SET ANX UP BY 1.
047260 IF ANX IS GREATER THAN MAX-ANX GO TO FIND-WORD-DONE.
047264 FIND-WORD-LOOP1.
047270 MOVE ELEM-CHAR TO PRIOR-ELEM-CHAR.
047280 MOVE ANS-CHAR (ANX) TO ELEM-CHAR.
047320 IF ELEM-CHAR NOT = SPACE GO TO FIND-WORD-LOOP.
047340 GO TO FIND-WORD-OUT.
047360 FIND-QUOTE.
047380* *PROCESS STRING IN QUOTES; STORE UNTIL GET UNQUOTE*.
047420 IF FWX IS GREATER THAN MAX-FWX GO TO FIND-WORD-DONE.
047440 SET ANX UP BY 1.
047460 IF ANX IS GREATER THAN MAX-ANX GO TO FIND-WORD-DONE.
047480 MOVE ANS-CHAR (ANX) TO ELEM-CHAR.
047500 IF ELEM-CHAR = CURRENT-QUOTE SET ANX UP BY 1
047520 GO TO FIND-WORD-OUT.
047540 MOVE ELEM-CHAR TO FOUND-CHAR (FWX).
047550 SET FWX UP BY 1.
047560 GO TO FIND-QUOTE.
047580 FIND-WORD-OUT.
047600* *CONTINUE LINE IF GET ++ ALONE*
047620 IF LITERAL-VAL-FLAG NOT = 1 AND FOUND-WORD-3 = '++ '
047640 PERFORM ASKER THRU ASKER-EXIT
047660 GO TO FIND-WORD.
047680 IF LITERAL-VAL-FLAG NOT = 1
047700 AND FOUND-CHAR (FWX) = ','
047720 MOVE ' ' TO FOUND-CHAR (FWX).
047724 FIND-WORD-DONE.
047728 MOVE FOUND-WORD TO FOUND6-WORD.
047740 FIND-WORD-EXIT.
047760 EXIT.
047780
047800***********************************************************
047820* SUBROUTINE TO READ OVER BLANKS OR COMMAS IN USER INPUT
047824* UNTIL HIT A CHARACTER THAT IS NEITHER*.
047840***********************************************************
047860 READ-BLANKS.
047880 IF ANX IS GREATER THAN MAX-ANX GO TO READ-BLANKS-EXIT.
047900 IF ANS-CHAR (ANX) NOT = SPACE AND
047904 ANS-CHAR (ANX) NOT = ',' GO TO READ-BLANKS-EXIT.
047920 SET ANX UP BY 1.
047940 GO TO READ-BLANKS.
047960 READ-BLANKS-EXIT.
047980 EXIT.
047982
047984*************************************************************
047986* THIS SUBROUTINE OBSCURES PASSWORD INPUT
047988*************************************************************
047990 CONFIDENTIAL-ASK.
047991 DISPLAY '*Password: ' UPON CONSOLE.
047992 MOVE ASCII-CR TO MASK7.
047994 MOVE '######' TO MASK1-6.
047996 DISPLAY MASK1-7 UPON CONSOLE WITH NO ADVANCING.
047998 MOVE 'HHHHHH' TO MASK1-6.
048000 DISPLAY MASK1-7 UPON CONSOLE WITH NO ADVANCING.
048002 MOVE 'IIIIII' TO MASK1-6.
048004 DISPLAY MASK1-7 UPON CONSOLE WITH NO ADVANCING.
048006 MOVE ASCII-CR TO MASK1.
048008 DISPLAY MASK1 UPON CONSOLE WITH NO ADVANCING.
048009 ACCEPT ANSWER FROM TTY.
048010* MOVE '******' TO MASK1-6.
048011* DISPLAY MASK1-6 UPON CONSOLE WITH NO ADVANCING.
048012* DISPLAY ' ' UPON CONSOLE.
048010 MOVE ANSWER-6 TO CURRENT-PASSWORD.
048011 IF CURRENT-PASSWORD = UNIVERSAL-PASSWORD
048012 MOVE 99 TO CURRENT-LEVEL
048013 GO TO CONFIDENTIAL-ASK-EXIT.
048014 SET DPX TO 1.
048015 CONFIDENTIAL-ASK1.
048016 IF CURRENT-PASSWORD = PASSWORD (DPX)
048018 MOVE LEVEL (DPX) TO CURRENT-LEVEL
048020 GO TO CONFIDENTIAL-ASK-EXIT.
048022 IF DPX < 10 SET DPX UP BY 1 GO TO CONFIDENTIAL-ASK1.
048024 MOVE 0 TO CURRENT-LEVEL.
048026
048028 CONFIDENTIAL-ASK-EXIT.
048030 EXIT.
048032
048034************************************************************
048035* SUBROUTINE TO UNSCRAMBLE PASSWORDS FROM DICTIONARY
048036************************************************************
048037 UNSCRAMBLE-PW.
048038 MOVE DP-TEXT TO PW-TEXT.
048039 SUBTRACT PW-MASK1 FROM PW-WORK1.
048040 SUBTRACT PW-MASK2 FROM PW-WORK2.
048041 MOVE SPACES TO DP-TEXT.
048042 MOVE PW-CHAR (10) TO DP-CHAR (1).
048043 MOVE PW-CHAR (9) TO DP-CHAR (2).
048044 MOVE PW-CHAR (6) TO DP-CHAR (3).
048045 MOVE PW-CHAR (12) TO DP-CHAR (4).
048046 MOVE PW-CHAR (3) TO DP-CHAR (5).
048047 MOVE PW-CHAR (2) TO DP-CHAR (6).
048048 UNSCRAMBLE-PW-EXIT.
048049 EXIT.
048054
048055***********************************************************
048057* SUBROUTINE 'ASKER' TO REQUEST AND GET COMMAND.
048060**********************************************************
048080 ASKER.
048100 ENTER MACRO CLRTTY.
048120* DISPLAY '<QU> ' UPON CONSOLE WITH NO ADVANCING.
048140* PERFORM ACCEPTER THRU ACCEPTER-EXIT.
048160 MOVE SPACES TO ANSWER-ASCII.
048180 ENTER MACRO PARSEU USING ANSWER-ASCII.
048200 MOVE ANSWER-ASCII TO ANSWER.
048220 SET ANX TO 1.
048240 ASKER-EXIT.
048260 EXIT.
048280
048300***********************************************************
048320* SUBROUTINE TO PHYSICALLY ACCEPT USER'S INPUT.
048340***********************************************************
048360 ACCEPTER.
048380 ACCEPT ANSWER FROM TTY.
048400 SET ANX TO 1.
048420 ACCEPTER-EXIT.
048440 EXIT.
048460
048480***********************************************************
048500* SUBROUTINE 'DISPLAY-ADV' DISPLAYS LINE WITH ADVANCING.
048520***********************************************************
048540 DISPLAY-ADV.
048550 PERFORM CHOP-RIGHT THRU CHOP-RIGHT-EXIT.
048560 DISPLAY DISPLAY-LINE72 UPON CONSOLE.
048580 DISPLAY-ADV-EXIT.
048600 EXIT.
048620
048640***********************************************************
048660* SUBROUTINE 'DISPLAY-NOADV' DISPLAYS LINE, NO ADVANCINNG.
048680***********************************************************
048700 DISPLAY-NOADV.
048720 DISPLAY DISPLAY-LINE-35 UPON CONSOLE
048740 WITH NO ADVANCING.
048760 DISPLAY-NOADV-EXIT.
048780 EXIT.
048800
048820******************************************************
048840* SUBROUTINE 'DISPLAY-REC' TO DISPLAY CURRENT RECORD.
048860*******************************************************
048880 DISPLAY-REC.
048900 MOVE START-COL TO WORKDEX.
048920 MOVE NO-COLS TO WORKX.
048940 DISPLAY-REC1.
048960 IF WORKX GREATER THAN 72 MOVE 72 TO NC
048980 SUBTRACT 72 FROM WORKX
049000 ELSE MOVE WORKX TO NC MOVE 0 TO WORKX.
049020 MOVE SPACES TO DISPLAY-LINE.
049030 IF DICT-FILETYPE = '6'
049040 ENTER MACRO IQSX67 USING NC QIFLE6-REC WORKDEX
049060 DISPLAY-LINE CONST1
049064 ELSE IF DICT-FILETYPE = '7'
049066 ENTER MACRO IQSX77 USING NC QIFLE7-REC WORKDEX
049068 DISPLAY-LINE CONST1.
049070 PERFORM CHOP-RIGHT THRU CHOP-RIGHT-EXIT.
049080 DISPLAY DISPLAY-LINE72 UPON CONSOLE.
049100 IF WORKX = 0 GO TO DISPLAY-REC-EXIT.
049120 ADD 72 TO WORKDEX.
049140 GO TO DISPLAY-REC1.
049160 DISPLAY-REC-EXIT.
049180 EXIT.
049182
049184************************************************************
049186* SUBROUTINE CHOP-RIGHT TO PUT NULLS AT RIGHT OF DISPLAY LINE
049188************************************************************
049190 CHOP-RIGHT.
049192 SET DIX TO 72.
049194 CHOP-RIGHT1.
049196 IF DISPLAY-CHAR (DIX) = SPACE
049198 MOVE ASCII-NULL TO DISPLAY-CHAR (DIX)
049200 IF DIX NOT < 2 SET DIX DOWN BY 1 GO TO CHOP-RIGHT1.
049202 CHOP-RIGHT-EXIT.
049204 EXIT.
049206
049220**********************************************************
049240* SUBROUTINE 'GO-TO-END' TO POSITION FILE AT END
049260**********************************************************
049280 GO-TO-END.
049300 IF READ-FLAG = 2 GO TO GO-TO-END1.
049320 IF READ-FLAG NOT = 3
049340 PERFORM WRITE-OUT THRU WRITE-OUT-EXIT.
049360 PERFORM READ-IN THRU READ-IN-EXIT.
049380 GO TO GO-TO-END.
049400 GO-TO-END1.
049420 PERFORM NOTIFY-EOF THRU NOTIFY-EOF-EXIT.
049440 GO-TO-END-EXIT.
049460 EXIT.
049480
049500**********************************************************
049520* SUBROUTINES 'NOTIFY-EOF' AND 'NOTIFY-BEGFILE' TO DISPLAY
049540* END OF FILE OR BEGINNING OF FILE MSGS.
049560**********************************************************
049580 NOTIFY-EOF.
049600 IF KEYLOC NOT = 0
049620 MOVE 0 TO READ-FLAG.
049640 MOVE EOF-MSG TO DISPLAY-LINE.
049660 PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT.
049680 NOTIFY-EOF-EXIT.
049700 EXIT.
049720
049740 NOTIFY-BEGFILE.
049760 MOVE BEG-OF-FILE-MSG TO DISPLAY-LINE.
049780 PERFORM DISPLAY-ADV THRU DISPLAY-ADV-EXIT.
049800 NOTIFY-BEGFILE-EXIT.
049820 EXIT.
049840
049860**********************************************************
049880* SUBROUTINE 'SAVE-FILE' TO PUT CURRENT VERSION IN
049900* ORIGINAL FILE
049920**********************************************************
049940 SAVE-FILE.
049960 IF KEYLOC NOT = 0
049980 PERFORM ISAM-TOPPER THRU ISAM-TOPPER-EXIT
050000 GO TO SAVE-FILE-EXIT.
050020 IF DICT-FILENAME = CURRENT-ID-OUT GO TO SAVE-FILE1.
050040* *HERE IF TARGET FINAL FILE IS CURRENT INPUT*.
050060 IF CHANGES-FLAG = 0 GO TO SAVE-FILE2.
050080 PERFORM SWITCH-INPUT THRU SWITCH-INPUT-EXIT.
050100 SAVE-FILE1.
050120* * HERE IF TARGET FINAL FILE IS CURRENT OUTPUT*.
050140 IF READ-FLAG = 2 GO TO SAVE-FILE2.
050160 IF READ-FLAG = 1
050180 PERFORM WRITE-OUT THRU WRITE-OUT-EXIT.
050200 PERFORM READ-IN THRU READ-IN-EXIT.
050220 GO TO SAVE-FILE1.
050240 SAVE-FILE2.
050260 PERFORM CLOSE-IN THRU CLOSE-IN-EXIT.
050280 PERFORM CLOSE-OUT THRU CLOSE-OUT-EXIT.
050300* *SINCE NOW IT IS LATEST, FORCE INPUT FROM NEW FINAL*.
050320 MOVE DICT-FILENAME TO CURRENT-ID-IN.
050340 MOVE WORK-FILENAME TO CURRENT-ID-OUT.
050360 MOVE 0 TO CHANGES-FLAG.
050380 SAVE-FILE-EXIT.
050400 EXIT.
050420
050440***********************************************************
050460* SUBROUTINE TO GET TO THE BEGINNING OF FILES FROM ANY
050480* POINT SUCH THAT THE NEW INPUT FILE IS COMPLETE AND CONTAINS
050500* ALL CHANGES TO THIS POINT. IF NECESSARY, IT COPIES
050520* OUT THE REST OF THE CURRENT INPUT FILE THEN SWITCHES
050540* FILES. EXIT IS MADE WITH THE NEW INPUT FILE OPEN BUT
050560* BEFORE THE FIRST RECORD AND NEW OUTPUT FILE OPEN
050580* BUT WITH NO RECORDS YET WRITTEN TO IT. THIS SUBROUTINE
050600* IS CALLED ANY TIME IQU GOES TOWARD THE BEGINNING OF
050620* THE INPUT FILE (WITH UP, TOP, OR USE OF FIRST).
050640***********************************************************
050660 SWITCH-INPUT.
050680 IF KEYLOC NOT = 0
050700 PERFORM ISAM-TOPPER THRU ISAM-TOPPER-EXIT
050720 GO TO SWITCH-INPUT-EXIT.
050740 IF CHANGES-FLAG = 0 GO TO SWITCH-INPUT2.
050760 SWITCH-INPUT1.
050780 IF READ-FLAG = 2
050800 GO TO SWITCH-INPUT2.
050820 IF READ-FLAG = 1
050840 PERFORM WRITE-OUT THRU WRITE-OUT-EXIT.
050860 PERFORM READ-IN THRU READ-IN-EXIT.
050880 GO TO SWITCH-INPUT1.
050900 SWITCH-INPUT2.
050920 PERFORM CLOSE-IN THRU CLOSE-IN-EXIT.
050940 PERFORM CLOSE-OUT THRU CLOSE-OUT-EXIT.
050960 IF CHANGES-FLAG = 0
050980 GO TO SWITCH-INPUT3.
051000 MOVE CURRENT-ID-IN TO CHAR-WORK9.
051020 MOVE CURRENT-ID-OUT TO CURRENT-ID-IN.
051040 MOVE CHAR-WORK9 TO CURRENT-ID-OUT.
051060 SWITCH-INPUT3.
051080 PERFORM OPEN-IN THRU OPEN-IN-EXIT.
051100 PERFORM OPEN-OUT THRU OPEN-OUT-EXIT.
051120 IF DICT-FILETYPE = '6' MOVE SPACES TO QIFLE6-REC
051124 ELSE IF DICT-FILETYPE = '7' MOVE SPACES TO QIFLE7-REC.
051140 SWITCH-INPUT-EXIT.
051160 EXIT.
051180
051200***********************************************************
051220* SUBROUTINE TO OPEN INPUT FILE.
051240***********************************************************
051260 OPEN-IN.
051280 IF INPUT-OPEN-FLAG = 1
051300* DISPLAY ' ?Double open' UPON CONSOLE
051320 GO TO OPEN-IN-EXIT.
051340 MOVE 1 TO INPUT-OPEN-FLAG.
051360 MOVE 3 TO READ-FLAG.
051380 MOVE 0 TO READ-COUNT.
051400 MOVE 0 TO CHANGES-FLAG.
051420 MOVE CURRENT-ID-IN TO QIFLE6-ID QIFLE7-ID.
051440 IF KEYLOC NOT = 0 GO TO OPEN-ISAM.
051460* * OPEN SEQUENTIAL FILE
051480 IF DICT-FILETYPE = '6' OPEN INPUT QIFLE6 ELSE
051500 OPEN INPUT QIFLE7.
051520 GO TO OPEN-IN1.
051540 OPEN-ISAM.
051560 IF DICT-FILETYPE = '7' GO TO OPEN-ISAM7.
051580* *OPEN SIXBIT ISAM
051600 OPEN-ISAM6.
051620 MOVE 1 TO CORE-DATA-MODE FILE-RECORD-MODE.
051640 IF MODE-FLAG NOT = 1 GO TO OPEN-ISAM6-I-O.
051660 ENTER MACRO IQISAM USING QIFLE6-ID BLKFACT RECLEN KEYTYPE
051680 KEYLEN FILE-RECORD-MODE
051690 KEYLOC KEYSIGN FILE-RECORD-MODE.
051700 OPEN INPUT QISAM6.
051720 GO TO OPEN-IN1.
051740 OPEN-ISAM6-I-O.
051760 ENTER MACRO IQISAM USING QIFLE6-ID BLKFACT RECLEN KEYTYPE
051780 KEYLEN FILE-RECORD-MODE
051790 KEYLOC KEYSIGN FILE-RECORD-MODE.
051800 OPEN INPUT-OUTPUT QISAM6.
051820 GO TO OPEN-IN1.
051840 OPEN-ISAM7.
051860 MOVE 0 TO CORE-DATA-MODE FILE-RECORD-MODE.
051880 IF MODE-FLAG NOT = 1 GO TO OPEN-ISAM7-I-O.
051900 ENTER MACRO IQISAM USING QIFLE7-ID BLKFACT RECLEN KEYTYPE
051920 KEYLEN FILE-RECORD-MODE
051930 KEYLOC KEYSIGN FILE-RECORD-MODE.
051940 OPEN INPUT QISAM7.
051960 GO TO OPEN-IN1.
051980 OPEN-ISAM7-I-O.
052000 ENTER MACRO IQISAM USING QIFLE7-ID BLKFACT RECLEN KEYTYPE
052020 KEYLEN FILE-RECORD-MODE
052030 KEYLOC KEYSIGN FILE-RECORD-MODE.
052040 OPEN INPUT-OUTPUT QISAM7.
052060 OPEN-IN1.
052080* *WRITE DIARY FILE*.
052100 OPEN OUTPUT QLUPDT.
052120 MOVE ' is your latest good output file.'
052140 TO ANSWER.
052160 MOVE CURRENT-ID-IN TO ANSWER-10.
052180 WRITE QLUPDT-REC FROM ANSWER.
052200 CLOSE QLUPDT.
052220 OPEN-IN-EXIT.
052240 EXIT.
052260
052280***********************************************************
052300* SUBROUTINE TO OPEN OUTPUT FILE.
052320* NOTE: CALL TO IQISAM MUST BE -JUST- BEFORE OPEN STMNT.
052340***********************************************************
052360 OPEN-OUT.
052380 IF OUTPUT-OPEN-FLAG = 1
052400* DISPLAY ' ?Double open' UPON CONSOLE
052420 GO TO OPEN-OUT-EXIT.
052440 MOVE 1 TO OUTPUT-OPEN-FLAG.
052460 MOVE 0 TO WRITE-COUNT.
052480 MOVE 0 TO CHANGES-FLAG.
052500 IF KEYLOC NOT = 0 GO TO OPEN-OUT-EXIT.
052520 MOVE CURRENT-ID-OUT TO QOFLE6-ID QOFLE7-ID.
052540 IF DICT-FILETYPE = '6' GO TO OPEN-OUT6.
052560 ENTER MACRO IQISAM USING CURRENT-ID-OUT BLKFACT RECLEN.
052580 OPEN OUTPUT QOFLE7.
052600 GO TO OPEN-OUT-EXIT.
052620 OPEN-OUT6.
052640 ENTER MACRO IQISAM USING CURRENT-ID-OUT BLKFACT RECLEN.
052660 OPEN OUTPUT QOFLE6.
052680 OPEN-OUT-EXIT.
052700 EXIT.
052720
052740***********************************************************
052760* SUBROUTINE TO READ INPUT FILE.
052780* READ-FLAG SHOWS POSITION OF FILE:
052800* 0 = BAD RECORD (SHOULD NEVER HAPPEN)
052820* 1 = GOOD READ
052840* 2 = AT END OF FILE
052860* 3 = AT BEGINNING OF FILE (BEFORE 1ST RECORD)
052880* ALSO RESETS WRITE-FLAG TO 1 (WRITE IT) FOR EACH
052900* NEW READ
052920***********************************************************
052940 READ-IN.
052960 IF READ-FLAG = 2 GO TO READ-IN-EXIT.
052980 MOVE 0 TO READ-FLAG.
053000 IF INPUT-OPEN-FLAG NOT = 1
053020 DISPLAY ' ?Reading unopened input' UPON CONSOLE
053040 GO TO READ-IN-EXIT.
053060 MOVE 1 TO READ-FLAG WRITE-FLAG.
053080 ADD 1 TO READ-COUNT.
053100 IF DICT-FILETYPE = '6' GO TO READ-IN6
053120 ELSE GO TO READ-IN7.
053160
053180 READ-IN6.
053200 IF KEYLOC NOT = 0
053240 GO TO READ-IN6-ISAM.
053250 READ QIFLE6 AT END MOVE 2 TO READ-FLAG.
053260 GO TO READ-IN-EXIT.
053300
053302 READ-IN6-ISAM.
053304 MOVE LOW-VALUES TO QISAM6-SYMKEY.
053306 READ QISAM6
053308 INVALID KEY MOVE 2 TO READ-FLAG.
053310 GO TO READ-IN-EXIT.
053312
053320 READ-IN7.
053340 IF KEYLOC NOT = 0
053380 GO TO READ-IN7-ISAM.
053390 READ QIFLE7 AT END MOVE 2 TO READ-FLAG.
053400 GO TO READ-IN-EXIT.
053440
053560 READ-IN7-ISAM.
053570 MOVE LOW-VALUES TO QISAM7-SYMKEY.
053580 READ QISAM7
053600 INVALID KEY MOVE 2 TO READ-FLAG.
053660
053670 READ-IN-EXIT.
053674 EXIT.
053680
053700
053720***********************************************************
053740* SUBROUTINE TO WRITE OUTPUT FILE.
053760* WRITE-FLAG IS DIRECTIVE TO THIS SUBROUTINE TO
053780* WRITE RECORD:
053800* 0 = DO NOT WRITE (BAD OR WRITTEN ALREADY)
053820* 1 = WRITE RECORD
053840* NOTE: CALL TO IQWRTS MUST BE -JUST- BEFORE WRITE STMNT.
053860***********************************************************
053880 WRITE-OUT.
053900 IF OUTPUT-OPEN-FLAG NOT = 1
053920* DISPLAY ' ?Writing unopened output' UPON CONSOLE
053940 GO TO WRITE-OUT-EXIT.
053960 IF WRITE-FLAG = 0 GO TO WRITE-OUT-EXIT.
053980 ADD 1 TO WRITE-COUNT.
054000* *SET WRITE FLAG SO WILL NOT WRITE THIS RECORD AGAIN*.
054020 MOVE 0 TO WRITE-FLAG.
054040 IF KEYLOC NOT = 0 GO TO WRITE-OUT-EXIT.
054060 IF DICT-FILETYPE = '6' GO TO WRITE-OUT6.
054080 WRITE-OUT7.
054100 ENTER MACRO IQSX77 USING RECLEN
054104 QIFLE7-REC CONST1 QOFLE7-REC CONST1.
054120 ENTER MACRO IQWRTS USING RECLEN.
054140 WRITE QOFLE7-REC.
054160 GO TO WRITE-OUT-EXIT.
054180 WRITE-OUT6.
054200 ENTER MACRO IQSX66 USING RECLEN
054204 QIFLE6-REC CONST1 QOFLE6-REC CONST1.
054220 ENTER MACRO IQWRTS USING RECLEN.
054240 WRITE QOFLE6-REC.
054260 WRITE-OUT-EXIT.
054280 EXIT.
054300
054320***********************************************************
054340* SUBROUTINE TO CLOSE INPUT FILE.
054360***********************************************************
054380 CLOSE-IN.
054400 MOVE 0 TO READ-FLAG.
054420 IF INPUT-OPEN-FLAG NOT = 1
054440* DISPLAY ' ?Closing unopened input' UPON CONSOLE
054460 GO TO CLOSE-IN-EXIT.
054480 MOVE 0 TO INPUT-OPEN-FLAG.
054500 IF KEYLOC = 0 GO TO CLOSE-IN1.
054520 IF DICT-FILETYPE = '6' CLOSE QISAM6
054540 ELSE CLOSE QISAM7.
054560 GO TO CLOSE-IN-EXIT.
054570
054580 CLOSE-IN1.
054620 IF DICT-FILETYPE = '6' CLOSE QIFLE6
054640 ELSE CLOSE QIFLE7.
054660 CLOSE-IN-EXIT.
054680 EXIT.
054700
054720***********************************************************
054740* SUBROUTINE TO CLOSE OUTPUT FILE.
054760***********************************************************
054780 CLOSE-OUT.
054800 IF KEYLOC NOT = 0 GO TO CLOSE-OUT-EXIT.
054820 IF OUTPUT-OPEN-FLAG NOT = 1
054840* DISPLAY ' ?Closing unopened output' UPON CONSOLE
054860 GO TO CLOSE-OUT-EXIT.
054880 MOVE 0 TO OUTPUT-OPEN-FLAG.
054900 IF DICT-FILETYPE = '6' CLOSE QOFLE6
054920 ELSE CLOSE QOFLE7.
054940 CLOSE-OUT-EXIT.
054960 EXIT.
054980
055000*******************************************************
055020* SUBROUTINES TO BUILD ELEMENTARY DICT ENTRIES
055040*******************************************************
055060 DYN-DICT-DD.
055080 MOVE 'D' TO IDNT-ELEM.
055100 MOVE IN-NAME TO NAME-ELEM.
055120 MOVE IN-TYPEV TO TYPEV-ELEM.
055140 MOVE IN-SCALE TO SCALE-ELEM.
055160 MOVE IN-FCHAR TO FCHAR-ELEM.
055180 MOVE IN-NCHAR TO NCHAR-ELEM.
055200 MOVE IN-ECHAR TO ECHAR-ELEM.
055220 MOVE 0 TO IN-USE-ELEM.
055240 MOVE IN-PICT TO PICT-ELEM.
055260 PERFORM BUILD-PROMPT THRU BUILD-PROMPT-EXIT.
055280 IF IN-UPFLAG = 'N' MOVE '*' TO UPFLAG-ELEM.
055300
055320 DYN-DICT-RD.
055340 MOVE 1 TO MULT-RT-FLAG.
055360 MOVE 'R' TO IDNT-ELEM.
055380 MOVE IN-NAME TO NAME-ELEM.
055400 MOVE DR-ORIGIN TO FCHAR-ELEM.
055420 IF FCHAR-ELEM = 0 MOVE 1 TO FCHAR-ELEM.
055440 MOVE DR-LENGTH TO NCHAR-ELEM.
055460 MOVE DR-TYPE TO RECTYPE-ELEM.
055480
055500*******************************************************
055520* SUBROUTINE TO PEEL EXTRA BLANKS OUT OF MSGS
055540*******************************************************
055560 BLANK-PEELOUT.
055580* ENTER MACRO IQDBNK USING MSG-LINE, MAX-PRINT-CHARS.
055660 SET PRX TO 1.
055680 MOVE 1 TO I J.
055700
055720 BLANK-PEELOUT1.
055740 IF PRX GREATER THAN MAX-PRINT-CHARS SET PRX TO J
055760 GO TO BLANK-PEELOUT2.
055780 MOVE PRINT-CHAR (PRX) TO ELEM-CHAR.
055800 IF I = 0 AND ELEM-CHAR = SPACE NEXT SENTENCE
055820 ELSE MOVE ELEM-CHAR TO PRINT-CHAR (J)
055840 ADD 1 TO J
055860 IF ELEM-CHAR = SPACE MOVE 0 TO I
055880 ELSE MOVE 1 TO I.
055900 SET PRX UP BY 1.
055920 GO TO BLANK-PEELOUT1.
055940
055960 BLANK-PEELOUT2.
055980 IF PRX NOT GREATER THAN MAX-PRINT-CHARS
056000 MOVE SPACE TO PRINT-CHAR (PRX)
056020 SET PRX UP BY 1
056040 GO TO BLANK-PEELOUT2.
056060
056080 BLANK-PEELOUT-EXIT.
056100 EXIT.
056120
056140*******************************************************
056160* SUBROUTINE TO DISPLAY ERROR OR PROGRESS MSGS
056180*******************************************************
056200 DISPLAY-MSG.
056220 PERFORM BLANK-PEELOUT THRU BLANK-PEELOUT-EXIT.
056222 MOVE 80 TO M.
056224 DISPLAY-MSG1.
056226 IF PRINT-CHAR (M) = SPACE
056228 MOVE ASCII-NULL TO PRINT-CHAR (M)
056230 IF M NOT < 2 SUBTRACT 1 FROM M GO TO DISPLAY-MSG1.
056240 DISPLAY MSG-LINE UPON CONSOLE.
056244 DISPLAY-MSG-EXIT.
056248 EXIT.
056260
056280*******************************************************
056300* SUBROUTINE TO PARSE SUPPLIED FILE NAME
056320*******************************************************
056340 FILE-PARSER.
056360 EXAMINE FOUND6-WORD TALLYING UNTIL FIRST '.'.
056380 IF TALLY GREATER THAN 6 MOVE SPACES TO PARSED-FILE-NAME
056400 GO TO FILE-PARSER-EXIT.
056420 MOVE SPACES TO PARSED-FILE-NAME.
056440 MOVE TALLY TO I
056460 ENTER MACRO IQSX66 USING I
056480 FOUND6-WORD CONST1 PARSED-FILE-NAME CONST1.
056500 ADD 2 TO I.
056520 ENTER MACRO IQSX66 USING CONST3
056540 FOUND6-WORD I PARSED-FILE-NAME CONST7.
056560 FILE-PARSER-EXIT.
056580 EXIT.
056600
056620***********************************************
056640* SUBROUTINE TO PROCESS AN ISAM FIND
056660***********************************************
056680
056700 ISAM-KEY-FIND.
056720 MOVE 0 TO READ-FLAG WRITE-FLAG.
056740 IF FIND-TEST-ELEM NOT = 1
056760 MOVE ' %Expecting "=" "EQ" or "EQUALS" after find key'
056780 TO DISPLAY-LINE
056800 PERFORM DISPLAY-MSG THRU DISPLAY-MSG-EXIT
056820 GO TO ISAM-KEY-FIND-EXIT.
056840 IF KEYLOC = 0
056860 MOVE 'FIND KEY = only valid for ISAM'
056880 TO DISPLAY-LINE
056900 PERFORM DISPLAY-MSG THRU DISPLAY-MSG-EXIT
056920 GO TO ISAM-KEY-FIND-EXIT.
056940 MOVE 1 TO READ-FLAG WRITE-FLAG.
056960 IF DICT-FILETYPE = '6'
056980 MOVE FIND-VALUE-ELEM TO QISAM6-SYMKEY
057000 READ QISAM6 INVALID KEY
057020 DISPLAY ' %Key value not found in ISAM file'
057040 MOVE 0 TO READ-FLAG WRITE-FLAG.
057044 IF DICT-FILETYPE = '7'
057060 MOVE FIND-VALUE-ELEM TO QISAM7-SYMKEY
057080 READ QISAM7 INVALID KEY
057100 DISPLAY ' %Key value not found in ISAM file'
057120 MOVE 0 TO READ-FLAG WRITE-FLAG.
057140 ISAM-KEY-FIND-EXIT.
057150 EXIT.
057160
057180**************************************************
057200* SUBROUTINE TO SET THE SYMBOLIC KEY TO THE RECORD KEY
057220************************************************
057240
057260 SET-SYMKEY.
057280 IF DICT-FILETYPE = '6'
057300 MOVE LOW-VALUES TO QISAM6-SYMKEY
057320 ENTER MACRO IQSX66 USING
057340 CONST30 QISAM6-REC KEYLOC
057360 QISAM6-SYMKEY CONST1
057380 ELSE MOVE LOW-VALUES TO QISAM7-SYMKEY
057400 ENTER MACRO IQSX77 USING
057420 CONST30 QISAM7-REC KEYLOC
057440 QISAM7-SYMKEY CONST1.
057460 SET-SYMKEY-EXIT.
057470 EXIT.
057480
057500***********************************************
057520* SUBROUTINE TO REWRITE A MODIFIED ISAM RECORD
057540*********************************************
057560
057580 REWRITE-ISAM.
057600 IF DICT-FILETYPE = '6'
057640 ENTER MACRO IQWRTI USING RECLEN
057660 REWRITE QISAM6-REC INVALID KEY
057700 DISPLAY ' %Illegal to modify ISAM record key'.
057720 IF DICT-FILETYPE = '7'
057760 ENTER MACRO IQWRTI USING RECLEN
057780 REWRITE QISAM7-REC INVALID KEY
057820 DISPLAY ' %Illegal to modify ISAM record key'.
057840 REWRITE-ISAM-EXIT.
057850 EXIT.
057860
057880***************************************************
057900* ROUTINE TO FIND ORDINAL POSITION OF CURRENT ISAM RECORD
057920***************************************************
057940
057960 FIND-THIS-ISAM.
057980 IF DICT-FILETYPE = '6'
058000 PERFORM FIND-THIS-ISAM6 THRU
058020 FIND-THIS-ISAM6-EXIT
058040 ELSE PERFORM FIND-THIS-ISAM7 THRU
058060 FIND-THIS-ISAM7-EXIT.
058080 FIND-THIS-ISAM-EXIT.
058090 EXIT.
058100
058120 FIND-THIS-ISAM6.
058140 SET WRITE-COUNT TO ZERO.
058160 PERFORM SET-SYMKEY THRU SET-SYMKEY-EXIT.
058180 MOVE QISAM6-SYMKEY TO LAST-QISAM6-SYMKEY.
058200 PERFORM ISAM-TOPPER THRU ISAM-TOPPER-EXIT.
058220
058240
058260 F-T-ISAM6-1.
058280 SET WRITE-COUNT UP BY 1.
058300 MOVE LOW-VALUES TO QISAM6-SYMKEY.
058320 READ QISAM6 INVALID KEY MOVE 2 TO READ-FLAG.
058340 PERFORM SET-SYMKEY THRU SET-SYMKEY-EXIT.
058360 IF QISAM6-SYMKEY EQUALS LAST-QISAM6-SYMKEY
058380 GO TO F-T-ISAM6-2.
058400 GO TO F-T-ISAM6-1.
058420 F-T-ISAM6-2.
058440 COMPUTE WORKX = WRITE-COUNT - WORKX - 1.
058460 FIND-THIS-ISAM6-EXIT.
058470 EXIT.
058480
058500 FIND-THIS-ISAM7.
058520 SET WRITE-COUNT TO ZERO.
058540 PERFORM SET-SYMKEY THRU SET-SYMKEY-EXIT.
058560 MOVE QISAM7-SYMKEY TO LAST-QISAM7-SYMKEY.
058580 PERFORM ISAM-TOPPER THRU ISAM-TOPPER-EXIT.
058600
058620 F-T-ISAM7-1.
058640 SET WRITE-COUNT UP BY 1.
058660 MOVE LOW-VALUES TO QISAM7-SYMKEY.
058680 READ QISAM7 INVALID KEY MOVE 2 TO READ-FLAG.
058700 PERFORM SET-SYMKEY THRU SET-SYMKEY-EXIT.
058720 IF QISAM7-SYMKEY EQUALS LAST-QISAM7-SYMKEY
058740 GO TO F-T-ISAM7-2.
058760 GO TO F-T-ISAM7-1.
058780 F-T-ISAM7-2.
058800 COMPUTE WORKX = WRITE-COUNT - WORKX - 1.
058820 FIND-THIS-ISAM7-EXIT.
058830 EXIT.
058840
058860
058880***********************************************************
058900* ROUTINE TO WRITE AN ISAM RECORD KEYED BY RECORD KEY
058920*************************************************************
058940
058960 WRITE-ISAM.
059000 IF DICT-FILETYPE = '6'
059002 MOVE SPACES TO QISAM6-SYMKEY
059004 ENTER MACRO IQSX66 USING CONST30
059008 QISAM6-REC KEYLOC QISAM6-SYMKEY CONST1
059040 ENTER MACRO IQWRTI USING RECLEN
059060 WRITE QISAM6-REC INVALID KEY
059100 DISPLAY ' %Inserted ISAM record already exists'
059120 ' use CHANGE or delete and re-insert'
059140 UPON CONSOLE.
059160 IF DICT-FILETYPE = '7'
059162 MOVE SPACES TO QISAM7-SYMKEY
059164 ENTER MACRO IQSX77 USING CONST30
059168 QISAM7-REC KEYLOC QISAM7-SYMKEY CONST1
059200 ENTER MACRO IQWRTI USING RECLEN
059220 WRITE QISAM7-REC INVALID KEY
059260 DISPLAY ' %Inserted ISAM record already exists',
059280 ' use CHANGE or delete and re-insert'
059300 UPON CONSOLE.
059320 WRITE-ISAM-EXIT.
059330 EXIT.
059340
059360***************************************************
059380*ROUTINE TO DELETE AN EXISTING ISAM RECORD KEYED FROM RECORD KEY
059400*******************************************************
059420
059440 DELETE-ISAM.
059460
059480 PERFORM SET-SYMKEY THRU SET-SYMKEY-EXIT.
059500 IF DICT-FILETYPE = '6'
059520 DELETE QISAM6-REC
059540 INVALID KEY
059560 DISPLAY ' %ISAM record not found on delete'
059580 UPON CONSOLE.
059600 IF DICT-FILETYPE = '7'
059620 DELETE QISAM7-REC
059640 INVALID KEY
059660 DISPLAY ' %ISAM record not found on delete'
059670 UPON CONSOLE.
059680 DELETE-ISAM-EXIT.
059690 EXIT.
059700
059704************************************************************
059708* ROUTINE TO POSITION ISAM FILE AT ITS BEGINNING
059710*************************************************************
059720 ISAM-TOPPER.
059740 MOVE 1 TO INPUT-OPEN-FLAG.
059760 MOVE 3 TO READ-FLAG.
059780 MOVE 0 TO READ-COUNT.
059800 MOVE 0 TO CHANGES-FLAG.
059820 MOVE 1 TO OUTPUT-OPEN-FLAG.
059840 MOVE 0 TO WRITE-COUNT.
059860 MOVE 0 TO CHANGES-FLAG.
059870 MOVE '!' TO ELEM-CHAR.
059880 COMPUTE TMPWRK = KEYLEN.
059890 IF DICT-FILETYPE = '6'
059900 MOVE LOW-VALUES TO QISAM6-SYMKEY
059910 ENTER MACRO IQSX76 USING CONST1 ELEM-CHAR
059915 CONST1 QISAM6-SYMKEY TMPWRK
059920 READ QISAM6 INVALID KEY MOVE 2 TO READ-FLAG.
059930 MOVE LOW-VALUES TO QISAM6-SYMKEY.
059960 IF DICT-FILETYPE = '7'
059970 MOVE LOW-VALUES TO QISAM7-SYMKEY
059980 ENTER MACRO IQSX77 USING CONST1 ELEM-CHAR
059990 CONST1 QISAM7-SYMKEY TMPWRK
060000 READ QISAM7 INVALID KEY MOVE 2 TO READ-FLAG.
060004 MOVE LOW-VALUES TO QISAM7-SYMKEY.
060040 MOVE 1 TO INPUT-OPEN-FLAG.
060060 MOVE 3 TO READ-FLAG.
060080 ISAM-TOPPER-EXIT.
060090 EXIT.
060100