Google
 

Trailing-Edge - PDP-10 Archives - iqlv30 - iqm.cbl
There are 2 other files named iqm.cbl in the archive. Click here to see a list.
000100 IDENTIFICATION DIVISION.
000120 PROGRAM-ID.   IQM.
000140 DATE-WRITTEN. 1977.
000160 SECURITY.     COPYRIGHT 1977 AZREX INC.
000180
000200 REMARKS.      IQM IS THE MULTIPLE REPORT MODULE OF IQL3;
000220               IT SEPARATES MULTIPLE REPORTS WHICH HAVE
000240               BEEN PREPARED BY THE EXECUTION PHASE (IQE);
000260               THE REPORTS ARE PASSED ON A DISK TEMP FILE
000280               AND THIS MODULE PICKS THEM APART;
000290               LAST UPDATED BY DWM 11 NOV 78.
000300
000320               BASIC LOGIC:
000340               (A) THE FIRST RECORD IN A REPORT
000360               MAY BE A HEADER. IF SO, IT HAS QTE-PAGE-NO = 0
000380               AND QTE-LINE-NO = 0
000400               AND IQM MOVES THE FORMATING PARAMETERS IN
000420               IT TO THE CURRENT CONTROL SLOTS. IF THERE
000440               IS NO HEADER, IQM USES THE FORMATING VALUES
000460               WHICH WERE USED FOR THE PRIOR REPORT
000480               (DEFAULT VALUES FOR THE FIRST REPORT).
000500
000520               (B) FOR HANDLING ACROSS AND/OR MULTIPLE
000540               LINES/REPORT, IQM KEEPS A TABLE
000560               OF WHAT PRINTX IS CURRENTLY CONTRIBUTING
000580               TO THE CONTENTS OF WHAT BUFFER. IT MATCHES
000600               BUFFERS UP ON THIS PRINTX. SINCE THE QTEXEC
000620               RECORD CONTAINS THE ORIGIN (RELATIVE TO
000640               COLUMN 1 OF WHERE IN THE PHYSICAL LINE THIS
000660               PRINT IMAGE GOES, IQM USES IQSXFR TO SLIDE
000680               THE NEW IMAGE INTO THE BUFFER. IF WE DO
000700               HAVE A TRUE ACROSSING SITUATION, THE
000720               QTE-ACROSS FIELD CONTAINS A COUNT WHICH IS
000740               (THIS-SETTING - ACROSS-SETTING)
000760               AND WE GO TO PRINT ONLY WHEN THIS VALUE
000780               BECOMES LESS THAN 1.
000800
000820*===NEEDS TO BE COMPLETELY CHECKED OUT===*
000840
000860 ENVIRONMENT DIVISION.
000880 CONFIGURATION SECTION.
000900 SOURCE-COMPUTER. DECSYSTEM-10.
000920 OBJECT-COMPUTER. DECSYSTEM-10.
000940 SPECIAL-NAMES.   CHANNEL (1) IS TOP-OF-PAGE
000960                  CONSOLE IS TTY.
000980
001000 INPUT-OUTPUT SECTION.
001020 FILE-CONTROL.
001040     SELECT QTEXEC ASSIGN TO DSK.
001060     SELECT QLEXEC ASSIGN TO DSK.
001080
001100 DATA DIVISION.
001120
001140 FILE SECTION.
001160
001180 FD  QTEXEC
001200     VALUE OF IDENTIFICATION IS QT001MTMP
001220     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS
001240     DATA RECORDS ARE QTEXEC-REC1 QTEXEC-REC2.
001260
001280 01  QTEXEC-REC1 USAGE IS DISPLAY-6.
001300     02  QTE-RPT-PARAMS.
001320         04  QTE-RPT-NO      PIC S9(10) COMP.
001340         04  QTE-PAGE-NO     PIC S9(10) COMP.
001360         04  QTE-LINE-NO     PIC S9(10) COMP.
001380         04  QTE-ACROSS      PIC S9(10) COMP.
001400         04  QTE-VSPACE      PIC S9(10) COMP.
001420         04  QTE-PRINTX      PIC S9(10) COMP.
001440     02  QTE-PRINTPOS        PIC S9(10) COMP.
001460     02  QTE-IMAGE           PIC X(200).
001480
001500 01  QTEXEC-REC2 USAGE IS DISPLAY-6.
001520     02  FILLER              PIC X(18).
001540     02  QTE-DISPLAY-FLAG    PIC S9(10) COMP.
001560     02  QTE-PRINT-FLAG      PIC S9(10) COMP.
001580     02  QTE-LINES-PAGE      PIC S9(10) COMP.
001600     02  QTE-LINES-FORM      PIC S9(10) COMP.
001620     02  FILLER              PIC X(200).
001640
001660 FD  QLEXEC
001680     VALUE OF IDENTIFICATION IS QLEXECLPT
001700     LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS
001720     DATA RECORDS IS QLEXEC-REC.
001740
001760 01  QLEXEC-REC USAGE IS DISPLAY-7.
001764     02  MESSAGE-PART.
001780         04  PRINT-MSG       PIC X(30).
001800         04  PRINT-COUNT     PIC X(7).
001805         04  FILLER          PIC X(5).
001810         04  QLEXECLPT-MSG   PIC X(9).
001820         04  FILLER          PIC X(149).
001824     02  DATA-LINE REDEFINES MESSAGE-PART.
001828         04  PRINT-CHAR      PIC X OCCURS 200 INDEXED BY PCX.
001840
001860 WORKING-STORAGE SECTION.
001880
001882 01  SIXBIT-SPACES           PIC X(6) DISPLAY-6 VALUE SPACES.
001884 01  ASCII-NULLS REDEFINES SIXBIT-SPACES DISPLAY-7.
001886     02  ASCII-NULL          PIC X.
001888     02  FILLER              PIC XXXX.
001890
001900*    *FLAGS AND COMP WORK ITEMS FOLLOW*
001920 01  CONST1                  PIC S9(10) COMP VALUE 1.
001940 01  CURR-RPT-NO             PIC S9(10) COMP VALUE 0.
001960 01  DEVICER                 PIC X(6) VALUE ' '.
001980 01  DISPLAY-FLAG            PIC S9(10) COMP VALUE 1.
002000 01  DONE-FLAG               PIC S9(10) COMP VALUE 1.
002002 01  FIRSTTIME               PIC S9(10) COMP VALUE 0.
002020 01  I                       PIC S9(10) COMP VALUE 1.
002040 01  IMAGE-LENGTH            PIC S9(10) COMP VALUE 200.
002060 01  J                       PIC S9(10) COMP VALUE 1.
002080 01  JOB-NO                  PIC S9(10) COMP VALUE 1.
002100 01  LINES-FORM              PIC S9(10) COMP VALUE 66.
002120 01  LINES-PAGE              PIC S9(10) COMP VALUE 59.
002140 01  MAX-PXX                 PIC S9(10) COMP VALUE 20.
002160 01  MAX-RPX                 PIC S9(10) COMP VALUE 99.
002180 01  MORE-TO-GO              PIC S9(10) COMP VALUE 0.
002200 01  NO-OF-RPTS              PIC S9(10) COMP VALUE 0.
002220 01  NO-TOTAL-LINES          PIC S9(10) COMP VALUE 0.
002240 01  PAGE-LINE               PIC S9(10) COMP VALUE 1.
002260 01  PRINT-FLAG              PIC S9(10) COMP VALUE 1.
002280 01  PROJ                    PIC S9(10) COMP VALUE 0.
002300 01  USER                    PIC S9(10) COMP VALUE 0.
002320
002340*    *DYNAMIC FILE NAMES FOLLOW*
002360 01  QT001MTMP.
002380     02  FILLER              PIC X(02) VALUE 'QT'.
002400     02  QT001MNO            PIC 999 VALUE 001.
002420     02  FILLER              PIC X(04) VALUE 'MTMP'.
002440 01  QLEXECLPT.
002460     02  FILLER              PIC X(02) VALUE 'QL'.
002480     02  QLEXECNO            PIC 999 VALUE 001.
002500     02  FILLER             REDEFINES QLEXECNO.
002520         04  QLEXEC-NODUP    PIC X.
002540         04  FILLER          PIC XX.
002560     02  FILLER              PIC X(04) VALUE 'ELPT'.
002580
002600*    *NAME OF NEXT MODULE TO BE EXECUTED GOES HERE*
002620 01  CALLED-NAME PIC X(6) USAGE IS DISPLAY-6.
002640
002660 01  DYN-FILE-CHAR-SET.
002680     02  FILLER              PIC X VALUE '1'.
002700     02  FILLER              PIC X VALUE '2'.
002720     02  FILLER              PIC X VALUE '3'.
002740     02  FILLER              PIC X VALUE '4'.
002760     02  FILLER              PIC X VALUE '5'.
002780     02  FILLER              PIC X VALUE '6'.
002800     02  FILLER              PIC X VALUE '7'.
002820     02  FILLER              PIC X VALUE '8'.
002840     02  FILLER              PIC X VALUE '9'.
002860     02  FILLER              PIC X VALUE 'A'.
002880     02  FILLER              PIC X VALUE 'B'.
002900     02  FILLER              PIC X VALUE 'C'.
002920     02  FILLER              PIC X VALUE 'D'.
002940     02  FILLER              PIC X VALUE 'E'.
002960     02  FILLER              PIC X VALUE 'F'.
002980     02  FILLER              PIC X VALUE 'G'.
003000     02  FILLER              PIC X VALUE 'H'.
003020     02  FILLER              PIC X VALUE 'I'.
003040     02  FILLER              PIC X VALUE 'J'.
003060     02  FILLER              PIC X VALUE 'K'.
003080     02  FILLER              PIC X VALUE 'L'.
003100     02  FILLER              PIC X VALUE 'M'.
003120     02  FILLER              PIC X VALUE 'N'.
003140     02  FILLER              PIC X VALUE 'O'.
003160     02  FILLER              PIC X VALUE 'P'.
003180     02  FILLER              PIC X VALUE 'Q'.
003200     02  FILLER              PIC X VALUE 'R'.
003220     02  FILLER              PIC X VALUE 'S'.
003240     02  FILLER              PIC X VALUE 'T'.
003260     02  FILLER              PIC X VALUE 'U'.
003280     02  FILLER              PIC X VALUE 'V'.
003300     02  FILLER              PIC X VALUE 'W'.
003320     02  FILLER              PIC X VALUE 'X'.
003340     02  FILLER              PIC X VALUE 'Y'.
003360     02  FILLER              PIC X VALUE 'Z'.
003380
003400 01  DYN-FILE-CHAR-SET1 REDEFINES DYN-FILE-CHAR-SET.
003420     02  DYN-FILE-CHAR       PIC X OCCURS 35 TIMES
003440                             INDEXED BY DDX.
003460
003480
003500*    *WORKING TABLE FOR KEEPING TRACK OF REPORT STATUS*
003520 01  RPTS-DONE.
003540     02  RPT-NO               PIC S9(10) COMP OCCURS 99 TIMES
003560                                 INDEXED BY RPX.
003580
003600 01  PRINT-MASK              PIC ZZZ,ZZ9.
003620
003640 01  PRINT-BUFFERS.
003660     02  PRINT-LINE PIC X(200) OCCURS 20 TIMES.
003680
003700 01  PRINT-POINTERS OCCURS 20 TIMES INDEXED BY PXX.
003720     02  BUFFER-PRINTX       PIC S9(10) COMP.
003740     02  IP                  PIC S9     COMP.
003760     02  VSP                 PIC S999   COMP.
003780
003800 PROCEDURE DIVISION.
003820
003840 BEGIN.
003860*    *INITIALIZE ENTIRE MULTIPLE REPORTS RUN*
003880     ENTER MACRO CLRTTY.
003900     ENTER MACRO IQGJOB USING JOB-NO.
003920     MOVE JOB-NO TO QT001MNO QLEXECNO.
003940*    CANCEL IQGJOB.
003960     MOVE 0 TO NO-OF-RPTS NO-TOTAL-LINES.
003980     SET RPX TO 1.
004000
004020 INITIALIZER.
004040*    *CLEAR OUT REPORT STATUS TABLE*
004060     MOVE 0 TO RPT-NO (RPX).
004080     IF RPX LESS THAN 99 SET RPX UP BY 1
004100           GO TO INITIALIZER.
004120
004140*    *MAKE SURE PRINT FILE WILL NOT WRITE OVER ONE ALREADY THERE*
004160     DIVIDE JOB-NO BY 100 GIVING J.
004180     IF J = 0 MOVE '0' TO QLEXEC-NODUP GO TO UNIQUE-PRINTFILE1.
004200 UNIQUE-PRINTFILE.
004220     IF J GREATER THAN 35 MOVE '1' TO QLEXEC-NODUP
004240         DISPLAY ' %Writing over ' QLEXECLPT 
004260             UPON CONSOLE GO TO KICKOFF-PRINT.
004280     SET DDX TO J.
004300     MOVE DYN-FILE-CHAR (DDX) TO QLEXEC-NODUP.
004320 UNIQUE-PRINTFILE1.
004340     ENTER MACRO IQLOOK USING DEVICER QLEXECLPT
004360         PROJ USER I.
004380     IF I = -1 ADD 1 TO J GO TO UNIQUE-PRINTFILE.
004400
004420 KICKOFF-PRINT.
004440     OPEN OUTPUT QLEXEC.
004460
004480 OPEN-REOPEN.
004500*    *LOOP HERE TO START NEXT REPORT*
004520     OPEN INPUT QTEXEC.
004540     MOVE 0 TO MORE-TO-GO  CURR-RPT-NO.
004560     SET PXX TO 1.
004580
004600 CLEAROUT-BUFFERS.
004620*    *CLEAR OUT PRINT BUFFERS FOR NEXT REPORT*.
004640     MOVE 0 TO BUFFER-PRINTX (PXX).
004660     MOVE 0 TO IP (PXX).
004680     MOVE 1 TO VSP (PXX).
004700     IF PXX LESS THAN MAX-PXX
004720         SET PXX UP BY 1
004740         GO TO CLEAROUT-BUFFERS.
004760     MOVE SPACES TO PRINT-BUFFERS.
004780
004800 READ-LOOP.
004820*    *LOOP HERE WITHIN A REPORT*
004840     MOVE 0 TO DONE-FLAG.
004860     READ QTEXEC AT END MOVE 1 TO DONE-FLAG GO TO SEE-IF-DONE.
004880
004900*    *IF THIS IS A HEADER RECORD, SET OVERALL PARAMETERS*.
004920     IF QTE-PAGE-NO = 0 AND QTE-LINE-NO = 0
004940         MOVE QTE-DISPLAY-FLAG TO DISPLAY-FLAG
004960         MOVE QTE-PRINT-FLAG   TO PRINT-FLAG
004980         MOVE QTE-LINES-PAGE   TO LINES-PAGE
005000         MOVE QTE-LINES-FORM   TO LINES-FORM
005020         GO TO READ-LOOP.
005040
005060 CHECK-RPT-NO.
005080     IF QTE-RPT-NO = CURR-RPT-NO GO TO PRINT-IT.
005100*    *SEE IF THIS REPORT HAS BEEN DONE*.
005120     SET RPX TO QTE-RPT-NO.
005140     IF RPT-NO (RPX) = 1 GO TO READ-LOOP.
005160*    *NO - SEE IF TIME TO KICK OFF ANOTHER REPORT*.
005180     IF CURR-RPT-NO NOT = 0
005200         MOVE 1 TO MORE-TO-GO
005220         GO TO READ-LOOP.
005240     ADD 1 TO NO-OF-RPTS.
005260     MOVE 1 TO RPT-NO (RPX).
005280     SET CURR-RPT-NO TO RPX.
005300     GO TO PRINT-IT.
005320
005340 PRINT-IT.
005360*    *FIRST LOOK FOR A BUFFER WITH THE SAME PRINTX AS QTE*
005380     SET PXX TO 1.
005400
005420 FIND-PRINTX.
005440     IF BUFFER-PRINTX (PXX) = QTE-PRINTX GO TO ASSEMBLE-LINE.
005460*    *IF NO SUCH BUFFER, ASSIGN ONE*
005480     IF BUFFER-PRINTX (PXX) = 0
005500         MOVE QTE-PRINTX TO BUFFER-PRINTX (PXX)
005520         GO TO ASSEMBLE-LINE.
005540     IF PXX LESS THAN MAX-PXX
005560          SET PXX UP BY 1 GO TO FIND-PRINTX.
005580     DISPLAY
005600         ' ?IQM buffer overflow- too many prints in report'
005620         UPON CONSOLE GO TO READ-LOOP.
005640
005660 ASSEMBLE-LINE.
005680*    *NOW CONCATENATE LOGICAL PRINT IMAGES IF ACROSSING*
005700*    *FIRST CALCULATE WHERE TO PUT THIS IMAGE*
005720     SET I TO PXX.
005740     SUBTRACT 1 FROM I.
005760     MULTIPLY I BY IMAGE-LENGTH GIVING I.
005780     ADD QTE-PRINTPOS TO I.
005800*    *NOW CALCULATE HOW MANY CHARACTERS TO MOVE*
005820     ADD IMAGE-LENGTH 1 GIVING J.
005840     SUBTRACT QTE-PRINTPOS FROM J.
005860     ENTER MACRO IQSX66 USING J
005880         QTE-IMAGE CONST1 PRINT-BUFFERS I.
005900*    *NOW SEE IF WANT TO DO PHYSICAL OUTPUT*
005920     IF QTE-ACROSS GREATER THAN 0
005940         MOVE QTE-VSPACE TO VSP (PXX)
005960         MOVE 1 TO IP (PXX)
005980         GO TO READ-LOOP.
006000     MOVE 0 TO IP (PXX).
006020 ASSEMBLE-LINE1.
006040*    *UPDATE VERTICAL LINE POSITION IN CURRENT PAGE*
006060     IF QTE-VSPACE = 0
006080         SUBTRACT PAGE-LINE FROM LINES-FORM GIVING I
006100         MOVE 1 TO PAGE-LINE
006120         ELSE MOVE QTE-VSPACE TO I ADD I TO PAGE-LINE.
006130     MOVE PRINT-LINE (PXX) TO QLEXEC-REC.
006132      PERFORM TRAILING-NULLS THRU TRAILING-NULLS-EXIT.
006140     IF DISPLAY-FLAG NOT = 1 GO TO PRINT-VSPACE.
006160
006180 DISPLAY-VSPACE.
006200*    *DO ANY NECESSARY VERTICAL SPACING ON TERMINAL*
006202*    * (BUT NOT THE FIRSTIME THRU)*
006204     IF FIRSTTIME = 0
006206        MOVE 1 TO FIRSTTIME  I
006208     ELSE
006220     IF I NOT GREATER THAN 1 NEXT SENTENCE ELSE
006240         DISPLAY ' ' UPON CONSOLE
006260         SUBTRACT 1 FROM I
006280         GO TO DISPLAY-VSPACE.
006300     DISPLAY QLEXEC-REC UPON CONSOLE.
006320
006340 PRINT-VSPACE.
006360*    *SET UP TO DO ANY NECESSARY VERTICAL SPACING ON PRINTER*
006380     IF PRINT-FLAG NOT = 1 GO TO PRINT-IT-DONE.
006400     IF QTE-VSPACE NOT GREATER THAN 3 GO TO PRINT-IT1.
006420     MOVE SPACES TO QLEXEC-REC.
006440
006460 PRINT-VSPACE1.
006480     IF QTE-VSPACE GREATER THAN 3
006500         SUBTRACT 3 FROM QTE-VSPACE
006520         WRITE QLEXEC-REC AFTER ADVANCING 3 LINES
006540         GO TO PRINT-VSPACE1.
006560
006580 PRINT-IT1.
006600     IF QTE-VSPACE = 0
006620         WRITE QLEXEC-REC FROM PRINT-LINE (PXX)
006640              AFTER ADVANCING TOP-OF-PAGE
006660         ELSE WRITE QLEXEC-REC FROM PRINT-LINE (PXX)
006680              AFTER ADVANCING QTE-VSPACE LINES.
006700
006720 PRINT-IT-DONE.
006740     ADD 1 TO NO-TOTAL-LINES.
006760     MOVE 1 TO QTE-VSPACE.
006780     IF DONE-FLAG = 0 GO TO READ-LOOP ELSE GO TO SEE-IF-DONE1.
006800
006820 SEE-IF-DONE.
006840     CLOSE QTEXEC.
006860     SET PXX TO 1.
006880 FLUSH-BUFFERS.
006900     IF IP (PXX) NOT = 0
006920         MOVE VSP (PXX) TO QTE-VSPACE
006940         MOVE 0 TO IP (PXX)
006960         GO TO ASSEMBLE-LINE1.
006980
007000 SEE-IF-DONE1.
007020     SET PXX UP BY 1.
007040     IF PXX LESS THAN MAX-PXX GO TO FLUSH-BUFFERS.
007060
007080     IF MORE-TO-GO  = 1 GO TO OPEN-REOPEN.
007100     MOVE ' End multiple report phase; print file is '
007102        TO QLEXEC-REC
007104     MOVE QLEXECLPT TO QLEXECLPT-MSG.
007120     IF DISPLAY-FLAG NOT = 1 GO TO PRINT-WRAPUP.
007140     SUBTRACT PAGE-LINE FROM LINES-PAGE GIVING I.
007160
007180 DISPLAY-WRAPUP.
007200*    *SPACE DOWN TO TOP OF NEXT TERMINAL PAGE*
007220     IF I GREATER THAN 1 DISPLAY ' ' UPON CONSOLE
007240         SUBTRACT 1 FROM I
007260         GO TO DISPLAY-WRAPUP.
007270     PERFORM TRAILING-NULLS THRU TRAILING-NULLS-EXIT.
007280     DISPLAY QLEXEC-REC UPON CONSOLE.
007300
007320 PRINT-WRAPUP.
007340     IF PRINT-FLAG = 1
007360         WRITE QLEXEC-REC AFTER ADVANCING TOP-OF-PAGE.
007380     MOVE SPACES TO QLEXEC-REC.
007400     MOVE ' Reports printed-' TO PRINT-MSG.
007420     MOVE NO-OF-RPTS TO PRINT-MASK.
007440     MOVE  PRINT-MASK TO PRINT-COUNT.
007460     IF DISPLAY-FLAG = 1 DISPLAY ' ' UPON CONSOLE
007470     PERFORM TRAILING-NULLS THRU TRAILING-NULLS-EXIT.
007480          DISPLAY QLEXEC-REC UPON CONSOLE.
007500     IF PRINT-FLAG = 1
007520         WRITE QLEXEC-REC AFTER ADVANCING 2 LINES.
007540     MOVE SPACES TO QLEXEC-REC.
007560     MOVE ' Lines printed-' TO PRINT-MSG.
007580     MOVE NO-TOTAL-LINES TO PRINT-MASK.
007600     MOVE PRINT-MASK TO PRINT-COUNT.
007620     IF DISPLAY-FLAG = 1
007624         PERFORM TRAILING-NULLS THRU TRAILING-NULLS-EXIT
007626         DISPLAY QLEXEC-REC UPON CONSOLE.
007640     IF PRINT-FLAG = 1
007660         WRITE QLEXEC-REC AFTER ADVANCING 1 LINES.
007680
007700 REALLY-DONE.
007720     CLOSE QLEXEC.
007740     OPEN INPUT QTEXEC.
007760     CLOSE QTEXEC WITH DELETE.
007780*    CLOSE QTEXEC.
007800     MOVE 'IQL   ' TO CALLED-NAME.
007820     ENTER MACRO IQNEXT USING CALLED-NAME.
007840     STOP RUN.
007860
007880 TRAILING-NULLS.
007900      SET PCX TO 200.
007920 TRAILING-NULLS1.
007940     IF PRINT-CHAR (PCX) = SPACE IF PCX >1
007960         MOVE ASCII-NULL TO PRINT-CHAR (PCX)
007980         SET PCX DOWN BY 1 GO TO TRAILING-NULLS1.
007800 TRAILING-NULLS-EXIT.
007820     EXIT.