Google
 

Trailing-Edge - PDP-10 Archives - BB-H548C-BM - iql-source/iqe.cbl
There are 2 other files named iqe.cbl in the archive. Click here to see a list.
000100 IDENTIFICATION DIVISION.
000120 PROGRAM-ID.       IQE.
000140 DATE-WRITTEN.     1 DEC    1976.
000160 DATE-COMPILED.
000180
000200 SECURITY.         COPYRIGHT 1981 AZREX INC
000220                   ALL RIGHTS RESERVED.
000240
000260 REMARKS.          EXECUTION MODULE FOR IQL RELEASE 3.0;
000280                   FIELD TEST VERSION EDIT 4.
000300                   LAST UPDATED 10 NOV 78 BY DWM.
000380                   THIS VERSION CONTAINS SUMMARY BREAK TRIPLES
000400                   AS WELL AS GETTING ITEM VALUES DIRECTLY FROM
000420                   THE RECORD INPUT BUFFERS.
000421
000422       EDIT HISTORY:
000424
000426       EDIT 1 :    FIXED NOT FINDING SUMMARY STATEMENT RIGHT
000428                   AFTER OPEN IF DBMS OR ISAM READING.
000430                   LINE 025044; 6/10/78 BY DWM.
000432
000434       EDIT 2 :    INSERTED DECLARATIVE SECTION TO KEEP COBOL
000436                   FROM BLOWING OFF ON ABSENCE OF FILES ISAMF6.IDX
000438                   AND ISAMF7.IDX UNTIL WE CAN TELL IT THE REAL  
000440                   .IDX FILES TO USE; 6/10/78 BY DWM.
000442
000444       EDIT 3 :    CHANGED BLOCKING FACTORS FROM 2 TO 10 ON ALL
000446                   ISAM FILES SO AS TO GIVE MORE ROOM FOR PHYSICAL
000448                   BLOCK; 6/10/78 BY DWM.
000450
000452       EDIT 4 :    CHANGED ELEM-F-KEYTYPE TO ELEM-F-KEYLOC
000454                   JUST AFTER CORE-DATA-MODE IN ALL CALLS TO
000456                   IQISAM BEFORE OPENING ISAM FILES;
000457                   6/24/78 BY DWM.
000540
000458       EDIT 5 :     ADDED INSTRUCTION 67 (IF ERROR-COUNT)
000460                    AS PART OF INSTRUCTION IF ERROR-STATUS;
000462                    APPLIES TO DBMS PROCESSING ONLY;
000463                    7/13/78 BY DWM.
000464
000466       EDIT 6:      FIXED INDEX RUNOFF IN PARAGRAPHS 
000468                    SORTDSC-ALPHA AND SORTDSC-ALPHA1 SO THAT
000470                    IQE CAN SUCCESSFULLY COMPLEMENT A VERY
000472                    LONG ALPHA FIELD FOR SORT DESCENDING;
000473                    7/13/78 BY DWM.
000474
000475      EDIT 7:	FIX TO CORRECTLY SORT ASCII DBMS RECORDS
000476			NOTE: REQUIRES IQSXFR.FIX INSTALLED IN
000477			IQLIB.REL TO CORRECTLY HANDLE LOWER-CASE.
000478			3/30/79 BY DMW & WML.
000479
000560 ENVIRONMENT DIVISION.
000580 CONFIGURATION SECTION.
000600 SOURCE-COMPUTER.  DECSYSTEM-20.
000620 OBJECT-COMPUTER.  DECSYSTEM-20.
000640 SPECIAL-NAMES.    CHANNEL (1) IS TOP-OF-PAGE
000660                   CONSOLE IS TTY.
000680
000700 INPUT-OUTPUT SECTION.
000720
000740 FILE-CONTROL.
000760     SELECT QTANLZ    ASSIGN TO DSK
000780                      RESERVE NO ALTERNATE AREAS.
000800     SELECT QTEXEC    ASSIGN TO DSK
000820                      RESERVE NO ALTERNATE AREAS.
000840     SELECT QLEXEC    ASSIGN TO DSK.
000860*    *TO AUTOMATICALLY SPOOL PRINTER REPORTS, CHANGE DEVICE
000880*    * ABOVE FROM DSK TO LPT.
000900
000920     SELECT INF1SD6   ASSIGN TO DSK.
000940     SELECT INF1SD7   ASSIGN TO DSK.
000960     SELECT INF2SD6   ASSIGN TO DSK
000980                      RESERVE NO ALTERNATE AREAS.
001000     SELECT INF2SD7   ASSIGN TO DSK
001020                      RESERVE NO ALTERNATE AREAS.
001040     SELECT INF3SD6   ASSIGN TO DSK
001060                      RESERVE NO ALTERNATE AREAS.
001080     SELECT INF3SD7   ASSIGN TO DSK
001100                      RESERVE NO ALTERNATE AREAS.
001120     SELECT OUTFSD6   ASSIGN TO DSK
001140                      RESERVE NO ALTERNATE AREAS.
001160     SELECT OUTFSD7   ASSIGN TO DSK
001180                      RESERVE NO ALTERNATE AREAS.
001200     SELECT CREATESD6 ASSIGN TO DSK
001220                      RESERVE NO ALTERNATE AREAS.
001240     SELECT CREATESD7 ASSIGN TO DSK
001260                      RESERVE NO ALTERNATE AREAS.
001280     SELECT INF1ISAM6 ASSIGN TO DSK
001300                      ACCESS IS INDEXED
001320                      RECORD   KEY IS INF1ISAM6-RECKEY
001340                      SYMBOLIC KEY IS INF1ISAM6-SYMKEY
001344                      FILE-STATUS IS SC,EM,AC.
001360     SELECT INF1ISAM7 ASSIGN TO DSK
001380                      ACCESS IS INDEXED
001400                      RECORD   KEY IS INF1ISAM7-RECKEY
001420                      SYMBOLIC KEY IS INF1ISAM7-SYMKEY
001424                      FILE-STATUS IS SC,EM,AC.
001440     SELECT INF2ISAM6 ASSIGN TO DSK
001460                      ACCESS IS INDEXED
001480                      RECORD   KEY IS INF2ISAM6-RECKEY
001500                      SYMBOLIC KEY IS INF2ISAM6-SYMKEY
001504                      FILE-STATUS IS SC,EM,AC.
001520     SELECT INF2ISAM7 ASSIGN TO DSK
001540                      ACCESS IS INDEXED
001560                      RECORD   KEY IS INF2ISAM7-RECKEY
001580                      SYMBOLIC KEY IS INF2ISAM7-SYMKEY
001584                      FILE-STATUS IS SC,EM,AC.
001600     SELECT INF3ISAM6 ASSIGN TO DSK
001620                      ACCESS IS INDEXED
001640                      RECORD   KEY IS INF3ISAM6-RECKEY
001660                      SYMBOLIC KEY IS INF3ISAM6-SYMKEY
001664                      FILE-STATUS IS SC,EM,AC.
001680     SELECT INF3ISAM7 ASSIGN TO DSK
001700                      ACCESS IS INDEXED
001720                      RECORD   KEY IS INF3ISAM7-RECKEY
001740                      SYMBOLIC KEY IS INF3ISAM7-SYMKEY
001744                      FILE-STATUS IS SC,EM,AC.
001760     SELECT SORTFILE  ASSIGN TO DSK.
001780
001800 I-O-CONTROL.
001820     SAME AREA FOR INF1SD6 INF1SD7 INF1ISAM6 INF1ISAM7.
001840     SAME AREA FOR OUTFSD6 OUTFSD7 QTANLZ.
001860     SAME AREA FOR CREATESD6 CREATESD7.
001880     SAME AREA FOR INF2SD6 INF2SD7 INF2ISAM6 INF2ISAM7.
001900     SAME AREA FOR INF3SD6 INF3SD7 INF3ISAM6 INF3ISAM7.
001920
001940 DATA DIVISION.
001960
001980 FILE SECTION.
002000
002020 FD  INF1SD6
002040     VALUE OF IDENTIFICATION IS ELEM-F-ID
002060*    USER-NUMBER IS ELEM-F-PPN
002080     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS
002100     DATA RECORDS ARE INF1SD6-REC RD-DBMS-TABLE.
002120 01  INF1SD6-REC             PIC X(4092) USAGE IS DISPLAY-6.
002140
002141 01  RD-DBMS-TABLE         DISPLAY-6.
002142     02  FILLER OCCURS 96 TIMES INDEXED BY RX.
002143         04  REC-NAM          PIC X(30).
002144         04  REC-TYP          PIC 9.
002145             88  RSIXBIT      VALUE 6.
002146             88  RASCII       VALUE 7.
002147             88  REBCDIC      VALUE 9.
002148         04  START-LOC        PIC 9(4).
002149         04  R-LENGTH         PIC 9(4).
002150         04  NMID             PIC 99.
002151         04  FILLER           PIC X.
002152
002160 FD  INF1SD7
002180     VALUE OF IDENTIFICATION IS ELEM-F-ID
002200*    USER-NUMBER IS ELEM-F-PPN
002220     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS
002240     DATA RECORD IS INF1SD7-REC.
002260 01  INF1SD7-REC             PIC X(3410) USAGE IS DISPLAY-7.
002280
002300 FD  INF2SD6
002320     VALUE OF IDENTIFICATION IS ELEM-F-ID
002340*    USER-NUMBER IS ELEM-F-PPN
002360     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS
002380     DATA RECORD IS INF2SD6-REC.
002400 01  INF2SD6-REC             PIC X(4092).
002420
002440 FD  INF2SD7
002460     VALUE OF IDENTIFICATION IS ELEM-F-ID
002480*    USER-NUMBER IS ELEM-F-PPN
002500     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS
002520     DATA RECORD IS INF2SD7-REC.
002540 01  INF2SD7-REC             PIC X(3410) USAGE IS DISPLAY-7.
002560
002580 FD  INF3SD6
002600     VALUE OF IDENTIFICATION IS ELEM-F-ID
002620*    USER-NUMBER IS ELEM-F-PPN
002640     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS
002660     DATA RECORD IS INF3SD6-REC.
002680 01  INF3SD6-REC             PIC X(4092) USAGE IS DISPLAY-6.
002700
002720 FD  INF3SD7
002740     VALUE OF IDENTIFICATION IS ELEM-F-ID
002760*    USER-NUMBER IS ELEM-F-PPN
002780     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS
002800     DATA RECORD IS INF3SD7-REC.
002820 01  INF3SD7-REC             PIC X(3410) USAGE IS DISPLAY-7.
002840
002860 FD  OUTFSD6
002880     VALUE OF IDENTIFICATION IS ELEM-F-ID
002900     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS
002920     DATA RECORD IS OUTFSD6-REC.
002940 01  OUTFSD6-REC             PIC X(4092) USAGE IS DISPLAY-6.
002960
002980 FD  OUTFSD7
003000     VALUE OF IDENTIFICATION IS ELEM-F-ID
003020     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS
003040     DATA RECORD IS  OUTFSD7-REC.
003060 01  OUTFSD7-REC             PIC X(3410) USAGE IS DISPLAY-7.
003080
003100 FD  CREATESD6
003120     VALUE OF IDENTIFICATION IS ELEM-F-ID
003140     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS
003160     DATA RECORD IS CREATESD6-REC.
003180 01  CREATESD6-REC           PIC X(4092) USAGE IS DISPLAY-6.
003200
003220 FD  CREATESD7
003240     VALUE OF IDENTIFICATION IS ELEM-F-ID
003260     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS
003280     DATA RECORD IS CREATESD7-REC.
003300 01  CREATESD7-REC           PIC X(3410) USAGE IS DISPLAY-7.
003320
003340 FD  INF1ISAM6
003360     VALUE OF IDENTIFICATION IS ELEM-F-ID
003380*    USER-NUMBER IS ELEM-F-PPN
003400     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 10 RECORDS
003420     DATA RECORD IS INF1ISAM6-REC.
003440 01  INF1ISAM6-REC USAGE IS DISPLAY-6.
003460     02  INF1ISAM6-RECKEY    PIC X(30).
003480     02  FILLER              PIC X(4062).
003500
003520 FD  INF1ISAM7
003540     VALUE OF IDENTIFICATION IS INFXISAM7-ID
003560*    USER-NUMBER IS ELEM-F-PPN
003580     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 10 RECORDS
003600     DATA RECORD IS INF1ISAM7-REC.
003620 01  INF1ISAM7-REC USAGE IS DISPLAY-7.
003640     02  INF1ISAM7-RECKEY    PIC X(30).
003660     02  FILLER              PIC X(3380).
003680
003700 FD  INF2ISAM6
003720     VALUE OF IDENTIFICATION IS ELEM-F-ID
003740*    USER-NUMBER IS ELEM-F-PPN
003760     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 10 RECORDS
003780     DATA RECORD IS INF2ISAM6-REC.
003800 01  INF2ISAM6-REC USAGE IS DISPLAY-6.
003820     02  INF2ISAM6-RECKEY    PIC X(30).
003840     02  FILLER              PIC X(4062).
003860
003880 FD  INF2ISAM7
003900     VALUE OF IDENTIFICATION IS INFXISAM7-ID
003920*    USER-NUMBER IS ELEM-F-PPN
003940     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 10 RECORDS
003960     DATA RECORD IS INF2ISAM7-REC.
003980 01  INF2ISAM7-REC USAGE IS DISPLAY-7.
004000     02  INF2ISAM7-RECKEY    PIC X(30).
004020     02  FILLER              PIC X(3380).
004040
004060 FD  INF3ISAM6
004080     VALUE OF IDENTIFICATION IS ELEM-F-ID
004100*    USER-NUMBER IS ELEM-F-PPN
004120     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 10 RECORDS
004140     DATA RECORD IS INF3ISAM6-REC.
004160 01  INF3ISAM6-REC USAGE IS DISPLAY-6.
004180     02  INF3ISAM6-RECKEY    PIC X(30).
004200     02  FILLER              PIC X(4062).
004220
004240 FD  INF3ISAM7
004260     VALUE OF IDENTIFICATION IS INFXISAM7-ID
004280*    USER-NUMBER IS ELEM-F-PPN
004300     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 10 RECORDS
004320     DATA RECORD IS INF3ISAM7-REC.
004340 01  INF3ISAM7-REC USAGE IS DISPLAY-7.
004360     02  INF3ISAM7-RECKEY    PIC X(30).
004380     02  FILLER              PIC X(3380).
004400
004420 FD  QTANLZ
004440     VALUE OF IDENTIFICATION IS QTANLZTMP
004460     BLOCK CONTAINS 0 RECORDS
004480     LABEL RECORD IS STANDARD
004500     DATA RECORDS ARE QTANLZ-REC QTANLZ-REC1.
004520 01  QTANLZ-REC.
004540     02  QTANLZ-NAME.
004560         04  QTANLZ-PREFIX   PIC X(6).
004580         04  QTANLZ-SUFFIX   PIC X(3).
004600     02  FILLER              PIC XXX.
004620     02  QTANLZ-PPN          PIC S9(10) COMP.
004640     02  FILLER              PIC X(72).
004660
004680 01  QTANLZ-REC1.
004700     02  QTANLZ-SWITCH       PIC X(30).
004720     02  FILLER              PIC X(60).
004740
004760
004780 FD  QTEXEC
004800     VALUE OF IDENTIFICATION IS QTEXECTMP
004820     BLOCK CONTAINS 0 RECORDS
004840     LABEL RECORD IS STANDARD DATA RECORD IS QTEXEC-REC.
004860 01  QTEXEC-REC USAGE IS DISPLAY-6.
004880     02  QTE-RPT-PARAMS.
004900         04  QTE-RPT-NO      PIC S9(10) COMP.
004920         04  QTE-PAGE-NO     PIC S9(10) COMP.
004940         04  QTE-LINE-NO     PIC S9(10) COMP.
004960         04  QTE-ACROSS      PIC S9(10) COMP.
004980         04  QTE-DISPLAY-FLAG   REDEFINES QTE-ACROSS
005000                             PIC S9(10) COMP.
005020         04  QTE-VSPACE      PIC S9(10) COMP.
005040         04  QTE-PRINT-FLAG     REDEFINES QTE-VSPACE
005060                             PIC S9(10) COMP.
005080         04  QTE-PRINTX      PIC S9(10) COMP.
005100         04  QTE-PAGE-LINES     REDEFINES QTE-PRINTX
005120                             PIC S9(10) COMP.
005140         04  QTE-PRINTPOS    PIC S9(10) COMP.
005160         04  QTE-FORM-LINES     REDEFINES QTE-PRINTPOS
005180                                 PIC S9(10) COMP.
005200     02  QTE-IMAGE           PIC X(200).
005220
005240 FD  QLEXEC
005260     VALUE OF IDENTIFICATION IS QLEXECLPT
005280     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS
005300     RECORD CONTAINS 132 CHARACTERS
005320     DATA RECORD IS QLEXEC-REC.
005340 01  QLEXEC-REC USAGE IS DISPLAY-7.
005360     02  QLEXEC-REC-CHARS    PIC X OCCURS 132 TIMES.
005380
005400 FD SORTFILE
005420     VALUE OF IDENTIFICATION IS QTSORTTMP
005440     LABEL RECORDS ARE STANDARD
005460     BLOCK CONTAINS 0 RECORDS
005480     RECORD CONTAINS 4092 CHARACTERS
005500     DATA RECORD IS SORTFILE-REC.
005520 01  SORTFILE-REC.
005540     02  SORTFILE-KEY.
005560         04  SORTFILE-KEYCHAR PIC X OCCURS 4092 TIMES
005580                                        INDEXED BY SKX.
005600
005620 WORKING-STORAGE SECTION.
005621
005622 01  COPYRIGHT-NOTICE     PIC X(50)     VALUE
005623     "COPYRIGHT 1981 - AZREX, INC. - ALL RIGHTS RESERVED".
005640
005660*****DYNAMIC FILE NAMES FOLLOW*****.
005680
005700 01  QTSORTTMP.
005720     02  FILLER              PIC X(2) VALUE 'QT'.
005740     02  QTSORTNO            PIC 999  VALUE 001.
005760     02  FILLER              PIC X(4) VALUE 'STMP'.
005780 01  QTANLZTMP               PIC X(9).
005800 01  QT001ATMP.
005820     02  FILLER              PIC X(2) VALUE 'QT'.
005840     02  QTANLZNO            PIC 999  VALUE 001.
005860     02  FILLER              PIC X(4) VALUE 'ATMP'.
005880 01  QTEXECTMP.
005900     02  FILLER              PIC X(2) VALUE 'QT'.
005920     02  QTEXECNO            PIC 999  VALUE 001.
005940     02  FILLER REDEFINES QTEXECNO.
005960         04  QTEXEC-NODUP    PIC X.
005980         04  FILLER          PIC XX.
006000     02  FILLER              PIC X(4) VALUE 'MTMP'.
006020 01  QLEXECLPT.
006040     02  FILLER              PIC X(2) VALUE 'QL'.
006060     02  QLEXECNO            PIC 999  VALUE 001.
006080     02  FILLER REDEFINES QLEXECNO.
006100         04  QLEXEC-NODUP    PIC X.
006120         04  FILLER          PIC XX.
006140     02  FILLER              PIC X(4) VALUE 'ELPT'.
006160 01  INFXISAM7-ID            PIC X(9) VALUE 'ISAMF7IDX'.
006180
006200**DBMS CALL PARAMETERS FOLLOW**
006220
006240 01  FIND-RSE                PIC S9(10) COMP VALUE 10.
006260 01  RECORD-NAME             PIC X(30) VALUE ' ' DISPLAY-7.
006280 01  SCHEMA-NAME             PIC X(30) VALUE ' ' DISPLAY-7.
006300 01  FIRST-NEXT-INDIC        PIC S9(10) COMP VALUE -12.
006320     88  OWNER-INDIC         VALUE -11.
006340     88  FIRST-INDIC         VALUE -12.
006360     88  LAST-INDIC          VALUE -13.
006380     88  NEXT-INDIC          VALUE -14.
006400     88  PRIOR-INDIC         VALUE -15.
006420 01  AREA-NAME               PIC X(30) VALUE ' ' DISPLAY-7.
006440 01  SET-NAME               REDEFINES AREA-NAME
006460                             PIC X(30) DISPLAY-7.
006480 01  SUBSCHEMA-NAME          PIC X(30) VALUE ' ' DISPLAY-7.
006500 01  SET-AREA-INDIC          PIC S9(10) COMP VALUE -18.
006520     88  AREA-INDIC          VALUE -18.
006540     88  SET-INDIC           VALUE -20.
006560 01  DBMS-ERROR-FLAG         PIC S9(10) COMP VALUE 0.
006580 01  PRIVACY-KEY             PIC X(30) VALUE 'NOLOCK' DISPLAY-7.
006600
006620**FLAGS FOLLOW**
006640
006660 01  FLAGS.
006680     02  ALL-SPACES-FLAG     PIC 9 COMP VALUE 0.
006700     02  BREAK-FLAG          PIC 9 COMP VALUE 0.
006720     02  CALL-IQM-FLAG       PIC 9 COMP VALUE 0.
006740     02  COPYFILE-FLAG       PIC 9 COMP VALUE 0.
006760     02  CREATEFILE-FLAG     PIC 9 COMP VALUE 0.
006780     02  DECIMAL-FLAG        PIC 9 COMP VALUE 0.
006800     02  ENDING-FLAG         PIC 9 COMP VALUE 0.
006802     02  END-DD-F            PIC 9 COMP VALUE 0.
006804         88  END-DD          VALUE 1.
006806     02  END-TAB-F           PIC 9 COMP VALUE 0.
006808         88  END-TAB         VALUE 1.
006820     02  ENTRY-ERROR-FLAG    PIC 9 COMP VALUE 0.
006840     02  INF1-FLAG           PIC 9 COMP VALUE 0.
006860         88  CLOSED          VALUE 0.
006880         88  BEFORE-1ST-REC  VALUE 1.
006900         88  FIRST-REC       VALUE 2.
006920         88  IN-MIDDLE       VALUE 3.
006940         88  LAST-RECORD     VALUE 4.
006960         88  END-FILE        VALUE 5.
006980         88  NOT-IN-USE      VALUE 6.
007000     02  INF2-FLAG           PIC 9 COMP VALUE 0.
007020     02  INF3-FLAG           PIC 9 COMP VALUE 0.
007030     02  ISAM-ERROR-FLAG     PIC 9 COMP VALUE 0.
007040     02  FIND-ERROR-FLAG     PIC 9 COMP VALUE 0.
007060     02  LITERAL-FLAG        PIC 9 COMP VALUE 0.
007080     02  MINUS-FLAG          PIC 9 COMP VALUE 0.
007100     02  MISS-FLAG           PIC 9 COMP VALUE 0.
007120     02  NEWGROUP-FLAG       PIC 9 COMP VALUE 0.
007140     02  NEWPAGE-FLAG        PIC 9 COMP VALUE 0.
007160     02  NUM-VAL-FLAG        PIC 9 COMP VALUE 0.
007180     02  OVERFLOW-FLAG       PIC 9 COMP VALUE 0.
007200     02  PRINTFILE-FLAG      PIC 9 COMP VALUE 0.
007220     02  ROUNDING-FLAG       PIC 9 COMP VALUE 0.
007240     02  SORTFILE-FLAG       PIC 9 COMP VALUE 0.
007250     02  STOP-FLAG           PIC 9 COMP VALUE 0.
007260     02  SPECIAL-ITM-FLAG    PIC 9 COMP VALUE 0.
007280     02  SUPPRESSING-FLAG    PIC 9 COMP VALUE 1.
007300     02  TRUE-FLAG           PIC 9 COMP VALUE 0.
007320
007312**FILE ERROR RETURNS FOR USE BY DECLARATIVES FOLLOW**
007314 01  ERROR-CONTROL-BLOCK.
007316     02  SC                  PIC 99.
007316     02  EM                  PIC 9(10).                  
007317     02  FILLER              REDEFINES EM.
000020         04  ERROR-VERB      PIC 99.
007322         04  ERROR-CALL      PIC 99.
007324         04  ERROR-FILE      PIC 99.
007326         04  ERROR-BLOCK     PIC 9.
007328         04  ERROR-NUMBER    PIC 999.
007330     02  AC                  INDEX.
007332
007340**WORKING COMPUTATIONAL ITEMS FOLLOW**
007360
007380 01  COMP-WORKERS.
007400     02  ACCUM-SCALE         PIC S9(10) COMP VALUE 0.
007420     02  ALT-NHOLDER-SCALE   PIC S9(10) COMP VALUE 0.
007440     02  ALT-NHOLDER-TYPE    PIC S9(10) COMP VALUE 0.
007460     02  AVERAGE-CODE        PIC S9(10) COMP VALUE 49.
007480     02  AVERAGE-TALLY       PIC S9(10) COMP VALUE 1.
007500     02  BUFFER-LENGTH       PIC S9(10) COMP VALUE 6144.
007510     02  C2E18               PIC S9(10) COMP VALUE 262144.
007515     02  C2E18-1             PIC S9(10) COMP VALUE 262143.
007520     02  CHARS-PER-WORD      PIC S9(10) COMP VALUE 6.
007540     02  CONST-1             PIC S9(10) COMP VALUE -1.
007560     02  CONST2              PIC S9(10) COMP VALUE 2.
007580     02  CONST6              PIC S9(10) COMP VALUE 6.
007600     02  CONST7              PIC S9(10) COMP VALUE 7.
007620     02  CONST8              PIC S9(10) COMP VALUE 8.
007640     02  CONST9              PIC S9(10) COMP VALUE 9.
007660     02  CONST10             PIC S9(10) COMP VALUE 10.
007680     02  CONST12             PIC S9(10) COMP VALUE 12.
007700     02  CONST18             PIC S9(10) COMP VALUE 18.
007720     02  CONST19             PIC S9(10) COMP VALUE 19.
007740     02  CONST20             PIC S9(10) COMP VALUE 20.
007742     02  CONST30             PIC S9(10) COMP VALUE 30.
007760     02  CONST63             PIC S9(10) COMP VALUE 63.
007780     02  CONST100            PIC S9(10) COMP VALUE 100.
007800     02  COPY-FX             PIC S9(10) COMP VALUE 0.
007820     02  COPY-RECLEN         PIC S9(10) COMP VALUE 0.
007840     02  CORE-DATA-MODE      PIC S9(10) COMP VALUE 0.
007860     02  CREATE-FX           PIC S9(10) COMP VALUE 0.
007880     02  CREATE-RECLEN       PIC S9(10) COMP VALUE 0.
007900     02  CURR-HSPACE         PIC S9(10) COMP VALUE 0.
007920     02  CURR-VSPACE         PIC S9(10) COMP VALUE 1.
007940     02  DOLLAR-COUNT        PIC S9(10) COMP VALUE 0.
007950     02  DX-LOWEST           PIC S9(10) COMP VALUE 0.
007955     02  ELEM-INSTR          PIC S9(10) COMP VALUE 0.
007960     02  FALSEGOX            PIC S9(10) COMP VALUE 1.
007980     02  FILE-RECORDING-MODE PIC S9(10) COMP VALUE 0.
008000     02  FILE-ROUTER         PIC S9(10) COMP VALUE 1.
008020     02  FIND-ERROR-CODE     PIC S9(10) COMP VALUE 0.
008040     02  FIND-PLACE          PIC S9(10) COMP VALUE 0.
008060     02  FIND-REC-NO         PIC S9(10) COMP VALUE 0.
008080     02  FIND-SET            PIC S9(10) COMP VALUE 0.
008100     02  FIND-SUPPRESS       PIC S9(10) COMP VALUE 0.
008120     02  FLOAT-POS           PIC S9(10) COMP VALUE 0.
008140     02  HOLDX               PIC S9(10) COMP VALUE 1.
008150     02  HOLD-TITLE-FLAG     PIC S9(10) COMP VALUE 0.
008160     02  I                   PIC S9(10) COMP VALUE 1.
008180     02  INF1-FX             PIC S9(10) COMP VALUE 0.
008200     02  INF1-RECLEN         PIC S9(10) COMP VALUE 0.
008220     02  INF1-TYPE           PIC S9(10) COMP VALUE 0.
008240         88  SEQUENTIAL-SIXBIT                   VALUE 1.
008260         88  SEQUENTIAL-ASCII                    VALUE 2.
008280         88  ISAM-SIXBIT                         VALUE 3.
008300         88  ISAM-ASCII                          VALUE 4.
008320         88  DBMS-TYPE                           VALUE 5.
008340     02  INF2-FX             PIC S9(10) COMP VALUE 0.
008360     02  INF2-RECLEN         PIC S9(10) COMP VALUE 0.
008380     02  INF2-TYPE           PIC S9(10) COMP VALUE 0.
008400     02  INF3-FX             PIC S9(10) COMP VALUE 0.
008420     02  INF3-RECLEN         PIC S9(10) COMP VALUE 0.
008440     02  INF3-TYPE           PIC S9(10) COMP VALUE 0.
008460     02  INPUT-TO-COPY-FTYPE PIC S9(10) COMP VALUE 1.
008480     02  J                   PIC S9(10) COMP VALUE 1.
008500     02  K                   PIC S9(10) COMP VALUE 1.
008520     02  KEYLEN1             PIC S9(10) COMP VALUE 1.
008540     02  KEYLEN2             PIC S9(10) COMP VALUE 1.
008560     02  KEYLEN3             PIC S9(10) COMP VALUE 1.
008580     02  KEYLOC1             PIC S9(10) COMP VALUE 1.
008600     02  KEYLOC2             PIC S9(10) COMP VALUE 1.
008620     02  KEYLOC3             PIC S9(10) COMP VALUE 1.
008640     02  KICKOFF-FLAG        PIC S9(10) COMP VALUE 0.
008660     02  L                   PIC S9(10) COMP VALUE 1.
008670     02  LEFT-HALF           PIC S9(10) COMP VALUE 0.
008680     02  LINES-IN-PHASE      PIC S9(10) COMP VALUE 0.
008700     02  LASTTIME-X          PIC S9(10) COMP VALUE 0.
008710     02  LINE-LENGTH         PIC S9(10) COMP VALUE 1.
008720     02  LPAREN-COUNT        PIC S9(10) COMP VALUE 0.
008740     02  MAXIMUM-CODE        PIC S9(10) COMP VALUE 80.
008760     02  MAX-AITEM-LEN       PIC S9(10) COMP VALUE 54.
008780     02  MAX-AITEM-LEN-UP1   PIC S9(10) COMP VALUE 55.
008800     02  MAX-ANX             PIC S9(10) COMP VALUE 84.
008820     02  MAX-DX              PIC S9(10) COMP VALUE 200.
008840     02  MAX-FWX             PIC S9(10) COMP VALUE 72.
008860     02  MAX-KEYLEN          PIC S9(10) COMP VALUE 30.
008880     02  MAX-NITEM-LEN       PIC S9(10) COMP VALUE 18.
008900     02  MAX-NITEM-LEN-UP1   PIC S9(10) COMP VALUE 19.
008920     02  MAX-PRINT-CHARS     PIC S9(10) COMP VALUE 220.
008940     02  MAX-PROMPT          PIC S9(10) COMP VALUE 33.
008960     02  MAX-REPORTS         PIC S9(10) COMP VALUE 10.
008980     02  MINIMUM-CODE        PIC S9(10) COMP VALUE 81.
009000     02  NCOPIED             PIC S9(10) COMP VALUE 0.
009020     02  NEXTRX              PIC S9(10) COMP VALUE 1.
009040     02  NHOLDER-SCALE       PIC S9(10) COMP VALUE 0.
009060     02  NHOLDER-TYPE        PIC 9 COMP VALUE 0.
009080         88  EMPTY-TYPE      VALUE 0.
009100         88  ALPHA-TYPE      VALUE 1.
009120         88  NUMERIC-TYPE    VALUE 2.
009140         88  BINARY-TYPE     VALUE 6.
009150     02  OCCURENCE           PIC S9(10) COMP VALUE 0.
009160     02  OPERATION           PIC S9(10) COMP VALUE 0.
009180     02  PREV-START-ANX      PIC S9(10) COMP VALUE 1.
009200     02  PRINT-POS           PIC S9(10) COMP VALUE 1.
009220     02  PROJ                PIC S9(10) COMP VALUE 0.
009240     02  QTEXEC-COUNT        PIC S9(10) COMP VALUE 0.
009250     02  RANGE1              PIC S9(10) COMP VALUE 0.
009255     02  RANGE2              PIC S9(10) COMP VALUE 0.
009260     02  REPORT-CODE         PIC S9(10) COMP VALUE 23.
009280     02  RELATIONSHIP        PIC S9(10) COMP VALUE 0.
009290     02  RIGHT-HALF          PIC S9(10) COMP VALUE 0.
009300     02  ROUTER              PIC S9(10) COMP VALUE 0.
009310         88  IN-SCAN1        VALUE 1,2,3,4.
009312         88  IN-SCAN2        VALUE 7,8,9,10.
009314         88  IN-SCAN3        VALUE 13,14,15,16.
009320     02  RPTHEAD-STOPPER     PIC S9(10) COMP VALUE 90902.
009340     02  RUNNING-ACROSS      PIC S9(10) COMP VALUE 1.
009360     02  RUNNING-ACROSSX     PIC S9(10) COMP VALUE 1.
009380     02  RUNNING-PRINTPOS    PIC S9(10) COMP VALUE 1.
009400     02  RUNNING-PRINTPOSX   PIC S9(10) COMP VALUE 1.
009404     02  SAVE-BHOLDER        PIC S9(18) COMP.
009410     02  SAVE-LEFT-DX-X      PIC S9(10) COMP VALUE 0.
009414     02  SAVE-SCALE          PIC S9(10) COMP.
009415     02  SAVED-GRPNAME       PIC X           VALUE SPACE.
009420     02  SAVEX               PIC S9(10) COMP VALUE 0.
009425     02  SCAN-ITEM-SW        PIC S9(10) COMP VALUE 0.
009430         88  NO-SCAN-ITEMS   VALUE 0.
009435     02  SCAN-POS            PIC S9(10) COMP VALUE 0.
009440     02  SUMX                PIC S9(10) COMP VALUE 0.
009460     02  SIGN-POS            PIC S9(10) COMP VALUE 1.
009480     02  SORT-KEYLEN         PIC S9(10) COMP VALUE 60.
009500     02  SORT-KEYOFFSET      PIC S9(10) COMP VALUE 1.
009520     02  SORT-RECLEN         PIC S9(10) COMP VALUE 640.
009540     02  SORTER-ROUTER       PIC S9(10) COMP VALUE 1.
009560     02  SORT-STARTX         PIC S9(10) COMP VALUE 1.
009580     02  START-ANX           PIC S9(10) COMP VALUE 1.
009590     02  STOP-CHARS          PIC S9(10) COMP VALUE 0.
009600     02  SUMJ                PIC S9(10) COMP VALUE 1.
009620     02  SUMK                PIC S9(10) COMP VALUE 1.
009640     02  SUM-WORK            PIC S9(18) COMP VALUE 0.
009660     02  SUMMARY-ROUTER      PIC S9(10) COMP VALUE 1.
009680     02  TALLY-CODE          PIC S9(10) COMP VALUE 47.
009700     02  TARGET-DX           PIC S9(10) COMP VALUE 1.
009720     02  TARGET-ROUTER       PIC S9(10) COMP VALUE 1.
009730     02  TERM-CHARS          PIC S9(10) COMP VALUE 72.
009735     02  TITL-WHILE-ACROSS   PIC S9(10) COMP VALUE 0.
009740     02  TOTAL-CODE          PIC S9(10) COMP VALUE 48.
009760     02  TRUEGOX             PIC S9(10) COMP VALUE 1.
009780     02  TRUE-TYPEV          PIC S9(10) COMP VALUE 1.
009800     02  USER                PIC S9(10) COMP VALUE 0.
009820     02  WORK-2              PIC S9(18) COMP VALUE 0.
009840     02  FILLER REDEFINES WORK-2.
009860         04  WORK-2-LEFT	   PIC S9(10) COMP.
009880         04  WORK-2-RIGHT    PIC S9(10) COMP.
009900     02  WORKX               PIC S9(10) COMP VALUE 0.
009920
009940**MISC ALPHA & STRAIGHT NUM ITEMS FOLLOW**
009960
009980 01  ALPHA-WORKERS.
010000     02  DEVICER             PIC X(6)  VALUE ' '.
010020     02  CALLED-NAME         PIC X(6)  VALUE 'IQL   '.
010040     02  CURRENT-QUOTE       PIC X     VALUE SPACE.
010060     02  FLOAT-CHAR          PIC X     VALUE SPACE.
010080 01  FIND-NAME               PIC X(30) VALUE SPACE.
010100 01  FIND-RECORD             PIC X(30) VALUE SPACE.
010120 01  FILLER.
010140     02  TODAYS-DATE.
010160         04  TODAY1          PIC 99.
010180         04  TODAY2          PIC 99.
010200         04  TODAY3          PIC 99.
010220     02  REPORTDATE.
010240         04  REPORTDATE1     PIC 99.
010260         04  REPORTDATE2     PIC 99.
010280         04  REPORTDATE3     PIC 99.
010300     02  RPTMASK.
010320         04  RPTMASK1        PIC 99.
010340         04  FILLER          PIC X VALUE '/'.
010360         04  RPTMASK2        PIC 99.
010380         04  FILLER          PIC X VALUE '/'.
010400         04  RPTMASK3        PIC 99.
010420     02  DISPLAY-PAGE.
010440         04  FILLER          PIC X(5) VALUE 'PAGE '.
010460         04  DISPLAY-PAGENO  PIC ZZZ9.
010480     02  PICT-WORK.
010500         04  PICT-CHAR       PIC X OCCURS 21
010520                             INDEXED BY PIX.
010540     02  TEMPKEYV            PIC X(30).
010560
010580 01  INF1ISAM6-SYMKEY        PIC X(30) VALUE ' ' DISPLAY-6.
010600 01  INF1ISAM7-SYMKEY        PIC X(30) VALUE ' ' DISPLAY-7.
010620 01  INF2ISAM6-SYMKEY        PIC X(30) VALUE ' ' DISPLAY-6.
010640 01  INF2ISAM7-SYMKEY        PIC X(30) VALUE ' ' DISPLAY-7.
010660 01  INF3ISAM6-SYMKEY        PIC X(30) VALUE ' ' DISPLAY-6.
010680 01  INF3ISAM7-SYMKEY        PIC X(30) VALUE ' ' DISPLAY-7.
010700 01  ERROR-CODE              PIC 99999.
010720 01  BINARY-CHAR             PIC S9(10) COMP.
010740 01  FILLER REDEFINES BINARY-CHAR.
010760     02  FILLER             PIC X(5).
010780     02  ELEM-CHAR          PIC X.
010800 01  RANDOM-SEED.
010820     02  SEEDER              PIC 9(14) VALUE 47594118.
010840     02  FILLER REDEFINES SEEDER.
010860         04  SEED-JUNK       PIC 9(4).
010880         04  SEED            PIC 9(10).
010900 01  SEED-WORK-PARAMS.
010920     02  SEED-MULT           PIC 99 VALUE 23.
010940     02  SEED-INC            PIC 9 VALUE 1.
010960     02  SEED-WORK           PIC 9(4).
010980
011000**MISCELLANEOUS BUFFERS FOLLOW**
011020
011040*
011060*    *NOTE THAT ARGUMENTS ARE -BEFORE- BUFFERS*.
011080*
011100 01   SYSCOM DISPLAY-7.
011120         03  SYSCOM-AREA-NAME		PIC X(30) DISPLAY-7.
011140         03  SYSCOM-RECORD-NAME		PIC X(30) DISPLAY-7.
011160         03  ERROR-STATUS		PIC 9(5) DISPLAY-7.
011180         03  ERROR-SET		PIC X(30) DISPLAY-7.
011200         03  ERROR-RECORD		PIC X(30) DISPLAY-7.
011220         03  ERROR-AREA		PIC X(30) DISPLAY-7.
011240         03  ERROR-COUNT		PIC 99 COMP.
011241         03  data-base-key        pic 9(10) comp.
011242         03  error-data           pic 9(10) comp.
011243         03  filler               pic x(50) display-7.
011244
011248 01  CURRENT-RECORD-KEY           PIC S9(10) COMP VALUE 0.
011249 01  AREA-NAME-IDENT              PIC X(30)  DISPLAY-7.
011260 01  BUFFERS.
011280
011300
011320     02  FILLER              PIC X(336).
011340     02  HOLD-BUFFER         PIC X(1000).
011360*
011380 01  PASSED-PARAMS REDEFINES BUFFERS.
011400     02  EXIT-CODE           PIC 999.
011420     02  STATUS-CODE         PIC XXX.
011460     02  ARGUMENTS.
011480         04  ARG             PIC X(30) OCCURS 11 TIMES
011500                                           INDEXED BY ARX.
011502     02  ARGUMENTS-R1        REDEFINES ARGUMENTS.
011504         04  ARG-R1          OCCURS 11 TIMES.
011506             06  FILLER      PIC X(12).
011508             06  N-ARG       PIC S9(18).
011510     02  ARGUMENTS-R2        REDEFINES ARGUMENTS.
011512         04  ARG-R2          OCCURS 11 TIMES.
011514             06  FILLER      PIC X(18).
011616             06  B-ARG       PIC S9(18) COMP.
011520     02  ARGUMENTS1 REDEFINES ARGUMENTS.
011540         04  EXIT-FNAME      PIC X(9).
011560         04  EXIT-FTYPE      PIC X.
011580         04  FILLER          PIC X(14).
011600         04  EXIT-PPN        PIC S9(10) COMP.
011620         04  FILLER          PIC X(300).
011640     02 INPCHR.
011660         04  BUFFER-CHAR     PIC X OCCURS 1000
011680                             INDEXED BY BUFX.
011700
011720 01  PRINT-LINE.
011740     02  PRINT-CHAR          PIC X OCCURS 220 TIMES
011760                             INDEXED BY PRX.
011780
011800 01  SUMMARY-LINE.
011820     02  SUMMARY-BREAK-TITLE1 PIC X(11).
011840     02  SUMMARY-BREAK-TITLE2 PIC X(11).
011860     02  SUMMARY-BREAK-VALUE  PIC X(19).
011880     02  FILLER               PIC X VALUE SPACE.
011900     02  SUMMARY-TITLE.
011920         04  SUMMARY-TITLE1  PIC X(11).
011940         04  SUMMARY-TITLE2  PIC X(11).
011960
011980 01  SUMMARY-VERB            PIC X(7).
012000 01  SUMMARY-VALUE           PIC X(19).
012020
012040 01  PROMPT-LINE.
012060     02  PROMPT-LINE-SHORT.
012080         04  BASIC-LINE-ASTERISK PIC X.
012100         04  BASIC-LINE-TITLE1   PIC X(11).
012120         04  BASIC-LINE-TITLE2   PIC X(11).
012140         04  BASIC-LINE-NCHAR    PIC ZZZZ9.
012160         04  BASIC-LINE-POINT    PIC X.
012180         04  BASIC-LINE-DECIMALS PIC 9.
012200         04  BASIC-LINE-TYPEV    PIC XX.
012220         04  BASIC-LINE-COLON    PIC XX.
012240     02  FILLER              PIC X(170).
012260 01  WORK-LINE REDEFINES PROMPT-LINE.
012280     02  PROMPT-CHAR         PIC X OCCURS 204 TIMES
012300                             INDEXED BY PRX.
012320
012340 01  SPACE-LINE              PIC X(204) VALUE SPACES.
012360
012362*    *BELOW GIVES ASCII NULL CAPABILITY FOR TERMINAL LINES*
012364 01  TERM-LINE USAGE IS DISPLAY-7.
012366     02  TERM-CHAR           PIC X OCCURS 205 INDEXED BY NX.
012367     
012368 01  SIXBIT-TERM-LINE REDEFINES TERM-LINE DISPLAY-6.
012370     02  SIXBIT-TERM-CHAR    PIC X OCCURS 246.
012372
012374 01  SIXBIT-SPACES           PIC X(6) VALUE SPACES DISPLAY-6.
012376 01  FILLER REDEFINES SIXBIT-SPACES DISPLAY-7.
012378     02  ASCII-NULL          PIC X.
012380     02  FILLER              PIC X(4).
012382
012380**WORKING REGISTERS FOR NUMBER CONVERSION FOLLOW**
012400*    *NOTE: DO NOT REARRANGE FROM HERE TO BHOLDER. IN
012420*    ADDITION TO THEIR PRIMARY FUNCTIONS, ALT-AHOLDER,
012440*    ANSWER CATCH OVERFLOW FROM AHOLDER
012460*    IN THE CASE OF VERY LONG LITERAL OR ALPHA ITEMS*.
012480
012500 01  AHOLDER.
012520   02  AHOLDER-30.
012540     03  AHOLDER-25.
012560       04  AHOLDER-20.
012580         05  AHOLDER-15.
012600           06  AHOLDER-10.
012620             07  AHOLDER-9.
012640               08  AHOLDER-8.
012660                 09  AHOLDER-7.
012680                   10  AHOLDER-6.
012700                     11  AHOLDER-5.
012720                       12  AHOLDER-4.
012740                         13  AHOLDER-3.
012760                           14  AHOLDER-2.
012780                             15  AHOLDER-1 PIC X.
012800                             15  FILLER PIC X.
012820                           14  FILLER PIC X.
012840                         13  FILLER PIC X.
012860                       12  FILLER PIC X.
012880                     11  FILLER PIC X.
012900                   10  FILLER PIC X.
012920                 09  FILLER  PIC X.
012940               08  FILLER    PIC X.
012960             07  FILLER      PIC X.
012980           06  FILLER        PIC X(5).
013000         05  FILLER          PIC X(5).
013020       04  FILLER            PIC X(5).
013040     03  FILLER              PIC X(5).
013060   02  FILLER                PIC X(24).
013080 01  FILLER REDEFINES AHOLDER.
013100     02  AHOLDER-CHAR        PIC X OCCURS 54 TIMES
013120                             INDEXED BY AHLX.
013140 01  FILLER REDEFINES AHOLDER.
013160     02  NHOLDER-PREFIX      PIC X(36).
013180     02  NHOLDER             PIC S9(18).
013200     02  ANHOLDER            REDEFINES NHOLDER.
013220         04  NHOLDER-CHAR    PIC X OCCURS 18
013240                                 INDEXED BY NHLX.
013260     02  UNPK1 REDEFINES NHOLDER.
013280         04  FILLER          PIC X(17).
013300         04  NHOLDER1        PIC S9.
013320     02  UNPK8 REDEFINES NHOLDER.
013340         04  FILLER          PIC X(10).
013360         04  NHOLDER8        PIC S9(8).
013380     02  UNPK10 REDEFINES NHOLDER.
013400         04  FILLER          PIC X(8).
013420         04  NHOLDER10       PIC S9(10).
013440     02  UNPK18 REDEFINES NHOLDER.
013460         04  NHOLDER18       PIC S9(18).
013480
013484 01  AHOLDER-EXTENSION1.
023500     02  NHOLDER-EXTENSION   PIC S9(18) VALUE 0.
023520     02  NHOLDER-EXTENSION1  PIC S9(18) VALUE 0.
013540
013544 01  AHOLDER-EXTENSION2     PIC X(84).
013560 01  ANSWER REDEFINES AHOLDER-EXTENSION2.
013580   02  ANSWER-30.
013600     03  ANSWER-25.
013620       04  ANSWER-20.
013640         05  ANSWER-15.
013660           06  ANSWER-10.
013680             07  ANSWER-9.
013700               08  ANSWER-8.
013720                 09  ANSWER-7.
013740                   10  ANSWER-6.
013760                     11  ANSWER-5.
013780                       12  ANSWER-4.
013800                         13  ANSWER-3.
013820                           14  ANSWER-2.
013840                             15  ANSWER-1 PIC X.
013860                             15  FILLER PIC X.
013880                           14  FILLER PIC X.
013900                         13  FILLER PIC X.
013920                       12  FILLER PIC X.
013940                     11  FILLER PIC X.
013960                   10  FILLER PIC X.
013980                 09  FILLER  PIC X.
014000               08  FILLER    PIC X.
014020             07  FILLER      PIC X.
014040           06  FILLER        PIC X(5).
014060         05  FILLER          PIC X(5).
014080       04  FILLER            PIC X(5).
014100     03  FILLER              PIC X(5).
014120   02  FILLER                PIC X(54).
014140 01  FILLER REDEFINES ANSWER.
014160     02  ANS-CHAR            PIC X OCCURS 84 TIMES
014180                             INDEXED BY ANX.
014184
014185*    *FILLER BELOW GIVES SPACE FOR OVERFLOW OF LONG ALPHAS.
014188 01  AHOLDER-EXTENSION3      PICTURE X(300).
014200
014220 01  ALT-AHOLDER             PIC X(54).
014240 01  FILLER REDEFINES ALT-AHOLDER.
014260     02  ALT-AHOLDER-30      PIC X(30).
014280     02  FILLER              PIC X(6).
014300     02  ALT-NHOLDER         PIC S9(18).
014320     02  ALT-UNPK1 REDEFINES ALT-NHOLDER.
014340         04  FILLER          PIC X(17).
014360         04  ALT-NHOLDER1    PIC S9.
014380         04  ALT-ANHOLDER1  REDEFINES ALT-NHOLDER1 PIC X.
014400     02  ALT-UNPK8 REDEFINES ALT-UNPK1.
014420         04  FILLER          PIC X(10).
014440         04  ALT-NHOLDER8    PIC S9(8).
014460     02  ALT-UNPK10 REDEFINES ALT-UNPK8.
014480         04  FILLER          PIC X(8).
014500         04  ALT-NHOLDER10   PIC S9(10).
014520     02  ALT-UNPK18 REDEFINES ALT-UNPK10.
014540         04  ALT-NHOLDER18   PIC S9(18).
014560
014580 01  ALT-NHOLDER-EXTENSION   PIC S9(18) VALUE 0.
014600
014601*    *FILLER BELOW GIVES SPACES FOR OVERFLOW OF LONG ALPHAS.
014604 01  FILLER                  PICTURE X(300).
014608
014620 01  BHOLDER-ALPHA PIC X(12).
014640 01  BHOLDER REDEFINES BHOLDER-ALPHA
014660                       PIC S9(18) COMP.
014680 01  FILLER REDEFINES BHOLDER-ALPHA.
014700     02  BHOLDER-LEFT        PIC S9(10) COMP.
014720     02  BCOMP6              PIC S9(10) COMP.
014740     02  BCOMP6A REDEFINES BCOMP6 PIC X(6).
014760 01  BHOLDER1 REDEFINES BHOLDER-ALPHA.
014780     02  BCOMP12             PIC S9(18) COMP.
014800     02  BCOMP12A REDEFINES BCOMP12 PIC X(12).
014820
014840 01  ALT-BHOLDERA            PIC X(12).
014860 01  ALT-BHOLDER            REDEFINES ALT-BHOLDERA
014880                             PIC S9(18) COMP.
014900 01  FILLER                 REDEFINES ALT-BHOLDER.
014920     02  ALT-BHOLDER-LEFT    PIC S9(10) COMP.
014940     02  ALT-BCOMP6          PIC S9(10) COMP.
014960     02  ALT-BCOMP6A REDEFINES ALT-BCOMP6 PIC X(6).
014980 01  FILLER REDEFINES ALT-BHOLDER.
015000     02  ALT-BCOMP12         PIC S9(18) COMP.
015020     02  ALT-BCOMP12A REDEFINES ALT-BCOMP12 PIC X(12).
015040     02  ACCUM REDEFINES ALT-BCOMP12A
015060                             PIC S9(18) COMP.
015080
015100*    *TEMP STACK FOR COMPUTATIONS (AND OTHER THINGS):
015120 01  TEMP-REGISTERS OCCURS 10 TIMES INDEXED BY TX.
015140     02  TEMP                PIC S9(18) COMP.
015160     02  TSCALE              PIC S9(10) COMP.
015180
015200
015220 01  DYN-FILE-CHAR-SET.
015240     02  FILLER              PIC X VALUE '1'.
015260     02  FILLER              PIC X VALUE '2'.
015280     02  FILLER              PIC X VALUE '3'.
015300     02  FILLER              PIC X VALUE '4'.
015320     02  FILLER              PIC X VALUE '5'.
015340     02  FILLER              PIC X VALUE '6'.
015360     02  FILLER              PIC X VALUE '7'.
015380     02  FILLER              PIC X VALUE '8'.
015400     02  FILLER              PIC X VALUE '9'.
015420     02  FILLER              PIC X VALUE 'A'.
015440     02  FILLER              PIC X VALUE 'B'.
015460     02  FILLER              PIC X VALUE 'C'.
015480     02  FILLER              PIC X VALUE 'D'.
015500     02  FILLER              PIC X VALUE 'E'.
015520     02  FILLER              PIC X VALUE 'F'.
015540     02  FILLER              PIC X VALUE 'G'.
015560     02  FILLER              PIC X VALUE 'H'.
015580     02  FILLER              PIC X VALUE 'I'.
015600     02  FILLER              PIC X VALUE 'J'.
015620     02  FILLER              PIC X VALUE 'K'.
015640     02  FILLER              PIC X VALUE 'L'.
015660     02  FILLER              PIC X VALUE 'M'.
015680     02  FILLER              PIC X VALUE 'N'.
015700     02  FILLER              PIC X VALUE 'O'.
015720     02  FILLER              PIC X VALUE 'P'.
015740     02  FILLER              PIC X VALUE 'Q'.
015760     02  FILLER              PIC X VALUE 'R'.
015780     02  FILLER              PIC X VALUE 'S'.
015800     02  FILLER              PIC X VALUE 'T'.
015820     02  FILLER              PIC X VALUE 'U'.
015840     02  FILLER              PIC X VALUE 'V'.
015860     02  FILLER              PIC X VALUE 'W'.
015880     02  FILLER              PIC X VALUE 'X'.
015900     02  FILLER              PIC X VALUE 'Y'.
015920     02  FILLER              PIC X VALUE 'Z'.
015940
015960 01  DYN-FILE-CHAR-SET1 REDEFINES DYN-FILE-CHAR-SET.
015980     02  DYN-FILE-CHAR       PIC X OCCURS 35 TIMES
016000                                     INDEXED BY DDX.
016020
016040
016060 01  POWERS-OF-TEN.
016080     02  10E1                PIC S9(12) COMP VALUE 10.
016100     02  10E2                PIC S9(12) COMP VALUE 100.
016120     02  10E3                PIC S9(12) COMP VALUE 1000.
016140     02  10E4                PIC S9(12) COMP VALUE 10000.
016160     02  10E5                PIC S9(12) COMP VALUE 100000.
016180     02  10E6                PIC S9(12) COMP VALUE 1000000.
016200     02  10E7                PIC S9(12) COMP VALUE 10000000.
016220     02  10E8                PIC S9(12) COMP VALUE 100000000.
016240     02  10E9                PIC S9(12) COMP VALUE 1000000000.
016260     02  10E10    PIC S9(12) COMP VALUE 10000000000.
016280     02  10E11    PIC S9(12) COMP VALUE 100000000000.
016300     02  10E12    PIC S9(13) COMP VALUE 1000000000000.
016320     02  10E13    PIC S9(14) COMP VALUE 10000000000000.
016340     02  10E14    PIC S9(15) COMP VALUE 100000000000000.
016360     02  10E15    PIC S9(16) COMP VALUE 1000000000000000.
016380     02  10E16    PIC S9(17) COMP VALUE 10000000000000000.
016400     02  10E17    PIC S9(18) COMP VALUE 100000000000000000.
016420     02  10E18    PIC S9(18) COMP VALUE 100000000000000000.
016440 01  FILLER REDEFINES POWERS-OF-TEN.
016460     02  10EX                PIC S9(13) COMP OCCURS 18 TIMES
016480                     INDEXED BY PTX.
016500
016520 01  ROUNDING-FACTORS.
016540     02  5E0                 PIC S9(12) COMP VALUE 5.
016560     02  5E1                 PIC S9(12) COMP VALUE 50.
016580     02  5E2                 PIC S9(12) COMP VALUE 500.
016600     02  5E3                 PIC S9(12) COMP VALUE 5000.
016620     02  5E4                 PIC S9(12) COMP VALUE 50000.
016640     02  5E5                 PIC S9(12) COMP VALUE 500000.
016660     02  5E6                 PIC S9(12) COMP VALUE 5000000.
016680     02  5E7                 PIC S9(12) COMP VALUE 50000000.
016700     02  5E8                 PIC S9(12) COMP VALUE 500000000.
016720     02  5E9                 PIC S9(12) COMP VALUE 5000000000.
016740     02  5E10        PIC S9(12) COMP VALUE 50000000000.
016760     02  5E11        PIC S9(12) COMP VALUE 500000000000.
016780     02  5E12        PIC S9(13) COMP VALUE 5000000000000.
016800 01  FILLER REDEFINES ROUNDING-FACTORS.
016820     02  5EX                 PIC S9(13) COMP OCCURS 13
016840                             INDEXED BY RNDX.
016860
016880***ELEMENTARY TABLES (FOR SPEED) FOLLOW*******************
016900
016920*    *TABLE OF ELEMENTARY REPORT PARAMETERS FOLLOWS*.
016940
016960 01  ELEM-R-ENTRY.
016980     02  ELEM-RPT-TYPE       PIC S9(10) COMP VALUE 19.
017000     02  ELEM-RPT-PARAMS.
017020         04  ELEM-RPT-NO     PIC S9(10) COMP VALUE 1.
017040         04  ELEM-PAGE-NO    PIC S9(10) COMP VALUE 0.
017060         04  ELEM-LINE-NO    PIC S9(10) COMP VALUE 0.
017080         04  ELEM-ACROSS-NO  PIC S9(10) COMP VALUE 1.
017100         04  ELEM-RPTDATE    PIC S9(10) COMP VALUE -1.
017120         04  ELEM-LAST-PRINTX PIC S9(10) COMP VALUE 0.
017140         04  ELEM-PRINTPOS    PIC S9(10) COMP VALUE 1.
017160     02  ELEM-LAST-PRINTYPE  PIC S9(10) COMP VALUE 0.
017180         88  NO-LINE         VALUE 0.
017200         88  DETAIL-LINE     VALUE 1.
017220         88  SUMMATION-LINE  VALUE 2.
017240         88  PAGE-HEADING    VALUE 3.
017260     02  ELEM-RPTHEADX       PIC S9(10) COMP VALUE 3.
017280
017300 01  ELEM-F-ENTRY.
017320     02  ELEM-F-TYPE         PICTURE S9(10) COMP VALUE 7.
017340     02  ELEM-F-RECLEN       PICTURE S9(10) COMP VALUE 80.
017360     02  ELEM-F-BLKLEN       PICTURE S9(10) COMP VALUE 0.
017380     02  ELEM-F-ORIGIN       PICTURE S9(10) COMP VALUE 1.
017400     02  RD1.
017420         03  ELEM-F-KEYLOC       PICTURE S9(10) COMP .
017440         03  ELEM-F-KEYLEN       PICTURE S9(10) COMP  .
017460         03  ELEM-F-KEYTYPE      PICTURE S9(10) COMP  .
017480         03  ELEM-F-KEYSIGN      PICTURE S9(10) COMP  .
017500         03  ELEM-F-PPN          PICTURE S9(10) COMP  .
017520     02  ELEM-F-SUBSCHEMA REDEFINES RD1 PIC X(30).
017540     02  RD2.
017560         03  ELEM-F-ID           PICTURE X(9) VALUE 'ISAMF6IDX'.
017580         03  ELEM-F-DEVICE       PICTURE X(6).
017600         03  FILLER              PICTURE X(14).
017604         03  ELEM-F-OPEN         PIC X.
017620     02  ELEM-F-SCHEMA REDEFINES RD2 PICTURE X(30).
017640     02  DBMS-PASSWORD	PICTURE X(6) VALUE SPACE.
017660 01  ELEM-B-ENTRY REDEFINES ELEM-F-ENTRY.
017680     02  ELEM-B-TYPEV		PICTURE S9(10) COMP.
017700     02  ELEM-B-NCHAR		PICTURE S9(10) COMP.
017720     02  ELEM-B-SCALE		PICTURE S9(10) COMP.
017740     02  ELEM-B-FILLER-1		PICTURE X(12).
017760     02  ELEM-B-FCHAR		PICTURE S9(10) COMP.
017780     02  ELEM-B-FILLER-2		PICTURE X(6).
017800     02  ELEM-B-NAME		PICTURE X(30).
017820     02  ELEM-B-AREA-SET		PIC S9(10) COMP.
017840     02  ELEM-B-RECNO		PICTURE S9(10) COMP.
017860     02  ELEM-B-FILLER-3		PICTURE X(6).
017880
017900
017920
017940 01  ELEM-D-ENTRY REDEFINES ELEM-B-ENTRY.
017960     02  ELEM-D-TYPEV        PIC S9(10) COMP.
017980     02  ELEM-D-NCHAR        PIC S9(10) COMP.
018000     02  ELEM-D-SCALE        PIC S9(10) COMP.
018020     02  ELEM-D-ECHAR        PIC S9(10) COMP.
018040     02  ELEM-D-TCHAR        PIC S9(10) COMP.
018060     02  ELEM-D-FCHAR        PIC S9(10) COMP.
018080     02  ELEM-D-NREPEATS     PIC S9(10) COMP.
018100     02  ELEM-D-GRPLEN       PIC S9(10) COMP.
018120     02  ELEM-D-TITLE1.
018140         04  EDT1            PIC X OCCURS 10.
018160     02  ELEM-D-TITLE2.
018180         04  EDT2            PIC X OCCURS 10.
018200     02  ELEM-D-PICT.
018220         04  ELEM-D-PICT-T   PIC X.
018240         04  FILLER          PIC X(19).
018260     02  ELEM-D-GRPNAME      PIC X.
018280     02  ELEM-D-STOPV        PIC X.
018300
018320 01  ELEM-V-ENTRY REDEFINES ELEM-D-ENTRY.
018340     02  ELEM-V-TYPEV        PIC S9(10) COMP.
018360     02  ELEM-V-NCHAR        PIC S9(10) COMP.
018380     02  ELEM-V-SCALE        PIC S9(10) COMP.
018400     02  ELEM-V-ECHAR        PIC S9(10) COMP.
018420     02  ELEM-V-TCHAR        PIC S9(10) COMP.
018440     02  ELEM-V-BINARY       PIC S9(18) COMP.
018460     02  ELEM-V-WORK         PIC S9(10) COMP.
018480     02  ELEM-V-TITLE1       PIC X(10).
018500     02  ELEM-V-TITLE2       PIC X(10).
018520     02  ELEM-V-PICTURET         PIC X(20).
018540     02  FILLER              PIC XX.
018560
018580 01  ELEM-C-ENTRY REDEFINES ELEM-V-ENTRY.
018600     02  ELEM-C-TYPEV        PIC S9(10) COMP.
018620     02  ELEM-C-NCHAR        PIC S9(10) COMP.
018640     02  ELEM-C-SCALE        PIC S9(10) COMP.
018660     02  FILLER              PIC X(12).
018680     02  ELEM-C-BINARY       PIC S9(18) COMP.
018700     02  ELEM-C-NUMERIC      PIC S9(18).
018720     02  FILLER              PIC X(30).
018740
018760 01  ELEM-L-ENTRY REDEFINES ELEM-C-ENTRY.
018780     02  ELEM-L-TYPEV        PIC S9(10) COMP.
018800     02  ELEM-L-NCHAR        PIC S9(10) COMP.
018820     02  ELEM-L-VALUE        PIC X(78).
018840
018860 01  ELEM-K-ENTRY REDEFINES ELEM-L-ENTRY.
018880     02  ELEM-K-TYPEV        PIC S9(10) COMP.
018900     02  ELEM-K-NCHAR        PIC S9(10) COMP.
018920     02  ELEM-K-STARTKEY     PIC X(30).
018940     02  ELEM-K-ENDKEY       PIC X(30).
018960     02  FILLER              PIC X(18).
018980
019000
019020*****TABLES PASSED FROM ANALYSIS MODULE FOLLOW************
019040
019060 01  CONTROL-TABLE.
019080*    *VALUES BELOW ARE DEFAULTS WHICH SHOULD BE PASSED IF
019100*     THE QUERY DOES NOT AFFECT THAT QUANTITY*.
019120*    *1ST ENTRY WILL STOP RUN IF EVER GET THERE*.
019140*    *2ND & 3RD ENTRIES ARE DEFAULT RPTHEAD DX LIST.
019160     02  CONST1              PIC S9(10) COMP VALUE 1.
019180     02  FILLER              PIC S9(10) COMP VALUE 1.
019200     02  CONST0              PIC S9(10) COMP VALUE 0.
019220     02  DYN-JOBNO           PIC S9(10) COMP VALUE 1.
019240     02  EXEC-STARTX         PIC S9(10) COMP VALUE 1.
019260     02  EOF1-X              PIC S9(10) COMP VALUE 1.
019280     02  ACROSS-CONTROL      PIC S9(10) COMP VALUE 1.
019300     02  DISPLAY-FLAG        PIC S9(10) COMP VALUE 1.
019320     02  HEADING-FLAG        PIC S9(10) COMP VALUE 1.
019340     02  PAGING-FLAG         PIC S9(10) COMP VALUE 1.
019360     02  PRINT-FLAG          PIC S9(10) COMP VALUE 1.
019380     02  SUMPRINT-FLAG       PIC S9(10) COMP VALUE 1.
019400     02  TITLE-FLAG          PIC S9(10) COMP VALUE 1.
019420     02  FORM-LINES          PIC S9(10) COMP VALUE 66.
019440     02  PAGE-LINES          PIC S9(10) COMP VALUE 57.
019460     02  REPORT-DX           PIC S9(10) COMP VALUE 0.
019480     02  NUMB-REPORTS        PIC S9(10) COMP VALUE 1.
019500     02  HSPACE              PIC S9(10) COMP VALUE 3.
019520     02  VSPACE              PIC S9(10) COMP VALUE 1.
019540     02  LMARGIN             PIC S9(10) COMP VALUE 1.
019560     02  RMARGIN             PIC S9(10) COMP VALUE 72.
019580  02  DBMS-STSBLK.
019600         04  DBMS-SIXBIT     PIC X.
019620         04  DBMS-ASCII      PIC X.
019640         04  DBMS-BINARY     PIC X.
019660         04  DBMS-EBC        PIC X.
019680         04  DBMS-CM3        PIC X.
019700         04  DBMS-CM1        PIC X.
019720     02  FILLER              PIC S9(10) COMP OCCURS 2978.
019740
019760 01  INSTR-TABLE REDEFINES CONTROL-TABLE.
019780     02  INSTR               PIC S9(10) COMP
019800                             OCCURS 3000 INDEXED BY X.
019820
019840 01  FILE-TABLE REDEFINES INSTR-TABLE.
019860     02  F-ENTRY OCCURS 200 INDEXED BY FX.
019880         04  F-TYPE          PIC S9(10) COMP.
019900         04  F-RECLEN        PIC S9(10) COMP.
019920         04  F-BLKLEN        PIC S9(10) COMP.
019940         04  F-ORIGIN        PIC S9(10) COMP.
019960         04  F-KEYLOC        PIC S9(10) COMP.
019980         04  F-KEYLEN        PIC S9(10) COMP.
020000         04  F-KEYTYPE       PIC S9(10) COMP.
020020         04  F-KEYSIGN       PIC S9(10) COMP.
020040         04  F-PPN           PIC S9(10) COMP.
020060         04  F-ID            PIC X(9).
020080         04  F-DEVICE        PIC X(6).
020100         04  FILLER          PIC X(15).
020120         04  F-MARKER        PIC X(6).
020140
020160 01  DICTIONARY-TABLE REDEFINES FILE-TABLE.
020180     02  D-ENTRY OCCURS 200 INDEXED BY DX.
020200         04  D-TYPEV         PIC S9(10) COMP.
020220         04  D-NCHAR         PIC S9(10) COMP.
020240         04  D-SCALE         PIC S9(10) COMP.
020260         04  D-ECHAR         PIC S9(10) COMP.
020280         04  D-TCHAR         PIC S9(10) COMP.
020300         04  D-FCHAR         PIC S9(10) COMP.
020320         04  D-NREPEATS      PIC S9(10) COMP.
020340         04  D-GRPLEN        PIC S9(10) COMP.
020360         04  D-TITLE1        PIC X(10).
020380         04  D-TITLE2        PIC X(10).
020400         04  D-PICTURET          PIC X(20).
020420         04  D-GRPNAME       PIC X.
020440         04  D-STOPV         PIC X.
020450* 01  INTERRUPT-FLAG  INDEX.
020051* 01  INTERRUPT-ERROR  INDEX.
020460
020480*$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
020500*$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
020520
020540**********************************************************
020560* THIS SECTION READS IN THE ANALYSIS TABLE FILE AND
020580* INITIALIZES AS NECESSARY.
020600**********************************************************
020620
020640 PROCEDURE DIVISION.
020642
020644 DECLARATIVES.
020646 
020648 ISAM-FILE-ERROR SECTION. USE AFTER STANDARD ERROR PROCEDURE
020652     ON INF1SD6 INF1SD7 INF2SD6 INF2SD7 INF3SD6 INF3SD7.
020654 ISAM-FILE-ERROR-SCREEN.
020655*    *THIS IS JUST HERE TO CUTOFF COBOL'S SCREAMING ABOUT MISSING
020656*    * ISAM FILES UNTIL WE CAN TELL IT WHAT FILES WE REALLY WANT*
020657     MOVE 0 TO ISAM-ERROR-FLAG.
020658     IF NOT ( ERROR-VERB = 1 AND
020660         ( ERROR-CALL = 3 OR ERROR-CALL = 7 )) GO TO ISAM-IS-OK.
020662     MOVE 1 TO ISAM-ERROR-FLAG.
020664 ISAM-IS-OK.
020666     EXIT.
020668
020670 END DECLARATIVES.
020672
020674 MAIN SECTION.
020676*    *'ENTER MACRO IQGETI' IS EQUIVALENT TO
020680*    *  'MOVE INSTR (X) TO ELEM-INSTR'
020700
020720*    *'ENTER MACRO IQGETD' IS EQUIVALENT TO
020740*    *  'MOVE D-ENTRY (DX) TO ELEM-D-ENTRY'
020760
020780*    *'ENTER MACRO IQPUTI' IS EQUIVALENT TO
020800*    *  'MOVE ELEM-INSTR TO INSTR (X)'
020820
020840*    *'ENTER MACRO IQPUTD' IS EQUIVALENT TO
020860*    *  'MOVE ELEM-D-ENTRY TO D-ENTRY (DX)'
020880
020900*    *ALL OF THE ABOVE REQUIRE THAT 'ENTER MACRO IQSETX'
020920*    *  BE RUN INITIALLY TO INITIALIZE THEM.
020940
020960*    * 'ENTER MACRO IQPICT' IS EQUIVALENT TO
020980*    *  'PERFORM EDITOR THRU EDITOR-EXIT'
021000*    *  (IQPICT REQUIRES A CALL TO IQEBND TO
021020*    *  INITIALIZE IT).
021040
021060 BEGIN-EXEC.
021065*     SET INTERRUPT-FLAG TO 0.
021070*     CALL SETINT USING 5,INTERRUPT-FLAG,INTERRUPT-ERROR.
021072*     IF INTERRUPT-ERROR NOT = 0 
021074*         DISPLAY '? ERROR IN SETINT' STOP RUN.
021080     ENTER MACRO CLRTTY.
021100
021120*    *SET UP FOR FAST INSTRUCT AND DICT ENTRY RETRIEVAL*.
021140     ENTER MACRO IQSETX USING INSTR-TABLE X
021160         DICTIONARY-TABLE DX ELEM-INSTR ELEM-D-ENTRY.
021180     ENTER MACRO IQEBND USING TRUE-TYPEV PICT-WORK AHOLDER
021200      ELEM-D-PICT
021220         ELEM-D-ECHAR ELEM-D-NCHAR ELEM-D-SCALE.
021240
021260*    *SET UP DYNAMIC FILE NAMES*.
021280     ENTER MACRO IQGJOB USING J.
021300     MOVE J TO QTSORTNO QTANLZNO QTEXECNO.
021320     MOVE QT001ATMP TO QTANLZTMP.
021340
021360*   *OPEN MULTIPLE REPORT FILE HERE, EVEN IF DUMMY*
021380     MOVE 0 TO QTEXEC-COUNT.
021400     OPEN OUTPUT QTEXEC.
021420
021440 OPEN-ANLZ.
021460*    *READ IN TABLES FROM ANALYSIS MODULE*
021480     OPEN INPUT QTANLZ.
021500     SET DX TO 1.
021520
021540     READ QTANLZ AT END GO TO READ-ANLZ-ERR.
021560*    * IF A PRE-ANALYZED QUERY FILE, TEMP FILE WILL BE ONE
021580*    * RECORD CONTAINING NAME OF PRE-ANALYZED QUERY; PLANT IT
021600*    * AND EXECUTE FROM THE *REAL* CONTROL FILE.
021620     IF QTANLZ-SUFFIX = 'INQ' MOVE QTANLZ-NAME TO QTANLZTMP
021640         CLOSE QTANLZ GO TO OPEN-ANLZ.
021660     GO TO READ-ANLZ1.
021680
021700 READ-ANLZ.
021720     READ QTANLZ AT END GO TO READ-ANLZ-ERR.
021740
021760 READ-ANLZ1.
021780     IF QTANLZ-SWITCH = ALL SPACES SET K TO DX
021800         SET DX TO MAX-DX GO TO READ-ANLZ2.
021820     MOVE QTANLZ-REC TO D-ENTRY (DX).
021840     SET DX UP BY 1.
021860     IF DX GREATER THAN MAX-DX GO TO READ-ANLZ-ERR.
021880     GO TO READ-ANLZ.
021900
021920 READ-ANLZ2.
021940     READ QTANLZ AT END SET DX-LOWEST TO DX
021950                        GO TO READ-ANLZ-DONE.
021960     MOVE QTANLZ-REC TO D-ENTRY (DX).
021980     IF DX LESS THAN K GO TO READ-ANLZ-ERR.
022000     SET DX DOWN BY 1.
022020     GO TO READ-ANLZ2.
022040
022060 READ-ANLZ-ERR.
022080     CLOSE QTANLZ.
022100     MOVE 01 TO ERROR-CODE.
022120     GO TO ABORT-RUN.
022140
022160 READ-ANLZ-DONE.
022180     CLOSE QTANLZ.
022200     MOVE QT001ATMP TO QTANLZTMP.
022220
022240*    *SET UP DOUBLE-DYNAMIC FILE NAMES (SO WILL NOT
022260*    *COLLIDE WHEN HAVE MULTIPLE SORT STAGES*    *.
022265     MOVE J TO DYN-JOBNO.
022280     MOVE DYN-JOBNO TO QLEXECNO.
022300     DIVIDE DYN-JOBNO BY 100 GIVING J.
022320 UNIQUE-PRINTFILE.
022340     IF J GREATER THAN 35
022360         DISPLAY '%Too many .LPT files on DSK:'
022364             UPON CONSOLE 
022368         DISPLAY '  Please delete the old ones and re run'
022372             UPON CONSOLE
022376         MOVE 0 TO SORTFILE-FLAG PRINTFILE-FLAG GO TO ENDER.
022380     IF J NOT = 0
022400         SET DDX TO J
022420         MOVE DYN-FILE-CHAR (DDX) TO QLEXEC-NODUP.
022440*    *MAKE SURE NOT WRITING OVER AN EXISTING PRINT FILE*
022460     ENTER MACRO IQLOOK USING DEVICER QLEXECLPT PROJ USER I.
022480     IF I = -1 ADD 1 TO J GO TO UNIQUE-PRINTFILE.
022500     OPEN OUTPUT QLEXEC.
022520     MOVE 1 TO PRINTFILE-FLAG.
022540
022560*    *INITIALIZE TERMINAL POSITION*.
022580     DISPLAY ' ' UPON CONSOLE.
022600*
022620*    *INITIALIZE FILE STATUS FLAGS*.
022640     MOVE 0 TO INF1-FLAG INF2-FLAG INF3-FLAG
022650               INF1-FX   INF2-FX   INF3-FX
022660         COPYFILE-FLAG CREATEFILE-FLAG LASTTIME-X
022680         LINES-IN-PHASE CALL-IQM-FLAG.
022700
022720
022740     MOVE 1 TO ACROSS-CONTROL.
022760     MOVE 0 TO LASTTIME-X ENDING-FLAG.
022780
022800*    *SET UP INITIAL REPORT ENTRY*.
022820     IF REPORT-DX NOT = 0
022840         SET DX TO REPORT-DX
022860         ENTER MACRO IQGETD
022880         MOVE ELEM-D-ENTRY TO ELEM-R-ENTRY
022900         MOVE 0 TO ELEM-PAGE-NO  ELEM-LINE-NO
022920         ENTER MACRO IQPUTD.
022940
022960*    *SET UP REPORT DATE*.
022980     MOVE TODAY TO TODAYS-DATE.
023000*    *DATE COMES IN AS YYMMDD*.
023020*    *NOW SET UP FOR EXECUTION*.
023040     MOVE EOF1-X TO SORT-STARTX.
023060*    *ABOVE TAKES CARE OF SUMMARY WRAPUP WHEN NO SORT*
023080     SET X TO EXEC-STARTX.
023100     GO TO NEXT-INSTR.
023120
023140**********************************************************
023160*  SEQUENCE 'ABORT-RUN' TO ISSUE ERROR MESSAGE AND END
023180*  THE RUN ON AN ERROR.
023200**********************************************************
023220
023240 ABORT-RUN.
023260     PERFORM COMPLAINER THRU COMPLAINER-EXIT.
023280*    *KILL SORTING SO WILL END RUN RATHER THAN JUST STAGE*.
023290 ABORT-RUN1.
023300     MOVE 0 TO SORTFILE-FLAG.
023320     GO TO ENDER.
023340
023360 COMPLAINER.
023380     MOVE '?IQE ERROR CODE ' TO PROMPT-LINE.
023400     MOVE ERROR-CODE TO BASIC-LINE-NCHAR.
023420     IF DISPLAY-FLAG = 1 DISPLAY PROMPT-LINE-SHORT UPON CONSOLE.
023440     IF PRINT-FLAG = 1 WRITE QLEXEC-REC FROM PROMPT-LINE-SHORT
023460         AFTER ADVANCING 2 LINES ADD 1 TO LINES-IN-PHASE.
023480     ADD 2 TO ELEM-LINE-NO.
023500
023520
023540 COMPLAINER-EXIT.
023560     EXIT.
023580
023600 ILLEGAL-ALPHA.
023620     DISPLAY
023640     '%Illegal alpha in numeric field; changed to 0'
023660         UPON CONSOLE.
023680
023700*******************************************************
023720* MAJOR INSTRUCTION CYCLING LOGIC FOLLOWS.
023740*******************************************************
023760
023780 NEXT-INSTR-UPX.
023800*    *RETURN HERE WHEN KICKING X BEFORE NEXT INSTR.
023820     SET X UP BY 1.
023840
023860 NEXT-INSTR.
023862*    *CHECK FOR AN INTERRUPT REQUEST..IF SO, SIMULATE A "GO TO QT".
023864*     IF INTERRUPT-FLAG NOT = 0 
023866*         DISPLAY '[^E Panic interrupt detected]'
023867*         SET INTERRUPT-FLAG TO 0.
023868*         GO TO GO-TO-QT.
023880     ENTER MACRO IQGETI.
023900     SET X UP BY 1.
023920*
023940*    *CENTRAL TRANSFER VECTOR OF ENTIRE MODULE FOLLOWS*.
023960     GO TO ENDER        OPENER       INSTR-ERR    INSTR-ERR
023980           READSEQ      READRAN      READDBMS     COPIER
024000           CREATER      READSUBBEG   READSUB      SORTER
024020           INSTR-ERR    ACCEPT2      DISPLAYER    PRINTIT
024040           INSTR-ERR    HSPACER      VSPACER      LMARGINER
024060           RMARGINER    ACROSSER     REPORTER     RPTHEADER
024080           NEWPAGE      PAGING-ON    PAGING-OFF   HEADING-ON
024100           HEADING-OFF  TITLES-ON    TITLES-OFF   SUMPRINT-ON
024120           SUMPRINT-OFF DISPLAY-ON   DISPLAY-OFF  PRINT-ON
024140           PRINT-OFF    RPTDATE-ON   RPTDATE-OFF  HOLDER
024160           RESETTER     SETTER       COMPUTE-IT   PAGELINE-SET
024180           FORMLINE-SET PAGE-SET     TALLIER      TOTALER
024200           AVERAGER     GO-TO-QT     GO-TO-XT     GO-TO-NR
024220           GO-TO-NN     EXITER       IF-BOF1      IF-EOF1
024240           IFNEWPAGE    IFNEWGRP     INSTR-ERR    INSTR-ERR
024260           IF-ER        IF-FIRST     IF-LAST      IF-ANY
024280           IF-NEXT      INSTR-ERR    IFERRCOUNT    IFERRSTATUS
024300           INSTR-ERR    RPTDATE-SET  IF-EOF2      IF-EOF3
024320           INSTR-ERR    IF-BOF2      IF-BOF3      INSTR-ERR
024340           INSTR-ERR    PICTURER     TITLE-IT     MAXIMIZER
024360           MINIMIZER    INSTR-ERR    INSTR-ERR    INSTR-ERR
024362           INSTR-ERR    INSTR-ERR    REWRITE-IT
024380           DEPENDING ON ELEM-INSTR.
024400
024420**********************************************************
024440*  NO-OP INSTRUCTION
024460*    FORMAT:
024480*      (X)    = INSTRUCTION  VALUE 0.
024500* NOTE: THIS FALLS THROUGH FROM ABOVE FOR ALL
024520*       VALUES NOT 1-81.  MUST FILTER OUT TRUE NO-OP (VALUE 0)
024540*       FROM ERRORS AND ROUTE CONTROL ACCORDINGLY.
024560**********************************************************
024580
024600 NO-OP.
024620     IF ELEM-INSTR = 0 GO TO NEXT-INSTR.
024640
024660 INSTR-ERR.
024680*    *IF HERE, HAVE INVALID INSTRUCTION; ABORT RUN.
024700     MOVE 03 TO ERROR-CODE.
024720     GO TO ABORT-RUN.
024740
024760**********************************************************
024780
024800*  END RUN INSTRUCTION.
024820*    FORMAT:     (X) = INSTRUCTION  VALUE 1.
024840*   -NOTE-  DOES NOT FALL THROUGH TO NEXT X.
024860**********************************************************
024880
024900 ENDER.
024920*    *CHECK TO SEE IF ANY LAST TIME PROCESSING TO DO*.
024940     IF LASTTIME-X NOT = 0 SET X TO LASTTIME-X
024960         MOVE 0 TO LASTTIME-X GO TO NEXT-INSTR.
024980
025000*    *PUMP OUT ANY PENDING SUMMARY QUANTITIES*.
025020     IF SUMPRINT-FLAG NOT = 1 GO TO ENDER3.
025040     SET X TO EXEC-STARTX.
025044     SET X DOWN BY 1.
025060     MOVE 1 TO ENDING-FLAG.
025080
025100 ENDER1.
025120*    *CUT OFF SEARCH FOR SUMMARIES AT END OF STAGE*
025140     IF X NOT LESS THAN SORT-STARTX GO TO ENDER3.
025160     ENTER MACRO IQGETI.
025180*    *LOOK FOR INSTR (X) OF 0 FOLLOWED BY A
025200*    * SUMMARY VERB*.
025220     IF ELEM-INSTR NOT = 0 SET X UP BY 1 GO TO ENDER1.
025240
025260 ENDER1A.
025280     SET X UP BY 1.
025300     ENTER MACRO IQGETI.
025320*    *FIRST LOOK TO SEE IF CHANGING REPORT NUMBER*
025322     IF ELEM-INSTR = 0 GO TO ENDER1A.
025340     IF ELEM-INSTR = REPORT-CODE
025360         SET X UP BY 1
025380         ENTER MACRO IQGETI
025400         IF ELEM-INSTR NOT = 0 SET DX TO ELEM-INSTR
025420             ENTER MACRO IQGETD
025440             MOVE ELEM-D-ENTRY TO ELEM-R-ENTRY
025460             GO TO ENDER1
025480         ELSE GO TO ENDER1.
025500*    *NO - NOW SEE IF HAVE A SUMMARY VERB*
025520     IF ELEM-INSTR = TALLY-CODE
025540         MOVE 1 TO SUMMARY-ROUTER GO TO ENDER2.
025560     IF ELEM-INSTR = TOTAL-CODE
025580         MOVE 2 TO SUMMARY-ROUTER GO TO ENDER2.
025600     IF ELEM-INSTR = AVERAGE-CODE
025620         MOVE 3 TO SUMMARY-ROUTER GO TO ENDER2.
025640     IF ELEM-INSTR = MAXIMUM-CODE
025660         MOVE 4 TO SUMMARY-ROUTER GO TO ENDER2.
025680     IF ELEM-INSTR = MINIMUM-CODE
025700         MOVE 5 TO SUMMARY-ROUTER GO TO ENDER2.
025720     SET X UP BY 1.  GO TO ENDER1.
025740
025760 ENDER2.
025780*    *HERE IF HAVE A SUMMARY TO WRAP UP*
025800     SET X UP BY 1.
025820     ENTER MACRO IQGETI.
025840     MOVE ELEM-INSTR TO SUMK.
025850     IF ELEM-INSTR < 0 SUBTRACT ELEM-INSTR FROM 0 GIVING SUMK.
025860
025880 ENDER2A.
025900     SET HOLDX TO X.
025920     SET X UP BY 1.
025940*    *GO TO SUMMARIZING WRAPUP LOGIC; IT WILL RETURN
025960*    *  TO ENDER1A.
025980     GO TO SUMMARIZER4.
026000
026020 ENDER3.
026040*    IF QTEXEC-COUNT = 0*WRITE QTEXEC-REC.
026060     CLOSE QTEXEC.
026080*    *CLOSE ANY OPEN DATA FILES*.
026100     PERFORM CLOSER1 THRU CLOSER1-EXIT.
026120     PERFORM CLOSER2 THRU CLOSER2-EXIT.
026140     PERFORM CLOSER3 THRU CLOSER3-EXIT.
026160     IF COPYFILE-FLAG NOT = 0
026180         MOVE 0 TO COPYFILE-FLAG
026200         SET DX TO COPY-FX
026220         ENTER MACRO IQGETD
026240         IF ELEM-F-TYPE = 26 CLOSE OUTFSD6
026260             ELSE CLOSE OUTFSD7.
026280     IF CREATEFILE-FLAG NOT = 0
026300         MOVE 0 TO CREATEFILE-FLAG
026320         SET DX TO CREATE-FX
026340         ENTER MACRO IQGETD
026360         IF ELEM-F-TYPE = 26 CLOSE CREATESD6
026380             ELSE CLOSE CREATESD7.
026400     IF PRINTFILE-FLAG NOT = 0 CLOSE QLEXEC
026420         IF LINES-IN-PHASE = 0 OPEN INPUT QLEXEC
026440             CLOSE QLEXEC WITH DELETE
026460         ELSE DISPLAY ' ' DISPLAY
026480          '(End query phase; print file is ' QLEXECLPT ')'
026500          UPON CONSOLE.
026520     IF SORTFILE-FLAG NOT = 0 GO TO ENDER-SORT.
026540     IF CALL-IQM-FLAG = 0
026560         MOVE 'IQL   ' TO CALLED-NAME ELSE
026580         MOVE 'IQM   ' TO CALLED-NAME.
026600*    *ADJUST TERMINAL SO IQM STARTS AT TOP OF PAGE*.
026620     IF NUMB-REPORTS GREATER THAN 1
026640         IF DISPLAY-FLAG = 1
026660             SUBTRACT ELEM-LINE-NO FROM FORM-LINES GIVING I
026680             PERFORM DISPLAY-VSPACE THRU DISPLAY-VSPACE-EXIT.
026700     ENTER MACRO IQNEXT USING CALLED-NAME.
026720     GO TO STOPPER.
026740
026760 ENDER-SORT.
026780*    *SET UP STARTX FOR NEXT STAGE (WHEN COME BACK FROM IQS)*.
026800*    *NEW EXEC-STARTX IS 1 PAST CURRENT 'END' INSTRUCTION*.
026802*    *HOWEVER, DISABLE ANY GO TO NN FOUND HERE*
026804     COMPUTE X = SORT-STARTX + 4.
026806     ENTER MACRO IQGETI.
026808     IF ELEM-INSTR = 53 MOVE 0 TO ELEM-INSTR
026810         ENTER MACRO IQPUTI
026812         SET X UP BY 1
026814         ENTER MACRO IQPUTI.
026820     SET EXEC-STARTX TO SORT-STARTX.
026840     CLOSE SORTFILE.
026860     ADD 100 TO DYN-JOBNO.
026880*    *BUILD SORT FILE PARAMS INTO INF1 F-ENTRY FOR NEXT TIME*.
026900     IF SORTER-ROUTER = 1 SET DX TO INF1-FX
026920         ELSE IF SORTER-ROUTER = 2 SET DX TO INF2-FX
026940         ELSE SET DX TO INF3-FX.
026960     ENTER MACRO IQGETD.
026980     MOVE 0 TO ELEM-F-PPN ELEM-F-KEYLOC ELEM-F-KEYLEN
027000               ELEM-F-KEYTYPE ELEM-F-KEYSIGN ELEM-F-BLKLEN.
027020     MOVE QTSORTTMP TO ELEM-F-ID.
027024    IF ELEM-F-TYPE = 27
027028         COMPUTE ELEM-F-RECLEN = ELEM-F-RECLEN * 6 / 5.
027040     MOVE 26 TO ELEM-F-TYPE.
027042     MOVE ' ' TO DBMS-SIXBIT DBMS-ASCII DBMS-BINARY
027044                 DBMS-EBC    DBMS-CM3   DBMS-CM1.
027060     ENTER MACRO IQPUTD.
027080
027100*    *MOVE CURRENT R-ENTRY SO IS CARRIED OVER*
027120     MOVE 0 TO ELEM-LINE-NO.
027140     MOVE ELEM-R-ENTRY TO ELEM-D-ENTRY.
027160     SET DX TO REPORT-DX.
027180     ENTER MACRO IQPUTD.
027200
027220*    *WRITE OUT DYNAMIC CONTROL TABLES FOR USE AFTER IQS*.
027240     OPEN OUTPUT QTANLZ.
027260     SET DX TO 1.
027280
027300 ENDER-SORT-SAVE1.
027320*    *WRITE OUT LOW CORE (INSTRUCTIONS) FOR NEXT STAGE*.
027340     MOVE D-ENTRY (DX) TO QTANLZ-REC.
027360     WRITE QTANLZ-REC.
027380     IF QTANLZ-REC NOT = ALL SPACES SET DX UP BY 1
027400         GO TO ENDER-SORT-SAVE1.
027420     SET DX TO MAX-DX.
027440
027460 ENDER-SORT-SAVE2.
027480*    *NOW WRITE OUT DYNAMIC DICTIONARY FOR NEXT STAGE*.
027500     MOVE D-ENTRY (DX) TO ELEM-D-ENTRY.
027560     IF ELEM-D-ENTRY = ALL SPACES GO TO ENDER-SORT-SAVE4.
027860
027880 ENDER-SORT-SAVE3.
027900     WRITE QTANLZ-REC FROM ELEM-D-ENTRY.
027920     SET DX DOWN BY 1.
027940     GO TO ENDER-SORT-SAVE2.
027960
027980 ENDER-SORT-SAVE4.
028000     CLOSE QTANLZ.
028020*    *CALL SUBROUTINE TO BUILD TEMPCOR FILE FOR STAND-ALONE
028040*     SORT*
028060     CALL IQES1 USING SORT-RECLEN SORT-KEYOFFSET SORT-KEYLEN.
028080
028100 STOPPER.
028120     STOP RUN.
028140
028160***********************************************************
028180*  OPEN INSTRUCTION; FORMAT:
028200*  (X)   = INSTRUCTION VALUE 2.
028220*  (X+1) = 0
028222*
028224*  OPEN CHECKS TO SEE IF THE PRIMARY FILE IS OPEN AND IF SO
028226*  CLOSES IT. WHILE THIS MAY SEEM BACKWARD, THE PHYSICAL OPEN
028227*  IS DONE JUST BEFORE THE FIRST READ; THE COMBINATION MAKES
028228*  ANY 2ND OR SUBSEQUENT OPEN AN EFFECTIVE "REWIND".
028240*  OPEN ALSO RESETS THE VALUE OF EXEC-STARTX SO THAT
028260*  'GO TO NR' COMES BACK JUST BELOW THIS OPEN INSTRUCTION.
028280*  THIS PERMITS THE USE OF ONE-TIME QUERY COMMANDS BEFORE
028300*  THE 'OPEN', THUS SAVING EXECUTION TIME*.
028320**********************************************************
028340
028360 OPENER.
028364     IF INF1-FX = 0 OR INF1-FLAG = 0 GO TO OPENER1
028368         ELSE IF INF1-FLAG NOT = 0 
028372             PERFORM CLOSER1 THRU CLOSER1-EXIT.
028376 OPENER1.
028380     SET X UP BY 1.
028400     SET EXEC-STARTX TO X.
028420     GO TO NEXT-INSTR.
028440
028460
028480****************************************************
028500* INSTRUCTION TO READ SEQUENTIALLY (INCLUDING ISAM FILES)
028520* FORMAT:  (X)   = INSTRUCTION VALUE 5
028540*          (X+1) = FX OF INPUT FILE F-ENTRY.
028560*          (X+2) = READ TYPE; VALUES ARE:
028580*                  1  = PRIMARY 6 BIT SEQUENTIAL
028600*                  2  = PRIMARY 7 BIT (ASCII) SEQUENTIAL
028620*                  3  = PRIMARY 6 BIT ISAM READ SEQUENTIALLY
028640*                  4  = PRIMARY 7 BIT ISAM READ SEQUENTIALLY
028660*                  5  = RESERVED FOR FUTURE USE
028680*                  6  = RESERVED FOR FUTURE USE
028700*                  7  = SECONDARY 6 BIT SEQUENTIAL
028720*                  8  = SECONDARY 7 BIT SEQUENTIAL
028740*                  9  = SECONDARY 6 BIT ISAM READ SEQUENTIALLY
028760*                  10 = SECONDARY 7 BIT ISAM READ SEQUENTIALLY
028780*                  11 = RESERVED FOR FUTURE USE
028800*                  12 = RESERVED FOR FUTURE USE
028820*                  13 = TERTIARY 6 BIT SEQUENTIAL
028840*                  14 = TERTIARY 7 BIT SEQUENTIAL
028860*                  15 = TERTIARY 6 BIT ISAM READ SEQUENTIALLY
028880*                  16 = TERTIARY 7 BIT ISAM READ SEQUENTIALLY
028900*                  17 = RESERVED FOR FUTURE USE
028920*                  18 = RESERVED FOR FUTURE USE
028940*
028960* NOTE THAT OPENS ARE DONE HERE JUST BEFORE FIRST READ.
028980**********************************************************
029000
029020 READSEQ.
029040     ENTER MACRO IQGETI.
029060     SET FX TO ELEM-INSTR.
029080     SET X UP BY 1.
029100     ENTER MACRO IQGETI.
029120     MOVE ELEM-INSTR TO ROUTER.
029140     MOVE 0 TO ELEM-INSTR.
029160
029180 READSEQ-COMMON.
029190     IF NO-SCAN-ITEMS NEXT SENTENCE
029195         ELSE PERFORM RESET-SCAN-ITEMS THRU RESET-SCAN-EXIT.
029200     GO TO  RD1SEQ6S  RD1SEQ7S  RD1ISAM6S  RD1ISAM7S
029220            READERRS  READERRS  RD2SEQ6S   RD2SEQ7S
029240            RD2ISAM6S RD2ISAM7S READERRS   READERRS
029260            RD3SEQ6S  RD3SEQ7S  RD3ISAM6S  RD3ISAM7S
029280            DEPENDING ON ROUTER.
029300
029320 READERRS.
029340     MOVE 04 TO ERROR-CODE.
029360     GO TO ABORT-RUN.
029380
029400 READLT.
029420
029440 READNLT.
029460*    *READ INFLT INTO INPUT-RECS AT END GO TO QWRAPUP.
029480 READCD.
029500*    *READ INFCD INTO INPUT-RECS AT END GO TO QWRAPUP.
029520     GO TO READERRS.
029540
029560 RD1SEQ6S.
029580     IF INF1-FLAG NOT LESS THAN 5 GO TO END-FILE1.
029600     IF INF1-FLAG = 0 PERFORM OPEN1-SEQ
029620             ELSE MOVE 3 TO INF1-FLAG.
029640 RD1SEQ6S1.
029660     READ INF1SD6 AT END GO TO END-FILE1.
029680*    *IF ELEM-INSTR = 0 HAVE AN EFFECTIVE 'FIND NEXT'*.
029700     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
029720*    *HERE IF DOING FIND ITEM = VALUE   *.
029740     ENTER MACRO IQGETD.
029760     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
029780     IF AHOLDER = ALT-AHOLDER GO TO NEXT-INSTR-UPX.
029800     GO TO RD1SEQ6S1.
029820
029840 RD1ISAM6S.
029860     IF INF1-FLAG NOT LESS THAN 5 GO TO END-FILE1.
029880     IF INF1-FLAG = 0
029900         MOVE LOW-VALUES TO INF1ISAM6-SYMKEY
029920         PERFORM OPEN1-ISAM
029940             ELSE MOVE 3 TO INF1-FLAG.
029960 RD1ISAM6S1.
029980     READ INF1ISAM6 INVALID KEY GO TO END-FILE1.
030000     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
030020     ENTER MACRO IQGETD.
030040     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
030060     IF AHOLDER = ALT-AHOLDER GO TO NEXT-INSTR-UPX.
030080     GO TO RD1ISAM6S1.
030100
030120 RD1SEQ7S.
030140     IF INF1-FLAG NOT LESS THAN 5 GO TO END-FILE1.
030160     IF INF1-FLAG = 0 PERFORM OPEN1-SEQ
030180             ELSE MOVE 3 TO INF1-FLAG.
030200 RD1SEQ7S1.
030220     READ INF1SD7 AT END GO TO END-FILE1.
030240     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
030260     ENTER MACRO IQGETD.
030280     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
030300     IF AHOLDER = ALT-AHOLDER GO TO NEXT-INSTR-UPX.
030320     GO TO RD1SEQ7S1.
030340
030360 RD1ISAM7S.
030380     IF INF1-FLAG NOT LESS THAN 5 GO TO END-FILE1.
030400     IF INF1-FLAG = 0
030420         MOVE LOW-VALUES TO INF1ISAM7-SYMKEY
030440         PERFORM OPEN1-ISAM
030460             ELSE MOVE 3 TO INF1-FLAG.
030480 RD1ISAM7S1.
030500     READ INF1ISAM7 INVALID KEY GO TO END-FILE1.
030520     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
030540     ENTER MACRO IQGETD.
030560     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
030580     IF AHOLDER = ALT-AHOLDER GO TO NEXT-INSTR-UPX.
030600     GO TO RD1ISAM7S1.
030620
030640 RD2SEQ6S.
030660     IF INF2-FLAG = 5 GO TO NEXT-INSTR-UPX.
030680     IF INF2-FLAG = 0 PERFORM OPEN2-SEQ
030700             ELSE MOVE 3 TO INF2-FLAG.
030720 RD2SEQ6S1.
030740     READ INF2SD6 AT END ENTER MACRO IQSXB6 USING INF2-RECLEN
030760         INF2SD6-REC CONST1 GO TO END-FILE2.
030780     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
030800     ENTER MACRO IQGETD.
030820     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
030840     IF AHOLDER = ALT-AHOLDER GO TO NEXT-INSTR-UPX.
030860     GO TO RD2SEQ6S1.
030880
030900 RD2ISAM6S.
030920     IF INF2-FLAG = 5 GO TO NEXT-INSTR-UPX.
030940     IF INF2-FLAG = 0
030960         MOVE LOW-VALUES TO INF2ISAM6-SYMKEY
030980         PERFORM OPEN2-ISAM
031000             ELSE MOVE 3 TO INF2-FLAG.
031020 RD2ISAM6S1.
031040     READ INF2ISAM6 INVALID KEY ENTER MACRO IQSXB6 USING
031060         INF2-RECLEN INF2ISAM6-REC CONST1 GO TO END-FILE2.
031080     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
031100     ENTER MACRO IQGETD.
031120     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
031140     IF AHOLDER = ALT-AHOLDER GO TO NEXT-INSTR-UPX.
031160     GO TO RD2ISAM6S1.
031180
031200 RD2SEQ7S.
031220     IF INF2-FLAG = 5 GO TO NEXT-INSTR-UPX.
031240     IF INF2-FLAG = 0 PERFORM OPEN2-SEQ
031260             ELSE MOVE 3 TO INF2-FLAG.
031280 RD2SEQ7S1.
031300     READ INF2SD7 AT END ENTER MACRO IQSXB7 USING
031320         INF2-RECLEN INF2SD7-REC CONST1 GO TO END-FILE2.
031340     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
031360     ENTER MACRO IQGETD.
031380     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
031400     IF AHOLDER = ALT-AHOLDER GO TO NEXT-INSTR-UPX.
031420     GO TO RD2SEQ7S1.
031440
031460 RD2ISAM7S.
031480     IF INF2-FLAG = 5 GO TO NEXT-INSTR-UPX.
031500     IF INF2-FLAG = 0
031520         MOVE LOW-VALUES TO INF2ISAM7-SYMKEY
031540         PERFORM OPEN2-ISAM
031560             ELSE MOVE 3 TO INF2-FLAG.
031580 RD2ISAM7S1.
031600     READ INF2ISAM7 INVALID KEY ENTER MACRO IQSXB7 USING
031620         INF2-RECLEN INF2ISAM7-REC CONST1 GO TO END-FILE2.
031640     ENTER MACRO IQGETD.
031660     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
031680     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
031700     IF AHOLDER = ALT-AHOLDER GO TO NEXT-INSTR-UPX.
031720     GO TO RD2ISAM7S1.
031740
031760 RD3SEQ6S.
031780     IF INF3-FLAG = 5 GO TO NEXT-INSTR-UPX.
031800     IF INF3-FLAG = 0 PERFORM OPEN3-SEQ
031820             ELSE MOVE 3 TO INF3-FLAG.
031840 RD3SEQ6S1.
031860     READ INF3SD6 AT END ENTER MACRO IQSXB6 USING
031880         INF3-RECLEN INF3SD6-REC CONST1 GO TO END-FILE3.
031900     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
031920     ENTER MACRO IQGETD.
031940     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
031960     IF AHOLDER = ALT-AHOLDER GO TO NEXT-INSTR-UPX.
031980     GO TO RD3SEQ6S1.
032000
032020 RD3ISAM6S.
032040     IF INF3-FLAG = 5 GO TO NEXT-INSTR-UPX.
032060     IF INF3-FLAG = 0
032080         MOVE LOW-VALUES TO INF1ISAM6-SYMKEY
032100         PERFORM OPEN3-ISAM
032120             ELSE MOVE 3 TO INF3-FLAG.
032140 RD3ISAM6S1.
032160     READ INF3ISAM6 INVALID KEY ENTER MACRO IQSXB6 USING
032180         INF3-RECLEN INF3ISAM6-REC CONST1 GO TO END-FILE3.
032200     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
032220     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
032240     IF AHOLDER = ALT-AHOLDER GO TO NEXT-INSTR-UPX.
032260     GO TO RD3ISAM6S1.
032280
032300 RD3SEQ7S.
032320     IF INF3-FLAG = 5 GO TO NEXT-INSTR-UPX.
032340     IF INF3-FLAG = 0 PERFORM OPEN3-SEQ
032360             ELSE MOVE 3 TO INF3-FLAG.
032380 RD3SEQ7S1.
032400     READ INF3SD7 AT END ENTER MACRO IQSXB7 USING
032420         INF3-RECLEN INF3SD7-REC CONST1 GO TO END-FILE3.
032440     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
032460     ENTER MACRO IQGETD.
032480     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
032500     IF AHOLDER = ALT-AHOLDER GO TO NEXT-INSTR-UPX.
032520     GO TO RD3SEQ7S1.
032540
032560 RD3ISAM7S.
032580     IF INF3-FLAG = 0 GO TO NEXT-INSTR-UPX.
032600     IF INF3-FLAG = 0
032620         MOVE LOW-VALUES TO INF3ISAM7-SYMKEY
032640         PERFORM OPEN3-ISAM
032660             ELSE MOVE 3 TO INF3-FLAG.
032680 RD3ISAM7S1.
032700     READ INF3ISAM7 INVALID KEY ENTER MACRO IQSXB7 USING
032720         INF3-RECLEN INF3ISAM7-REC CONST1 GO TO END-FILE3.
032740     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
032760     ENTER MACRO IQGETD.
032780     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
032800     IF AHOLDER = ALT-AHOLDER GO TO NEXT-INSTR-UPX.
032820     GO TO RD3ISAM7S1.
032840
032860 END-FILE1.
032880     MOVE 5 TO INF1-FLAG.
032900     SET X TO EOF1-X.
032920     GO TO NEXT-INSTR.
032940
032960 END-FILE2.
032980     MOVE 5 TO INF2-FLAG.
033000     GO TO NEXT-INSTR-UPX.
033020
033040 END-FILE3.
033060     MOVE 5 TO INF3-FLAG.
033080     GO TO NEXT-INSTR-UPX.
033100
033120*    *OPEN/CLOSE SUBROUTINES FOLLOW*
033140*    *EACH IS ENTERED WITH FX POINTING TO CORRECT F-ENTRY*.
033160
033180 OPEN1-SEQ.
033200     MOVE 0 TO NEWGROUP-FLAG.
033220     MOVE ROUTER TO INF1-TYPE.
033240     SET INF1-FX TO FX.
033260     PERFORM LOCATE-INPUT-FILE.
033280     MOVE ELEM-F-RECLEN TO INF1-RECLEN.
033300     IF ELEM-F-TYPE = 26 OPEN INPUT INF1SD6
033320         ELSE OPEN INPUT INF1SD7.
033340*    *RESTORE ELEM-D-ENTRY WIPED OUT BY ELEM-F-ENTRY ABOVE*.
033360     ENTER MACRO IQGETD.
033380     MOVE 2 TO INF1-FLAG.
033400
033420
033440 OPEN1-ISAM.
033460     MOVE 0 TO NEWGROUP-FLAG.
033480     MOVE ROUTER TO INF1-TYPE.
033500     SET INF1-FX TO FX.
033520     PERFORM LOCATE-INPUT-FILE.
033540     MOVE ELEM-F-RECLEN TO INF1-RECLEN.
033560     MOVE ELEM-F-KEYLEN TO KEYLEN1.
033580     MOVE ELEM-F-KEYLOC TO KEYLOC1.
033600     MOVE 2 TO INF1-FLAG.
033620     IF ELEM-F-TYPE = 26
033640         MOVE 1 TO CORE-DATA-MODE FILE-RECORDING-MODE
033650         IF ELEM-F-OPEN NOT = 'O'
033660           ENTER MACRO IQISAM USING ELEM-F-ID
033680             ELEM-F-BLKLEN  ELEM-F-RECLEN  ELEM-F-KEYTYPE
033700             ELEM-F-KEYLEN  CORE-DATA-MODE ELEM-F-KEYLOC
033720             ELEM-F-KEYSIGN FILE-RECORDING-MODE
033740           OPEN INPUT INF1ISAM6
033760         ELSE ENTER MACRO IQISAM USING ELEM-F-ID
033762              ELEM-F-BLKLEN  ELEM-F-RECLEN  ELEM-F-KEYTYPE
033764              ELEM-F-KEYLEN  CORE-DATA-MODE ELEM-F-KEYLOC
033766              ELEM-F-KEYSIGN FILE-RECORDING-MODE
033768             OPEN INPUT-OUTPUT INF1ISAM6.
033770     IF ELEM-F-TYPE = 27
033780         MOVE ELEM-F-ID   TO INFXISAM7-ID
033800         MOVE 0 TO CORE-DATA-MODE FILE-RECORDING-MODE
033810       IF ELEM-F-OPEN NOT = 'O'
033820         ENTER MACRO IQISAM USING INFXISAM7-ID
033840           ELEM-F-BLKLEN  ELEM-F-RECLEN  ELEM-F-KEYTYPE
033860           ELEM-F-KEYLEN  CORE-DATA-MODE ELEM-F-KEYLOC
033880           ELEM-F-KEYSIGN FILE-RECORDING-MODE
033900         OPEN INPUT INF1ISAM7
033902       ELSE ENTER MACRO IQISAM USING INFXISAM7-ID
033904              ELEM-F-BLKLEN  ELEM-F-RECLEN  ELEM-F-KEYTYPE
033906              ELEM-F-KEYLEN  CORE-DATA-MODE ELEM-F-KEYLOC
033908              ELEM-F-KEYSIGN FILE-RECORDING-MODE
033910            OPEN INPUT-OUTPUT INF1ISAM7.
033920     ENTER MACRO IQGETD.
033940
033960 OPEN1-DBMS.
033980     MOVE 10 TO FIND-RSE.
034000     SET INF1-FX TO FX.
034040     PERFORM LOCATE-INPUT-FILE.
034060     MOVE ELEM-F-RECLEN TO INF1-RECLEN.
034080*    MOVE ELEM-F-ORIGIN TO INF1SD6-REC-ORIGIN.
034100     IF ELEM-F-TYPE NOT = 28 GO TO OPENERR.
034120     MOVE ELEM-F-SUBSCHEMA TO SUBSCHEMA-NAME.
034140     MOVE ELEM-F-SCHEMA TO SCHEMA-NAME.
034160     MOVE 1 TO FIRST-NEXT-INDIC.
034180     MOVE 0 TO SET-AREA-INDIC.
034200     MOVE DBMS-PASSWORD TO PRIVACY-KEY.
034220     ENTER MACRO IQDBIO USING FIND-RSE SCHEMA-NAME
034240         FIRST-NEXT-INDIC SUBSCHEMA-NAME SET-AREA-INDIC
034260         DBMS-ERROR-FLAG INF1SD6-REC PRIVACY-KEY DBMS-STSBLK  
034270                 FIND-SUPPRESS
034280                  SYSCOM CURRENT-RECORD-KEY AREA-NAME-IDENT.
034290    IF DBMS-ERROR-FLAG NOT EQUAL 0
034295       MOVE ERROR-STATUS TO ERROR-CODE
034297       GO TO ABORT-RUN.
034299     MOVE 2 TO INF1-FLAG.
034360     MOVE 5 TO INF1-TYPE.
034380     IF DBMS-ERROR-FLAG NOT = 0
034400         MOVE ERROR-STATUS TO ERROR-CODE
034420         GO TO ABORT-RUN.
034440
034441     SET DX TO MAX-DX.
034521 
034522 OPEN2-SEQ.
034524     MOVE ROUTER TO INF2-TYPE.
034526     SET INF2-FX TO FX.
034528     PERFORM LOCATE-INPUT-FILE.
034540     MOVE ELEM-F-RECLEN TO INF2-RECLEN.
034560     IF ELEM-F-TYPE = 26 OPEN INPUT INF2SD6
034580         ELSE OPEN INPUT INF2SD7.
034600     ENTER MACRO IQGETD.
034620     MOVE 2 TO INF2-FLAG.
034640
034660 OPEN2-ISAM.
034680     MOVE ROUTER TO INF2-TYPE.
034700     SET INF2-FX TO FX.
034720     PERFORM LOCATE-INPUT-FILE.
034740     MOVE ELEM-F-RECLEN TO INF2-RECLEN.
034760     MOVE ELEM-F-KEYLEN TO KEYLEN2.
034780     MOVE ELEM-F-KEYLOC TO KEYLOC2.
034800     MOVE 2 TO INF2-FLAG.
034820     IF ELEM-F-TYPE = 26
034840         MOVE 1 TO CORE-DATA-MODE FILE-RECORDING-MODE
034850         IF ELEM-F-OPEN NOT = 'O'
034860         ENTER MACRO IQISAM USING ELEM-F-ID
034880           ELEM-F-BLKLEN  ELEM-F-RECLEN  ELEM-F-KEYTYPE
034900           ELEM-F-KEYLEN  CORE-DATA-MODE ELEM-F-KEYLOC
034920           ELEM-F-KEYSIGN FILE-RECORDING-MODE
034940         OPEN INPUT INF2ISAM6
034960       ELSE ENTER MACRO IQISAM USING ELEM-F-ID
034962              ELEM-F-BLKLEN  ELEM-F-RECLEN  ELEM-F-KEYTYPE
034964              ELEM-F-KEYLEN  CORE-DATA-MODE  ELEM-F-KEYLOC
034966              ELEM-F-KEYSIGN  FILE-RECORDING-MODE
034968            OPEN INPUT-OUTPUT INF1ISAM6.
034970     IF ELEM-F-TYPE = 27
034980         MOVE ELEM-F-ID   TO INFXISAM7-ID
035000          MOVE 0 TO CORE-DATA-MODE FILE-RECORDING-MODE
035010          IF ELEM-F-OPEN NOT = 'O'
035020         ENTER MACRO IQISAM USING INFXISAM7-ID
035040           ELEM-F-BLKLEN  ELEM-F-RECLEN  ELEM-F-KEYTYPE
035060           ELEM-F-KEYLEN  CORE-DATA-MODE ELEM-F-KEYLOC
035080           ELEM-F-KEYSIGN FILE-RECORDING-MODE
035100         OPEN INPUT INF2ISAM7
035102       ELSE ENTER MACRO IQISAM USING INFXISAM7-ID
035104              ELEM-F-BLKLEN  ELEM-F-RECLEN  ELEM-F-KEYTYPE
035106              ELEM-F-KEYLEN  CORE-DATA-MODE ELEM-F-KEYLOC
035108              ELEM-F-KEYSIGN FILE-RECORDING-MODE
035110            OPEN INPUT-OUTPUT INF2ISAM7.
035120     ENTER MACRO IQGETD.
035140
035160 OPEN3-SEQ.
035180     MOVE ROUTER TO INF3-TYPE.
035200     SET INF3-FX TO FX.
035220     PERFORM LOCATE-INPUT-FILE.
035240     MOVE ELEM-F-RECLEN TO INF3-RECLEN.
035260     IF ELEM-F-TYPE = 26 OPEN INPUT INF3SD6
035280         ELSE OPEN INPUT INF3SD7.
035300     ENTER MACRO IQGETD.
035320     MOVE 2 TO INF3-FLAG.
035340
035360 OPEN3-ISAM.
035380     MOVE ROUTER TO INF3-TYPE.
035400     SET INF3-FX TO FX.
035420     PERFORM LOCATE-INPUT-FILE.
035440     MOVE ELEM-F-RECLEN TO INF3-RECLEN.
035460     MOVE ELEM-F-KEYLEN TO KEYLEN3.
035480     MOVE ELEM-F-KEYLOC TO KEYLOC3.
035500     MOVE 2 TO INF3-FLAG.
035520     IF ELEM-F-TYPE = 26
035540         MOVE 1 TO CORE-DATA-MODE FILE-RECORDING-MODE
035550         IF ELEM-F-OPEN NOT = 'O'
035560         ENTER MACRO IQISAM USING ELEM-F-ID
035580           ELEM-F-BLKLEN  ELEM-F-RECLEN  ELEM-F-KEYTYPE
035600           ELEM-F-KEYLEN  CORE-DATA-MODE ELEM-F-KEYLOC
035620           ELEM-F-KEYSIGN FILE-RECORDING-MODE
035640         OPEN INPUT INF3ISAM6
035660       ELSE ENTER MACRO IQISAM USING ELEM-F-ID
035662              ELEM-F-BLKLEN  ELEM-F-RECLEN  ELEM-F-KEYTYPE
035664              ELEM-F-KEYLEN  CORE-DATA-MODE ELEM-F-KEYLOC
035666              ELEM-F-KEYSIGN FILE-RECORDING-MODE
035668            OPEN INPUT-OUTPUT INF3ISAM6.
035670     IF ELEM-F-TYPE = 27
035680         MOVE ELEM-F-ID   TO INFXISAM7-ID
035700         MOVE 0 TO CORE-DATA-MODE FILE-RECORDING-MODE
035710         IF ELEM-F-OPEN NOT = 'O'
035720           ENTER MACRO IQISAM USING INFXISAM7-ID
035740             ELEM-F-BLKLEN  ELEM-F-RECLEN  ELEM-F-KEYTYPE
035760             ELEM-F-KEYLEN  CORE-DATA-MODE ELEM-F-KEYLOC
035780             ELEM-F-KEYSIGN FILE-RECORDING-MODE
035800           OPEN INPUT INF3ISAM7
035802       ELSE ENTER MACRO IQISAM USING INFXISAM7-ID
035804              ELEM-F-BLKLEN  ELEM-F-RECLEN  ELEM-F-KEYTYPE
035806              ELEM-F-KEYLEN  CORE-DATA-MODE ELEM-F-KEYLOC
035808              ELEM-F-KEYSIGN FILE-RECORDING-MODE
035810            OPEN INPUT-OUTPUT INF3ISAM7.
035820     ENTER MACRO IQGETD.
035840
035860 OPENERR.
035880     MOVE 05 TO ERROR-CODE. GO TO ABORT-RUN.
035882
035884*    *SPECIAL SUBROUTINE TO LOCATE INPUT FILE AND COMPLAIN IF NOT*
035886 LOCATE-INPUT-FILE.
035888     MOVE F-ENTRY (FX) TO ELEM-F-ENTRY.
035890     ENTER MACRO IQLOOK USING DEVICER ELEM-F-ID
035892         PROJ USER I.
035894     IF I NOT = -1 DISPLAY 
035896         '?Cannot find input file ' ELEM-F-ID '; ending run.'
035898         GO TO ABORT-RUN1.
035900
035920 CLOSER1.
035940     IF INF1-FLAG = 0 OR INF1-FLAG = 6 GO TO CLOSER1-EXIT.
035960     SET FX TO INF1-FX.
035980     MOVE F-ENTRY (FX) TO ELEM-F-ENTRY.
036000     MOVE 0 TO INF1-FLAG.
036020     IF ELEM-F-TYPE NOT = 28 GO TO CLOSER1A.
036040     MOVE 9 TO FIND-RSE.
036060     ENTER MACRO IQDBIO USING FIND-RSE SCHEMA-NAME
036080         FIRST-NEXT-INDIC SUBSCHEMA-NAME SET-AREA-INDIC
036100         DBMS-ERROR-FLAG INF1SD6-REC PRIVACY-KEY DBMS-STSBLK,
036110                 FIND-SUPPRESS
036120                  SYSCOM CURRENT-RECORD-KEY AREA-NAME-IDENT.
036140     IF DBMS-ERROR-FLAG NOT = 0
036160         MOVE ERROR-STATUS TO ERROR-CODE
036180         GO TO ABORT-RUN.
036200     GO TO CLOSER1-EXIT.
036220
036240
036260 CLOSER1A.
036280     IF ELEM-F-KEYLEN NOT = 0 GO TO CLOSER1-ISAM.
036300     IF ELEM-F-TYPE = 26 CLOSE INF1SD6 ELSE CLOSE INF1SD7.
036320     GO TO CLOSER1-EXIT.
036340
036360 CLOSER1-ISAM.
036380     IF ELEM-F-TYPE = 26 CLOSE INF1ISAM6 ELSE CLOSE INF1ISAM7.
036400
036420 CLOSER1-EXIT.
036440     EXIT.
036460
036480 CLOSER2.
036500     IF INF2-FLAG = 0 GO TO CLOSER2-EXIT.
036520     SET FX TO INF2-FX.
036540     MOVE F-ENTRY (FX) TO ELEM-F-ENTRY.
036560     MOVE 0 TO INF2-FLAG.
036580     IF ELEM-F-KEYLEN NOT = 0 GO TO CLOSER2-ISAM.
036600     IF ELEM-F-TYPE = 26 CLOSE INF2SD6 ELSE CLOSE INF2SD7.
036620     GO TO CLOSER2-EXIT.
036640
036660 CLOSER2-ISAM.
036680     IF ELEM-F-TYPE = 26 CLOSE INF2ISAM6 ELSE CLOSE INF2ISAM7.
036700
036720 CLOSER2-EXIT.
036740     EXIT.
036760
036780 CLOSER3.
036800     IF INF3-FLAG = 0 GO TO CLOSER3-EXIT.
036820     SET FX TO INF3-FX.
036840     MOVE F-ENTRY (FX) TO ELEM-F-ENTRY.
036860     MOVE 0 TO INF3-FLAG.
036880     IF ELEM-F-KEYLEN NOT = 0 GO TO CLOSER3-ISAM.
036900     IF ELEM-F-TYPE = 26 CLOSE INF3SD6 ELSE CLOSE INF3SD7.
036920     GO TO CLOSER3-EXIT.
036940
036960 CLOSER3-ISAM.
036980     IF ELEM-F-TYPE = 26 CLOSE INF3ISAM6 ELSE CLOSE INF3ISAM7.
037000
037020 CLOSER3-EXIT.
037040     EXIT.
037060
037080**********************************************************
037100* INSTRUCTION TO READ RANDOMLY
037120* FORMAT  (X)   = INSTRUCTION VALUE 6
037140*         (X+1) = FX OF INPUT FILE F-ENTRY.
037160*         (X+2) = X OF NEXT INSTRUCTION (1 PAST END OF LIST)
037180*         (X+3) = READ TYPE; VALUES ARE:
037200*                 1  = PRIMARY 6 BIT ISAM
037220*                 2  = PRIMARY 7 BIT ISAM
037240*                 3  = RESERVED FOR FUTURE USE
037260*                 4  = RESERVED FOR FUTURE USE
037280*                 5  = SECONDARY 6 BIT ISAM
037300*                 6  = SECONDARY 7 BIT ISAM
037320*                 7  = RESERVED FOR FUTURE USE
037340*                 8  = RESERVED FOR FUTURE USE
037360*                 9  = TERTIARY 6 BIT ISAM
037380*                 10 = TERTIARY 7 BIT ISAM
037400*                 11 = RESERVED FOR FUTURE USE
037420*                 12 = RESERVED FOR FUTURE USE
037440*         (X+4) = BEGINNING OF LIST OF DX ENTRIES POINTING
037460*                 TO KEY VALUE ENTRIES.  END OF LIST
037480*                 IS SIGNIFIED BY A DX OF 0; NEXT X IS
037500*                 NEXT INSTRUCTION.
037520*
037540*  SEE LAYOUT OF ELEM-K-ENTRY FOR FORMAT OF A KEY ENTRY.
037560*  VALUE ASSIGNMENTS ARE:
037580*
037600*  1.  IF A SINGLE KEY:    STARTKEY IS SOUGHT VALUE.
037620*                          TYPEV    IS 13.
037640*
037660*  2.  IF A RANGE OF KEYS: STARTKEY IS BEGINNING VALUE.
037680*                          ENDKEY   IS ENDING VALUE.
037700*                          TYPEV    IS 14.
037720*
037740*  3.  IF A RANGE OF KEYS GOING TO END-OF-FILE:
037760*                          STARTKEY IS BEGINNING VALUE.
037780*                          ENDKEY   IS HIGH-VALUES
037800*                          TYPEV    IS 14.
037820*  NOTE: LOGIC BELOW WILL CHANGE VALUES IN KEY ENTRIES
037840*        AS IT GOES; SEE COMMENTS IN SECTION BELOW.
037860*  NOTE THAT OPENS ARE DONE HERE JUST BEFORE FIRST READ.
037880*  NOTE THAT PARTIAL KEY READS ARE VALID ONLY FOR ALPHA ARGS.
037900**********************************************************
037920
037940 READRAN.
037960     MOVE 0 TO MISS-FLAG.
037980     ENTER MACRO IQGETI.
038000     SET FX TO ELEM-INSTR.
038020     SET X UP BY 1.
038040     ENTER MACRO IQGETI.
038060     MOVE ELEM-INSTR TO TRUEGOX.
038080     SET X UP BY 1.
038100     ENTER MACRO IQGETI.
038120     MOVE ELEM-INSTR TO ROUTER.
038140
038160 READRAN1.
038180*    *GET FIRST/NEXT DX POINTER TO A KEY ENTRY*.
038200     SET X UP BY 1.
038220     ENTER MACRO IQGETI.
038240*    *DX OF HIGH-VALUES SAYS 'READ FOR THIS ENTRY COMPLETED -
038260*    * GO ON TO NEXT ENTRY'*.
038280     IF ELEM-INSTR = HIGH-VALUES GO TO READRAN1.
038300*    *DX OF 0 SAYS 'END OF FILE - SET EOF FLAG FOR THIS FILE'*.
038320     IF ELEM-INSTR = 0 GO TO READRAN-ROUTER.
038340     SET DX TO ELEM-INSTR.
038360     ENTER MACRO IQGETD.
038380*    *IF TYPEV IS LESS THAN 13, KEY IS A DATA ITEM*.
038400*    *IF TYPEV IS 13, 14, 15, A KEY VALUE IS IN ELEM-K-STARTKEY*.
038420     IF ELEM-D-TYPEV = 13 OR 14 OR 15
038440         MOVE ELEM-K-STARTKEY TO AHOLDER-30
038460         MOVE 1 TO NHOLDER-TYPE
038480         MOVE -1 TO NHOLDER-SCALE
038500       ELSE
038520         PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
038540
038560 READRAN-ROUTER.
038580     MOVE SPACES TO TEMPKEYV.
038590     IF NO-SCAN-ITEMS NEXT SENTENCE
038595        ELSE PERFORM RESET-SCAN-ITEMS THRU RESET-SCAN-EXIT.
038600     GO TO RD1ISAM RD1ISAM READRAN-ERR READRAN-ERR
038620           RD2ISAM RD2ISAM READRAN-ERR READRAN-ERR
038640           RD3ISAM RD3ISAM DEPENDING ON ROUTER.
038660
038680 READRAN-ERR.
038700     MOVE 06 TO ERROR-CODE. GO TO ABORT-RUN.
038720
038740 RD1ISAM.
038760     MOVE 0 TO NEWGROUP-FLAG.
038780     IF INF1-FLAG = 5 GO TO RD1ISAM-EOF.
038800     IF INF1-FLAG = 0 PERFORM OPEN1-ISAM
038820         ELSE MOVE 3 TO INF1-FLAG.
038840     IF ELEM-INSTR = 0 GO TO RD1ISAM-EOF.
038860*    *ADJUST KEY LEFT TO ALPHA IF IT IS NUMERIC*
038880     IF NHOLDER-TYPE NOT = 1
038900         SUBTRACT KEYLEN1 FROM MAX-NITEM-LEN-UP1 GIVING I
038920         ENTER MACRO IQSX66 USING KEYLEN1
038940             NHOLDER I AHOLDER CONST1.
038960     IF ROUTER = 2 GO TO RD1ISAM7R.
038980     MOVE AHOLDER-30 TO INF1ISAM6-SYMKEY.
039000 RD1ISAM6R1.
039020     READ INF1ISAM6 INVALID KEY
039040         GO TO RD1ISAM6R2.
039060     ENTER MACRO IQSX66 USING KEYLEN1 INF1ISAM6-REC
039080         KEYLOC1 TEMPKEYV CONST1.
039100     GO TO READGOOD1.
039120 RD1ISAM6R2.
039140*    *IF INVALID KEY, MAY HAVE PARTIAL KEY  -
039160*    * READ NEXT SEQUENTIAL RECORD*.
039180     IF ( ELEM-D-TYPEV = 14 OR 15 )
039200         IF INF1ISAM6-SYMKEY = LOW-VALUES GO TO RD1ISAM-EOF
039220         ELSE MOVE LOW-VALUES TO INF1ISAM6-SYMKEY
039240             GO TO RD1ISAM6R1.
039260     MOVE LOW-VALUES TO INF1ISAM6-SYMKEY.
039280     READ INF1ISAM6 INVALID KEY
039300         GO TO RD1ISAM-EOF.
039320     ENTER MACRO IQSX66 USING KEYLEN1 INF1ISAM6-REC
039340         KEYLOC1 TEMPKEYV CONST1.
039360     GO TO READGOOD2.
039380
039400 RD1ISAM7R.
039420     IF AHOLDER-30 = LOW-VALUES
039440         MOVE LOW-VALUES TO INF1ISAM7-SYMKEY
039460         ELSE MOVE AHOLDER-30 TO INF1ISAM7-SYMKEY.
039480 RD1ISAM7R1.
039500     READ INF1ISAM7 INVALID KEY
039520         GO TO RD1ISAM7R2.
039540     ENTER MACRO IQSX76 USING KEYLEN1 INF1ISAM7-REC
039560         KEYLOC1 TEMPKEYV CONST1.
039580     GO TO READGOOD1.
039600 RD1ISAM7R2.
039620     IF ( ELEM-D-TYPEV = 14 OR 15 )
039640         IF INF1ISAM7-SYMKEY = LOW-VALUES GO TO RD1ISAM-EOF
039660         ELSE MOVE LOW-VALUES TO INF1ISAM7-SYMKEY
039680             GO TO RD1ISAM7R1.
039700     MOVE LOW-VALUES TO INF1ISAM7-SYMKEY.
039720     READ INF1ISAM7 INVALID KEY
039740          GO TO RD1ISAM-EOF.
039760     ENTER MACRO IQSX76 USING KEYLEN1 INF1ISAM7-REC
039780         KEYLOC1 TEMPKEYV CONST1.
039800     GO TO READGOOD2.
039820
039840
039860 RD1ISAM-EOF.
039880     IF ELEM-INSTR NOT = 0 IF ( ELEM-D-TYPEV = 13 OR 14 OR 15 )
039900         MOVE HIGH-VALUES TO ELEM-INSTR  ENTER MACRO IQPUTI
039920         MOVE 1 TO MISS-FLAG GO TO READRAN1.
039940     MOVE 5 TO INF1-FLAG.
039960     SET X TO EOF1-X.
039980     GO TO NEXT-INSTR.
040000
040020 RD2ISAM.
040040     IF INF2-FLAG = 0 PERFORM OPEN2-ISAM
040060         ELSE MOVE 3 TO INF2-FLAG.
040080     IF ELEM-INSTR = 0 GO TO RD2ISAM-EOF.
040100     IF NHOLDER-TYPE NOT = 1
040120         SUBTRACT KEYLEN2 FROM MAX-NITEM-LEN-UP1 GIVING I
040140         ENTER MACRO IQSX66 USING KEYLEN2
040160             NHOLDER I AHOLDER CONST1.
040180     IF ROUTER = 6 GO TO RD2ISAM7R.
040200     MOVE AHOLDER-30 TO INF2ISAM6-SYMKEY
040220 RD2ISAM6R1.
040240     READ INF2ISAM6 INVALID KEY
040260         GO TO RD2ISAM6R2.
040280     ENTER MACRO IQSX66 USING KEYLEN2 INF2ISAM6-REC
040300         KEYLOC2 TEMPKEYV CONST1.
040320     GO TO READGOOD1.
040340 RD2ISAM6R2.
040360     IF ( ELEM-D-TYPEV = 14 OR 15 )
040380         IF INF2ISAM6-SYMKEY = LOW-VALUES GO TO RD2ISAM-EOF
040400         ELSE MOVE LOW-VALUES TO INF2ISAM6-SYMKEY
040420             GO TO RD2ISAM6R1.
040440     MOVE LOW-VALUES TO INF2ISAM6-SYMKEY.
040460     READ INF2ISAM6 INVALID KEY
040480         GO TO RD2ISAM-EOF.
040500     ENTER MACRO IQSX66 USING KEYLEN2 INF2ISAM6-REC
040520         KEYLOC2 TEMPKEYV CONST1.
040540     GO TO READGOOD2.
040560
040580 RD2ISAM7R.
040600     IF AHOLDER-30 = LOW-VALUES
040620         MOVE LOW-VALUES TO INF2ISAM7-SYMKEY
040640         ELSE MOVE AHOLDER-30 TO INF2ISAM7-SYMKEY.
040660 RD2ISAM7R1.
040680     READ INF2ISAM7 INVALID KEY
040700         GO TO RD2ISAM7R2.
040720     ENTER MACRO IQSX76 USING KEYLEN2 INF2ISAM7-REC
040740         KEYLOC2 TEMPKEYV CONST1.
040760     GO TO READGOOD1.
040780 RD2ISAM7R2.
040800     IF ( ELEM-D-TYPEV = 14 OR 15 )
040820         IF INF2ISAM7-SYMKEY = LOW-VALUES GO TO RD2ISAM-EOF
040840         ELSE MOVE LOW-VALUES TO INF2ISAM7-SYMKEY
040860         GO TO RD2ISAM7R1.
040880     MOVE LOW-VALUES TO INF2ISAM7-SYMKEY,
040900     READ INF2ISAM7 INVALID KEY
040920         GO TO RD2ISAM-EOF.
040940     ENTER MACRO IQSX76 USING KEYLEN2 INF2ISAM7-REC
040960         KEYLOC2 TEMPKEYV CONST1.
040980     GO TO READGOOD2.
041000
041020 RD2ISAM-EOF.
041040     MOVE 5 TO INF2-FLAG.
041060     GO TO READRAN-ENTRYDONE.
041080
041100 RD3ISAM.
041120     IF INF3-FLAG = 0 PERFORM OPEN3-ISAM
041140         ELSE MOVE 3 TO INF3-FLAG.
041160     IF ELEM-INSTR = 0 GO TO RD3ISAM-EOF.
041180     IF NHOLDER-TYPE NOT = 1
041200         SUBTRACT KEYLEN3 FROM MAX-NITEM-LEN-UP1 GIVING I
041220         ENTER MACRO IQSX66 USING KEYLEN3
041240             NHOLDER I AHOLDER CONST1.
041260     IF ROUTER = 10 GO TO RD3ISAM7R.
041280     MOVE AHOLDER-30 TO INF3ISAM6-SYMKEY.
041300 RD3ISAM6R1.
041320     READ INF3ISAM6 INVALID KEY
041340         GO TO RD3ISAM6R2.
041360     ENTER MACRO IQSX66 USING KEYLEN3 INF3ISAM6-REC
041380         KEYLOC3 TEMPKEYV CONST1.
041400     GO TO READGOOD1.
041420 RD3ISAM6R2.
041440     IF ( ELEM-D-TYPEV = 14 OR 15 )
041460         IF INF3ISAM6-SYMKEY = LOW-VALUES GO TO RD3ISAM-EOF
041480         ELSE MOVE LOW-VALUES TO INF3ISAM6-SYMKEY
041500             GO TO RD3ISAM6R1.
041520     MOVE LOW-VALUES TO INF3ISAM6-SYMKEY.
041540     READ INF3ISAM6 INVALID KEY
041560         GO TO RD3ISAM-EOF.
041580     ENTER MACRO IQSX66 USING KEYLEN3 INF3ISAM6-REC
041600         KEYLOC3 TEMPKEYV CONST1.
041620     GO TO READGOOD2.
041640
041660 RD3ISAM7R.
041680     IF AHOLDER-30 = LOW-VALUES
041700         MOVE LOW-VALUES TO INF3ISAM7-SYMKEY
041720         ELSE MOVE AHOLDER-30 TO INF3ISAM7-SYMKEY.
041740 RD3ISAM7R1.
041760     READ INF3ISAM7 INVALID KEY
041780         GO TO RD3ISAM7R2.
041800     ENTER MACRO IQSX76 USING KEYLEN3 INF3ISAM7-REC
041820         KEYLOC3 TEMPKEYV CONST1.
041840     GO TO READGOOD1.
041860 RD3ISAM7R2.
041880     IF ( ELEM-D-TYPEV = 14 OR 15 )
041900         IF INF3ISAM7-SYMKEY = LOW-VALUES GO TO RD3ISAM-EOF
041920         ELSE MOVE LOW-VALUES TO INF3ISAM7-SYMKEY
041940             GO TO RD3ISAM7R1.
041960     MOVE LOW-VALUES TO INF3ISAM7-SYMKEY.
041980     READ INF3ISAM7 INVALID KEY
042000         GO TO RD3ISAM-EOF.
042020     ENTER MACRO IQSX76 USING KEYLEN3 INF3ISAM7-REC
042040         KEYLOC3 TEMPKEYV CONST1.
042060     GO TO READGOOD2.
042080
042100
042120 READGOOD1.
042140*    *HERE IF HIT VALID READ FIRST TIME THRU - IF HAVE
042160*    * EXACT KEY (13) OR ITEM, GOT TRUE HIT;
042180*    * IF RANGE THRU KEY (14) OR RANGE TO KEY (15)
042200*    * MAY BE READING IN RANGE*.
042220     IF ELEM-D-TYPEV = 13 MOVE HIGH-VALUES TO ELEM-INSTR
042240         ENTER MACRO IQPUTI
042260         SET X TO TRUEGOX  GO TO NEXT-INSTR.
042280     IF ELEM-D-TYPEV NOT = 14 AND NOT = 15
042300         SET X TO TRUEGOX GO TO NEXT-INSTR.
042320*    *SET UP FOR SEQUENTIAL READ IN RANGE NEXT TIME*
042340     MOVE LOW-VALUES TO ELEM-K-STARTKEY.
042360     ENTER MACRO IQPUTD.
042380*    *NOW LOOK TO SEE IF RAN OUT OF RANGE*
042400     IF ELEM-D-TYPEV = 15
042420         IF TEMPKEYV LESS THAN ELEM-K-ENDKEY
042440         SET X TO TRUEGOX GO TO NEXT-INSTR.
042460     IF ELEM-D-TYPEV = 14
042480         IF TEMPKEYV NOT GREATER THAN ELEM-K-ENDKEY
042500         SET X TO TRUEGOX  GO TO NEXT-INSTR.
042520*    *DID RUN OUT OF RANGE; MOVE DOWN TO NEXT ENTRY IN STACK*
042540     MOVE HIGH-VALUES TO ELEM-INSTR.
042560     ENTER MACRO IQPUTI.
042580     GO TO READRAN1.
042600
042620 READGOOD2.
042640*    *ONLY GET HERE ON (SINGLE KEY OR ITEM) & IF DID NOT HIT
042660*    * EXACT VALUE & ARE LOOKING AT NEXT SEQUENTIAL RECORD*.
042680*    *ONLY PERMIT PARTIAL KEY THRU IF (A) ALPHA
042700*    * AND (B) EXACT MATCH ON # OF CHARACTERS FURNISHED*.
042720*    *IF SO, BLANK OUT EXTRA CHARACTERS ON RIGHT OF KEY*
042740     IF NHOLDER-TYPE = 1
042760         SUBTRACT ELEM-D-NCHAR FROM MAX-KEYLEN GIVING I
042780         ADD 1 TO ELEM-D-NCHAR
042800         IF I GREATER THAN 0
042820             ENTER MACRO IQSXB6 USING I TEMPKEYV ELEM-D-NCHAR.
042840     IF TEMPKEYV = AHOLDER-30 IF ELEM-D-TYPEV = 13
042860         MOVE HIGH-VALUES TO ELEM-INSTR  ENTER MACRO IQPUTI
042880         SET X TO TRUEGOX  GO TO NEXT-INSTR
042900         ELSE SET X TO TRUEGOX  GO TO NEXT-INSTR.
042920     IF ELEM-D-TYPEV = 13 MOVE HIGH-VALUES TO ELEM-INSTR
042940         ENTER MACRO IQPUTI.
042960     MOVE 1 TO MISS-FLAG.
042980     SET X TO TRUEGOX.
043000*    *ON MISSED KEY, BLANK OUT APPROPRIATE BUFFER*
043020     GO TO READGOOD2A READGOOD2B READGOOD2X READGOOD2X
043040           READGOOD2E READGOOD2F READGOOD2X READGOOD2X
043060           READGOOD2I READGOOD2J DEPENDING ON ROUTER.
043080 READGOOD2X.
043100     GO TO NEXT-INSTR.
043120 READGOOD2A.
043140     ENTER MACRO IQSXB6 USING INF1-RECLEN INF1ISAM6-REC CONST1.
043160     GO TO NEXT-INSTR.
043180 READGOOD2B.
043200     ENTER MACRO IQSXB7 USING INF1-RECLEN INF1ISAM7-REC CONST1.
043220     GO TO NEXT-INSTR.
043240 READGOOD2E.
043260     ENTER MACRO IQSXB6 USING INF2-RECLEN INF2ISAM6-REC CONST1.
043280     GO TO NEXT-INSTR.
043300 READGOOD2F.
043320     ENTER MACRO IQSXB7 USING INF2-RECLEN INF2ISAM7-REC CONST1.
043340     GO TO NEXT-INSTR.
043360 READGOOD2I.
043380     ENTER MACRO IQSXB6 USING INF3-RECLEN INF3ISAM6-REC CONST1.
043400     GO TO NEXT-INSTR.
043420 READGOOD2J.
043440     ENTER MACRO IQSXB7 USING INF3-RECLEN INF3ISAM7-REC CONST1.
043460     GO TO NEXT-INSTR.
043480
043500 RD3ISAM-EOF.
043520     MOVE 5 TO INF3-FLAG.
043540
043560 READRAN-ENTRYDONE.
043580     IF ELEM-INSTR NOT = 0
043600         IF ( ELEM-D-TYPEV = 13 OR 14 OR 15 )
043620         MOVE HIGH-VALUES TO ELEM-INSTR
043640         ENTER MACRO IQPUTI.
043660     MOVE 1 TO MISS-FLAG.
043680
043700     SET X TO TRUEGOX.
043720     GO TO NEXT-INSTR.
043740
043760******************************************************
043780* READ DATA BASE INSTRUCTION.
043800* FORMAT: (X)   = INSTRUCTION VALUE 7.
043820*         (X+1) = FX OF INPUT DATA BASE FILE F-ENTRY.
043840*         (X+2) = RSE-NUMBER (1-5 FOR DBMS V5)
043860*         (X+3) = PLACEMENT-NO: OWNER = -11
043880*                               FIRST = -12
043900*                               LAST  = -13
043920*                               PRIOR = -14
043940*                               NEXT  = -15
043941*                               DUPLICATE = -16
043942*				      (NOT USED) = 0
043960*         (X+4) = DX OF RECORD NAME ENTRY  (RSE 1,3,5)
043961*                 DX OF SET-NAME-1, OR 0  (RSE 2)
043962*			0 (RSE 4)
043963*
043980*         (X+5) = DX OF ITEM-NAME (RSE 1)
043981*			DX OF SET-NAME-2 OR AREA-NAME OR RECORD-NAME (RSE 2)
043982*			  	OR KEYWORD RUN-UNIT (= -23)
043987*			DX OF SET OR AREA NAME (RSE 3)
043988*			DX OF SET NAME (RSE 4)
043989*			0 (RSE 5)
043990*
044000*         (X+6) = SUPPRESS OPTION: NONE   = 0
044020*                                  ALL    = -17
044040*                                  AREA   = -18
044060*                                  RECORD = -19
044080*                                  SET    = -20
044100*         (X+7) = ZERO (END OF INSTRUCTION)
044120******************************************************
044140
044160 READDBMS.
044180     ENTER MACRO IQGETI.
044200     SET FX TO ELEM-INSTR.
044220     SET X UP BY 1.
044240     IF INF1-FLAG = 0 PERFORM OPEN1-DBMS
044260         MOVE 2 TO INF1-FLAG
044280       ELSE MOVE 3 TO INF1-FLAG.
044300     ENTER MACRO IQGETI.
044320     MOVE ELEM-INSTR TO FIND-RSE.
044340     SET X UP BY 1.
044360     ENTER MACRO IQGETI.
044380     MOVE ELEM-INSTR TO FIRST-NEXT-INDIC.
044400     SET X UP BY 1.
044420     ENTER MACRO IQGETI.
044440     SET DX TO ELEM-INSTR.
044450     IF DX > 0
044460         ENTER MACRO IQGETD
044480         MOVE ELEM-B-NAME TO RECORD-NAME
044485       ELSE MOVE SPACES TO RECORD-NAME.
044500     SET X UP BY 1.
044520     ENTER MACRO IQGETI.
044540     SET DX TO ELEM-INSTR.
044545     IF DX < 0
044546         MOVE SPACES TO AREA-NAME
044547         MOVE 0      TO SET-AREA-INDIC.
044550     IF DX > 0
044560         ENTER MACRO IQGETD.
044580     IF FIND-RSE NOT = 1  AND  DX > 0
044584         MOVE ELEM-B-NAME TO AREA-NAME
044588         MOVE ELEM-B-AREA-SET TO SET-AREA-INDIC
044592         GO TO FINDDBMS1.
044595     IF FIND-RSE = 1
044596         PERFORM GETB-VALUE THRU GET-VALUE-EXIT
044600         IF ELEM-D-SCALE NOT = 0
044604             SET PTX TO ELEM-D-SCALE
044608             DIVIDE 10EX (PTX) INTO BHOLDER GIVING I
044612           ELSE MOVE BHOLDER TO I.
044616 FINDDBMS1.
044660     SET X UP BY 1.
044680     ENTER MACRO IQGETI.
044700     MOVE ELEM-INSTR TO FIND-SUPPRESS.
044720     MOVE 0 TO FIND-ERROR-CODE  FIND-ERROR-FLAG.
044740*    *NOW ACTUALLY READ DATA BASE*
044760     MOVE 0 TO DBMS-ERROR-FLAG.
044780     IF FIND-RSE = 1
044800         ENTER MACRO IQDBIO USING FIND-RSE RECORD-NAME
044820             I AREA-NAME SET-AREA-INDIC
044840             DBMS-ERROR-FLAG INF1SD6-REC PRIVACY-KEY DBMS-STSBLK
044850                 FIND-SUPPRESS
044860                  SYSCOM CURRENT-RECORD-KEY AREA-NAME-IDENT
044880       ELSE
044900         ENTER MACRO IQDBIO USING FIND-RSE RECORD-NAME
044920         FIRST-NEXT-INDIC AREA-NAME SET-AREA-INDIC
044940         DBMS-ERROR-FLAG INF1SD6-REC PRIVACY-KEY DBMS-STSBLK
044950                 FIND-SUPPRESS
044960                  SYSCOM CURRENT-RECORD-KEY AREA-NAME-IDENT.
044980     IF DBMS-ERROR-FLAG NOT = 0
045000         MOVE ERROR-STATUS TO ERROR-CODE
045020         GO TO ABORT-RUN.
045040     GO TO NEXT-INSTR-UPX.
045060
045062*****************************************************
045064* REWRITE INSTRUCTION
045066*  FORMAT:
045068* (X)   = INSTRUCTION VALUE 87
045070* (X+1) = FX OF REWRITE FILE F-ENTRY
045072* (X+2) = REWRITE FILE TYPE, VALUES ARE:
045074*         1 = REWRITE PRIMARY 6 BIT
045076*         2 = REWRITE PRIMARY ASCII
045078*         3 = RESERVED FOR FUTURE USE PRIMARY EBCDIC)
045080*         4 = REWRITE SECONDARY 6 BIT
045082*         5 = REWRITE SECONDARY ASCII
045084*         6 = RESERVED FOR FUTURE USE (SECONDARY EBCDIC)
045086*         7 = REWRITE TERTIARY 6 BIT
045088*         8 = REWRITE TERTIARY ASCII
045090*         9 = RESERVED FOR FUTURE USE (TERTIARY EBCDIC)
045092************************************************************
045094 REWRITE-IT.
045096     ENTER MACRO IQGETI.
045098     SET FX TO ELEM-INSTR.
045100     MOVE F-ENTRY (FX) TO ELEM-F-ENTRY.
045102     SET X UP BY 1.
045104     ENTER MACRO IQGETI.
045106     MOVE ELEM-INSTR TO ROUTER.
045110     GO TO REWRITE1-6  REWRITE1-7  INSTR-ERR
045112           REWRITE2-6  REWRITE2-7  INSTR-ERR
045114           REWRITE3-6  REWRITE3-7  INSTR-ERR
045116           DEPENDING ON ROUTER.
045118     GO TO INSTR-ERR.
045120
045122 REWRITE1-6.
045124     ENTER MACRO IQSX66 USING CONST30 
045122         INF1ISAM6-REC ELEM-F-KEYLOC INF1ISAM6-SYMKEY CONST1.
045123     ENTER MACRO IQWRTI USING ELEM-F-RECLEN.
045124     REWRITE INF1ISAM6-REC INVALID KEY GO TO REWRITE-ERR.
045125     MOVE LOW-VALUES TO INF1ISAM6-SYMKEY.
045126     GO TO NEXT-INSTR-UPX.
045128 REWRITE1-7.
045128     ENTER MACRO IQSX77 USING CONST30
045128         INF1ISAM7-REC ELEM-F-KEYLOC INF1ISAM7-SYMKEY CONST1.
045130     ENTER MACRO IQWRTI USING ELEM-F-RECLEN.
045132     REWRITE INF1ISAM7-REC INVALID KEY GO TO REWRITE-ERR.
045133     MOVE LOW-VALUES TO INF1ISAM7-SYMKEY.
045133     GO TO NEXT-INSTR-UPX.
045134 REWRITE2-6.
045134     ENTER MACRO IQSX66 USING CONST30
045134         INF2ISAM6-REC ELEM-F-KEYLOC INF2ISAM6-SYMKEY CONST1.
045136     ENTER MACRO IQWRTI USING ELEM-F-RECLEN.
045138     REWRITE INF2ISAM6-REC INVALID KEY GO TO REWRITE-ERR.
045139     MOVE LOW-VALUES TO INF2ISAM6-SYMKEY.
045140     GO TO NEXT-INSTR-UPX.
045142 REWRITE2-7.
045142     ENTER MACRO IQSX77 USING CONST30
045142         INF2ISAM7-REC ELEM-F-KEYLOC INF2ISAM7-SYMKEY CONST1.
045144     ENTER MACRO IQWRTI USING ELEM-F-RECLEN.
045146     REWRITE INF2ISAM7-REC INVALID KEY GO TO REWRITE-ERR.
045147     MOVE LOW-VALUES TO INF2ISAM7-SYMKEY.
045148     GO TO NEXT-INSTR-UPX.
045150 REWRITE3-6.
045150     ENTER MACRO IQSX66 USING CONST30
045150         INF3ISAM6-REC ELEM-F-KEYLOC INF3ISAM6-SYMKEY CONST1.
045152     ENTER MACRO IQWRTI USING ELEM-F-RECLEN.
045154     REWRITE INF3ISAM6-REC INVALID KEY GO TO REWRITE-ERR.
045155     MOVE LOW-VALUES TO INF3ISAM6-SYMKEY.
045156     GO TO NEXT-INSTR-UPX.
045158 REWRITE3-7.
045158     ENTER MACRO IQSX77 USING CONST30
045158         INF3ISAM7-REC ELEM-F-KEYLOC INF3ISAM7-SYMKEY CONST1.
045160     ENTER MACRO IQWRTI USING ELEM-F-RECLEN.
045162     REWRITE INF3ISAM7-REC INVALID KEY GO TO REWRITE-ERR.
045163     MOVE LOW-VALUES TO INF3ISAM7-SYMKEY.
045164     GO TO NEXT-INSTR-UPX.
045166
045168 REWRITE-ERR.
045170     DISPLAY '%REWRITE error symbolic key ' 
045172         UPON CONSOLE.
045174
045176**********************************************************
045178* COPY INSTRUCTION
045180*  FORMAT:
045182*    (X)   = INSTRUCTION VALUE 8.
045200*    (X+1) = FX OF COPY FILE F-ENTRY.
045220*    (X+2) = COPY TYPE; VALUES ARE:
045240*            1  = COPY PRIMARY 6 BIT.
045260*            2  = COPY PRIMARY 7 BIT (ASCII).
045280*            3  = RESERVED FOR FUTURE USE.
045300*            4  = COPY SECONDARY 6 BIT.
045320*            5  = COPY SECONDARY 7 BIT (ASCII).
045340*            6  = RESERVED FOR FUTURE USE.
045360*            7  = COPY TERTIARY 6 BIT.
045380*            8  = COPY TERTIARY 7 BIT (ASCII).
045400*            9  = RESERVED FOR FUTURE USE.
045420*
045440*  THERE MAY BE MULTIPLE COPY STATEMENTS IN A QUERY, BUT
045460*  ONLY ONE COPY MAY BE USED IN EACH STAGE*.
045480*
045500*  NOTE THAT COPY FILE IS OPENED JUST BEFORE FIRST WRITE.
045520**********************************************************
045540
045560 COPIER.
045570*     *IF COPY FILE IS NOT OPEN, OPEN IT.
045580     IF COPYFILE-FLAG NOT = 0 GO TO COPIER1.
045600     ENTER MACRO IQGETI.
045620     SET FX TO ELEM-INSTR.
045640     SET COPY-FX TO FX.
045650*    *BRING IN F-ENTRY GOVERNING COPY FILE.
045660     MOVE F-ENTRY (FX) TO ELEM-F-ENTRY.
045680     MOVE ELEM-F-RECLEN TO COPY-RECLEN.
045700     MOVE 2 TO COPYFILE-FLAG.
045702*    *ADJUST COPY F-ENTRY TO MATCH ORIGINAL FILE BEING COPIED;
045704*    * THIS LETS US PUT OUT AN ASCII FILE EVEN THOUGH IT
045706*    * BECAME SIXBIT DURING SORTING.
045706     SET X UP BY 1.
045708     ENTER MACRO IQGETI.
045709     MOVE ELEM-INSTR TO ROUTER.
045710*    *CHECK ROUTER TO SEE WHAT FILE WE ARE COPYING.
045712     IF ELEM-INSTR LESS THAN 4 SET FX TO INF1-FX 
045716       ELSE IF ELEM-INSTR LESS THAN 7 SET FX TO INF2-FX
045720       ELSE SET FX TO INF3-FX.
045721*    *REMOVE THIS LOGIC TO CONVERT SORTED FILES, AS THEY ARE MAINTAINED IN ASCII NOW
045722*     MOVE F-TYPE (FX) TO INPUT-TO-COPY-FTYPE.
045736*    *MAKE SURE 6-BIT RECORD LENGTH IS MULTIPLE OF 6*
045740     IF ELEM-F-TYPE = 26
045760         SUBTRACT 1 FROM COPY-RECLEN GIVING WORKX
045780         DIVIDE CONST6 INTO WORKX GIVING WORKX
045800         ADD 1 TO WORKX
045820         MULTIPLY WORKX BY CONST6 GIVING COPY-RECLEN
045840         OPEN OUTPUT OUTFSD6
045860       ELSE OPEN OUTPUT OUTFSD7.
045864     GO TO COPIER2.
045864
045868 COPIER1.
045880     SET X UP BY 1.
045900     ENTER MACRO IQGETI.  MOVE ELEM-INSTR TO ROUTER.
045910 COPIER2.
045920     GO TO COPY1SEQ6 COPY1SEQ7 INSTR-ERR
045940           COPY2SEQ6 COPY2SEQ7 INSTR-ERR
045960           COPY3SEQ6 COPY3SEQ7 DEPENDING ON ROUTER.
045980     MOVE 07 TO ERROR-CODE. GO TO ABORT-RUN.
046000
046020 COPY1SEQ6.
046040     ENTER MACRO IQSX66 USING COPY-RECLEN
046060         INF1SD6-REC CONST1 OUTFSD6-REC CONST1.
046080     ENTER MACRO IQWRTS USING COPY-RECLEN.
046100     WRITE OUTFSD6-REC.
046120     GO TO NEXT-INSTR-UPX.
046140
046160 COPY1SEQ7.
046162*    *IF SORTED, AND ORIGINAL FILE WAS ASCII, TRANSFORM BACK*
046164*     IF INPUT-TO-COPY-FTYPE = 26
046166*         ENTER MACRO IQSX67 USING COPY-RECLEN
046168*         INF1SD6-REC CONST1 OUTFSD7-REC CONST1 ELSE
046180         ENTER MACRO IQSX77 USING COPY-RECLEN
046200         INF1SD7-REC CONST1 OUTFSD7-REC CONST1.
046220     ENTER MACRO IQWRTS USING COPY-RECLEN.
046240     WRITE OUTFSD7-REC.
046260     GO TO NEXT-INSTR-UPX.
046280
046300 COPY2SEQ6.
046320     ENTER MACRO IQSX66 USING COPY-RECLEN
046340         INF2SD6-REC CONST1 OUTFSD6-REC CONST1.
046360     ENTER MACRO IQWRTS USING COPY-RECLEN.
046380     WRITE OUTFSD6-REC.
046400     GO TO NEXT-INSTR-UPX.
046420
046440 COPY2SEQ7.
046442*    *IF SORTED, AND ORIGINAL FILE WAS ASCII, TRANSFORM BACK*
046444*     IF INPUT-TO-COPY-FTYPE = 26
046446*         ENTER MACRO IQSX67 USING COPY-RECLEN
046448*             INF2SD6-REC CONST1 OUTFSD7-REC CONST1 ELSE
046460         ENTER MACRO IQSX77 USING COPY-RECLEN
046480             INF2SD7-REC CONST1 OUTFSD7-REC CONST1.
046500     ENTER MACRO IQWRTS USING COPY-RECLEN.
046520     WRITE OUTFSD7-REC.
046540     GO TO NEXT-INSTR-UPX.
046560
046580 COPY3SEQ6.
046600     ENTER MACRO IQSX66 USING COPY-RECLEN
046620         INF3SD6-REC CONST1 OUTFSD6-REC CONST1.
046640     ENTER MACRO IQWRTS USING COPY-RECLEN.
046660     WRITE OUTFSD6-REC.
046680     GO TO NEXT-INSTR-UPX.
046700
046720 COPY3SEQ7.
046722*   *IF SORTED, AND ORIGINAL FILE WAS ASCII, TRANSFORM BACK*
046724*     IF INPUT-TO-COPY-FTYPE = 26
046724*         ENTER MACRO IQSX67 USING COPY-RECLEN
046728*             INF3SD6-REC CONST1 OUTFSD7-REC CONST1 ELSE
046740         ENTER MACRO IQSX77 USING COPY-RECLEN
046760             INF3SD7-REC CONST1 OUTFSD7-REC CONST1.
046780     ENTER MACRO IQWRTS USING COPY-RECLEN.
046800     WRITE OUTFSD7-REC.
046820     GO TO NEXT-INSTR-UPX.
046840
046860**********************************************************
046880* CREATE INSTRUCTION.
046900*   FORMAT:
046920*     (X)   = INSTRUCTION VALUE 9.
046940*     (X+1) = FX OF CREATE FILE F-ENTRY.
046960*     (X+2) = CREATE TYPE; VALUES ARE:
046980*             1  = 6 BIT.
047000*             2  = 7 BIT (ASCII).
047020*             3  = RESERVED FOR FUTURE USE.
047040*     (X+3) = START OF DX LIST.  END OF LIST IS MARKED BY 0.
047060*             IF A DX IS NEGATIVE, ITS ABSOLUTE MAGNITUDE
047080*             IS A SPACING (FILLER) INCREMENT.
047100*
047120* NOTE THAT NUMERIC QUANTITIES ARE WRITTEN OUT NUMERIC,
047140* NOT BINARY.
047160*
047180* NOTE THAT CREATE FILE IS OPENED JUST BEFORE FIRST WRITE.
047200*
047220* NOTE: MULTIPLE CREATE STATEMENTS MAY BE USED IN
047240* A QUERY, BUT ONLY ONE CREATE MAY BE USED PER STAGE.
047260*
047280* NOTE: CUSTOM MOVES INSTEAD OF USING GETN-VALUE WOULD BE
047300* FASTER BUT LATTER USED HERE FOR REDUCING CORE.
047320**********************************************************
047340
047360 CREATER.
047380     IF CREATEFILE-FLAG = 0
047400         ENTER MACRO IQGETI
047420         SET FX TO ELEM-INSTR
047440         MOVE F-ENTRY (FX) TO ELEM-F-ENTRY
047460         SET CREATE-FX TO FX
047480         MOVE 2 TO CREATEFILE-FLAG
047500         MOVE ELEM-F-RECLEN TO CREATE-RECLEN
047520*    *MAKE SURE 6-BIT RECORD LENGTH IS MULTIPLE OF 6*.
047540         IF ELEM-F-TYPE = 26
047560             SUBTRACT 1 FROM CREATE-RECLEN GIVING WORKX
047580             DIVIDE CONST6 INTO WORKX GIVING WORKX
047600             ADD 1 TO WORKX
047620             MULTIPLY WORKX BY CONST6 GIVING CREATE-RECLEN
047640             OPEN OUTPUT CREATESD6
047660             ELSE OPEN OUTPUT CREATESD7.
047680     SET X UP BY 1.
047700     ENTER MACRO IQGETI.
047720     MOVE ELEM-INSTR TO J.
047740     MOVE CONST1 TO K.
047760
047780 CREATER1.
047800     SET X UP BY 1.
047820     ENTER MACRO IQGETI.
047840     IF ELEM-INSTR = 0
047860         GO TO CREATER2 CREATER3 DEPENDING ON J.
047880     IF ELEM-INSTR LESS THAN 0
047900         SUBTRACT ELEM-INSTR FROM K GIVING K
047920         GO TO CREATER1.
047940     SET DX TO ELEM-INSTR.
047960     ENTER MACRO IQGETD.
047980     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
048000     IF TRUE-TYPEV NOT = 1 AND TRUE-TYPEV NOT = 10
048020         GO TO CREATER1N.
048040     IF J = 1 ENTER MACRO IQSX66 USING ELEM-D-NCHAR AHOLDER
048060         CONST1 CREATESD6-REC K.
048080     IF J = 2 ENTER MACRO IQSX67 USING ELEM-D-NCHAR AHOLDER
048100         CONST1 CREATESD7-REC K.
048120     ADD ELEM-D-NCHAR TO K.
048140     GO TO CREATER1.
048160
048180*    *IF GET HERE, ARE PROCESSING SOME KIND OF NUMERIC*.
048200 CREATER1N.
048220     SUBTRACT ELEM-D-NCHAR FROM MAX-NITEM-LEN-UP1 GIVING WORKX.
048240     IF J = 1 ENTER MACRO IQSX66 USING ELEM-D-NCHAR NHOLDER WORKX
048260         CREATESD6-REC K.
048280     IF J = 2 ENTER MACRO IQSX67 USING ELEM-D-NCHAR NHOLDER WORKX
048300         CREATESD7-REC K.
048320     ADD ELEM-D-NCHAR TO K.
048340     GO TO CREATER1.
048360
048380 CREATER2.
048400     ENTER MACRO IQWRTS USING CREATE-RECLEN.
048420     WRITE CREATESD6-REC.
048440     GO TO NEXT-INSTR-UPX.
048460
048480 CREATER3.
048500     ENTER MACRO IQWRTS USING CREATE-RECLEN.
048520     WRITE CREATESD7-REC.
048540     GO TO NEXT-INSTR-UPX.
048560
048580********************************************************
048600* READ SUB FILE FROM BEGINNING INSTRUCTION VALUE 10
048620*  FOR  FORMAT SEE INSTR VALUE 11
048640********************************************************
048660 READSUBBEG.
048680*    *FORCE 'FROM BEGINNING' BY CLOSING PROPER FILE*.
048700     ENTER MACRO IQGETI.
048720     SET FX TO ELEM-INSTR.
048740     SET X UP BY 1.
048760     ENTER MACRO IQGETI.
048780     IF ELEM-INSTR LESS THAN 7
048800         PERFORM CLOSER1 THRU CLOSER1-EXIT
048820         GO TO READSUB-COMMON.
048840     IF ELEM-INSTR LESS THAN 13
048860         PERFORM CLOSER2 THRU CLOSER2-EXIT
048880         ELSE PERFORM CLOSER3 THRU CLOSER3-EXIT.
048900     GO TO READSUB-COMMON.
048920
048940
048960********************************************************
048980* READ SUB FILE FROM CURRENT POSITION
049000*  FORMAT:
049020*  (X)    = INSTRUCTION VALUE 11.
049040*  (X+1)  = FX OF INPUT FILE F-ENTRY.
049060*  (X+2)  = READTYPE ROUTER; SAME AS FOR INSTRUCT 5.
049080*  (X+3)  = DX OF LEFTSIDE ITEM.
049100*  (X+4)  = DX OF RIGHTSIDE ITEM (0 IF FIND NEXT).
049120**********************************************************
049140 READSUB.
049160     ENTER MACRO IQGETI.
049180     SET FX TO ELEM-INSTR.
049200     SET X UP BY 1.
049220     ENTER MACRO IQGETI.
049240 READSUB-COMMON.
049260     MOVE ELEM-INSTR TO ROUTER.
049280     SET X UP BY 2.
049300     ENTER MACRO IQGETI.
049320     IF ELEM-INSTR = 0 GO TO READSEQ-COMMON.
049340*    *HERE FOR FIND ITEM = ITEM OR VALUE
049360*    *- ELEM-INSTR = RIGHTSIDE DX*
049380     SET DX TO ELEM-INSTR.
049400     ENTER MACRO IQGETD.
049420*    *GET RIGHTSIDE VALUE AND SAVE RIGHTSIDE TYPE*.
049440     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
049460     MOVE TRUE-TYPEV TO L.
049480     SET X DOWN BY 1.
049500     ENTER MACRO IQGETI.
049520     SET DX TO ELEM-INSTR.
049540*    *CHECK RIGHTSIDE VS LEFTSIDE ITEM TYPE; ADJUST IF NECESSARY*.
049560     ENTER MACRO IQGETD.
049620     PERFORM HOLDER-ADJUST THRU HOLDER-ADJUST-EXIT.
049640*   *NOW GET READY TO GO TO COMMON FILE READING LOGIC*
049660     MOVE AHOLDER TO ALT-AHOLDER.
049680     MOVE NHOLDER-SCALE TO ALT-NHOLDER-SCALE.
049700     ENTER MACRO IQGETI.
049720     SET DX TO ELEM-INSTR.
049740     SET X UP BY 1.
049760     GO TO READSEQ-COMMON.
049780
049800**********************************************************
049820*  SORT INSTRUCTION
049840*   FORMAT:
049860*        (X)    = INSTRUCTION VALUE 12.
049880*        (X+1)  = FILE NUMBER; 1, 2, OR 3
049900*        (X+2)  = START OF DX LIST OF ITEMS TO GO INTO KEY.
049920*                 END OF DX LIST IS SIGNIFIED BY 0.
049940*                 IF AN ITEM IS TO BE SORTED DESCENDING, ITS
049960*                 DX IS NEGATED; IE -197 MEANS THE ITEM
049980*                 SORTED DESCRIBED BY DX 197 IS TO BE SORTED
050000*                 DESCENDING.
050020*
050040*  NOTE: AFTER SORT RECORD WRITTEN, CONTROL GOES TO X POINTED
050060*        TO BY EXEC-STARTX.  THIS IS THE SAME AS IF SORT HAD
050080*        BEEN FOLLOWED BY A 'GO TO NR$' INSTRUCTION.
050100*        THERE SHOULD BE A 'GO TO NR$' INSTRUCTION IMMEDIATELY
050120*        AFTER SORT ( GENERATED AUTOMATICALLY BY IQA ) ANYWAY
050140*        TO SERVE AS THE FALSEGOX TARGET OF ANY IF WHICH CONTROLS
050160*        THE SORT.  I.E:  IF DIV = 421 SORT BY DEPT $
050180*        GENERATES CODE AS IF IT HAD BEEN WRITTEN
050200*                         IF DEPT = 421 SORT BY DEPT $
050220*                         GO TO NR $
050240*
050260*    ON IQE'S HITTING END OF INPUT FILE, CONTROL GOES TO LOCATION
050280*    ADDRESSED BY EOF1-X.  THIS NORMALLY WILL BE AN 'END'
050300*    INSTRUCTION.  HERE, IQE WILL LOOK TO SEE IF IT IS
050320*    SORTING, AND IF SO IT WILL WRITE OUT THE CURRENT
050340*    CONTROL TABLES AND EXIT TO IQS.  BEFORE WRITING THE
050360*    CONTROL TABLES, IT RESETS EXEC-STARTX TO POINT TO THE
050380*    NEXT READ INSTRUCTION AFTER THE SORT INSTRUCTION NOW BEING
050400*    EXECUTED.  THIS NORMALLY WILL BE A
050420*    'READ PRIMARY SEQUENTIAL SIXBIT' INSTRUCTION, WHICH
050440*    WILL SERVE AS THE FIRST INSTRUCTION WHEN IQE IS
050460*    RE ENTERED FROM IQS; IT WILL ALSO BE THE TARGET OF ANY
050480*    'GO TO NR' (IMPLIED OR REAL) IN THE NEW STAGE.
050500*
050520*  NOTE THAT IQE TAKES CARE OF OPENING AND CLOSING THE
050540*    SORTED FILE.
050560**********************************************************
050580
050600 SORTER.
050620     IF SORTFILE-FLAG NOT = 0 GO TO SORTER1.
050640     OPEN OUTPUT SORTFILE.
050660     MOVE 1 TO SORTFILE-FLAG.
050680 SORTER1.
050700     ENTER MACRO IQGETI.
050720     MOVE ELEM-INSTR TO SORTER-ROUTER.
050740     GO TO SORTER-BUILDREC1 SORTER-BUILDREC2 SORTER-BUILDREC3
050760           DEPENDING ON SORTER-ROUTER.
050780
050800 SORTER-BUILDREC1.
050820     SET DX TO INF1-FX.
050840     ENTER MACRO IQGETD.
050860     IF ELEM-F-TYPE = 27 
050864         COMPUTE ELEM-F-RECLEN = ELEM-F-RECLEN * 6 / 5.
051000     ENTER MACRO IQSX66 USING ELEM-F-RECLEN INF1SD6-REC
051020         CONST1 SORTFILE-REC CONST1.
051040     GO TO SORTER2.
051060
051300 SORTER-BUILDREC2.
051320     SET DX TO INF2-FX.
051340     ENTER MACRO IQGETD.
051360     IF ELEM-F-TYPE = 27 
051364         COMPUTE ELEM-F-RECLEN = ELEM-F-RECLEN * 6 / 5.
051500     ENTER MACRO IQSX66 USING ELEM-F-RECLEN INF2SD6-REC
051520         CONST1 SORTFILE-REC CONST1.
051540     GO TO SORTER2.
051560
051760
051780 SORTER-BUILDREC3.
051800     SET DX TO INF3-FX.
051820     ENTER MACRO IQGETD.
051840     IF ELEM-F-TYPE = 27
051860         COMPUTE ELEM-F-RECLEN = ELEM-F-RECLEN * 6 / 5.
051980     ENTER MACRO IQSX66 USING ELEM-F-RECLEN INF3SD6-REC
052000         CONST1 SORTFILE-REC CONST1.
052020     GO TO SORTER2.
052040
052240
052260 SORTER2.
052280     MOVE ELEM-F-RECLEN TO SORT-KEYOFFSET.
052300     ADD 1 TO SORT-KEYOFFSET.
052320     SET SKX TO SORT-KEYOFFSET.
052340
052360 SORTER-LOOP.
052380*    *BUILD KEY IN THIS LOOP*.
052400     SET X UP BY 1.
052420     ENTER MACRO IQGETI.
052440     IF ELEM-INSTR = 0 GO TO SORTER-BUILDREC.
052460     IF ELEM-INSTR LESS THAN 0 GO TO SORTER-DESC-KEY.
052480
052500 SORTER-ASC-KEY.
052520*    *PROCESS ASCENDING KEY FIELD HERE*.
052540     SET DX TO ELEM-INSTR.
052560     ENTER MACRO IQGETD.
052580     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
052600     GO TO SORTASC-ALPHA SORTASC-NUM SORTER-ERR SORTER-ERR
052620           SORTER-ERR SORTASC-NUM SORTASC-NUM SORTASC-NUM
052640           SORTASC-NUM SORTASC-ALPHA SORTASC-NUM SORTER-ERR
052660           SORTASC-ALPHA SORTASC-ALPHA SORTASC-NUM
052680           DEPENDING ON TRUE-TYPEV.
052700
052720 SORTER-ERR.
052740     MOVE 08 TO ERROR-CODE.
052760     PERFORM COMPLAINER THRU COMPLAINER-EXIT.
052780     GO TO SORTER-LOOP.
052800 SORTASC-ALPHA.
052820     ENTER MACRO IQSX66 USING ELEM-D-NCHAR AHOLDER
052840         CONST1 SORTFILE-KEY SKX.
052860     SET SKX UP BY ELEM-D-NCHAR.
052880     GO TO SORTER-LOOP.
052900
052920 SORTASC-NUM.
052940     SUBTRACT ELEM-D-NCHAR FROM MAX-NITEM-LEN-UP1 GIVING I.
052960
052980 SORTASC-NUM1.
053000     SET PTX TO ELEM-D-NCHAR.
053020*    *ADJUST FOR POSSIBLE NEGATIVE VALUES*.
053040     ADD 10EX (PTX) TO NHOLDER.
053060
053080 SORTASC-NUM2.
053100     IF I GREATER 1
053120         SUBTRACT 1 FROM I  ADD 1 TO ELEM-D-NCHAR.
053140     ENTER MACRO IQSX66 USING ELEM-D-NCHAR
053160         NHOLDER I SORTFILE-KEY SKX.
053180     SET SKX UP BY ELEM-D-NCHAR.
053200     GO TO SORTER-LOOP.
053220
053240
053260 SORTER-DESC-KEY.
053280*    *PROCESS DESCENDING KEY FIELD HERE*.
053300     SUBTRACT ELEM-INSTR FROM 0 GIVING ELEM-INSTR.
053320     SET DX TO ELEM-INSTR.
053340     ENTER MACRO IQGETD.
053360     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
053380     GO TO SORTDSC-ALPHA SORTDSC-NUM SORTER-ERR SORTER-ERR
053400          SORTER-ERR SORTDSC-NUM SORTDSC-NUM SORTDSC-NUM
053420          SORTDSC-NUM SORTDSC-ALPHA SORTDSC-NUM SORTER-ERR
053440          SORTDSC-ALPHA SORTDSC-ALPHA SORTDSC-NUM
053460          DEPENDING ON TRUE-TYPEV.
053480
053500 SORTDSC-ALPHA.
053580*    *COMPLEMENT ALPHA CHAR FOR SORTING DESCENDING*.
053582     SET I TO SKX.
053584     COMPUTE I = I + ELEM-D-NCHAR - 1 .
053586     ENTER MACRO IQSX66 USING ELEM-D-NCHAR
053588         AHOLDER CONST1 SORTFILE-KEY SKX.
053590
053592 SORTDSC-ALPHA1.
053600     MOVE SORTFILE-KEYCHAR (SKX) TO ELEM-CHAR.
053620     SUBTRACT BINARY-CHAR FROM CONST63 GIVING BINARY-CHAR.
053640     MOVE ELEM-CHAR TO SORTFILE-KEYCHAR (SKX).
053642     SET SKX UP BY 1.
053660     IF SKX NOT GREATER THAN I
053680         GO TO SORTDSC-ALPHA1.
053760     GO TO SORTER-LOOP.
053780
053800 SORTDSC-NUM.
053820     SUBTRACT ELEM-D-NCHAR FROM MAX-NITEM-LEN-UP1 GIVING I.
053840
053860 SORTDSC-NUM1.
053880     SET PTX TO ELEM-D-NCHAR.
053900*    *ADJUST FOR POSSIBLE NEGATIVE VALUES AND COMPLEMENT*.
053920     SUBTRACT NHOLDER FROM 10EX (PTX) GIVING NHOLDER.
053940
053960 SORTDSC-NUM2.
053980     IF I GREATER 1
054000         SUBTRACT 1 FROM I
054020         ADD 1 TO ELEM-D-NCHAR.
054040     ENTER MACRO IQSX66 USING ELEM-D-NCHAR
054060         NHOLDER I SORTFILE-KEY SKX.
054080     SET SKX UP BY ELEM-D-NCHAR.
054100     GO TO SORTER-LOOP.
054120
054140
054160 SORTER-BUILDREC.
054180     IF SORTFILE-FLAG = 1 MOVE 2 TO SORTFILE-FLAG
054200         SET SORT-RECLEN TO SKX
054220         MOVE SORT-RECLEN TO SORT-KEYLEN
054240         SUBTRACT SORT-KEYOFFSET FROM SORT-KEYLEN
054260         SUBTRACT 1 FROM SORT-RECLEN
054280     ENTER MACRO IQWRTS USING SORT-RECLEN.
054300     WRITE SORTFILE-REC.
054320*    *SET UP START EXECUTION ROUTER FOR NEXT STAGE -
054340*    *THIS ALSO SERVES TO STOP SUMMARY OUT SEARCH*
054350*    *SORT-STARTX IS 5 PAST END OF KEY LIST TO GIVE ROOM FOR ANY
054355*    * GO TO NN INSTRUCTION THAT MAY IMMEDIATELY FOLLOW SORT.
054360     COMPUTE SORT-STARTX = X + 5.
054442*    *TURN OFF FIRST TIME ACTIVITY*
054444     IF INF1-FLAG LESS THAN 3 MOVE 3 TO INF1-FLAG.
054460     GO TO NEXT-INSTR.
054480
054500*******************************************************
054520*  ACCEPT INSTRUCTION
054540*    FORMAT:
054560*       (X):         INSTRUCTION:  VALUE 14
054580*       (X+1):       DX OF ITEM TO BE ACCEPTED
054600*                    DX LIST CONTINUES UNTIL DX IS 0,
054620*                    SIGNIFYING END OF LIST AND THAT NEXT
054640*                    INSTR (X) IS NEXT INSTRUCTION.
054660******************************************************
054680
054700 ACCEPT2.
054720     ENTER MACRO IQGETI.
054740     IF ELEM-INSTR = CONST0
054760         GO TO NEXT-INSTR-UPX.
054780     SET DX TO ELEM-INSTR.
054800     ENTER MACRO IQGETD.
054820     PERFORM RECEIVE-ITEM THRU RECEIVE-ITEM-EXIT.
054840     PERFORM SET-VALUE THRU SET-VALUE-EXIT.
054860     SET X UP BY 1.
054880     GO TO ACCEPT2.
054900
054920**********************************************************
054940*  DISPLAY INSTRUCTION.
054960*  FORMAT:
054980*  (X)   = INSTRUCTION VALUE 15.
055000*  REST OF INSTRUCTION IS EXACTLY THE SAME AS PRINT (SEE BELOW).
055020**********************************************************
055040
055060 DISPLAYER.
055080     MOVE SPACES TO PRINT-LINE.
055100     MOVE HSPACE TO CURR-HSPACE.
055120     MOVE LMARGIN TO PRINT-POS.
055124*    *SAVE TITLE-FLAG THEN KILL IT SO TITLES DO NOT AFFECT*
055130     MOVE TITLE-FLAG TO HOLD-TITLE-FLAG.
055132     MOVE 0 TO TITLE-FLAG.
055140     PERFORM PRINTLINE-BUILD THRU PRINTLINE-BUILD-EXIT.
055150     MOVE PRINT-POS TO TERM-CHARS.
055160     PERFORM DISPLAY-PRINT-LINE.
055164*    *RESTORE TITLE-FLAG*
055170     MOVE HOLD-TITLE-FLAG TO TITLE-FLAG.
055180     GO TO NEXT-INSTR-UPX.
055200
055220**********************************************************
055240*  PRINT  INSTRUCTION
055260*     FORMAT     (X)     =  INSTRUCTION VALUE 16
055280*                (X+1)   =  RUNNING PAGE NO; INITIALLY 1.
055300*                (X+2)   =  RUNNING ACROSS; INITIALLY 1.
055320*                (X+3)   =  RUNNING PRINTPOS; INITIALLY 1.
055340*                (X+4)   =  START OF DX LIST. 3 TYPES OF ENTRY:
055360*                           DX = 0 : END OF LIST.
055380*                           DX > 0 : VALID DX TO DYN DICT.
055400*                           DX < 0 : SPACING CONSTANT WHOSE
055420*                                    VALUE IS - (MAGNITUDE + 1);
055440*                                    IE: -2 IS REALLY +1.
055460**********************************************************
055480
055500 PRINTIT.
055520
055540*    *IF FIRST TIME FOR MULTIPLE REPORT, WRITE HEADER*
055560     IF ELEM-RPT-NO LESS THAN 2
055580         AND ACROSS-CONTROL LESS THAN 2 GO TO PRINTIT1.
055600     IF PAGING-FLAG NOT = 0 GO TO PRINTIT1.
055620     IF ELEM-PAGE-NO = 0 AND ELEM-LINE-NO = 0
055640         MOVE DISPLAY-FLAG TO QTE-DISPLAY-FLAG
055660         MOVE PRINT-FLAG   TO QTE-PRINT-FLAG
055680         MOVE PAGE-LINES   TO QTE-PAGE-LINES
055700         MOVE FORM-LINES   TO QTE-FORM-LINES
055720         MOVE ELEM-RPT-NO  TO QTE-RPT-NO
055740         MOVE 0 TO QTE-PAGE-NO QTE-LINE-NO
055760         MOVE 1 TO CALL-IQM-FLAG
055780         WRITE QTEXEC-REC ADD 1 TO QTEXEC-COUNT.
055800
055820 PRINTIT1.
055840     SET X UP BY 1.
055860*   *EXTRACT RUNNING ACROSS COUNT*
055880     ENTER MACRO IQGETI.
055900     MOVE ELEM-INSTR TO RUNNING-ACROSS.
055920     SUBTRACT ELEM-INSTR FROM ACROSS-CONTROL
055940         GIVING ELEM-ACROSS-NO.
055960*   *SET UP RUNNING ACROSS FOR NEXT TIME*
055980     IF ELEM-ACROSS-NO LESS THAN 1 MOVE 1 TO ELEM-INSTR
056000         ELSE ADD 1 TO ELEM-INSTR.
056020     ENTER MACRO IQPUTI.
056040     SET X UP BY 1.
056060*   *EXTRACT RUNNING PRINT POSITION*
056080     SET RUNNING-PRINTPOSX TO X.
056100     ENTER MACRO IQGETI.
056120     MOVE ELEM-INSTR TO RUNNING-PRINTPOS.
056140     IF RUNNING-ACROSS = 1 MOVE 1 TO RUNNING-PRINTPOS.
056160     MOVE RUNNING-PRINTPOS TO ELEM-PRINTPOS.
056180     SET X UP BY 1.
056200     MOVE VSPACE TO CURR-VSPACE.
056210     IF ELEM-LAST-PRINTYPE = 2 ADD 1 TO CURR-VSPACE.
056214*    *IF APPROPRIATE, FORCE PAGE FIRST TIME*
056220     IF ELEM-LINE-NO = 0 AND PAGING-FLAG = 1
056240         MOVE FORM-LINES TO ELEM-LINE-NO.
056250*    *NOW SEE IF ABOUT TO OVERFLOW PAGE*
056255     MOVE ELEM-LINE-NO TO J.
056260     ADD CURR-VSPACE TO J.
056270     IF X NOT = ELEM-LAST-PRINTX AND TITLE-FLAG = 1
056274         ADD 4 TO J.
056280     IF J NOT GREATER THAN PAGE-LINES
056300         NEXT SENTENCE ELSE
056320         IF PAGING-FLAG = 1
056340         PERFORM NEWPAGER THRU NEWPAGER-EXIT
056360         MOVE 1 TO CURR-VSPACE
056380         GO TO PRINTER-COMMON2.
056420*    *IF MULTIPLE REPORTS, VSPACE VIA THAT MECHANISM*
056440     IF ELEM-RPT-NO GREATER THAN 1
056460         OR ACROSS-CONTROL GREATER THAN 1
056480         MOVE SPACES TO PRINT-LINE
056500         GO TO PRINTER-COMMON2.
056520     IF DISPLAY-FLAG = 1 MOVE CURR-VSPACE TO I
056540         SUBTRACT 1 FROM I
056560         PERFORM DISPLAY-VSPACE THRU DISPLAY-VSPACE-EXIT.
056580     MOVE SPACES TO PRINT-LINE.
056600     IF PRINT-FLAG NOT = 1 GO TO PRINTER-COMMON2.
056610     ADD CURR-VSPACE TO ELEM-LINE-NO.
056620
056640 PRINTER-COMMON1.
056660     IF CURR-VSPACE LESS THAN 4 GO TO PRINTER-COMMON2A.
056680*    *HERE FOR PRINT VERTICAL SPACING MORE THAN 3 - LOOP*.
056700     WRITE QLEXEC-REC FROM PRINT-LINE
056720         AFTER ADVANCING 3 LINES ADD 1 TO LINES-IN-PHASE.
056740     SUBTRACT 3 FROM CURR-VSPACE.
056760     GO TO PRINTER-COMMON1.
056780
056800 PRINTER-COMMON2.
056810     ADD CURR-VSPACE TO ELEM-LINE-NO.
056812
056814 PRINTER-COMMON2A.
056820*    *CHECK FOR TITLING NEED*.
056830     IF TITL-WHILE-ACROSS = 1 GO TO TITLER.
056840     IF X NOT = ELEM-LAST-PRINTX NEXT SENTENCE
056860         ELSE GO TO PRINTER-MAINLINE.
056880     MOVE 0 TO NEWPAGE-FLAG.
056900
056920 TITLER.
056940     IF TITLE-FLAG NOT = 1 GO TO PRINTER-MAINLINE.
056945     IF ACROSS-CONTROL > 1 MOVE 1 TO TITL-WHILE-ACROSS
056948         IF RUNNING-ACROSS = ACROSS-CONTROL 
056949             MOVE 0 TO TITL-WHILE-ACROSS.
056950     ADD 4 TO ELEM-LINE-NO.
056960     SET SAVEX TO X.
056980     MOVE HSPACE TO CURR-HSPACE.
057000     IF ELEM-ACROSS-NO LESS THAN 1
057020         MOVE LMARGIN TO PRINT-POS
057040         ELSE MOVE 1 TO PRINT-POS.
057060     MOVE SPACES TO WORK-LINE.
057080     ENTER MACRO IQGETI.
057100     IF ELEM-INSTR = 0 OR HIGH-VALUES GO TO TITLER5.
057120     IF ELEM-INSTR GREATER THAN 0 GO TO TITLER3.
057140     GO TO TITLER2.
057160
057180 TITLER1.
057200     ENTER MACRO IQGETI.
057220     IF ELEM-INSTR = 0 GO TO TITLER5.
057240
057260 TITLER2.
057280     IF ELEM-INSTR LESS THAN 0
057300         SUBTRACT ELEM-INSTR FROM CONST-1 GIVING CURR-HSPACE
057320         SET X UP BY 1
057340         GO TO TITLER1.
057360     ADD CURR-HSPACE TO PRINT-POS.
057380
057400 TITLER3.
057420     SET DX TO ELEM-INSTR.
057440     ENTER MACRO IQGETD.
057460     IF ELEM-D-TYPEV = 10
057480         ADD ELEM-D-NCHAR TO PRINT-POS
057500         SET X UP BY 1
057520         GO TO TITLER1.
057540     SUBTRACT ELEM-D-TCHAR FROM ELEM-D-ECHAR GIVING J.
057560     IF J LESS THAN 0 MOVE 0 TO J.
057580     DIVIDE CONST100 INTO ELEM-D-TYPEV GIVING FILE-ROUTER
057600         REMAINDER TRUE-TYPEV.
057620     IF TRUE-TYPEV = 1 OR 12 OR 33 OR 34 OR 36 GO TO TITLER4.
057640*    *RIGHT JUSTIFY NUMERIC TITLES*.
057660     ADD J TO PRINT-POS.
057680     MOVE 0 TO J.
057700
057720 TITLER4.
057740     ENTER MACRO IQSX66 USING ELEM-D-TCHAR
057760         ELEM-D-TITLE1 CONST1 PRINT-LINE PRINT-POS.
057780     ENTER MACRO IQSX66 USING ELEM-D-TCHAR
057800         ELEM-D-TITLE2 CONST1 WORK-LINE PRINT-POS.
057820     ADD J ELEM-D-TCHAR TO PRINT-POS.
057840     SET X UP BY 1.
057860     GO TO TITLER1.
057880
057900 TITLER5.
057920*    *IF OVERFLOW RIGHT MARGIN BLANK OUT EXCESS*.
057940     IF PRINT-POS GREATER THAN RMARGIN
057960         SUBTRACT RMARGIN FROM PRINT-POS GIVING I
057980         ADD CONST1 RMARGIN GIVING J
058000         ENTER MACRO IQSX66 USING I SPACE-LINE CONST1
058020             PRINT-LINE J
058040         ENTER MACRO IQSX66 USING I SPACE-LINE CONST1
058060             WORK-LINE J.
058080     IF ACROSS-CONTROL LESS THAN 2 AND
058100         ELEM-RPT-NO LESS THAN 2 GO TO TITLER5A.
058120*    *PROCESS ANY MULTIPLE REPORTS*.
058140     MOVE ELEM-RPT-PARAMS TO QTE-RPT-PARAMS.
058160     MOVE CURR-VSPACE TO QTE-VSPACE.
058180     SET I TO X.
058200     SUBTRACT 1 FROM I GIVING QTE-PRINTX.
058220     MOVE PRINT-LINE TO QTE-IMAGE.
058240     WRITE QTEXEC-REC ADD 1 TO QTEXEC-COUNT.
058260     MOVE 1 TO QTE-VSPACE.
058280     ADD 1 TO QTE-LINE-NO.
058300     MOVE WORK-LINE TO QTE-IMAGE.
058320     ADD 1 TO QTE-PRINTX.
058340     WRITE QTEXEC-REC ADD 1 TO QTEXEC-COUNT.
058360     MOVE 2 TO CURR-VSPACE.
058380     GO TO TITLER7.
058400
058420 TITLER5A.
058440     IF DISPLAY-FLAG NOT = 1 GO TO TITLER6.
058460     DISPLAY ' ' UPON CONSOLE.
058470     MOVE PRINT-POS TO TERM-CHARS.
058480     PERFORM DISPLAY-PRINT-LINE.
058500     PERFORM DISPLAY-WORK-LINE.
058520     DISPLAY ' ' UPON CONSOLE.
058540
058560 TITLER6.
058580     IF PRINT-FLAG NOT = 1 GO TO TITLER7.
058600     WRITE QLEXEC-REC FROM PRINT-LINE
058620         AFTER ADVANCING 2 LINES ADD 1 TO LINES-IN-PHASE.
058640     WRITE QLEXEC-REC FROM WORK-LINE
058660         AFTER ADVANCING 1 LINES ADD 1 TO LINES-IN-PHASE.
058680     MOVE 2 TO CURR-VSPACE.
058700
058720 TITLER7.
058760     SET X TO SAVEX.
058780     MOVE SPACES TO PRINT-LINE.
058800
058820 PRINTER-MAINLINE.
058840     MOVE 1 TO ELEM-LAST-PRINTYPE.
058860     IF TITLE-FLAG = 1 SET ELEM-LAST-PRINTX TO X.
058880     MOVE HSPACE TO CURR-HSPACE.
058900     MOVE LMARGIN TO PRINT-POS.
058920     PERFORM PRINTLINE-BUILD THRU PRINTLINE-BUILD-EXIT.
058940*     *IF PRINT LINE OVERFLOW BLANK OUT
058960     IF PRINT-POS GREATER THAN RMARGIN
058980         SUBTRACT RMARGIN FROM PRINT-POS GIVING I
059000         ADD CONST1 RMARGIN GIVING J
059020         ENTER MACRO IQSX66 USING I
059040             SPACE-LINE CONST1 PRINT-LINE J.
059060     IF ACROSS-CONTROL LESS THAN 2 AND
059080         ELEM-RPT-NO LESS THAN 2 GO TO PRINTER-MAINLINE1.
059100     MOVE ELEM-RPT-PARAMS TO QTE-RPT-PARAMS.
059120     MOVE CURR-VSPACE TO QTE-VSPACE.
059140     MOVE PRINT-LINE TO QTE-IMAGE.
059160*   *SET UP RUNNING PRINT POSITION FOR NEXT TIME.
059180     WRITE QTEXEC-REC ADD 1 TO QTEXEC-COUNT.
059200     SET SAVEX TO X.
059220     SET X TO RUNNING-PRINTPOSX.
059240     ADD PRINT-POS RUNNING-PRINTPOS GIVING ELEM-INSTR.
059260     ENTER MACRO IQPUTI.
059280     SET X TO SAVEX.
059300     GO TO NEXT-INSTR-UPX.
059320
059340 PRINTER-MAINLINE1.
059360     IF PRINT-FLAG = 1
059380         WRITE QLEXEC-REC FROM PRINT-LINE
059400         AFTER ADVANCING CURR-VSPACE LINES 
059402         ADD 1 TO LINES-IN-PHASE.
059420     IF DISPLAY-FLAG = 1
059421         MOVE PRINT-POS TO TERM-CHARS
059440         PERFORM DISPLAY-PRINT-LINE.
059460     GO TO NEXT-INSTR-UPX.
059480
059500**********************************************************
059520* SUBROUTINE TO CONSTRUCT PRINT LINE FROM DX LIST.  IT IS
059540* CALLED BOTH FROM PRINT AND NEWPAGER.
059560* X MUST POINT TO START OF PRINT DX LIST.
059580* NOTE THAT THIS SUBROUTINE CHANGES X.
059600**********************************************************
059620
059640 PRINTLINE-BUILD.
059660*    *DOES NOT BLANK OUT LINE TO START - TO ALLOW 'ACROSS'*.
059680     ENTER MACRO IQGETI.
059700     IF ELEM-INSTR = 0 OR ELEM-INSTR = RPTHEAD-STOPPER
059720         GO TO PRINTLINE-BUILD-EXIT.
059740     IF ELEM-INSTR GREATER THAN 0 GO TO PRINTLINE-BUILD3.
059760     GO TO PRINTLINE-BUILD2.
059780
059800
059820 PRINTLINE-BUILD1.
059840     SET X UP BY 1.
059860     ENTER MACRO IQGETI.
059880     IF ELEM-INSTR = 0 OR ELEM-INSTR = RPTHEAD-STOPPER
059890         MOVE PRINT-POS TO LINE-LENGTH
059900         ADD CURR-HSPACE TO PRINT-POS
059920         GO TO PRINTLINE-BUILD-EXIT.
059924*    *CUT OFF IF OVERFLOWING LINE.
059928     IF PRINT-POS > RMARGIN GO TO PRINTLINE-BUILD1.
059940
059960 PRINTLINE-BUILD2.
059980*    *A NEGATIVE QTY IS A NEW SPACING VALUE OF - ( QTY + 1 );
060000*    *  IE -2 IS A SPACING VALUE OF 1, AND -1 IS REALLY 0*.
060020     IF ELEM-INSTR LESS THAN 0
060040         SUBTRACT ELEM-INSTR FROM CONST-1 GIVING CURR-HSPACE
060060         GO TO PRINTLINE-BUILD1.
060080     ADD CURR-HSPACE TO PRINT-POS.
060100
060120 PRINTLINE-BUILD3.
060140     SET DX TO ELEM-INSTR.
060160     ENTER MACRO IQGETD.
060180     PERFORM GETN-VALUE THRU  GET-VALUE-EXIT.
060200     IF TRUE-TYPEV NOT = 1 GO TO PRINTLINE-BUILD4.
060220*    *FOR ALPHA ITEMS, IF NOT EDITED, MOVE DIRECTLY FROM
060240*     AHOLDER TO PRINT-LINE*
060260     IF TRUE-TYPEV = 10 OR ELEM-D-NCHAR = ELEM-D-ECHAR
060280         ENTER MACRO IQSX66 USING ELEM-D-NCHAR
060300             AHOLDER CONST1 PRINT-LINE PRINT-POS
060320     ELSE ENTER MACRO IQPICT
060340         ENTER MACRO IQSX66 USING ELEM-D-ECHAR
060360             PICT-WORK CONST1 PRINT-LINE PRINT-POS.
060380*    *IF TITLING ALLOW FOR GREATER OF TITLE OR EDITED ITEM LENGTH*.
060390     IF TITLE-FLAG NOT = 1
060400         OR ELEM-D-ECHAR GREATER THAN ELEM-D-TCHAR
060420         ADD ELEM-D-ECHAR TO PRINT-POS
060440         ELSE ADD ELEM-D-TCHAR TO PRINT-POS.
060460     GO TO PRINTLINE-BUILD1.
060480
060500 PRINTLINE-BUILD4.
060520*===*EXPAND BELOW FOR LONGER THAN 72 LITERALS====*.
060540     IF ELEM-D-TYPEV NOT = 10 GO TO PRINTLINE-BUILD5.
060560*    *NEXT STMNT TREATS NULL (0 LGTH) LITERAL*
060580     IF ELEM-D-NCHAR = 0 GO TO PRINTLINE-BUILD1.
060600     ENTER MACRO IQSX66 USING ELEM-D-NCHAR
060620         ELEM-L-VALUE CONST1 PRINT-LINE PRINT-POS
060640         ADD ELEM-D-NCHAR TO PRINT-POS
060660         GO TO PRINTLINE-BUILD1.
060680
060700 PRINTLINE-BUILD5.
060720*    *ADJUST PRINT POSITION IF TITLE LONGER THAN ITEM*.
060740     SUBTRACT ELEM-D-ECHAR FROM ELEM-D-TCHAR GIVING J.
060750     IF TITLE-FLAG = 1
060760         IF J GREATER THAN 0 ADD J TO PRINT-POS.
060780     ENTER MACRO IQPICT.
060800     ENTER MACRO IQSX66 USING ELEM-D-ECHAR
060820         PICT-WORK CONST1 PRINT-LINE PRINT-POS.
060840     ADD ELEM-D-ECHAR TO PRINT-POS.
060860     GO TO PRINTLINE-BUILD1.
060880
060900 PRINTLINE-BUILD-EXIT.
060920     EXIT.
060940
060960**********************************************************
060980* SERVICE SUBROUTINE TO DO MULTIPLE VERTICAL SPACING
061000* ON CONSOLE.  ARGUMENT IS IN I; IT IS DESTROYED.
061020**********************************************************
061040
061060 DISPLAY-VSPACE.
061090     IF I > 0
061080         ENTER MACRO IQTVSP USING I.
061100*    IF I NOT GREATER THAN 0 GO TO DISPLAY-VSPACE-EXIT.
061120*    DISPLAY ' ' UPON CONSOLE.
061140*    SUBTRACT 1 FROM I.  GO TO DISPLAY-VSPACE.
061160
061180 DISPLAY-VSPACE-EXIT.
061200     EXIT.
061220
061240**********************************************************
061260*  HSPACE VSPACE LMARGIN RMARGIN ACROSS INSTRUCTIONS
061280*  -ALL ARE 2 WORD INSTRUCTIONS-
061300*    FORMAT:
061320*      (X) =       INSTRUCTION;  VALUES ARE:
061340*                  18 = HSPACE
061360*                  19 = VSPACE
061380*                  20 = LMARGIN
061400*                  21 = RMARGIN
061420*                  22 = ACROSS
061440*                  44 = PAGELINE-SET
061460*                  45 = FORMLINE-SET
061480*      (X+1):   CONSTANT
061500**********************************************************
061520
061540 HSPACER.
061560     ENTER MACRO IQGETI.
061580*    *VALUE FOR HSPACE IS - ( CONST + 1 ) SINCE 0 IS VALID.
061600*    * IE: TRUE VALUE 2 IS PASSED AS -3.
061620     ADD 1 TO ELEM-INSTR.
061640     SUBTRACT ELEM-INSTR FROM 0 GIVING ELEM-INSTR.
061660     MOVE ELEM-INSTR TO HSPACE.
061680     GO TO NEXT-INSTR-UPX.
061700
061720 VSPACER.
061740     ENTER MACRO IQGETI.
061760     MOVE ELEM-INSTR TO VSPACE.
061780     GO TO NEXT-INSTR-UPX.
061800
061820 LMARGINER.
061840     ENTER MACRO IQGETI.
061860     MOVE ELEM-INSTR TO LMARGIN.
061880     GO TO NEXT-INSTR-UPX.
061900
061920 RMARGINER.
061940     ENTER MACRO IQGETI.
061960     MOVE ELEM-INSTR TO RMARGIN.
061980     GO TO NEXT-INSTR-UPX.
062000
062020 ACROSSER.
062040     ENTER MACRO IQGETI.
062060     MOVE ELEM-INSTR TO ACROSS-CONTROL.
062080     GO TO NEXT-INSTR-UPX.
062100
062120 PAGELINE-SET.
062140     ENTER MACRO IQGETI.
062160     MOVE ELEM-INSTR TO PAGE-LINES.
062180*    *MAKE SURE PAGE-LINES DO NOT GET BIGGER THAN FORM-LINES*
062200     IF ELEM-INSTR GREATER THAN FORM-LINES
062220         MOVE ELEM-INSTR TO FORM-LINES.
062240     GO TO NEXT-INSTR-UPX.
062260
062280 FORMLINE-SET.
062300     ENTER MACRO IQGETI.
062320     MOVE ELEM-INSTR TO FORM-LINES.
062340*     *MAKE SURE PAGE-LINES ARE NOT LEFT GREATER THAN FORM-LINES*
062360     IF PAGE-LINES GREATER THAN ELEM-INSTR
062380         MOVE ELEM-INSTR TO PAGE-LINES.
062400     GO TO NEXT-INSTR-UPX.
062420
062440**********************************************************
062460* REPORT INSTRUCTION
062480*   FORMAT:  (X)   = INSTRUCTION VALUE 23
062500*            (X+1) = DX OF R-ENTRY FOR REFERENCED REPORT
062520**********************************************************
062540
062560 REPORTER.
062570     MOVE ELEM-RPTHEADX TO I.
062580*    *SAVE CURRENT REPORT PARAMS UNLESS STARTING OFF*
062600     IF REPORT-DX NOT = 0 SET DX TO REPORT-DX
062620         MOVE ELEM-R-ENTRY TO ELEM-D-ENTRY
062640         ENTER MACRO IQPUTD.
062660     ENTER MACRO IQGETI.
062680     MOVE ELEM-INSTR TO REPORT-DX.
062700     SET DX TO ELEM-INSTR.
062720     ENTER MACRO IQGETD.
062740     MOVE ELEM-D-ENTRY TO ELEM-R-ENTRY.
062750     IF ELEM-RPTHEADX = 0 MOVE I TO ELEM-RPTHEADX.
062760     GO TO NEXT-INSTR-UPX.
062780
062800**********************************************************
062820* RPTHEAD INSTRUCTION
062840*  FORMAT:
062860*    (X):      INSTRUCTION VALUE 24.
062880*    (X+1):    X OF NEXT INSTRUCTION (DX LIST BYPASS).
062900*    (X+2):    START OF DX LIST. END OF LIST MARKED BY 0.
062920**********************************************************
062940
062960 RPTHEADER.
062980     ENTER MACRO IQGETI.
063000     SET X UP BY 1.
063020     SET ELEM-RPTHEADX TO X.
063040     SET X TO ELEM-INSTR.
063060     MOVE 1 TO HEADING-FLAG.
063080     GO TO NEXT-INSTR.
063100
063120*********************************************************
063140* NEWPAGE INSTRUCTION
063160* FORMAT:   (X)   = INSTRUCTION VALUE 25.
063180*           (X+1) = NEXT INSTRUCTION
063200*
063220* REFERS TO A REPORT HEADING DX LIST WHOSE ORIGIN (X)
063240* HAS BEEN PREVIOUSLY PLANTED IN ELEM-RPTHEADX BY A
063260* 'RPTHEAD' INSTRUCTION OR BY ANALYSIS IF THERE IS
063280* ONLY 1 REPORT IN THE QUERY.
063300* FORMAT OF THE RPTHEAD DX LIST IS:
063320*     (X)   = START OF DX LIST WITH VALUES:
063340*       DX = 0 : END OF LIST.
063360*       DX = 90902 : START A NEW LINE (CENTERED).
063380*       DX > 0 AND NOT 90902 : REGULAR DX.
063400*       DX < 0 : SPACING CONSTANT WHOSE VALUE IS
063420*                   - (MAGNITUDE + 1), IE -2 IS REALLY 1.
063440* NOTE FORMAT OF RPTHEAD DX LIST IS EXACTLY THE
063460* SAME AS FOR DX LIST IN 'PRINT' COMMAND EXCEPT THAT
063480* 'PRINT' DOES NOT RECOGNIZE HIGH-VALUES.
063500*
063520* NOTE THAT NEWPAGE DOES -NOT- TURN AUTOMATIC PAGING ON.
063540**********************************************************
063560
063580 NEWPAGE.
063600     PERFORM NEWPAGER THRU NEWPAGER-EXIT.
063620     GO TO NEXT-INSTR.
063640
063660 NEWPAGER.
063664*    *HOLD ONTO TITLE-FLAG, THEN RESET
063668*    * IT SO IT DOESNT AFFECT BUILDING OF HEADING LINES*
063672     MOVE TITLE-FLAG TO HOLD-TITLE-FLAG.
063676     MOVE 0 TO TITLE-FLAG.
063680*    *IF THIS NEW PAGE IS THE FIRST ACTION IN A MULTIPLE
063700*     REPORT, PUMP OUT HEADER*
063720     IF ( ELEM-RPT-NO GREATER THAN 1
063740         OR ACROSS-CONTROL GREATER THAN 1 )
063760         AND ELEM-PAGE-NO = 0
063780         MOVE DISPLAY-FLAG  TO QTE-DISPLAY-FLAG
063800         MOVE PRINT-FLAG    TO QTE-PRINT-FLAG
063820         MOVE PAGE-LINES    TO QTE-PAGE-LINES
063840         MOVE FORM-LINES    TO QTE-FORM-LINES
063860         MOVE ELEM-RPT-NO   TO QTE-RPT-NO
063880         MOVE 0 TO QTE-PAGE-NO QTE-LINE-NO
063900         MOVE 1 TO CALL-IQM-FLAG
063920         WRITE QTEXEC-REC ADD 1 TO QTEXEC-COUNT.
063940
063960*    *NOW PROCESS HEADING, IF ANY*
063980     MOVE 3 TO ELEM-LAST-PRINTYPE.
064000     SET SAVEX TO X.
064020     MOVE SPACES TO WORK-LINE.
064040     IF ELEM-PAGE-NO = 0 MOVE 1 TO ELEM-PAGE-NO.
064060     IF HEADING-FLAG NOT = 1 MOVE 0 TO ELEM-INSTR
064080         GO TO NEWPAGER2.
064100     MOVE ELEM-PAGE-NO TO DISPLAY-PAGENO.
064120     ADD 1 TO ELEM-PAGE-NO.
064140
064160*    *SET UP TOP LINE*
064180     MOVE SPACES TO WORK-LINE.
064200
064220*    *SET UP DATE IN HEADING*
064240     IF ELEM-RPTDATE = 0 GO TO NEWPAGER1.
064260     IF ELEM-RPTDATE LESS THAN 0
064280         MOVE TODAY1 TO RPTMASK3
064300         MOVE TODAY2 TO RPTMASK1
064320         MOVE TODAY3 TO RPTMASK2
064340         ENTER MACRO IQSX66 USING CONST8
064360             RPTMASK CONST1 WORK-LINE LMARGIN
064380         GO TO NEWPAGER1.
064400*    *TREAT ITEM OR CONSTANT VALUE SUPPLIED AS DATE*
064420     SET DX TO ELEM-RPTDATE.
064440     ENTER MACRO IQGETD.
064460     IF ELEM-D-TYPEV = 10
064480         ENTER MACRO IQSX66 USING ELEM-D-NCHAR
064500             ELEM-L-VALUE CONST1 WORK-LINE LMARGIN
064520         GO TO NEWPAGER1.
064540     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
064560     IF ELEM-D-TYPEV = 9 MOVE 8 TO ELEM-D-ECHAR
064580         MOVE '99/99/99' TO ELEM-D-PICT.
064600     ENTER MACRO IQPICT.
064620     ENTER MACRO IQSX66 USING ELEM-D-ECHAR
064640         PICT-WORK CONST1 WORK-LINE LMARGIN.
064660
064680 NEWPAGER1.
064700     SUBTRACT CONST8 FROM RMARGIN GIVING I.
064720     ENTER MACRO IQSX66 USING CONST9
064740         DISPLAY-PAGE CONST1 WORK-LINE I.
064760
064780
064800*    *PICK UP POINTER TO REPORT HEADING DX LIST -
064820*    *WHICH WAS PREVIOUSLY PLANTED BY RPTHEAD INSTRUCTION*.
064840     IF ELEM-RPTHEADX = 0 MOVE 0 TO ELEM-INSTR GO TO NEWPAGER2.
064860     SET X TO ELEM-RPTHEADX.
064880     ENTER MACRO IQGETI.
064900     IF ELEM-INSTR = 0 GO TO NEWPAGER2.
064920     MOVE 1 TO PRINT-POS.
064940*    *NOW BUILD CENTER PART OF HEADING*.
064960     MOVE HSPACE TO CURR-HSPACE.
064980     MOVE SPACES TO PRINT-LINE.
065000     PERFORM PRINTLINE-BUILD THRU PRINTLINE-BUILD-EXIT.
065020*    *CALCULATE CENTER OF PAGE.
065040     ADD LMARGIN RMARGIN CONST2 GIVING I.
065060     SUBTRACT LINE-LENGTH FROM I.
065080     IF I LESS THAN 2 MOVE 2 TO I
065084        COMPUTE LINE-LENGTH = RMARGIN + 1 - LMARGIN.
065100     DIVIDE 2 INTO I GIVING I.
065120     ENTER MACRO IQSX66 USING LINE-LENGTH PRINT-LINE
065140         CONST1 WORK-LINE I.
065160
065180
065200 NEWPAGER2.
065220*    *OUTPUT FIRST LINE, GOING TO TOP OF PAGE*.
065240*    *HANDLE POSSIBLE MULTIPLE REPORT*.
065260     IF ELEM-RPT-NO > 1 OR ACROSS-CONTROL > 1
065280         MOVE ELEM-RPT-PARAMS TO QTE-RPT-PARAMS
065300         MOVE -1 TO QTE-ACROSS
065320         MOVE 1 TO QTE-PRINTX
065340         MOVE LMARGIN TO QTE-PRINTPOS
065360         MOVE 0 TO QTE-VSPACE
065380         MOVE WORK-LINE TO QTE-IMAGE
065400         WRITE QTEXEC-REC ADD 1 TO QTEXEC-COUNT
065420         GO TO NEWPAGER3.
065440     IF PRINT-FLAG = 1 WRITE QLEXEC-REC FROM WORK-LINE
065460         AFTER ADVANCING TOP-OF-PAGE ADD 1 TO LINES-IN-PHASE.
065480     IF DISPLAY-FLAG = 1
065500         SUBTRACT ELEM-LINE-NO FROM FORM-LINES GIVING I
065520         PERFORM DISPLAY-VSPACE THRU DISPLAY-VSPACE-EXIT
065540         MOVE RMARGIN TO TERM-CHARS
065548         PERFORM DISPLAY-WORK-LINE.
065560 NEWPAGER3.
065580     MOVE 1 TO ELEM-LINE-NO.
065600*    *TRICK PRINT SEQUENCE INTO DOING TITLES 1ST TIME THIS PAGE*.
065620     MOVE 0 TO ELEM-LAST-PRINTX.
065640
065660 NEWPAGER-LOOP.
065680     IF ELEM-INSTR = 0 GO TO NEWPAGER-DONE.
065700     SET X UP BY 1.
065720*    *HERE IF BUILDING NON-FIRST LINE OF RPTHEAD*
065740     MOVE 1 TO PRINT-POS CURR-HSPACE.
065760     MOVE SPACES TO PRINT-LINE.
065780     PERFORM PRINTLINE-BUILD THRU PRINTLINE-BUILD-EXIT.
065800     ADD LMARGIN RMARGIN CONST2 GIVING I.
065820     SUBTRACT LINE-LENGTH FROM I.
065824     IF I LESS THAN 2 MOVE 2 TO I
065828         COMPUTE LINE-LENGTH = RMARGIN + 1 - LMARGIN.
065840     DIVIDE 2 INTO I GIVING I.
065860     MOVE SPACES TO WORK-LINE.
065880     ENTER MACRO IQSX66 USING LINE-LENGTH
065900         PRINT-LINE CONST1 WORK-LINE I.
065920     IF ELEM-RPT-NO > 1 OR ACROSS-CONTROL > 1
065940         MOVE 1 TO QTE-VSPACE
065960         ADD 1 TO QTE-LINE-NO
065980         MOVE WORK-LINE TO QTE-IMAGE
066000         WRITE QTEXEC-REC ADD 1 TO QTEXEC-COUNT
066020         ADD 1 TO ELEM-LINE-NO
066040         GO TO NEWPAGER-LOOP.
066060     IF PRINT-FLAG = 1 WRITE QLEXEC-REC FROM WORK-LINE
066080         AFTER ADVANCING 1 LINES ADD 1 TO LINES-IN-PHASE.
066100     IF DISPLAY-FLAG = 1
066104         ADD I PRINT-POS GIVING TERM-CHARS
066108         PERFORM DISPLAY-WORK-LINE.
066120     ADD 1 TO ELEM-LINE-NO.
066140     GO TO NEWPAGER-LOOP.
066160
066180 NEWPAGER-DONE.
066182*    *RESTORE TITLE FLAG*.
066184     MOVE HOLD-TITLE-FLAG TO TITLE-FLAG.
066200     MOVE 1 TO NEWPAGE-FLAG.
066220     SET X TO SAVEX.
066240     MOVE SPACES TO PRINT-LINE.
066260     IF ELEM-RPT-NO > 1 OR ACROSS-CONTROL > 1
066280         MOVE 1 TO QTE-VSPACE
066300         ADD 1 TO QTE-LINE-NO
066320         MOVE SPACES TO QTE-IMAGE
066340         WRITE QTEXEC-REC ADD 1 TO QTEXEC-COUNT
066360         GO TO NEWPAGER-EXIT.
066380     IF PRINT-FLAG = 1
066400         WRITE QLEXEC-REC FROM PRINT-LINE
066420         AFTER ADVANCING 1 LINES ADD 1 TO LINES-IN-PHASE.
066440     IF DISPLAY-FLAG = 1 DISPLAY ' ' UPON CONSOLE.
066450     ADD 1 TO ELEM-LINE-NO.
066460
066480 NEWPAGER-EXIT.
066500     EXIT.
066520
066540*******************************************************
066560*  VARIOUS 1 WORD CONTROL INSTRUCTIONS (SEE LIST BELOW)
066580*    FORMAT:
066600*       (X)  =    INSTRUCTION;  VALUES ARE:
066620*                 26 = PAGING ON
066640*                 27 = PAGING OFF
066660*                 28 = HEADING ON
066680*                 29 = HEADING OFF
066700*                 30 = TITLES ON
066720*                 31 = TITLES OFF
066740*                 32 = SUMMARY PRINT ON
066760*                 33 = SUMMARY PRINT OFF
066780*                 34 = DISPLAY ON
066800*                 35 = DISPLAY OFF
066820*                 36 = PRINT ON
066840*                 37 = PRINT OFF
066860*                 38 = REPORTDATE ON
066880*                 39 = REPORTDATE OFF
066900**********************************************************
066920
066940 PAGING-ON.
066960     MOVE 1 TO PAGING-FLAG.
066980     GO TO NEXT-INSTR.
067000
067020 PAGING-OFF.
067040     MOVE 0 TO PAGING-FLAG.
067060     GO TO NEXT-INSTR.
067080
067100 HEADING-ON.
067120     MOVE 1 TO HEADING-FLAG.
067140     GO TO NEXT-INSTR.
067160
067180 HEADING-OFF.
067200     MOVE 0 TO HEADING-FLAG.
067220     GO TO NEXT-INSTR.
067240
067260 TITLES-ON.
067280     MOVE 1 TO TITLE-FLAG.
067300     GO TO NEXT-INSTR.
067320
067340 TITLES-OFF.
067360     MOVE 0 TO TITLE-FLAG.
067380     GO TO NEXT-INSTR.
067400
067420 SUMPRINT-ON.
067440     MOVE 1 TO SUMPRINT-FLAG.
067460     GO TO NEXT-INSTR.
067480
067500 SUMPRINT-OFF.
067520     MOVE 0 TO SUMPRINT-FLAG.
067540     GO TO NEXT-INSTR.
067560
067580 DISPLAY-ON.
067600     MOVE 1 TO DISPLAY-FLAG.
067620     GO TO NEXT-INSTR.
067640
067660 DISPLAY-OFF.
067680     MOVE 0 TO DISPLAY-FLAG.
067700     GO TO NEXT-INSTR.
067720
067740 PRINT-ON.
067760     MOVE 1 TO PRINT-FLAG.
067780     GO TO NEXT-INSTR.
067800
067820 PRINT-OFF.
067840     MOVE 0 TO PRINT-FLAG.
067860     GO TO NEXT-INSTR.
067880
067900 RPTDATE-ON.
067920     MOVE -1 TO ELEM-RPTDATE.
067940     GO TO NEXT-INSTR.
067960
067980 RPTDATE-OFF.
068000     MOVE 0 TO ELEM-RPTDATE.
068020     GO TO NEXT-INSTR.
068040
068060**********************************************************
068080* REPORTDATE  VALUE  INSTRUCTION
068100*  FORMAT:
068120*    (X):    INSTRUCTION VALUE 70.
068140*    (X+1):  DX POINTING TO CONSTANT, VARIABLE, OR DATA
068160*            ITEM WHOSE VALUE IS TO BECOME THE REPORT
068180*            DATE. THE DX IS PLANTED IN ELEM-RPTDATE
068200*            AND THE NEWPAGE LOGIC USES IT TO GET THE CURRENT
068220*            VALUE OF THAT ITEM WHEN IT DOES ITS THING*
068240*    (X+2):  NEXT INSTRUCTION.
068260**********************************************************
068280
068300 RPTDATE-SET.
068320     ENTER MACRO IQGETI.
068340*    *SET DX POINTER FOR NEW PAGE REFERENCE*
068360     MOVE ELEM-INSTR TO ELEM-RPTDATE.
068380     GO TO NEXT-INSTR-UPX.
068400
068420********************************************************
068440* PAGE-SET INSTRUCTION
068460*  FORMAT:  (X):   INSTRUCTION VALUE 46
068480*           (X+1): DX POINTING TO ITEM WHOSE VALUE BECOMES PAGE #
068500********************************************************
068520
068540 PAGE-SET.
068560     ENTER MACRO IQGETI.
068580     SET DX TO ELEM-INSTR.
068600     ENTER MACRO IQGETD.
068620     PERFORM GETB-VALUE THRU GET-VALUE-EXIT.
068640*    *ALPHAS ARE NOT PERMITTED (BECAUSE WE INCREMENT); SET TO 0*
068660     IF NHOLDER-TYPE = 1 MOVE 0 TO ELEM-PAGE-NO
068680         GO TO NEXT-INSTR-UPX.
068700*    *IF NOT AN INTEGER, MAKE IT ONE (SO CAN USE VARIABLES)*
068720     IF NHOLDER-SCALE NOT = 0
068740         SET PTX TO NHOLDER-SCALE
068760         DIVIDE 10EX (PTX) INTO BHOLDER GIVING BHOLDER.
068780     MOVE BHOLDER TO ELEM-PAGE-NO.
068800     GO TO NEXT-INSTR-UPX.
068820
068840*****************************************************
068860*  HOLD INSTRUCTION.
068880*    FORMAT:
068900*      (X)   =  INSTRUCTION  VALUE 40
068920*      (X+1) =  DX OF SOURCE ITEM.
068940*      (X+2) =  DX OF TARGET ITEM.
068960*               ABOVE CONTINUES IN PAIRS UNTIL DX OF
068980*               SOURCE ITEM IS ZERO, SIGNIFYING END OF
069000*               LIST AND THAT NEXT INSTR (X) IS NEXT.
069020*               INSTRUCTION.
069040*
069060* NOTE: CUSTOM MOVES WOULD BE FASTER THAN USING GET-VALUE,
069080* BUT LATTER USED HERE ONLY TO REDUCE CORE*.
069100*****************************************************
069120
069140 HOLDER.
069160     ENTER MACRO IQGETI.
069180     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
069200     SET DX TO ELEM-INSTR.
069220     ENTER MACRO IQGETD.
069240     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
069260     SET X UP BY 1.
069280     ENTER MACRO IQGETI.
069300     SET DX TO ELEM-INSTR.
069320     ENTER MACRO IQGETD.
069340     SET X UP BY 1.
069360     PERFORM SET-VALUE THRU SET-VALUE-EXIT.
069380     GO TO HOLDER.
069400
069420****************************************************
069440*  RESET INSTRUCTION.
069460*     FORMAT:
069480*      (X)   =  INSTRUCTION  VALUE 41
069500*      (X+1) =  DX OF ITEM TO BE RESET.
069520*               ABOVE CONTINUES UNTIL INSTR (X) IS
069540*               0; SIGNIFYING END OF LIST AND THAT
069560*               NEXT INSTR (X) IS NEXT INSTRUCTION.
069580*
069600* NOTE: CUSTOM MOVES WOULD BE FASTER THAN USING GET-VALUE,
069620* BUT LATTER USED HERE ONLY TO REDUCE CORE*.
069640*****************************************************
069660
069680 RESETTER.
069700     ENTER MACRO IQGETI.
069720     IF ELEM-INSTR = CONST0
069740         GO TO NEXT-INSTR-UPX.
069760     SET DX TO ELEM-INSTR.
069780     ENTER MACRO IQGETD.
069800     DIVIDE CONST100 INTO ELEM-D-TYPEV GIVING FILE-ROUTER
069820         REMAINDER TRUE-TYPEV.
069840     SET X UP BY 1.
069860     MOVE ELEM-D-SCALE TO NHOLDER-SCALE.
069880     IF TRUE-TYPEV = 2 MOVE 0 TO NHOLDER
069900         MOVE 2 TO NHOLDER-TYPE
069920         PERFORM SET-VALUE THRU SET-VALUE-EXIT GO TO RESETTER.
069940     IF TRUE-TYPEV = 6 OR 7 OR 8 MOVE 0 TO BHOLDER
069960         MOVE 6 TO NHOLDER-TYPE
069980         PERFORM SET-VALUE THRU SET-VALUE-EXIT GO TO RESETTER.
070000*    *BLANK OUT ANY NO. OF TARGET CHARACTERS*
070020     MOVE SPACES TO AHOLDER.
070022*    *IN CASE OF VERY LONG ITEM, BLANK OUT ALL OF AHOLDER.
070024     IF ELEM-D-NCHAR > 54 MOVE SPACES TO AHOLDER-EXTENSION1
070028         AHOLDER-EXTENSION2 AHOLDER-EXTENSION3.
070040     MOVE 1 TO NHOLDER-TYPE.
070060     PERFORM SET-VALUE THRU SET-VALUE-EXIT.
070080     GO TO RESETTER.
070100
070120**********************************************************
070140*  SET INSTRUCTION
070160*     FORMAT:     X    = INSTRUCTION VALUE 42
070180*                 X+1  = DX OF SOURCE ITEM.
070200*                 X+2  = DX OF TARGET ITEM.
070220*                        ABOVE CONTINUES IN PAIRS
070240*                        UNTIL DX OF SOURCE ITEM = 0.
070260*
070280* NOTE: CUSTOM MOVES WOULD BE FASTER THAN GET-VALUE, BUT
070300* LATTER USED HERE ONLY TO REDUCE CORE.
070320**********************************************************
070340
070360 SETTER.
070380     ENTER MACRO IQGETI.
070400     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
070420     SET DX TO ELEM-INSTR.
070440     ENTER MACRO IQGETD.
070460     PERFORM GET-VALUE THRU GET-VALUE-EXIT.
070480     SET X UP BY 1.
070500     ENTER MACRO IQGETI.
070520     SET DX TO ELEM-INSTR.
070522     MOVE ELEM-D-NCHAR TO I.
070521*    *SAVE SOURCE NO. OF CHARS.
070540     ENTER MACRO IQGETD.
070544*    *SEE IF WE HAVE A LONG ITEM BEING SET BY A SHORT ONE*.
070548     IF ELEM-D-NCHAR < 54 GO TO SETTER1.
070552     IF I NOT LESS THAN ELEM-D-NCHAR GO TO SETTER1.
070556*    *YES - BLANK OUT EXCESS IN AHOLDER EXTENSIONS.
070558     ADD 1 TO I.
070560     SUBTRACT I FROM ELEM-D-NCHAR GIVING WORKX.
070568     ENTER MACRO IQSXB6 USING WORKX AHOLDER I.
070572
070576 SETTER1.
070578     PERFORM SET-VALUE THRU SET-VALUE-EXIT.
070580     SET X UP BY 1.
070600     GO TO SETTER.
070620
070640
070660**********************************************************
070680*  COMPUTE INSTRUCTION.
070700*     FORMAT:  X    = INSTRUCTION:  VALUE 43.
070720*              X+1  = DX WHERE FINAL RESULT GOES.
070740*              X+2  = BEGINNING OF COMPUTE STACK. THIS IS
070760*                     IN IRISH (MODIFIED POLISH) NOTATION:
070780*                     ITEM, OPERATOR, ITEM, OPERATOR ...
070800*                     WHERE VALUES OF ITEMS ARE:
070820*                      (A) -1 REFERS TO TOP
070840*                          VALUE IN TEMP STACK. REFERING
070860*                          TO IT RETRIEVES VALUE AND
070880*                          DROPS TEMP STACK REF BY 1;
070900*                          IT IS AN EFFECTIVE 'POP'.
070920*                      (B) -2 REFERS TO VALUE 1 DOWN
070940*                          FROM TOP OF STACK. STACK REF.
070960*                          IS NOT CHANGED.
070980*                      (C) ANY OTHER ITEM VALUE IS
071000*                          A NORMAL DX VALUE.
071020*                     AND VALUES OF OPERATORS ARE:
071040*                      0 = MOVE ACCUM TO FINAL RESULT
071060*                          AND END STACK.
071080*                      1 = ADD NEXT ITEM TO ACCUM.
071100*                      2 = SUBTRACT NEXT ITEM FROM ACCUM.
071120*                      3 = MULTIPLY ACCUM BY NEXT ITEM.
071140*                      4 = DIVIDE NEXT ITEM INTO ACCUM.
071160*                      5 = PUSH ACCUM INTO TEMP REGISTER
071180*                          STACK AND KICK REF TO STACK;
071200*                          MOVE NEXT ITEM TO ACCUM.
071220*
071240*  ALL OPERATIONS ARE FIXED POINT DOUBLE WORD BINARY.
071260*
071280*  EXAMPLE OF PARSING:
071300*
071320*  W=((A+(B/C))*D)-(E*(F+G))+H+((I*J*K)/(L-M)) $
071340*
071360*    GIVES COMPUTE STACK IN IRISH NOTATION:
071380*
071400*  B/C+A*D^F+G*E+H+!^L-M^I*J*K/!+!=
071420*
071440*    WHERE ^ MEANS 'PUSH' AND ! MEANS 'LAST PUSHED VALUE'.
071460**********************************************************
071480
071500 COMPUTE-IT.
071520*    *INITIALIZE COMPUTE STACK.
071540     MOVE 0 TO OVERFLOW-FLAG.
071560     SET TX TO 0.
071580     ENTER MACRO IQGETI.
071600     MOVE ELEM-INSTR TO TARGET-DX.
071620
071640 COMPUTE-KICKOFF.
071660*    *LOAD FIRST OPERAND INTO EFFECTIVE ACCUMULATOR: ACCUM.
071680     SET X UP BY 1.
071700     ENTER MACRO IQGETI.
071720     IF ELEM-INSTR = 0 GO TO COMPUTE-DONE.
071740     SET DX TO ELEM-INSTR.
071760     ENTER MACRO IQGETD.
071780     PERFORM GETB-VALUE THRU GET-VALUE-EXIT.
071800     IF NHOLDER-TYPE = 1 PERFORM ILLEGAL-ALPHA MOVE 0 TO BHOLDER.
071820     MOVE BHOLDER TO ACCUM.
071840     MOVE ELEM-D-SCALE TO ACCUM-SCALE.
071860
071880 COMPUTE-LOOP.
071900*    *GET NEXT OPERATOR AND OPERAND.
071920     SET X UP BY 1.
071940     ENTER MACRO IQGETI.
071960     IF ELEM-INSTR = 0 GO TO COMPUTE-DONE.
071980     IF ELEM-INSTR = 5 GO TO PUSHER.
072000     MOVE ELEM-INSTR TO OPERATION.
072020     SET X UP BY 1.
072040     ENTER MACRO IQGETI.
072060*    *LOOK TO SEE IF GETTING LEGITIMATE DX ENTRIES
072080*    * OR POPPING FROM STACK.
072100     IF ELEM-INSTR GREATER THAN 0
072120         SET DX TO ELEM-INSTR
072140         ENTER MACRO IQGETD
072160         PERFORM GETB-VALUE THRU GET-VALUE-EXIT
072180         GO TO COMPUTE-TESTER
072200       ELSE IF ELEM-INSTR = -1
072220         MOVE TEMP (TX) TO BHOLDER
072240         MOVE TSCALE (TX) TO ELEM-D-SCALE
072260         MOVE 6 TO NHOLDER-TYPE
072280         SET TX DOWN BY 1
072300         GO TO COMPUTE-ROUTER
072320       ELSE 
072324         MOVE TEMP (TX) TO SAVE-BHOLDER
072328         MOVE TSCALE (TX) TO SAVE-SCALE
072332         SET TX DOWN BY 1
072340         MOVE TEMP (TX) TO BHOLDER
072360         MOVE TSCALE (TX) TO ELEM-D-SCALE
072364         MOVE SAVE-BHOLDER TO TEMP (TX)
072368         MOVE SAVE-SCALE TO TSCALE (TX)
072400         MOVE 6 TO NHOLDER-TYPE
072420         GO TO COMPUTE-ROUTER.
072440 COMPUTE-TESTER.
072460     IF NHOLDER-TYPE = 1 PERFORM ILLEGAL-ALPHA MOVE 0 TO BHOLDER.
072480 COMPUTE-ROUTER.
072500     GO TO ADDER ADDER MULTIPLIER DIVIDER PUSHER
072520         DEPENDING ON OPERATION.
072540     MOVE 09 TO ERROR-CODE. GO TO ABORT-RUN.
072560
072580 ADDER.
072600     IF ELEM-D-SCALE = ACCUM-SCALE GO TO ADDER1.
072620*    *IF SCALES DIFFER, SCALE LOWER LEFT TO HIGHER*.
072640     IF ELEM-D-SCALE GREATER THAN ACCUM-SCALE
072660         SUBTRACT ACCUM-SCALE FROM ELEM-D-SCALE GIVING K
072680         MOVE ELEM-D-SCALE TO ACCUM-SCALE
072700         SET PTX TO K
072720         MOVE 10EX (PTX) TO WORK-2
072740         ENTER MACRO IQDMUL USING ACCUM WORK-2 OVERFLOW-FLAG
072760         IF OVERFLOW-FLAG NOT = 0
072780             DISPLAY '%Add shift overflow' UPON CONSOLE
072790             PERFORM ACCUM-ZERO GO TO COMPUTE-LOOP
072800             ELSE GO TO ADDER1.
072820     SUBTRACT ELEM-D-SCALE FROM ACCUM-SCALE GIVING K.
072840     SET PTX TO K.
072860     MOVE 10EX (PTX) TO WORK-2.
072880     ENTER MACRO IQDMUL USING BHOLDER WORK-2 OVERFLOW-FLAG.
072900     IF OVERFLOW-FLAG NOT = 0
072920         DISPLAY '%Add shift overflow' UPON CONSOLE
072930         PERFORM ACCUM-ZERO GO TO COMPUTE-LOOP.
072940
072960 ADDER1.
072980*    *NOW ADD OR SUBTRACT*
073000     IF OPERATION = 2 GO TO SUBTRACTER1.
073020     ADD BHOLDER TO ACCUM ON SIZE ERROR GO TO ADD-FAULT.
073040     GO TO COMPUTE-LOOP.
073060
073080 SUBTRACTER1.
073100     SUBTRACT BHOLDER FROM ACCUM ON SIZE ERROR 
073102         GO TO ADD-FAULT.
073120     GO TO COMPUTE-LOOP.
073140
073160 ADD-FAULT.
073180     DISPLAY '%Add overflow' UPON CONSOLE.
073180     PERFORM ACCUM-ZERO.
073200     GO TO COMPUTE-LOOP.
073220
073240
073260 MULTIPLIER.
073280*    *DO ASS'Y LANGUAGE DOUBLE PRECISION MULTIPLY*
073300     ENTER MACRO IQDMUL USING ACCUM BHOLDER OVERFLOW-FLAG.
073320     IF OVERFLOW-FLAG NOT = 0
073340         DISPLAY '%Multiply overflow' UPON CONSOLE
073350         PERFORM ACCUM-ZERO GO TO COMPUTE-LOOP.
073360     ADD ELEM-D-SCALE ACCUM-SCALE GIVING ACCUM-SCALE.
073380*    *IF TOO MANY DECIMALS, SHIFT DOWN TO 5*
073400     IF ACCUM-SCALE GREATER THAN 5
073420         SUBTRACT 5 FROM ACCUM-SCALE
073440         SET PTX TO ACCUM-SCALE
073460         DIVIDE 10EX (PTX) INTO ACCUM GIVING ACCUM
073480         MOVE 5 TO ACCUM-SCALE.
073500     GO TO COMPUTE-LOOP.
073520
073540 DIVIDER.
073560     MOVE 5 TO J.
073580     ADD J ELEM-D-SCALE GIVING K.
073600     SUBTRACT ACCUM-SCALE FROM K.
073620     IF K NOT GREATER THAN 0 SUBTRACT K FROM J
073640         GO TO DIVIDER1.
073660*===*NEED WAY TO TRAP DIVIDE SHIFT OVERFLOW*
073680*    *KICK NUMERATOR BY APPROPRIATE POWER OF 10 TO GET SIGNIFICANCE
073700
073720     SET PTX TO K.
073740     MOVE 10EX (PTX) TO WORK-2.
073760     ENTER MACRO IQDMUL USING ACCUM WORK-2 OVERFLOW-FLAG.
073780     IF OVERFLOW-FLAG NOT = 0
073800         DISPLAY '%Divide shift overflow' UPON CONSOLE
073810         PERFORM ACCUM-ZERO GO TO COMPUTE-LOOP.
073820
073840 DIVIDER1.
073860     DIVIDE BHOLDER INTO ACCUM ON SIZE ERROR
073880         DISPLAY '%Divide overflow' UPON CONSOLE
073890         PERFORM ACCUM-ZERO GO TO COMPUTE-LOOP.
073900     MOVE J TO ACCUM-SCALE.
073920     GO TO COMPUTE-LOOP.
073940
073960
073980 PUSHER.
074000     SET TX UP BY 1.
074020     MOVE ACCUM TO TEMP (TX).
074040     MOVE ACCUM-SCALE TO TSCALE (TX).
074060     SET X UP BY 1.
074080     ENTER MACRO IQGETI.
074100     IF ELEM-INSTR GREATER THAN 0
074120         SET DX TO ELEM-INSTR
074140         ENTER MACRO IQGETD
074160         PERFORM GETB-VALUE THRU GET-VALUE-EXIT
074180       ELSE IF ELEM-INSTR = -1
074200         MOVE TEMP (TX) TO BHOLDER
074220         MOVE TSCALE (TX) TO ELEM-D-SCALE
074240         MOVE 6 TO NHOLDER-TYPE
074260         SET TX DOWN BY 1
074280       ELSE 
074284         MOVE TEMP (TX) TO SAVE-BHOLDER
074288         MOVE TSCALE (TX) TO SAVE-SCALE
074292         SET TX DOWN BY 1
074300         MOVE TEMP (TX) TO BHOLDER
074320         MOVE TSCALE (TX) TO ELEM-D-SCALE
074324         MOVE SAVE-BHOLDER TO TEMP (TX)
074328         MOVE SAVE-SCALE TO TSCALE (TX)
074360         MOVE 6 TO NHOLDER-TYPE.
074380     IF NHOLDER-TYPE = 1 PERFORM ILLEGAL-ALPHA MOVE 0 TO BHOLDER.
074400     MOVE BHOLDER TO ACCUM.
074420     MOVE ELEM-D-SCALE TO ACCUM-SCALE.
074440     GO TO COMPUTE-LOOP.
074460
074480 COMPUTE-DONE.
074500     SET DX TO TARGET-DX.
074520     ENTER MACRO IQGETD.
074540     MOVE ACCUM TO BHOLDER.
074560     MOVE 6 TO NHOLDER-TYPE.
074580     MOVE ACCUM-SCALE TO NHOLDER-SCALE.
074600     PERFORM SET-VALUE THRU SET-VALUE-EXIT.
074620     GO TO NEXT-INSTR-UPX.
074640
074644*    *ON ERROR CONDITION, ZERO ACCUMULATOR AND ITS SCALE.
074648 ACCUM-ZERO.
074654     DIVIDE 1 INTO 2 GIVING ACCUM 
074654         ON SIZE ERROR MOVE 0 TO ACCUM.
074652     MOVE 0 TO ACCUM ACCUM-SCALE.
074660
074680**********************************************************
074700*  TALLY INSTRUCTION
074720*     FORMAT:  (X)   = INSTRUCTION VALUE 47.
074740*              (X+1) = DX OF ITEM BEING TALLIED.
074760*              (X+2) = DX OF V-ENTRY WHERE TALLY IS KEPT.
074780*              (X+3) = DX OF CONTROLLING (BREAK) ITEM.
074800*              (X+4) = DX OF ITEM FOR PRIOR BREAK VALUE.
074820*
074840*                      TRIPLES OF V-ENTRY DX, BREAK ITEM DX, AND
074860*                      PRIOR BREAK DX CONTINUE WITH A TRIPLE FOR
074880*                      EACH BREAK AND END WITH A TRIPLE WHERE
074900*                      THE DX OF THE BREAK ITEM = 0.
074920*
074940*                      THE FIRST TIME THROUGH, THE DX IN (X+1)
074960*                      IS < 0; THIS IS A FIRST TIME 'KICKOFF'
074980*                      SWITCH & IT IS IMMEDIATELY RESET TO > 0
075000*
075020*             NOTE: NECHARS, NCHARS, PICT IN BUCKET
075040*             V-ENTRY ARE SET UP BY MODULE IQA.
075060**********************************************************
075080
075100*    *SET UP FOR TALLYING (COUNTING)*
075120 TALLIER.
075140     MOVE 1 TO SUMMARY-ROUTER.
075160     ENTER MACRO IQGETI.
075180     MOVE ELEM-INSTR TO KICKOFF-FLAG.
075200     IF ELEM-INSTR LESS THAN 0
075220         SUBTRACT ELEM-INSTR FROM 0 GIVING ELEM-INSTR
075240         ENTER MACRO IQPUTI.
075260     MOVE ELEM-INSTR TO SUMK.
075280     MOVE 1 TO SUM-WORK.
075300     GO TO SUMMARIZER1.
075320
075340*    *THE SUMMARY COMMANDS TOTAL, AVERAGE, MAXIMUM AND MINIMUM
075360*    * COME IN TO THE COMMON SUMMARY LOGIC HERE.
075380
075400*    *SUM-WORK IS THE INCREMENTAL VALUE FOR EACH SUMMARY*
075420
075440 SUMMARIZER.
075460     ENTER MACRO IQGETI.
075480     MOVE ELEM-INSTR TO KICKOFF-FLAG.
075500     IF ELEM-INSTR LESS THAN 0
075520         SUBTRACT ELEM-INSTR FROM 0 GIVING ELEM-INSTR
075540         ENTER MACRO IQPUTI.
075560     MOVE ELEM-INSTR TO SUMK.
075580     SET DX TO ELEM-INSTR.
075600     ENTER MACRO IQGETD.
075620     PERFORM GETB-VALUE THRU GET-VALUE-EXIT.
075640     MOVE BHOLDER TO SUM-WORK.
075660
075680 SUMMARIZER1.
075700*    *MAIN BREAK TEST AND SUMMARY BUCKET UPDATE LOOP*.
075720     SET X UP BY 1.
075740     ENTER MACRO IQGETI.
075760*    *HERE HAVE DX OF V-ENTRY*
075780     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
075800     MOVE ELEM-INSTR TO SUMJ.
075820     SET X UP BY 1.
075840     ENTER MACRO IQGETI.
075860*    *HERE HAVE DX OF CURRENT BREAK ITEM*
075880
075900*    *SPECIALLY PROCESS IF KICKING OFF SUMMARY FOR VERY FIRST TIME*
075920     IF KICKOFF-FLAG LESS THAN 0
075940         SET DX TO SUMJ
075960         ENTER MACRO IQGETD
075980*        *INITIALIZE SUMMARY BUCKET*
076000         MOVE SUM-WORK TO ELEM-V-BINARY
076020         MOVE 1 TO ELEM-V-WORK
076040         ENTER MACRO IQPUTD
076060         IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX
076080*        *MUST INITIALIZE PRIOR BREAK VALUE*
076100         ELSE SET DX TO ELEM-INSTR
076120             ENTER MACRO IQGETD
076140             PERFORM GETN-VALUE THRU GET-VALUE-EXIT
076160             SET X UP BY 1
076180             ENTER MACRO IQGETI
076200             SET DX TO ELEM-INSTR
076220             ENTER MACRO IQGETD
076240             PERFORM SET-VALUE THRU SET-VALUE-EXIT
076260             GO TO SUMMARIZER1.
076280
076300*    *ON END OF DX LIST, HAVE NO BREAK; UPDATE BUCKETS*
076320     IF ELEM-INSTR = 0 GO TO SUMMARIZER2.
076340
076360*    *TEST FOR BREAK*
076380     SET DX TO ELEM-INSTR.
076400*    *HERE HAVE DX OF CURRENT BREAK ITEM VALUE*
076420     ENTER MACRO IQGETD.
076440     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
076460     MOVE AHOLDER TO ALT-AHOLDER.
076480     SET X UP BY 1.
076500     ENTER MACRO IQGETI.
076520     SET DX TO ELEM-INSTR.
076540*    *HERE HAVE DX OF PRIOR BREAK ITEM VALUE*
076560     ENTER MACRO IQGETD.
076580     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
076600*    *NOW COMPARE OLD AND NEW BREAK VALUES.
076620     IF NHOLDER-TYPE = 1 IF AHOLDER NOT = ALT-AHOLDER
076640         GO TO SUMMARIZER3 ELSE GO TO SUMMARIZER2.
076660     IF NHOLDER-TYPE = 2 IF NHOLDER NOT = ALT-NHOLDER
076680         GO TO SUMMARIZER3 ELSE GO TO SUMMARIZER2.
076700
076720*    *HERE IF BREAK ITEM DID NOT CHANGE; KICK VALUE IN V-ENTRY*
076740 SUMMARIZER2.
076760     SET DX TO SUMJ.
076780     ENTER MACRO IQGETD.
076800     GO TO SUMMARIZER2A SUMMARIZER2A SUMMARIZER2B
076820           SUMMARIZER2C SUMMARIZER2D
076840           DEPENDING ON SUMMARY-ROUTER.
076860 SUMMARIZER2A.
076880     ADD SUM-WORK TO ELEM-V-BINARY.
076900     GO TO SUMMARIZER2E.
076920 SUMMARIZER2B.
076940     ADD SUM-WORK TO ELEM-V-BINARY.
076960     ADD 1 TO ELEM-V-WORK.
076980     GO TO SUMMARIZER2E.
077000 SUMMARIZER2C.
077020     IF SUM-WORK GREATER THAN ELEM-V-BINARY
077040         MOVE SUM-WORK TO ELEM-V-BINARY.
077060     GO TO SUMMARIZER2E.
077080 SUMMARIZER2D.
077100     IF SUM-WORK LESS THAN ELEM-V-BINARY
077120         MOVE SUM-WORK TO ELEM-V-BINARY.
077140 SUMMARIZER2E.
077160     ENTER MACRO IQPUTD.
077180     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX
077200         ELSE GO TO SUMMARIZER1.
077220
077240*    *HERE IF BREAK ITEM DID CHANGE*
077260*    *FLAG NEW GROUP FOR IF NEWGROUP USE AND MARK
077280*    *  X WHERE BREAK OCCURRED IN LIST OF DX TRIPLES*
077300
077320 SUMMARIZER3.
077340     MOVE 1 TO NEWGROUP-FLAG.
077360     SET HOLDX TO X.
077380     SUBTRACT 3 FROM HOLDX.
077400     SET X UP BY 1.
077420
077440*    *NOTE: LOGIC FROM STAGE END COMES IN HERE TO WRAP UP*
077460*    *FIRST, SPACE DOWN TO END OF BREAK ITEM DX LIST
077480*    * BECAUSE WILL HAVE TO BACK UP, SHOWING LEAST MAJOR
077500*    * SUMMARIES FIRST*
077520 SUMMARIZER4.
077540     ENTER MACRO IQGETI.
077560*    *HERE HAVE DX OF V-ENTRY*
077580     IF ELEM-INSTR = 0
077600         SET SUMX TO X
077620         SET X DOWN BY 3
077640         GO TO SUMMARIZER5.
077660     SET X UP BY 1.
077680     ENTER MACRO IQGETI.
077700     IF ELEM-INSTR = 0 SET SUMX TO X
077720         SET X DOWN BY 1 GO TO SUMMARIZER5.
077740     SET X UP BY 2.
077760     GO TO SUMMARIZER4.
077780
077800
077820*    *LOGIC BELOW PUSHES OUT SUMMARIES IN RIGHT TO LEFT ORDER*
077840 SUMMARIZER5.
077860*    *IF HAVE BACKED ALL THE WAY TO WHERE BREAK OCCURRED, QUIT*
077880     IF X NOT GREATER THAN HOLDX
077900         SET X TO SUMX
077920         IF ENDING-FLAG = 1 GO TO ENDER1A
077940             ELSE GO TO NEXT-INSTR-UPX.
077960     ENTER MACRO IQGETI.
077980*    *HERE HAVE DX OF V-ENTRY (WHICH IS SUMMARY BUCKET)*
078000     MOVE ELEM-INSTR TO SUMJ.
078020     SET X UP BY 1.
078040     ENTER MACRO IQGETI.
078060     IF ELEM-INSTR NOT = 0
078080         SET X UP BY 1
078100         ENTER MACRO IQGETI.
078120*    *HERE HAVE DX OF PRIOR BREAK ITEM VALUE, IF ANY*
078140     IF ELEM-INSTR NOT = 0
078160         SET DX TO ELEM-INSTR
078180         ENTER MACRO IQGETD.
078200*    *IF SUMPRINT FLAG IS ON SHOW THE SUMMARIES*
078220     IF SUMPRINT-FLAG = 1
078240         IF ELEM-INSTR NOT = 0
078260             PERFORM GETN-VALUE THRU GET-VALUE-EXIT
078280             PERFORM SUMMARY-SHOW THRU SUMMARY-SHOW-EXIT
078300        ELSE PERFORM SUMMARY-SHOW THRU SUMMARY-SHOW-EXIT.
078320
078340*    *INITIALIZE SUMMARY BUCKET FOR NEXT TIME AROUND*
078360     SET DX TO SUMJ.
078380     IF ENDING-FLAG = 1 SET X DOWN BY 5 GO TO SUMMARIZER5.
078400     ENTER MACRO IQGETD.
078420     MOVE SUM-WORK TO ELEM-V-BINARY.
078440     MOVE 1 TO ELEM-V-WORK.
078460     ENTER MACRO IQPUTD.
078480
078500*    *NOW REPLACE PRIOR BREAK VALUE WITH CURRENT*
078520     SET X DOWN BY 1.
078540     ENTER MACRO IQGETI.
078560     SET DX TO ELEM-INSTR.
078580     ENTER MACRO IQGETD.
078600     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
078620     SET X UP BY 1.
078640     ENTER MACRO IQGETI.
078660     SET DX TO ELEM-INSTR.
078680     ENTER MACRO IQGETD.
078700     PERFORM SET-VALUE THRU SET-VALUE-EXIT.
078720
078740*    *NOW BACK UP TO NEXT DX TRIPLE*
078760     SET X DOWN BY 5.
078780     GO TO SUMMARIZER5.
078800
078820**********************************************************
078840*  TOTAL INSTRUCTION
078860*  FORMAT:   (X)   = INSTRUCTION VALUE 48.
078880*            (X+1) = DX OF ITEM BEING TOTALED.
078900*                    ;INITIALLY < 0 THEN RESET TO > 0
078920*            (X+2) = DX OF V-ENTRY WHERE TOTAL IS KEPT.
078940*            (X+3) = DX OF CONTROLLING (BREAK) ITEM.
078960*            (X+4) = DX OF ITEM FOR PRIOR BREAK VALUE
078980*
079000*                    TRIPLES OF V-ENTRY DX, BREAK ITEM DX, AND
079020*                    PRIOR BREAK DX CONTINUE WITH A TRIPLE FOR
079040*                    EACH BREAK AND END WITH A TRIPLE WHERE
079060*                    THE DX OF THE BREAK ITEM = 0.
079080*
079100*            NOTE: IQA CREATES ENTRIES IN NECHAR, NCHAR,
079120*            AND PICT IN THE V--ENTRY FOR EACH BUCKET
079140*            WHICH HAVE CAPACITIES FOR 3 EXTRA DIGITS TO
079160*            THE LEFT COMPARED TO ITEM TOTALED.
079180**********************************************************
079200
079220 TOTALER.
079240     MOVE 2 TO SUMMARY-ROUTER.
079260     GO TO SUMMARIZER.
079280
079300**********************************************************
079320* AVERAGE INSTRUCTION
079340* FORMAT:   (X)    = INSTRUCTION VALUE 49.
079360*           (X+1)  = DX OF ITEM BEING AVERAGED.
079380*                    ;INITIALLY < 0 THEN RESET TO > 0
079400*           (X+2)  = DX OF VARIABLE V-ENTRY WHERE
079420*                    AVERAGE IS KEPT:  NUMERATOR IS IN
079440*                    V-BINARY; DENOMINATOR IS IN V-WORK.
079460*           (X+3)  = DX OF CONTROLLING (BREAK) ITEM.
079480*           (X+4)  = DX OF ITEM FOR PRIOR BREAK VALUE.
079500*
079520*                    TRIPLES OF V-ENTRY DX, BREAK ITEM DX, AND
079540*                    PRIOR BREAK DX CONTINUE WITH A TRIPLE FOR
079560*                    EACH BREAK AND END WITH A TRIPLE WHERE
079580*                    THE DX OF THE BREAK ITEM = 0.
079600*
079620**********************************************************
079640
079660 AVERAGER.
079680     MOVE 3 TO SUMMARY-ROUTER.
079700     GO TO SUMMARIZER.
079720
079740*********************************************************
079760* MAXIMUM INSTRUCTION
079780* FORMAT:    (X)   = INSTRUCTION VALUE 80.
079800*            (X+1) = DX OF ITEM MAXIMIZED
079820*                    ;INITIALLY < 0 THEN RESET TO > 0
079840*            (X+2) = DX OF V-ENTRY WHERE MAXIMUM IS KEPT.
079860*            (X+3) = DX OF CONTROLLING (BREAK) ITEM.
079880*            (X+4) = DX OF ITEM FOR PRIOR BREAK VALUE.
079900*
079920*                    TRIPLES OF V-ENTRY DX, BREAK ITEM DX AND
079940*                    PRIOR BREAK DX CONTINUE WITH A TRIPLE
079960*                    FOR EACH BREAK AND END WITH A TRIPLE WHERE
079980*                    THE DX OF THE BREAK ITEM = 0.
080000*********************************************************
080020
080040 MAXIMIZER.
080060     MOVE 4 TO SUMMARY-ROUTER.
080080     GO TO SUMMARIZER.
080100
080120*****************************************************************
080140* MINIMUM INSTRUCTION
080160* FORMAT:        (X)   = INSTRUCTION VALUE 81.
080180*                (X+1) = DX OF ITEM BEING MINIMIZED.
080200*                        INITIALLY < 0 THEN RESET TO > 0
080220*                (X+2) = DX OF V-ENTRY WHERE MINIMUM IS KEPT
080240*                (X+3) = DX OF CONTROLLING (BREAK) ITEM.
080260*                (X+4) = DX OF ITEM FOR PRIOR BREAK VALUE.
080280*
080300*                        TRIPLES OF V-ENTRY DX, BREAK ITEM DX AND
080320*                        PRIOR BREAK DX CONTINUE WITH A TRIPLE
080340*                        FOR EACH BREAK AND END WITH A TRIPLE
080360*                        WHERE THE DX OF THE BREAK ITEM = 0.
080380*****************************************************************
080400
080420 MINIMIZER.
080440     MOVE 5 TO SUMMARY-ROUTER.
080460     GO TO SUMMARIZER.
080480
080500**********************************************************
080520* THIS SUBROUTINE SERVICES ALL OF TALLIER, TOTALER
080540* MAXIMIZER, MINIMIZER, AND AVERAGE.
080560* AS FAR AS DISPLAYING THE SUMMARY WHEN
080580* (A) PROPER BREAK OCCURS, AND (B) PRINTING IS BY DEFAULT.
080600* ON ENTRY MUST HAVE:
080620*     SUMJ = DX OF SUMMARY VARIABLE (BUCKET FOR SUMMARY).
080640*     SUMK = DX OF ITEM BEING SUMMARIZED.
080660*     ELEM-D-ENTRY CONTAINS DESCRIPT OF ITEM CONTROLLING BREAK.
080680*     ALT-NHOLDER = OLD (BEFORE CHANGE) VALUE.
080700*     SUMMARY-ROUTER INDICATES WHICH SUMMARY.
080720***********************************************************
080740
080760 SUMMARY-SHOW.
080780     MOVE VSPACE TO CURR-VSPACE.
080800     IF ELEM-LAST-PRINTYPE = 1 ADD 1 TO CURR-VSPACE.
080820     MOVE SPACES TO SUMMARY-LINE.
080840     IF ELEM-INSTR = 0 MOVE 'OVERALL' TO SUMMARY-BREAK-TITLE1
080860         GO TO SUMMARY-SHOW1.
080880*    *IDENTIFY ITEM & VALUE WHICH CAUSED BREAK*.
080900     MOVE ELEM-D-TITLE1 TO SUMMARY-BREAK-TITLE1.
080920     MOVE ELEM-D-TITLE2 TO SUMMARY-BREAK-TITLE2.
080940     ENTER MACRO IQPICT.
080960     ENTER MACRO IQSX66 USING ELEM-D-ECHAR
080980         PICT-WORK CONST1 SUMMARY-BREAK-VALUE CONST1.
081000 SUMMARY-SHOW1.
081020*    *NOW IDENTIFY ITEM BEING SUMMARIZED*.
081040     SET DX TO SUMK.
081060     ENTER MACRO IQGETD.
081080     MOVE ELEM-D-TITLE1 TO SUMMARY-TITLE1.
081100     MOVE ELEM-D-TITLE2 TO SUMMARY-TITLE2.
081120*    *FINALLY, PUT OUT TALLY, TOTAL OR AVERAGE VALUE*.
081140     SET DX TO SUMJ.
081160     ENTER MACRO IQGETD.
081180     IF SUMMARY-ROUTER NOT = 3
081200         MOVE ELEM-V-BINARY TO NHOLDER
081220         GO TO SUMMARY-SHOW2.
081240*    *CALCULATE THE ACTUAL AVERAGE.
081260     DIVIDE ELEM-V-WORK INTO ELEM-V-BINARY
081280         GIVING NHOLDER ROUNDED.
081300
081320 SUMMARY-SHOW2.
081340     MOVE ELEM-V-TYPEV TO TRUE-TYPEV.
081360     ENTER MACRO IQPICT.
081380*    *NOW RIGHT JUSTIFY EDITED QUANTITY SO LINE UP DECIMALS*
081400     MOVE SPACES TO SUMMARY-VALUE.
081420     SUBTRACT ELEM-V-ECHAR FROM CONST20 GIVING I.
081440     ENTER MACRO IQSX66 USING ELEM-V-ECHAR
081460         PICT-WORK CONST1 SUMMARY-VALUE I.
081480     IF SUMMARY-ROUTER = 1 MOVE 'TALLY: ' TO SUMMARY-VERB
081500         GO TO SUMMARY-SHOW3.
081520     IF SUMMARY-ROUTER = 2 MOVE 'TOTAL: ' TO SUMMARY-VERB
081540         GO TO SUMMARY-SHOW3.
081560     IF SUMMARY-ROUTER = 3 MOVE 'AVG: ' TO SUMMARY-VERB
081580         GO TO SUMMARY-SHOW3.
081600     IF SUMMARY-ROUTER = 4 MOVE 'MAX: ' TO SUMMARY-VERB
081620         GO TO SUMMARY-SHOW3.
081640     MOVE 'MIN: ' TO SUMMARY-VERB.
081660
081680 SUMMARY-SHOW3.
081700     IF ELEM-LINE-NO = 0 MOVE FORM-LINES TO ELEM-LINE-NO.
081720     ADD CURR-VSPACE TO ELEM-LINE-NO.
081740     IF ELEM-LINE-NO GREATER THAN PAGE-LINES
081760         AND PAGING-FLAG = 1
081780         PERFORM NEWPAGER THRU NEWPAGER-EXIT
081784         MOVE 2 TO CURR-VSPACE
081788         ADD CURR-VSPACE TO ELEM-LINE-NO.
081800     MOVE SUMMARY-LINE TO PRINT-LINE.
081820*    *SQUEEZE OUT ANY EXTRA SPACES IN SUMMARY TEXT*
081840     PERFORM BLANK-PEELOUT THRU BLANK-PEELOUT-EXIT.
081860*    *NOW MAKE ROOM TO PUT IN SUMMARY VALUES ON RIGHT*
081880*    *FIRST SEE HOW MUCH ROOM WE NEED*
081900     SUBTRACT 26 FROM RMARGIN GIVING I.
081920     IF I GREATER THAN 63 MOVE 63 TO I.
081940     ENTER MACRO IQSX66 USING CONST7
081960         SUMMARY-VERB CONST1 PRINT-LINE I.
081980     ADD 7 TO I.
082000     ENTER MACRO IQSX66 USING CONST19
082020         SUMMARY-VALUE CONST1 PRINT-LINE I.
082040     IF ELEM-RPT-NO GREATER THAN 1
082060         OR ACROSS-CONTROL GREATER THAN 1
082080         MOVE ELEM-RPT-NO TO QTE-RPT-NO
082100         MOVE CURR-VSPACE TO QTE-VSPACE
082120         ADD 1 TO QTE-LINE-NO
082140         MOVE PRINT-LINE TO QTE-IMAGE
082160         WRITE QTEXEC-REC ADD 1 TO QTEXEC-COUNT
082180         MOVE 1 TO CALL-IQM-FLAG
082200         GO TO SUMMARY-SHOW-DONE.
082220     IF DISPLAY-FLAG = 1 ADD I 19 GIVING TERM-CHARS
082222         IF CURR-VSPACE GREATER THAN 1
082240         MOVE CURR-VSPACE TO I
082250         SUBTRACT 1 FROM I
082260         PERFORM DISPLAY-VSPACE THRU DISPLAY-VSPACE-EXIT.
082280     IF DISPLAY-FLAG = 1 PERFORM DISPLAY-PRINT-LINE.
082300     IF PRINT-FLAG = 1
082320         WRITE QLEXEC-REC FROM PRINT-LINE
082340         AFTER ADVANCING CURR-VSPACE LINES 
082342         ADD 1 TO LINES-IN-PHASE.
082360
082380 SUMMARY-SHOW-DONE.
082400     MOVE 2 TO ELEM-LAST-PRINTYPE.
082420
082440 SUMMARY-SHOW-EXIT.
082460     EXIT.
082480
082500**********************************************************
082520*  GO TO QT (QUIT) INSTRUCTION
082540*  FORMAT:
082560*  (X) = INSTRUCTION VALUE 50.
082580**********************************************************
082600
082620 GO-TO-QT.
082640     MOVE 10 TO ERROR-CODE.
082660     MOVE 0 TO SORTFILE-FLAG.
082670*   * LET CONTROL FALL THRU TO EXECUTE THE GO-TO-XT LOGIC AS WELL
082680*     GO TO ENDER.
082700
082720**********************************************************
082740*  GO TO XT INSTRUCTION
082760*  FORMAT:
082780*  (X) = INSTRUCTION VALUE 51.
082800**********************************************************
082820
082840 GO-TO-XT.
082860     SET X TO EOF1-X.
082865     IF INF1-FLAG = 6 GO TO NEXT-INSTR.
082870     IF INF1-FLAG = 0 MOVE 6 TO INF1-FLAG ELSE 
082874                      MOVE 5 TO INF1-FLAG.
082880     GO TO NEXT-INSTR.
082900
082920**********************************************************
082940*  GO TO NR INSTRUCTION
082960*  FORMAT:
082980*  (X) = INSTRUCTION VALUE 52.
083000**********************************************************
083020
083040 GO-TO-NR.
083060     MOVE 0 TO NEWGROUP-FLAG.
083080     IF INF1-FLAG = 0 MOVE 6 TO INF1-FLAG.
083100     IF INF1-FLAG LESS THAN 3 MOVE 3 TO INF1-FLAG.
083120     SET X TO EXEC-STARTX.
083140     GO TO NEXT-INSTR.
083160
083180**********************************************************
083200*  GO TO NN (ANOTHER STATEMENT) INSTRUCTION.
083220*  FORMAT:
083240*  (X)   = INSTRUCTION VALUE 53
083260*  (X+1) = TARGET X.
083280*
083300*  NOTE: DOES NOT FALL THROUGH TO NEXT X.
083320**********************************************************
083340
083360 GO-TO-NN.
083380     ENTER MACRO IQGETI.
083400     SET X TO ELEM-INSTR.
083420     GO TO NEXT-INSTR.
083440
083460**********************************************************
083480*  EXIT INSTRUCTION
083500*  INSTRUCTION FORMAT:
083520*  (X)   = INSTRUCTION VALUE 54.
083540*  (X+1) = EXIT NUMBER.
083560*  (X+2) = START OF DX LIST OF ARGUMENTS. LIST IS ENDED
083580*          BY DX = 0. NEXT INSTRUCTION FOLLOWS.
083600*          IF A VALUE IS TO BE RETURNED FROM THE CALLED
083620*          USER ROUTINE, THE DX IS NEGATIVE.
083640*  NOTE: THIS LOGIC APPLIES ONLY TO NON-STANDARD EXITS.
083660*  NOTE: FORMATS OF ARGUMENTS ARE DIFFERENT THAN IQL2.3
083680**********************************************************
083700
083720 EXITER.
083740     ENTER MACRO IQGETI.
083744     SET DX TO ELEM-INSTR.
083748     ENTER MACRO IQGETD.
083752     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
083760     MOVE NHOLDER TO EXIT-CODE.
083780     MOVE SPACES TO STATUS-CODE.
083800     MOVE SPACES TO ARGUMENTS.
083820*    *HOLD THIS X FOR RECEIVING PASS*
083840     SET J TO X.
083860     SET K TO 0.
083880     SET ARX TO 1.
083900
083920 EXITER-SETUP.
083940     SET X UP BY 1.
083960     ENTER MACRO IQGETI.
083980     IF ELEM-INSTR = 0 GO TO EXITER-CALL.
084000     IF ELEM-INSTR LESS THAN 0
084020         SUBTRACT ELEM-INSTR FROM 0 GIVING ELEM-INSTR
084040         MOVE 1 TO K.
084060     SET DX TO ELEM-INSTR.
084080     ENTER MACRO IQGETD.
084100     PERFORM GET-VALUE THRU GET-VALUE-EXIT.
084120*    *JUSTIFY IN ARG TO PASS IT*.
084180     IF NHOLDER-TYPE = 1 MOVE AHOLDER TO ARG (ARX)
084184         ELSE IF NHOLDER-TYPE = 2 MOVE NHOLDER TO N-ARG (ARX)
084188         ELSE IF NHOLDER-TYPE = 6 MOVE BHOLDER TO B-ARG (ARX).
084244     IF ARX < 11 SET ARX UP BY 1
084260         GO TO EXITER-SETUP.
084280
084300 EXITER-CALL.
084320     CALL IQCALL USING PASSED-PARAMS.
084340     IF STATUS-CODE = 'BAD' GO TO ABORT-RUN.
084344     IF STATUS-CODE = 'END' GO TO ENDER.
084360     IF STATUS-CODE NOT = SPACES 
084364         DISPLAY '%Returned status code: ' STATUS-CODE 
084368         UPON CONSOLE.
084372     MOVE STATUS-CODE TO ERROR-STATUS.
084380*    *IF GOOD STATUS, SEE IF ANY ARGS TO BE RETURNED*.
084400     IF K = 0 GO TO NEXT-INSTR-UPX.
084420     SET X TO J.
084440     SET ARX TO 1.
084460
084480 EXITER-RECEIVE.
084500     SET X UP BY 1.
084520     ENTER MACRO IQGETI.
084540     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
084560     IF ELEM-INSTR GREATER THAN 0
084580         SET ARX UP BY 1 GO TO EXITER-RECEIVE.
084600     SUBTRACT ELEM-INSTR FROM 0 GIVING ELEM-INSTR.
084620     SET DX TO ELEM-INSTR.
084640     ENTER MACRO IQGETD.
084680     DIVIDE CONST100 INTO ELEM-D-TYPEV GIVING FILE-ROUTER
084700         REMAINDER TRUE-TYPEV.
084720     IF ( TRUE-TYPEV = 1 OR 10 OR 12 OR 33 OR 34 OR 36 )
084722         MOVE ARG (ARX) TO AHOLDER
084724         MOVE 1 TO NHOLDER-TYPE
084726         SUBTRACT ELEM-D-FCHAR FROM 0 GIVING NHOLDER-SCALE
084740       ELSE IF  ( TRUE-TYPEV = 6 OR 7 OR 8 )
084742         MOVE 6 TO NHOLDER-TYPE
084744         MOVE ELEM-D-SCALE TO NHOLDER-SCALE
084746         MOVE B-ARG (ARX) TO BHOLDER
084760       ELSE MOVE 2 TO  NHOLDER-TYPE
084762         MOVE ELEM-D-SCALE TO NHOLDER-SCALE
084764         MOVE N-ARG (ARX) TO  NHOLDER.
084800     PERFORM SET-VALUE THRU SET-VALUE-EXIT.
084820     SET ARX UP BY 1.
084840     GO TO EXITER-RECEIVE.
084860
084880*===*REVIEW PROCESSING OF STATUS CODE*.
084900*===*ADD LOGIC TO PROCESS RETURNED VALUES*.
084920
084940
084960**********************************************************
084980* IF BEGINNING OF FILE (ON 1ST RECORD) INSTRUCTION
085000*  FORMAT:
085020*    (X)   = INSTRUCTION; VALUES 55 74 75 FOR FILES 1 2 3
085040*    (X+1) = TRUEGO X
085060*    (X+2) = FALSEGO X
085080*    IF THIS IS THE FIRST RECORD READ CONDITION (TRUE)
085100*    THEN GO TO INSTRUCTION POINTED-TO BY TRUEGO X.
085120*    IF NOT (FALSE CONDITION), GO TO THE INSTRUCTION
085140*    POINTED-TO BY FALSEGO X.
085160*
085180* NOTE - FOR 'NOT' CASE, IQA SIMPLY REVERSES VALUES FOR
085200*        TRUEGO AND FALSGO; ABOVE FUNCTIONS AS USUAL*
085220**********************************************************
085240
085260 IFFIRSTIME.
085280 IF-BOF1.
085300     IF INF1-FLAG GREATER THAN 2 SET X UP BY 1.
085320     ENTER MACRO IQGETI.
085340     SET X TO ELEM-INSTR.
085360     GO TO NEXT-INSTR.
085380
085400 IF-BOF2.
085420     IF INF2-FLAG NOT = 2 SET X UP BY 1.
085440     ENTER MACRO IQGETI.
085460     SET X TO ELEM-INSTR.
085480     GO TO NEXT-INSTR.
085500
085520 IF-BOF3.
085540     IF INF3-FLAG NOT = 2 SET X UP BY 1.
085560     ENTER MACRO IQGETI.
085580     SET X TO ELEM-INSTR.
085600     GO TO NEXT-INSTR.
085620
085640**********************************************************
085660*  IF END OF FILE INSTRUCTION
085680*    FORMAT:
085700*      (X)   = INSTRUCTION VALUES 56 71 72 FOR FILES 1 2 3
085720*      (X+1) = TRUEGO X
085740*      (X+2) = FALSEGO X
085760*      IF EOF IS HIT (TRUE CONDITION) THEN GO TO
085780*      INSTRUCTION POINTED-TO BY TRUEGO X. IF NOT, GO TO
085800*      INSTRUCTION POINTED-TO BY FALSEGO X.
085820*
085840* NOTE - IN CASE OF 'NOT' IQA SIMPLY REVERSES VALUES FOR
085860*       FALSEGOX AND TRUGOX.
085880**********************************************************
085900
085920 IFLASTIME.
085940 IF-EOF1.
085960     IF INF1-FLAG  NOT LESS THAN 5 GO TO IF-EOF1A.
085980     SET WORKX TO X.
086000     SUBTRACT 1 FROM WORKX.
086020     IF LASTTIME-X = 0 MOVE WORKX TO LASTTIME-X.
086040     IF WORKX LESS THAN LASTTIME-X MOVE WORKX TO LASTTIME-X.
086060     SET X UP BY 1.
086080
086100 IF-EOF1A.
086120     ENTER MACRO IQGETI.
086140     SET X TO ELEM-INSTR.
086160     GO TO NEXT-INSTR.
086180
086200 IF-EOF2.
086220     IF INF2-FLAG NOT = 5 SET X UP BY 1.
086240     ENTER MACRO IQGETI.
086260     SET X TO ELEM-INSTR.
086280     GO TO NEXT-INSTR.
086300
086320 IF-EOF3.
086340     IF INF3-FLAG NOT = 5 SET X UP BY 1.
086360     ENTER MACRO IQGETI.
086380     SET X TO ELEM-INSTR.
086400     GO TO NEXT-INSTR.
086420
086440**********************************************************
086460* IF NEWPAGE INSTRUCTION.
086480* FORMAT:   (X)   = INSTRUCTION VALUE 57.
086500*           (X+1) = TRUEGO X
086520*           (X+2) = FALSEGOX.
086540*
086560* NOTE - IN CASE OF 'NOT' IQA SIMPLY REVERSES THE VALUES
086580*        FOR TRUEGO AND FALSEGO X'S.
086600**********************************************************
086620
086640 IFNEWPAGE.
086660     IF NEWPAGE-FLAG NOT = 1 SET X UP BY 1.
086680     ENTER MACRO IQGETI.
086700     SET X TO ELEM-INSTR.
086720     GO TO NEXT-INSTR.
086740
086760********************************************************
086780* IF NEWGROUP INSTRUCTION
086800*   FORMAT:
086820*     (X)   = INSTRUCTION  VALUE 58
086840*     (X+1) = TRUEGO X
086860*             ;INITIALLY < 0 THEN RESET TO > 0; 1ST-TIME SWITCH.
086880*     (X+2) = FALSEGO X
086900*     (X+3) = IF 0 THEN NEWGROUP CONDITION APPLIES TO ALL
086920*             OR ANY SUB-GROUPS REFERRED TO BY TALLY, TOTAL
086940*             OR AVERAGE.
086960*             IF NOT 0, BEGINS LIST OF DX PAIRS WHERE
086980*             1ST DX POINTS TO ITEM FOR CURRENT VALUE AND
087000*             2ND DX POINTS TO ITEM FOR PRIOR VALUE.
087020*             DX LIST CONTINUES
087040*             UNTIL 1ST DX OF PAIR IS 0, INDICATING END OF LIST
087060*             AND THAT NEXT INSTR (X) IS NEXT INSTRUCTION*.
087080**********************************************************
087100
087120 IFNEWGRP.
087140     ENTER MACRO IQGETI.
087160*    *CHECK FOR FIRST TIME THROUGH*
087180     MOVE ELEM-INSTR TO KICKOFF-FLAG.
087200     IF ELEM-INSTR LESS THAN 0
087220         SUBTRACT ELEM-INSTR FROM 0 GIVING ELEM-INSTR
087240         ENTER MACRO IQPUTI.
087260     MOVE ELEM-INSTR TO TRUEGOX.
087280     SET X UP BY 1.
087300     ENTER MACRO IQGETI.
087320     MOVE ELEM-INSTR TO FALSEGOX.
087340     SET X UP BY 1.
087360     ENTER MACRO IQGETI.
087380     IF ELEM-INSTR = 0
087400        IF NEWGROUP-FLAG = 1 SET X TO TRUEGOX
087420             GO TO NEXT-INSTR
087440             ELSE SET X TO FALSEGOX GO TO NEXT-INSTR.
087460
087480 IFNEWGRP-LOOP.
087500*    *HERE FOR DX POINTERS*.
087520     SET DX TO ELEM-INSTR.
087540     ENTER MACRO IQGETD.
087560     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
087580     MOVE AHOLDER TO ALT-AHOLDER.
087600*    *COMPARE WITH SAVED PREVIOUS GROUP VALUE*.
087620     SET X UP BY 1.
087640     ENTER MACRO IQGETI.
087660     SET DX TO ELEM-INSTR.
087680     ENTER MACRO IQGETD.
087700     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
087720*    *IF 1ST TIME THRU, FORCE CURRENT BREAK VALUE AS PRIOR ALSO.
087740     IF KICKOFF-FLAG LESS THAN 0
087760         MOVE ALT-AHOLDER TO AHOLDER
087780         PERFORM SET-VALUE  THRU SET-VALUE-EXIT.
087800     IF NHOLDER-TYPE = 1 GO TO TEST-NEW-ALPHA.
087820
087840 TEST-NEW-NUMERIC.
087860     IF NHOLDER = ALT-NHOLDER GO TO IFNEWGRP-NEXT.
087880     GO TO IFNEWGRP-CHANGE.
087900
087920 TEST-NEW-ALPHA.
087940     IF AHOLDER = ALT-AHOLDER GO TO IFNEWGRP-NEXT.
087960
087980 IFNEWGRP-CHANGE.
088000*    *ON CHANGE, UPDATE PRIOR BREAK VALUE TO CURRENT VALUE*
088020     MOVE ALT-AHOLDER TO AHOLDER.
088040     PERFORM SET-VALUE THRU SET-VALUE-EXIT.
088060     SET X TO TRUEGOX.
088080     GO TO NEXT-INSTR.
088100
088120 IFNEWGRP-NEXT.
088140     SET X UP BY 1.
088160     ENTER MACRO IQGETI.
088180     IF ELEM-INSTR NOT = 0 GO TO IFNEWGRP-LOOP.
088200     SET X TO FALSEGOX.
088220     GO TO NEXT-INSTR.
088240*****************************************
088250*         IF ERROR COUNT INSTRUCTION (67);
088260*		IF ERROR STATUS INSTRUCTION (68);
088280*		FORMAT:(X)	= INSTRUCTION VALUE 67 OR 68
088300*		       (X+1)	= TRUEGOX
088320*		       (X+2)	= FLASEGOX
088340*		       (X+3)	= RELATIONSHIP; SEE IF-ER FOR VALUES
088360*		       (X+4)	= RIGHT SID QUALIFIERS LIST OF DX'S
088380*				  STARTS HERE AND IS ENDED BY A DX OF 0;
088400*				  HAVE A 'HIT' IF ANY ITEM ADDRESSED
088420*				  BY ONE OF THESE DX'S VS LEFTSIDE
088440*				  SATISFIES RELATIONSHIP
088460*		NOTES:		(1) THIS CODE IS USED ONLY BY DBMS IQL
088480*				(2) LOGIC IS SIMILAR TO INSTRUCTION 61
088500*				(3) INSTRUCTION BRANCHES TO GENERAL 'IF'
088520*				    LOGIC TO MINIMIZE DUPLICATION
088540*********************************************************
088560
088562 IFERRCOUNT.
088564     MOVE ERROR-COUNT TO ALT-NHOLDER.
088566     GO TO IFERR-COMMON.
088568
088580 IFERRSTATUS.
088582     MOVE ERROR-STATUS TO ALT-NHOLDER.
088584
088586 IFERR-COMMON.
088600     ENTER MACRO IQGETI.
088620     MOVE ELEM-INSTR TO TRUEGOX.
088640     SET X UP BY 1.
088660     ENTER MACRO IQGETI.
088680     MOVE ELEM-INSTR TO FALSEGOX.
088700     SET X UP BY 1.
088720*   *LEFT SIDE IS ALWAYS ERROR-COUNT OR ERROR-STATUS.
088760     MOVE 0 TO NHOLDER-SCALE,ALT-NHOLDER-SCALE.
088780     MOVE 3 TO J.
088800     ENTER MACRO IQGETI.
088820     MOVE ELEM-INSTR TO RELATIONSHIP.
088840*   *PATCH INTO RIGHT SIDE IF LOGIC.
088860     PERFORM IF-ER-LOOP THRU IF-EXIT.
088862     GO TO NEXT-INSTR.
088864*    THE ABOVE IS KLUDGY SINCE IT DOES A PERFORM
088866*    OF PART OF THE RANGE OF CODE THAT IS 
088868*    FULLY PERFORMED BY THE SCAN IF LOGIC
088880
088900**********************************************************
088920*  GENERAL IF INSTRUCTION
088940*    FORMAT:
088960*      (X)   = INSTRUCTION  VALUE 61
088980*      (X+1) = TRUEGO X
089000*      (X+2) = FALSEGO X
089020*      (X+3) = DX OF LEFTSIDE ITEM.
089040*      (X+4) = RELATIONSHIP; VALUES ARE:
089060*              1 =  EQUAL TO
089080*              2 =  NOT EQUAL TO
089100*              3 =  LESS THAN
089120*              4 =  GREATER THAN
089140*              5 =  LESS THAN OR EQUAL TO
089160*              6 =  GREATER THAN OR EQUAL TO
089180*      (X+5) = RIGHTSIDE QUALIFIER LIST OF DX'S STARTS
089200*              HERE AND IS ENDED BY A DX OF 0;  HAVE A
089220*              'HIT' IF ANY ITEM ADDRESSED BY ONE OF THESE
089240*              THESE DX'S VS LEFTSIDE SATISFIES RELATIONSHIP.
089260* NOTES* (1) IF COMPARING AN ALPHA TO A NUMERIC, DECIMAL
089280*            POINTS ARE IGNORED. IE
089300*            TEST '12345' = 123.45,  RESPONSE WILL BE TRUE.
089320*
089340*        (2) IF COMPARING TWO NUMERICS SCALED DIFFERENTLY,
089360*            THE ONE WITH THE LOWER SCALE IS SHIFTED LEFT TO
089380*            MATCH THE OTHER; ZEROES ARE FILLED ON THE RIGHT.
089400*
089420**********************************************************
089440
089460 IF-ER.
089465     PERFORM IF-LOGIC THRU IF-EXIT.
089470     GO TO NEXT-INSTR.
089472
089474******************************************************************
089476* THIS SUBROUTINE PERFORMS IF-LOGIC
089478*****************************************************************
089479 IF-LOGIC.
089480     ENTER MACRO IQGETI.
089500     MOVE ELEM-INSTR TO TRUEGOX.
089520     SET X UP BY 1.
089540     ENTER MACRO IQGETI.
089560     MOVE ELEM-INSTR TO FALSEGOX.
089580     SET X UP BY 1.
089590     SET SAVE-LEFT-DX-X TO X.
089595 GET-LEFT-DX.
089600     ENTER MACRO IQGETI.
089620*    *GET LEFTSIDE VALUE AND HOLD IT*.
089640     SET DX TO ELEM-INSTR.
089660     ENTER MACRO IQGETD.
089670 GET-LEFT-VALUE.
089680     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
089700     MOVE AHOLDER TO ALT-AHOLDER.
089720      MOVE NHOLDER-SCALE TO ALT-NHOLDER-SCALE.
089740     MOVE ELEM-D-NCHAR TO J.
089760     SET X UP BY 1.
089780     ENTER MACRO IQGETI.
089800     MOVE ELEM-INSTR TO RELATIONSHIP.
089820
089840 IF-ER-LOOP.
089860     SET X UP BY 1.
089880     ENTER MACRO IQGETI.
089900     IF ELEM-INSTR = 0 SET X TO FALSEGOX
089920         GO TO IF-EXIT.
089940     SET DX TO ELEM-INSTR.
089960     ENTER MACRO IQGETD.
089980     PERFORM GETN-VALUE THRU GET-VALUE-EXIT.
090000     IF ALT-NHOLDER-SCALE NOT LESS THAN 0 GO TO IF-NUMERIC.
090020*    *HERE IF ALT-AHOLDER IS ALPHA*.
090040     IF NHOLDER-SCALE LESS THAN 0 GO TO IFA-ROUTER.
090060      SUBTRACT ELEM-D-NCHAR FROM MAX-NITEM-LEN-UP1 GIVING I.
090080     ENTER MACRO IQSX66 USING ELEM-D-NCHAR
090100         NHOLDER I AHOLDER CONST1.
090120 IFA-ROUTER.
090140     GO TO IFA-EQ IFA-NQ IFA-LS IFA-GR IFA-LEQ IFA-GEQ
090160         DEPENDING ON RELATIONSHIP.
090180
090200 IF-NUMERIC.
090220*    *HERE IF ALT-AHOLDER IS NUMERIC*.
090240     IF ALT-NHOLDER-SCALE = NHOLDER-SCALE
090260         GO TO IFN-EQ IFN-NQ IFN-LS IFN-GR IFN-LEQ IFN-GEQ
090280         DEPENDING ON RELATIONSHIP.
090300
090320*    *HERE IF SCALES DIFFERENT - SEE IF AHOLDER IS ALPHA*
090340     IF NHOLDER-SCALE LESS THAN 0
090360         SUBTRACT J FROM MAX-NITEM-LEN-UP1 GIVING I
090380         ENTER MACRO IQSX66 USING J
090400             ALT-NHOLDER I ALT-AHOLDER CONST1
090420         GO TO IFA-ROUTER.
090440
090460*    *HERE IF BOTH ARE NUMERIC BUT SCALED DIFFERENTLY;
090480*    * SCALE LOWER UP TO HIGHER*.
090500     IF ALT-NHOLDER-SCALE GREATER THAN NHOLDER-SCALE
090520         MOVE NHOLDER TO BHOLDER
090540         SUBTRACT NHOLDER-SCALE FROM ALT-NHOLDER-SCALE
090560              GIVING K
090580         SET PTX TO K
090600         MOVE 10EX (PTX) TO WORK-2
090620         ENTER MACRO IQDMUL USING BHOLDER WORK-2 OVERFLOW-FLAG
090640         MOVE BHOLDER TO NHOLDER
090660         IF OVERFLOW-FLAG NOT = 0
090680             DISPLAY '%IF test overflow' UPON CONSOLE
090700             GO TO IFN-ROUTER ELSE
090720             GO TO IFN-ROUTER.
090740     MOVE ALT-NHOLDER TO BHOLDER.
090760     SUBTRACT ALT-NHOLDER-SCALE FROM NHOLDER-SCALE GIVING K.
090780     SET PTX TO K.
090800     MOVE 10EX (PTX) TO WORK-2.
090820     ENTER MACRO IQDMUL USING BHOLDER WORK-2 OVERFLOW-FLAG.
090840     MOVE BHOLDER TO ALT-NHOLDER.
090860
090880 IFN-ROUTER.
090900     GO TO IFN-EQ IFN-NQ IFN-LS IFN-GR IFN-LEQ IFN-GEQ
090920         DEPENDING ON RELATIONSHIP.
090940
090960 IFN-EQ.
090980     IF ALT-NHOLDER = NHOLDER SET X TO TRUEGOX GO TO IF-EXIT.
091000         GO TO IF-ER-LOOP.
091020
091040 IFN-NQ.
091060     IF ALT-NHOLDER NOT = NHOLDER
091080         SET X TO TRUEGOX GO TO IF-EXIT.
091100     GO TO IF-ER-LOOP.
091120
091140 IFN-LS.
091160     IF ALT-NHOLDER LESS THAN NHOLDER
091180         SET X TO TRUEGOX GO TO IF-EXIT.
091200     GO TO IF-ER-LOOP.
091220
091240 IFN-GR.
091260     IF ALT-NHOLDER GREATER THAN NHOLDER
091280         SET X TO TRUEGOX GO TO IF-EXIT.
091300     GO TO IF-ER-LOOP.
091320
091340 IFN-LEQ.
091360     IF ALT-NHOLDER NOT GREATER THAN NHOLDER
091380         SET X TO TRUEGOX GO TO IF-EXIT.
091400     GO TO IF-ER-LOOP.
091420
091440 IFN-GEQ.
091460     IF ALT-NHOLDER NOT LESS THAN NHOLDER
091480         SET X TO TRUEGOX GO TO IF-EXIT.
091500     GO TO IF-ER-LOOP.
091520
091540
091560 IFA-EQ.
091580     IF ALT-AHOLDER-30 = AHOLDER-30 SET X TO TRUEGOX
091600         GO TO IF-EXIT.
091620     GO TO IF-ER-LOOP.
091640
091660 IFA-NQ.
091680     IF ALT-AHOLDER-30 NOT = AHOLDER-30 SET X TO TRUEGOX
091700         GO TO IF-EXIT.
091720     GO TO IF-ER-LOOP.
091740
091760 IFA-LS.
091780     IF ALT-AHOLDER-30 LESS THAN AHOLDER-30
091800         SET X TO TRUEGOX GO TO IF-EXIT.
091820     GO TO IF-ER-LOOP.
091840
091860 IFA-GR.
091880     IF ALT-AHOLDER-30 GREATER THAN AHOLDER-30
091900         SET X TO TRUEGOX GO TO IF-EXIT.
091920     GO TO IF-ER-LOOP.
091940
091960 IFA-LEQ.
091980     IF ALT-AHOLDER-30 NOT GREATER THAN AHOLDER-30
092000         SET X TO TRUEGOX GO TO IF-EXIT.
092020     GO TO IF-ER-LOOP.
092040
092060 IFA-GEQ.
092080     IF ALT-AHOLDER-30 NOT LESS THAN AHOLDER-30
092100         SET X TO TRUEGOX GO TO IF-EXIT.
092120     GO TO IF-ER-LOOP.
092122
092125 IF-EXIT.
092130     EXIT.
092140
092160**********************************************************
092180*  IF-FIRST INSTRUCTION VALUE 62
092200*==FILL IN CODE FOR RECORD BUFFER EXTRACTS===
092220**********************************************************
092222 IF-FIRST.
092224     MOVE 1 TO OCCURENCE.
092226* GET LEFTSIDE DX; SET UP TRUE AND FALSE GO
092228     PERFORM IF-LOGIC THRU GET-LEFT-DX.
092230* CLEAR SCHAR (LEFT HALF OF FCHAR FOR USE IN GET-VALUE-- CLEAR SCAN-POS
092232* FOR USE IN BUMP-ITEMS
092234     DIVIDE ELEM-D-FCHAR BY C2E18 GIVING LEFT-HALF
092236                                  REMAINDER ELEM-D-FCHAR.
092238     MOVE 0 TO SCAN-POS.
092240* SAVE GROUP NAME FOR BUMP-ITEMS
092242     MOVE ELEM-D-GRPNAME TO SAVED-GRPNAME.
092242     PERFORM GET-LEFT-VALUE.
092242     PERFORM SEARCH-FOR-STOPPER THRU STOP-EXIT.
092242     IF STOP-FLAG = 1   SET X TO FALSEGOX
092242                        GO TO BUMP-ITEMS.
092244* CHECK RELATIONSHIP
092246     PERFORM IF-ER-LOOP THRU IF-EXIT.
092248     GO TO BUMP-ITEMS.
092300
092320**********************************************************
092340*  IF-LAST INSTRUCTION VALUE 63
092360*==FILL IN CODE FOR RECORD BUFFER EXTRACTS===
092380**********************************************************
092382 IF-LAST.
092383* GET LEFTSIDE DX AND TRUE AND FALSE GO
092384     PERFORM IF-LOGIC THRU GET-LEFT-DX.
092384     MOVE ELEM-D-GRPNAME TO SAVED-GRPNAME.
092390     DIVIDE ELEM-D-FCHAR BY C2E18 GIVING LEFT-HALF
092392                                  REMAINDER RIGHT-HALF.
092392     IF LEFT-HALF = 0 MOVE 0 TO SCAN-POS
092392          ELSE SUBTRACT RIGHT-HALF FROM LEFT-HALF GIVING SCAN-POS.
092392     DIVIDE SCAN-POS BY ELEM-D-GRPLEN GIVING OCCURENCE.
092394     MOVE RIGHT-HALF TO LEFT-HALF.
092396     ADD SCAN-POS  RIGHT-HALF GIVING ELEM-D-FCHAR.
092398 TRY-NEXT.
092402     PERFORM GET-LEFT-VALUE.
092404     ADD 1 TO OCCURENCE.
092408     IF OCCURENCE = ELEM-D-NREPEATS GO TO FOUND-LAST.
092410     IF OCCURENCE > ELEM-D-NREPEATS GO TO BACK-1-UP.
092412     PERFORM SEARCH-FOR-STOPPER THRU STOP-EXIT.
092412     IF STOP-FLAG = 1 GO TO BACK-1-UP.
092412     ADD ELEM-D-GRPLEN TO SCAN-POS ELEM-D-FCHAR.
092414     SET X TO SAVE-LEFT-DX-X.
092416     GO TO TRY-NEXT.
092418 BACK-1-UP.
092422     SUBTRACT ELEM-D-GRPLEN FROM SCAN-POS.
092424     MOVE LEFT-HALF TO RIGHT-HALF.
092426     ADD SCAN-POS TO RIGHT-HALF.
092428     MULTIPLY C2E18 BY RIGHT-HALF.
092430     ADD LEFT-HALF RIGHT-HALF GIVING ELEM-D-FCHAR.
092430     SET X DOWN BY 1.
092430     PERFORM GET-LEFT-VALUE.
092432 FOUND-LAST.
092434     PERFORM IF-ER-LOOP THRU IF-EXIT.
092436     GO TO BUMP-ITEMS.
092480**********************************************************
092500*  IF-ANY INSTRUCTION VALUE 64
092520*==FILL IN CODE FOR RECORD BUFFER EXTRACTS===
092540**********************************************************
092542 IF-ANY.
092544* SET OCCURENCE TO BEGINNING OF ARRAY
092544* AND SET UP SCAN-POS FOR BUMP-ITEMS (IN CASE OF FIRST TIME HIT)
092544     MOVE 0 TO SCAN-POS.
092546     MOVE 1 TO OCCURENCE.
092548* GET LEFTSIDE DX; SET UP TRUEGO AND FALSEGO
092550     PERFORM IF-LOGIC THRU GET-LEFT-DX.
092552* CLEAR SCHAR TO POINT TO FIRST ELEMENT
092554     DIVIDE ELEM-D-FCHAR BY C2E18 GIVING LEFT-HALF
092556         REMAINDER ELEM-D-FCHAR.
092558* SAVE GROUP NAME FOR SYNCHRONIZATION OF ALL ITEMS IN GROUP
092560     MOVE ELEM-D-GRPNAME TO SAVED-GRPNAME.
092562* GET VALUE OF LEFTSIDE AND SET UP RELATIONSHIP
092564     PERFORM GET-LEFT-VALUE.
092566* IF WE ARE AT END OF ARRAY SET X TO FALSEGO AND SET ALL
092568* ITEMS IN THE GROUP TO THE SAME OCCURENCE
092570 CHK-NEXT-ITEM.
092572     IF OCCURENCE > ELEM-D-NREPEATS SET X TO FALSEGOX
092573         SUBTRACT ELEM-D-GRPLEN FROM SCAN-POS
092574         GO TO BUMP-ITEMS.
092574     PERFORM SEARCH-FOR-STOPPER THRU STOP-EXIT.
092574     GO TO COMP-STOP-CHAR.
092574 SEARCH-FOR-STOPPER.
092574     IF ELEM-D-STOPV = " " AND AHOLDER = SPACES
092574                  MOVE 1 TO STOP-FLAG
092574                  GO TO STOP-EXIT.
092574     IF ELEM-D-STOPV = ZERO AND NHOLDER-TYPE = 2 AND NHOLDER = 0
092574                  MOVE 1 TO STOP-FLAG
092574                  GO TO STOP-EXIT.
092574     MOVE 0 TO STOP-CHARS.
092574 SEARCHING-STOPPER.
092574     IF TRUE-TYPEV = 1  
092574         SET AHLX TO 1
092574         GO TO SEARCHING-STOPPER-A.
092574     COMPUTE WORKX = MAX-NITEM-LEN-UP1 - ELEM-D-NCHAR.
092574     IF WORKX < 1 MOVE 1 TO WORKX.
092574     SET NHLX TO WORKX.
092574 SEARCHING-STOPPER-N.
092574     IF NHLX > 18 GO TO SET-STOP-FLAG.
092574     IF NHOLDER-CHAR (NHLX) = ELEM-D-STOPV
092574         ADD 1 TO STOP-CHARS.
092574     SET NHLX UP BY 1.
092574     GO TO SEARCHING-STOPPER-N.
092574 SEARCHING-STOPPER-A.
092574     IF AHLX > ELEM-D-NCHAR GO TO SET-STOP-FLAG.
092574     IF AHOLDER-CHAR (AHLX)  = ELEM-D-STOPV
092574          ADD 1 TO STOP-CHARS.
092574     SET AHLX UP BY 1.
092574     GO TO SEARCHING-STOPPER-A.
092574 SET-STOP-FLAG.
092574      IF STOP-CHARS = ELEM-D-NCHAR MOVE 1 TO STOP-FLAG
092574         ELSE MOVE 0 TO STOP-FLAG.
092574 STOP-EXIT. EXIT.
092574 COMP-STOP-CHAR.
092578     IF STOP-FLAG = 1 SET X TO FALSEGOX
092580                              GO TO BUMP-ITEMS.
092582* USE IF LOGIC TO SEE IF THE RELATIONSHIP IS TRUE
092584     PERFORM IF-ER-LOOP THRU IF-EXIT.
092586     IF X = TRUEGOX GO TO BUMP-ITEMS.
092588* RESET X TO POINT TO LEFTSIDE DX, GET IT AND CALCULATE
092590* NEW STARTING ADDRESS FOR SCAN ELEMENT.
092592     SET X TO SAVE-LEFT-DX-X.
092594     PERFORM GET-LEFT-DX.
092594     DIVIDE ELEM-D-FCHAR BY C2E18 GIVING LEFT-HALF
092594          REMAINDER ELEM-D-FCHAR.
092596     MULTIPLY OCCURENCE BY ELEM-D-GRPLEN GIVING SCAN-POS.
092598     ADD SCAN-POS TO ELEM-D-FCHAR.
092600     ADD 1 TO OCCURENCE.
092602     PERFORM GET-LEFT-VALUE.
092604     GO TO CHK-NEXT-ITEM.
092606* THIS LOGIC SCANS THE DYNAMIC DICTIONARY AND SYNCHRONIZES
092608* ALL ITEMS IN THE SAME GROUP. IT WILL LEAVE THE POINTER
092610* TO THE CURRENT ELEMENT IN THE LEFT HALF-WORD OF FCHAR.
092612* AT END IT BRANCHES TO NEXT-INSTR. X IS PROPERLY SET.
092614 BUMP-ITEMS.
092616     MOVE 1 TO SCAN-ITEM-SW.
092618     SET DX TO DX-LOWEST.
092620 SEARCH-FOR-ITEMS.
092620     IF DX > MAX-DX GO TO NEXT-INSTR.
092626     IF D-GRPNAME (DX) = SAVED-GRPNAME
092626         DIVIDE D-FCHAR (DX) BY C2E18 GIVING LEFT-HALF
092628                                      REMAINDER RIGHT-HALF
092630         MOVE RIGHT-HALF TO LEFT-HALF
092632         ADD SCAN-POS TO RIGHT-HALF
092634         MULTIPLY C2E18 BY RIGHT-HALF
092636         ADD LEFT-HALF RIGHT-HALF GIVING D-FCHAR (DX).
092636     SET DX UP BY 1.
092636     GO TO SEARCH-FOR-ITEMS.
092640**********************************************************
092660*  IF-NEXT INSTRUCTION VALUE 65
092680*==FILL IN CODE FOR RECORD BUFFER EXTRACTS===
092700**********************************************************
092702 IF-NEXT.
092704* GET LEFT DX; SET TRUE AND FALSE GO
092706     PERFORM IF-LOGIC THRU GET-LEFT-DX.
092708     MOVE ELEM-D-GRPNAME TO SAVED-GRPNAME.
092710* CALCULATE NEW FIRST POSITION FOR SCAN ITEM
092714     DIVIDE ELEM-D-FCHAR BY C2E18 GIVING LEFT-HALF
092716                                  REMAINDER ELEM-D-FCHAR.
092716     IF LEFT-HALF = 0 MOVE 0 TO SCAN-POS
092716         ELSE SUBTRACT ELEM-D-FCHAR FROM LEFT-HALF
092716         GIVING SCAN-POS
092716         ADD ELEM-D-GRPLEN TO SCAN-POS.
092718     ADD SCAN-POS TO ELEM-D-FCHAR.
092718     DIVIDE SCAN-POS BY ELEM-D-NREPEATS GIVING OCCURENCE.
092720* GET VALUE AND SEE IF WE'RE AT END OF ARRAY
092722     PERFORM GET-LEFT-VALUE.
092724     IF OCCURENCE = ELEM-D-NREPEATS SET X TO FALSEGOX
092726                                    GO TO BUMP-ITEMS.
092728     PERFORM SEARCH-FOR-STOPPER THRU STOP-EXIT.
092730*     IF STOP-FLAG = 1 SET X TO FALSEGOX
092732*                                   GO TO BUMP-ITEMS.
092736*     PERFORM IF-ER-LOOP THRU IF-EXIT.
092738*     GO TO BUMP-ITEMS.
092739     GO TO COMP-STOP-CHAR.
092720
092780
092800**********************************************************
092805* THIS CODE IS PERFORMED BY READ ROUTINES WHEN IT IS NECESSARY
092810* TO RESET SCAN ITEMS TO THE FIRST OCCURENCE (IE WHEN A NEW
092815* RECORD IS READ THAT HAS SCAN ITEMS IN IT).
092860**********************************************************
092862 RESET-SCAN-ITEMS.
092862     MOVE 0 TO OCCURENCE.
092864* SET UP RANGES FOR DETERMINING WHETHER SCAN ITEM IS IN
092866* THE FILE THAT IS BEING READ.
092868     IF IN-SCAN1 MOVE 100 TO RANGE1 MOVE 700 TO RANGE2 
092869                 GO TO BEGIN-RESET.
092870     IF IN-SCAN2 MOVE 700 TO RANGE1 MOVE 1300 TO RANGE2 
092872                 GO TO BEGIN-RESET.
092872     IF IN-SCAN3 MOVE 1300 TO RANGE1
092874                 MOVE 1900 TO RANGE2
092876                 GO TO BEGIN-RESET.
092878* SEARCH FOR TYPES 1,2 OR 6 THAT HAVE GROUP NAME NOT EQUAL
092880* SPACE. SET SCHAR TO ZERO FOR THESE TYPES IF THEY ARE IN
092882* THE PROPER FILE.
092884 BEGIN-RESET.
092886     MOVE 0 TO SCAN-ITEM-SW.
092888     SET DX TO DX-LOWEST.
092890 CONTINUE-RESET.
092892     SEARCH D-ENTRY AT END GO TO RESET-SCAN-EXIT
092894       WHEN D-GRPNAME (DX) NOT = SPACE GO TO SET-SCHAR-0.
092894     SET DX UP BY 1.
092896     GO TO CONTINUE-RESET.
092898 SET-SCHAR-0.
092900     IF D-TYPEV (DX) > RANGE1 AND D-TYPEV (DX) < RANGE2
092902         DIVIDE CONST100 INTO D-TYPEV (DX) GIVING FILE-ROUTER
092904                                           REMAINDER TRUE-TYPEV
092906         IF TRUE-TYPEV = 1 OR 2 OR 6
092908             MOVE 1 TO SCAN-ITEM-SW
092910             DIVIDE C2E18 INTO D-FCHAR (DX) GIVING I
092912                                       REMAINDER D-FCHAR (DX).
092912     SET DX UP BY 1.
092914     GO TO CONTINUE-RESET.
092916 RESET-SCAN-EXIT.
092918     EXIT.
092940
092960******************************************************************
092980*  PICTURE INSTRUCTION.
093000*  INSTRUCTION FORMAT:
093020*  (X)   = INSTRUCTION VALUE 78.
093040*  (X+1) = DX OF ITEM WHOSE PICTURE IS TO BE CHANGED.
093060*  (X+2) THROUGH (X+5) = 24 CHARACTER STRING CONTAINING
093080*           NEW PICTURE AS LEFTMOST 19 CHARACTERS.
093100*  ABOVE CONTINUES IN PAIRS UNTIL DX = 0. NEXT INSTRUCTION
093120*  FOLLOWS.
093140**********************************************************
093160
093180 PICTURER.
093200     ENTER MACRO IQGETI.
093220     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
093240     SET DX TO ELEM-INSTR.
093260     ENTER MACRO IQGETD.
093280     SET WORKX TO X.
093300     MULTIPLY CHARS-PER-WORD BY WORKX GIVING WORKX.
093320     ADD 1 TO WORKX.
093340     ENTER MACRO IQSX66 USING CONST20
093360           INSTR-TABLE WORKX ELEM-D-PICT CONST1.
093380*    *NOW SET UP NEW VALUE FOR ELEM-D-ECHAR*
093400     EXAMINE ELEM-D-PICT TALLYING UNTIL FIRST ' '.
093420     MOVE TALLY TO ELEM-D-ECHAR.
093440     IF ELEM-D-ECHAR GREATER THAN CONST20
093460         MOVE CONST20 TO ELEM-D-ECHAR.
093480     EXAMINE ELEM-D-PICT TALLYING UNTIL FIRST 'R'.
093500     IF TALLY LESS THAN ELEM-D-ECHAR MOVE TALLY TO ELEM-D-ECHAR.
093520     ENTER MACRO IQPUTD.
093540     SET X UP BY 5.
093560     GO TO PICTURER.
093580
093600**********************************************************
093620*  TITLER INSTRUCTION.
093640*  INSTRUCTION FORMAT:
093660*  (X)   = INSTRUCTION VALUE 79.
093680*  (X+1) = DX OF ENTRY WHOSE TITLES ARE TO BE CHANGED.
093700*  (X+2) THROUGH (X+5) = 24 CHARACTER STRING CONTAINING
093720*          TOP TITLE AS LEFTMOST 10 CHARS AND BOTTOM TITLE
093740*          AS NEXT 10 CHARS.
093760*  ABOVE CONTINUES IN PAIRS UNTIL DX = 0. NEXT
093780*  INSTRUCTION FOLLOWS.
093800**********************************************************
093820
093840 TITLE-IT.
093860     ENTER MACRO IQGETI.
093880     IF ELEM-INSTR = 0 GO TO NEXT-INSTR-UPX.
093900     SET DX TO ELEM-INSTR.
093920     ENTER MACRO IQGETD.
093940     SET WORKX TO X.
093960     MULTIPLY CHARS-PER-WORD BY WORKX GIVING WORKX.
093980     ADD 1 TO WORKX.
094000     ENTER MACRO IQSX66 USING CONST20
094020         INSTR-TABLE WORKX ELEM-D-TITLE1 CONST1.
094040*    *SET UP REVISED TITLE LENGTH IN ELEM-D-TCHAR*
094060     MOVE 10 TO I.
094080
094100 TITLE-IT1.
094120     IF EDT1 (I) NOT = ' ' OR EDT2 (I) NOT = ' '
094140         GO TO TITLE-IT2.
094160     SUBTRACT 1 FROM I.
094180     IF I GREATER THAN 0 GO TO TITLE-IT1.
094200
094220 TITLE-IT2.
094240     MOVE I TO ELEM-D-TCHAR.
094260     ENTER MACRO IQPUTD.
094280     SET X UP BY 5.
094300     GO TO TITLE-IT.
094320
094340
094360*$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
094380*  GENERAL USAGE SUBROUTINES FOLLOW.
094400*$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
094420***********************************************************
094440* SUBROUTINE TO ISSUE PROMPT, AND
094460*    PHYSICALLY GET AN ITEM VALUE FROM TERMINAL.
094480*    DESTROYS I, J, L CONTENTS.
094500*    MOVES DYN-DD-ENTRY TO ELEM-DD-ENTRY.
094520***********************************************************
094540
094560 RECEIVE-ITEM.
094580     DIVIDE CONST100 INTO ELEM-D-TYPEV GIVING FILE-ROUTER
094600         REMAINDER TRUE-TYPEV.
094620     PERFORM BUILD-PROMPT THRU BUILD-PROMPT-EXIT.
094640     DISPLAY PROMPT-LINE-SHORT UPON CONSOLE WITH NO ADVANCING.
094660     MOVE 0 TO ALL-SPACES-FLAG  LITERAL-FLAG
094680         SPECIAL-ITM-FLAG.
094700     MOVE SPACES TO AHOLDER AHOLDER-EXTENSION1
094704         AHOLDER-EXTENSION2 AHOLDER-EXTENSION3.
094720     ACCEPT AHOLDER FROM TTY.
094740*    *IF VALUE IS ENCLOSED IN QUOTES, GET RID OF THEM*.
094760     IF AHOLDER-1 = '"'
094780         EXAMINE AHOLDER REPLACING ALL '"' BY ' '
094800         GO TO RECEIVE-ITEM1.
094820     IF AHOLDER-1 = "'"
094840         EXAMINE AHOLDER REPLACING ALL "'" BY " "
094860         GO TO RECEIVE-ITEM1.
094880     GO TO RECEIVE-ITEM2.
094900 RECEIVE-ITEM1.
094920     ENTER MACRO IQSX66 USING CONST63
094940         AHOLDER CONST2 AHOLDER CONST1.
094960     GO TO RECEIVE-ITEM3.
094980 RECEIVE-ITEM2.
095000     IF AHOLDER = SPACES MOVE 1 TO ALL-SPACES-FLAG
095020         IF TRUE-TYPEV = 1 OR 12 OR 33 OR 34 OR 36
095024             GO TO RECEIVE-ITEM3
095040         ELSE MOVE 0 TO AHOLDER-1.
095060
095080
095100 RECEIVE-ITEM3.
095120     IF TRUE-TYPEV = 1 OR 12 OR 33 OR 34 OR 36
095124         MOVE 1 TO NHOLDER-TYPE
095140         SUBTRACT ELEM-D-NCHAR FROM 0 GIVING NHOLDER-SCALE
095160         GO TO RECEIVE-ITEM-EXIT.
095180     PERFORM JUST-RIGHT THROUGH JUST-RIGHT-EXIT.
095200     MOVE 2 TO NHOLDER-TYPE.
095220     MOVE ELEM-D-SCALE TO NHOLDER-SCALE.
095240     IF ENTRY-ERROR-FLAG = 1
095260         MOVE '%Item is too long or contains alpha'
095280           TO PRINT-LINE
095300         DISPLAY PRINT-LINE UPON CONSOLE
095320         GO TO RECEIVE-ITEM.
095340
095360 RECEIVE-ITEM-EXIT.
095380     EXIT.
095400
095420**********************************************************
095440* SUBROUTINE TO CONSTRUCT A PROMPT FOR ITEM VALUE
095460* WORKS FROM VALUES IN CURRENT ELEM-D-ENTRY.
095480**********************************************************
095500
095520 BUILD-PROMPT.
095540     MOVE SPACES TO PROMPT-LINE.
095560     MOVE '*' TO BASIC-LINE-ASTERISK.
095580     MOVE ':' TO BASIC-LINE-COLON.
095600     MOVE ELEM-D-TITLE1 TO BASIC-LINE-TITLE1.
095620     MOVE ELEM-D-TITLE2 TO BASIC-LINE-TITLE2.
095640     IF ELEM-D-SCALE  NOT = 0 MOVE '.' TO BASIC-LINE-POINT
095660         MOVE ELEM-D-SCALE TO BASIC-LINE-DECIMALS
095680         MOVE ELEM-D-NCHAR TO L
095700         SUBTRACT ELEM-D-SCALE FROM L
095720         MOVE L TO BASIC-LINE-NCHAR
095740             ELSE MOVE ELEM-D-NCHAR TO BASIC-LINE-NCHAR.
095760     IF TRUE-TYPEV = 1 OR 12 OR 33 OR 34 OR 36
095764         MOVE "A" TO BASIC-LINE-TYPEV
095780         ELSE MOVE 'N' TO BASIC-LINE-TYPEV.
095800     MOVE 1 TO I.  MOVE 1 TO J.  MOVE 1 TO L.
095820
095840 BUILD-PROMPT1.
095860     IF PROMPT-CHAR (I) NOT = ' ' MOVE 0 TO L
095880         GO TO BUILD-PROMPT2.
095900     IF L = 0 MOVE 1 TO L
095920         GO TO BUILD-PROMPT2.
095940     ADD 1 TO I.
095960     IF I NOT GREATER THAN MAX-PROMPT GO TO BUILD-PROMPT1.
095980     GO TO BUILD-PROMPT3.
096000
096020 BUILD-PROMPT2.
096040     MOVE PROMPT-CHAR (I) TO PROMPT-CHAR (J).
096060     ADD 1 TO I. ADD 1 TO J.
096080     IF I NOT GREATER THAN MAX-PROMPT GO TO BUILD-PROMPT1.
096100
096120 BUILD-PROMPT3.
096140     IF J NOT GREATER THAN MAX-PROMPT
096160         MOVE ' ' TO PROMPT-CHAR (J)
096180         ADD 1 TO J
096200         GO TO BUILD-PROMPT3.
096220
096240 BUILD-PROMPT-EXIT.
096260     EXIT.
096280
096300***********************************************************
096320* SUBROUTINE BELOW RIGHT JUSTIFIES AN ITEM JUST RECEIVED
096340* FROM THE TERMINAL.  PEELS OUT COMMAS, DECIMALS AND DOLLAR SIGNS.
096360* SCALES WITH FILLED IN ZEROES FOR UNENTERED DECIMALS AND LEFT
096380* FILLS WITH LEADING ZEROES IF NECESSARY.  MINUS IN FRONT GIVES A
096400* NEGATIVE QUANTITY IN APPROPRIATE NHOLDER.  THIS ROUTINE RELIES
096420* ON THE CURRENT DD BEING IN ELEM-D-ENTRY.
096440* DESTROYS I, J, L CONTENTS.
096460***********************************************************
096480
096500 JUST-RIGHT.
096520     MOVE 0 TO L DECIMAL-FLAG ENTRY-ERROR-FLAG MINUS-FLAG.
096540     SET AHLX TO 0.  SET NHLX TO 0.
096560     MOVE 0 TO NHOLDER.
096580
096600 JUST-RIGHT1.
096620*    *PROCESS ANY LEADING NON NUMERIC CHARACTERS*.
096640     SET AHLX UP BY 1.
096660     IF AHLX GREATER THAN MAX-AITEM-LEN GO TO JUST-RIGHT7.
096680     MOVE AHOLDER-CHAR (AHLX) TO ELEM-CHAR.
096700     IF ELEM-CHAR IS NUMERIC GO TO JUST-RIGHT3.
096720     IF ELEM-CHAR = '.' MOVE 1 TO DECIMAL-FLAG
096740         SET AHLX UP BY 1
096760         GO TO JUST-RIGHT2.
096780     IF ELEM-CHAR = '$' OR ',' GO TO JUST-RIGHT1.
096800     IF ELEM-CHAR NOT = '-' AND NOT = '+'
096820         GO TO JUST-RIGHT-ERROR.
096840     IF MINUS-FLAG NOT = 0 GO TO JUST-RIGHT-ERROR.
096860     IF ELEM-CHAR = '-' MOVE 1 TO MINUS-FLAG
096880         ELSE MOVE 2 TO MINUS-FLAG.
096900     GO TO JUST-RIGHT1.
096920
096940 JUST-RIGHT2.
096960*    *PROCESS NUMERIC CHARACTERS*.
096980     MOVE AHOLDER-CHAR (AHLX) TO ELEM-CHAR.
097000     IF ELEM-CHAR NOT NUMERIC GO TO JUST-RIGHT5.
097020
097040 JUST-RIGHT3.
097060     SET NHLX UP BY 1.
097080     MOVE ELEM-CHAR TO AHOLDER-CHAR (NHLX).
097100     IF DECIMAL-FLAG = 1 ADD 1 TO L.
097120
097140 JUST-RIGHT4.
097160     SET AHLX UP BY 1.
097180     IF AHLX GREATER THAN MAX-AITEM-LEN GO TO JUST-RIGHT7.
097200     GO TO JUST-RIGHT2.
097220
097240 JUST-RIGHT5.
097260     IF ELEM-CHAR = ' ' GO TO JUST-RIGHT7.
097280     IF ELEM-CHAR = '-' OR '+' GO TO JUST-RIGHT6.
097300     IF DECIMAL-FLAG = 1 GO TO JUST-RIGHT-ERROR.
097320     IF ELEM-CHAR = ',' GO TO JUST-RIGHT4.
097340     IF ELEM-CHAR = '.' MOVE 1 TO DECIMAL-FLAG
097360         GO TO JUST-RIGHT4.
097380
097400 JUST-RIGHT6.
097420     IF MINUS-FLAG NOT = 0 GO TO JUST-RIGHT-ERROR.
097440     SET AHLX UP BY 1.
097460     IF AHOLDER-CHAR (AHLX) NOT = ' ' GO TO JUST-RIGHT-ERROR.
097480     IF ELEM-CHAR = '-' MOVE 1 TO MINUS-FLAG
097500         ELSE MOVE 2 TO MINUS-FLAG.
097520
097540 JUST-RIGHT7.
097560*    *FILL IN ANY TRAILING (AFTER .) ZEROES NEEDED*.
097580     IF L = ELEM-D-SCALE GO TO JUST-RIGHT8.
097600     IF L GREATER THAN ELEM-D-SCALE GO TO JUST-RIGHT-ERROR.
097620     SET NHLX UP BY 1.
097640     MOVE 0 TO AHOLDER-CHAR (NHLX).
097660     ADD 1 TO L.
097680     GO TO JUST-RIGHT7.
097700
097720 JUST-RIGHT8.
097740*    *SEE IF SUPPLIED NUMBER IS TOO LONG*.
097760     IF NHLX GREATER THAN ELEM-D-NCHAR GO TO JUST-RIGHT-ERROR.
097780     SET J TO NHLX.
097800     SUBTRACT J FROM MAX-NITEM-LEN-UP1 GIVING WORKX.
097820     ENTER MACRO IQSX66 USING J AHOLDER CONST1
097840         NHOLDER WORKX.
097860     IF MINUS-FLAG NOT = 1 GO TO JUST-RIGHT-EXIT.
097880*    *IF (-) FURNISHED MAKE QUANTITY NEGATIVE*.
097900     SUBTRACT NHOLDER FROM 0 GIVING NHOLDER.
097920     GO TO JUST-RIGHT-EXIT.
097940
097960 JUST-RIGHT-ERROR.
097980     MOVE 0 TO NHOLDER.
098000     MOVE 1 TO ENTRY-ERROR-FLAG.
098020     DISPLAY '%' ELEM-D-TITLE1 ELEM-D-TITLE2 'value improper'
098040         UPON CONSOLE.
098060
098080 JUST-RIGHT-EXIT.
098100     EXIT.
098120
098140**********************************************************
098160* SUBROUTINE TO EXTRACT AN ITEM VALUE FROM THE CURRENT
098180* INPUT RECORD, A WORKING LOCATION, OR A SPECIAL ITEM.
098200* EXTRACTED VALUE IS LEFT IN NHOLDER IF NUMERIC,
098220* AHOLDER IF ALPHA.
098240* IT DOES THIS UNDER CONTROL OF THE DD CURRENTLY IN
098260* ELEM-D-ENTRY.  IT ALSO EXPECTS DX TO POINT TO THE
098280* CORRECT ENTRY.
098300*
098320* NOTE THAT THERE ARE THREE ENTRANCES TO THIS SUBROUTINE:
098340* GETN-VALUE TO GET NUMBERS AS NUMERIC IN NHOLDER.
098360* GETB-VALUE TO GET NUMBERS AS BINARY IN BHOLDER.
098380* GETN-VALUE TO GET NUMBERS AS THEIR INPUT TYPE;
098400*     NUMERICS IN NHOLDER
098420*     VARIABLES, BINARIES IN BHOLDER.
098440*
098460* ITEM TYPES ARE:
098480*   1  = ALPHA ITEM FROM RECORD.
098500*   2  = NUMERIC ITEM FROM RECORD.
098520*   3  = RESERVED FOR FUTURE PACKED SIGNED.
098540*   4  = RESERVED FOR FUTURE PACKED UNSIGNED.
098560*   5  = RESERVED FOR FUTURE FLOATING POINT.
098580*   6  = BINARY ITEM FROM RECORD.
098600*   7  = COMP WORK ITEM (VARIABLE, TALLY OR TOTAL).
098620*   8  = COMP AVERAGE.
098640*   9  = CONSTANT (BOTH NUMERIC AND COMP).
098660*  10  = LITERAL.
098680*  11  = XRANDOM (10 DIGIT RANDOM NUMBER).
098700*  12  = USED BY IQA FOR ALPHA WORK ITEMS (TEMP).
098720*  13  = SINGLE-ENTRY ISAM KEY.
098740*  14  = DOUBLE-ENTRY (RANGE THRU) ISAM KEY.
098760*  15  = DOUBLE-ENTRY (RANGE TO) ISAM KEY.
098780*  16  = TODAY'S DATE AS YYMMDD.
098782*  24  = DBMS ERROR-STATUS
098784*  32  = CURRENT RECORD KEY
098786*  33  = RECORD-NAME
098788*  34  = AREA-NAME
098790*  35  = ERROR-COUNT
098792*  36  = AREA-NAME-IDENT
098800*  NOTE THAT TYPES 7-10,12-14 HAVE THE VALUE IN THE DYN
098820*    DICT ENTRY ITSELF.
098840*  NOTE: USES WORK ITEM I.
098860*
098880*  NOTE: IF ITEM IS NUMERIC, THIS SUBROUTINE SETS
098900*        NHOLDER-SCALE TO >= 0; IF ITEM IS ALPHA,
098920*        SETS NHOLDER-TYPE TO 1; THIS CAN BE USED
098940*        AS A QUICK DOWNSTREAM TEST.
098960*   FOR ALPHA ITEMS AND LITERAL, NHOLDER-SCALE
098980*   IS SET TO -LENGTH OF ITEM
099000*
099020*   ON RETURN, TRUE-TYPEV IS SET TO THE TRUE TYPE OF THE
099040*   DATA ITEM; THAT IS, WITH THE FILE ROUTER STRIPPED OFF.
099060*
099080**********************************************************
099100
099120*    *BUFFER EXTRACT LOGIC WORKS IF WE RETAIN
099140*    *THE -SAME AREA- DEFINITIONS CURRENTLY IN I O CONTROL
099160*    *WHERE THE SEQUENTIAL AND ISAM FILES ARE SAME AREAED.
099180
099200 GETN-VALUE.
099205     MOVE SPACES TO AHOLDER.
099220     MOVE 2 TO TARGET-ROUTER.
099240     DIVIDE CONST100 INTO ELEM-D-TYPEV GIVING FILE-ROUTER
099260         REMAINDER TRUE-TYPEV.
099280     ADD 1 TO FILE-ROUTER.
099300     GO TO  GIV1    GIV2    GIVERR  GIVERR  GIVERR  GIV6
099320            GIV7N   GIV8N   GIV9N   GIV10   GIV11N  GIV12
099340            GIVERR  GIVERR  GIVERR  GIV16N  GIVERR  GIVERR
099350            GIVERR  GIVERR  GIVERR  GIVERR  GIVERR  GIV24N
099362            GIVERR  GIVERR  GIVERR  GIVERR  GIVERR  GIVERR
099364            GIVERR  GIV32N  GIV33   GIV34   GIV35N  GIV36
099366            DEPENDING ON TRUE-TYPEV.
099380     GO TO GIVERR.
099400
099420 GETB-VALUE.
099425     MOVE SPACES TO AHOLDER.
099440     MOVE 6 TO TARGET-ROUTER.
099460     DIVIDE CONST100 INTO ELEM-D-TYPEV GIVING FILE-ROUTER
099480         REMAINDER TRUE-TYPEV.
099500     ADD 1 TO FILE-ROUTER.
099520     GO TO  GIV1    GIV2    GIVERR  GIVERR  GIVERR  GIV6
099540            GIV7B   GIV8B   GIV9B   GIV10   GIV11B  GIV12
099560            GIVERR  GIVERR  GIVERR  GIV16B  GIVERR  GIVERR
099570            GIVERR  GIVERR  GIVERR  GIVERR  GIVERR  GIV24N
099572            GIVERR  GIVERR  GIVERR  GIVERR  GIVERR  GIVERR
099574            GIVERR  GIV32B  GIV33   GIV34   GIV35B  GIV36
099580            DEPENDING ON TRUE-TYPEV.
099600    GO TO GIVERR.
099620
099640 GET-VALUE.
099645     MOVE SPACES TO AHOLDER.
099660     DIVIDE CONST100 INTO ELEM-D-TYPEV GIVING FILE-ROUTER
099680         REMAINDER TRUE-TYPEV.
099700     MOVE TRUE-TYPEV TO TARGET-ROUTER.
099720     ADD 1 TO FILE-ROUTER.
099740     GO TO  GIV1    GIV2    GIVERR  GIVERR  GIVERR   GIV6
099760            GIV7B   GIV8B   GIV9B   GIV10   GIV11N   GIV12
099780            GIVERR  GIVERR  GIVERR  GIV16N  GIVERR  GIVERR
099790            GIVERR  GIVERR  GIVERR  GIVERR  GIVERR  GIV24N
099792            GIVERR  GIVERR  GIVERR  GIVERR  GIVERR  GIVERR
099794            GIVERR  GIV32B  GIV33   GIV34   GIV35B  GIV36
099800            DEPENDING ON TRUE-TYPEV.
099820     GO TO GIVERR.
099840
099860 GIV1.
099880 GIV12.
099882     IF ELEM-D-FCHAR < C2E18 NEXT SENTENCE
099884         ELSE DIVIDE C2E18 INTO ELEM-D-FCHAR.
099900*    *SET UP GENERAL STATUS OF AHOLDER*
099920     MOVE 1 TO NHOLDER-TYPE.
099960     SUBTRACT ELEM-D-NCHAR FROM 0 GIVING NHOLDER-SCALE.
099980*    *NOW ROUTE CONTROL TO EXTRACT FROM PROPER BUFFER*
100000*    *0 IS HOLD-BUFFER; OTHER IS FROM TABLE FOR READ SEQUENTIAL*
100020     GO TO GIV1-0  GIV1-1  GIV1-2  GIV1-1  GIV1-2  GIVERR
100040           GIVERR  GIV1-7  GIV1-8  GIV1-7  GIV1-8  GIVERR
100060           GIVERR  GIV1-13 GIV1-14 GIV1-13 GIV1-14
100080           DEPENDING ON FILE-ROUTER.
100100     GO TO GIVERR.
100200 GIV1-0. ENTER MACRO IQSX66 USING ELEM-D-NCHAR HOLD-BUFFER
100220         ELEM-D-FCHAR AHOLDER CONST1. GO TO GIV-DONE.
100240 GIV1-1. ENTER MACRO IQSX66 USING ELEM-D-NCHAR INF1SD6-REC
100260         ELEM-D-FCHAR AHOLDER CONST1. GO TO GIV-DONE.
100280 GIV1-2. ENTER MACRO IQSX76 USING ELEM-D-NCHAR INF1SD7-REC
100300         ELEM-D-FCHAR AHOLDER CONST1. GO TO GIV-DONE.
100320 GIV1-7. ENTER MACRO IQSX66 USING ELEM-D-NCHAR INF2SD6-REC
100340         ELEM-D-FCHAR AHOLDER CONST1. GO TO GIV-DONE.
100360 GIV1-8. ENTER MACRO IQSX76 USING ELEM-D-NCHAR INF2SD7-REC
100380         ELEM-D-FCHAR AHOLDER CONST1. GO TO GIV-DONE.
100400 GIV1-13. ENTER MACRO IQSX66 USING ELEM-D-NCHAR INF3SD6-REC
100420          ELEM-D-FCHAR AHOLDER CONST1. GO TO GIV-DONE.
100440 GIV1-14. ENTER MACRO IQSX76 USING ELEM-D-NCHAR INF3SD7-REC
100460          ELEM-D-FCHAR AHOLDER CONST1. GO TO GIV-DONE.
100480
100500 GIV2.
100510     MOVE 0 TO NHOLDER.
100502     IF ELEM-D-FCHAR < C2E18 NEXT SENTENCE
100504         ELSE DIVIDE C2E18 INTO ELEM-D-FCHAR.
100520     MOVE ELEM-D-SCALE TO NHOLDER-SCALE.
100540     MOVE TARGET-ROUTER TO NHOLDER-TYPE.
100580     SUBTRACT ELEM-D-NCHAR FROM MAX-NITEM-LEN-UP1 GIVING I.
100600     GO TO GIV2-0  GIV2-1  GIV2-2  GIV2-1  GIV2-2  GIVERR
100620           GIVERR  GIV2-7  GIV2-8  GIV2-7  GIV2-8  GIVERR
100640           GIVERR  GIV2-13 GIV2-14 GIV2-13 GIV2-14
100660           DEPENDING ON FILE-ROUTER.
100680     GO TO GIVERR.
100780 GIV2-0.  ENTER MACRO IQSX66 USING ELEM-D-NCHAR HOLD-BUFFER
100800          ELEM-D-FCHAR ANHOLDER I. GO TO GIV2B.
100820 GIV2-1.  ENTER MACRO IQSX66 USING ELEM-D-NCHAR INF1SD6-REC
100840          ELEM-D-FCHAR ANHOLDER I. GO TO GIV2B.
100860 GIV2-2.  ENTER MACRO IQSX76 USING ELEM-D-NCHAR INF1SD7-REC
100880          ELEM-D-FCHAR ANHOLDER I. GO TO GIV2B.
100900 GIV2-7.  ENTER MACRO IQSX66 USING ELEM-D-NCHAR INF2SD6-REC
100920          ELEM-D-FCHAR ANHOLDER I. GO TO GIV2B.
100940 GIV2-8.  ENTER MACRO IQSX76 USING ELEM-D-NCHAR INF2SD7-REC
100960          ELEM-D-FCHAR ANHOLDER I. GO TO GIV2B.
100980 GIV2-13. ENTER MACRO IQSX66 USING ELEM-D-NCHAR INF3SD6-REC
101000          ELEM-D-FCHAR ANHOLDER I. GO TO GIV2B.
101020 GIV2-14. ENTER MACRO IQSX76 USING ELEM-D-NCHAR INF3SD7-REC
101040          ELEM-D-FCHAR ANHOLDER I. GO TO GIV2B.
101060
101080 GIV2B.
101090     EXAMINE ANHOLDER REPLACING ALL ' ' BY '0'.
101100     IF TARGET-ROUTER = 6
101120         MOVE NHOLDER TO BHOLDER.
101140     GO TO GIV-DONE.
101160
101180 GIVERR.
101220     DISPLAY '%Trying to get from illegal item type '
101222         TRUE-TYPEV ' in file ' FILE-ROUTER
101224         UPON CONSOLE.
101240     MOVE SPACES TO AHOLDER.  MOVE 1 TO NHOLDER-TYPE.
101260     MOVE -1 TO NHOLDER-SCALE.
101280     MOVE 0 TO BHOLDER.
101300     GO TO GIV-DONE.
101320
101340 GIV6.
101344     IF ELEM-D-FCHAR < C2E18 NEXT SENTENCE
101348         ELSE DIVIDE C2E18 INTO ELEM-D-FCHAR.
101360     MOVE ELEM-D-SCALE TO NHOLDER-SCALE.
101380     MOVE TARGET-ROUTER TO NHOLDER-TYPE.
101400     GO TO GIV6-0  GIV6-1  GIV6-2  GIV6-1  GIV6-2  GIVERR
101420           GIVERR  GIV6-7  GIV6-8  GIV6-7  GIV6-8  GIVERR
101440           GIVERR  GIV6-13 GIV6-14 GIV6-13 GIV6-14
101460           DEPENDING ON FILE-ROUTER.
101540     GO TO GIVERR.
101560 GIV6-0. ENTER MACRO IQSX66 USING CONST12 HOLD-BUFFER
101580         ELEM-D-FCHAR BHOLDER-ALPHA CONST1. GO TO GIV6B.
101600 GIV6-1.  ENTER MACRO IQSX66 USING CONST12 INF1SD6-REC
101620          ELEM-D-FCHAR BHOLDER-ALPHA CONST1. GO TO GIV6B.
101640 GIV6-2.  
101642*    *HERE IF HAVE COMP ITEM FROM ASCII - CALC ORIGIN.
101644     COMPUTE I = ( (ELEM-D-FCHAR - 1) / 5) * 6 + 1.
101646     ENTER MACRO IQSX66 USING CONST12 INF1SD6-REC
101648         I BHOLDER-ALPHA CONST1. GO TO GIV6B.
101660 GIV6-7.  ENTER MACRO IQSX66 USING CONST12 INF2SD6-REC
101680          ELEM-D-FCHAR BHOLDER-ALPHA CONST1. GO TO GIV6B.
101700 GIV6-8.  
101702     COMPUTE I = ( (ELEM-D-FCHAR - 1) / 5) * 6 + 1.
101704     ENTER MACRO IQSX66 USING CONST12 INF2SD6-REC
101706         I BHOLDER-ALPHA CONST1. GO TO GIV6B.
101720 GIV6-13. ENTER MACRO IQSX66 USING CONST12 INF3SD6-REC
101740          ELEM-D-FCHAR BHOLDER-ALPHA CONST1. GO TO GIV6B.
101760 GIV6-14. 
101762     COMPUTE I = ( (ELEM-D-FCHAR - 1) / 5) * 6 + 1.
101764     ENTER MACRO IQSX66 USING CONST12 INF3SD6-REC
101766         I BHOLDER-ALPHA CONST1. GO TO GIV6B.
101780
101800 GIV6B.
101820     IF NHOLDER-TYPE = 2 IF ELEM-D-NCHAR LESS THAN 11
101840         MOVE BHOLDER-LEFT TO NHOLDER GO TO GIV-DONE
101860         ELSE MOVE BCOMP12 TO NHOLDER GO TO GIV-DONE.
101880     IF ELEM-D-NCHAR GREATER THAN 10
101900         GO TO GIV-DONE.
101920     MOVE BHOLDER-LEFT TO WORKX.
101940     MOVE WORKX TO BCOMP12.
101960     GO TO GIV-DONE.
101980
102000 GIV7N.
102020     MOVE ELEM-D-SCALE TO NHOLDER-SCALE.
102040     MOVE 2 TO NHOLDER-TYPE.
102060     MOVE ELEM-V-BINARY TO NHOLDER.
102080     GO TO GIV-DONE.
102100
102120 GIV7B.
102140     MOVE ELEM-D-SCALE TO NHOLDER-SCALE.
102160     MOVE 6 TO NHOLDER-TYPE.
102180     MOVE ELEM-V-BINARY TO BHOLDER.
102200     GO TO GIV-DONE.
102220
102240 GIV8N.
102260     MOVE ELEM-D-SCALE TO NHOLDER-SCALE.
102280     MOVE 2 TO NHOLDER-TYPE.
102300     DIVIDE ELEM-V-WORK INTO ELEM-V-BINARY
102320         GIVING NHOLDER ROUNDED.
102340     GO TO GIV-DONE.
102360
102380 GIV8B.
102400     MOVE ELEM-D-SCALE TO NHOLDER-SCALE.
102420     MOVE 6 TO NHOLDER-TYPE.
102440     DIVIDE ELEM-V-WORK INTO ELEM-V-BINARY
102460         GIVING BHOLDER ROUNDED.
102480     GO TO GIV-DONE.
102500
102520 GIV9N.
102540     MOVE ELEM-D-SCALE TO NHOLDER-SCALE.
102560     MOVE 2 TO NHOLDER-TYPE.
102580     MOVE ELEM-C-NUMERIC TO NHOLDER.
102600     GO TO GIV-DONE.
102620
102640 GIV9B.
102660     MOVE ELEM-D-SCALE TO NHOLDER-SCALE.
102680     MOVE 6 TO NHOLDER-TYPE.
102700     MOVE ELEM-C-BINARY TO BHOLDER.
102720     GO TO GIV-DONE.
102740
102760 GIV10.
102780     MOVE 1 TO NHOLDER-TYPE.
102820     SUBTRACT ELEM-D-NCHAR FROM 0 GIVING NHOLDER-SCALE.
102840     IF ELEM-D-NCHAR NOT GREATER THAN 0 GO TO GIV-DONE.
102860     IF ELEM-D-NCHAR LESS THAN 79
102880         ENTER MACRO IQSX66 USING ELEM-D-NCHAR
102900         ELEM-L-VALUE CONST1 AHOLDER CONST1
102920         GO TO GIV-DONE.
102940*====*REVIEW LOGIC FOR LONGER-THAN-72 LITERALS====*
102960*    *MOVE LONGER-THAN-72 LITERAL DIRECTLY FROM D-ENTRY*.
102980     SET WORKX TO DX.
103000*    *NOTE: ((DX-1)*90)+13 = (90*DX)-77.
103020     MULTIPLY WORKX BY 90 GIVING WORKX.
103040     SUBTRACT 77 FROM WORKX.
103060     ENTER MACRO IQSX66 USING ELEM-D-NCHAR
103080         INSTR-TABLE WORKX AHOLDER CONST1.
103100     GO TO GIV-DONE.
103120
103140 GIV11N.
103160     MOVE 0 TO NHOLDER-SCALE.
103180     MOVE 2 TO NHOLDER-TYPE.
103200*    *GENERATE A NEW RANDOM NUMBER FOR EACH TIME*
103220     MOVE ZEROES TO SEED-JUNK.
103240     MULTIPLY SEEDER BY SEED-MULT GIVING SEEDER.
103260     ADD SEED-INC TO SEEDER.
103280     MOVE SEED-JUNK TO SEED-WORK.
103300     ADD SEED-WORK TO SEEDER.
103320     MOVE SEED TO NHOLDER.
103340     GO TO GIV-DONE.
103360
103380 GIV11B.
103400     MOVE 0 TO NHOLDER-SCALE.
103420     MOVE 6 TO NHOLDER-TYPE.
103440     MOVE ZEROES TO SEED-JUNK.
103460     MULTIPLY SEEDER BY SEED-MULT GIVING SEEDER.
103480     ADD SEED-INC TO SEEDER.
103500     MOVE SEED-JUNK TO SEED-WORK.
103520     ADD SEED-WORK TO SEEDER.
103540     MOVE SEED TO BHOLDER.
103560     GO TO GIV-DONE.
103580
103600 GIV16N.
103620     MOVE 0 TO NHOLDER-SCALE.
103640     MOVE 6 TO NHOLDER-TYPE.
103660     MOVE TODAYS-DATE TO NHOLDER BHOLDER.
103680     GO TO GIV-DONE.
103700
103720 GIV16B.
103740     MOVE 0 TO NHOLDER-SCALE.
103760     MOVE 6 TO NHOLDER-TYPE.
103780     MOVE TODAYS-DATE TO BHOLDER.
103782     GO TO GIV-DONE.
103784
103790 GIV24N.
103794     MOVE 0 TO NHOLDER-SCALE.
103798     MOVE 2 TO NHOLDER-TYPE.
103802     MOVE ERROR-STATUS TO NHOLDER.
103804     MOVE ERROR-STATUS TO BHOLDER.
103806     GO TO GIV-DONE.
103808
103810 GIV24B.
103812     MOVE 0 TO NHOLDER-SCALE.
103814     MOVE 6 TO NHOLDER-TYPE.
103816     MOVE ERROR-STATUS TO BHOLDER.
103818     MOVE ERROR-STATUS TO NHOLDER.
103820     GO TO GIV-DONE.
103822
103824 GIV32B.
103825     MOVE 6 TO TRUE-TYPEV.
103826     MOVE 6 TO NHOLDER-TYPE.
103828     MOVE 0 TO NHOLDER-SCALE.
103830     MOVE CURRENT-RECORD-KEY TO BHOLDER.
103832     GO TO GET-VALUE-EXIT.
103834
103836 GIV32N.
103837     MOVE 2 TO TRUE-TYPEV.
103838     MOVE 2 TO NHOLDER-TYPE.
103840     MOVE 0 TO NHOLDER-SCALE.
103842     MOVE CURRENT-RECORD-KEY TO NHOLDER.
103844     GO TO GET-VALUE-EXIT.
103846
103848 GIV33.
103849     MOVE 1 TO TRUE-TYPEV.
103850     ENTER MACRO IQSX76 USING CONST30 SYSCOM-RECORD-NAME
103851         CONST1 AHOLDER CONST1.
103852     MOVE 1 TO NHOLDER-TYPE.
103854     MOVE -30 TO NHOLDER-SCALE.
103856     GO TO GET-VALUE-EXIT.
103858 
103860 GIV34.
103861     MOVE 1 TO TRUE-TYPEV.
103862     ENTER MACRO IQSX76 USING CONST30 SYSCOM-AREA-NAME
103863         CONST1 AHOLDER CONST1.
103864     MOVE 1 TO NHOLDER-TYPE.
103866     MOVE -30 TO NHOLDER-SCALE.
103868     GO TO GET-VALUE-EXIT.
103870
103872 GIV35B.
103873     MOVE 6 TO TRUE-TYPEV.
103874     MOVE 6 TO NHOLDER-TYPE.
103876     MOVE 0 TO NHOLDER-SCALE.
103878     MOVE ERROR-COUNT TO BHOLDER.
103880     GO TO GET-VALUE-EXIT.
103882
103884 GIV35N.
103885     MOVE 2 TO TRUE-TYPEV.
103886     MOVE 2 TO NHOLDER-TYPE.
103888     MOVE 0 TO NHOLDER-SCALE.
103890     MOVE ERROR-COUNT TO NHOLDER.
103892     GO TO GET-VALUE-EXIT.
103894
103900 GIV36.
103902     MOVE 1 TO TRUE-TYPEV.
103904     ENTER MACRO IQSX76 USING CONST30 AREA-NAME-IDENT
103906         CONST1 AHOLDER CONST1.
103908     MOVE 1 TO NHOLDER-TYPE.
103910     MOVE -30 TO NHOLDER-SCALE.
103912     GO TO GET-VALUE-EXIT.
103914
103996 GIV-DONE.
103997 GET-VALUE-EXIT.
103998     EXIT.
103999
104000**********************************************************
104001* SUBROUTINE TO SET ITEM VALUES IN IMAGE.  DEPENDS ON
104002* PROPER ENTRY BEING IN ELEM-DD-ENTRY, DX BEING SET.
104003* THIS SUBROUTINE LOOKS IN NHOLDER-TYPE TO FIND OUT WHERE
104020* AND WHAT TYPE THE INPUT ITEM IS.
104040*    1 = ALPHA IN AHOLDER.
104060*    2 = NUMERIC IN NHOLDER.
104080*    6 = BINARY IN BHOLDER.
104100* IT SCALES NUMERICS (AND BINARIES) ACCORDING TO INPUT
104120* FOUND IN NHOLDER-SCALE AND TO MATCH TARGET SCALE FOUND
104140* FOUND IN ELEM-D-SCALE.
104160**********************************************************
104180
104200 SET-VALUE.
104210     IF ELEM-D-FCHAR < C2E18 NEXT SENTENCE 
104215         ELSE DIVIDE C2E18 INTO ELEM-D-FCHAR.
104220     DIVIDE CONST100 INTO ELEM-D-TYPEV GIVING FILE-ROUTER
104240         REMAINDER TRUE-TYPEV.
104242     IF NHOLDER-TYPE NOT = 1 GO TO SET-VALUE1.
104244     IF TRUE-TYPEV = 1 GO TO SET-VALUE1.
104246     IF TRUE-TYPEV = 2 OR 6 OR 7 OR 8 OR 11 OR 16 
104248                       OR 24 OR 32 OR 35
104250         PERFORM JUST-RIGHT THRU JUST-RIGHT-EXIT
104252         MOVE ELEM-D-SCALE TO NHOLDER-SCALE
104254         MOVE 2 TO NHOLDER-TYPE.
104256 SET-VALUE1.
104260     ADD 1 TO FILE-ROUTER.
104280     GO TO SIV1   SIV2   SIV3   SIV4   SIV5
104300           SIV6   SIV7   SIV8   SIV9   SIV10
104320           SIV11  SIV12  SIVERR SIVERR SIVERR
104322           SIVERR SIVERR SIVERR SIVERR SIVERR
104324           SIVERR SIVERR SIVERR SIV24  SIVERR
104326           SIVERR SIVERR SIVERR SIVERR SIVERR
104328           SIVERR SIV32  SIV33  SIV34  SIV35
104330           SIV36
104340           DEPENDING ON TRUE-TYPEV.
104360     GO TO SIVERR.
104380
104400 SIV1.
104420 SIV12.
104440     IF NHOLDER-TYPE = 1 MOVE 1 TO I
104460         GO TO SIV1-SPRAY.
104461     IF NHOLDER-TYPE = 6 MOVE BHOLDER TO NHOLDER
104480     EXAMINE NHOLDER TALLYING LEADING '0'.
104482     MOVE TALLY TO I.
104484     ADD 1 TO I.
104485     IF I NOT > NHOLDER-SCALE COMPUTE I = NHOLDER-SCALE + 1.
104484*    *I NOW CONTAINS LOC IN NHOLDER OF LEADING DIGIT.
104483     SUBTRACT I FROM MAX-NITEM-LEN-UP1 GIVING J.
104484*    *J NOW CONTAINS INITIAL # OF DIGITS TO MOVE.
104485     IF J = 0 MOVE 1 TO J.
104504     ENTER MACRO IQSX66 USING J ANHOLDER I
104506         AHOLDER CONST1.
104508     IF NHOLDER-SCALE = 0 GO TO SIV1A.
104509*    *STUFF IN A DECIMAL POINT TO MAKE IT LOOK PRETTY.
104513     COMPUTE J = J - NHOLDER-SCALE + 1.
104514     MOVE '.' TO AHOLDER-CHAR (J).
104514     ADD 1 TO J.
104515     COMPUTE I = MAX-NITEM-LEN-UP1 - NHOLDER-SCALE.
104516     ENTER MACRO IQSX66 USING NHOLDER-SCALE ANHOLDER J
104518         AHOLDER I.
104519 SIV1A.
104520     MOVE 1 TO NHOLDER-TYPE I. 
104522     MOVE -19 TO NHOLDER-SCALE.
104524     MOVE SPACES TO ANHOLDER.
104540
104560 SIV1-SPRAY.
104580     GO TO SIV1-0  SIV1-1  SIV1-2  SIV1-1  SIV1-2  SIVERR
104600           SIVERR  SIV1-7  SIV1-8  SIV1-7  SIV1-8  SIVERR
104620           SIVERR  SIV1-13 SIV1-14 SIV1-13 SIV1-14 SIVERR
104640           DEPENDING ON FILE-ROUTER.
104660     GO TO SIVERR.
104760 SIV1-0. ENTER MACRO IQSX66 USING ELEM-D-NCHAR AHOLDER I
104780         HOLD-BUFFER ELEM-D-FCHAR. GO TO SET-VALUE-EXIT.
104800 SIV1-1. ENTER MACRO IQSX66 USING ELEM-D-NCHAR AHOLDER I
104820         INF1SD6-REC ELEM-D-FCHAR. GO TO SET-VALUE-EXIT.
104840 SIV1-2. ENTER MACRO IQSX67 USING ELEM-D-NCHAR AHOLDER I
104860         INF1SD7-REC ELEM-D-FCHAR. GO TO SET-VALUE-EXIT.
104880 SIV1-7. ENTER MACRO IQSX66 USING ELEM-D-NCHAR AHOLDER I
104900         INF2SD6-REC ELEM-D-FCHAR. GO TO SET-VALUE-EXIT.
104920 SIV1-8. ENTER MACRO IQSX67 USING ELEM-D-NCHAR AHOLDER I
104940         INF2SD7-REC ELEM-D-FCHAR. GO TO SET-VALUE-EXIT.
104960 SIV1-13. ENTER MACRO IQSX66 USING ELEM-D-NCHAR AHOLDER I
104980          INF3SD6-REC ELEM-D-FCHAR. GO TO SET-VALUE-EXIT.
105000 SIV1-14. ENTER MACRO IQSX67 USING ELEM-D-NCHAR AHOLDER I
105020          INF3SD7-REC ELEM-D-FCHAR. GO TO SET-VALUE-EXIT.
105040
105060 SIV2.
105080     IF NHOLDER-TYPE = 2 GO TO SIV2AA.
105100     IF NHOLDER-TYPE = 6 GO TO SIV2D.
105120     GO TO SIV2C.
105140
105160 SIV2AA.
105180*    *TYPES ARE SAME (NUMERIC); SEE IF SCALES ARE.
105200     IF ELEM-D-SCALE NOT = NHOLDER-SCALE
105220         MOVE NHOLDER TO BHOLDER
105240         GO TO SIV2B.
105260 SIV2A.
105280*    *HERE HAVE NUMERIC & PROPER SCALE*
105300     COMPUTE I = MAX-AITEM-LEN-UP1 - ELEM-D-NCHAR.
105320     GO TO SIV1-SPRAY.
105340
105360*    *MUST SCALE - EASIEST TO DO IN BINARY*.
105380 SIV2B.
105400*    *HERE HAVE A BINARY TO BE SCALED*
105420     IF NHOLDER-SCALE GREATER THAN ELEM-D-SCALE
105440         SUBTRACT ELEM-D-SCALE FROM NHOLDER-SCALE GIVING I
105460         SET PTX TO I
105480         DIVIDE 10EX (PTX) INTO BHOLDER ROUNDED
105500       ELSE SUBTRACT NHOLDER-SCALE FROM ELEM-D-SCALE GIVING I
105520         SET PTX TO I
105540         MOVE 10EX (PTX) TO WORK-2
105560         ENTER MACRO IQDMUL USING BHOLDER WORK-2 OVERFLOW-FLAG
105580             IF OVERFLOW-FLAG NOT = 0 PERFORM SET-COMPLAINER.
105600     MOVE BHOLDER TO NHOLDER.
105620     GO TO SIV2A.
105640
105660 SIV2C.
105680*    *HERE HAVE ALPHA SENDING VALUE; NHOLDER-SCALE CONTAINS
105700*    * - LENGTH OF ALPHA VALUE*
105720     MOVE 0 TO NHOLDER.
105740     MOVE 2 TO NHOLDER-TYPE.
105750     EXAMINE AHOLDER REPLACING LEADING ' ' BY '0'.
105760     EXAMINE AHOLDER TALLYING UNTIL FIRST ' '.
105770     MOVE TALLY TO I.
105775     IF I = 0 OR I > MAX-NITEM-LEN
105778         MOVE MAX-NITEM-LEN TO I.
105780     MOVE 0 TO NHOLDER-SCALE.
105860     SUBTRACT I FROM MAX-NITEM-LEN-UP1 GIVING K.
105880     ENTER MACRO IQSX66 USING I AHOLDER CONST1
105900         ANHOLDER K.
105920     EXAMINE ANHOLDER REPLACING ALL ' ' BY '0'.
105940     IF NHOLDER IS NOT NUMERIC PERFORM ILLEGAL-ALPHA
105960         MOVE 0 TO NHOLDER.
105980     IF TRUE-TYPEV = 2 GO TO SIV2AA.
106000     MOVE NHOLDER TO BHOLDER GO TO SIV6A.
106020
106040 SIV2D.
106060*    *HERE HAVE BINARY IN - IF SCALED OK, QUICK CONVERT*
106080     IF NHOLDER-SCALE = ELEM-D-SCALE
106100         MOVE BHOLDER TO NHOLDER GO TO SIV2A.
106120     GO TO SIV2B.
106140
106160 SIVERR.
106180 SIV3.
106200 SIV4.
106220 SIV5.
106240 SIV9.
106260 SIV10.
106280 SIV11.
106320     DISPLAY '%Trying to set to illegal item type '
106322         TRUE-TYPEV ' in file ' FILE-ROUTER
106324         UPON CONSOLE.
106340     GO TO SET-VALUE-EXIT.
106360
106380 SIV6.
106400     IF NHOLDER-TYPE NOT = 6 GO TO SIV6B.
106420
106440*    *HERE HAVE A BINARY - SEE IF SCALES MATCH.
106460 SIV6A.
106480     IF NHOLDER-SCALE = ELEM-D-SCALE GO TO SIV6C.
106500     IF NHOLDER-SCALE GREATER THAN ELEM-D-SCALE
106520         SUBTRACT ELEM-D-SCALE FROM NHOLDER-SCALE GIVING I
106540         SET PTX TO I
106560         DIVIDE 10EX (PTX) INTO BHOLDER ROUNDED
106580         GO TO SIV6C
106600       ELSE SUBTRACT NHOLDER-SCALE FROM ELEM-D-SCALE GIVING I
106620         SET PTX TO I
106640         MOVE 10EX (PTX) TO WORK-2
106660         ENTER MACRO IQDMUL USING BHOLDER WORK-2 OVERFLOW-FLAG
106680           IF OVERFLOW-FLAG NOT = 0 PERFORM SET-COMPLAINER.
106700     GO TO SIV6C.
106720
106740 SIV6B.
106760     IF NHOLDER-TYPE = 2 MOVE NHOLDER TO BHOLDER GO TO SIV6A.
106780     GO TO SIV2C.
106800
106820*    *HERE HAVE A BINARY SCALED CORRECTLY*
106840 SIV6C.
106860     IF ELEM-D-NCHAR GREATER THAN 10 MOVE 12 TO I
106880         MOVE 1 TO J GO TO SIV6D.
106900     MOVE 6 TO I.  MOVE 7 TO J.
106920*   *CHECK TO MAKE SURE NOT LOPPING OFF LEFT SIDE*
106940     IF BHOLDER-LEFT = 0 GO TO SIV6D.
106960     MOVE BHOLDER TO WORK-2.
106980     SUBTRACT WORK-2 FROM 0 GIVING WORK-2.
107000     IF WORK-2-LEFT = 0 GO TO SIV6D.
107020     DISPLAY '%Binary truncation' UPON CONSOLE.
107040 SIV6D.
107060     GO TO SIV6-0  SIV6-1  SIV6-2  SIV6-1  SIV6-2  SIVERR
107080           SIVERR  SIV6-7  SIV6-8  SIV6-7  SIV6-8  SIVERR
107100           SIVERR  SIV6-13 SIV6-14 SIV6-13 SIV6-14
107120           DEPENDING ON FILE-ROUTER.
107140     GO TO SIVERR.
107240 SIV6-0.  ENTER MACRO IQSX66 USING I BHOLDER-ALPHA
107260          J HOLD-BUFFER ELEM-D-FCHAR. GO TO SET-VALUE-EXIT.
107280 SIV6-1.  ENTER MACRO IQSX66 USING I BHOLDER-ALPHA
107300          J INF1SD6-REC ELEM-D-FCHAR. GO TO SET-VALUE-EXIT.
107320 SIV6-2.
107322     COMPUTE K = ( (ELEM-D-FCHAR - 1) / 5) * 6 + 1.
107324     ENTER MACRO IQSX66 USING I BHOLDER-ALPHA
107326         J INF1SD6-REC K. GO TO SET-VALUE-EXIT.
107360 SIV6-7.  ENTER MACRO IQSX66 USING I BHOLDER-ALPHA
107380          J INF2SD6-REC ELEM-D-FCHAR. GO TO SET-VALUE-EXIT.
107400 SIV6-8.
107402     COMPUTE K = ( (ELEM-D-FCHAR - 1) / 5) * 6 + 1.
107404     ENTER MACRO IQSX66 USING I BHOLDER-ALPHA
107406         J INF2SD6-REC K. GO TO SET-VALUE-EXIT.
107440 SIV6-13. ENTER MACRO IQSX66 USING I BHOLDER-ALPHA
107460          J INF3SD6-REC ELEM-D-FCHAR. GO TO SET-VALUE-EXIT.
107480 SIV6-14.
107482     COMPUTE K = ( (ELEM-D-FCHAR - 1) / 5) * 6 + 1.
107484     ENTER MACRO IQSX66 USING I BHOLDER-ALPHA
107486         J INF3SD6-REC K. GO TO SET-VALUE-EXIT.
107520 SIV7.
107540     IF NHOLDER-TYPE NOT = 6 GO TO SIV7B.
107560
107580 SIV7A.
107600     IF NHOLDER-SCALE = ELEM-D-SCALE GO TO SIV7C.
107620*    *HERE HAVE A BINARY TO BE SCALED.
107640     IF NHOLDER-SCALE GREATER THAN ELEM-D-SCALE
107660         SUBTRACT ELEM-D-SCALE FROM NHOLDER-SCALE GIVING I
107680         SET PTX TO I
107700         DIVIDE 10EX (PTX) INTO BHOLDER ROUNDED
107720         GO TO SIV7C
107740       ELSE SUBTRACT NHOLDER-SCALE FROM ELEM-D-SCALE GIVING I
107760         SET PTX TO I
107780         MOVE 10EX (PTX) TO WORK-2
107800         ENTER MACRO IQDMUL USING BHOLDER WORK-2 OVERFLOW-FLAG
107820           IF OVERFLOW-FLAG NOT = 0 PERFORM SET-COMPLAINER.
107840     GO TO SIV7C.
107860
107880 SIV7B.
107900     IF NHOLDER-TYPE = 1
107920         COMPUTE I = MAX-NITEM-LEN-UP1 - ELEM-D-NCHAR
107940         ENTER MACRO IQSX66 USING ELEM-D-NCHAR
107960             AHOLDER CONST1 ANHOLDER I
107980         EXAMINE ANHOLDER REPLACING ALL ' ' BY '0'
108000         IF NHOLDER IS NOT NUMERIC
108020             MOVE 15 TO ERROR-CODE
108040             PERFORM COMPLAINER THRU COMPLAINER-EXIT
108060             MOVE 0 TO NHOLDER.
108080     MOVE NHOLDER TO BHOLDER.
108100     GO TO SIV7A.
108120
108140 SIV7C.
108160*    *HERE HAVE A BINARY SCALED PROPERLY*
108180     MOVE BHOLDER TO ELEM-V-BINARY.
108200     ENTER MACRO IQPUTD.
108220     GO TO SET-VALUE-EXIT.
108240
108260 SIV8.
108280     MOVE 1 TO ELEM-V-WORK.
108300     GO TO SIV7.
108302
108304 SIV24.
108306     IF NHOLDER-TYPE = 6 MOVE BHOLDER TO ERROR-STATUS
108308         ELSE MOVE NHOLDER TO ERROR-STATUS.
108310     GO TO SET-VALUE-EXIT.
108312
108314 SIV32.
108316     IF NHOLDER-TYPE = 6 
108318         MOVE BHOLDER TO CURRENT-RECORD-KEY
108320         ELSE MOVE NHOLDER TO CURRENT-RECORD-KEY.
108322     GO TO SET-VALUE-EXIT.
108324
108326 SIV33.
108328     MOVE AHOLDER TO SYSCOM-RECORD-NAME.
108330     GO TO SET-VALUE-EXIT.
108332
108334 SIV34.
108336     MOVE AHOLDER TO SYSCOM-AREA-NAME.
108338     GO TO SET-VALUE-EXIT.
108340
108342 SIV35.
108344      IF NHOLDER-TYPE = 2 MOVE NHOLDER TO BHOLDER.
108346     MOVE BHOLDER TO ERROR-COUNT.
108348     GO TO SET-VALUE-EXIT.
108350
108352 SIV36.
108354     MOVE AHOLDER TO AREA-NAME-IDENT.
108356     GO TO SET-VALUE-EXIT.
108358
108360 SET-COMPLAINER.
108362     DISPLAY '%SET value shift overflow' UPON CONSOLE.
108364     MOVE 0 TO BHOLDER. MOVE 0 TO NHOLDER.
108380
108400 SET-VALUE-EXIT.
108420     EXIT.
108440
108460**********************************************************
108480* SUBROUTINE 'HOLDER-ADJUST' TO SHIFT CONTENTS OF AHOLDER
108500* TO BE APPROPRIATE FOR COMPARING TO ANOTHER ITEM.
108520* ARGUMENTS ARE:
108540*   VALUE TO BE ADJUSTED IS IN AHOLDER (OR NHOLDER).
108560*   SCALE OF VALUE TO BE ADJUSTED IS IN NHOLDER-SCALE
108580*      (IF THE ITEM IS ALPHA, NHOLDER SCALE = -1)
108600*   DESCRIPT OF ITEM TO WHICH VALUE SHOULD BE ADJUSTED IS
108620*      IN ELEM-D-ENTRY.
108640*
108660* NOTE: USES WORK CELL I.
108680**********************************************************
108700
108720 HOLDER-ADJUST.
108740     DIVIDE CONST100 INTO ELEM-D-TYPEV GIVING FILE-ROUTER
108760         REMAINDER TRUE-TYPEV.
108780     IF NHOLDER-TYPE = 1 GO TO HOLDER-IS-ALPHA.
108800
108820 HOLDER-IS-NUM.
108840     IF TRUE-TYPEV  = 1 OR TRUE-TYPEV = 10
108860         GO TO HOLDER-IS-NUM-TARGET-ALPHA.
108880*    *HAVE TWO NUMERICS; SEE IF SCALES ARE SAME*
108900     IF NHOLDER-SCALE = ELEM-D-SCALE GO TO HOLDER-ADJUST-EXIT.
108920*    *NO - ADJUST NHOLDER TO MATCH SCALE DESCRIBED IN ELEM-D-ENTRY*
108940     IF NHOLDER-SCALE GREATER THAN ELEM-D-SCALE
108960         SUBTRACT ELEM-D-SCALE FROM NHOLDER-SCALE GIVING I
108980         SET PTX TO I
109000         DIVIDE 10EX (PTX) INTO NHOLDER GIVING NHOLDER
109020       ELSE SUBTRACT NHOLDER-SCALE FROM ELEM-D-SCALE GIVING I
109040         SET PTX TO I
109060         MOVE NHOLDER TO ACCUM
109080         MOVE 10EX (PTX) TO BHOLDER
109100         ENTER MACRO IQDMUL USING ACCUM BHOLDER OVERFLOW-FLAG
109120         MOVE ACCUM TO NHOLDER.
109140      GO TO HOLDER-ADJUST-EXIT.
109160
109180 HOLDER-IS-NUM-TARGET-ALPHA.
109200*    *HERE IF HAVE NUMERIC TO BE MOVED TO ALPHA*.
109220     SUBTRACT ELEM-D-NCHAR FROM MAX-NITEM-LEN-UP1 GIVING I.
109240     ENTER MACRO IQSX66 USING ELEM-D-NCHAR
109260         NHOLDER I AHOLDER CONST1.
109280     MOVE SPACES TO ANHOLDER.
109300     GO TO HOLDER-ADJUST-EXIT.
109320
109340 HOLDER-IS-ALPHA.
109360     IF TRUE-TYPEV = 1 OR TRUE-TYPEV = 10
109380         GO TO HOLDER-ADJUST-EXIT.
109400     MOVE 0 TO NHOLDER.
109420     SUBTRACT ELEM-D-NCHAR FROM MAX-NITEM-LEN-UP1 GIVING I.
109440     ENTER MACRO IQSX66 USING ELEM-D-NCHAR
109460         AHOLDER CONST1 NHOLDER I.
109480     MOVE SPACES TO AHOLDER-30.
109500
109520 HOLDER-ADJUST-EXIT.
109540     EXIT.
109560
109900**********************************************************
109920*  SUBROUTINE TO CALL USER'S OWN-CODE THROUGH IQL EXITS.
109940**********************************************************
109960
109980 EXIT-CALLER.
110000     IF EXIT-CODE NOT = 1 MOVE '00' TO STATUS-CODE.
110020     CALL IQCALL USING PASSED-PARAMS.
110040     IF STATUS-CODE = '03' MOVE 11 TO ERROR-CODE
110060         GO TO ABORT-RUN.
110080
110100 EXIT-CALLER-EXIT.
110120     EXIT.
110140
110160**********************************************************
110180* SUBROUTINE TO PEEL EXTRA BLANKS OUT OF PRINT LINE
110200*    AND BLANK RIGHT FILL AS NECESSARY.
110220*    RETURNS WITH J SET TO LAST NON-BLANK CHARACTER*
110240**********************************************************
110260
110280 BLANK-PEELOUT.
110300     SET PRX TO 1.
110320     MOVE 1 TO I J.
110340
110360 BLANK-PEELOUT1.
110380     IF PRX GREATER THAN MAX-PRINT-CHARS SET PRX TO J
110400         GO TO BLANK-PEELOUT3.
110420     MOVE PRINT-CHAR (PRX) TO ELEM-CHAR.
110440     IF I = 0 AND ELEM-CHAR = SPACE NEXT SENTENCE
110460         ELSE MOVE ELEM-CHAR TO PRINT-CHAR (J)
110480         ADD 1 TO J
110500         IF ELEM-CHAR = SPACE MOVE 0 TO I
110520             ELSE MOVE 1 TO I.
110540     SET PRX UP BY 1.
110560     GO TO BLANK-PEELOUT1.
110580
110600 BLANK-PEELOUT3.
110620*    *NOW BLANK RIGHT FILL*.
110640     IF PRX NOT GREATER THAN MAX-PRINT-CHARS
110660         MOVE SPACE TO PRINT-CHAR (PRX)
110680         SET PRX UP BY 1
110700         GO TO BLANK-PEELOUT3.
110720
110740 BLANK-PEELOUT-EXIT.
110760     EXIT.
110762
110764**********************************************************
110766* SUBROUTINE DISPLAY-PRINT-LINE AND DISPLAY-WORK-LINE
110768* TO DISPLAY THE CONTENTS OF THESE RESPECTIVE LINES
110770* UPON TERMINAL. TO DO THIS, IT MOVES ONLY
110772* THE USEFULE LEFT PART OF LINE, AS INDICATED THE TERM-CHARS
110774* TO A TERMINAL LINE THAT HAS BEEN INITIALIZED WITH ASCII NULLS.
110776**************************************************************
110780 DISPLAY-PRINT-LINE.
110782     MOVE SPACES TO SIXBIT-TERM-LINE.
110784     ENTER MACRO IQSX67 USING TERM-CHARS
110786         PRINT-LINE CONST1 TERM-LINE CONST1.
110788     PERFORM TRAILING-NULLS THRU TRAILING-NULLS-EXIT.
110789     DISPLAY TERM-LINE UPON CONSOLE.
110790
110792 DISPLAY-WORK-LINE.
110794     MOVE SPACES TO SIXBIT-TERM-LINE.
110796     ENTER MACRO IQSX67 USING TERM-CHARS
110798         WORK-LINE CONST1 TERM-LINE CONST1.
110800     PERFORM TRAILING-NULLS THRU TRAILING-NULLS-EXIT.
110802     DISPLAY TERM-LINE UPON CONSOLE.
110804
110806 TRAILING-NULLS.
110808     SET NX TO TERM-CHARS.
110810 TRAILING-NULLS1.
110812     IF TERM-CHAR (NX) NOT = ASCII-NULL AND NOT = SPACE
110814         GO TO TRAILING-NULLS-EXIT.
110816     MOVE ASCII-NULL TO TERM-CHAR (NX).
110818     IF NX NOT < 2 SET NX DOWN BY 1 GO TO TRAILING-NULLS1.
110820 TRAILING-NULLS-EXIT.
110822
110824*====* TO RESTORE COBOL EDIT BELOW, DO THE FOLLOWING
110826*====* SUBSTITUTIONS FROM THIS POINT TO END:
110840*====*   FIRST:   SUBSTITUTE '0 ' FOR '0*'.
110860*====*   SECOND:  SUBSTITUTE '0* ' FOR '0 *'.
110880*====* THEN GO TO THE BEGINNING OF THE PROCEDURE DIV
110900*====* AND SUBSTITUTE 'PEFORM EDITOR THRU EDITOR-EXIT'
110920*====*  FOR 'ENTER MACRO IQPICT'.
110940**********************************************************
110960**SUBROUTINE 'EDITOR' TO EDIT ITEM.
110980**USED BY PRINT AND SUMMARY (TALLY,TOTAL,AVERAGE) LOGIC.
111000**LEAVES EDITED RESULT IN ITEM 'PICT-WORK'.
111020**ON ENTRY THE FOLLOWING MUST BE SET:
111040**    ELEM-D-ENTRY CONTAINS DESCRIPTION OF ITEM.
111060**    IF NUMERIC ITEM, VALUE MUST BE IN NHOLDER.
111080*
111100**********************************************************
111120
111140*EDITOR.
111160*    IF TRUE-TYPEV NOT = 1 GO TO EDIT-NUM1.
111180*    IF ELEM-D-PICT-T = SPACE MOVE AHOLDER TO PICT-WORK
111200*        GO TO EDITOR-EXIT.
111220**   *EDIT ALPHA ITEM DIRECTLY FROM INPUT BUFFERS*.
111240*    SET PIX TO 1.
111260*    SET INPX TO ELEM-D-FCHAR.
111280*    MOVE ELEM-D-PICT TO PICT-WORK.
111300
111320*EDIT-ALPHA.
111340**   *LEFT-TO-RIGHT SCAN INSERTING ALPHA CHARS OVER PICT X'S*
111360*    IF PICT-CHAR (PIX) = 'X'
111380*        MOVE INPUT-CHAR (INPX) TO PICT-CHAR (PIX)
111400*        SET INPX UP BY 1.
111420*    IF PIX LESS THAN ELEM-D-ECHAR
111440*        SET PIX UP BY 1
111460*        GO TO EDIT-ALPHA.
111480*    GO TO EDITOR-EXIT.
111500
111520*EDIT-NUM1.
111540**   *SET UP TO EDIT NUMERIC ITEM (IF PICTURE FOUND)*.
111560**   *FOR SPEED - NO CHECKING. PICTURE MUST BE CORRECT*
111580**   *NOW SEE IF EDITING - IE: IS THERE A PICTURE?
111600*    IF ELEM-D-PICT-T = SPACE
111620*        SUBTRACT ELEM-D-NCHAR FROM MAX-NITEM-LEN-UP1 GIVING I
111640*        ENTER MACRO IQSX66 USING ELEM-D-NCHAR
111660*        NHOLDER I PICT-WORK CONST1
111680*        GO TO EDITOR-EXIT.
111700*    MOVE ELEM-D-PICT TO PICT-WORK.
111720*    MOVE ' ' TO FLOAT-CHAR.
111740**   *FIRST CHECK FOR ROUNDING AND DO IF NECESSARY*.
111760*    EXAMINE PICT-WORK TALLYING ALL 'R'.
111780*    IF TALLY = 0*GO TO EDIT-NUM2.
111800*    SET RNDX TO TALLY.
111820*    IF NHOLDER NOT LESS THAN 0
111840*        ADD 5EX (RNDX) TO NHOLDER
111860*        ELSE SUBTRACT 5EX (RNDX) FROM NHOLDER.
111880*EDIT-NUM2.
111900*    MOVE ZERO TO DOLLAR-COUNT  LPAREN-COUNT.
111920**   *FIND OUT WHERE DECIMAL IS IN THE PICTURE*.
111940*    EXAMINE PICT-WORK TALLYING UNTIL FIRST '.'.
111960*    IF TALLY IS GREATER THAN ELEM-D-ECHAR
111980*        SET PIX TO ELEM-D-ECHAR
112000*        ELSE SET PIX TO TALLY.
112020**   *NOW LINE UP WITH SCALE FOR NUMBER IN NHOLDER*.
112040*    SUBTRACT ELEM-D-SCALE FROM MAX-NITEM-LEN-UP1 GIVING WORKX.
112060*    SET NHLX TO WORKX.
112080
112100*EDIT-RIGHT-LEFT.
112120**   *SYNCHRONIZE INDICES TO LEFT OF PICTURE*.
112140*    MOVE PICT-CHAR (PIX) TO ELEM-CHAR.
112160*    IF ELEM-CHAR = '9' OR 'Z' OR 'R'
112180*        SET NHLX DOWN BY 1 GO TO EDIT-MOVE-LEFT.
112200*    IF ELEM-CHAR = '$' ADD 1 TO DOLLAR-COUNT
112220*        IF DOLLAR-COUNT GREATER THAN 1
112240*            MOVE ELEM-CHAR TO FLOAT-CHAR
112260*            SET NHLX DOWN BY 1 GO TO EDIT-MOVE-LEFT
112280*            ELSE GO TO EDIT-MOVE-LEFT.
112300*    IF ELEM-CHAR = '(' ADD 1 TO LPAREN-COUNT
112320*        IF LPAREN-COUNT GREATER THAN 1
112340*            MOVE ELEM-CHAR TO FLOAT-CHAR
112360*            SET NHLX DOWN BY 1.
112380
112400*EDIT-MOVE-LEFT.
112420*    IF PIX GREATER THAN 1 SET PIX DOWN BY 1
112440*        GO TO EDIT-RIGHT-LEFT.
112460
112480*EDIT-LEFT-RIGHT.
112500**   *LEFT-TO-RIGHT INSERTION AND SUPPRESSION/FLOATING
112520**   *PASS STARTS HERE*.
112540*    MOVE 1 TO SUPPRESSING-FLAG SIGN-POS.
112560*    MOVE 0*TO FLOAT-POS ROUNDING-FLAG.
112580
112600*EDIT-NUM3.
112620**   *NUMERIC EDIT LOOP STARTS HERE*.
112640*    IF PIX GREATER THAN ELEM-D-ECHAR GO TO EDIT-NUM-DONE.
112660*    MOVE PICT-CHAR (PIX) TO ELEM-CHAR.
112680*    IF ELEM-CHAR = '9' GO TO EDIT-NUM-STUFF.
112700*    IF ELEM-CHAR NOT = 'S' GO TO EDIT-NUM4.
112720**   *FILL IN SIGN IF MINUS*.
112740*    IF ROUNDING-FLAG = 0*SET SIGN-POS TO PIX.
112760**   *IF WE ARE ROUNDING, SIGN POS WILL ALREADY BE SET*.
112780*    IF NHOLDER LESS THAN 0
112800*        MOVE '-' TO PICT-CHAR (SIGN-POS)
112820*        SUBTRACT NHOLDER1 FROM 0*GIVING NHOLDER1
112840*        ELSE MOVE SPACE TO PICT-CHAR (SIGN-POS).
112860*    SET PIX UP BY 1.
112880*    GO TO EDIT-NUM3.
112900
112920*EDIT-NUM4.
112940*    IF ELEM-CHAR NOT = 'Z' GO TO EDIT-NUM5.
112960*    IF SUPPRESSING-FLAG = 0*GO TO EDIT-NUM-STUFF.
112980**   *IF GET HERE, ARE STILL SUPPRESSING Z'S*.
113000*    IF NHOLDER-CHAR (NHLX) = 0
113020*        MOVE SPACE TO PICT-CHAR (PIX)
113040*        SET NHLX UP BY 1
113060*        SET PIX UP BY 1
113080*        GO TO EDIT-NUM3
113100*        ELSE GO TO EDIT-NUM-STUFF.
113120
113140*EDIT-NUM5.
113160*    IF ELEM-CHAR NOT = FLOAT-CHAR GO TO EDIT-NUM6.
113180*    IF FLOAT-POS = 0*MOVE 1 TO FLOAT-POS
113200*        MOVE ' ' TO PICT-CHAR (PIX)
113220*        SET PIX UP BY 1 GO TO EDIT-NUM3.
113240*    IF SUPPRESSING-FLAG = 0*OR NHOLDER-CHAR (NHLX) NOT = '0'
113260*        GO TO EDIT-NUM-STUFF.
113280*    SET NHLX UP BY 1.
113300*    MOVE ' ' TO PICT-CHAR (PIX).
113320*    SET PIX UP BY 1.
113340*    GO TO EDIT-NUM3.
113360
113380*EDIT-NUM6.
113400*    IF ROUNDING-FLAG = 1 MOVE SPACE TO PICT-CHAR (PIX)
113420*       SET PIX UP BY 1  GO TO EDIT-NUM3.
113440*    IF ELEM-CHAR = ',' OR '.'
113460*        IF SUPPRESSING-FLAG = 1
113480*            MOVE SPACE TO PICT-CHAR (PIX)
113500*            SET PIX UP BY 1
113520*            GO TO EDIT-NUM3
113540*          ELSE SET PIX UP BY 1 GO TO EDIT-NUM3.
113560*    IF ELEM-CHAR NOT = 'R'
113580*        MOVE 0*TO SUPPRESSING-FLAG
113600*        SET PIX UP BY 1 GO TO EDIT-NUM3.
113620**   *SPACE OVER ROUNDING CHAR LOOKING FOR SIGN*.
113640*    IF ROUNDING-FLAG = 0*SET SIGN-POS TO PIX
113660*        MOVE SPACE TO PICT-CHAR (PIX)
113680*        MOVE 1 TO ROUNDING-FLAG.
113700*    SET NHLX UP BY 1.
113720*    SET PIX UP BY 1.
113740*    GO TO EDIT-NUM3.
113760
113780*EDIT-NUM-STUFF.
113800*    IF SUPPRESSING-FLAG = 1 SET FLOAT-POS TO PIX
113820*        SUBTRACT 1 FROM FLOAT-POS.
113840*    MOVE 0*TO SUPPRESSING-FLAG.
113860*    IF NHLX NOT GREATER THAN 18
113880*        MOVE NHOLDER-CHAR (NHLX) TO PICT-CHAR (PIX)
113900*        SET NHLX UP BY 1
113920*        ELSE MOVE 0*TO PICT-CHAR (PIX).
113940*    SET PIX UP BY 1.
113960*    GO TO EDIT-NUM3.
113980
114000*EDIT-NUM-DONE.
114020*    IF FLOAT-CHAR NOT = ' ' AND SUPPRESSING-FLAG NOT = 1
114040*        SET PIX TO FLOAT-POS
114060*        MOVE FLOAT-CHAR TO PICT-CHAR (PIX).
114080
114100*EDITOR-EXIT.
114120*    EXIT.