Trailing-Edge
-
PDP-10 Archives
-
BB-H548B-BM
-
iql-source/iqd.cbl
There are 2 other files named iqd.cbl in the archive. Click here to see a list.
000100 IDENTIFICATION DIVISION.
000120
000140 PROGRAM-ID. IQD.
000160
000180 DATE-WRITTEN. 1976.
000200 DATE-COMPILED. 1976.
000220
000240 SECURITY. COPYRIGHT 1976 AZREX INC. ALL RIGHTS RESERVED.
000260 REMARKS. THIS IS VERSION 3.0 OF THE DICTIONARY GENERATOR
000280 FOR THE IQL3 SYSTEM.
000360
000380 ENVIRONMENT DIVISION.
000400 CONFIGURATION SECTION.
000420 SOURCE-COMPUTER. DECSYSTEM-20.
000440 OBJECT-COMPUTER. DECSYSTEM-20.
000460 SPECIAL-NAMES. CHANNEL (1) IS TOP-OF-PAGE
000480 CONSOLE IS TTY.
000500
000520 INPUT-OUTPUT SECTION.
000540 FILE-CONTROL.
000560 SELECT QPDICT ASSIGN TO DSK.
000580 SELECT QTDICT ASSIGN TO DSK.
000600 SELECT QCDICT ASSIGN TO DSK.
000620 SELECT QLDICT ASSIGN TO DSK.
000640
000660 DATA DIVISION.
000680
000700 FILE SECTION.
000720
000740 FD QPDICT
000760 VALUE OF IDENTIFICATION IS QPDICTSEQ
000780 LABEL RECORDS ARE STANDARD
000800 BLOCK CONTAINS 0 RECORDS
000820 RECORD CONTAINS 150 CHARACTERS
000840 DATA RECORD IS DICT-REC.
000860 01 DICT-REC PIC X(150) USAGE IS DISPLAY-7.
000880
000900 FD QLDICT
000920 VALUE OF IDENTIFICATION IS QL001DLPT
000940 LABEL RECORDS ARE STANDARD
000960 BLOCK CONTAINS 0 RECORDS
000980 RECORD CONTAINS 132 CHARACTERS
001000 DATA RECORD IS PRINT-LINE.
001020 01 PRINT-LINE USAGE IS DISPLAY-7.
001040 02 PRINT-LN PIC X(132).
001060
001080 FD QCDICT
001100 VALUE OF IDENTIFICATION IS QC001DTMP
001120 LABEL RECORDS ARE STANDARD
001140 BLOCK CONTAINS 0 RECORDS
001160 DATA RECORD IS TRANSACTION-REC.
001180 01 TRANSACTION-REC PIC X(120) USAGE IS DISPLAY-7.
001200
001220 FD QTDICT
001240 VALUE OF IDENTIFICATION IS QT001DTMP
001260 LABEL RECORDS ARE STANDARD
001280 BLOCK CONTAINS 0 RECORDS
001300 RECORD CONTAINS 150 CHARACTERS
001320 DATA RECORD IS WORK-REC.
001340 01 WORK-REC PIC X(150) USAGE IS DISPLAY-7.
001360
001380 WORKING-STORAGE SECTION.
001390 01 UNIVERSAL-PASSWORD PIC X(12) VALUE 'DRAGON '.
001400 01 COPY-LEVEL PIC 99 VALUE 0.
001420 01 CURRENT-CF-NAME PIC X(30).
001440 01 CURRENT-DF-NAME PIC X(30).
001460 01 DASH PIC X VALUE '-'.
001480 01 PAGE-CTR PIC 9(3) VALUE 0.
001500 01 PW-REF-SUM PIC 9(3) VALUE 0.
001520 01 PW-TEXT-HOLDER PIC X(12).
001540 01 LINE-CTR PIC 99 VALUE 0.
001560 01 LINE-MAX PIC 99 VALUE 54.
001580 01 ELEM-CHAR PIC X VALUE SPACE DISPLAY-7.
001600 01 FOUND-FD-TRAN PIC S9(10) COMP VALUE 0.
001620 01 FOUND-ENTRY PIC S9(10) COMP VALUE 0.
001640 01 FOUND-FD PIC S9(10) COMP VALUE 0.
001660 01 FOUND-DICT PIC S9(10) COMP VALUE 0.
001680 01 FOUND-NON-FD-FLAG PIC S9(10) COMP VALUE 0.
001700 01 1ST-NTRY-FLAG PIC S9(10) COMP VALUE 0.
001720 01 FURNISHED-UNLOCKER PIC X(6).
001740 01 HOLD-TRAN-FLAG PIC S9(10) COMP VALUE 0.
001760 01 DICT-EOF PIC S9(10) COMP VALUE 0.
001780 01 DICT-LOCK PIC S9(10) COMP VALUE 0.
001800 01 I PIC S9(4) COMP VALUE 0.
001820 01 IGNORE-RECORD-FLAG PIC S9(10) COMP VALUE 0.
001840 01 J PIC S9(10) COMP VALUE 0.
001860 01 JOB-NO PIC S9(3) COMP VALUE 1.
001880 01 K PIC S9(10) COMP VALUE 0.
001900 01 L PIC S9(10) COMP VALUE 0.
001904 01 M PIC S9(10) COMP VALUE 0.
001920 01 LOOK-CYCLE PIC 9 VALUE 0.
001940 01 TRAN-ERR-FLG PIC 9 VALUE 0.
001960*77 MAX-RECLEN PIC 9(4) VALUE 2600.
001980*77 MIN-RECLEN PIC 9(4) VALUE 15.
002000*77 MAX-BLKFACT PIC 9(4) VALUE 7200.
002020 01 MAX-EDIT PIC 99 VALUE 20.
002040 01 EDIT-ERROR-FLAG PIC S9(10) COMP VALUE 0.
002060 01 TEMPFTX PIC X.
002080 01 TEMPNUMFT REDEFINES TEMPFTX
002100 PIC 9.
002120 01 MAX-KEYLEN PIC 9(3) VALUE 30.
002140 01 MAX-ITEMLEN PIC 9(4) VALUE 50.
002160 01 CURRENT-FILENAME PIC X(30).
002180 01 TRAN-FILE-FLAG PIC S9(10) COMP VALUE 0.
002200 01 DICT-FILE-FLAG PIC S9(10) COMP VALUE 0.
002220 01 WORK-FILE-FLAG PIC S9(10) COMP VALUE 0.
002240 01 PRINT-FILE-FLAG PIC S9(10) COMP VALUE 0.
002244 01 PROTECTED-LEVEL PIC 99 VALUE 0.
002260 01 RETURN-FLAG PIC S9(10) COMP.
002310 01 UNLOCKED-LEVEL PIC 99 VALUE 0.
002315 01 UNLOCKED-WORK PIC 99 VALUE 0.
002340 01 WORK-1 PIC 9(4) VALUE 0.
002360 01 WORK-2 PIC 9(8) VALUE 0.
002380
002400**FILE NAME CONSTRUCTORS FOLLOW**
002420
002440 01 QC001DTMP.
002460 02 FILLER PIC X(2) VALUE 'QC'.
002480 02 QC001DNO PIC 9(3) VALUE 1.
002500 02 FILLER PIC X(4) VALUE 'DTMP'.
002520 01 QT001DTMP.
002540 02 FILLER PIC X(2) VALUE 'QT'.
002560 02 QT001DNO PIC 9(3) VALUE 1.
002580 02 FILLER PIC X(4) VALUE 'DTMP'.
002600 01 QL001DLPT.
002620 02 FILLER PIC X(2) VALUE 'QL'.
002640 02 QL001DNO PIC 9(3) VALUE 1.
002660 02 FILLER PIC X(4) VALUE 'DLPT'.
002680 01 QPDICTSEQ PIC X(9) VALUE 'QPDICTSEQ'.
002700 01 DEVICER PIC X(6) VALUE SPACE.
002720 01 PROJ PIC S9(8) COMP VALUE 0.
002740 01 USER PIC S9(8) COMP VALUE 0.
002760 01 CALLED-NAME PIC X(6) USAGE IS DISPLAY-6.
002780 01 TOP-TITLE DISPLAY-7.
002800 02 TOP-TITLE-CHAR PIC X OCCURS 10 TIMES
002820 INDEXED BY TTX.
002840 01 BOTTOM-TITLE DISPLAY-7.
002860 02 BOTTOM-TITLE-CHAR PIC X OCCURS 10 TIMES
002880 INDEXED BY BTX.
002900 01 PICT-REDEF.
002920 02 PICTCHAR PIC X OCCURS 19 TIMES
002940 INDEXED BY PIX.
002960 01 SCANTABLE.
002980 02 N-SCANITEMS PIC 9(3) VALUE 0.
003000 02 SCANTABLEINFO OCCURS 100 TIMES.
003020 03 GROUP-NAME-TAB PIC X.
003040 03 GROUP-LEN-TAB PIC 9(3).
003060 01 DATE-CONV.
003080 02 YR-IN PIC 99.
003100 02 MO-IN PIC 99.
003120 02 DA-IN PIC 99.
003140 02 FILLER PIC X(38).
003160 01 DATE-MASK.
003180 02 MON PIC 99.
003200 02 SLSH1 PIC X VALUE '/'.
003220 02 DAYY PIC 99.
003240 02 SLSH2 PIC X VALUE '/'.
003260 02 YEAR PIC 99.
003280 01 DATE-WORK.
003300 02 WMON PIC XX.
003320 02 WDAY PIC XX.
003340 02 WYEAR PIC XX.
003360 01 PACKED-DATE.
003380 02 PMON PIC XX.
003400 02 PDAY PIC XX.
003420 02 PYEAR PIC XX.
003440 01 SLASHED-DATE.
003460 02 SMON PIC XX.
003480 02 FILLER PIC X VALUE '/'.
003500 02 SDAY PIC XX.
003520 02 FILLER PIC X VALUE '/'.
003540 02 SYEAR PIC XX.
003560 01 NUMEDX4 PIC 9(4).
003580 01 NUMEDXANGRP REDEFINES NUMEDX4.
003600 02 FILLER PIC XX.
003620 02 NUMEDXAN PIC 99.
003640 01 NUMEDXGRP REDEFINES NUMEDX4.
003660 02 FILLER PIC XX.
003680 02 NUMEDX PIC 99.
003700 01 TRAN-MESSAGE USAGE IS DISPLAY-7.
003720 02 FILLER PIC X(8) VALUE ' TRANS- '.
003740 02 TRAN-LINE PIC X(120).
003760 02 FILLER PIC X(4) VALUE SPACE.
003780
003800 01 PICTURE-TABLE.
003820 02 PICT1 PIC X(15) VALUE '999-99-9999'.
003840 02 PICT2 PIC X(15) VALUE 'SZZZ9.99'.
003860 02 PICT3 PIC X(15) VALUE '999-9999'.
003880 02 PICT4 PIC X(15) VALUE '9999 9999'.
003900 02 PICT5 PIC X(15) VALUE 'SZ9.99'.
003920 02 PICT6 PIC X(15) VALUE 'SZZ9.99'.
003940 02 PICT7 PIC X(15) VALUE '99-99-99'.
003960 02 PICT8 PIC X(15) VALUE 'SZZZZ9'.
003980 02 PICT9 PIC X(15) VALUE 'SZZZZ9.99'.
004000 02 PICT10 PIC X(15) VALUE 'SZZZZZ9.99999'.
004020 02 PICT11 PIC X(15)
004040 VALUE 'ZZZZZZZZZZZZZZZ'.
004060 02 PICT12 PIC X(15) VALUE 'SZZZZZ9.99'.
004080 02 PICT13 PIC X(15) VALUE 'SZZZZZZ9.99'.
004100 02 PICT14 PIC X(15) VALUE 'SZZZ9.999'.
004120 02 PICT15 PIC X(15) VALUE 'ZZZZZ9.99'.
004140 02 PICT16 PIC X(15) VALUE 'S9.99'.
004160 02 PICT17 PIC X(15) VALUE 'SZZZZZZZ'.
004180 02 PICT18 PIC X(15) VALUE 'SZ9.999'.
004200 02 PICT19 PIC X(15) VALUE 'SZZZZZ9'.
004220 02 PICT20 PIC X(15) VALUE 'SZZZZZZ9.99'.
004240 02 PICT21 PIC X(15) VALUE 'XX-XXXX-X'.
004260 02 PICT22 PIC X(15) VALUE 'X-XXX-XX'.
004280 02 PICT23 PIC X(15) VALUE 'ZZZ.999'.
004300 02 PICT24 PIC X(15) VALUE 'S9.999'.
004320 02 PICT25 PIC X(15) VALUE 'SZZZZZZZZ'.
004340 02 PICT26 PIC X(15) VALUE 'SZZZZZZZZZ'.
004360 02 PICT27 PIC X(15) VALUE 'SZZZZZZZZZZ'.
004380 02 PICT28 PIC X(15) VALUE 'SZZZZZZZ9.99'.
004400 02 PICT29 PIC X(15) VALUE '.999999'.
004420 02 PICT30 PIC X(15) VALUE 'SZZZZZZZZ9.99'.
004440 01 PICT-TAB REDEFINES PICTURE-TABLE.
004460 02 IQ-PICTURE PIC X(15) OCCURS 30 TIMES.
004480
004500 01 HOLD-WS PIC X(150).
004520
004540**INPUT FORMATS FOR DICTIONARY TRANSACTIONS FOLLOWS**
004560
004580 01 TRAN-WS DISPLAY-7.
004600 02 TRAN-FD.
004620 04 CF-IDNT PIC XX.
004640 04 CF-ACT PIC X.
004660 04 CF-NAME PIC X(30).
004680 04 CF-INLABEL PIC X(9).
004700 04 FILLER PIC X(8).
004720 04 CF-DIRECT PIC X(19).
004740 04 CF-FILETYPE-X PIC X.
004760 04 CF-FILETYPE REDEFINES CF-FILETYPE-X
004780 PIC 9.
004800 04 CF-RECLEN-X PIC X(4).
004820 04 CF-RECLEN REDEFINES CF-RECLEN-X
004840 PIC 9(4).
004860 04 CF-BLKFACT-X PIC X(4).
004880 04 CF-BLKFACT REDEFINES CF-BLKFACT-X
004900 PIC S9(4).
004920 04 CF-KEYPOS-X PIC X(4).
004940 04 CF-KEYPOS REDEFINES CF-KEYPOS-X
004960 PIC 9(4).
004980 04 CF-KEYLEN-X PIC XXX.
005000 04 CF-KEYLEN REDEFINES CF-KEYLEN-X
005020 PIC 9(3).
005040 04 CF-KEYTYPE-X PIC X.
005060 04 CF-KEYTYPE REDEFINES CF-KEYTYPE-X
005080 PIC 9.
005100 04 CF-KEYSIGN PIC X.
005120 04 CF-PROT-READ PIC XX.
005140 04 CF-PROT-COPY PIC XX.
005160 04 CF-PROT-REWR PIC XX.
005180 04 FILLER PIC X(21).
005200 04 CF-PASSWORD PIC X(6).
005220
005240 02 TRAN-PD REDEFINES TRAN-FD.
005260 04 CP-IDNT PIC XX.
005280 04 CP-ACT PIC X.
005300 04 CP-PROT-NO PIC 99.
005320 04 CP-PROT-NO-X REDEFINES CP-PROT-NO
005340 PIC XX.
005360 04 CP-DATE-FLAG PIC X.
005380 04 CP-LINE PIC 9.
005400 04 CP-LINE-X REDEFINES CP-LINE
005420 PIC X.
005440 04 CP-TEXT.
005460 06 CP-PASSWORD.
005480 08 CP-CHAR PIC X OCCURS 6 TIMES.
005500 08 FILLER PIC X(6).
005520 04 FILLER PIC X(101).
005540
005560 02 TRAN-DD REDEFINES TRAN-FD.
005580 04 CD-IDNT PIC XX.
005600 04 CD-ACT PIC X.
005620 04 CD-NAME.
005640 06 CD-NME2.
005660 08 CD-NME1 PIC X.
005680 08 FILLER PIC X.
005700 06 FILLER PIC X(28).
005720 04 CD-TITLE1 PIC X(10).
005740 04 CD-TITLE2 PIC X(10).
005760 04 CD-FCHAR-X PIC X(4).
005780 04 CD-FCHAR REDEFINES CD-FCHAR-X
005800 PIC 9(4).
005820 04 CD-NCHARS-X PIC X(4).
005840 04 CD-NCHARS REDEFINES CD-NCHARS-X
005860 PIC 9(4).
005880 04 CD-TYPE PIC 9.
005900 04 CD-TYPE-X REDEFINES CD-TYPE
005920 PIC X.
005940 04 CD-SCALE PIC 9.
005960 04 CD-SCALE-X REDEFINES CD-SCALE
005980 PIC X.
006000 04 CD-OFFSET PIC 9.
006020 04 CD-OFFSET-X REDEFINES CD-OFFSET
006040 PIC X.
006060 04 CD-EDIT-X PIC XX.
006080 04 CD-EDIT REDEFINES CD-EDIT-X
006100 PIC 99.
006120 04 CD-PICT PIC X(19).
006140 04 FILLER REDEFINES CD-PICT.
006160 06 CD-PICTCHAR PIC X OCCURS 19 TIMES.
006180 04 CD-SCANINFO.
006200 06 CD-GRPNME PIC X.
006220 06 CD-NREPEATS PIC 99.
006240 06 CD-NREPEATS-X REDEFINES CD-NREPEATS
006260 PIC XX.
006280 06 CD-STOPPER PIC X.
006300 04 CD-PROTINFO.
006320 06 CD-PROT-NO PIC 99.
006340 06 CD-PROT-NO-X REDEFINES CD-PROT-NO
006360 PIC XX.
006380 06 CD-EXCLFLAG PIC X.
006400 04 CD-NOUPD PIC X.
006420 04 FILLER PIC X(27).
006440 02 TRAN-CD REDEFINES TRAN-FD.
006460 04 CC-IDNT PIC XX.
006480 04 CC-ACT PIC X.
006500 04 CC-NO PIC XX.
006520 04 CC-TEXT PIC X(115).
006540 02 TRAN-RD REDEFINES TRAN-FD.
006560 04 RD-IDNT PIC XX.
006580 04 RD-ACT PIC X.
006600 04 RD-NAME PIC X(30).
006620 04 RD-ORIGIN PIC 9(4).
006640 04 RD-ORIGIN-X REDEFINES RD-ORIGIN
006660 PIC X(4).
006680 04 RD-LENGTH PIC 9(4).
006700 04 RD-LENGTH-X REDEFINES RD-LENGTH
006720 PIC X(4).
006740 04 RD-TYPE PIC XXX.
006760 04 RD-TEXT PIC X(76).
006780 02 TRAN-AD REDEFINES TRAN-FD.
006800 04 AD-IDNT PIC XX.
006820 04 AD-ACT PIC X.
006840 04 AD-NAME PIC X(30).
006860 04 AD-ORIGIN PIC 9(4).
006880 04 AD-ORIGIN-X REDEFINES AD-ORIGIN
006900 PIC X(4).
006920 04 AD-LENGTH PIC 9(4).
006940 04 AD-LENGTH-X REDEFINES AD-LENGTH
006960 PIC X(4).
006980 04 AD-TYPE PIC XXX.
007000 04 AD-TEXT PIC X(76).
007020 02 TRAN-SD REDEFINES TRAN-FD.
007040 04 SD-IDNT PIC XX.
007060 04 SD-ACT PIC X.
007080 04 SD-NAME PIC X(30).
007100 04 FILLER PIC X(8).
007120 04 SD-TYPE PIC XXX.
007140 04 SD-TEXT PIC X(76).
007160 01 HOLD-TRAN-FD PIC X(120) VALUE SPACES
007170 DISPLAY-7.
007180 01 LAST-DD-NAME.
007200 02 LAST-DD-CHAR PIC X OCCURS 30 TIMES.
007220 01 PW-WORKER USAGE IS DISPLAY-6.
007240 02 PW-CHAR PIC X OCCURS 12 TIMES.
007260 01 PW-WORK REDEFINES PW-WORKER.
007280 02 PW-WORK1 PIC S9(10) COMP.
007300 02 PW-WORK2 PIC S9(10) COMP.
007320 01 PW-MASK1 PIC S9(10) COMP VALUE 14729163.
007340 01 PW-MASK2 PIC S9(10) COMP VALUE -24815212.
007360
007380 01 HOLD-TRAN PIC X(120) DISPLAY-7.
007400
007420**FORMATS FOR PERMANENT DICTIONARY ENTRIES FOLLOW**
007440
007460 01 DICT-WS DISPLAY-7.
007480 02 DICT-FD.
007500 04 DF-IDNT PIC XX.
007520 04 DF-NAME PIC X(30).
007540 04 DF-NDICTS PIC 9(3).
007560 04 DF-INLABEL PIC X(17).
007580 04 DF-DIRECT PIC X(19).
007600 04 DF-FILETYPE PIC X.
007620 04 DF-RECLEN PIC 9(4).
007640 04 DF-BLKFACT PIC S9(4).
007660 04 DF-KEYPOS PIC 9(4).
007680 04 DF-KEYLEN PIC 9(3).
007700 04 DF-KEYTYPE PIC 9.
007720 04 DF-KEYSIGN PIC 9.
007740 04 DF-PROT PIC X.
007760 04 DF-PROT-READ PIC XX.
007780 04 DF-PROT-COPY PIC XX.
007800 04 DF-PROT-REWR PIC XX.
007820 04 FILLER PIC X(48).
007840 04 DF-LAST-UPDATE PIC X(6).
007860
007880 02 DICT-DD REDEFINES DICT-FD.
007900 04 DD-IDNT PIC XX.
007920 04 DD-NAME PIC X(30).
007940 04 DD-TITLE1 PIC X(10).
007960 04 DD-TITLE2 PIC X(10).
007980 04 DD-NTCHARS PIC 99.
008000 04 DD-NECHARS PIC 9(4).
008020 04 DD-FCHAR PIC 9(4).
008040 04 DD-NCHARS PIC 9(4).
008060 04 DD-TYPE PIC X.
008080 04 DD-SCALE PIC 9.
008100 04 DD-OFFSET PIC 9.
008120 04 DD-EDIT PIC 99.
008140 04 DD-PICT PIC X(19).
008160 04 DD-SCANINFO.
008180 06 DD-GRPLEN PIC 9(3).
008200 06 DD-GRPNME PIC X.
008220 06 DD-NREPEATS PIC XX.
008240 06 DD-STOPPER PIC X.
008260 04 DD-PROTINFO.
008280 06 DD-PROT-NO PIC 99.
008300 06 DD-PROT-NO-X REDEFINES DD-PROT-NO
008320 PIC XX.
008340 06 DD-EXCLFLAG PIC X.
008360 04 DD-RECTYPE PIC XXX.
008380 04 DD-NOUPD PIC X.
008400 04 FILLER PIC X(40).
008420 04 DD-LAST-UPDATE PIC X(6).
008440
008460 02 DICT-PD REDEFINES DICT-FD.
008480 04 DP-IDNT PIC XX.
008500 04 DP-PROT-NO PIC 99.
008520 04 DP-DATE-FLAG PIC X.
008540 04 DP-LINE PIC 9.
008560 04 DP-TEXT.
008580 06 DP-CHAR PIC X OCCURS 12 TIMES.
008600 04 FILLER PIC X(126).
008620 04 DP-LAST-UPDATE PIC X(6).
008640
008660 02 DICT-CD REDEFINES DICT-FD.
008680 04 DC-IDNT PIC XX.
008700 04 DC-NO PIC XX.
008720 04 DC-TEXT PIC X(115).
008740 04 FILLER PIC X(25).
008760 04 DC-LAST-UPDATE PIC X(6).
008780
008800 02 DICT-RD REDEFINES DICT-FD.
008820 04 DR-IDNT PIC XX.
008840 04 DR-NAME PIC X(30).
008860 04 DR-ORIGIN PIC 9(4).
008880 04 DR-LENGTH PIC 9(4).
008900 04 DR-TYPE PIC XXX.
008920 04 DR-TEXT PIC X(76).
008940 04 FILLER PIC X(25).
008960 04 DR-LAST-UPDATE PIC X(6).
008980
009000 02 DICT-AD REDEFINES DICT-FD.
009020 04 DA-IDNT PIC XX.
009040 04 DA-NAME PIC X(30).
009060 04 DA-ORIGIN PIC 9(4).
009080 04 DA-LENGTH PIC 9(4).
009100 04 DA-TYPE PIC XXX.
009120 04 DA-TEXT PIC X(76).
009140 04 FILLER PIC X(25).
009160 04 DA-LAST-UPDATE PIC X(6).
009180
009200 02 DICT-SD REDEFINES DICT-FD.
009220 04 DS-IDNT PIC XX.
009240 04 DS-NAME PIC X(30).
009260 04 FILLER PIC X(8).
009280 04 DS-TYPE PIC XXX.
009300 04 DS-TEXT PIC X(76).
009320 04 FILLER PIC X(25).
009340 04 DS-LAST-UPDATE PIC X(6).
009360
009380 01 FILE-TYPE-LIST DISPLAY-7.
009400 02 FILLER PIC X(16) VALUE 'Labeled Tape '.
009420 02 FILLER PIC X(16) VALUE 'Unlabeled Tape '.
009440 02 FILLER PIC X(16) VALUE 'Rptd Lbld Tape '.
009460 02 FILLER PIC X(16) VALUE 'Rptd Unlbld Tape'.
009480 02 FILLER PIC X(16) VALUE 'Tran File '.
009500 02 FILLER PIC X(16) VALUE 'Sixbit Disk- Seq'.
009520 02 FILLER PIC X(16) VALUE 'ASCII Disk- Seq'.
009540 02 FILLER PIC X(16) VALUE 'DBMS Schema '.
009560 02 FILLER PIC X(16) VALUE 'Sorted Disk '.
009580 02 FILLER PIC X(16) VALUE '?Illegal type'.
009600 02 FIllER PIC X(16) VALUE '?Illegal type'.
009620 02 FILLER PIC X(16) VALUE '?Illegal type'.
009640 01 FILE-TYPE REDEFINES FILE-TYPE-LIST DISPLAY-7.
009660 02 TYPE-LIST PIC X(16) OCCURS 12 TIMES.
009680
009700 01 FD-ERROR-MESSAGES DISPLAY-7.
009720 02 FD-MSG-0 PIC X(57) VALUE
009740 ' %Resulting FD entry may need correction'.
009760* 02 FD-MSG-1 PIC X(57) VALUE
009780* ' %Record len was too large- changed to system maximum'.
009800* 02 FD-MSG-2 PIC X(57) VALUE
009820* ' %Record len was too small- changed to system minimum'.
009840* 02 FD-MSG-3 PIC X(53) VALUE
009860* ' %Block fact for ISAM files must be > 0; set to 1'.
009880* 02 FD-MSG-4 PIC X(53) VALUE
009900* ' %Block fact was too small- changed to 1'.
009920 02 FD-MSG-5 PIC X(53) VALUE
009940 ' %File type was illegal- changed to 7 (ASCII disk)'.
009960 02 FD-MSG-6 PIC X(48) VALUE
009980 ' %No key position for ISAM file- changed to 1'.
010000 02 FD-MSG-7 PIC X(54) VALUE
010020 ' %Key position outside of ISAM record- changed to 1'.
010040 02 FD-MSG-8 PIC X(41) VALUE
010060 ' %No length for ISAM key- changed to 1'.
010080 02 FD-MSG-9 PIC X(53) VALUE
010100 ' %Length for ISAM key exceeded max- changed to max'.
010120* 02 FD-MSG-10 PIC X(57) VALUE
010140* ' %Block fact not multiple of rec len - set to 1'.
010160 02 FD-MSG-11.
010180 03 FILLER PIC XXX VALUE ' %'.
010200 03 FD-NO-NUM PIC X(12) VALUE SPACE.
010220 03 FILLER PIC X(31) VALUE
010240 'was not numeric- set to 0'.
010260 02 FD-MSG-12 PIC X(51) VALUE
010280 ' %Key data furnished for non-ISAM file - ignored'.
010300 02 FD-MSG-13 PIC X(54) VALUE
010320 ' %Illegal key type for ISAM file- set to alphabetic'.
010340 02 FD-MSG-14 PIC X(54) VALUE
010360 ' %Illegal key sign for ISAM file- set to unsigned'.
010380 02 FD-MSG-15 PIC X(43) VALUE
010400 ' %Dict name was blank- set to "BAD-NAME"'.
010420 02 FD-MSG-16 PIC X(56) VALUE
010440 ' %0 blocksize only valid for sequential disk files'.
010460
010480 01 DD-ERROR-MSGS DISPLAY-7.
010500 02 DD-MSG-0 PIC X(32) VALUE
010520 ' %DD transaction rejected'.
010540 02 DD-MSG-1 PIC X(28) VALUE
010560 ' %Action code was illegal'.
010580 02 DD-MSG-2 PIC X(35) VALUE
010600 ' %Item name started with X or ZZ'.
010620 02 DD-MSG-3 PIC X(27) VALUE
010640 ' %No first char location'.
010660* 02 DD-MSG-4 PIC X(41) VALUE
010680* ' %Item partly or all outside of record'.
010700 02 DD-MSG-5 PIC X(19) VALUE
010720 ' %No item length'.
010740* 02 DD-MSG-6 PIC X(37) VALUE
010760* ' %Item length too long - max is 354'.
010780 02 DD-MSG-7 PIC X(26) VALUE
010800 ' %Item type was illegal'.
010820 02 DD-MSG-8 PIC X(38) VALUE
010840 ' %Scale was larger than item length'.
010860 02 DD-MSG-9 PIC X(26) VALUE
010880 ' %Edit code was illegal'.
010900 02 DD-MSG-10 PIC X(35) VALUE
010920 ' %Had both edit code and picture'.
010940 02 DD-MSG-11 PIC X(45) VALUE
010960 ' %Warning- picture positions/item mismatch'.
010980 02 DD-MSG-12 PIC X(40) VALUE
011000 ' %Picture decimal did not match scale'.
011020 02 DD-MSG-13 PIC X(23) VALUE
011040 ' %No scan group name'.
011060 02 DD-MSG-14 PIC X(39) VALUE
011080 ' %Scan repeats ran outside of record'.
011100 02 DD-MSG-15 PIC X(20) VALUE
011120 ' %No scan repeats'.
011140 02 DD-MSG-16 PIC X(35) VALUE
011160 ' %No PD for referenced protection'.
011180 02 DD-MSG-17 PIC X(37) VALUE
011200 ' %Illegal value for prot excl flag'.
011220 02 DD-MSG-18.
011240 04 FILLER PIC XXX VALUE ' %'.
011260 04 DD-NO-NUM PIC X(30) VALUE SPACE.
011280 04 FILLER PIC X(17) VALUE
011300 'was not numeric'.
011320 02 DD-MSG-19 PIC X(24) VALUE
011340 ' %Name was all blanks'.
011360 02 DD-MSG-20 PIC X(42) VALUE
011380 ' %Length of member exceeds group length'.
011400 02 PD-MSG-0 PIC X(33) VALUE
011420 ' %PD transaction rejected'.
011440 02 PD-MSG-1 PIC X(35) VALUE
011460 ' %Protection no. was not numeric'.
011480 02 PD-MSG-2 PIC X(38) VALUE
011500 ' %Dict not unlocked for PW changes'.
011520
011540 01 HEAD-1 DISPLAY-7.
011560 02 FILLER PIC X(61) VALUE SPACE.
011580 02 H1 PIC X(13) VALUE SPACE.
011600 01 HEAD-2 DISPLAY-7.
011620 02 H2 PIC X(7) VALUE ' Date: '.
011640 02 DATEX PIC X(8).
011660 02 FILLER PIC X(41) VALUE SPACE.
011680 02 H3 PIC X(22) VALUE
011700 'IQL Dictionary Listing'.
011720 02 FILLER PIC X(43) VALUE SPACE.
011740 02 H4 PIC X(6) VALUE 'Page: '.
011760 02 PAGE-OUT PIC ZZ9.
011780 01 HEAD-3 DISPLAY-7.
011800 02 FILLER PIC X(56) VALUE SPACE.
011820 02 H5 PIC X(22) VALUE
011840 '--- ---------- -------'.
011860 01 HEAD-4 DISPLAY-7.
011880 02 H6 PIC X(18) VALUE
011900 'File Definition- '.
011920 01 HEAD-5 DISPLAY-7.
011940 02 J5 PIC X(24) VALUE
011960 'Data Item Definitions -'.
011980 01 FD-HEAD-1 DISPLAY-7.
012000 02 FILLER PIC X(44) VALUE
012020 ' '.
012040 02 FILLER PIC X(44) VALUE
012060 ' Re'.
012080 02 FILLER PIC X(44) VALUE
012100 'c Blk Key Key K K RD CP WR Last '.
012120 01 FD-HEAD-2 DISPLAY-7.
012140 02 FILLER PIC X(44) VALUE
012160 'Dictionary Name File in Name '.
012180 02 FILLER PIC X(44) VALUE
012200 ' Directory File type Lt'.
012220 02 FILLER PIC X(44) VALUE
012240 'h Fac Loc Lth T S PT PT PT Updated '.
012260 01 FD-HYPHS DISPLAY-7.
012280 02 FILLER PIC X(44) VALUE
012300 '-------------- ------------ '.
012320 02 FILLER PIC X(44) VALUE
012340 ' --------- --------- --'.
012360 02 FILLER PIC X(44) VALUE
012380 '-- ---- ---- --- - - -- -- -- ------- '.
012400 01 DD-HEAD1 DISPLAY-7.
012420 02 FILLER PIC X(47) VALUE
012440 ' Top Bo'.
012460 02 FILLER PIC X(44) VALUE
012480 'ttom S NT Edit Ed Print'.
012500 02 FILLER PIC X(41) VALUE
012520 'ing Grp Scan Last '.
012540 01 DD-HEAD-2 DISPLAY-7.
012560 02 FILLER PIC X(47) VALUE
012580 'ID Item name Title Ti'.
012600 02 FILLER PIC X(44) VALUE
012620 'tle Type Loc Lth C Ch Lth Cd Pictu'.
012640 02 FILLER PIC X(41) VALUE
012660 're Len G-NN-S Prot Updated'.
012680 01 DD-HYPHS DISPLAY-7.
012700 02 FILLER PIC X(47) VALUE
012720 '-- --------- ----- --'.
012740 02 FILLER PIC X(44) VALUE
012760 '--- ---- ---- ---- - -- ---- -- -----'.
012780 02 FILLER PIC X(41) VALUE
012800 '--- --- - -- - ---- ------- '.
012820
012840**DISPLAY(PRINT) LAYOUTS FOR VARIOUS ENTRIES FOLLOW**.
012860
012880 01 FD-DATA DISPLAY-7.
012900 02 FIL-NM-PRT PIC X(30).
012920 02 FILLER PIC X.
012940 02 IN-LAB-PRT PIC X(17).
012960 02 FILLER PIC X.
012980 02 DIRECT-PRT PIC X(19).
013000 02 FILLER PIC X.
013020 02 FIL-TYP-PRT.
013040 04 FILLER PIC X(12).
013060 04 FIL-ORG-PRT PIC X(4).
013080 02 FILLER PIC X.
013100 02 RECZ-PRT PIC ZZZ9.
013120 02 FILLER PIC X.
013140 02 BLKF-PRT PIC ZZZ9.
013160 02 FILLER PIC X.
013180 02 KEY-POS-PRT PIC ZZZ9.
013200 02 FILLER PIC X.
013220 02 KEY-LEN-PRT PIC ZZ9.
013240 02 FILLER PIC X.
013260 02 KEY-TYP-PRT PIC X.
013280 02 FILLER PIC X.
013300 02 KEY-SIGN-PRT PIC X.
013320 02 FILLER PIC X.
013340 02 FD-PD-READ PIC XX.
013360 02 FILLER PIC X.
013380 02 FD-PD-COPY PIC XX.
013400 02 FILLER PIC X.
013420 02 FD-PD-REWR PIC XX.
013440 02 FILLER PIC X(6).
013460 02 FD-UPDATE-PRT PIC X(8).
013480
013500 01 DD-DATA REDEFINES FD-DATA DISPLAY-7.
013520 02 DD-DATA-IDNT PIC XXX.
013540 02 DD-NAME-PRT PIC X(30).
013560 02 FILLER PIC X.
013580 02 DD-TITLE1-PRT PIC X(10).
013600 02 FILLER PIC X.
013620 02 DD-TITLE2-PRT PIC X(10).
013640 02 FILLER PIC X.
013660 02 DD-TYPE-PRT PIC X(6).
013680 02 FILLER PIC X.
013700 02 DD-FCHAR-PRT PIC ZZZZ.
013720 02 DD-FCHAR-PRT-DBS REDEFINES DD-FCHAR-PRT PIC XXXX.
013740 02 FILLER PIC X.
013760 02 NCHAR-PRT PIC ZZZZ.
013780 02 FILLER PIC X.
013800 02 SCL-PRT PIC Z.
013820 02 FILLER PIC X.
013840 02 NTCHAR-PRT PIC ZZ.
013860 02 NOUPD-PRT PIC X.
013880 02 NECHAR-PRT PIC ZZZZ.
013900 02 FILLER PIC X.
013920 02 DD-EDIT-PRT PIC ZZ.
013940 02 FILLER PIC X.
013960 02 PICT-PRT PIC X(19).
013980 02 FILLER PIC X.
014000 02 GRPLEN-PRT PIC ZZZ.
014020 02 FILLER PIC X.
014040 02 SCAN-PRT.
014060 03 GRPNME-PRT PIC X.
014080 03 DD-SCAN-DASH1 PIC X.
014100 03 NREPEATS-PRT PIC XX.
014120 03 DD-SCAN-DASH2 PIC X.
014140 03 STOPPER-PRT PIC X.
014160 02 FILLER PIC X.
014180 02 PROT-PRT.
014200 03 DP-PRT PIC XX.
014220 03 DP-PROT-DASH PIC X.
014240 03 DD-EXCLFLAG-PRT PIC X.
014260 02 FILLER PIC X(2).
014280 02 DD-UPDATE-PRT PIC X(8).
014300
014320 01 CD-DATA REDEFINES FD-DATA DISPLAY-7.
014340 02 CD-DATA-IDNT PIC XXX.
014360 02 FILLER PIC X.
014380 02 DC-NO-PRT PIC XX.
014400 02 FILLER PIC X.
014420 02 DC-TEXT-PRT PIC X(75).
014440 02 FILLER PIC X(41).
014460 02 DC-UPDATE-PRT PIC X(8).
014480
014500 01 RD-DATA REDEFINES FD-DATA DISPLAY-7.
014520 02 RD-DATA-IDNT PIC XXX.
014540 02 RD-DATA-NAME PIC X(31).
014560 02 RD-DATA-TEXT PIC X(28).
014580 02 FILLER PIC X.
014600 02 RD-DATA-ORIGIN PIC ZZZ9.
014620 02 FILLER PIC X.
014640 02 RD-DATA-LENGTH PIC ZZZ9.
014660 02 FILLER PIC XX.
014680 02 RD-DATA-TYPE PIC XXX.
014700 02 FILLER PIC X(46).
014720 02 RD-DATA-UPDATE PIC X(8).
014740
014760 01 PD-DATA REDEFINES FD-DATA DISPLAY-7.
014780 02 PD-DATA-IDNT PIC XXX.
014800 02 DP-TEXT-PRINT PIC X(12).
014820 02 FILLER PIC X(19).
014840 02 DP-PROT-NO-PRINT PIC XX.
014860 02 FILLER PIC X(87).
014880 02 DP-UPDATE-PRINT PIC X(8).
014900
014904 01 SIXBIT-SPACES DISPLAY-6 PIC X(90) VALUE SPACES.
014908 01 ASCII-NULLS REDEFINES SIXBIT-SPACES DISPLAY-7.
014912 02 ASCII-NULL PIC X.
014916 02 FILLER PIC X(74).
014920
014924 01 CONSOLE-LINE DISPLAY-7.
014924 02 CONSOLE-CHAR PIC X OCCURS 72.
014930
014940 PROCEDURE DIVISION.
014960
014980*******************************************************
015000* BEGIN PROCESSING
015020*******************************************************
015040 STARTDG.
015060 ENTER MACRO CLRTTY.
015080 ENTER MACRO IQGJOB USING JOB-NO.
015100 MOVE JOB-NO TO QC001DNO QT001DNO QL001DNO.
015120 PERFORM OPEN-PRINT-FILE.
015140 OPEN OUTPUT QTDICT.
015160 CLOSE QTDICT.
015180 MOVE SPACES TO DEVICER.
015200 MOVE 0 TO USER PROJ I.
015220* *BE SURE THERE ARE TRANSACTIONS TO PROCESS*
015240 ENTER MACRO IQLOOK USING DEVICER QC001DTMP
015260 PROJ USER I.
015280 IF I NOT = -1
015300 MOVE ' %No dictionary transaction input found'
015320 TO PRINT-LINE
015340 PERFORM DISPLAYER THRU DISPLAYER-EXIT
015360 PERFORM PRINT2
015380 PERFORM CLOSE-ALL-FILES
015400 GO TO STOPPER1.
015420* *IF THERE IS NO QPDICT IN DIRECTORY, MAKE ONE*
015440 ENTER MACRO IQLOOK USING DEVICER QPDICTSEQ
015460 PROJ USER I.
015480 IF I NOT = -1
015500 OPEN OUTPUT QPDICT
015520 MOVE 'CD00BEGINNING ENTRY' TO DICT-REC
015540 WRITE DICT-REC
015560 CLOSE QPDICT.
015580 MOVE 0 TO DICT-EOF.
015600 PERFORM OPEN-TRAN-FILE.
015620 MOVE TODAY TO DATE-CONV.
015640 MOVE YR-IN TO YEAR.
015660 MOVE MO-IN TO MON.
015680 MOVE DA-IN TO DAYY.
015700 MOVE DATE-MASK TO DATEX.
015720 MOVE MON TO PMON.
015740 MOVE DAYY TO PDAY.
015760 MOVE YEAR TO PYEAR.
015780 MOVE 0 TO RETURN-FLAG.
015800 START-TRANS-IN.
015820 READ QCDICT INTO TRAN-WS AT END
015840 PERFORM NEW-PAGE
015860 MOVE ' %Dictionary transaction input was empty'
015880 TO PRINT-LINE
015900 PERFORM DISPLAYER THRU DISPLAYER-EXIT
015920 PERFORM PRINT2
015940 GO TO DICT-RUN-DONE.
015960 MOVE TRAN-WS TO HOLD-TRAN.
015980 IF CF-IDNT = 'FD' MOVE 1 TO FOUND-FD-TRAN
016000 GO TO CENTRAL-DICT-CONTROL.
016020 PERFORM NEW-PAGE.
016040 PERFORM PRINT-TRAN.
016060 MOVE ' %First transaction above was not FD - ignored'
016080 TO PRINT-LINE.
016100 PERFORM PRINT1B.
016120 PERFORM DISPLAYER THRU DISPLAYER-EXIT.
016140 ADD 1 TO LINE-CTR.
016160 GO TO START-TRANS-IN.
016180
016200*****************************
016220* THIS IS CENTRAL LOGIC OF ENTIRE PROGRAM.
016240* CONTROL GOES HERE WHENEVER JUST READ FD TRAN.
016260*****************************
016280 CENTRAL-DICT-CONTROL.
016300 IF FOUND-FD-TRAN NOT = 1 GO TO DICT-RUN-DONE.
016320 MOVE TRAN-FD TO HOLD-TRAN-FD.
016340 MOVE 0 TO N-SCANITEMS.
016360 MOVE CF-NAME TO CURRENT-CF-NAME LAST-DD-NAME.
016380 MOVE 0 TO FOUND-FD-TRAN DICT-LOCK
016384 UNLOCKED-LEVEL PROTECTED-LEVEL
016386 COPY-LEVEL.
016400 PERFORM NEW-PAGE.
016420 IF CF-ACT = 'P' PERFORM DICT-PRINTER
016440 THROUGH DICT-PRINTER-EXIT
016460 GO TO CENTRAL-DICT-CONTROL.
016480 MOVE CF-NAME TO CURRENT-FILENAME.
016500 IF CF-ACT = 'S' PERFORM DICT-STARTER
016520 THROUGH DICT-STARTER-EXIT
016540 GO TO CENTRAL-DICT-CONTROL.
016560 IF CF-ACT = 'A' PERFORM DICT-ADDER
016580 THROUGH DICT-ADDER-EXIT
016600 GO TO CENTRAL-DICT-CONTROL.
016620 IF CF-ACT = 'D' PERFORM DICT-DELETER
016640 THROUGH DICT-DELETER-EXIT
016660 GO TO CENTRAL-DICT-CONTROL.
016680 IF CF-ACT = 'R' PERFORM DICT-REPLACER
016700 THROUGH DICT-REPLACER-EXIT
016720 GO TO CENTRAL-DICT-CONTROL.
016740 IF CF-ACT = 'C' PERFORM DICT-CHANGER
016760 THROUGH DICT-CHANGER-EXIT
016780 GO TO CENTRAL-DICT-CONTROL.
016800 IF CF-ACT = 'N' PERFORM DICT-NAMES THROUGH DICT-NAMES-EXIT
016820 GO TO CENTRAL-DICT-CONTROL1.
016840 PERFORM PRINT-TRAN.
016860 MOVE ' %Action code in above FD tran is in error -'
016880 TO PRINT-LINE. PERFORM PRINT1D.
016900 MOVE ' following DD CD or PD trans ignored'
016920 TO PRINT-LINE. PERFORM DISPLAYER THRU DISPLAYER-EXIT.
016940 PERFORM PRINT1B.
016960 CENTRAL-DICT-CONTROL1.
016980 PERFORM FIND-FD-TRAN THROUGH FIND-FD-TRAN-EXIT.
017000 IF FOUND-FD-TRAN = 1 GO TO CENTRAL-DICT-CONTROL.
017020 DICT-RUN-DONE.
017040 MOVE ' ' TO PRINT-LINE.
017060 PERFORM PRINT1.
017080 MOVE ' (End of dictionary run)' TO PRINT-LINE.
017100 PERFORM DISPLAYER THRU DISPLAYER-EXIT.
017120 PERFORM PRINT0.
017140 MOVE ' ' TO PRINT-LINE.
017160 PERFORM PRINT1B.
017180 PERFORM CLOSE-ALL-FILES.
017200 STOPPER.
017220 OPEN INPUT QTDICT.
017240 CLOSE QTDICT WITH DELETE.
017260 STOPPER1.
017280 MOVE 'IQL ' TO CALLED-NAME.
017300 ENTER MACRO IQNEXT USING CALLED-NAME.
017320
017340*****************************
017360* SUBROUTINES WHICH FOLLOW CONTROL MASTER EXECUTION OF ACTIONS
017380* IN FD TRANS INPUT FROM TRAN IMAGE FILE. THEY DRAW IN TURN
017400* UPON THE SUBROUTINES IN THE SUBSEQUENT SECTION.
017420*****************************
017440
017460*****************************
017480* SUBROUTINE TO PRINT OUT ALL OR SELECTED DICTS ON 'P' OPTION
017500* IF THE FD TRAN CONTAINS A NAME ONLY THIS DICTIONARY WILL BE PRI
017520* IF THE TRAN NAME IS SPACE ALL DICTIONARIES WILL BE PRINTED.
017540*****************************
017560 DICT-PRINTER.
017580 PERFORM DICT-FINDER THROUGH DICT-FINDER-EXIT.
017600 IF FOUND-DICT NOT = 1 GO TO DICT-PRINTER-ERROR.
017620 DICT-PRINTER-FD.
017640 IF CF-PASSWORD = UNIVERSAL-PASSWORD
017650 MOVE 99 TO UNLOCKED-LEVEL ELSE
017654 PERFORM DICT-UNLOCKER THRU DICT-UNLOCKER-EXIT
017658 PERFORM DICT-FINDER THRU DICT-FINDER-EXIT.
017700 PERFORM PRINT-FD-HEAD.
017720 PERFORM PRINT-FD-FIELDS THRU PRINT-FD-FIELDS-EXIT.
017740 MOVE 0 TO FOUND-NON-FD-FLAG.
017760 DICT-PRINTER-READ.
017780 READ QPDICT INTO DICT-WS AT END
017800 GO TO DICT-PRINTER-DONE.
017820 IF DF-IDNT NOT = 'FD'
017840 AND FOUND-NON-FD-FLAG NOT = 1
017860 MOVE 1 TO FOUND-NON-FD-FLAG
017880 PERFORM PRINT-DD-HEAD.
017900 IF DF-IDNT = 'DD' OR 'KD' PERFORM PRINT-DD-FIELDS
017920 GO TO DICT-PRINTER-READ.
017940 IF DF-IDNT NOT = 'PD' GO TO DICT-PRINTER-READ1.
017960 MOVE DP-TEXT TO PW-TEXT-HOLDER.
017980 PERFORM UNSCRAMBLE-PW THRU UNSCRAMBLE-PW-EXIT.
018060 MOVE PW-TEXT-HOLDER TO DP-TEXT.
018080 PERFORM PRINT-PD-FIELDS.
018100 GO TO DICT-PRINTER-READ.
018120 DICT-PRINTER-READ1.
018140 IF DF-IDNT = 'RD' OR 'AD' OR 'SD'
018160 PERFORM PRINT-RD-FIELDS THRU PRINT-RD-FIELDS-EXIT
018180 GO TO DICT-PRINTER-READ.
018200 IF DF-IDNT = 'CD' PERFORM PRINT-CD-FIELDS
018220 GO TO DICT-PRINTER-READ.
018240 IF DF-IDNT NOT = 'FD' MOVE DICT-WS TO PRINT-LINE
018260 PERFORM PRINT1 GO TO DICT-PRINTER-READ.
018280 MOVE DF-NAME TO CURRENT-DF-NAME.
018300 IF FOUND-NON-FD-FLAG NOT = 1
018320 PERFORM PRINT-FD-FIELDS THRU PRINT-FD-FIELDS-EXIT
018340 GO TO DICT-PRINTER-READ.
018360 IF CF-NAME = SPACE
018380 PERFORM NEW-PAGE
018400 GO TO DICT-PRINTER-FD.
018420 GO TO DICT-PRINTER-DONE.
018440 DICT-PRINTER-ERROR.
018460 PERFORM PRINT-TRAN.
018480 MOVE ' %Cannot find dictionary for name specified above'
018500 TO PRINT-LINE. PERFORM DISPLAYER THRU DISPLAYER-EXIT.
018520 PERFORM PRINT1.
018540 DICT-PRINTER-DONE.
018560 PERFORM CLOSE-DICT-WORK.
018580 PERFORM FIND-FD-TRAN THROUGH FIND-FD-TRAN-EXIT.
018600 MOVE 0 TO DICT-LOCK.
018620 DICT-PRINTER-EXIT.
018640 EXIT.
018660
018680********************
018700* SUBROUTINE TO PRINT OUT DICTIONARY NAMES ON N ACTION CODE.
018720********************
018740 DICT-NAMES.
018760 PERFORM OPEN-IN-DICT-OUT-WORK.
018780 DICT-NAMES-1.
018800 PERFORM NEW-PAGE.
018820 PERFORM PRINT-FD-HEAD.
018840 DICT-NAMES-2.
018860 READ QPDICT INTO DICT-WS AT END
018880 PERFORM CLOSE-DICT-WORK GO TO DICT-NAMES-EXIT.
018900 IF DF-IDNT = 'FD' PERFORM PRINT-FD-FIELDS
018920 THRU PRINT-FD-FIELDS-EXIT
018940 ADD 1 TO LINE-CTR.
018960 IF LINE-CTR LESS THAN LINE-MAX GO TO DICT-NAMES-2.
018980 GO TO DICT-NAMES-1.
019000 DICT-NAMES-EXIT.
019020 EXIT.
019040
019060*****************************
019080* SUBROUTINE TO START A NEW DICTIONARY FILE. IT DOES THIS BY
019100* PLANTING AN END OF FILE AT THE BEGINNING OF THE DICTIONARY FILE
019120* AND THEN ADDING THE NEW DICTIONARY AS USUAL.
019140*****************************
019160 DICT-STARTER.
019180 PERFORM CLOSE-DICT-WORK.
019200 PERFORM OPEN-OUT-DICT.
019220 PERFORM CLOSE-DICT-WORK.
019240 PERFORM DICT-ADDER THROUGH DICT-ADDER-EXIT.
019260 DICT-STARTER-EXIT.
019280 EXIT.
019300
019320*****************************
019340* SUBROUTINE TO ADD A NEW DICTIONARY TO THE FILE. IT CALLS
019360* SUBROUTINE NEW-DICT TO DO MOST OF ITS WORK. DICT-ADDER IS
019380* CALLED BY DICT-STARTER.
019400*****************************
019420 DICT-ADDER.
019440 PERFORM DICT-FINDER THROUGH DICT-FINDER-EXIT.
019460 IF FOUND-DICT = 1 GO TO DICT-ADDER-ERROR.
019480 PERFORM NEW-DICT THROUGH NEW-DICT-EXIT.
019500 PERFORM WORK-COPY THROUGH WORK-COPY-EXIT.
019520 GO TO DICT-ADDER-EXIT.
019540 DICT-ADDER-ERROR.
019560 PERFORM CLOSE-DICT-WORK.
019580 PERFORM PRINT-TRAN.
019600 MOVE ' %A dictionary already exists for the name '
019620 TO PRINT-LINE.
019640 PERFORM DISPLAYER THRU DISPLAYER-EXIT.
019660 PERFORM PRINT1.
019680 MOVE ' above. Change name in tran or action to D or R'
019700 TO PRINT-LINE. PERFORM DISPLAYER THRU DISPLAYER-EXIT.
019720 PERFORM PRINT1B.
019740 PERFORM FIND-FD-TRAN THROUGH FIND-FD-TRAN-EXIT.
019760 DICT-ADDER-EXIT.
019780 EXIT.
019800
019820*****************************
019840* SUBROUTINE TO DELETE A DICTIONARY FROM FILE
019860*****************************
019880 DICT-DELETER.
019900 PERFORM DICT-FINDER THROUGH DICT-FINDER-EXIT.
019920 PERFORM PRINT-FD-HEAD.
019940 IF FOUND-DICT NOT = 1 GO TO DICT-DELETER-ERROR.
019960 IF DF-PROT-READ = ' ' OR '00' GO TO DICT-DELETER2.
019980 IF CF-PASSWORD = UNIVERSAL-PASSWORD
019984 MOVE 99 TO UNLOCKED-LEVEL
020000 GO TO DICT-DELETER2.
020004 PERFORM DICT-UNLOCKER THRU DICT-UNLOCKER-EXIT.
020008* *TO DELETE A DICT MUST UNLOCK AT HIGHEST PD LEVEL*
020012 IF DICT-LOCK = 0
020016 PERFORM DICT-FINDER THRU DICT-FINDER-EXIT
020018 GO TO DICT-DELETER2.
020020 PERFORM PRINT-TRAN.
020040 MOVE ' %Dictionary not unlocked to be deleted'
020060 TO PRINT-LINE.
020080 GO TO DICT-DELETER-ERROR1.
020100 DICT-DELETER2.
020120 PERFORM PRINT-FD-FIELDS THRU PRINT-FD-FIELDS-EXIT.
020140 PERFORM DICT-PASS THROUGH DICT-PASS-EXIT.
020160 PERFORM DICT-COPY THRU DICT-COPY-EXIT.
020180 PERFORM WORK-COPY THROUGH WORK-COPY-EXIT.
020200 MOVE ' (Dictionary correctly deleted)' TO PRINT-LINE.
020220 GO TO DICT-DELETER-DONE.
020240 DICT-DELETER-ERROR.
020260 PERFORM PRINT-TRAN.
020280 MOVE ' %No dictionary found under above name'
020300 TO PRINT-LINE.
020320 DICT-DELETER-ERROR1.
020340 PERFORM DISPLAYER THRU DISPLAYER-EXIT.
020360 PERFORM CLOSE-DICT-WORK.
020380 DICT-DELETER-DONE.
020400 PERFORM PRINT1B.
020420 PERFORM FIND-FD-TRAN THROUGH FIND-FD-TRAN-EXIT.
020440 DICT-DELETER-EXIT.
020460 EXIT.
020480
020500*****************************
020520* SUBROUTINE TO REPLACE A DICTIONARY IN DICTIONARY FILE.
020540*****************************
020560 DICT-REPLACER.
020580 PERFORM DICT-FINDER THROUGH DICT-FINDER-EXIT.
020600 IF FOUND-DICT NOT = 1 GO TO DICT-REPLACER-ERROR.
020620 IF DF-PROT-READ = ' ' OR '00' GO TO DICT-REPLACER1.
020640 IF CF-PASSWORD = UNIVERSAL-PASSWORD
020650 MOVE 99 TO UNLOCKED-LEVEL
020660 GO TO DICT-REPLACER1.
020664 PERFORM DICT-UNLOCKER THRU DICT-UNLOCKER-EXIT.
020666* *TO REPLACE A DICT MUST UNLOCK AT HIGHEST PD LEVEL*
020668 IF DICT-LOCK = 0
020670 PERFORM DICT-FINDER THRU DICT-FINDER-EXIT
020672 GO TO DICT-REPLACER1.
020680 PERFORM PRINT-TRAN.
020700 MOVE ' %Dictionary not unlocked to be replaced'
020720 TO PRINT-LINE.
020740 GO TO DICT-REPLACER-ERROR1.
020760* * COPY OUT ANY ALTERNATE FD ENTRIES * *
020780 DICT-REPLACER1.
020800 READ QPDICT INTO DICT-WS AT END
020820 MOVE 1 TO DICT-EOF
020840 GO TO DICT-REPLACER2.
020860 IF DF-IDNT NOT = 'FD' GO TO DICT-REPLACER2.
020880 WRITE WORK-REC FROM DICT-WS.
020900 GO TO DICT-REPLACER1.
020920 DICT-REPLACER2.
020940 MOVE 0 TO IGNORE-RECORD-FLAG.
020960 PERFORM NEW-DICT THROUGH NEW-DICT-EXIT.
020980 PERFORM DICT-PASS THROUGH DICT-PASS-EXIT.
021000 PERFORM DICT-COPY THROUGH DICT-COPY-EXIT.
021020 PERFORM WORK-COPY THROUGH WORK-COPY-EXIT.
021040 GO TO DICT-REPLACER-EXIT.
021060 DICT-REPLACER-ERROR.
021080 PERFORM PRINT-TRAN.
021100 MOVE ' %No dictionary found to replace under above name'
021120 TO PRINT-LINE.
021140 DICT-REPLACER-ERROR1.
021160 PERFORM CLOSE-DICT-WORK.
021180 PERFORM DISPLAYER THRU DISPLAYER-EXIT.
021200 PERFORM PRINT1B.
021220 PERFORM FIND-FD-TRAN THROUGH FIND-FD-TRAN-EXIT.
021240 DICT-REPLACER-EXIT.
021260 EXIT.
021280
021300****************************************************
021320* SUBROUTINE TO PROCESS CHANGES TO AN EXISTING DICTIONARY
021340* INCLUDING FD PD RD AD SD CD AND DD CHANGES. IN EACH
021360* NON-BLANK FIELDS IN THE INPUT TRANS
021380* REPLACE THOSE FIELDS IN THE DICTIONARY; ALL OTHER FIELDS
021400* REMAIN AS ORIGINALLY CONTAINED. ALPHA FIELDS CONTAINING
021420* ALL '*' IN THE INPUT ARE SET TO BLANKS IN THE
021440* DICTIONARY. THE COMPOSITE TRAN IMAGE IS PROCESSED THROUGH
021460* ALL NORMAL EDITS AND CHECKS INTO THE DICTIONARY.
021480******************************************************
021500 DICT-CHANGER.
021520 PERFORM DICT-FINDER THROUGH DICT-FINDER-EXIT.
021540 IF FOUND-DICT = 1 GO TO DICT-CHANGER-FD.
021560 PERFORM CLOSE-DICT-WORK.
021580 PERFORM PRINT-TRAN.
021600 MOVE ' %No dictionary found to change under above name'
021620 TO PRINT-LINE. PERFORM DISPLAYER THRU DISPLAYER-EXIT.
021640 PERFORM PRINT1B.
021660 PERFORM FIND-FD-TRAN THRU FIND-FD-TRAN-EXIT.
021680 GO TO DICT-CHANGER-EXIT.
021700
021720* *PROCESS FD CHANGES* *
021740 DICT-CHANGER-FD.
021740 IF CF-PASSWORD = UNIVERSAL-PASSWORD
021760 MOVE 99 TO UNLOCKED-LEVEL
021780 GO TO DICT-CHANGER-FD1A.
021800 PERFORM DICT-UNLOCKER THRU DICT-UNLOCKER-EXIT.
021802* *TO CHANGE DICT MUST UNLOCK AT HIGHEST LEVEL
021820 IF DICT-LOCK = 1 GO TO DICT-CHANGER-FD-LOCK.
021840 PERFORM DICT-FINDER THRU DICT-FINDER-EXIT.
021860 GO TO DICT-CHANGER-FD1A.
021960 DICT-CHANGER-FD-LOCK.
021980 PERFORM PRINT-TRAN.
022000 MOVE ' %Dictionary not unlocked for update'
022020 TO PRINT-LINE.
022040 PERFORM DISPLAYER THRU DISPLAYER-EXIT.
022060 PERFORM PRINT1B.
022080 PERFORM FIND-FD-TRAN THRU FIND-FD-TRAN-EXIT.
022100 PERFORM CLOSE-DICT-WORK.
022120 GO TO DICT-CHANGER-EXIT.
022140 DICT-CHANGER-FD1A.
022160 IF CF-INLABEL = SPACE MOVE DF-INLABEL TO CF-INLABEL.
022180 IF CF-INLABEL = ALL '*'
022200 MOVE SPACE TO CF-INLABEL.
022220 IF CF-DIRECT = SPACE MOVE DF-DIRECT TO CF-DIRECT.
022240 IF CF-DIRECT = ALL '*'
022260 MOVE SPACE TO CF-DIRECT.
022280 IF CF-FILETYPE-X = SPACE MOVE DF-FILETYPE TO CF-FILETYPE.
022300 IF CF-RECLEN-X = SPACE MOVE DF-RECLEN TO CF-RECLEN.
022320 IF CF-BLKFACT-X = SPACE MOVE DF-BLKFACT TO CF-BLKFACT.
022340 IF CF-BLKFACT-X = ALL '*' MOVE SPACES TO CF-BLKFACT.
022360 IF CF-KEYPOS-X = SPACE MOVE DF-KEYPOS TO CF-KEYPOS.
022380 IF CF-KEYPOS-X = ALL '*' MOVE SPACES TO CF-KEYPOS-X.
022400 IF CF-KEYLEN-X = SPACE MOVE DF-KEYLEN TO CF-KEYLEN.
022420 IF CF-KEYLEN-X = ALL '*' MOVE SPACES TO CF-KEYLEN-X.
022440 IF CF-KEYTYPE-X = SPACE MOVE DF-KEYTYPE TO CF-KEYTYPE.
022460 IF CF-KEYTYPE-X = ALL '*' MOVE SPACES TO CF-KEYTYPE-X.
022480 IF CF-KEYSIGN = SPACE MOVE DF-KEYSIGN TO CF-KEYSIGN.
022500 IF CF-KEYSIGN = ALL '*' MOVE SPACES TO CF-KEYSIGN.
022520 IF CF-PROT-READ = SPACE MOVE DF-PROT-READ TO CF-PROT-READ.
022540 IF CF-PROT-COPY = SPACE MOVE DF-PROT-COPY TO CF-PROT-COPY.
022560 IF CF-PROT-REWR = SPACE MOVE DF-PROT-REWR TO CF-PROT-REWR.
022580 IF CF-PROT-READ = '**' MOVE SPACE TO CF-PROT-READ.
022600 IF CF-PROT-COPY = '**' MOVE SPACE TO CF-PROT-COPY.
022620 IF CF-PROT-REWR = '**' MOVE SPACE TO CF-PROT-REWR.
022640 PERFORM PRINT-FD-HEAD.
022660 PERFORM EDIT-FD-FIELDS.
022680 PERFORM CHECK-FD-FIELDS THRU CHECK-FD-FIELDS-EXIT.
022700 PERFORM MOVE-FD-FIELDS.
022720 PERFORM PRINT-FD-FIELDS THRU PRINT-FD-FIELDS-EXIT.
022740 MOVE 0 TO IGNORE-RECORD-FLAG.
022760 PERFORM PRINT-DD-HEAD.
022780* * KEEP CHANGED FD ENTRY AND COPY ALT FD'S * *
022800 DICT-CHANGER-FD1.
022820 WRITE WORK-REC FROM DICT-WS.
022840 IF HOLD-TRAN-FLAG = 1 MOVE HOLD-TRAN TO TRAN-WS
022860 MOVE 1 TO IGNORE-RECORD-FLAG
022880 MOVE 0 TO HOLD-TRAN-FLAG
022900 GO TO DICT-CHANGER-DETAIL1.
022920 READ QPDICT INTO DICT-WS AT END
022940 PERFORM CLOSE-DICT-WORK
022960 GO TO DICT-CHANGER-FD2.
022980 IF DF-IDNT = 'FD' GO TO DICT-CHANGER-FD1.
023000 DICT-CHANGER-FD2.
023020 MOVE 1 TO 1ST-NTRY-FLAG.
023040 DICT-CHANGER-DETAIL.
023060 READ QCDICT INTO TRAN-WS AT END
023080 MOVE 0 TO FOUND-FD-TRAN GO TO DICT-CHANGER-DONE.
023100 MOVE TRAN-WS TO HOLD-TRAN.
023120 DICT-CHANGER-DETAIL1.
023140 IF CF-IDNT = 'FD' MOVE 1 TO FOUND-FD-TRAN
023160 MOVE CF-NAME TO CURRENT-CF-NAME
023180 GO TO DICT-CHANGER-DONE.
023200 IF CD-IDNT = 'DD' OR 'KD' GO TO DICT-CHANGER-DD.
023220 IF CD-IDNT = 'CD' GO TO DICT-CHANGER-CD.
023240 IF CD-IDNT = 'PD' GO TO DICT-CHANGER-PD.
023260 IF CD-IDNT = 'RD' OR 'AD' OR 'SD' GO TO DICT-CHANGER-RD.
023280 GO TO DICT-CHANGER-ERROR.
023300
023320* *COMPLAIN ABOUT ANY ERRORS* *
023340 DICT-CHANGER-ERROR.
023360 PERFORM PRINT-TRAN.
023380 MOVE ' %Tran type or action code above illegal- ignored'
023400 TO PRINT-LINE.
023420 PERFORM DISPLAYER THRU DISPLAYER-EXIT.
023440 PERFORM PRINT1B.
023460 GO TO DICT-CHANGER-DETAIL.
023480
023500* *PROCESS RD, AD, OR SD ENTRY* *
023520* *(WHICH ARE ALL SAME FORMAT)* *
023540 DICT-CHANGER-RD.
023560 IF RD-ACT = 'A' OR ' ' GO TO DICT-CHANGER-RD-ADD.
023580 IF RD-ACT = 'D' GO TO DICT-CHANGER-RD-DEL.
023600 IF RD-ACT = 'C' GO TO DICT-CHANGER-RD-CHG.
023620 GO TO DICT-CHANGER-ERROR.
023640 DICT-CHANGER-RD-DEL.
023660 PERFORM FIND-ENTRY THRU FIND-ENTRY-EXIT.
023680 IF FOUND-ENTRY NOT = 1 GO TO DICT-CHANGER-MISSED-CMN.
023700 PERFORM PRINT-RD-FIELDS THRU PRINT-RD-FIELDS-EXIT.
023720 GO TO DICT-CHANGER-DEL-CMN.
023740 DICT-CHANGER-RD-ADD.
023760 PERFORM DICT-CHG-WRITE1.
023780 GO TO DICT-CHANGER-RD-CHG1.
023800 DICT-CHANGER-RD-CHG.
023820 PERFORM FIND-ENTRY THRU FIND-ENTRY-EXIT.
023840 IF FOUND-ENTRY NOT = 1 GO TO DICT-CHANGER-MISSED-CMN.
023860 IF RD-ORIGIN-X = SPACE MOVE DR-ORIGIN TO RD-ORIGIN.
023880 IF RD-ORIGIN-X = ALL '*' MOVE SPACE TO RD-ORIGIN.
023900 IF RD-LENGTH-X = SPACE MOVE DR-LENGTH TO RD-LENGTH.
023920 IF RD-LENGTH-X = ALL '*' MOVE SPACE TO RD-LENGTH-X.
023940 IF RD-TYPE = SPACE MOVE DR-TYPE TO RD-TYPE.
023960 IF RD-TYPE = ALL '*' MOVE SPACE TO RD-TYPE.
023980 IF RD-TEXT = SPACE MOVE DR-TEXT TO RD-TEXT.
024000 IF RD-TEXT = ALL '*' MOVE SPACE TO RD-TEXT.
024020 DICT-CHANGER-RD-CHG1.
024040 PERFORM EDIT-RD-FIELDS THRU EDIT-RD-FIELDS-EXIT.
024060 PERFORM CHECK-RD-FIELDS THRU CHECK-RD-FIELDS-EXIT.
024080 IF TRAN-ERR-FLG NOT = 1 GO TO DICT-CHANGER-RD-CHG2.
024100 IF RD-ACT = 'A' MOVE 1 TO IGNORE-RECORD-FLAG.
024120 GO TO DICT-CHANGER-DETAIL.
024140 DICT-CHANGER-RD-CHG2.
024160 PERFORM MOVE-RD-FIELDS THRU MOVE-RD-FIELDS-EXIT.
024180 PERFORM PRINT-RD-FIELDS THRU PRINT-RD-FIELDS-EXIT.
024200 GO TO DICT-CHANGER-AC-CMN.
024220
024240* *PROCESS PD CHANGES* *
024260 DICT-CHANGER-PD.
024280 IF CP-ACT = 'A' OR ' ' GO TO DICT-CHANGER-PD-ADD.
024300 IF CP-ACT = 'D' GO TO DICT-CHANGER-PD-DEL.
024320 IF CP-ACT = 'C' GO TO DICT-CHANGER-PD-CHG.
024340 GO TO DICT-CHANGER-ERROR.
024360 DICT-CHANGER-PD-DEL.
024380 PERFORM FIND-ENTRY THROUGH FIND-ENTRY-EXIT.
024400 IF FOUND-ENTRY NOT = 1 GO TO DICT-CHANGER-MISSED-CMN.
024420 PERFORM PRINT-PD-FIELDS.
024440 GO TO DICT-CHANGER-DEL-CMN.
024460 DICT-CHANGER-PD-ADD.
024480 PERFORM DICT-CHG-WRITE1.
024500 GO TO DICT-CHANGER-PD-CHG1.
024520 DICT-CHANGER-PD-CHG.
024540 PERFORM FIND-ENTRY THROUGH FIND-ENTRY-EXIT.
024560 IF FOUND-ENTRY NOT = 1 GO TO DICT-CHANGER-MISSED-CMN.
024580 IF CP-PROT-NO-X = SPACE MOVE DP-PROT-NO TO CP-PROT-NO.
024600 IF CP-DATE-FLAG = SPACE MOVE DP-DATE-FLAG TO CP-DATE-FLAG.
024620 IF CP-LINE-X = SPACE MOVE DP-LINE TO CP-LINE.
024640 IF CP-PASSWORD = SPACE MOVE DP-TEXT TO CP-PASSWORD.
024660 DICT-CHANGER-PD-CHG1.
024680 PERFORM EDIT-PD-FIELDS.
024700 PERFORM CHECK-PD-FIELDS.
024720 IF TRAN-ERR-FLG NOT = 1 GO TO DICT-CHANGER-PD-CHG2.
024740 IF CP-ACT = 'A' MOVE 1 TO IGNORE-RECORD-FLAG.
024760 GO TO DICT-CHANGER-DETAIL.
024780 DICT-CHANGER-PD-CHG2.
024800 PERFORM MOVE-PD-FIELDS.
024820 PERFORM PRINT-PD-FIELDS.
024840 GO TO DICT-CHANGER-AC-CMN.
024860
024880* *PROCESS DD CHANGES* *
024900 DICT-CHANGER-DD.
024920 IF CD-ACT = 'A' OR ' ' GO TO DICT-CHANGER-DD-ADD.
024940 IF CD-ACT = 'D' GO TO DICT-CHANGER-DD-DEL.
024960 IF CD-ACT = 'C' GO TO DICT-CHANGER-DD-CHG.
024980 GO TO DICT-CHANGER-ERROR.
025000 DICT-CHANGER-DD-DEL.
025020 PERFORM FIND-ENTRY THROUGH FIND-ENTRY-EXIT.
025040 IF FOUND-ENTRY NOT = 1 GO TO DICT-CHANGER-MISSED-CMN.
025060 PERFORM PRINT-DD-FIELDS.
025080 GO TO DICT-CHANGER-DEL-CMN.
025100 DICT-CHANGER-DD-ADD.
025120 PERFORM DICT-CHG-WRITE1.
025140 GO TO DICT-CHANGER-DD-CHG1.
025160 DICT-CHANGER-DD-CHG.
025180 PERFORM FIND-ENTRY THROUGH FIND-ENTRY-EXIT.
025200 IF FOUND-ENTRY NOT = 1 GO TO DICT-CHANGER-MISSED-CMN.
025220 IF CD-TITLE1 = SPACE MOVE DD-TITLE1 TO CD-TITLE1.
025240 IF CD-TITLE1 = ALL '*' MOVE SPACE TO CD-TITLE1.
025260 IF CD-TITLE2 = SPACE MOVE DD-TITLE2 TO CD-TITLE2.
025280 IF CD-TITLE2 = ALL '*' MOVE SPACE TO CD-TITLE2.
025300 IF CD-FCHAR-X = SPACE MOVE DD-FCHAR TO CD-FCHAR.
025320 IF CD-FCHAR-X = ALL '*' MOVE SPACE TO CD-FCHAR-X.
025340 IF CD-NCHARS-X = SPACE MOVE DD-NCHARS TO CD-NCHARS.
025360 IF CD-NCHARS-X = ALL '*' MOVE SPACE TO CD-NCHARS-X.
025380 IF CD-NOUPD = SPACES MOVE DD-NOUPD TO CD-NOUPD.
025400 IF CD-NOUPD = '*' MOVE SPACE TO CD-NOUPD.
025420 IF CD-TYPE-X = SPACE MOVE DD-TYPE TO CD-TYPE.
025440 IF CD-TYPE-X = ALL '*' MOVE SPACE TO CD-TYPE-X.
025460 IF CD-SCALE-X = SPACE MOVE DD-SCALE TO CD-SCALE.
025480 IF CD-SCALE-X = ALL '*' MOVE SPACE TO CD-SCALE-X.
025500 IF CD-OFFSET-X = SPACE MOVE DD-OFFSET TO CD-OFFSET.
025520 IF CD-OFFSET-X = ALL '*' MOVE SPACE TO CD-OFFSET-X.
025540 IF CD-EDIT-X = SPACE MOVE DD-EDIT TO CD-EDIT.
025560 IF CD-EDIT-X = ALL '*' MOVE SPACE TO CD-EDIT-X.
025580 IF CD-PICT = SPACE MOVE DD-PICT TO CD-PICT.
025600 IF CD-PICT = ALL '*' MOVE SPACE TO CD-PICT.
025620 IF CD-GRPNME = SPACE MOVE DD-GRPNME TO CD-GRPNME.
025640 IF CD-GRPNME = '*' MOVE SPACE TO CD-GRPNME.
025660 IF CD-NREPEATS-X = SPACE MOVE DD-NREPEATS TO CD-NREPEATS.
025680 IF CD-NREPEATS-X = ALL '*' MOVE SPACE TO CD-NREPEATS-X.
025700 IF CD-STOPPER = SPACE MOVE DD-STOPPER TO CD-STOPPER.
025720 IF CD-STOPPER = '*' MOVE SPACE TO CD-STOPPER.
025740 IF CD-PROT-NO-X = SPACE MOVE DD-PROT-NO TO CD-PROT-NO.
025760 IF CD-PROT-NO-X = ALL '*' MOVE SPACE TO CD-PROT-NO-X
025780 IF CD-EXCLFLAG = SPACE MOVE DD-EXCLFLAG TO CD-EXCLFLAG.
025800 IF CD-EXCLFLAG = '*' MOVE SPACE TO CD-EXCLFLAG.
025820 DICT-CHANGER-DD-CHG1.
025840 PERFORM EDIT-DD-FIELDS.
025860 PERFORM CHECK-DD-FIELDS.
025880 IF TRAN-ERR-FLG NOT = 1 GO TO DICT-CHANGER-DD-CHG2.
025900 IF CD-ACT = 'A' MOVE 1 TO IGNORE-RECORD-FLAG.
025920 GO TO DICT-CHANGER-DETAIL.
025940 DICT-CHANGER-DD-CHG2.
025960 PERFORM MOVE-DD-FIELDS.
025980 PERFORM PRINT-DD-FIELDS.
026000 GO TO DICT-CHANGER-AC-CMN.
026020
026040* *PROCESS CD (COMMENT) CHANGES* *
026060 DICT-CHANGER-CD.
026080 IF CC-ACT = 'A' OR ' ' GO TO DICT-CHANGER-CD-ADD.
026100 IF CC-ACT = 'C' GO TO DICT-CHANGER-CD-CHG.
026120 IF CC-ACT = 'D' GO TO DICT-CHANGER-CD-DEL.
026140 GO TO DICT-CHANGER-ERROR.
026160 DICT-CHANGER-CD-ADD.
026180 PERFORM DICT-CHG-WRITE1.
026200 GO TO DICT-CHANGER-CD-CHG1.
026220 DICT-CHANGER-CD-CHG.
026240 PERFORM FIND-ENTRY THROUGH FIND-ENTRY-EXIT.
026260 IF FOUND-ENTRY NOT = 1 GO TO DICT-CHANGER-MISSED-CMN.
026280 DICT-CHANGER-CD-CHG1.
026300 IF CC-TEXT = SPACE MOVE DC-TEXT TO CC-TEXT.
026320 IF CC-TEXT = ALL '*' MOVE SPACE TO CC-TEXT.
026340 PERFORM MOVE-CD-FIELDS.
026360 PERFORM PRINT-CD-FIELDS.
026380 GO TO DICT-CHANGER-AC-CMN.
026400 DICT-CHANGER-CD-DEL.
026420 PERFORM FIND-ENTRY THROUGH FIND-ENTRY-EXIT.
026440 IF FOUND-ENTRY NOT = 1 GO TO DICT-CHANGER-MISSED-CMN.
026460 PERFORM PRINT-CD-FIELDS.
026480 GO TO DICT-CHANGER-DEL-CMN.
026500
026520* *COMMON LOGIC FOLLOWS TO SERVICE ABOVE SEQUENCES* *
026540 DICT-CHANGER-MISSED-CMN.
026560 PERFORM PRINT-TRAN.
026580 MOVE ' %Found no entry matching above- tran rejected'
026600 TO PRINT-LINE.
026620 PERFORM DISPLAYER THRU DISPLAYER-EXIT.
026640 IF DICT-EOF = 1
026660 PERFORM WORK-COPY THRU WORK-COPY-EXIT
026680 PERFORM DICT-FINDER THRU DICT-FINDER-EXIT.
026700 GO TO DICT-CHANGER-CMN.
026720 DICT-CHANGER-AC-CMN.
026740 MOVE 0 TO IGNORE-RECORD-FLAG.
026760 IF CF-ACT = 'C' GO TO DICT-CHANGER-CHG-CMN.
026780 IF 1ST-NTRY-FLAG = 1 WRITE WORK-REC FROM DICT-WS
026800 MOVE HOLD-WS TO DICT-WS.
026820 MOVE ' *Above entry added' TO PRINT-LINE.
026840 GO TO DICT-CHANGER-CMN.
026860 DICT-CHANGER-CHG-CMN.
026880 MOVE ' *Above entry after changes made' TO PRINT-LINE.
026900 GO TO DICT-CHANGER-CMN.
026920 DICT-CHANGER-DEL-CMN.
026940 MOVE 1 TO IGNORE-RECORD-FLAG.
026960 MOVE ' *Above entry deleted' TO PRINT-LINE.
026980 DICT-CHANGER-CMN.
027000 PERFORM PRINT1B.
027020 GO TO DICT-CHANGER-DETAIL.
027040 DICT-CHANGER-DONE.
027060 PERFORM DICT-COPY THRU DICT-COPY-EXIT.
027080 PERFORM WORK-COPY THRU WORK-COPY-EXIT.
027100
027120 DICT-CHANGER-EXIT.
027140 EXIT.
027160
027180 DICT-CHG-WRITE1.
027200 IF 1ST-NTRY-FLAG = 1 MOVE DICT-WS TO HOLD-WS
027220 MOVE 1 TO IGNORE-RECORD-FLAG.
027240 IF IGNORE-RECORD-FLAG = 0
027260 WRITE WORK-REC FROM DICT-WS.
027280 MOVE 0 TO IGNORE-RECORD-FLAG.
027300
027320********************
027340* THE SUBROUTINE BELOW SEARCHES THE CURRENT DICTIONARY FOR
027360* THE ENTRY CORRESPONDING TO THE CURRENT TRAN. IF IT DOES NOT
027380* HIT THE FIRST TIME IT RETRIES FROM THE BEGINNING OF THE
027400* DICTIONARY BEFORE SETTING AN ERROR (NOT FOUND) FLAG AND
027420* EXITING.
027440* ON HIT, EXITS WITH: FOUND-ENTRY = 1
027460* FILES OPEN AND MARKED OPEN
027480* DICT-EOF = 0
027500* ON MISS, EXITS WITH: FOUND-ENTRY = 0
027520* FILES CLOSED AND MARKED CLOSED
027540* DICT-EOF = 0
027560********************
027580 FIND-ENTRY.
027600 MOVE 0 TO FOUND-ENTRY 1ST-NTRY-FLAG.
027620 MOVE 1 TO LOOK-CYCLE.
027640 FIND-ENTRY-READ.
027660 IF DICT-FILE-FLAG = 0 GO TO FIND-ENTRY-RETRY.
027680 IF IGNORE-RECORD-FLAG = 1 GO TO FIND-ENTRY2.
027700 IF DF-IDNT NOT = CF-IDNT GO TO FIND-ENTRY1.
027720 IF ( DF-IDNT = 'DD' OR 'KD' OR 'RD' OR 'AD' OR 'SD' )
027740 AND DF-NAME = CF-NAME GO TO FIND-ENTRY-DONE.
027760 IF DF-IDNT = 'CD' AND DC-NO = CC-NO
027780 GO TO FIND-ENTRY-DONE.
027800 IF DF-IDNT NOT = 'PD' GO TO FIND-ENTRY1.
027820 MOVE DP-TEXT TO PW-TEXT-HOLDER.
027840 PERFORM UNSCRAMBLE-PW THRU UNSCRAMBLE-PW-EXIT.
027860 IF DP-PROT-NO = CP-PROT-NO AND
027880 ( CP-TEXT = DP-TEXT OR
027900 CP-TEXT = UNIVERSAL-PASSWORD )
027920 MOVE PW-TEXT-HOLDER TO DP-TEXT
027940 GO TO FIND-ENTRY-DONE.
027960 MOVE PW-TEXT-HOLDER TO DP-TEXT.
027980 GO TO FIND-ENTRY2.
028000 FIND-ENTRY1.
028020 IF DF-IDNT = 'DD' OR 'KD'
028040 PERFORM GETGRPLEN THRU GETGRPLENX
028060 GO TO FIND-ENTRY2.
028080 IF DF-IDNT = 'FD' AND DF-NAME NOT = CURRENT-CF-NAME
028100 MOVE 1 TO FOUND-FD
028120 MOVE DF-NAME TO CURRENT-DF-NAME
028140 GO TO FIND-ENTRY-RETRY.
028160 FIND-ENTRY2.
028180 IF IGNORE-RECORD-FLAG = 0
028200 WRITE WORK-REC FROM DICT-WS.
028220 MOVE 0 TO IGNORE-RECORD-FLAG 1ST-NTRY-FLAG.
028240 IF DICT-FILE-FLAG = 0 GO TO FIND-ENTRY-RETRY.
028260 READ QPDICT INTO DICT-WS AT END PERFORM CLOSE-DICT-WORK
028280 GO TO FIND-ENTRY-RETRY.
028300 GO TO FIND-ENTRY-READ.
028320 FIND-ENTRY-RETRY.
028340 IF LOOK-CYCLE = 2
028360 PERFORM CLOSE-DICT-WORK GO TO FIND-ENTRY-EXIT.
028380 MOVE 2 TO LOOK-CYCLE.
028400 PERFORM DICT-COPY THROUGH DICT-COPY-EXIT.
028420 PERFORM WORK-COPY THROUGH WORK-COPY-EXIT.
028440 PERFORM DICT-FINDER THROUGH DICT-FINDER-EXIT.
028460 MOVE 0 TO N-SCANITEMS.
028480 GO TO FIND-ENTRY2.
028500 FIND-ENTRY-DONE.
028520 MOVE 1 TO FOUND-ENTRY.
028540 FIND-ENTRY-EXIT.
028560 EXIT.
028580
028600*****************************
028620* SUBROUTINE TO PROCESS A NEW DICTIONARY FROM TRANS TO WORK FILE.
028640* IT READS TRANS EDITS THEM CHECKS AND CORRECTS ERRORS MOVES
028660* TO WORK FILE PRINTS THEM OUT. ASSUMES DICT AND TRAN FILES
028680* ARE OPEN AND POSITIONED AT PLACE TO BE READ OR WRITTEN TO.
028700*****************************
028720 NEW-DICT.
028724 MOVE 99 TO UNLOCKED-LEVEL.
028726 MOVE 0 TO DICT-LOCK.
028740 PERFORM PRINT-FD-HEAD.
028760 PERFORM EDIT-FD-FIELDS.
028780 PERFORM CHECK-FD-FIELDS THRU CHECK-FD-FIELDS-EXIT.
028800 PERFORM MOVE-FD-FIELDS.
028820 PERFORM PRINT-FD-FIELDS THRU PRINT-FD-FIELDS-EXIT.
028840 PERFORM PRINT-DD-HEAD.
028860 IF IGNORE-RECORD-FLAG EQUAL TO 0
028880 WRITE WORK-REC FROM DICT-WS.
028900 MOVE 0 TO IGNORE-RECORD-FLAG FOUND-FD-TRAN.
028920 NEW-DICT-READ.
028940 READ QCDICT INTO TRAN-WS AT END GO TO NEW-DICT-EXIT.
028960 MOVE TRAN-WS TO HOLD-TRAN.
028980 IF CF-ACT = 'D' OR CF-ACT = 'C'
029000 MOVE HOLD-TRAN-FD TO TRAN-FD
029020 MOVE 1 TO HOLD-TRAN-FLAG
029040 MOVE 'C' TO CF-ACT
029060 GO TO NEW-DICT-FD.
029080 IF CF-IDNT = 'FD' GO TO NEW-DICT-FD.
029100 IF CC-IDNT = 'CD' GO TO NEW-DICT-CD.
029120 IF CD-IDNT = 'PD' GO TO NEW-DICT-PD.
029140 IF CD-IDNT = 'DD' OR 'KD' GO TO NEW-DICT-DD.
029160 IF CD-IDNT = 'RD' OR 'AD' OR 'SD' GO TO NEW-DICT-RD.
029180 GO TO NEW-DICT-ERROR.
029200**SAME LOGIC BELOW APPLIES FOR RD, AD, AND SD TRANSACTIONS***
029220 NEW-DICT-RD.
029240 PERFORM EDIT-RD-FIELDS THRU EDIT-RD-FIELDS-EXIT.
029260 PERFORM CHECK-RD-FIELDS THRU CHECK-RD-FIELDS-EXIT.
029280 IF TRAN-ERR-FLG = 1 GO TO NEW-DICT-READ.
029300 PERFORM MOVE-RD-FIELDS THRU MOVE-RD-FIELDS-EXIT.
029320 PERFORM PRINT-RD-FIELDS THRU PRINT-RD-FIELDS-EXIT.
029340 WRITE WORK-REC FROM DICT-WS.
029360 GO TO NEW-DICT-READ.
029380 NEW-DICT-DD.
029400 PERFORM EDIT-DD-FIELDS.
029420 PERFORM CHECK-DD-FIELDS.
029440 IF TRAN-ERR-FLG = 1 GO TO NEW-DICT-READ.
029460 PERFORM MOVE-DD-FIELDS.
029480 PERFORM PRINT-DD-FIELDS.
029500 WRITE WORK-REC FROM DICT-WS.
029520 GO TO NEW-DICT-READ.
029540 NEW-DICT-CD.
029560 PERFORM MOVE-CD-FIELDS.
029580 PERFORM PRINT-CD-FIELDS.
029600 WRITE WORK-REC FROM DICT-WS.
029620 GO TO NEW-DICT-READ.
029640 NEW-DICT-PD.
029660 IF CP-IDNT NOT = 'PD' GO TO NEW-DICT-FD.
029680 PERFORM EDIT-PD-FIELDS.
029700 PERFORM CHECK-PD-FIELDS.
029720 IF TRAN-ERR-FLG = 1 GO TO NEW-DICT-READ.
029740 PERFORM MOVE-PD-FIELDS.
029760 PERFORM PRINT-PD-FIELDS.
029780 WRITE WORK-REC FROM DICT-WS.
029800 GO TO NEW-DICT-READ.
029820 NEW-DICT-FD.
029840 IF CF-IDNT = 'FD' MOVE 1 TO FOUND-FD-TRAN
029860 MOVE CF-NAME TO CURRENT-CF-NAME
029880 GO TO NEW-DICT-EXIT.
029900 PERFORM PRINT-TRAN.
029920 NEW-DICT-ERROR.
029940 MOVE ' %Unrecognizeable tran type above- ignored'
029960 TO PRINT-LINE. PERFORM DISPLAYER THRU DISPLAYER-EXIT.
029980 PERFORM PRINT1B.
030000 PERFORM DISPLAYER THRU DISPLAYER-EXIT.
030020 GO TO NEW-DICT-READ.
030040 NEW-DICT-EXIT.
030060 EXIT.
030080
030100*****************************
030120* SUBROUTINE TO POSITION DICTIONARY FILE AT THE BEGINNING OF THE
030140* DICTIONARY NAMED IN THE FD TRAN IN TRAN-WS. AN ALL SPACE
030160* NAME WILL GIVE HIT ON FIRST DICTIONARY IN FILE. FILES ARE
030180* LEFT OPEN. FD ENTRY OF FIRST DICTIONARY FOUND IS LEFT IN
030200* DICT-WS.
030220* EXIT CONDITIONS ARE:
030240* IF DID NOT FIND DICT, HIT EOF ON QPDICT:
030260* FILES OPEN AND MARKED OPEN
030280* DICT-EOF = 1
030300* FOUND-DICT = 0
030320*
030340* IF SUCCESSFULLY FOUND DICT:
030360* FILES ARE LEFT OPEN
030380* DICT-EOF = 0
030400* FOUND-DICT = 1
030420*****************************
030440 DICT-FINDER.
030460 MOVE 0 TO FOUND-DICT.
030480 PERFORM OPEN-IN-DICT-OUT-WORK.
030500 DICT-FINDER-READ.
030520 READ QPDICT INTO DICT-WS AT END MOVE 1 TO DICT-EOF
030540 GO TO DICT-FINDER-EXIT.
030560 IF DF-IDNT EQUAL TO 'FD' GO TO DICT-FINDER-FD.
030580 WRITE WORK-REC FROM DICT-WS.
030600 GO TO DICT-FINDER-READ.
030620 DICT-FINDER-FD.
030640* *BLK FAC CONVERSION NOTED OUT FOR NOW* *
030660* *IF HAVE OLD BLK LEN, CONVERT IT TO - BLKFACT*.
030680* IF DF-BLKFACT GREATER THAN 0
030700* DIVIDE DF-RECLEN INTO DF-BLKFACT GIVING WORK-1
030720* SUBTRACT WORK-1 FROM 0 GIVING DF-BLKFACT.
030740 IF CURRENT-CF-NAME = SPACE MOVE 1 TO FOUND-DICT
030760 MOVE DF-NAME TO CURRENT-DF-NAME
030780 GO TO DICT-FINDER-EXIT.
030800 IF DF-NAME = CURRENT-CF-NAME
030820 MOVE 1 TO FOUND-DICT GO TO DICT-FINDER-EXIT.
030840 WRITE WORK-REC FROM DICT-WS.
030860 GO TO DICT-FINDER-READ.
030880 DICT-FINDER-EXIT.
030900 EXIT.
030920
030940*****************************
030960* SUBROUTINE TO PASS OVER A DICTIONARY IN DICTIONARY FILE.
030980* IT LEAVES THE NEXT FD RECORD (IF ANY) IN DICT-WS. IF IT
031000* DOES NOT FIND A NEXT FD RECORD FLAG DICT-EOF IS SET
031020* TO 1 ELSE IT IS SET TO 0.
031040*****************************
031060 DICT-PASS.
031080 IF DICT-EOF = 1 PERFORM CLOSE-DICT-WORK
031100 GO TO DICT-PASS-EXIT.
031120 IF DICT-FILE-FLAG = 0 GO TO DICT-PASS-EXIT.
031140 DICT-PASS1.
031160 READ QPDICT INTO DICT-WS AT END
031180 PERFORM CLOSE-DICT-WORK GO TO DICT-PASS-EXIT.
031200 IF DF-IDNT NOT = 'FD' GO TO DICT-PASS1.
031220* *BLK FAC CONVERSION NOTED OUT FOR NOW* *
031240* *CONVERT OLD BLK LEN TO BLK FACT (< 0)*.
031260* IF DF-BLKFACT GREATER THAN 0
031280* DIVIDE DF-RECLEN INTO DF-BLKFACT GIVING WORK-1
031300* SUBTRACT WORK-1 FROM 0 GIVING DF-BLKFACT.
031320 DICT-PASS-EXIT.
031340 EXIT.
031360
031380*****************************
031400* SUBROUTINE TO COPY REST OF DICTIONARY FILE INTO WORK FILE.
031420* STARTING FROM RECORD NOW IN DICT-WS.
031440*****************************
031460 DICT-COPY.
031480 IF DICT-EOF = 1 PERFORM CLOSE-DICT-WORK
031500 GO TO DICT-COPY-EXIT.
031520 IF DICT-FILE-FLAG = 0 GO TO DICT-COPY-EXIT.
031540 DICT-COPY-1.
031560 IF IGNORE-RECORD-FLAG EQUAL TO 0
031580 WRITE WORK-REC FROM DICT-WS.
031600 MOVE 0 TO IGNORE-RECORD-FLAG.
031620 READ QPDICT INTO DICT-WS AT END
031640 PERFORM CLOSE-DICT-WORK
031660 GO TO DICT-COPY-EXIT.
031680 GO TO DICT-COPY-1.
031700 DICT-COPY-EXIT.
031720 EXIT.
031740
031760*****************************
031780* SUBROUTINE TO COPY WORK FILE BACK INTO ORIGINAL DICTIONARY FILE
031800*****************************
031820 WORK-COPY.
031840 PERFORM OPEN-OUT-DICT-IN-WORK.
031860 WORK-COPY-1.
031880 READ QTDICT AT END
031900 PERFORM CLOSE-DICT-WORK
031920 GO TO WORK-COPY-EXIT.
031940 WRITE DICT-REC FROM WORK-REC.
031960 GO TO WORK-COPY-1.
031980 WORK-COPY-EXIT.
032000 EXIT.
032020
032040*****************************
032060* SUBROUTINE TO READ OVER TRANS FROM CURRENT POSITION UNTIL
032080* HIT AN FD TRAN OR END OF TRAN IMAGE FILE.
032100* IF FINDS FD TRAN IT IS LEFT IN TRAN-WS.
032120*****************************
032140 FIND-FD-TRAN.
032160 MOVE 0 TO FOUND-FD-TRAN.
032180 FIND-FD-TRAN-1.
032200 READ QCDICT INTO TRAN-WS AT END GO TO FIND-FD-TRAN-EXIT.
032220 MOVE TRAN-WS TO HOLD-TRAN.
032240 IF CF-IDNT NOT = 'FD' GO TO FIND-FD-TRAN-1.
032260 MOVE 1 TO FOUND-FD-TRAN.
032280 MOVE CF-NAME TO CURRENT-CF-NAME.
032300 FIND-FD-TRAN-EXIT.
032320 EXIT.
032340
032360**************************
032380* PRINT SUBROUTINES FOLLOW.
032400* THIS IS THE ONLY PLACE PRINTS ARE PHYSICALLY DONE.
032420**************************
032440 PRINT0.
032460 WRITE PRINT-LINE AFTER ADVANCING TOP-OF-PAGE.
032480 MOVE 0 TO LINE-CTR.
032500 PRINT0-EXIT.
032520 EXIT.
032540
032560 PRINT1.
032580 WRITE PRINT-LINE AFTER ADVANCING 1 LINES.
032600 ADD 1 TO LINE-CTR.
032620 IF LINE-CTR GREATER THAN LINE-MAX PERFORM NEW-PAGE
032640 PERFORM PRINT-DD-HEAD.
032660 PRINT1-EXIT.
032680 EXIT.
032700
032720 PRINT1B.
032740 WRITE PRINT-LINE AFTER ADVANCING 1 LINES.
032760 ADD 1 TO LINE-CTR.
032780 IF LINE-CTR GREATER THAN LINE-MAX PERFORM NEW-PAGE
032800 PERFORM PRINT-DD-HEAD
032820 ELSE
032840 MOVE ' ' TO PRINT-LINE PERFORM PRINT1.
032860 PRINT1B-EXIT.
032880 EXIT.
032900
032920 PRINT1D.
032940 PERFORM DISPLAYER THRU DISPLAYER-EXIT.
032960 PERFORM PRINT1.
032980 PRINT1D-EXIT.
033000 EXIT.
033020
033040 PRINT2.
033060 WRITE PRINT-LINE AFTER ADVANCING 2 LINES.
033080 ADD 2 TO LINE-CTR.
033100 IF LINE-CTR GREATER THAN LINE-MAX PERFORM NEW-PAGE
033120 PERFORM PRINT-DD-HEAD.
033140 PRINT2-EXIT.
033160 EXIT.
033180
033200******************************************************
033220* SUBROUTINE TO SPACE 1 LINE ON PRINTER.
033240******************************************************
033260 SPACER.
033280 MOVE SPACE TO PRINT-LINE.
033300 WRITE PRINT-LINE AFTER ADVANCING 1 LINES.
033320 ADD 1 TO LINE-CTR.
033340
033360*****************************
033380* SUBROUTINE TO PRINT OUT TRAN IMAGE VERBATIM.
033400*****************************
033420 PRINT-TRAN.
033440 MOVE HOLD-TRAN TO TRAN-LINE.
033460 MOVE TRAN-MESSAGE TO PRINT-LINE.
033480 PERFORM DISPLAYER THRU DISPLAYER-EXIT.
033500 PERFORM PRINT2.
033520 PRINT-TRAN-EXIT.
033540 EXIT.
033560
033580***************************
033600* SUBROUTINE TO DISPLAY PRINT LINE UPON TERMINAL.
033620***************************
033640 DISPLAYER.
033644 MOVE PRINT-LINE TO CONSOLE-LINE.
033648 MOVE 72 TO M.
033652 DISPLAYER1.
033656 IF CONSOLE-CHAR (M) = SPACE
033660 MOVE ASCII-NULL TO CONSOLE-CHAR (M)
033664 IF M NOT < 2 SUBTRACT 1 FROM M
033668 GO TO DISPLAYER1.
033672 DISPLAY CONSOLE-LINE UPON CONSOLE.
033680 DISPLAYER-EXIT.
033700 EXIT.
033720
033740********************
033760* DATE SLASHING ROUTINE
033780********************
033800 DATE-SLASHER.
033820 MOVE WMON TO SMON.
033840 MOVE WDAY TO SDAY.
033860 MOVE WYEAR TO SYEAR.
033880 DATE-SLASHER-EXIT.
033900 EXIT.
033920
033940***********************************************************
033960* SUBROUTINES WHICH FOLLOW OPEN AND CLOSE FILES.
033980***********************************************************
034000
034020*****************************
034040* SUBROUTINE TO OPEN TRAN FILE.
034060*****************************
034080 OPEN-TRAN-FILE.
034100 IF TRAN-FILE-FLAG = 1 CLOSE QCDICT.
034120 OPEN INPUT QCDICT.
034140 MOVE 1 TO TRAN-FILE-FLAG.
034160 OPEN-TRAN-FILE-EXIT.
034180 EXIT.
034200
034220*****************************
034240* SUBROUTINE TO OPEN PRINT FILE.
034260*****************************
034280 OPEN-PRINT-FILE.
034300 IF PRINT-FILE-FLAG = 1 CLOSE QLDICT.
034320 OPEN OUTPUT QLDICT.
034340 MOVE 1 TO PRINT-FILE-FLAG.
034360 OPEN-PRINT-FILE-EXIT.
034380 EXIT.
034400
034420*****************************
034440* SUBROUTINE TO OPEN OUTPUT DICTIONARY FILE ONLY.
034460*****************************
034480 OPEN-OUT-DICT.
034500 IF DICT-FILE-FLAG = 1 CLOSE QPDICT.
034520 MOVE 0 TO DICT-EOF.
034540 OPEN OUTPUT QPDICT.
034560 MOVE 1 TO DICT-FILE-FLAG.
034580 OPEN-OUT-DICT-EXIT.
034600 EXIT.
034620
034640*****************************
034660* SUBROUTINE TO OPEN INPUT DICT FILE AND OUTPUT WORK FILE
034680*****************************
034700 OPEN-IN-DICT-OUT-WORK.
034720 MOVE 0 TO DICT-EOF.
034740 IF DICT-FILE-FLAG = 1 CLOSE QPDICT.
034760 IF WORK-FILE-FLAG = 1 CLOSE QTDICT
034770 MOVE 0 TO WORK-FILE-FLAG.
034780 OPEN INPUT QPDICT. MOVE 1 TO DICT-FILE-FLAG.
034800 OPEN OUTPUT QTDICT. MOVE 1 TO WORK-FILE-FLAG.
034820 OPEN-IN-DICT-OUT-WORK-EXIT.
034840 EXIT.
034860
034880*****************************
034900* SUBROUTINE TO OPEN INPUT WORK FILE AND OUTPUT DICT FILE.
034920*****************************
034940 OPEN-OUT-DICT-IN-WORK.
034960 MOVE 0 TO DICT-EOF.
034980 IF DICT-FILE-FLAG = 1 CLOSE QPDICT.
035000 IF WORK-FILE-FLAG = 1 CLOSE QTDICT
035010 MOVE 0 TO WORK-FILE-FLAG.
035020 OPEN INPUT QTDICT. MOVE 1 TO WORK-FILE-FLAG.
035040 OPEN OUTPUT QPDICT. MOVE 1 TO DICT-FILE-FLAG.
035060
035080*****************************
035100* SUBROUTINE TO CLOSE DICT AND WORK FILES.
035120*****************************
035140 CLOSE-DICT-WORK.
035160 MOVE 0 TO DICT-EOF.
035180 IF DICT-FILE-FLAG = 1 CLOSE QPDICT.
035200 IF WORK-FILE-FLAG = 1 CLOSE QTDICT
035210 MOVE 0 TO WORK-FILE-FLAG.
035220 MOVE 0 TO DICT-FILE-FLAG WORK-FILE-FLAG.
035240
035260*****************************
035280* SUBROUTINE TO CLOSE ALL FILES.
035300*****************************
035320 CLOSE-ALL-FILES.
035340 IF DICT-FILE-FLAG = 1 CLOSE QPDICT.
035360 IF WORK-FILE-FLAG = 1 CLOSE QTDICT
035370 MOVE 0 TO WORK-FILE-FLAG.
035380 IF TRAN-FILE-FLAG = 1 CLOSE QCDICT.
035400 IF PRINT-FILE-FLAG = 1 CLOSE QLDICT.
035420 MOVE 0 TO DICT-FILE-FLAG WORK-FILE-FLAG
035440 TRAN-FILE-FLAG PRINT-FILE-FLAG DICT-EOF.
035460
035480***********************************************************
035500* SUBROUTINES BELOW ALL DEAL WITH CHECKING TRANSACTION
035520* AND MOVING IT INTO PERMANENT DICTIONARY ENTRY AND/OR
035540* PRINTING ENTRY FIELDS.
035560***********************************************************
035580
035600*****************************
035620* SUBROUTINE TO EDIT FD FIELDS IN INPUT TRAN
035640*****************************
035660 EDIT-FD-FIELDS.
035680 EXAMINE CF-RECLEN-X REPLACING ALL SPACE BY 0.
035700 EXAMINE CF-BLKFACT-X REPLACING ALL SPACE BY 0.
035720 EXAMINE CF-KEYPOS-X REPLACING ALL SPACE BY 0.
035740 EXAMINE CF-KEYLEN-X REPLACING ALL SPACE BY 0.
035760 EXAMINE CF-KEYTYPE-X REPLACING ALL SPACE BY 0.
035780 EXAMINE CF-KEYSIGN REPLACING ALL SPACE BY 0.
035800 EXAMINE CF-PROT-READ REPLACING ALL SPACE BY 0.
035820 EXAMINE CF-PROT-COPY REPLACING ALL SPACE BY 0.
035840 EXAMINE CF-PROT-REWR REPLACING ALL SPACE BY 0.
035860
035880****************************
035900* SUBROUTINE TO CHECK FD FIELDS FOR ERRORS PRINTOUT PROPER
035920* MESSAGES AND CHANGE FIELDS CONTENTS AS INDICATED.
035940*****************************
035960 CHECK-FD-FIELDS.
035980 MOVE 0 TO TRAN-ERR-FLG.
036000 IF CF-NAME = SPACE PERFORM FD-ERROR
036020 MOVE 'BAD-NAME' TO CF-NAME
036040 MOVE FD-MSG-15 TO PRINT-LINE
036060 PERFORM PRINT1D.
036080 IF CF-FILETYPE = '6' OR '7' NEXT SENTENCE
036100 ELSE GO TO CHECK-FD-FIELDS2.
036120 IF CF-KEYTYPE-X = 'N' AND CF-KEYLEN GREATER THAN 10
036140 MOVE 2 TO CF-KEYTYPE GO TO CHECK-FD-FIELDS1.
036160 IF CF-KEYTYPE-X = 'N'
036180 MOVE 1 TO CF-KEYTYPE GO TO CHECK-FD-FIELDS1.
036200 IF CF-KEYTYPE-X EQUAL TO 'A'
036220 MOVE 0 TO CF-KEYTYPE GO TO CHECK-FD-FIELDS1.
036240 IF CF-KEYTYPE-X NOT = '0'
036260 AND CF-KEYTYPE-X NOT = '1'
036280 AND CF-KEYTYPE-X NOT = '2'
036300 MOVE 0 TO CF-KEYTYPE
036320 PERFORM FD-ERROR
036340 MOVE FD-MSG-13 TO PRINT-LINE PERFORM PRINT1D.
036360 CHECK-FD-FIELDS1.
036380 IF CF-KEYSIGN = 'S'
036400 MOVE '0' TO CF-KEYSIGN GO TO CHECK-FD-FIELDS2.
036420 IF CF-KEYSIGN = 'U' MOVE '1' TO CF-KEYSIGN
036440 GO TO CHECK-FD-FIELDS2.
036460 IF CF-KEYSIGN NOT = '0'
036480 AND CF-KEYSIGN NOT = '1'
036500 MOVE 1 TO CF-KEYSIGN
036520 PERFORM FD-ERROR
036540 MOVE FD-MSG-14 TO PRINT-LINE PERFORM PRINT1D.
036560 CHECK-FD-FIELDS2.
036580 IF CF-RECLEN-X IS NOT NUMERIC PERFORM FD-ERROR
036600 MOVE 0 TO CF-RECLEN MOVE 'REC LENGTH' TO FD-NO-NUM
036620 MOVE FD-MSG-11 TO PRINT-LINE PERFORM PRINT1D.
036640 IF CF-BLKFACT IS NOT NUMERIC PERFORM FD-ERROR
036660 MOVE 0 TO CF-BLKFACT-X MOVE 'BLK FACT' TO FD-NO-NUM
036680 MOVE FD-MSG-11 TO PRINT-LINE PERFORM PRINT1D.
036700 IF CF-KEYPOS-X IS NOT NUMERIC
036720 PERFORM FD-ERROR MOVE 0 TO CF-KEYPOS
036740 MOVE 'KEY POSITION' TO FD-NO-NUM
036760 MOVE FD-MSG-11 TO PRINT-LINE PERFORM PRINT1D.
036780 IF CF-KEYLEN-X IS NOT NUMERIC
036800 PERFORM FD-ERROR MOVE 0 TO CF-KEYLEN
036820 MOVE 'KEY LENGTH' TO FD-NO-NUM
036840 MOVE FD-MSG-11 TO PRINT-LINE PERFORM PRINT1D.
036860 IF CF-PROT-READ IS NOT NUMERIC PERFORM FD-ERROR
036880 MOVE 0 TO CF-PROT-READ
036900 MOVE 'READ PROTECT' TO FD-NO-NUM
036920 MOVE FD-MSG-11 TO PRINT-LINE PERFORM PRINT1D.
036940 IF CF-PROT-COPY IS NOT NUMERIC
036960 MOVE 0 TO CF-PROT-COPY
036980 MOVE 'COPY PROTECT' TO FD-NO-NUM
037000 MOVE FD-MSG-11 TO PRINT-LINE PERFORM PRINT1D.
037020 IF CF-PROT-REWR IS NOT NUMERIC
037040 MOVE 0 TO CF-PROT-REWR
037060 MOVE 'REWR PROTECT' TO FD-NO-NUM
037080 MOVE FD-MSG-11 TO PRINT-LINE PERFORM PRINT1D.
037100* *BLK FAC CONVERSION NOTED OUT FOR NOW* *
037120* *IF HAVE OLD BLK LEN, CONVERT TO BLKFACT (< 0)*.
037140* IF CF-BLKFACT GREATER THAN 0
037160* DIVIDE CF-RECLEN INTO CF-BLKFACT GIVING WORK-1
037180* SUBTRACT WORK-1 FROM 0 GIVING CF-BLKFACT.
037200* IF CF-RECLEN GREATER THAN MAX-RECLEN
037220* MOVE MAX-RECLEN TO CF-RECLEN PERFORM FD-ERROR
037240* MOVE FD-MSG-1 TO PRINT-LINE PERFORM PRINT1D.
037260* IF CF-RECLEN LESS THAN MIN-RECLEN
037280* MOVE MIN-RECLEN TO CF-RECLEN PERFORM FD-ERROR
037300* MOVE FD-MSG-2 TO PRINT-LINE PERFORM PRINT1D.
037320* IF CF-BLKFACT GREATER THAN MAX-BLKFACT
037340* MOVE CF-RECLEN TO CF-BLKFACT PERFORM FD-ERROR
037360* MOVE FD-MSG-3 TO PRINT-LINE PERFORM PRINT1D.
037380 IF CF-FILETYPE = '8' GO TO CHECK-FD-NOBLOCK.
037400 IF ( CF-FILETYPE = '6' OR '7' ) AND
037420 CF-KEYPOS = 0 AND
037440 CF-KEYLEN = 0 AND
037460 CF-BLKFACT = 0 GO TO CHECK-FD-NOBLOCK.
037480 IF CF-BLKFACT = 0
037500 PERFORM FD-ERROR
037520 MOVE FD-MSG-16 TO PRINT-LINE PERFORM PRINT1D.
037540 CHECK-FD-NOBLOCK.
037560 IF CF-FILETYPE-X EQUAL TO SPACE
037580 MOVE '6' TO CF-FILETYPE-X PERFORM FD-ERROR
037600 MOVE FD-MSG-5 TO PRINT-LINE PERFORM PRINT1D.
037620 MOVE CF-KEYPOS TO WORK-1. ADD CF-KEYLEN TO WORK-1.
037640 SUBTRACT 1 FROM WORK-1.
037660 IF WORK-1 IS GREATER THAN CF-RECLEN PERFORM FD-ERROR
037680 MOVE 1 TO CF-KEYPOS
037700 MOVE FD-MSG-7 TO PRINT-LINE PERFORM PRINT1D.
037720 IF CF-KEYLEN GREATER THAN MAX-KEYLEN
037740 PERFORM FD-ERROR MOVE MAX-KEYLEN TO CF-KEYLEN
037760 MOVE FD-MSG-9 TO PRINT-LINE PERFORM PRINT1.
037780 MOVE CF-KEYLEN TO WORK-1.
037800 ADD CF-KEYPOS TO WORK-1.
037820 ADD CF-KEYTYPE TO WORK-1.
037840 IF WORK-1 NOT = 0
037860 AND CF-FILETYPE NOT = '6'
037880 AND CF-FILETYPE NOT = '7'
037900 PERFORM FD-ERROR
037920 MOVE FD-MSG-12 TO PRINT-LINE PERFORM PRINT1D.
037940 IF TRAN-ERR-FLG NOT = 0
037960 MOVE FD-MSG-0 TO PRINT-LINE
037980 PERFORM DISPLAYER THRU DISPLAYER-EXIT
038000 DISPLAY ' ' UPON CONSOLE
038020 PERFORM PRINT1B.
038040 CHECK-FD-FIELDS-EXIT. EXIT.
038060
038080*************************************
038100* SUB SUBROUTINE TO PRINT OFFENDING TRAN ON FIRST
038120* FD ERROR.
038140*************************************
038160 FD-ERROR.
038180 IF TRAN-ERR-FLG = 0 PERFORM PRINT-TRAN
038200 MOVE 1 TO TRAN-ERR-FLG.
038220 FD-ERROR-EXIT.
038240 EXIT.
038260
038280
038300*****************************
038320* SUBROUTINE TO MOVE FD FIELDS FROM TRAN-WS TO DICT-WS.
038340*****************************
038360 MOVE-FD-FIELDS.
038380 MOVE SPACE TO DICT-FD.
038400 MOVE CF-IDNT TO DF-IDNT.
038420 MOVE CF-NAME TO DF-NAME.
038440 MOVE 0 TO DF-NDICTS.
038460 MOVE CF-INLABEL TO DF-INLABEL.
038480 MOVE CF-DIRECT TO DF-DIRECT.
038500 MOVE CF-FILETYPE-X TO DF-FILETYPE.
038520 MOVE CF-RECLEN TO DF-RECLEN.
038540 MOVE CF-BLKFACT TO DF-BLKFACT.
038560 MOVE CF-KEYPOS TO DF-KEYPOS.
038580 MOVE CF-KEYLEN TO DF-KEYLEN.
038600 MOVE CF-KEYTYPE TO DF-KEYTYPE.
038620 MOVE CF-KEYSIGN TO DF-KEYSIGN.
038640 MOVE CF-PROT-READ TO DF-PROT-READ.
038660 MOVE CF-PROT-COPY TO DF-PROT-COPY.
038680 MOVE CF-PROT-REWR TO DF-PROT-REWR.
038700 MOVE PACKED-DATE TO DF-LAST-UPDATE.
038720 MOVE-FD-FIELDS-EXIT.
038740 EXIT.
038760
038780*****************************
038800* SUBROUTINE TO PRINT FD HEADING ON PAGE.
038820*****************************
038840 PRINT-FD-HEAD.
038860 MOVE HEAD-4 TO PRINT-LN.
038880 PERFORM PRINT1.
038900 MOVE FD-HEAD-1 TO PRINT-LN.
038920 PERFORM PRINT1.
038940 MOVE FD-HEAD-2 TO PRINT-LN.
038960 PERFORM PRINT1.
038980 MOVE FD-HYPHS TO PRINT-LN.
039000 PERFORM PRINT1.
039020
039040*****************************
039060* SUBROUTINE TO PRINT FD FIELDS FROM DICT-WS
039080*****************************
039100 PRINT-FD-FIELDS.
039110 MOVE DF-PROT-COPY TO COPY-LEVEL.
039120 MOVE SPACE TO FD-DATA.
039140 MOVE DF-NAME TO FIL-NM-PRT.
039142 MOVE DF-PROT-READ TO FD-PD-READ.
039144 MOVE DF-PROT-READ TO UNLOCKED-WORK.
039146 IF UNLOCKED-WORK > UNLOCKED-LEVEL
039148 MOVE '**' TO FD-PD-READ FD-PD-COPY FD-PD-REWR
039150 GO TO PRINT-FD-FIELDS1.
039152 MOVE DF-PROT-COPY TO FD-PD-COPY.
039154 MOVE DF-PROT-COPY TO UNLOCKED-WORK.
039156 IF UNLOCKED-WORK > UNLOCKED-LEVEL
039158 MOVE '**' TO FD-PD-COPY FD-PD-REWR
039160 GO TO PRINT-FD-FIELDS1.
039162 MOVE DF-PROT-REWR TO FD-PD-REWR.
039164 MOVE DF-PROT-REWR TO UNLOCKED-WORK.
039166 IF UNLOCKED-WORK > UNLOCKED-LEVEL
039168 MOVE '**' TO FD-PD-REWR
039170 ELSE GO TO PRINT-FD-FIELDS2.
039172 PRINT-FD-FIELDS1.
039174 MOVE '(Locked)' TO IN-LAB-PRT.
039176 GO TO PRINT-FD-FIELDS3.
039178 PRINT-FD-FIELDS2.
039340 MOVE DF-INLABEL TO IN-LAB-PRT.
039360 MOVE DF-DIRECT TO DIRECT-PRT.
039380 MOVE DF-FILETYPE TO TEMPFTX.
039400 IF TEMPFTX EQUAL TO 'V'
039420 MOVE 10 TO I ELSE IF TEMPFTX EQUAL TO 'S'
039440 MOVE 11 TO I ELSE IF TEMPFTX IS NOT NUMERIC
039460 MOVE 12 TO I.
039480 IF TEMPFTX IS NUMERIC MOVE TEMPNUMFT TO I.
039500 MOVE TYPE-LIST (I) TO FIL-TYP-PRT.
039520 IF DF-KEYPOS NOT = 0 MOVE 'ISAM' TO FIL-ORG-PRT.
039540 MOVE DF-RECLEN TO RECZ-PRT.
039560* *IF OLD BLK LEN (> 0), CONVERT TO BLK FAC.
039580 IF DF-BLKFACT GREATER THAN 0
039600 DIVIDE DF-RECLEN INTO DF-BLKFACT GIVING WORK-1
039620 ELSE SUBTRACT DF-BLKFACT FROM 0 GIVING WORK-1.
039640 MOVE WORK-1 TO BLKF-PRT.
039660 MOVE DF-KEYPOS TO KEY-POS-PRT.
039680 MOVE DF-KEYLEN TO KEY-LEN-PRT.
039700 MOVE SPACE TO KEY-TYP-PRT KEY-SIGN-PRT.
039720 IF DF-KEYPOS = 0 GO TO PRINT-FD-FIELDS3.
039740 MOVE DF-KEYTYPE TO KEY-TYP-PRT.
039760 IF DF-KEYTYPE = 0 MOVE 'A' TO KEY-TYP-PRT.
039780 IF DF-KEYTYPE = 1 MOVE 'N' TO KEY-TYP-PRT.
039800 IF DF-KEYTYPE = 2 MOVE 'N' TO KEY-TYP-PRT.
039820 MOVE DF-KEYSIGN TO KEY-SIGN-PRT.
039840 IF DF-KEYSIGN = 0 MOVE 'S' TO KEY-SIGN-PRT.
039860 IF DF-KEYSIGN = 1 MOVE 'U' TO KEY-SIGN-PRT.
039880 PRINT-FD-FIELDS3.
040120 MOVE DF-LAST-UPDATE TO DATE-WORK.
040140 IF DATE-WORK = SPACE MOVE SPACE TO FD-UPDATE-PRT ELSE
040160 PERFORM DATE-SLASHER
040180 MOVE SLASHED-DATE TO FD-UPDATE-PRT.
040200 PERFORM SPACER.
040220 IF TRAN-ERR-FLG = 1 MOVE SPACE TO PRINT-LINE
040240 PERFORM PRINT1.
040260 MOVE FD-DATA TO PRINT-LN.
040280 PERFORM PRINT1.
040300 PERFORM SPACER.
040320 PRINT-FD-FIELDS-EXIT.
040340 EXIT.
040360
040380*****************************
040400* SUBROUTINE TO EDIT FIELDS IN DD TRAN INPUT
040420*****************************
040440 EDIT-DD-FIELDS.
040460 EXAMINE CD-NCHARS-X REPLACING ALL SPACE BY 0.
040480 EXAMINE CD-FCHAR-X REPLACING ALL SPACE BY 0.
040500 EXAMINE CD-EDIT-X REPLACING ALL SPACE BY 0.
040520 EXAMINE CD-OFFSET-X REPLACING ALL SPACE BY 0.
040540 EXAMINE CD-SCALE-X REPLACING ALL SPACE BY 0.
040560 EXAMINE CD-NREPEATS-X REPLACING ALL SPACE BY 0.
040580 EXAMINE CD-PROT-NO-X REPLACING ALL SPACE BY 0.
040600 EDIT-DD-FIELDS-EXIT.
040620 EXIT.
040640
040660******************************
040680* SUBROUTINE TO CHECK DD FIELDS AND MODIFY IF NECESSARY
040700******************************
040720 CHECK-DD-FIELDS.
040740 MOVE 0 TO TRAN-ERR-FLG EDIT-ERROR-FLAG.
040760 IF CD-NAME = SPACE PERFORM DD-ERROR
040780 MOVE DD-MSG-19 TO PRINT-LINE
040800 PERFORM PRINT1D.
040820 IF CD-NCHARS-X IS NOT NUMERIC MOVE 'ITEM LENGTH'
040840 TO DD-NO-NUM MOVE 0 TO CD-NCHARS
040860 PERFORM DD-ERROR
040880 MOVE DD-MSG-18 TO PRINT-LINE PERFORM PRINT1D.
040900 IF CD-FCHAR-X = 'DBMS' MOVE '0000' TO CD-FCHAR-X.
040920 IF CD-FCHAR-X IS NOT NUMERIC
040940 MOVE 'FIRST CHAR LOC'
040960 TO DD-NO-NUM MOVE 0 TO CD-FCHAR
040980 PERFORM DD-ERROR
041000 MOVE DD-MSG-18 TO PRINT-LINE PERFORM PRINT1D.
041020 IF CD-SCALE-X IS NOT NUMERIC MOVE 'SCALE'
041040 TO DD-NO-NUM MOVE 0 TO CD-SCALE
041060 PERFORM DD-ERROR
041080 MOVE DD-MSG-18 TO PRINT-LINE PERFORM PRINT1D.
041100 MOVE 0 TO CD-OFFSET.
041120 IF CD-EDIT-X IS NOT NUMERIC MOVE 'EDIT CODE' TO
041140 DD-NO-NUM MOVE 0 TO CD-EDIT
041160 PERFORM DD-ERROR
041180 MOVE DD-MSG-18 TO PRINT-LINE PERFORM PRINT1D.
041200 IF CD-NREPEATS-X IS NOT NUMERIC MOVE 'SCAN REPEATS'
041220 TO DD-NO-NUM MOVE 0 TO CD-NREPEATS
041240 PERFORM DD-ERROR
041260 MOVE DD-MSG-18 TO PRINT-LINE PERFORM PRINT1D.
041280 IF CD-PROT-NO-X IS NOT NUMERIC MOVE 'PROT REF'
041300 TO DD-NO-NUM MOVE 0 TO CD-PROT-NO
041320 PERFORM DD-ERROR
041340 MOVE DD-MSG-18 TO PRINT-LINE PERFORM PRINT1D.
041360 IF CD-ACT NOT = ' ' AND CD-ACT NOT = 'A' AND
041380 CD-ACT NOT = 'C' AND CD-ACT NOT = 'D'
041400 PERFORM DD-ERROR
041420 MOVE DD-MSG-1 TO PRINT-LINE PERFORM PRINT1D.
041440 IF CD-NME1 = 'X' OR CD-NME2 = 'ZZ'
041460 PERFORM DD-ERROR
041480 MOVE DD-MSG-2 TO PRINT-LINE PERFORM PRINT1D.
041500* *CHECK FOR FCHAR = 0 DISABLED TO PERMIT DBMS DYNAMIC*.
041520* IF CD-FCHAR = 0
041540* PERFORM DD-ERROR
041560* MOVE DD-MSG-3 TO PRINT-LINE PERFORM PRINT1D.
041580* *NOTE: RECORD LENGTH CHECK DISABLED THIS VERSION*.
041600* IF CD-FCHAR GREATER THAN MAX-RECLEN
041620* PERFORM DD-ERROR
041640* MOVE DD-MSG-4 TO PRINT-LINE PERFORM PRINT1D.
041660 IF CD-NCHARS = 0
041680 PERFORM DD-ERROR
041700 MOVE DD-MSG-5 TO PRINT-LINE PERFORM PRINT1D.
041720* *NOTE: ITEM LENGTH CHECK DISABLED THIS VERSION*.
041740* IF CD-NCHARS GREATER THAN MAX-ITEMLEN
041760* PERFORM DD-ERROR
041780* MOVE DD-MSG-6 TO PRINT-LINE PERFORM PRINT1D.
041800 IF CD-TYPE-X = 'A' MOVE '1' TO CD-TYPE.
041820 IF CD-TYPE-X = 'N' MOVE '2' TO CD-TYPE.
041840 IF CD-TYPE-X = 'B' MOVE '6' TO CD-TYPE.
041860 IF CD-TYPE-X NOT = '1' AND CD-TYPE-X NOT = '2' AND
041880 CD-TYPE-X NOT = '6'
041900 PERFORM DD-ERROR
041920 MOVE DD-MSG-7 TO PRINT-LINE PERFORM PRINT1D.
041940 IF CD-SCALE GREATER THAN CD-NCHARS
041960 PERFORM DD-ERROR
041980 MOVE DD-MSG-8 TO PRINT-LINE PERFORM PRINT1D.
042000 IF CD-EDIT-X = '31' MOVE '00' TO CD-EDIT-X.
042020 IF CD-EDIT GREATER THAN MAX-EDIT
042040 PERFORM DD-ERROR
042060 MOVE DD-MSG-9 TO PRINT-LINE PERFORM PRINT1D.
042080 IF CD-PICT NOT = SPACE
042100 PERFORM CHECK-PICT THROUGH CHECK-PICT-EXIT.
042120 IF EDIT-ERROR-FLAG NOT = 0
042122 ADD 1 TO LINE-CTR PERFORM PRINT-TRAN
042126 MOVE DD-MSG-11 TO PRINT-LINE PERFORM PRINT1D
042128 MOVE 0 TO EDIT-ERROR-FLAG.
042160 IF CD-GRPNME = SPACE AND CD-NREPEATS NOT = 0
042180 PERFORM DD-ERROR
042200 MOVE DD-MSG-13 TO PRINT-LINE PERFORM PRINT1D.
042220* MULTIPLY CD-NREPEATS BY CD-NCHARS GIVING WORK-2.
042240* ADD CD-FCHAR TO WORK-2.
042260* IF WORK-2 IS GREATER THAN MAX-RECLEN
042280* PERFORM DD-ERROR
042300* MOVE DD-MSG-14 TO PRINT-LINE PERFORM PRINT1D.
042320 IF CD-GRPNME NOT = SPACE AND CD-NREPEATS = 0
042340 PERFORM DD-ERROR
042360 MOVE DD-MSG-15 TO PRINT-LINE PERFORM PRINT1D.
042380 IF CD-EXCLFLAG = ' ' MOVE '0' TO CD-EXCLFLAG.
042400 IF CD-EXCLFLAG = 'Y' MOVE '1' TO CD-EXCLFLAG.
042420 IF CD-EXCLFLAG = 'N' MOVE '0' TO CD-EXCLFLAG.
042440 IF CD-EXCLFLAG NOT = '0' AND CD-EXCLFLAG NOT = '1'
042460 PERFORM DD-ERROR
042480 MOVE DD-MSG-17 TO PRINT-LINE PERFORM PRINT1D.
042500 IF TRAN-ERR-FLG NOT = 0
042520 MOVE DD-MSG-0 TO PRINT-LINE
042540 PERFORM DISPLAYER THRU DISPLAYER-EXIT
042560 DISPLAY ' ' UPON CONSOLE
042580 PERFORM PRINT1B.
042600 CHECK-DD-FIELDS-EXIT.
042620 EXIT.
042640
042660*****************************************
042680* SUB SUBROUTINE TO PRINT OFFENDING DD TRAN
042700* ON FIRST ERROR ENCOUNTERED.
042720******************************************
042740 DD-ERROR.
042760 ADD 1 TO LINE-CTR.
042780 IF TRAN-ERR-FLG = 0 PERFORM PRINT-TRAN
042800 MOVE 1 TO TRAN-ERR-FLG.
042820 DD-ERROR-EXIT.
042840 EXIT.
042860
042880*****************************
042900* SUBROUTINE TO MOVE DD FIELDS FROM TRAN-WS TO DICT-WS.
042920*****************************
042940 MOVE-DD-FIELDS.
042960 MOVE SPACE TO DICT-DD.
042980 MOVE CD-IDNT TO DD-IDNT.
043000 MOVE CD-NAME TO DD-NAME LAST-DD-NAME.
043020 MOVE CD-TITLE1 TO DD-TITLE1.
043040 MOVE CD-TITLE2 TO DD-TITLE2.
043060 MOVE CD-FCHAR TO DD-FCHAR.
043080 MOVE CD-NCHARS TO DD-NCHARS.
043100 MOVE CD-EDIT TO DD-EDIT.
043120 MOVE CD-TYPE TO DD-TYPE.
043140 MOVE CD-SCALE TO DD-SCALE.
043160 MOVE CD-OFFSET TO DD-OFFSET.
043180 MOVE CD-PICT TO DD-PICT.
043200 MOVE CD-GRPNME TO DD-GRPNME.
043220 MOVE CD-NREPEATS TO DD-NREPEATS.
043240 MOVE CD-STOPPER TO DD-STOPPER.
043260 MOVE CD-PROT-NO TO DD-PROT-NO.
043280 MOVE CD-EXCLFLAG TO DD-EXCLFLAG.
043300 IF CD-NOUPD = 'N' MOVE 'N' TO DD-NOUPD
043310 ELSE MOVE ' ' TO DD-NOUPD.
043320 PERFORM DD-TITLE-LENGTH THROUGH DD-TITLE-LENGTH-EXIT.
043340 IF CD-TYPE NOT EQUAL TO '1' AND CD-EDIT = 0
043360 AND CD-PICT = SPACE AND CD-NCHARS NOT > 18
043380 PERFORM MAKE-OWN-PICT THROUGH MAKE-OWN-PICT-EXIT.
043400 PERFORM MODIFYPICTED THROUGH MODIFY-EXIT.
043420 PERFORM EDIT-LENGTH THROUGH EDIT-LENGTH-EXIT.
043440 PERFORM GETGRPLEN THRU GETGRPLENX.
043460 MOVE PACKED-DATE TO DD-LAST-UPDATE.
043480 MOVE-DD-FIELDS-EXIT.
043500 EXIT.
043520
043540*****************************
043560* SUBROUTINE TO PRINT DD COLUMN HEADINGS.
043580*****************************
043600 PRINT-DD-HEAD.
043620 MOVE HEAD-5 TO PRINT-LN.
043640 PERFORM PRINT1.
043660 MOVE DD-HEAD1 TO PRINT-LN.
043680 PERFORM PRINT1.
043700 MOVE DD-HEAD-2 TO PRINT-LN.
043720 PERFORM PRINT1.
043740 MOVE DD-HYPHS TO PRINT-LN.
043760 PERFORM PRINT1B.
043780
043800*****************************
043820* SUBROUTINE TO PRINT DD FIELDS FROM DICT-WS.
043840*****************************
043860 PRINT-DD-FIELDS.
043880 MOVE SPACE TO DD-DATA.
043900 MOVE DD-IDNT TO DD-DATA-IDNT.
043920 MOVE DD-NAME TO DD-NAME-PRT.
043940 MOVE DD-TITLE1 TO DD-TITLE1-PRT.
043960 MOVE DD-TITLE2 TO DD-TITLE2-PRT.
043980 MOVE DD-NTCHARS TO NTCHAR-PRT.
043990 MOVE DD-NCHARS TO NCHAR-PRT.
044000 MOVE DD-NECHARS TO NECHAR-PRT.
044002 MOVE DD-FCHAR TO DD-FCHAR-PRT.
044004 IF DD-PROT-NO > UNLOCKED-LEVEL
044006 OR COPY-LEVEL > UNLOCKED-LEVEL
044010 MOVE SPACES TO DD-FCHAR-PRT.
044012 MOVE DD-PROT-NO-X TO DP-PRT.
044014 IF DD-EXCLFLAG = 1 MOVE 'E' TO DD-EXCLFLAG-PRT
044016 MOVE DASH TO DP-PROT-DASH.
044018 IF DD-PROT-NO-X = ' ' OR '00'
044020 MOVE SPACE TO PROT-PRT
044022 ELSE IF DD-PROT-NO > UNLOCKED-LEVEL
044024 MOVE '** ' TO PROT-PRT.
044100 IF DD-FCHAR = 0 MOVE 'DBMS' TO DD-FCHAR-PRT-DBS.
044140 MOVE DD-EDIT TO DD-EDIT-PRT.
044160 IF DD-TYPE = '1' MOVE 'ALPHA' TO DD-TYPE-PRT.
044180 IF DD-TYPE = '2' MOVE 'NUM ' TO DD-TYPE-PRT.
044200 IF DD-TYPE = '6' MOVE 'BINARY' TO DD-TYPE-PRT.
044220 MOVE DD-SCALE TO SCL-PRT.
044240 MOVE DD-PICT TO PICT-PRT.
044260 MOVE DD-GRPLEN TO GRPLEN-PRT.
044280 IF DD-NREPEATS = '00' OR ' ' MOVE SPACE TO SCAN-PRT
044300 ELSE MOVE DASH TO DD-SCAN-DASH1 DD-SCAN-DASH2
044320 MOVE DD-GRPNME TO GRPNME-PRT
044340 MOVE DD-NREPEATS TO NREPEATS-PRT
044360 MOVE DD-STOPPER TO STOPPER-PRT.
044500 MOVE DD-LAST-UPDATE TO DATE-WORK.
044520 PERFORM DATE-SLASHER.
044540 IF DATE-WORK = SPACE MOVE SPACE TO DD-UPDATE-PRT ELSE
044560 MOVE SLASHED-DATE TO DD-UPDATE-PRT.
044580 MOVE DD-DATA TO PRINT-LN.
044600 PERFORM PRINT1.
044620 IF TRAN-ERR-FLG = 1 MOVE SPACE TO PRINT-LINE
044640 PERFORM PRINT1.
044660
044680*****************************
044700* SUBROUTINE TO EDIT FIELDS IN PD TRAN INPUT
044720*****************************
044740 EDIT-PD-FIELDS.
044760 EXAMINE CP-PROT-NO-X REPLACING ALL SPACE BY 0.
044780 EXAMINE CP-LINE-X REPLACING ALL SPACE BY 0.
044800 EDIT-PD-FIELDS-EXIT.
044820 EXIT.
044840
044860******************************
044880* SUBROUTINE TO CHECK FIELDS IN PD TRAN INPUT
044900******************************
044920 CHECK-PD-FIELDS.
044940 MOVE 0 TO TRAN-ERR-FLG.
044960 IF CP-PROT-NO-X NOT NUMERIC
044980 MOVE 1 TO TRAN-ERR-FLG PERFORM PRINT-TRAN
045000 MOVE PD-MSG-1 TO PRINT-LINE
045020 PERFORM PRINT1D
045040 MOVE PD-MSG-0 TO PRINT-LINE
045060 PERFORM DISPLAYER THRU DISPLAYER-EXIT
045080 DISPLAY ' ' UPON CONSOLE
045100 PERFORM PRINT1B.
045120 MOVE 1 TO CP-LINE.
045140 MOVE 0 TO CP-DATE-FLAG.
045160 CHECK-PD-FIELDS-EXIT.
045180 EXIT.
045200
045220*****************************
045240* SUBROUTINE TO MOVE PD FIELDS FROM TRAN-WS TO DICT-WS.
045260*****************************
045280 MOVE-PD-FIELDS.
045300 MOVE SPACE TO DICT-PD.
045320 MOVE '1' TO DF-PROT.
045340 MOVE CP-IDNT TO DP-IDNT.
045360 MOVE CP-PROT-NO TO DP-PROT-NO.
045380 MOVE CP-DATE-FLAG TO DP-DATE-FLAG.
045400 MOVE CP-LINE TO DP-LINE.
045420 MOVE PACKED-DATE TO DP-LAST-UPDATE.
045440 MOVE CP-PASSWORD TO DP-TEXT.
045460 PERFORM SCRAMBLE-PW THRU SCRAMBLE-PW-EXIT.
045480 MOVE-PD-FIELDS-EXIT.
045500 EXIT.
045520
045540*****************************
045560* SUBROUTINE TO PRINT PD FIELDS FROM DICT-WS
045580*****************************
045600 PRINT-PD-FIELDS.
045620 MOVE SPACE TO PD-DATA.
045640 MOVE 'PD' TO PD-DATA-IDNT.
045660 MOVE DP-PROT-NO TO DP-PROT-NO-PRINT.
045680 MOVE DP-TEXT TO PW-TEXT-HOLDER.
045700 PERFORM UNSCRAMBLE-PW THRU UNSCRAMBLE-PW-EXIT.
045710 IF UNLOCKED-LEVEL < DP-PROT-NO
045720 MOVE '(Locked)' TO DP-TEXT-PRINT
045740 ELSE MOVE DP-TEXT TO DP-TEXT-PRINT.
045760 MOVE PW-TEXT-HOLDER TO DP-TEXT.
045780 MOVE DP-LAST-UPDATE TO DATE-WORK.
045800 PERFORM DATE-SLASHER.
045820 IF DATE-WORK = SPACE MOVE SPACE TO DP-UPDATE-PRINT ELSE
045840 MOVE SLASHED-DATE TO DP-UPDATE-PRINT.
045860 MOVE PD-DATA TO PRINT-LN.
045880 PERFORM PRINT1.
045900 PRINT-PD-FIELDS-EXIT.
045920 EXIT.
045940
045960********************
045980* SUBROUTINE TO MOVE COMMENT (CD) FIELDS TO DICT-WS.
046000********************
046020 MOVE-CD-FIELDS.
046040 MOVE SPACE TO DICT-CD.
046060 MOVE 'CD' TO DC-IDNT.
046080 MOVE CC-NO TO DC-NO.
046100 MOVE CC-TEXT TO DC-TEXT.
046120 MOVE PACKED-DATE TO DC-LAST-UPDATE.
046140 MOVE-CD-FIELDS-EXIT.
046160 EXIT.
046180
046200********************
046220* SUBROUTINE TO PRINT COMMENT (CD) FIELDS FROM DICT-WS.
046240********************
046260 PRINT-CD-FIELDS.
046280 MOVE SPACE TO CD-DATA.
046300 MOVE 'CD' TO CD-DATA-IDNT.
046320 MOVE DC-NO TO DC-NO-PRT.
046340 MOVE DC-TEXT TO DC-TEXT-PRT.
046360 MOVE DC-LAST-UPDATE TO DATE-WORK.
046380 PERFORM DATE-SLASHER.
046400 IF DATE-WORK = SPACE MOVE SPACE TO DC-UPDATE-PRT ELSE
046420 MOVE SLASHED-DATE TO DC-UPDATE-PRT.
046440 MOVE CD-DATA TO PRINT-LN.
046460 PERFORM PRINT1.
046480 PRINT-CD-FIELDS-EXIT.
046500 EXIT.
046520
046540*************************************
046560* EDIT RD, AD, AND SD FIELDS.
046580***********************************
046600 EDIT-RD-FIELDS.
046620 EXAMINE RD-ORIGIN-X REPLACING ALL SPACE BY 0.
046640 EXAMINE RD-LENGTH-X REPLACING ALL SPACE BY 0.
046660 EDIT-RD-FIELDS-EXIT.
046680 EXIT.
046700
046720*************************************
046740* CHECK RD, AD, AND SD FIELDS.
046760*************************************
046780 CHECK-RD-FIELDS.
046800 MOVE 0 TO TRAN-ERR-FLG.
046820 IF RD-NAME = SPACE
046840 PERFORM DD-ERROR
046860 MOVE DD-MSG-19 TO PRINT-LINE
046880 PERFORM PRINT1D.
046900 IF RD-ORIGIN-X IS NOT NUMERIC
046920 MOVE 'ORIGIN' TO DD-NO-NUM
046940 MOVE 0 TO RD-ORIGIN
046960 PERFORM DD-ERROR
046980 MOVE DD-MSG-18 TO PRINT-LINE
047000 PERFORM PRINT1D.
047020 IF RD-LENGTH-X IS NOT NUMERIC
047040 MOVE 'LENGTH' TO DD-NO-NUM
047060 MOVE 0 TO RD-LENGTH
047080 PERFORM DD-ERROR
047100 MOVE DD-MSG-18 TO PRINT-LINE
047120 PERFORM PRINT1D.
047140 CHECK-RD-FIELDS-EXIT.
047160 EXIT.
047180
047200*********************************
047220* MOVE RD, AD, AND SD FIELDS FROM TRAN TO DICT-WS.
047240*********************************
047260 MOVE-RD-FIELDS.
047280 MOVE RD-IDNT TO DR-IDNT.
047300 MOVE RD-NAME TO DR-NAME.
047320 MOVE RD-ORIGIN TO DR-ORIGIN.
047340 MOVE RD-LENGTH TO DR-LENGTH.
047360 MOVE RD-TYPE TO DR-TYPE.
047380 MOVE RD-TEXT TO DR-TEXT.
047400 MOVE-RD-FIELDS-EXIT.
047420 EXIT.
047440
047460********************************
047480* SUBROUTINE TO PRINT RD, AD, OR SD FIELDS FROM DICT WS.
047500********************************
047520 PRINT-RD-FIELDS.
047540 MOVE SPACE TO RD-DATA.
047560 MOVE DR-IDNT TO RD-DATA-IDNT.
047580 MOVE DR-NAME TO RD-DATA-NAME.
047584 IF UNLOCKED-LEVEL NOT < PROTECTED-LEVEL
047600 MOVE DR-ORIGIN TO RD-DATA-ORIGIN
047620 MOVE DR-LENGTH TO RD-DATA-LENGTH.
047640 MOVE DR-TYPE TO RD-DATA-TYPE.
047660 MOVE DR-TEXT TO RD-DATA-TEXT.
047680 MOVE DR-LAST-UPDATE TO DATE-WORK.
047700 PERFORM DATE-SLASHER.
047720 IF DATE-WORK = SPACE MOVE SPACE TO RD-DATA-UPDATE
047740 ELSE MOVE SLASHED-DATE TO RD-DATA-UPDATE.
047760 MOVE RD-DATA TO PRINT-LINE.
047780 PERFORM PRINT2.
047800 PRINT-RD-FIELDS-EXIT.
047820 EXIT.
047840
047860*****************************
047880* SUBROUTINE TO GO TO A NEW PAGE AND PRINT GENERAL HEADING.
047900*****************************
047920 NEW-PAGE.
047940 MOVE HEAD-1 TO PRINT-LN.
047960 WRITE PRINT-LINE AFTER ADVANCING TOP-OF-PAGE.
047980 ADD 1 TO PAGE-CTR.
048000 MOVE PAGE-CTR TO PAGE-OUT.
048020 MOVE HEAD-2 TO PRINT-LN.
048040 WRITE PRINT-LINE AFTER ADVANCING 1 LINES.
048060 MOVE HEAD-3 TO PRINT-LN.
048080 WRITE PRINT-LINE AFTER ADVANCING 1 LINES.
048100 MOVE ' ' TO PRINT-LINE.
048120 WRITE PRINT-LINE AFTER ADVANCING 1 LINES.
048140 MOVE 3 TO LINE-CTR.
048160
048180*********************************
048200* THIS SUBROUTINE SCRAMBLES PASSWORDS.
048220*********************************
048240 SCRAMBLE-PW.
048260 MOVE DP-CHAR (1) TO PW-CHAR (10).
048280 MOVE DP-CHAR (2) TO PW-CHAR (9).
048300 MOVE DP-CHAR (3) TO PW-CHAR (6).
048320 MOVE DP-CHAR (4) TO PW-CHAR (12).
048340 MOVE DP-CHAR (5) TO PW-CHAR (3).
048360 MOVE DP-CHAR (6) TO PW-CHAR (2).
048380 MOVE LAST-DD-CHAR (1) TO PW-CHAR (1).
048400 MOVE LAST-DD-CHAR (2) TO PW-CHAR (7).
048420 MOVE LAST-DD-CHAR (3) TO PW-CHAR (4).
048440 MOVE LAST-DD-CHAR (4) TO PW-CHAR (11).
048460 MOVE LAST-DD-CHAR (5) TO PW-CHAR (8).
048480 MOVE LAST-DD-CHAR (6) TO PW-CHAR (5).
048500 ADD PW-MASK1 TO PW-WORK1.
048520 ADD PW-MASK2 TO PW-WORK2.
048540 MOVE PW-CHAR (1) TO DP-CHAR (1).
048560 MOVE PW-CHAR (2) TO DP-CHAR (2).
048580 MOVE PW-CHAR (3) TO DP-CHAR (3).
048600 MOVE PW-CHAR (4) TO DP-CHAR (4).
048620 MOVE PW-CHAR (5) TO DP-CHAR (5).
048640 MOVE PW-CHAR (6) TO DP-CHAR (6).
048660 MOVE PW-CHAR (7) TO DP-CHAR (7).
048680 MOVE PW-CHAR (8) TO DP-CHAR (8).
048700 MOVE PW-CHAR (9) TO DP-CHAR (9).
048720 MOVE PW-CHAR (10) TO DP-CHAR (10).
048740 MOVE PW-CHAR (11) TO DP-CHAR (11).
048760 MOVE PW-CHAR (12) TO DP-CHAR (12).
048780 SCRAMBLE-PW-EXIT.
048800 EXIT.
048820
048840*******************************
048860* THIS SUBROUTINE UNSCRAMBLES PASSWORDS.
048880*******************************
048900 UNSCRAMBLE-PW.
048920 MOVE DP-CHAR (1) TO PW-CHAR (1).
048940 MOVE DP-CHAR (2) TO PW-CHAR (2).
048960 MOVE DP-CHAR (3) TO PW-CHAR (3).
048980 MOVE DP-CHAR (4) TO PW-CHAR (4).
049000 MOVE DP-CHAR (5) TO PW-CHAR (5).
049020 MOVE DP-CHAR (6) TO PW-CHAR (6).
049040 MOVE DP-CHAR (7) TO PW-CHAR (7).
049060 MOVE DP-CHAR (8) TO PW-CHAR (8).
049080 MOVE DP-CHAR (9) TO PW-CHAR (9).
049100 MOVE DP-CHAR (10) TO PW-CHAR (10).
049120 MOVE DP-CHAR (11) TO PW-CHAR (11).
049140 MOVE DP-CHAR (12) TO PW-CHAR (12).
049160 SUBTRACT PW-MASK1 FROM PW-WORK1.
049180 SUBTRACT PW-MASK2 FROM PW-WORK2.
049200 MOVE SPACE TO DP-TEXT.
049220 MOVE PW-CHAR (10) TO DP-CHAR (1).
049240 MOVE PW-CHAR (9) TO DP-CHAR (2).
049260 MOVE PW-CHAR (6) TO DP-CHAR (3).
049280 MOVE PW-CHAR (12) TO DP-CHAR (4).
049300 MOVE PW-CHAR (3) TO DP-CHAR (5).
049320 MOVE PW-CHAR (2) TO DP-CHAR (6).
049340 UNSCRAMBLE-PW-EXIT.
049360 EXIT.
049380
049400*****************************
049420* THIS SUBROUTINE FINDS THE LENGTH OF THE EDIT
049440* PIC IF THERE IS ONE AND MOVES IT
049460* INTO FIELD DD-NECHARS. IF THERE IS NO EDIT PICTURE
049480* THE NUMBER OF CHARACTERS IN THE ITEM (FIELD DD-NCHARS)
049500* IS MOVED INTO DD-NECHARS.
049520*****************************
049540 EDIT-LENGTH.
049560 SET PIX TO 19.
049580 MOVE DD-PICT TO PICT-REDEF.
049600 EDIT-LENGTH-LOOP.
049620 IF PICTCHAR (PIX) IS NOT EQUAL TO SPACE
049640 GO TO EDIT-LENGTH-DONE.
049660 SET PIX DOWN BY 1.
049680 IF PIX IS NOT EQUAL TO 0 GO TO EDIT-LENGTH-LOOP.
049700 SET PIX TO DD-NCHARS.
049720 EDIT-LENGTH-DONE.
049740 SET DD-NECHARS TO PIX.
049760 EDIT-LENGTH-EXIT.
049780 EXIT.
049800
049820*****************************
049840* THIS SUBROUTINE FINDS THE LONGEST
049860* LENGTH OF THE TOP OR BOTTOM COLUMN DD-TITLWS
049880* AND STORES IT IN FIELD DD-NTCHARS.
049900*****************************
049920 DD-TITLE-LENGTH.
049940 SET TTX TO 10. SET BTX TO 10.
049960 MOVE DD-TITLE1 TO TOP-TITLE.
049980 MOVE DD-TITLE2 TO BOTTOM-TITLE.
050000 DD-TITLE-LENGTH-LOOP.
050020 IF TOP-TITLE-CHAR (TTX) IS NOT EQUAL TO
050040 SPACE GO TO DD-TITLE-LENGTH-DONE.
050060 IF BOTTOM-TITLE-CHAR (BTX) IS NOT EQUAL TO
050080 SPACE GO TO DD-TITLE-LENGTH-DONE.
050100 SET TTX DOWN BY 1. SET BTX DOWN BY 1.
050120 IF TTX IS NOT EQUAL TO 1 GO TO DD-TITLE-LENGTH-LOOP.
050140 DD-TITLE-LENGTH-DONE.
050160 SET DD-NTCHARS TO TTX.
050180 DD-TITLE-LENGTH-EXIT.
050200 EXIT.
050220
050240*****************************
050260* SUBROUTINE TO TRANSLATE OLD/NEW EDIT CODES.
050280*****************************
050300 MODIFYPICTED.
050320 IF CD-EDIT EQUAL TO 0 GO TO MOD4.
050340 IF CD-EDIT GREATER THAN 30 GO TO MODIFY-EXIT.
050360* *EDIT CODE ABOVE 31 INDICATES USER PLANS TO
050380* EDIT THIS ITEM VIA USER EXIT 9*.
050400 IF CD-PICT EQUAL TO SPACE GO TO MOD3.
050420* *HAVE BOTH EDIT CODE AND PICTURE--COMPARE INPUT
050440* PIC WITH STANDARD PIC AND IF DIFFERENT
050460* MAKE IT A NON-STANDARD CODE 31*.
050480 MOVE CD-EDIT TO NUMEDXAN.
050500 IF IQ-PICTURE (NUMEDX) EQUAL TO CD-PICT
050520 MOVE CD-EDIT TO DD-EDIT GO TO MOD2.
050540 MOD1.
050560 MOVE 31 TO CD-EDIT. MOVE 31 TO DD-EDIT.
050580 MOD2.
050600 MOVE CD-PICT TO DD-PICT.
050620 GO TO MODIFY-EXIT.
050640* *HERE FOR EDIT CODE SPECIFIED WITH NO PICTURE
050660* GIVEN--THIS MUST BE A STANDARD PICTURE*.
050680 MOD3.
050700 MOVE CD-EDIT TO NUMEDXAN.
050720 MOVE IQ-PICTURE (NUMEDX) TO CD-PICT.
050740 MOVE CD-PICT TO DD-PICT.
050760 GO TO MODIFY-EXIT.
050780 MOD4.
050800 IF CD-PICT EQUAL TO SPACE
050820 MOVE 00 TO DD-EDIT GO TO MODIFY-EXIT.
050840 GO TO MOD1.
050860 MODIFY-EXIT. EXIT.
050880
050900***************************************************
050920* SUBROUTINE TO CREATE OWN PIC FOR NUMERICS WITH
050940* NO SPECIFIED PICTURES.
050960***************************************************
050980 MAKE-OWN-PICT.
051000 MOVE SPACE TO PICT-REDEF.
051020 MOVE 'S' TO PICTCHAR (1).
051040 SET PIX TO CD-NCHARS. SET PIX UP BY 2.
051060 IF CD-SCALE = 0 GO TO MAKE-OWN-PICT-INTEGER.
051080 MOVE CD-SCALE TO J.
051084 IF PIX > 19 SET PIX TO 19.
051100 MAKE-OWN-PICT-FRACT.
051120 MOVE 9 TO PICTCHAR (PIX).
051140 SET PIX DOWN BY 1.
051160 SUBTRACT 1 FROM J.
051180 IF J = 0 MOVE '.' TO PICTCHAR (PIX)
051200 ELSE GO TO MAKE-OWN-PICT-FRACT.
051220 MAKE-OWN-PICT-INTEGER.
051222 IF PIX > 20 SET PIX TO 20.
051240 SET PIX DOWN BY 1.
051260 IF PIX = 1 GO TO MAKE-OWN-PICT-DONE.
051280 MOVE 9 TO PICTCHAR (PIX).
051300 MAKE-OWN-PICT-INTEGER-1.
051320 SET PIX DOWN BY 1.
051340 IF PIX = 1 GO TO MAKE-OWN-PICT-DONE.
051360 MOVE 'Z' TO PICTCHAR (PIX).
051380 GO TO MAKE-OWN-PICT-INTEGER-1.
051400 MAKE-OWN-PICT-DONE.
051420 MOVE PICT-REDEF TO CD-PICT DD-PICT.
051440 MOVE 31 TO DD-EDIT.
051460 MAKE-OWN-PICT-EXIT.
051480 EXIT.
051500
051520*********************************************
051540* SUB SUBROUTINE TO CHECK SPECIAL PICTURES VERSUS
051560* ITEM TYPE SCALE AND INSERTION CHARACTERS. IF DISCREPANCY
051580* IT SETS EDIT-ERROR-FLAG TO 1 AND GENERATES A NEW PICTURE.
051600***********************************************
051620 CHECK-PICT.
051640 MOVE 0 TO J.
051660 MOVE 0 TO EDIT-ERROR-FLAG.
051680 IF CD-PICT = SPACE GO TO CHECK-PICT-EXIT.
051700 MOVE CD-PICT TO PICT-REDEF.
051720 IF CD-TYPE-X = '1' OR 'A'
051740 GO TO CHECK-PICT-ALPHA.
051760 CHECK-PICT-NUM.
051780* *CHECK INSERTION CHARS 9 Z $ FOR NUMERIC ITEM*.
051800 MOVE 0 TO K L.
051820 SET PIX TO 1.
051840 CHECK-PICT-DEC.
051860 IF PIX GREATER THAN 19 GO TO CHECK-PICT-DEC2.
051880 MOVE PICTCHAR (PIX) TO ELEM-CHAR.
051900 IF ELEM-CHAR = ' ' GO TO CHECK-PICT-DEC2.
051920 IF ELEM-CHAR = '9' OR 'Z' OR 'R' ADD 1 TO L.
051940 IF ELEM-CHAR = '$' ADD 1 TO L MOVE 1 TO J.
051960 IF ELEM-CHAR NOT = '.' SET PIX UP BY 1
051980 GO TO CHECK-PICT-DEC.
052000 CHECK-PICT-DEC1.
052020 IF ELEM-CHAR = '9' OR 'Z' OR 'R' OR '$'
052040 ADD 1 TO K ADD 1 TO L.
052060 SET PIX UP BY 1.
052080 IF PIX GREATER THAN 19 GO TO CHECK-PICT-DEC2.
052100 MOVE PICTCHAR (PIX) TO ELEM-CHAR.
052120 IF ELEM-CHAR NOT = ' ' GO TO CHECK-PICT-DEC1.
052140 CHECK-PICT-DEC2.
052160 SUBTRACT J FROM L.
052180* * ABOVE TAKES ACCOUNT OF LEADING $*.
052200 IF L NOT = CD-NCHARS GO TO CHECK-PICT-ERROR.
052220 IF K NOT = CD-SCALE GO TO CHECK-PICT-ERROR.
052240 GO TO CHECK-PICT-EXIT.
052260 CHECK-PICT-ALPHA.
052280 EXAMINE CD-PICT TALLYING ALL 'X'.
052300 IF TALLY NOT = CD-NCHARS GO TO CHECK-PICT-ERROR.
052320 GO TO CHECK-PICT-EXIT.
052340 CHECK-PICT-ERROR.
052360 MOVE 1 TO EDIT-ERROR-FLAG.
052380 CHECK-PICT-EXIT.
052400 EXIT.
052420
052440*************************
052460* CALCULATE GROUP LENGTH.
052480**************************
052500 GETGRPLEN.
052520 IF DD-NREPEATS = '00' OR ' '
052540 MOVE 0 TO DD-GRPLEN
052560 GO TO GETGRPLENX.
052580 IF N-SCANITEMS = 0 GO TO GETGRPLEN3.
052600 MOVE 1 TO I.
052620 GETGRPLEN1.
052640 IF I GREATER THAN N-SCANITEMS GO TO GETGRPLEN3.
052660 IF DD-GRPNME = GROUP-NAME-TAB (I)
052680 GO TO GETGRPLEN4.
052700**THIS ROUTINE EXPECTS THAT THE FIRST APPEARANCE OF A
052720* FAMILY GROUP NAME IS ALSO THE FATHER OF ALL WITHIN
052740* THAT SAME FAMILY AND AS SUCH THE FIRST APPEARANCE OF A
052760* SPECIFIC FAMILY NAME DEFINES THE GRPLEN FOR THAT
052780* FAMILY--
052800* ALSO THIS VERSION OF IQD WILL NOT PROPERLY
052820* HANDLE UPDATES TO SCAN GROUP LTH-- ALL SCAN INFO
052840* MUST BE REENTERED*.
052860 ADD 1 TO I.
052880 GO TO GETGRPLEN1.
052900 GETGRPLEN3.
052920 ADD 1 TO N-SCANITEMS. MOVE N-SCANITEMS TO I.
052940 MOVE DD-GRPNME TO GROUP-NAME-TAB (I).
052960 MOVE DD-NCHARS TO GROUP-LEN-TAB (I).
052980 GETGRPLEN4.
053000 MOVE GROUP-LEN-TAB (I) TO DD-GRPLEN.
053020 IF DD-GRPLEN IS LESS THAN DD-NCHARS
053040 PERFORM PRINT-DD-FIELDS
053060 MOVE DD-MSG-20 TO PRINT-LINE
053080 PERFORM PRINT1D.
053100 GETGRPLENX.
053120 EXIT.
053140
053160**************************************************************
053180* SUBROUTINE TO PASS A DICTIONARY TO SEE IF IT CAN
053200* BE UPDATED. IT CHECKS THE UPDATING PASSWORD IN THE FD TRAN
053220* VERSUS THE PD'S IN THE DICTIONARY. THE LEVEL OF THE HIGHEST
053240* PD IS LEFT IN PROTECTED-LEVEL AND THE LEVEL OF THE UPDATING
053260* PASSWORD IS LEFT IN UNLOCKED-LEVEL.
053280* THIS SUBROUTINE DEPENDS ON THE DICTIONARY'S BEING
053300* POSITIONED AT THE FD AND ON THE FD'S BEING IN
053320* DICT-FD AND THE TRANSACTION'S BEING IN TRAN-FD.
053340*****************************************************************
053360
053380 DICT-UNLOCKER.
053400 MOVE 0 TO DICT-LOCK UNLOCKED-LEVEL PROTECTED-LEVEL.
053420 IF CF-PASSWORD = UNIVERSAL-PASSWORD
053440 MOVE 99 TO UNLOCKED-LEVEL
053460 GO TO DICT-UNLOCKER-EXIT.
053470
053480 DICT-UNLOCKER-LOOP.
053500 READ QPDICT INTO DICT-WS AT END
053520 GO TO DICT-UNLOCKER-DONE.
053540 IF DF-IDNT = 'FD' GO TO DICT-UNLOCKER-DONE.
053560 IF DF-IDNT NOT = 'PD' GO TO DICT-UNLOCKER-LOOP.
053580 IF DP-PROT-NO > PROTECTED-LEVEL
053600 MOVE DP-PROT-NO TO PROTECTED-LEVEL.
053620 MOVE DP-TEXT TO PW-TEXT-HOLDER.
053640 PERFORM UNSCRAMBLE-PW THRU UNSCRAMBLE-PW-EXIT.
053660 IF CF-PASSWORD = DP-TEXT
053680 MOVE DP-PROT-NO TO UNLOCKED-LEVEL.
053700 GO TO DICT-UNLOCKER-LOOP.
053720
053740 DICT-UNLOCKER-DONE.
053760 IF PROTECTED-LEVEL > UNLOCKED-LEVEL
053780 MOVE 1 TO DICT-LOCK.
053800
053820 DICT-UNLOCKER-EXIT.
053840 EXIT.
053860