Google
 

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