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