Trailing-Edge
-
PDP-10 Archives
-
iqlv30
-
iqe.cbl
Click iqe.cbl to
see without markup as text/plain
There are no other files named iqe.cbl in the archive.
000100 IDENTIFICATION DIVISION.
000120 PROGRAM-ID. IQE.
000140 DATE-WRITTEN. 1 DEC 1976.
000160 DATE-COMPILED.
000180
000200 SECURITY. COPYRIGHT 1978 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-10.
000620 OBJECT-COMPUTER. DECSYSTEM-10.
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 4095 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.
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.
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]'
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.
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 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.
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.
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.
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.
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 ADD ELEM-D-NCHAR TO I.
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).
053660 IF SKX NOT GREATER THAN I
053680 SET SKX UP BY 1 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*