//TVALOAD JOB (USERID,T208),
// USERID,REGION=2M,TIME=(,05)
/*JOBPARM FETCH
//*
//************************************************************
//* COBOL PLEX COMPILE, LOAD AND GO
//************************************************************
//*
//S2KCLGC PROC OUT=A,FCP=1,FCS=1,COBNAME=TVALOAD,
// WRKUNIT=RIO,
// PARMS=NLPARM
//PRECOM EXEC PGM=PRCOMC
//STEPLIB DD DSN=SASDWP.R116.LOAD,DISP=SHR
//SYSPRINT DD SYSOUT=&OUT
//SYSIN DD DSN=SASDWP.R116.TEST(&COBNAME),
// DISP=SHR
//SYSGO DD DSN=&&CSOURCE,DISP=(MOD,PASS),UNIT=RIO,
// DCB=(BLKSIZE=800,LRECL=80,RECFM=FB),
// SPACE=(CYL,(1,1))
//SYSUT1 DD UNIT=&WRKUNIT,SPACE=(TRK,(20,20))
//SYSUT2 DD UNIT=&WRKUNIT,SPACE=(TRK,(20,20))
//S2KSNAP DD SYSOUT=&OUT
//COB EXEC PGM=IKFCBL00,
// PARM=('SIZE=307200',NONUM,LOAD,APOST,NODMAP,
// NOPMAP,NODYNAM,NORES,NOOPT),COND=(4,LT,PRECOM)
//STEPLIB DD DSN=SYS1.VSCOLIB,DISP=SHR
//SYSPRINT DD SYSOUT=&OUT
//SYSUT1 DD SPACE=(460,(700,100)),UNIT=&WRKUNIT
//SYSUT2 DD SPACE=(460,(700,100)),UNIT=&WRKUNIT
//SYSUT3 DD SPACE=(460,(700,100)),UNIT=&WRKUNIT
//SYSUT4 DD SPACE=(460,(700,100)),UNIT=&WRKUNIT
//SYSUT5 DD SPACE=(460,(700,100)),UNIT=&WRKUNIT
//SYSLIB DD DSN=SASDWP.R116.TEST,DISP=SHR
//SYSIN DD DSN=&&CSOURCE,DISP=(OLD,DELETE)
//SYSLIN DD DSN=&&COBOBJ,DISP=(NEW,PASS),
// SPACE=(80,(900,100)),UNIT=&WRKUNIT
//LKED EXEC PGM=IEWL,
// PARM='MAP,XREF,LIST,LET,SIZE=(492K,24K)',
// COND=((4,LT,PRECOM),(8,LT,COB))
//SYSLIN DD DSN=&&COBOBJ,DISP=(OLD,DELETE)
//SYSLIB DD DSN=SYS1.VSCLLIB,DISP=SHR
// DD DSN=SASDWP.R116.LOAD,DISP=SHR
//SYSLMOD DD DSN=SASCCT.R116.LOAD(&COBNAME),
// DISP=SHR
//SYSPRINT DD SYSOUT=&OUT
//SYSUT1 DD SPACE=(1024,(400,20)),UNIT=&WRKUNIT
//*
//* PARM WILL BE THE PASSWORD OF THE DATABASE THAT IS BEING UNLOADED.
//GO EXEC PGM=*.LKED.SYSLMOD,PARM='TIVR',
// COND=((4,LT,PRECOM),(8,LT,COB),(8,LT,LKED))
//STEPLIB DD DSN=SYS1.VSCLLIB,DISP=SHR
// DD DSN=SASCCT.R116.LOAD,DISP=SHR
//S2KPARMS DD DSN=SASDWP.R116.TEST(&PARMS),DISP=SHR
//SF01 DD UNIT=&WRKUNIT,SPACE=(TRK,(&FCP,&FCS))
//SF02 DD UNIT=&WRKUNIT,SPACE=(TRK,(&FCP,&FCS))
//SF03 DD UNIT=&WRKUNIT,SPACE=(TRK,(&FCP,&FCS))
//SF04 DD UNIT=&WRKUNIT,SPACE=(TRK,(&FCP,&FCS))
//SF05 DD UNIT=&WRKUNIT,SPACE=(TRK,(&FCP,&FCS))
//SF06 DD UNIT=&WRKUNIT,SPACE=(TRK,(&FCP,&FCS))
//S2KPAD00 DD DSN=&&PAD00,UNIT=&WRKUNIT,SPACE=(CYL,(2,5))
//SYSOUT DD SYSOUT=&OUT
//S2KMSG DD DCB=(BLKSIZE=1320,LRECL=132,RECFM=FB),
// SYSOUT=&OUT
//S2KSNAP DD SYSOUT=&OUT,DCB=BLKSIZE=882
//SYSUDUMP DD SYSOUT=&OUT
//S2KCOMD DD DUMMY
//TIMEIO DD SYSOUT=&OUT
//IVR94TR1 DD DSN=SASBWC.JAN.IVR94TR1,DISP=OLD
//IVR94TR2 DD DSN=SASBWC.JAN.IVR94TR2,DISP=OLD
//IVR94TR3 DD DSN=SASBWC.JAN.IVR94TR3,DISP=OLD
//IVR94TR4 DD DSN=SASBWC.JAN.IVR94TR4,DISP=OLD
//IVR94TR5 DD DSN=SASBWC.JAN.IVR94TR5,DISP=OLD
//IVR94TR6 DD DSN=SASBWC.JAN.IVR94TR6,DISP=OLD
//*IVR94TR7 DD DSN=SASBWC.JAN.IVR94TR7,DISP=OLD
//*CHANGE INFL TO POINT TO THE DSN OF YOUR UNLOADED DATA FROM TVAUNLD RUN.
//INFL DD DSN=SASCCT.TVA.FEBOUTCT,DISP=SHR
//*
// PEND
//*
// EXEC S2KCLGC
//PRECOM.SYSIN DD *
IDENTIFICATION DIVISION.
PROGRAM-ID. TVALOAD.
REMARKS. MODIFIED COBOL LOAD PROGRAM FOR TVA TO
* DO AN INCREMENTAL LOAD INTO
* EXISTING DATABASE IVR9RTRA.
*
* THE PROGRAM CHECKS TO INSURE THAT HIGHER
* LEVEL RECORDS ARE NOT DUPLICATED.
*
* DISPLAYS OF WHERE CLAUSES AND INSERTED RECORDS
* HAVE BEEN COMMENTED OUT BUT CAN BE USED AT A
* LATER TIME FOR DEBUGGING PURPOSES IF NEEDED.
*
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-370.
OBJECT-COMPUTER. IBM-370.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT IN-FILE ASSIGN TO UT-S-INFL.
*
DATA DIVISION.
FILE SECTION.
FD IN-FILE
RECORDING MODE IS V
LABEL RECORDS ARE STANDARD
BLOCK CONTAINS 6216 CHARACTERS
RECORD CONTAINS 17 TO 346 CHARACTERS.
01 GENERAL.
02 HEADER PIC X(4).
02 FILL1 PIC X(342).
01 REC-0000.
02 HDER PIC X(4).
02 C0000-IO PIC X(56).
01 REC-0200.
02 HDER PIC X(4).
02 C0200-IO PIC X(20).
01 REC-0800.
02 HDER PIC X(4).
02 C0800-IO PIC X(13).
01 REC-0900.
02 HDER PIC X(4).
02 C0900-IO PIC X(48).
01 REC-1000.
02 HDER PIC X(4).
02 C1000-IO PIC X(342).
*
WORKING-STORAGE SECTION.
*
77 EOF-FLAG PIC X VALUE '0'.
77 ERR-FLAG PIC X VALUE '0'.
77 INSERT-MODE PIC X VALUE '0'.
01 STACK-ZERO PIC S9(9) COMP VALUE ZERO.
01 CTR-0 PIC 9(8) VALUE ZERO.
01 CTR-200 PIC 9(8) VALUE ZERO.
01 CTR-800 PIC 9(8) VALUE ZERO.
01 CTR-900 PIC 9(8) VALUE ZERO.
01 CTR-1000 PIC 9(8) VALUE ZERO.
01 DUP-CTR-0 PIC 9(8) VALUE ZERO.
01 DUP-CTR-200 PIC 9(8) VALUE ZERO.
01 DUP-CTR-800 PIC 9(8) VALUE ZERO.
01 DUP-CTR-900 PIC 9(8) VALUE ZERO.
*
*
*
COMMBLOCK OF IVR94TRA.
01 IVR94TRA.
05 SCHEMA-NAME.
05 DB-RETURN-CODE.
05 FILLER.
05 DB-LAST-DS.
05 DB-PASSWORD.
05 DB-NBR-OF-DS.
05 DB-DS-POSITION.
05 DB-LEVEL.
05 DB-TIME.
05 DB-DATE.
05 DB-CYCLE.
05 DB-SEP-SYM.
05 DB-END-TERMINATOR.
05 DB-STATUS.
*
SCHEMA C0000 OF IVR94TRA.
01 C0000.
05 C0100 PIC IS X(5).
05 C0105 PIC IS X(5).
05 C0110 PIC IS X(5).
05 C0115 PIC IS X(5).
05 C0120 PIC IS X(5).
05 C0125 PIC IS X(5).
05 C0130 PIC IS X(5).
05 C0135 PIC IS X(5).
05 C0198 PIC IS X(8).
05 C0199 PIC IS X(8).
*
SCHEMA C0200 OF IVR94TRA.
01 C0200.
05 C0210 PIC IS X(4).
05 C0215 PIC IS X(4).
05 C0220 PIC IS X(4).
05 C0225 PIC IS X(4).
05 C0230 PIC IS X(4).
*
SCHEMA C0800 OF IVR94TRA.
01 C0800.
05 C0805 PIC IS X(6).
05 C0810 PIC IS X(6).
05 C0815 PIC IS X(1).
*
SCHEMA C0900 OF IVR94TRA.
01 C0900.
05 C0905 PIC IS X(12).
05 C0910 PIC IS X(12).
05 C0915 PIC IS X(12).
05 C0920 PIC IS X(12).
*
SCHEMA C1000 OF IVR94TRA.
01 C1000.
05 C1035 PIC IS X(8).
FORM YYYYMMDD.
05 C1040 PIC IS X(8).
FORM YYYYMMDD.
05 C1180 PIC IS X(8).
FORM YYYYMMDD.
05 C1005 PIC IS X(3).
05 C1010 PIC IS X(4).
05 C1015 PIC IS X(1).
05 C1025 PIC IS X(6).
05 C1030 PIC IS X(7).
05 C1045 PIC IS X(119).
05 C1050 PIC IS X(5).
05 C1055 PIC IS X(5).
05 C1060 PIC IS X(5).
05 C1065 PIC IS X(5).
05 C1070 PIC IS X(5).
05 C1075 PIC IS X(5).
05 C1080 PIC IS X(5).
05 C1085 PIC IS X(5).
05 C1090 PIC IS X(5).
05 C1095 PIC IS X(5).
05 C1100 PIC IS X(5).
05 C1105 PIC IS X(5).
05 C1110 PIC IS X(5).
05 C1115 PIC IS X(5).
05 C1120 PIC IS X(3).
05 C1125 PIC IS X(3).
05 C1130 PIC IS X(3).
05 C1135 PIC IS X(3).
05 C1140 PIC IS X(3).
05 C1155 PIC IS X(12).
05 C1160 PIC IS X(12).
05 C1165 PIC IS X(12).
05 C1170 PIC IS X(3).
05 C1175 PIC IS X(1).
05 C1185 PIC IS X(6).
05 C1190 PIC IS X(6).
05 C1195 PIC IS X(6).
05 C1200 PIC IS X(6).
05 C1205 PIC IS X(6).
05 C1210 PIC IS X(4).
05 C1215 PIC IS X(4).
05 C1220 PIC IS X(1).
05 C1225 PIC IS X(1).
05 C1150 PIC IS S9(8)V9(1) COMP-3.
05 C1145 PIC IS S9(12)V9(2) COMP-3.
*
END SCHEMAS.
01 C0-WHERE.
03 FILLER PIC X(6) VALUE 'C0100 '.
03 C100-EQ PIC XXX VALUE 'EQ '.
03 C100-VAL PIC X(5) VALUE ' '.
03 FILLER PIC X(5) VALUE ' AND '.
03 FILLER PIC X(6) VALUE 'C0105 '.
03 C105-EQ PIC XXX VALUE 'EQ '.
03 C105-VAL PIC X(5) VALUE ' '.
03 FILLER PIC X(5) VALUE ' AND '.
03 FILLER PIC X(6) VALUE 'C0110 '.
03 C110-EQ PIC XXX VALUE 'EQ '.
03 C110-VAL PIC X(5) VALUE ' '.
03 FILLER PIC X(5) VALUE ' AND '.
03 FILLER PIC X(6) VALUE 'C0115 '.
03 C115-EQ PIC XXX VALUE 'EQ '.
03 C115-VAL PIC X(5) VALUE ' '.
03 FILLER PIC X(5) VALUE ' AND '.
03 FILLER PIC X(6) VALUE 'C0120 '.
03 C120-EQ PIC XXX VALUE 'EQ '.
03 C120-VAL PIC X(5) VALUE ' '.
03 FILLER PIC X(5) VALUE ' AND '.
03 FILLER PIC X(6) VALUE 'C0125 '.
03 C125-EQ PIC XXX VALUE 'EQ '.
03 C125-VAL PIC X(5) VALUE ' '.
03 FILLER PIC X(5) VALUE ' AND '.
03 FILLER PIC X(6) VALUE 'C0130 '.
03 C130-EQ PIC XXX VALUE 'EQ '.
03 C130-VAL PIC X(5) VALUE ' '.
03 FILLER PIC X(5) VALUE ' AND '.
03 FILLER PIC X(6) VALUE 'C0135 '.
03 C135-EQ PIC XXX VALUE 'EQ '.
03 C135-VAL PIC X(5) VALUE ' '.
03 C100-CONT PIC X(5) VALUE ':AND '.
03 C200-WHERE.
05 FILLER PIC X(6) VALUE 'C0210 '.
05 C210-EQ PIC XXX VALUE 'EQ '.
05 C210-VAL PIC X(5) VALUE ' '.
05 FILLER PIC X(5) VALUE ' AND '.
05 FILLER PIC X(6) VALUE 'C0215 '.
05 C215-EQ PIC XXX VALUE 'EQ '.
05 C215-VAL PIC X(5) VALUE ' '.
05 FILLER PIC X(5) VALUE ' AND '.
05 FILLER PIC X(6) VALUE 'C0220 '.
05 C220-EQ PIC XXX VALUE 'EQ '.
05 C220-VAL PIC X(5) VALUE ' '.
05 FILLER PIC X(5) VALUE ' AND '.
05 FILLER PIC X(6) VALUE 'C0225 '.
05 C225-EQ PIC XXX VALUE 'EQ '.
05 C225-VAL PIC X(5) VALUE ' '.
05 FILLER PIC X VALUE ':'.
*
LINKAGE SECTION.
01 JCL-PARMS.
02 LNGTH PIC S9(4) COMP.
02 JCL-PSWD PIC X(4).
*
EJECT
*
*
PROCEDURE DIVISION USING JCL-PARMS.
START S2K.
MOVE JCL-PSWD TO DB-PASSWORD.
OPEN INPUT IN-FILE.
OPEN IVR94TRA.
CALL 'QASTAT'.
IF DB-RETURN-CODE NOT = 0 GO TO S2K-ERROR.
DISPLAY 'COMMBLOCK = ' IVR94TRA.
*LOAD IVR94TRA.
QUEUE.
IF DB-RETURN-CODE NOT = 0 GO TO S2K-ERROR.
READ IN-FILE AT END MOVE '1' TO EOF-FLAG.
PERFORM EXTRACT THRU EXTRACT-EXIT UNTIL EOF-FLAG = '1'
OR ERR-FLAG NOT = '0'.
IF ERR-FLAG NOT = '0' PERFORM ERROR-RTN THRU ERROR-RTN-EXIT.
TERMINATE.
EOJ.
CALL 'QASTAT'.
MOVE 0 TO RETURN-CODE.
DISPLAY 'COUNT OF INSERTED C0 RECORDS = ', CTR-0.
DISPLAY 'COUNT OF INSERTED C200 RECORDS = ', CTR-200.
DISPLAY 'COUNT OF INSERTED C800 RECORDS = ', CTR-800.
DISPLAY 'COUNT OF INSERTED C900 RECORDS = ', CTR-900.
DISPLAY 'COUNT OF INSERTED C1000 RECORDS = ', CTR-1000.
DISPLAY 'COUNT OF MATCHING C0 RECORDS = ', DUP-CTR-0.
DISPLAY 'COUNT OF MATCHING C200 RECORDS = ', DUP-CTR-200.
DISPLAY 'COUNT OF MATCHING C800 RECORDS = ', DUP-CTR-800.
DISPLAY 'COUNT OF MATCHING C900 RECORDS = ', DUP-CTR-900.
CLOSE IVR94TRA.
IF DB-RETURN-CODE NOT = 0
DISPLAY 'DB CLOSE FAILED.'.
CLOSE IN-FILE.
GOBACK.
S2K-ERROR.
DISPLAY 'S2K ERROR ENCOUNTERED.'.
DISPLAY 'COMMBLOCK = ' IVR94TRA.
GO TO EOJ.
*
EJECT
*
EXTRACT.
IF HEADER = '0000'
PERFORM C0000-PARA THRU C0000-EXIT
ELSE IF HEADER = '0200'
PERFORM C0200-PARA THRU C0200-EXIT
ELSE IF HEADER = '0800'
PERFORM C0800-PARA THRU C0800-EXIT
ELSE IF HEADER = '0900'
PERFORM C0900-PARA THRU C0900-EXIT
ELSE IF HEADER = '1000'
PERFORM C1000-PARA THRU C1000-EXIT
ELSE MOVE '1' TO ERR-FLAG.
READ IN-FILE AT END MOVE '1' TO EOF-FLAG.
EXTRACT-EXIT. EXIT.
EJECT
*
C0000-PARA.
MOVE C0000-IO TO C0000.
*BUILD WHERE-CLAUSE TO CHECK FOR EXISTING C0 RECORD.
IF C0100 = LOW-VALUES
MOVE ' ' TO C100-EQ
MOVE 'FAILS' TO C100-VAL
ELSE
MOVE 'EQ ' TO C100-EQ
MOVE C0100 TO C100-VAL.
IF C0105 = LOW-VALUES
MOVE ' ' TO C105-EQ
MOVE 'FAILS' TO C105-VAL
ELSE
MOVE 'EQ ' TO C105-EQ
MOVE C0105 TO C105-VAL.
IF C0110 = LOW-VALUES
MOVE ' ' TO C110-EQ
MOVE 'FAILS' TO C110-VAL
ELSE
MOVE 'EQ ' TO C110-EQ
MOVE C0110 TO C110-VAL.
IF C0115 = LOW-VALUES
MOVE ' ' TO C115-EQ
MOVE 'FAILS' TO C115-VAL
ELSE
MOVE 'EQ ' TO C115-EQ
MOVE C0115 TO C115-VAL.
IF C0120 = LOW-VALUES
MOVE ' ' TO C120-EQ
MOVE 'FAILS' TO C120-VAL
ELSE
MOVE 'EQ ' TO C120-EQ
MOVE C0120 TO C120-VAL.
IF C0125 = LOW-VALUES
MOVE ' ' TO C125-EQ
MOVE 'FAILS' TO C125-VAL
ELSE
MOVE 'EQ ' TO C125-EQ
MOVE C0125 TO C125-VAL.
IF C0130 = LOW-VALUES
MOVE ' ' TO C130-EQ
MOVE 'FAILS' TO C130-VAL
ELSE
MOVE 'EQ ' TO C130-EQ
MOVE C0130 TO C130-VAL.
IF C0135 = LOW-VALUES
MOVE ' ' TO C135-EQ
MOVE 'FAILS' TO C135-VAL
ELSE
MOVE 'EQ ' TO C135-EQ
MOVE C0135 TO C135-VAL.
MOVE ': ' TO C100-CONT.
* DISPLAY 'C0-WHERE = ' C0-WHERE.
GET1 C0000 DYNAM C0-WHERE.
IF S2KRTC = ZERO
MOVE '0' TO INSERT-MODE
ADD 1 TO DUP-CTR-0
GO TO C0000-EXIT
ELSE
IF S2KRTC NOT = 4
GO TO S2K-ERROR.
*INSERT IS DONE ONLY IF NOT A DUPLICATE C0 RECORD.
INSERT-C0000.
INSERT C0000.
IF DB-RETURN-CODE NOT = 0 GO TO S2K-ERROR.
ADD 1 TO CTR-0.
TERMINATE.
IF S2KRTC NOT = 0
GO TO S2K-ERROR.
QUEUE.
IF S2KRTC NOT = 0
GO TO S2K-ERROR.
* DISPLAY 'NEW C0 RECORD ADDED, C0 = ' C0000.
MOVE '1' TO INSERT-MODE.
* RE-ESTABLISH NEWLY INSERTED C0 POSITION.
GET1 C0000 DYNAM C0-WHERE.
IF S2KRTC NOT = ZERO
DISPLAY 'GET1 C0 FAILED AFTER INSERT'
GO TO S2K-ERROR.
C0000-EXIT.
EXIT.
*
C0200-PARA.
MOVE C0200-IO TO C0200.
*IF INSERT-MODE ='1' WE HAVE A NEW LEVEL 0 RECORD AND
* INSERT OF C200 IS DONE. IF INSERT-MODE= '0' WE BUILD
* A WHERE CLAUSE TO TEST FOR DUPLICATE C200 RECORD.
IF INSERT-MODE = '1'
GO TO C0200-INSERT.
IF C0210 = LOW-VALUES
MOVE ' ' TO C210-EQ
MOVE 'FAILS' TO C210-VAL
ELSE
MOVE 'EQ ' TO C210-EQ
MOVE C0210 TO C210-VAL.
IF C0215 = LOW-VALUES
MOVE ' ' TO C215-EQ
MOVE 'FAILS' TO C215-VAL
ELSE
MOVE 'EQ ' TO C215-EQ
MOVE C0215 TO C215-VAL.
IF C0220 = LOW-VALUES
MOVE ' ' TO C220-EQ
MOVE 'FAILS' TO C220-VAL
ELSE
MOVE 'EQ ' TO C220-EQ
MOVE C0220 TO C220-VAL.
IF C0225 = LOW-VALUES
MOVE ' ' TO C225-EQ
MOVE 'FAILS' TO C225-VAL
ELSE
MOVE 'EQ ' TO C225-EQ
MOVE C0220 TO C225-VAL.
MOVE ' AND ' TO C100-CONT.
* DISPLAY 'C0-WHERE = ' C0-WHERE.
GET1 C0200 DYNAM C0-WHERE.
IF S2KRTC = ZERO
ADD 1 TO DUP-CTR-200
GO TO C0200-EXIT
ELSE
IF S2KRTC NOT = 4
GO TO S2K-ERROR.
C0200-INSERT.
MOVE '1' TO INSERT-MODE.
*INSERT IS DONE ONLY IF NOT A DUPLICATE C200 RECORD.
INSERT C0200.
IF DB-RETURN-CODE NOT = 0 GO TO S2K-ERROR.
ADD 1 TO CTR-200.
* DISPLAY 'NEW C200 RECORD ADDED, C200 = ' C0200.
C0200-EXIT.
*
C0800-PARA.
MOVE C0800-IO TO C0800.
*IF INSERT-MODE = '1' WE HAVE INSERTED A HIGHER LEVEL RECORD.
*IF INSERT-MODE = '0' CHECK FOR DUPLICATE C800 RECORD.
IF INSERT-MODE = '1'
GO TO C0800-INSERT.
IF C0805 = LOW-VALUES
GET1 C0800 WH C0805 FAILS AND
SAME STACK(STACK-ZERO);
ELSE
GET1 C0800 WH NON-KEY C0805 EQ AND
SAME STACK(STACK-ZERO).
IF S2KRTC = ZERO
ADD 1 TO DUP-CTR-800
GO TO C0800-EXIT
ELSE
IF S2KRTC NOT = 4
GO TO S2K-ERROR.
C0800-INSERT.
MOVE '1' TO INSERT-MODE
*INSERT IS DONE ONLY IF C800 IS NOT A DUPLICATE RECORD.
INSERT C0800.
IF DB-RETURN-CODE NOT = 0 GO TO S2K-ERROR.
ADD 1 TO CTR-800.
* DISPLAY 'NEW C800 RECORD ADDED, C800 = ' C0800.
C0800-EXIT.
*
C0900-PARA.
MOVE C0900-IO TO C0900.
*IF INSERT-MODE = '1' WE HAVE INSERTED A HIGHER LEVEL RECORD.
*IF INSERT-MODE = '0' CHECK FOR DUPLICATE C900 RECORD.
IF INSERT-MODE = '1'
GO TO C0900-INSERT.
IF C0905 = LOW-VALUES
GET1 C0900 WH C0905 FAILS AND
SAME STACK(STACK-ZERO);
ELSE
GET1 C0900 WH NON-KEY C0905 EQ AND
SAME STACK(STACK-ZERO).
IF S2KRTC = ZERO
ADD 1 TO DUP-CTR-900
GO TO C0900-EXIT
ELSE
IF S2KRTC NOT = 4
GO TO S2K-ERROR.
C0900-INSERT.
MOVE '1' TO INSERT-MODE
*INSERT IS DONE ONLY IF NOT A DUPLICATE C900 RECORD.
INSERT C0900.
IF DB-RETURN-CODE NOT = 0 GO TO S2K-ERROR.
ADD 1 TO CTR-900.
* DISPLAY 'NEW C900 RECORD ADDED, C900 = ' C0900.
C0900-EXIT.
*
C1000-PARA.
MOVE C1000-IO TO C1000.
INSERT C1000.
IF DB-RETURN-CODE NOT = 0
DISPLAY 'INSERT FAILED, C1000 = ' C1000
GO TO S2K-ERROR.
ADD 1 TO CTR-1000.
* DISPLAY 'NEW C1000 RECORD ADDED, C1000 = ' C1000.
C1000-EXIT.
*
ERROR-RTN.
IF ERR-FLAG = '1'
DISPLAY 'INVALID COMP-NBR READ.'
ELSE DISPLAY 'NO VALUES FOR SCHEMA ', HEADER.
ERROR-RTN-EXIT. EXIT.
END PROCEDURE.
//*
//*
//GO.CBPARM DD *
SWITCH=0
//*