//TVAUNLD JOB (USERID,TX54),
// USERID,REGION=2M,TIME=(,5)
/*JOBPARM FETCH
//*
//************************************************************
//* COBOL PLEX COMPILE, LOAD AND GO
//************************************************************
//*
//S2KCLGC PROC OUT=A,FCP=1,FCS=1,COBNAME=TVAUNLD,
// 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.FEB.IVR94TR1,DISP=OLD
//IVR94TR2 DD DSN=SASBWC.FEB.IVR94TR2,DISP=OLD
//IVR94TR3 DD DSN=SASBWC.FEB.IVR94TR3,DISP=OLD
//IVR94TR4 DD DSN=SASBWC.FEB.IVR94TR4,DISP=OLD
//IVR94TR5 DD DSN=SASBWC.FEB.IVR94TR5,DISP=OLD
//IVR94TR6 DD DSN=SASBWC.FEB.IVR94TR6,DISP=OLD
//*IVR94TR7 DD DSN=SASBWC.FEB.IVR94TR7,DISP=OLD
//*CHANGE OUTFL DD TO POINT TO YOUR OUTPUT FILE FOR UNLOADED DATA.
//OUTFL DD DSN=SASCCT.TVA.FEBOUTCT,DISP=SHR
//*
// PEND
//*
// EXEC S2KCLGC
//PRECOM.SYSIN DD *
IDENTIFICATION DIVISION.
PROGRAM-ID. TVAUNLD.
*
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-370.
OBJECT-COMPUTER. IBM-370.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT OUT-FILE ASSIGN TO UT-S-OUTFL.
*
DATA DIVISION.
FILE SECTION.
FD OUT-FILE
RECORDING MODE IS V
LABEL RECORDS ARE STANDARD
BLOCK CONTAINS 6216 CHARACTERS
RECORD CONTAINS 17 TO 346 CHARACTERS.
01 GENERAL.
05 HEADER PIC X(4).
05 FILL1 PIC X(342).
01 REC-0000.
05 HDER PIC X(4).
05 C0000-IO PIC X(56).
01 REC-0200.
05 HDER PIC X(4).
05 C0200-IO PIC X(20).
01 REC-0800.
05 HDER PIC X(4).
05 C0800-IO PIC X(13).
01 REC-0900.
05 HDER PIC X(4).
05 C0900-IO PIC X(48).
01 REC-1000.
05 HDER PIC X(4).
05 C1000-IO PIC X(342).
*
WORKING-STORAGE SECTION.
*
*
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.
*
LINKAGE SECTION.
01 JCL-PARMS.
05 LNGTH PIC S9(4) COMP.
05 JCL-PSWD PIC X(4).
*
*
*
PROCEDURE DIVISION USING JCL-PARMS.
FOR IVR94TRA RC 1-3,5-127 GO TO S2K-ERROR.
START S2K.
MOVE JCL-PSWD TO DB-PASSWORD.
OPEN OUTPUT OUT-FILE.
OPEN IVR94TRA.
IF DB-RETURN-CODE NOT = 0 GO TO S2K-ERROR.
DISPLAY 'COMMBLOCK = ', IVR94TRA.
CALL 'QASTAT'.
GET1 C0000 FIRST.
IF DB-RETURN-CODE = 4
DISPLAY 'NO DATA IN DATA BASE', IVR94TRA
GO TO EOJ.
PERFORM C0000-PARA THRU C0000-EXIT UNTIL DB-RETURN-CODE = 4.
EOJ.
CALL 'QASTAT'.
CLOSE IVR94TRA.
IF DB-RETURN-CODE NOT = 0
DISPLAY 'DB CLOSE FAILED.'.
CLOSE OUT-FILE.
DISPLAY 'COMMBLOCK = ', IVR94TRA.
GOBACK.
S2K-ERROR.
DISPLAY 'S2K ERROR ENCOUNTERED.'.
DISPLAY 'COMMBLOCK = ', IVR94TRA.
FOR IVR94TRA CANCEL.
GO TO EOJ.
*
C0000-PARA.
MOVE '0000' TO HEADER.
MOVE C0000 TO C0000-IO.
WRITE REC-0000.
GETD C0200 NEXT.
PERFORM C0200-PARA THRU C0200-EXIT UNTIL DB-RETURN-CODE = 4.
GET1 C0000 NEXT.
C0000-EXIT. EXIT.
*
C0200-PARA.
MOVE '0200' TO HEADER.
MOVE C0200 TO C0200-IO.
WRITE REC-0200.
GETD C0800 NEXT.
PERFORM C0800-PARA THRU C0800-EXIT UNTIL DB-RETURN-CODE = 4.
GETD C0200 NEXT.
C0200-EXIT. EXIT.
*
C0800-PARA.
MOVE '0800' TO HEADER.
MOVE C0800 TO C0800-IO.
WRITE REC-0800.
GETD C0900 NEXT.
PERFORM C0900-PARA THRU C0900-EXIT UNTIL DB-RETURN-CODE = 4.
GETD C0800 NEXT.
C0800-EXIT. EXIT.
*
C0900-PARA.
MOVE '0900' TO HEADER.
MOVE C0900 TO C0900-IO.
WRITE REC-0900.
GETD C1000 NEXT.
PERFORM C1000-PARA THRU C1000-EXIT UNTIL DB-RETURN-CODE = 4.
GETD C0900 NEXT.
C0900-EXIT. EXIT.
*
C1000-PARA.
MOVE '1000' TO HEADER.
MOVE C1000 TO C1000-IO.
WRITE REC-1000.
GETD C1000 NEXT.
C1000-EXIT. EXIT.
*
END PROCEDURE.
//*
//GO.CBPARM DD *
SWITCH=0
//*