This program reads IMS database segments and creates a sequential (flat) file that will be input into an IMS-to-DB2 database conversion program.
COBOL IMS sample program – explained how to access IMS segments
******************************************************************
IDENTIFICATION DIVISION.
******************************************************************
PROGRAM-ID. IMSBATCH.
AUTHOR. ABC.
INSTALLATION. DEPARTMENT.
DATE-WRITTEN. DATE XX/XX/XX.
DATE-COMPILED.
******************************************************************
ENVIRONMENT DIVISION.
****************************************************************
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-370.
OBJECT-COMPUTER. IBM-370.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT OUTFILE ASSIGN TO UT-S-OUTFILE.
******************************************************************
DATA DIVISION.
******************************************************************
FILE SECTION.
FD OUTFILE
RECORD IS VARYING IN SIZE FROM 383 TO 22727 CHARACTERS RECORDING MODE IS V
BLOCK CONTAINS 0 RECORDS
LABEL RECORDS ARE STANDARD
DATA RECORD IS O-PLT.
* 283
01 O-PLT.
05 O-PLT-DATA-AREA.
10 O-PLTROOT-PREFIX PIC X(001).
10 O-PLTROOT-NAME PIC X(008).
10 O-PLTROOT-TITLE PIC X(050).
10 O-PLTROOT-TERM-PRT-TABLE PIC X(200).
10 O-PLT-SEQ PIC 9(008).
10 O-PLTPE-SEQ-LAST PIC 9(008).
10 O-SEGPROF-SEQ-LAST PIC 9(008).
* 44
05 O-PLTPE.
10 O-PLTPE-KEY-SEQ PIC 9(03).
10 O-PLTPE-TYPE PIC X(01) . 10 O-PLTPE-NAME PIC X(08).
10 O-PLTPE-ACCESS PIC X(01).
10 O-PLTPE-TITLE PIC X(30).
10 O-PLTPE-COURTPRF PIC X(01).
* 56
05 O-SEGPROF OCCURS 400 TIMES DEPENDING ON W-SEGPROF-SEQ-LAST
INDEXED BY O-SEGPROF-INDEX.
10 O-SEGPROF-SEQ PIC 9(08).
10 O-SEGPROF-KEY-PREFIX PIC X(01).
10 O-SEGPROF-KEY-SUFFIX PIC X(08).
10 O-SEGPROF-PLT-NAME PIC X(08).
10 O-SEGPROF-NOTE PIC X(30).
10 O-SEGPROF-ACCESS PIC X(01).
WORKING-STORAGE SECTION.
01 W-TABLES.
05 W-PLT-DATA-AREA.
10 W-PLTROOT-PREFIX PIC X(001).
10 W-PLTROOT-NAME PIC X(008).
10 W-PLTROOT-TITLE PIC X(050).
10 W-PLTROOT-TERM-PRT-TABLE PIC X(200).
10 W-PLT-SEQ PIC 9(008) VALUE 0.
10 W-PLTPE-SEQ-LAST-LIT PIC X(019) VALUE ' W-PLTPE-SEQ-LAST= '.
10 W-PLTPE-SEQ-LAST PIC 9(008).
10 W-SEGPROF-SEQ-LAST-LIT PIC X(022) VALUE ' W-SEGPROF-SEQ-LAST=.
10 W-SEGPROF-SEQ-LAST PIC 9(008).
05 W-PLTPE OCCURS 1 TO 400 TIMES DEPENDING ON W-PLTPE-SEQ-LAST
INDEXED BY W-PLTPE-INDEX.
10 W-PLTPE-TYPE PIC X(01) . 88 PLTPE-MENU VALUE 'M'.
88 PLTPE-PROGRAM VALUE 'P'.
10 W-PLTPE-NAME PIC X(08).
10 W-PLTPE-KEY-SEQ PIC 9(03).
10 W-PLTPE-ACCESS PIC X(01).
88 PLTPE-ACCESS-VALUE VALUES ARE '0' THRU '9'.
10 W-PLTPE-TITLE PIC X(30).
10 W-PLTPE-COURTPRF PIC X(01).
88 W-PLTPE-COURTPRF-YES VALUE 'Y'.
88 W-PLTPE-COURTPRF-NO VALUE 'N'.
05 W-SEGPROF OCCURS 1 TO 400 TIMES DEPENDING ON
W-SEGPROF-SEQ-LAST
INDEXED BY W-SEGPROF-INDEX.
10 W-SEGPROF-KEY-PREFIX PIC X(01).
10 W-SEGPROF-KEY-SUFFIX PIC X(08).
10 W-SEGPROF-PLT-NAME PIC X(08).
10 W-SEGPROF-NOTE PIC X(30).
10 W-SEGPROF-SECURITY-TABLE PIC X(400).
01 DLI-FUNCTION-CODES.
05 EQ PIC X(02) VALUE ' ='.
05 GE PIC X(02) VALUE '>='.
05 GT PIC X(02) VALUE ' >'.
05 GU PIC X(04) VALUE 'GU '.
05 GHU PIC X(04) VALUE 'GHU '.
05 GN PIC X(04) VALUE 'GN '.
05 GHN PIC X(04) VALUE 'GHN '.
05 GNP PIC X(04) VALUE 'GNP '.
05 GHNP PIC X(04) VALUE 'GHNP'.
05 DLET PIC X(04) VALUE 'DLET'.
05 ISRT PIC X(04) VALUE 'ISRT'.
05 REPL PIC X(04) VALUE 'REPL'.
05 CHKP PIC X(04) VALUE 'CHKP'.
05 XRST PIC X(04) VALUE 'XRST'.
05 PCB PIC X(04) VALUE 'PCB '.
05 FUNCTION-CODE PIC X(04) VALUE ' '.
05 TERMINATE-DLI PIC X(04) VALUE 'TERM'.
05 PARM-COUNT PIC S9(08) COMP VALUE +1.
* 05 PSB-READ PIC X(8) VALUE 'MUPROFRD'.
01 DLI-STATUS-CODES.
05 GET-GOOD PIC X(02) VALUE SPACE.
05 GET-NOT-FOUND PIC X(02) VALUE 'GE'.
05 GET-END-DB PIC X(02) VALUE 'GB'.
05 GN-CROSS-BOUNDARY PIC X(02) VALUE 'GA'.
******************************************************
THESE SSA'S ARE FROM THE COPY BOOK SECMSSA
********************************************************
READ 01 = GU MENUROOT(PREFIX =P)
01 MENUROOT-SSA-PREFIX-P.
05 FILLER PIC X(17) VALUE 'MENUROOT(PREFIX '.
05 MENUROOT-SSA-OPER PIC X(02) VALUE ' ='.
05 MENUROOT-SSA-KEY.
10 MENUROOT-SSA-PREFIX PIC X(01) VALUE 'P'.
05 FILLER PIC XX VALUE ')'.
01 PLTROOT-LIT PIC X(10) VALUE ' PLTROOT= '.
01 PLTROOT.
05 PLT-DATA-AREA.
10 PLTROOT-KEY.
15 PLTROOT-PREFIX PIC X(1).
15 PLTROOT-NAME PIC X(08).
10 PLTROOT-TITLE PIC X(50).
10 PLTROOT-PFKEY-TABLE.
15 PLTROOT-PFKEY-RECORD
OCCURS 24 TIMES
INDEXED BY PLTROOT-PFKEY-INDEX.
20 PLTROOT-PFKEY PIC X(10).
88 VALID-PFKEY-VALUES VALUES ARE 'DISPLAY' 'UPDATE' 'FIND'
'BOTTOM' 'UP' 'DOWN'
'SWAP' 'SPLIT' 'MENU'
'PRINT' 'CLEAR' 'SOFTEXIT'
'LIST' 'TOP' 'RETURN'.
10 PLTROOT-TERMINAL-PRINTER-TABLE.
15 PLTROOT-PRINTER-RECORD
OCCURS 10 TIMES
INDEXED BY PLTROOT-PRT-INDEX.
20 PLTROOT-PRINTER-LITERAL PIC X(20).
01 FILLER PIC X(500).
*******************************************************
READ 02 = GNP PLTPE I/O AREA = PLTPE
STATUS = GE END-OF-SEGMENTS
********************************************************
01 UNQUAL-SSA-PLTPE PIC X(09) VALUE 'PLTPE '.
01 PLTPE-LIT PIC X(08) VALUE ' PLTPE= '.
01 PLTPE.
05 PLTPE-KEY.
10 PLTPE-KEY-SEQ PIC 9(03).
05 PLTPE-TYPE PIC X.
88 PLTPE-PROGRAM VALUE 'P'.
05 PLTPE-NAME PIC X(8).
05 PLTPE-TITLE PIC X(30).
05 PLTPE-ACCESS PIC X.
88 PLTPE-ACCESS-VALUE VALUES ARE '0' THRU '9'.
05 PLTPE-COURTPRF PIC X.
88 PLTPE-COURTPRF-YES VALUE 'Y'.
88 PLTPE-COURTPRF-NO VALUE 'N'.
01 FILLER PIC X(500).
***********************************************************
READ 03 = GU MENUROOT(PREFIX =S) THEN GN * I/O AREA = SEGPROF
***********************************************************
01 MENUROOT-SSA-PREFIX-S.
05 FILLER PIC X(19) VALUE 'MENUROOT(PREFIX ='.
05 MENUROOT-PREFIX-SSA-KEY PIC X VALUE 'S'.
05 FILLER PIC XX VALUE ') '.
01 SEGPROF-LIT PIC X(11) VALUE ' SEGPROF= '.
01 SEGPROF.
05 SEGPROF-KEY-AREA.
10 SEGPROF-KEY-PREFIX PIC X.
88 VALID-SEGPROF-KEY-PREFIX VALUE 'S'.
10 SEGPROF-KEY-SUFFIX PIC X(8).
05 SEGPROF-PLT-NAME PIC X(8).
05 SEGPROF-NOTE PIC X(30).
05 SEGPROF-SECURITY-TABLE PIC X(400).
05 SEGPROF-SECURITY-BYTE REDEFINES SEGPROF-SECURITY-TABLE OCCURS 400 TIMES.
10 SEGPROF-BYTE PIC X.
01 FILLER PIC X(500).
****************************************************
PROGRAM WORK FIELDS
**************************************
01 W-ZERO PIC 9(008) VALUE 0.
01 READ-PLTROOT-COUNT-LIT PIC X(22) VALUE ' READ-PLTROOT-COUNT= '.
01 READ-PLTROOT-COUNT PIC 9(008) VALUE 0.
01 READ-PLTPE-COUNT-LIT PIC X(19) VALUE ' READ-PLTPE-COUNT= '.
01 READ-PLTPE-COUNT PIC 9(008) VALUE 0.
01 READ-PLTPE-COUNT-LIT PIC X(22) VALUE ' READ-SEGPROF-COUNT= '.
01 READ-SEGPROF-COUNT PIC 9(008) VALUE 0.
01 W-PLTPE-SEQ-MAX PIC 9(008) VALUE 400.
01 W-SEGPROF-SEQ-MAX PIC 9(008) VALUE 400.
01 READ-PLT-OPCODE PIC X(004) VALUE SPACES.
01 READ-SEC-OPCODE PIC X(004) VALUE SPACES.
01 D-PLTPE-INDEX PIC 9(008).
01 D-SEGPROF-INDEX PIC 9(008).
01 BEGIN-PLT PIC X(008) VALUE ' '.
01 W-SEGPROF-ACCESS-TABLE.
05 W-SEGPROF-ACCESS-BYTES PIC X(400).
05 W-SEGPROF-ACCESS-BYTE
REDEFINES W-SEGPROF-ACCESS-BYTES OCCURS 400 TIMES
INDEXED BY W-ACCESS-INDEX.
10 W-SEGPROF-BYTE PIC X.
**********************************************************
LINKAGE SECTION.
*************************************************************
DLI PROGRAM COMMUNICATION BLOCK FOR PLTROOT SEGMENT
AND PLTPE DEPENDENT SEGMENTS
***************************************************
01 DLIPCB1.
05 PCB-DBD-NAME-1.
10 PCBDBDNM-1 PIC X(8).
05 PCB-LEVEL-1 PIC 9(2).
05 PCB-STATUS-CODE-1.
10 PCBSA-1 PIC XX.
05 PCB-PROCESSING-OPTIONS-1.
10 PCBPROPT-1 PIC X(4).
05 FILLER PIC S9(5) COMP.
05 PCB-SEGMENT-NAME-1.
10 PCBSEGNM-1 PIC X(8).
05 PCB-LENGTH-FEEDBACK-1.
10 PCBLKEYFB-1 PIC S9(5) COMP.
05 PCB-NUMBER-SEGMENTS-1 PIC S9(5) COMP.
05 PCB-KEY-FEEDBACK-1.
10 PCBKEYFB-1 PIC X(58).
*************************************************
DLI PROGRAM COMMUNICATION BLOCK FOR SEGPROF SEGMENT
************************************************
01 DLIPCB2.
05 PCB-DBD-NAME-2.
10 PCBDBDNM-2 PIC X(8).
05 PCB-LEVEL-2 PIC 9(2).
05 PCB-STATUS-CODE-2.
10 PCBSA-2 PIC XX.
05 PCB-PROCESSING-OPTIONS-2.
10 PCBPROPT-2 PIC X(4).
05 FILLER PIC S9(5) COMP.
05 PCB-SEGMENT-NAME-2.
10 PCBSEGNM-2 PIC X(8).
05 PCB-LENGTH-FEEDBACK-2.
10 PCBLKEYFB-2 PIC S9(5) COMP.
05 PCB-NUMBER-SEGMENTS-2 PIC S9(5) COMP.
05 PCB-KEY-FEEDBACK-2.
10 PCBKEYFB-2 PIC X(58).
***********************************************
PROGRAM INITIALIZATION
************************************************
PROCEDURE DIVISION.
ENTRY 'DLITCBL' USING DLIPCB1 DLIPCB2.
DISPLAY '*** START IMSBATCH'.
OPEN OUTPUT OUTFILE.
MOVE 0 TO O-PLT-SEQ.
MOVE GU TO READ-PLT-OPCODE.
MOVE GU TO READ-SEC-OPCODE.
**************************************************
READ PLT MENUROOT SEGMENTS
**************************************************
RTN-READ-PLT.
CALL 'CBLTDLI' USING READ-PLT-OPCODE DLIPCB1
PLTROOT
MENUROOT-SSA-PREFIX-P.
IF PCBSA-1 EQUAL GET-GOOD
GO TO RTN-READ-PLT-GOOD.
GO TO END-OF-DATABASE.
RTN-READ-PLT-GOOD.
IF BEGIN-PLT EQUAL SPACES NEXT SENTENCE
ELSE
IF PLTROOT-NAME LESS THAN BEGIN-PLT DISPLAY '*** SKIPPING ' PLTROOT-NAME
MOVE GN TO READ-PLT-OPCODE
GO TO RTN-READ-PLT.
ADD 1 TO READ-PLTROOT-COUNT.
ADD 1 TO W-PLT-SEQ.
MOVE 0 TO W-PLTPE-SEQ-LAST.
MOVE 0 TO W-SEGPROF-SEQ-LAST.
MOVE GN TO READ-PLT-OPCODE.
MOVE PLTROOT-PREFIX TO W-PLTROOT-PREFIX.
MOVE PLTROOT-NAME TO W-PLTROOT-NAME.
INSPECT W-PLTROOT-NAME
REPLACING ALL LOW-VALUE BY SPACE.
MOVE PLTROOT-TITLE TO W-PLTROOT-TITLE.
INSPECT W-PLTROOT-TITLE
REPLACING ALL LOW-VALUE BY SPACE.
MOVE PLTROOT-TERMINAL-PRINTER-TABLE
TO W-PLTROOT-TERM-PRT-TABLE.
INSPECT W-PLTROOT-TERM-PRT-TABLE
REPLACING ALL LOW-VALUE BY SPACE.
* DISPLAY ' '.
* DISPLAY '*** RTN-READ-PLT = ' W-PLT-SEQ.
DISPLAY '*** PROCESSING ' W-PLTROOT-NAME.
**********************************************
READ PLTPE DEPENDENT SEGMENTS
**********************************************
RTN-READ-PLTPE.
CALL 'CBLTDLI' USING GNP
DLIPCB1
PLTPE
UNQUAL-SSA-PLTPE.
IF PCBSA-1 EQUAL GET-GOOD
GO TO RTN-READ-PLTPE-GOOD.
IF PCBSA-1 EQUAL GN-CROSS-BOUNDARY OR EQUAL GET-NOT-FOUND
OR EQUAL GET-END-DB
GO TO RTN-READ-PLTPE-END.
GO TO END-OF-DATABASE.
RTN-READ-PLTPE-GOOD.
IF W-PLTPE-SEQ-LAST EQUAL
TO W-PLTPE-SEQ-MAX
DISPLAY '*** W-PLTPE-SEQ-MAX MAXIMUM ' W-PLTPE-SEQ-MAX ' COUNT EXCEEDED'
GO TO END-OF-DATABASE.
ADD 1 TO READ-PLTPE-COUNT.
ADD 1 TO W-PLTPE-SEQ-LAST.
SET W-PLTPE-INDEX TO W-PLTPE-SEQ-LAST.
MOVE PLTPE-TYPE TO W-PLTPE-TYPE(W-PLTPE-INDEX).
MOVE PLTPE-NAME TO W-PLTPE-NAME(W-PLTPE-INDEX).
INSPECT W-PLTPE-NAME(W-PLTPE-INDEX)
REPLACING ALL LOW-VALUE BY SPACE.
MOVE PLTPE-KEY-SEQ TO W-PLTPE-KEY-SEQ(W-PLTPE-INDEX).
MOVE PLTPE-ACCESS TO W-PLTPE-ACCESS(W-PLTPE-INDEX).
MOVE PLTPE-TITLE TO W-PLTPE-TITLE(W-PLTPE-INDEX).
INSPECT W-PLTPE-TITLE(W-PLTPE-INDEX)
REPLACING ALL LOW-VALUE BY SPACE.
MOVE PLTPE-COURTPRF TO W-PLTPE-COURTPRF(W-PLTPE-INDEX).
INSPECT W-PLTPE-COURTPRF(W-PLTPE-INDEX)
REPLACING ALL LOW-VALUE BY SPACE.
GO TO RTN-READ-PLTPE.
RTN-READ-PLTPE-END.
MOVE GU TO READ-SEC-OPCODE.
GO TO RTN-READ-SEGPROF.
*********************************************************
READ ALL SEGPROF SEGMENTS AND SELECT SEGMENTS THAT
MATCH THIS PLT
*******************************************************
RTN-READ-SEGPROF.
CALL 'CBLTDLI' USING READ-SEC-OPCODE DLIPCB2
SEGPROF
MENUROOT-SSA-PREFIX-S.
MOVE GN TO READ-SEC-OPCODE.
IF PCBSA-2 EQUAL GET-GOOD
GO TO RTN-READ-SEGPROF-GOOD.
IF PCBSA-2 EQUAL GN-CROSS-BOUNDARY OR EQUAL GET-NOT-FOUND
OR EQUAL GET-END-DB
GO TO RTN-READ-SEGPROF-END.
GO TO END-OF-DATABASE.
RTN-READ-SEGPROF-GOOD.
ADD 1 TO READ-SEGPROF-COUNT.
IF SEGPROF-PLT-NAME NOT EQUAL TO W-PLTROOT-NAME GO TO RTN-READ-SEGPROF.
IF W-SEGPROF-SEQ-LAST GREATER THAN OR EQUAL TO W-SEGPROF-SEQ-MAX
DISPLAY '*** W-SEGPROF-SEQ-MAX MAXIMUM ' W-SEGPROF-SEQ-MAX ' COUNT EXCEEDED '
GO TO END-OF-DATABASE.
ADD 1 TO W-SEGPROF-SEQ-LAST.
SET W-SEGPROF-INDEX TO W-SEGPROF-SEQ-LAST.
MOVE SEGPROF-KEY-PREFIX TO
W-SEGPROF-KEY-PREFIX(W-SEGPROF-INDEX).
MOVE SEGPROF-KEY-SUFFIX TO
W-SEGPROF-KEY-SUFFIX(W-SEGPROF-INDEX).
INSPECT W-SEGPROF-KEY-SUFFIX(W-SEGPROF-INDEX) REPLACING ALL LOW-VALUE BY SPACE.
MOVE SEGPROF-PLT-NAME TO
W-SEGPROF-PLT-NAME(W-SEGPROF-INDEX).
INSPECT W-SEGPROF-PLT-NAME(W-SEGPROF-INDEX) REPLACING ALL LOW-VALUE BY SPACE.
MOVE SEGPROF-NOTE TO
W-SEGPROF-NOTE(W-SEGPROF-INDEX).
INSPECT W-SEGPROF-NOTE(W-SEGPROF-INDEX) REPLACING ALL LOW-VALUE BY SPACE.
MOVE SEGPROF-SECURITY-TABLE TO
W-SEGPROF-SECURITY-TABLE(W-SEGPROF-INDEX).
INSPECT W-SEGPROF-SECURITY-TABLE(W-SEGPROF-INDEX) REPLACING ALL LOW-VALUE BY SPACE.
GO TO RTN-READ-SEGPROF.
RTN-READ-SEGPROF-END.
GO TO RTN-BUILD-RECORD.
**********************************************************
THE ROOT, DEPENDENT PLTPE AND OTHER SEGMENTS HAVE BEEN READ.
BUILD THE OUTPUT RECORD(S).
********************************************************
RTN-BUILD-RECORD.
SET W-PLTPE-INDEX TO W-ZERO.
SET W-SEGPROF-INDEX TO W-ZERO.
RTN-BUILD-PLTPE.
SET W-PLTPE-INDEX UP BY 1.
IF W-PLTPE-INDEX GREATER THAN W-PLTPE-SEQ-LAST SET W-PLTPE-INDEX TO W-ZERO
GO TO RTN-READ-PLT.
RTN-BUILD-SEGPROF.
PERFORM RTN-MOVE-PLT THROUGH RTN-MOVE-PLT-END.
PERFORM RTN-MOVE-PLTPE THROUGH RTN-MOVE-PLTPE-END.
IF W-SEGPROF-SEQ-LAST GREATER THAN 0 PERFORM RTN-MOVE-SEGPROF THROUGH RTN-MOVE-SEGPROF-END VARYING W-SEGPROF-INDEX FROM 1 BY 1 UNTIL W-SEGPROF-INDEX GREATER THAN W-SEGPROF-SEQ-LAST
ELSE PERFORM RTN-MOVE-SEGPROF-DUMMY THROUGH RTN-MOVE-SEGPROF-DUMMY-END.
PERFORM RTN-WRITE-PLT THROUGH RTN-WRITE-PLT-END.
GO TO RTN-BUILD-PLTPE.
RTN-MOVE-PLT.
MOVE W-PLTROOT-PREFIX TO O-PLTROOT-PREFIX.
MOVE W-PLTROOT-NAME TO O-PLTROOT-NAME.
MOVE W-PLTROOT-TITLE TO O-PLTROOT-TITLE.
MOVE W-PLTROOT-TERM-PRT-TABLE TO O-PLTROOT-TERM-PRT-TABLE.
MOVE W-PLT-SEQ TO O-PLT-SEQ.
MOVE W-PLTPE-SEQ-LAST TO O-PLTPE-SEQ-LAST.
MOVE W-SEGPROF-SEQ-LAST TO O-SEGPROF-SEQ-LAST.
* DISPLAY ' '
* DISPLAY 'O-PLTROOT-SEQ = ' O-PLT-SEQ.
* DISPLAY 'O-PLTROOT-NAME = ' O-PLTROOT-NAME.
RTN-MOVE-PLT-END.
EXIT.
RTN-MOVE-PLTPE.
MOVE W-PLTPE-TYPE(W-PLTPE-INDEX) TO O-PLTPE-TYPE.
MOVE W-PLTPE-NAME(W-PLTPE-INDEX) TO O-PLTPE-NAME.
MOVE W-PLTPE-KEY-SEQ(W-PLTPE-INDEX) TO O-PLTPE-KEY-SEQ.
MOVE W-PLTPE-ACCESS(W-PLTPE-INDEX) TO O-PLTPE-ACCESS.
MOVE W-PLTPE-TITLE(W-PLTPE-INDEX) TO O-PLTPE-TITLE.
MOVE W-PLTPE-COURTPRF(W-PLTPE-INDEX) TO O-PLTPE-COURTPRF.
RTN-MOVE-PLTPE-END.
* DISPLAY 'O-PLTPE-NAME = ' O-PLTPE-NAME.
EXIT.
RTN-MOVE-SEGPROF.
SET O-SEGPROF-INDEX TO W-SEGPROF-INDEX.
MOVE W-SEGPROF-KEY-PREFIX(W-SEGPROF-INDEX) TO O-SEGPROF-KEY-PREFIX(O-SEGPROF-INDEX).
MOVE W-SEGPROF-KEY-SUFFIX(W-SEGPROF-INDEX) TO O-SEGPROF-KEY-SUFFIX(O-SEGPROF-INDEX).
MOVE W-SEGPROF-PLT-NAME(W-SEGPROF-INDEX) TO O-SEGPROF-PLT-NAME(O-SEGPROF-INDEX).
MOVE W-SEGPROF-NOTE(W-SEGPROF-INDEX) TO O-SEGPROF-NOTE(O-SEGPROF-INDEX).
MOVE W-SEGPROF-SECURITY-TABLE(W-SEGPROF-INDEX) TO W-SEGPROF-ACCESS-TABLE.
SET W-ACCESS-INDEX TO W-PLTPE-KEY-SEQ(W-PLTPE-INDEX).
MOVE W-SEGPROF-BYTE(W-ACCESS-INDEX) TO O-SEGPROF-ACCESS(O-SEGPROF-INDEX).
ADD 1 TO O-SEGPROF-SEQ(O-SEGPROF-INDEX).
* DISPLAY 'O-SEGPROF-KEY-SUFFIX = ' O-SEGPROF-KEY-SUFFIX.
RTN-MOVE-SEGPROF-END.
EXIT.
RTN-MOVE-SEGPROF-DUMMY.
DISPLAY '*** DUMMY SECURITY FOR ' O-PLTROOT-NAME.
ADD 1 TO W-SEGPROF-SEQ-LAST.
SET O-SEGPROF-INDEX TO W-SEGPROF-SEQ-LAST.
MOVE W-SEGPROF-SEQ-LAST TO O-SEGPROF-SEQ-LAST.
MOVE 0 TO O-SEGPROF-SEQ(O-SEGPROF-INDEX).
MOVE 'S' TO O-SEGPROF-KEY-PREFIX(O-SEGPROF-INDEX).
MOVE 'DUMMY ' TO O-SEGPROF-KEY-SUFFIX(O-SEGPROF-INDEX).
MOVE 'DUMMY ' TO O-SEGPROF-PLT-NAME(O-SEGPROF-INDEX).
MOVE 'DUMMY ' TO O-SEGPROF-NOTE(O-SEGPROF-INDEX).
MOVE 0 TO O-SEGPROF-ACCESS(O-SEGPROF-INDEX).
RTN-MOVE-SEGPROF-DUMMY-END.
EXIT.
RTN-WRITE-PLT.
WRITE O-PLT.
RTN-WRITE-PLT-END.
EXIT.
*********************************************
PROGRAM EXIT AFTER THE MAXIMUM NUMBER OF USER RECORDS HAVE
BEEN READ AND/OR THERE ARE NO MORE USER RECORDS TO READ
************************************************
END-OF-DATABASE.
DISPLAY '*** END-OF-DATABASE'.
DISPLAY 'DLIPCB1 = ' DLIPCB1.
DISPLAY 'DLIPCB2 = ' DLIPCB2.
CLOSE OUTFILE.
DISPLAY 'READ-PLTROOT-COUNT = ' READ-PLTROOT-COUNT.
DISPLAY 'READ-PLTPE-COUNT = ' READ-PLTPE-COUNT.
DISPLAY 'READ-SEGPROF-COUNT = ' READ-SEGPROF-COUNT.
DISPLAY '*** END-OF-IMSBATCH'.
GOBACK.
Advertisements
