A mixture of JCL and Cobol. Outputs an inventory picklist.
000001 IDENTIFICATION DIVISION.
000002 PROGRAM-ID. ASST3.
000003 *****************************************************
000004 ** PROGRAM PURPOSE: INVENTORY MASTER UPDATE ASST 3
000005 ** PROGRAMMER NAME: STEVEN BARTSCH
000006 ** DATE : APR 16 2014
000007 *****************************************************
000008 ENVIRONMENT DIVISION.
000009 CONFIGURATION SECTION.
000010 SOURCE-COMPUTER. IBM-390 WITH DEBUGGING MODE.
000011 *SOURCE-COMPUTER. IBM-390.
000012 INPUT-OUTPUT SECTION.
000013 *****************************************************
000014 * FILE CONTROL **************************************
000015 *****************************************************
000016 FILE-CONTROL.
000017 SELECT F01-INVMAST
000018 ASSIGN TO INVMAST
000019 ORGANIZATION IS INDEXED
000020 ACCESS IS DYNAMIC
000021 RECORD KEY IS F01-ITEM
000022 FILE STATUS IS W01-F01-STAT.
000023 SELECT F02-INVORDR
000024 ASSIGN TO INVORDR.
000025 SELECT F03-INVREPT
000026 ASSIGN TO INVREPT.
000027 DATA DIVISION.
000028 *****************************************************
000029 * FILE SECTION **************************************
000030 *****************************************************
000031 FILE SECTION.
000032 FD F01-INVMAST
000033 RECORD CONTAINS 80 CHARACTERS
000034 DATA RECORD IS F01-INVENTORY.
000035 01 F01-INVENTORY.
000036 05 F01-ITEM PIC X(5).
000037 05 F01-DESC PIC X(20).
000038 05 F01-QOH PIC 9(5).
000039 05 F01-REORDER-QTY PIC 9(5).
000040 05 F01-REORDER-FLAG PIC X.
000041 05 F01-AISLE PIC XXX.
000042 05 F01-SHELF PIC XX.
000043 05 F01-BIN PIC XX.
000044 05 FILLER PIC X(37).
000045 FD F02-INVORDR
000046 RECORD CONTAINS 80 CHARACTERS
000047 RECORDING MODE F
000048 DATA RECORD IS F02-TRANSACTION.
000049 01 F02-TRANSACTION.
000050 05 F02-CODE PIC X.
000051 05 F02-CUST-ID PIC X(5).
000052 05 F02-ORDER-ID PIC X(5).
000053 05 F02-ITEMS OCCURS 6.
000054 10 F02-ITEM-ID PIC X(5).
000055 10 F02-ITEM-QTY PIC 9(4).
000056 05 FILLER PIC X(15).
000057 FD F03-INVREPT
000058 RECORD CONTAINS 80 CHARACTERS
000059 RECORDING MODE F
000060 DATA RECORD IS F03-OUPUT-LINE.
000061 01 F03-OUTPUT-LINE PIC X(80).
000062 *****************************************************
000063 * WORKING STORAGE ***********************************
000064 *****************************************************
000065 WORKING-STORAGE SECTION.
000066 01 W01-F01-STAT PIC XX VALUE '00'.
000067 01 W03-PICKN-HEADER-ONE.
000068 05 FILLER PIC X(6).
000069 05 FILLER PIC X(10) VALUE 'INVENTORY '.
000070 05 FILLER PIC X(8) VALUE 'PICKING'.
000071 05 FILLER PIC X(10) VALUE 'LIST '.
000072 05 FILLER PIC X(9) VALUE 'RUN DATE '.
000073 05 W03-DATE PIC XXXX/XX/XX.
000074 05 FILLER PIC X(7) VALUE ' PAGE '.
000075 05 W03-PAGE PIC ZZ9.
000076 05 FILLER PIC X(17).
000077 01 W04-PICKN-HEADER-TWO.
000078 05 FILLER PIC X(10) VALUE 'ORDER ID: '.
000079 05 W04-ORDER-ID PIC X(5).
000080 05 FILLER PIC X(9).
000081 05 FILLER PIC X(9) VALUE 'CUSTOMER '.
000082 05 FILLER PIC X(4) VALUE 'ID: '.
000083 05 W04-CUST-ID PIC X(5).
000084 05 FILLER PIC X(38).
000085 01 W05-PICKN-HEADER-THREE.
000086 05 FILLER PIC X(10) VALUE 'ITEM NUM '.
000087 05 FILLER PIC X(10) VALUE 'ITEM ID '.
000088 05 FILLER PIC X(10) VALUE ' QTY DESC'.
000089 05 FILLER PIC X(10) VALUE 'RIPTION '.
000090 05 FILLER PIC X(10) VALUE ' AIS'.
000091 05 FILLER PIC X(10) VALUE 'LE SHELF '.
000092 05 FILLER PIC X(10) VALUE ' BIN '.
000093 05 FILLER PIC X(10).
000094 01 W06-PICKN-LINE.
000095 05 W06-ITEM-NUM PIC 9 VALUE 0.
000096 05 FILLER PIC X(9).
000097 05 W06-ITEM-ID PIC X(5).
000098 05 FILLER PIC X(5).
000099 05 W06-ITEM-QTY PIC ZZZ9.
000100 05 FILLER PIC X(2).
000101 05 W06-ITEM-DESC PIC X(20).
000102 05 FILLER PIC X.
000103 05 W06-ITEM-AISLE PIC X(3).
000104 05 FILLER PIC X(4).
000105 05 W06-ITEM-SHELF PIC XX.
000106 05 FILLER PIC X(5).
000107 05 W06-ITEM-BIN PIC XX.
000108 05 FILLER PIC X(17).
000109 01 W07-REORDER-HEADER-ONE.
000110 05 FILLER PIC X(6).
000111 05 FILLER PIC X(10) VALUE 'RE-ORDER R'.
000112 05 FILLER PIC X(8) VALUE 'EPORT '.
000113 05 FILLER PIC X(10) VALUE ' '.
000114 05 FILLER PIC X(9) VALUE 'RUN DATE '.
000115 05 W07-DATE PIC XXXX/XX/XX.
000116 05 FILLER PIC X(7) VALUE ' PAGE '.
000117 05 W07-PAGE PIC ZZ9.
000118 01 W08-REORDER-HEADER-TWO.
000119 05 FILLER PIC X(10) VALUE 'ITEM ID '.
000120 05 FILLER PIC X(10) VALUE ' RE-ORDER-'.
000121 05 FILLER PIC X(10) VALUE 'QTY DESC'.
000122 05 FILLER PIC X(10) VALUE 'RIPTION '.
000123 05 FILLER PIC X(40).
000124 01 W09-REORDER-LINE.
000125 05 W09-ITEM-ID PIC X(5).
000126 05 FILLER PIC X(13).
000127 05 W09-ITEM-QTY PIC ZZZ9.
000128 05 FILLER PIC X(2).
000129 05 W09-ITEM-DESC PIC X(20).
000130 05 FILLER PIC X(36).
000131 01 W10-PAGE PIC 999.
000132 01 W11-EOF PIC X.
000133 01 W12-QOH PIC 9(5).
000134 01 W13-SUB PIC 99.
000135 *****************************************************
000136 * PROCEDURE DIVISION ********************************
000137 *****************************************************
000138 PROCEDURE DIVISION.
000139 PERFORM 100-OPEN-FILES
000140 PERFORM 400-PICKING-DATA
000141 CLOSE F01-INVMAST
000142 PERFORM 700-REORDER-OUTPUT
000143 PERFORM 800-CLOSE-FILES
000144 STOP RUN.
000145 100-OPEN-FILES.
000146 OPEN I-O F01-INVMAST
000147 IF W01-F01-STAT NOT = "00"
000148 1 DISPLAY "MAST OPEN FAILED, FILE STATUS="
000149 1 W01-F01-STAT
000150 1 MOVE 98 TO RETURN-CODE
000151 1 STOP RUN
000152 END-IF
000153 OPEN INPUT F02-INVORDR
000154 OPEN OUTPUT F03-INVREPT
000155 .
000156 400-PICKING-DATA.
000157 PERFORM UNTIL W11-EOF = "Y"
000158 1 READ F02-INVORDR
000159 2 AT END MOVE "Y" TO W11-EOF
000160 1 NOT AT END
000161
000162 2 PERFORM 500-PICKING-OUTPUT
000163 2 MOVE "N" TO W11-EOF
000164 2 PERFORM VARYING W13-SUB FROM 1 BY 1
000165 2 UNTIL W13-SUB > 6
000166 3 MOVE F02-ITEM-ID(W13-SUB) TO F01-ITEM
000167 3 IF F02-ITEM-ID(W13-SUB) NOT = SPACES
000168 4 READ F01-INVMAST
000169 4 INVALID KEY
000170 5 MOVE W13-SUB TO W06-ITEM-NUM
000171 5 MOVE F02-ITEM-ID(W13-SUB) TO W06-ITEM-ID
000172 5 MOVE F02-ITEM-QTY(W13-SUB) TO W06-ITEM-QTY
000173 5 MOVE "ERROR - NO INVENTORY" TO W06-ITEM-DESC
000174 5 MOVE SPACES TO W06-ITEM-AISLE
000175 5 MOVE SPACES TO W06-ITEM-SHELF
000176 5 MOVE SPACES TO W06-ITEM-BIN
000177 4 NOT INVALID KEY
000179 5 COMPUTE W12-QOH = F01-QOH - F02-ITEM-QTY(W13-SUB)
000181 5 IF W12-QOH LESS THAN F01-REORDER-QTY
000182 6 MOVE "*" TO F01-REORDER-FLAG
000183 5 END-IF
000184 5 MOVE W12-QOH TO F01-QOH
000186 5 REWRITE F01-INVENTORY
000187 5 INVALID KEY
000188 6 CONTINUE
000189 5 NOT INVALID KEY
000190 6 DISPLAY "MASTER RECORD UPDATED"
000191 5 END-REWRITE
000193 5 MOVE W13-SUB TO W06-ITEM-NUM
000194 5 MOVE F02-ITEM-ID(W13-SUB) TO W06-ITEM-ID
000195 5 MOVE F02-ITEM-QTY(W13-SUB) TO W06-ITEM-QTY
000196 5 MOVE F01-DESC TO W06-ITEM-DESC
000197 5 MOVE F01-AISLE TO W06-ITEM-AISLE
000198 5 MOVE F01-SHELF TO W06-ITEM-SHELF
000199 5 MOVE F01-BIN TO W06-ITEM-BIN
000200 4 END-READ
000201 4 MOVE W06-PICKN-LINE TO F03-OUTPUT-LINE
000202 4 WRITE F03-OUTPUT-LINE
000203 3 END-IF
000204 2 END-PERFORM
000205 2 MOVE SPACES TO F03-OUTPUT-LINE
000206 2 WRITE F03-OUTPUT-LINE
000207 2 WRITE F03-OUTPUT-LINE
000208 1 END-READ
000209 END-PERFORM
000210 .
000211 500-PICKING-OUTPUT.
000212 MOVE FUNCTION CURRENT-DATE(1:8) TO W03-DATE
000213 ADD 1 TO W10-PAGE
000214 MOVE W10-PAGE TO W03-PAGE
000215 MOVE F02-ORDER-ID TO W04-ORDER-ID
000216 MOVE F02-CUST-ID TO W04-CUST-ID
000217 MOVE W03-PICKN-HEADER-ONE TO F03-OUTPUT-LINE
000218 WRITE F03-OUTPUT-LINE
000219 MOVE SPACES TO F03-OUTPUT-LINE
000220 WRITE F03-OUTPUT-LINE
000221 MOVE W04-PICKN-HEADER-TWO TO F03-OUTPUT-LINE
000222 WRITE F03-OUTPUT-LINE
000223 MOVE SPACES TO F03-OUTPUT-LINE
000224 WRITE F03-OUTPUT-LINE
000225 MOVE W05-PICKN-HEADER-THREE TO F03-OUTPUT-LINE
000226 WRITE F03-OUTPUT-LINE
000227 MOVE SPACES TO F03-OUTPUT-LINE
000228 WRITE F03-OUTPUT-LINE
000229 .
000230 600-REORDER-REPORT.
000231 MOVE "N" TO W11-EOF
000232 MOVE 0 TO W10-PAGE
000233 OPEN INPUT F01-INVMAST
000234 PERFORM UNTIL W11-EOF = "Y"
000235 1 READ F01-INVMAST NEXT RECORD
000236 2 AT END MOVE "Y" TO W11-EOF
000237 1 NOT AT END
000238 2 IF F01-REORDER-FLAG = "*"
000239 3 MOVE F01-ITEM TO W09-ITEM-ID
000240 3 MOVE F01-REORDER-QTY TO W09-ITEM-QTY
000241 3 MOVE F01-DESC TO W09-ITEM-DESC
000242 3 MOVE W09-REORDER-LINE TO F03-OUTPUT-LINE
000243 3 WRITE F03-OUTPUT-LINE
000244 2 END-IF
000245 1 END-READ
000246 END-PERFORM
000247 .
000248 700-REORDER-OUTPUT.
000249 MOVE FUNCTION CURRENT-DATE(1:8) TO W07-DATE
000250 MOVE 1 TO W10-PAGE
000251 MOVE W10-PAGE TO W07-PAGE
000252 MOVE W07-REORDER-HEADER-ONE TO F03-OUTPUT-LINE
000253 WRITE F03-OUTPUT-LINE
000254 MOVE SPACES TO F03-OUTPUT-LINE
000255 WRITE F03-OUTPUT-LINE
000256 MOVE W08-REORDER-HEADER-TWO TO F03-OUTPUT-LINE
000257 WRITE F03-OUTPUT-LINE
000258 MOVE SPACES TO F03-OUTPUT-LINE
000259 WRITE F03-OUTPUT-LINE
000260 PERFORM 600-REORDER-REPORT
000261 .
000262 800-CLOSE-FILES.
000263 CLOSE F01-INVMAST
000264 CLOSE F02-INVORDR
000265 CLOSE F03-INVREPT
000266 .1 1 //KC03D35A JOB 1, JOB02942
// 'STEVEN BARTSCH',
// MSGCLASS=H,
// NOTIFY=&SYSUID,TIME=(,10)
//*
//*
//* COMP251 - COBOL
//**********************************************************
//* ASST3 FIRST MAINFRAME COMPILE-LINK-GO *
//* STANDARD COBOL JOB JCL FOR COMP 251 ASSIGNMENTS *
//**********************************************************
//*
IEFC653I SUBSTITUTION JCL - 1,'STEVEN BARTSCH',MSGCLASS=H,NOTIFY=KC03D35,TIME=(,10)
2 //STEPONE EXEC PGM=IDCAMS
3 //SYSPRINT DD SYSOUT=*
4 //SYSIN DD *
5 //MYINPUT DD DSN=SLC.CPA.COMP251.CNTL(INVMAST),
// DISP=SHR
//*
6 //STEPTWO EXEC IGYWCLG
7 XXIGYWCLG PROC LNGPRFX='IGY420',SYSLBLK=3200, 00001001
XX LIBPRFX='CEE',GOPGM=GO 00002000
XX* 00003000
XX********************************************************************* 00004000
XX* * 00005000
XX* Enterprise COBOL for z/OS * 00006000
XX* Version 4 Release 1 Modification 0 * 00007000
XX* * 00008000
XX* LICENSED MATERIALS - PROPERTY OF IBM. * 00009000
XX* * 00010000
XX* 5655-S71 © COPYRIGHT IBM CORP. 1991, 2007 * 00011000
XX* ALL RIGHTS RESERVED * 00012000
XX* * 00013000
XX* US GOVERNMENT USERS RESTRICTED RIGHTS - USE, * 00014000
XX* DUPLICATION OR DISCLOSURE RESTRICTED BY GSA * 00015000
XX* ADP SCHEDULE CONTRACT WITH IBM CORP. * 00016000
XX* * 00017000
XX********************************************************************* 00018000
XX* 00019000
XX* COMPILE, LINK EDIT AND RUN A COBOL PROGRAM 00020000
XX* 00021000
XX* PARAMETER DEFAULT VALUE USAGE 00022000
XX* LNGPRFX IGY420 PREFIX FOR LANGUAGE DATA SET NAMES 00023001
XX* SYSLBLK 3200 BLKSIZE FOR OBJECT DATA SET 00024000
XX* LIBPRFX CEE PREFIX FOR LIBRARY DATA SET NAMES 00025000
XX* GOPGM GO MEMBER NAME FOR LOAD MODULE 00026000
XX* 00027000
XX* CALLER MUST SUPPLY //COBOL.SYSIN DD ... 00028000
XX* 00029000
XX* CALLER MUST ALSO SUPPLY //COBOL.SYSLIB DD ... for COPY statements 00030000
XX* 00031000
8 XXCOBOL EXEC PGM=IGYCRCTL,REGION=0M 00032000
9 XXSTEPLIB DD DSNAME=&LNGPRFX..SIGYCOMP, 00033000
XX DISP=SHR 00034000
IEFC653I SUBSTITUTION JCL - DSNAME=IGY420.SIGYCOMP,DISP=SHR
10 XXSYSPRINT DD SYSOUT=* 00035000
11 XXSYSLIN DD DSNAME=&&LOADSET,UNIT=SYSALLDA, 00036000
XX DISP=(MOD,PASS),SPACE=(TRK,(3,3)), 00037000
XX DCB=(BLKSIZE=&SYSLBLK) 00038000
IEFC653I SUBSTITUTION JCL - DSNAME=&&LOADSET,UNIT=SYSALLDA,DISP=(MOD,PASS),SPACE=(TRK,(3,3)),
DCB=(BLKSIZE=3200)
12 XXSYSUT1 DD UNIT=SYSALLDA,SPACE=(CYL,(1,1)) 00039000
13 XXSYSUT2 DD UNIT=SYSALLDA,SPACE=(CYL,(1,1)) 00040000
14 XXSYSUT3 DD UNIT=SYSALLDA,SPACE=(CYL,(1,1)) 00041000
15 XXSYSUT4 DD UNIT=SYSALLDA,SPACE=(CYL,(1,1)) 00042000
16 XXSYSUT5 DD UNIT=SYSALLDA,SPACE=(CYL,(1,1)) 00043000
17 XXSYSUT6 DD UNIT=SYSALLDA,SPACE=(CYL,(1,1)) 00044000
18 XXSYSUT7 DD UNIT=SYSALLDA,SPACE=(CYL,(1,1)) 00045000
19 //COBOL.SYSIN DD DSN=&SYSUID..COMP251.COBOL(ASST3),DISP=SHR
IEFC653I SUBSTITUTION JCL - DSN=KC03D35.COMP251.COBOL(ASST3),DISP=SHR
20 XXLKED EXEC PGM=HEWL,COND=(8,LT,COBOL),REGION=0M 00046000
21 XXSYSLIB DD DSNAME=&LIBPRFX..SCEELKED, 00047000
XX DISP=SHR 00048000
IEFC653I SUBSTITUTION JCL - DSNAME=CEE.SCEELKED,DISP=SHR
22 XXSYSPRINT DD SYSOUT=* 00049000
23 XXSYSLIN DD DSNAME=&&LOADSET,DISP=(OLD,DELETE) 00050000
24 XX DD DDNAME=SYSIN 00051000
25 XXSYSLMOD DD DSNAME=&&GOSET(&GOPGM),SPACE=(TRK,(10,10,1)), 00052000
XX UNIT=SYSALLDA,DISP=(MOD,PASS) 00053000
IEFC653I SUBSTITUTION JCL - DSNAME=&&GOSET(GO),SPACE=(TRK,(10,10,1)),UNIT=SYSALLDA,DISP=(MOD,PASS)
26 XXSYSUT1 DD UNIT=SYSALLDA,SPACE=(TRK,(10,10)) 00054000
27 XXGO EXEC PGM=*.LKED.SYSLMOD,COND=((8,LT,COBOL),(4,LT,LKED)), 00055000
XX REGION=0M 00056000
28 XXSTEPLIB DD DSNAME=&LIBPRFX..SCEERUN, 00057000
XX DISP=SHR 00058000
IEFC653I SUBSTITUTION JCL - DSNAME=CEE.SCEERUN,DISP=SHR
29 XXSYSPRINT DD SYSOUT=* 00059000
30 //GO.CEEDUMP DD SYSOUT=*,OUTLIM=4000 PREVENT LARGE DUMPS
X/CEEDUMP DD SYSOUT=* 00060000
31 //GO.SYSUDUMP DD SYSOUT=*,OUTLIM=2000 PREVENT LARGE DUMPS
X/SYSUDUMP DD SYSOUT=* 00061000
//***** COBOL AND OS USES THESE FILES
//*
32 //GO.SYSOUT DD SYSOUT=*,OUTLIM=2000 USED BY DISPLAY COMMAND
//***** PROGRAM SELECT STATEMENT FILES
33 //GO.INVMAST DD DSN=KC03D35.COMP251.KSDSFILE,DISP=SHR
34 //GO.INVORDR DD DSN=SLC.CPA.COMP251.CNTL(INVORDER),DISP=SHR
35 //GO.INVREPT DD SYSOUT=*
//*
36 //STEPTHRE EXEC PGM=IDCAMS
37 //SYSPRINT DD SYSOUT=*
38 //SYSIN DD *1 INVENTORY PICKING LIST RUN DATE 2014/04/16 PAGE 1
ORDER ID: X0001 CUSTOMER ID: C0123
ITEM NUM ITEM ID QTY DESCRIPTION AISLE SHELF BIN
1 A0002 10 2X4X10 PINE A12 S3 B5
2 A0042 20 2X6X10 W RED CEDAR A14 S1 B5
3 B0022 500 NO8 2.5 DECK SCREW A04 S2 B2
INVENTORY PICKING LIST RUN DATE 2014/04/16 PAGE 2
ORDER ID: X1002 CUSTOMER ID: C0987
ITEM NUM ITEM ID QTY DESCRIPTION AISLE SHELF BIN
1 A0012 15 ERROR - NO INVENTORY
2 A0022 15 2X6X10 PINE A12 S3 B5
3 B0012 400 NO7 2.5 DECK SCREW A04 S2 B2
4 B0023 300 NO8 3.0 DECK SCREW A04 S2 B3
5 A0041 23 2X6X8 W RED CEDAR A14 S1 B4
6 B0011 60 NO7 2IN DECK SCREW A04 S2 B1
INVENTORY PICKING LIST RUN DATE 2014/04/16 PAGE 3
ORDER ID: X2344 CUSTOMER ID: C1543
ITEM NUM ITEM ID QTY DESCRIPTION AISLE SHELF BIN
1 A0013 33 ERROR - NO INVENTORY
2 B0022 450 NO8 2.5 DECK SCREW A04 S2 B2
INVENTORY PICKING LIST RUN DATE 2014/04/16 PAGE 4
ORDER ID: X5434 CUSTOMER ID: C4672
ITEM NUM ITEM ID QTY DESCRIPTION AISLE SHELF BIN
1 A0002 44 2X4X10 PINE A12 S3 B5
2 B0012 650 NO7 2.5 DECK SCREW A04 S2 B2
3 C0042 30 ERROR - NO INVENTORY
INVENTORY PICKING LIST RUN DATE 2014/04/16 PAGE 5
ORDER ID: X2245 CUSTOMER ID: C8744
ITEM NUM ITEM ID QTY DESCRIPTION AISLE SHELF BIN
1 A0023 15 2X6X12 PINE A12 S3 B6
2 B0002 250 NO6 2.5 DECK SCREW A04 S1 B2
3 A0002 35 2X4X10 PINE A12 S3 B5
INVENTORY PICKING LIST RUN DATE 2014/04/16 PAGE 6
ORDER ID: X4033 CUSTOMER ID: C0543
ITEM NUM ITEM ID QTY DESCRIPTION AISLE SHELF BIN
1 A0012 23 ERROR - NO INVENTORY
2 A0023 12 2X6X12 PINE A12 S3 B6
3 B0022 460 NO8 2.5 DECK SCREW A04 S2 B2
4 B0003 350 NO6 3.0 DECK SCREW A04 S1 B3
5 A0032 15 2X4X10 PT PINE A13 S5 B5
6 B0022 70 NO8 2.5 DECK SCREW A04 S2 B2 RE-ORDER REPORT RUN DATE 2014/04/16 PAGE 1
ITEM ID RE-ORDER-QTY DESCRIPTION
A0002 50 2X4X10 PINE
A0037 40 4X4X8 PT PINE
B0003 1000 NO6 3.0 DECK SCREW