Trailing-Edge
-
PDP-10 Archives
-
iqlv30
-
iqsch.cbl
There are 2 other files named iqsch.cbl in the archive. Click here to see a list.
000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. IQSCH.
000300 SECURITY. COPYRIGHT 1979 AZREX INC;
000400 ALL RIGHTS RESERVED.
000500
000600 ENVIRONMENT DIVISION.
000700 CONFIGURATION SECTION.
000800 INPUT-OUTPUT SECTION.
000900 FILE-CONTROL.
001000 SELECT DICT-TRNS-FILE ASSIGN TO DSK
001100 RECORDING MODE IS ASCII.
001200 DATA DIVISION.
001300 FILE SECTION.
001400
001500 FD DICT-TRNS-FILE
001600 VALUE OF IDENTIFICATION IS TRNS-FILE-VID
001700 LABEL RECORDS ARE STANDARD
001800 BLOCK CONTAINS 1 RECORD.
001900 01 DICT-TRNS-REC DISPLAY-7.
002000 02 TRNS-CODE PIC X(2).
002100 02 TRNS-ACT PIC X(1).
002200 02 FILLER PIC X(38).
002300 02 TRNS-RTYPE PIC XXX.
002400 02 FILLER PIC X(9).
002500 02 TRNS-FCHAR PIC 9(4).
002600 02 TRNS-NCHAR PIC 9(4).
002700 02 TRNS-ITYPE PIC X.
002800 02 FILLER PIC X(58).
002900
003000 WORKING-STORAGE SECTION.
003100
003200 01 CODEX PIC X VALUE SPACE.
003300 01 LAST-REC-TYPE PIC XXX VALUE SPACE.
003400 01 NEXT-FCHAR-SLOT PIC S9(8) COMP VALUE 0.
003500 01 I PIC S9(8) COMP VALUE 0.
003600 01 J PIC S9(8) COMP VALUE 0.
003700 01 ERR INDEX.
003800 01 FLAG INDEX.
003900 01 IJOB-NO INDEX.
004000 01 LOCKX PIC X(30) VALUE SPACES DISPLAY-7.
004100 01 SCH PIC X(30) VALUE SPACES DISPLAY-7.
004200 01 SCH-SIXBIT PIC X(30) VALUE SPACES DISPLAY-6.
004300 01 SSC PIC X(30) VALUE SPACES DISPLAY-7.
004400 01 SSC-SIXBIT PIC X(30) VALUE SPACES DISPLAY-6.
004500 01 STSBLK.
004600 02 FILLER PIC X(6) VALUE SPACES DISPLAY-6.
004700 01 SYSCOM.
004800 02 FILLER PIC X(70) VALUE SPACES DISPLAY-7.
004900 02 ERROR-STATUS INDEX.
005000 02 FILLER PIC X(105) VALUE SPACES DISPLAY-7.
005100 01 TRNSBLK DISPLAY-7.
005200 02 TRNSELEM OCCURS 2160 TIMES INDEXED BY IX.
005300 04 TRNS-ID PIC XX.
005400 04 FILLER PIC X(118).
005500 01 BUFFER REDEFINES TRNSBLK PIC X(259200) DISPLAY-7.
005600 01 TRNS-FILE-VID.
005700 02 FILLER PIC XX VALUE "QC".
005800 02 JOB-NO PIC 999 VALUE 0.
005900 02 FILLER PIC X(4) VALUE "DTMP".
006000
006100 PROCEDURE DIVISION.
006200
006300 BEGIN.
006400 PERFORM INIT THRU INIT-EXIT.
006500 ENTER MACRO IQDBDM USING
006600 SCH,SSC,LOCKX,BUFFER,FLAG,ERR,STSBLK,SYSCOM,TRNSBLK.
006700 IF ERR NOT = 0
006800 DISPLAY " "
006900 DISPLAY "?-Error occurred in IQDBDM..check"
007000 " that your schema name"
007100 DISPLAY " sub-schema name and key are correct"
007200 STOP RUN.
007300 PERFORM WRITE-TRNS THRU WRITE-TRNS-EXIT.
007400 DISPLAY " ".
007500 DISPLAY "[ Finished. Please run IQD to update QPDICT.SEQ]".
007600 STOP RUN.
007700
007800 INIT.
007900 DISPLAY " ".
008000 DISPLAY "[IQSCH - Program to create IQL dictionary"
008100 " from .SCH file]".
008200 DISPLAY " ".
008300 DISPLAY "SCHEMA=" WITH NO ADVANCING
008400 ACCEPT SCH-SIXBIT.
008500 MOVE SCH-SIXBIT TO SCH.
008600 DISPLAY "SUB-SCHEMA=" WITH NO ADVANCING.
008700 ACCEPT SSC-SIXBIT.
008800 MOVE SSC-SIXBIT TO SSC.
008900 DISPLAY "PRIVACY KEY (if any)=" WITH NO ADVANCING.
009000 ACCEPT LOCKX.
009100
009200 INIT1.
009300 DISPLAY "UPDATE CODE (H for help) =" WITH NO ADVANCING.
009400 ACCEPT CODEX.
009500 IF CODEX = "H"
009600 DISPLAY "A means ADD this as a new dictionary"
009700 DISPLAY
009800 "R means REPLACE the current dictionary with this one"
009900 GO TO INIT1.
010000 IF CODEX NOT = "A" AND CODEX NOT = "R"
010100 DISPLAY "%-Please type A, R, or H" GO TO INIT1.
010200 MOVE 2 TO FLAG.
010300 ENTER MACRO IQGJOB USING IJOB-NO.
010400 MOVE IJOB-NO TO JOB-NO.
010500
010600 INIT-EXIT.
010700 EXIT.
010800
010900 WRITE-TRNS.
011000 OPEN OUTPUT DICT-TRNS-FILE.
011100 SET IX TO 2.
011200 PERFORM WRITE-ONE-TRNS THRU WRITE-ONE-TRNS-EXIT.
011300 MOVE "A" TO CODEX.
011400
011500 WRITE-TRNS-LOOP.
011600 IF TRNS-ID (IX) = LOW-VALUES OR TRNS-ID (IX) = SPACES
011700 CLOSE DICT-TRNS-FILE
011800 GO TO WRITE-TRNS-EXIT
011900 ELSE PERFORM WRITE-ONE-TRNS THRU WRITE-ONE-TRNS-EXIT
012000 GO TO WRITE-TRNS-LOOP.
012100
012200 WRITE-TRNS-EXIT.
012300 EXIT.
012400
012500 WRITE-ONE-TRNS.
012600 MOVE TRNSELEM (IX) TO DICT-TRNS-REC.
012700 MOVE CODEX TO TRNS-ACT.
012800 IF TRNS-CODE = "RD" MOVE TRNS-RTYPE TO LAST-REC-TYPE
012900 MOVE 1 TO NEXT-FCHAR-SLOT
013000 GO TO WRITE-ONE-TRNS-WRITE.
013100 IF TRNS-CODE NOT = "DD" GO TO WRITE-ONE-TRNS-WRITE.
013200* *CALCULATE CURRENT LEFTMOST CHAR ORIGIN FOR DD IN-HAND*.
013300 IF TRNS-ITYPE = "1" OR "A" OR "2" OR "N"
013400 MOVE NEXT-FCHAR-SLOT TO TRNS-FCHAR
013500 ADD TRNS-NCHAR TO NEXT-FCHAR-SLOT
013600 GO TO WRITE-ONE-TRNS-WRITE.
013700 IF TRNS-ITYPE NOT = "6" AND TRNS-ITYPE NOT = "B"
013800 DISPLAY "%-Error in item type generated by IQSCH: "
013900 TRNS-ITYPE UPON CONSOLE
014000 GO TO WRITE-ONE-TRNS-WRITE.
014100 IF LAST-REC-TYPE = "006" GO TO WRITE-ONE-TRNS6.
014200 IF LAST-REC-TYPE = "007" GO TO WRITE-ONE-TRNS7.
014300 DISPLAY "%-Error in record type generated by IQSCH:"
014400 LAST-REC-TYPE UPON CONSOLE.
014500 DISPLAY " assuming 007 (ASCII)" UPON CONSOLE.
014600 MOVE "007" TO LAST-REC-TYPE.
014700
014800 WRITE-ONE-TRNS7.
014900* *CALCULATE NEXT POSSIBLE ASCII ORIGIN FOR A COMP (BINARY)*
015000 DIVIDE NEXT-FCHAR-SLOT BY 5 GIVING I REMAINDER J.
015100 IF J > 1 ADD 1 TO I.
015200 COMPUTE NEXT-FCHAR-SLOT = (I * 5) + 1.
015300 MOVE NEXT-FCHAR-SLOT TO TRNS-FCHAR.
015400 IF TRNS-NCHAR > 10 ADD 10 TO NEXT-FCHAR-SLOT
015500 ELSE ADD 5 TO NEXT-FCHAR-SLOT.
015600 GO TO WRITE-ONE-TRNS-WRITE.
015700
015800 WRITE-ONE-TRNS6.
015900* *HERE CALCULATE NEXT POSSIBLE SIXBIT SLOT FOR COMP (BINARY)*.
016000 DIVIDE NEXT-FCHAR-SLOT BY 6 GIVING I REMAINDER J.
016100 IF J > 1 ADD 1 TO I.
016200 COMPUTE NEXT-FCHAR-SLOT = (I * 6) + 1.
016300 IF TRNS-NCHAR > 10 ADD 12 TO NEXT-FCHAR-SLOT
016400 ELSE ADD 6 TO NEXT-FCHAR-SLOT.
016500
016600 WRITE-ONE-TRNS-WRITE.
016700 WRITE DICT-TRNS-REC.
016800 SET IX UP BY 1.
016900
017000 WRITE-ONE-TRNS-EXIT.
017100 EXIT.