5738PW1 V2R1M1 920327 SEU SOURCE LISTING 03/29/92 17:12:35 PAGE 1 SOURCE FILE . . . . . . . DRDA/QLBLSRC MEMBER . . . . . . . . . DDBPT6CB SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 100 IDENTIFICATION DIVISION. 200 *------------------------ 300 PROGRAM-ID. DDBPT6CB. 03/29/92 400 **************************************************************** 03/29/92 500 * MODULE NAME = DDBPT6CB 03/29/92 600 * 700 * DESCRIPTIVE NAME = D-DB SAMPLE APPLICATION 800 * REORDER POINT PROCESSING 900 * AS/400 03/29/92 1000 * COBOL 1100 * 1200 * FUNCTION = THIS MODULE PROCESS THE PART_STOCK TABLE AND 1300 * FOR EACH PART BELOW THE ROP (REORDER POINT) 1400 * CHECKS THE EXISTING ORDERS AND SHIPMENTS, 03/29/92 1500 * CREATES A SUPPLY ORDER AND PRINTS A REPORT. 03/29/92 1600 * 1700 * DEPENDENCIES = NONE 03/29/92 1800 * 1900 * INPUT = PARAMETERS EXPLICITLY PASSED TO THIS FUNCTION: 2000 * 2100 * LOCAL-DB LOCAL DB NAME 03/29/92 2200 * REMOTE-DB REMOTE DB NAME 03/29/92 2300 * 2400 * TABLES = PART-STOCK - LOCAL 03/29/92 2500 * PART_ORDER - REMOTE 03/29/92 2600 * PART_ORDLN - REMOTE 03/29/92 2700 * SHIPMENTLN - REMOTE 03/29/92 2800 * 03/29/92 2900 * CRTSQLCBL SPECIAL PARAMETERS 03/29/92 3000 * PGM(DDBPT6CB) RDB(remotedbname) OPTION(*APOST *APOSTSQL) 03/29/92 3100 * 03/29/92 3200 * INVOKE BY : CALL DDBPT6CB PARM(localdbname remotedbname) 03/29/92 3300 * 03/29/92 3400 **************************************************************** 03/29/92 3500 ENVIRONMENT DIVISION. 3600 *--------------------- 3700 INPUT-OUTPUT SECTION. 3800 FILE-CONTROL. 3900 SELECT RELAT ASSIGN TO PRINTER-QPRINT. 03/29/92 4000 DATA DIVISION. 4100 *-------------- 4200 FILE SECTION. 4300 *------------- 03/29/92 4400 FD RELAT 4500 RECORD CONTAINS 33 CHARACTERS 4600 LABEL RECORDS ARE OMITTED 4700 DATA RECORD IS REPREC. 4800 01 REPREC PIC X(33). 4900 WORKING-STORAGE SECTION. 5000 *------------------------ 03/29/92 5100 * PRINT LINE DEFINITIONS 03/29/92 5200 01 LINE0 PIC X(33) VALUE SPACES. 5300 01 LINE1 PIC X(33) VALUE
5738PW1 V2R1M1 920327 SEU SOURCE LISTING 03/29/92 17:12:35 PAGE 2 SOURCE FILE . . . . . . . DRDA/QLBLSRC MEMBER . . . . . . . . . DDBPT6CB SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 5400 '***** ROP PROCESSING REPORT *****'. 5500 01 LINE2. 5600 05 FILLER PIC X(18) VALUE ' ORDER NUMBER = '. 5700 05 MASK0 PIC ZZZ9. 5800 05 FILLER PIC X(11) VALUE SPACES. 5900 01 LINE3 PIC X(33) VALUE 6000 '---------------------------------'. 6100 01 LINE4 PIC X(33) VALUE 6200 ' LINE PART QTY '. 6300 01 LINE5 PIC X(33) VALUE 6400 ' NUMBER NUMBER REQUESTED '. 6500 01 LINE6. 6600 05 FILLER PIC XXXX VALUE SPACES. 6700 05 MASK1 PIC ZZZ9. 6800 05 FILLER PIC XXXX VALUE SPACES. 6900 05 PART-TABLE PIC XXXXX. 7000 05 FILLER PIC XXXX VALUE SPACES. 7100 05 MASK2 PIC Z,ZZZ,ZZZ.ZZ. 7200 01 LINE7. 7300 05 FILLER PIC X(26) VALUE 7400 'NUMBER OF LINES CREATED = '. 7500 05 MASK3 PIC ZZZ9. 7600 05 FILLER PIC XXX VALUE SPACES. 7700 01 LINE8 PIC X(33) VALUE 7800 '********* END OF PROGRAM ********'. 7900 * MISCELLANEOUS DEFINITIONS 03/29/92 8000 01 WHAT-TIME PIC X VALUE '1'. 8100 88 FIRST-TIME VALUE '1'. 8200 01 CONTL PIC S9999 COMP-4 VALUE ZEROS. 03/29/92 8300 01 CONTD PIC S9999 COMP-4 VALUE ZEROS. 03/29/92 8400 01 RTCODE1 PIC S9999 COMP-4 VALUE ZEROS. 03/29/92 8500 01 RTCODE2 PIC S9999 COMP-4. 03/29/92 8600 01 NEXT-NUM PIC S9999 COMP-4. 03/29/92 8700 01 IND-NULL PIC S9999 COMP-4. 03/29/92 8800 01 LOC-TABLE PIC X(16). 8900 01 ORD-TABLE PIC S9999 COMP-4. 03/29/92 9000 01 ORL-TABLE PIC S9999 COMP-4. 03/29/92 9100 01 QUANT-TABLE PIC S9(9) COMP-4. 03/29/92 9200 01 QTY-TABLE PIC S9(9) COMP-4. 03/29/92 9300 01 ROP-TABLE PIC S9(9) COMP-4. 03/29/92 9400 01 EOQ-TABLE PIC S9(9) COMP-4. 03/29/92 9500 01 QTY-REQ PIC S9(9) COMP-4. 03/29/92 9600 01 QTY-REC PIC S9(9) COMP-4. 03/29/92 9700 * CONSTANT FOR LOCATION NUMBER 03/29/92 9800 01 XPARM. 03/29/92 9900 05 LOC PIC X(4) VALUE 'SQLA'. 03/29/92 10000 * DEFINITIONS FOR ERROR MESSAGE HANDLING 03/29/92 10100 01 ERROR-MESSAGE. 03/29/92 10200 05 MSG-ID. 03/29/92 10300 10 MSG-ID-1 PIC X(2) 03/29/92 10400 VALUE 'SQ'. 03/29/92 10500 10 MSG-ID-2 PIC 99999. 03/29/92
5738PW1 V2R1M1 920327 SEU SOURCE LISTING 03/29/92 17:12:35 PAGE 3 SOURCE FILE . . . . . . . DRDA/QLBLSRC MEMBER . . . . . . . . . DDBPT6CB SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 10600 ****************************** 03/29/92 10700 * SQLCA INCLUDE * 03/29/92 10800 ****************************** 03/29/92 10900 EXEC SQL INCLUDE SQLCA END-EXEC. 11000 03/29/92 11100 LINKAGE SECTION. 03/29/92 11200 *---------------- 03/29/92 11300 01 LOCAL-DB PIC X(18). 03/29/92 11400 01 REMOTE-DB PIC X(18). 03/29/92 11500 03/29/92 11600 PROCEDURE DIVISION USING LOCAL-DB REMOTE-DB. 03/29/92 11700 *------------------ 03/29/92 11800 ***************************** 03/29/92 11900 * SQL CURSOR DECLARATION * 03/29/92 12000 ***************************** 03/29/92 12100 * RE-POSITIONABLE CURSOR : POSITION AFTER LAST PART_NUM 03/29/92 12200 EXEC SQL DECLARE NEXT_PART CURSOR FOR 12300 SELECT PART_NUM, 12400 PART_QUANT, 12500 PART_ROP, 12600 PART_EOQ 12700 FROM PART_STOCK 12800 WHERE PART_ROP > PART_QUANT 12900 AND PART_NUM > :PART-TABLE 03/29/92 13000 ORDER BY PART_NUM ASC 03/29/92 13100 END-EXEC. 13200 * CURSOR FOR ORDER LINES 03/29/92 13300 EXEC SQL DECLARE NEXT_ORDER_LINE CURSOR FOR 13400 SELECT A.ORDER_NUM, 13500 ORDER_LINE, 13600 QUANT_REQ 13700 FROM PART_ORDLN A, 03/29/92 13800 PART_ORDER B 13900 WHERE PART_NUM = :PART-TABLE 14000 AND LINE_STAT <> 'C' 03/29/92 14100 AND A.ORDER_NUM = B.ORDER_NUM 14200 AND ORDER_TYPE = 'R' 14300 END-EXEC. 14400 ****************************** 03/29/92 14500 * SQL RETURN CODE HANDLING* 03/29/92 14600 ****************************** 03/29/92 14700 EXEC SQL WHENEVER SQLERROR GO TO DB-ERROR END-EXEC. 14800 EXEC SQL WHENEVER SQLWARNING CONTINUE END-EXEC. 03/29/92 14900 03/29/92 15000 MAIN-PROGRAM-PROC. 03/29/92 15100 *------------------ 03/29/92 15200 PERFORM START-UP THRU START-UP-EXIT. 03/29/92 15300 PERFORM MAIN-PROC THRU MAIN-EXIT UNTIL RTCODE1 = 100. 03/29/92 15400 END-OF-PROGRAM. 03/29/92
5738PW1 V2R1M1 920327 SEU SOURCE LISTING 03/29/92 17:12:35 PAGE 4 SOURCE FILE . . . . . . . DRDA/QLBLSRC MEMBER . . . . . . . . . DDBPT6CB SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 15500 *--------------- 03/29/92 15600 **** 03/29/92 15700 EXEC SQL CONNECT RESET END-EXEC. 03/29/92 15800 **** 15900 CLOSE RELAT. 16000 GOBACK. 16100 MAIN-PROGRAM-EXIT. EXIT. 03/29/92 16200 *------------------ 03/29/92 16300 03/29/92 16400 START-UP. 03/29/92 16500 *---------- 03/29/92 16600 OPEN OUTPUT RELAT. 03/29/92 16700 **** 03/29/92 16800 EXEC SQL COMMIT END-EXEC. 03/29/92 16900 **** 03/29/92 17000 PERFORM CLEAN-UP THRU CLEAN-UP-EXIT. 03/29/92 17100 ******************************** 03/29/92 17200 * CONNECT TO LOCAL DATABASE * 03/29/92 17300 ******************************** 03/29/92 17400 **** 03/29/92 17500 EXEC SQL CONNECT TO :LOCAL-DB END-EXEC. 03/29/92 17600 **** 03/29/92 17700 START-UP-EXIT. EXIT. 03/29/92 17800 *------------ 03/29/92 17900 EJECT 18000 MAIN-PROC. 18100 *--------- 18200 EXEC SQL OPEN NEXT_PART END-EXEC. 03/29/92 18300 EXEC SQL 18400 FETCH NEXT_PART 18500 INTO :PART-TABLE, 18600 :QUANT-TABLE, 18700 :ROP-TABLE, 18800 :EOQ-TABLE 18900 END-EXEC. 19000 IF SQLCODE = 100 19100 MOVE 100 TO RTCODE1 03/29/92 19200 PERFORM TRAILER-PROC THRU TRAILER-EXIT 03/29/92 19300 ELSE 19400 MOVE 0 TO RTCODE2 19500 MOVE 0 TO QTY-REQ 19600 MOVE 0 TO QTY-REC 19700 * --- IMPLICIT "CLOSE" CAUSED BY COMMIT --- 03/29/92 19800 **** 03/29/92 19900 EXEC SQL COMMIT END-EXEC 03/29/92 20000 **** 03/29/92 20100 ********************************* 03/29/92 20200 * CONNECT TO REMOTE DATABASE * 03/29/92 20300 ********************************* 03/29/92
5738PW1 V2R1M1 920327 SEU SOURCE LISTING 03/29/92 17:12:35 PAGE 5 SOURCE FILE . . . . . . . DRDA/QLBLSRC MEMBER . . . . . . . . . DDBPT6CB SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 20400 **** 03/29/92 20500 EXEC SQL CONNECT TO :REMOTE-DB END-EXEC 03/29/92 20600 **** 03/29/92 20700 EXEC SQL OPEN NEXT_ORDER_LINE END-EXEC 03/29/92 20800 PERFORM UNTIL RTCODE2 = 100 20900 EXEC SQL 03/29/92 21000 FETCH NEXT_ORDER_LINE 21100 INTO :ORD-TABLE, 21200 :ORL-TABLE, 21300 :QTY-TABLE 21400 END-EXEC 21500 IF SQLCODE = 100 21600 MOVE 100 TO RTCODE2 21700 EXEC SQL CLOSE NEXT_ORDER_LINE END-EXEC 21800 ELSE 21900 ADD QTY-TABLE TO QTY-REQ 22000 EXEC SQL 22100 SELECT SUM(QUANT_RECV) 03/29/92 22200 INTO :QTY-TABLE:IND-NULL 22300 FROM SHIPMENTLN 03/29/92 22400 WHERE ORDER_LOC = :LOC 22500 AND ORDER_NUM = :ORD-TABLE 22600 AND ORDER_LINE = :ORL-TABLE 22700 END-EXEC 22800 IF IND-NULL NOT < 0 22900 ADD QTY-TABLE TO QTY-REC 23000 END-IF 23100 END-IF 23200 END-PERFORM 23300 IF ROP-TABLE > QUANT-TABLE + QTY-REQ - QTY-REC 23400 PERFORM ORDER-PROC THRU ORDER-EXIT 23500 END-IF 23600 END-IF. 23700 **** 03/29/92 23800 EXEC SQL COMMIT END-EXEC. 03/29/92 23900 **** 03/29/92 24000 ********************************** 03/29/92 24100 * RECONNECT TO LOCAL DATABASE * 03/29/92 24200 ********************************** 03/29/92 24300 **** 03/29/92 24400 EXEC SQL CONNECT TO :LOCAL-DB END-EXEC. 03/29/92 24500 **** 03/29/92 24600 MAIN-EXIT. EXIT. 24700 *--------------- 24800 ORDER-PROC. 24900 *---------- 25000 IF FIRST-TIME 25100 MOVE '2' TO WHAT-TIME 25200 PERFORM CREATE-ORDER-PROC THRU CREATE-ORDER-EXIT. 03/29/92 25300 ADD 1 TO CONTL.
5738PW1 V2R1M1 920327 SEU SOURCE LISTING 03/29/92 17:12:35 PAGE 7 SOURCE FILE . . . . . . . DRDA/QLBLSRC MEMBER . . . . . . . . . DDBPT6CB SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 25400 EXEC SQL 25500 INSERT 25600 INTO PART_ORDLN 03/29/92 25700 (ORDER_NUM, 25800 ORDER_LINE, 25900 PART_NUM, 26000 QUANT_REQ, 26100 LINE_STAT) 26200 VALUES (:NEXT-NUM, 26300 :CONTL, 26400 :PART-TABLE, 26500 :EOQ-TABLE, 26600 'O') 26700 END-EXEC. 26800 PERFORM DETAIL-PROC THRU DETAIL-EXIT. 26900 ORDER-EXIT. EXIT. 27000 *---------------- 27100 03/29/92 27200 CREATE-ORDER-PROC. 03/29/92 27300 *------------------ 03/29/92 27400 *GET NEXT ORDER NUMBER 03/29/92 27500 EXEC SQL 03/29/92 27600 SELECT (MAX(ORDER_NUM) + 1) 03/29/92 27700 INTO :NEXT-NUM:IND-NULL 03/29/92 27800 FROM PART_ORDER 03/29/92 27900 END-EXEC. 03/29/92 28000 IF IND-NULL < 0 03/29/92 28100 MOVE 1 TO NEXT-NUM. 03/29/92 28200 EXEC SQL 03/29/92 28300 INSERT 03/29/92 28400 INTO PART_ORDER 03/29/92 28500 (ORDER_NUM, 03/29/92 28600 ORIGIN_LOC, 03/29/92 28700 ORDER_TYPE, 03/29/92 28800 ORDER_STAT, 03/29/92 28900 CREAT_TIME) 03/29/92 29000 VALUES (:NEXT-NUM, 03/29/92 29100 :LOC, 'R', 'O', 03/29/92 29200 CURRENT TIMESTAMP) 03/29/92 29300 END-EXEC. 03/29/92 29400 MOVE NEXT-NUM TO MASK0. 03/29/92 29500 PERFORM HEADER-PROC THRU HEADER-EXIT. 03/29/92 29600 CREATE-ORDER-EXIT. EXIT. 03/29/92 29700 *------------------ 03/29/92 29800 03/29/92 29900 DB-ERROR. 03/29/92 30000 *-------- 03/29/92 30100 PERFORM ERROR-MSG-PROC THRU ERROR-MSG-EXIT. 03/29/92 30200 *********************** 03/29/92 30300 * ROLLBACK THE LUW * 03/29/92
5738PW1 V2R1M1 920327 SEU SOURCE LISTING 03/29/92 17:12:35 PAGE 8 SOURCE FILE . . . . . . . DRDA/QLBLSRC MEMBER . . . . . . . . . DDBPT6CB SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 30400 *********************** 03/29/92 30500 EXEC SQL WHENEVER SQLERROR CONTINUE END-EXEC. 03/29/92 30600 **** 03/29/92 30700 EXEC SQL ROLLBACK WORK END-EXEC. 03/29/92 30800 **** 03/29/92 30900 PERFORM END-OF-PROGRAM THRU MAIN-PROGRAM-EXIT. 03/29/92 31000 * -- NEXT LINE INCLUDED TO RESET THE "GO TO" DEFAULT -- 03/29/92 31100 EXEC SQL WHENEVER SQLERROR GO TO DB-ERROR END-EXEC. 03/29/92 31200 03/29/92 31300 ERROR-MSG-PROC. 03/29/92 31400 *---------- 03/29/92 31500 MOVE SQLCODE TO MSG-ID-2. 03/29/92 31600 DISPLAY 'SQL STATE =' SQLSTATE ' SQLCODE =' MSG-ID-2. 03/29/92 31700 * -- ADD HERE ANY ADDITIONAL ERROR MESSAGE HANDLING -- 03/29/92 31800 ERROR-MSG-EXIT. EXIT. 03/29/92 31900 *---------------- 03/29/92 32000 03/29/92 32100 ******************* 03/29/92 32200 * REPORT PRINTING * 03/29/92 32300 ******************* 03/29/92 32400 HEADER-PROC. 03/29/92 32500 *----------- 03/29/92 32600 WRITE REPREC FROM LINE1 AFTER ADVANCING PAGE. 32700 WRITE REPREC FROM LINE2 AFTER ADVANCING 3 LINES. 32800 WRITE REPREC FROM LINE3 AFTER ADVANCING 2 LINES. 32900 WRITE REPREC FROM LINE4 AFTER ADVANCING 1 LINES. 33000 WRITE REPREC FROM LINE5 AFTER ADVANCING 1 LINES. 33100 WRITE REPREC FROM LINE3 AFTER ADVANCING 1 LINES. 33200 WRITE REPREC FROM LINE0 AFTER ADVANCING 1 LINES. 33300 HEADER-EXIT. EXIT. 33400 *----------------- 33500 DETAIL-PROC. 33600 *----------- 33700 ADD 1 TO CONTD. 33800 IF CONTD > 50 33900 MOVE 1 TO CONTD 34000 PERFORM HEADER-PROC THRU HEADER-EXIT 34100 END-IF 34200 MOVE CONTL TO MASK1. 34300 MOVE EOQ-TABLE TO MASK2. 34400 WRITE REPREC FROM LINE6 AFTER ADVANCING 1 LINES. 34500 DETAIL-EXIT. EXIT. 34600 *----------------- 34700 TRAILER-PROC. 34800 *------------ 34900 MOVE CONTL TO MASK3. 35000 WRITE REPREC FROM LINE3 AFTER ADVANCING 2 LINES. 35100 WRITE REPREC FROM LINE7 AFTER ADVANCING 2 LINES. 35200 WRITE REPREC FROM LINE3 AFTER ADVANCING 2 LINES. 35300 WRITE REPREC FROM LINE8 AFTER ADVANCING 1 LINES. 35400 TRAILER-EXIT. EXIT. 35500 *------------------
5738PW1 V2R1M1 920327 SEU SOURCE LISTING 03/29/92 17:12:35 PAGE 8 SOURCE FILE . . . . . . . DRDA/QLBLSRC MEMBER . . . . . . . . . DDBPT6CB SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 35600 ******************************************************** 03/29/92 35700 * THIS PARAGRAPH IS ONLY REQUIRED IN A TEST ENVIRONMENT* 03/29/92 35800 * TO RESET THE DATA TO PERMIT RE-RUNNING OF THE TEST * 03/29/92 35900 ******************************************************** 03/29/92 36000 CLEAN-UP. 03/29/92 36100 *--------- 03/29/92 36200 ********************************* 03/29/92 36300 * CONNECT TO REMOTE DATABASE * 03/29/92 36400 ********************************* 03/29/92 36500 **** 03/29/92 36600 EXEC SQL CONNECT TO :REMOTE-DB END-EXEC. 03/29/92 36700 **** 03/29/92 36800 *---------------------DELETE ORDER ROWS FOR RERUNABILITY 03/29/92 36900 EXEC SQL 03/29/92 37000 DELETE 03/29/92 37100 FROM PART_ORDLN 03/29/92 37200 WHERE ORDER_NUM IN 03/29/92 37300 (SELECT ORDER_NUM 03/29/92 37400 FROM PART_ORDER 03/29/92 37500 WHERE ORDER_TYPE = 'R') 03/29/92 37600 END-EXEC. 03/29/92 37700 EXEC SQL 03/29/92 37800 DELETE 03/29/92 37900 FROM PART_ORDER 03/29/92 38000 WHERE ORDER_TYPE = 'R' 03/29/92 38100 END-EXEC. 03/29/92 38200 **** 03/29/92 38300 EXEC SQL COMMIT END-EXEC. 03/29/92 38400 **** 03/29/92 38500 CLEAN-UP-EXIT. EXIT. 03/29/92 38600 *------------- 03/29/92 * * * * E N D O F S O U R C E * * * *