IDENTIFICATION DIVISION.
PROGRAM-ID. PRUM020.
AUTHOR. BILL VORIS.
DATE-WRITTEN. 05/24/2000.
DATE-COMPILED. 07/11/2000.
******************************************************************
* PROGRAM NAME : COBOL/DB2/IMS PROGRAM TO MAINTAIN THE *
* PARTS MASTER DATA BASE *
* *
* *
* INPUT/OUTPUT : *
* *
* DATABASES DB2 TABLE PRUKANB *
* INPUTS: DB2 TABLE PRUKBPD *
* DB2 TABLE CSULOCD *
* DB2 TABLE CSULDPD *
* *
* DATABASES DB2 TABLE PRUKANB *
* OUTPUTS: DB2 TABLE PRUKBPD *
* DB2 TABLE PRUAUDT F
* *
******************************************************************
* PROGRAM HISTORY *
* *
* DATE PROGRAMMER PROJECT# CHANGE DESCRIPTION *
* ---------- -------------- -------- ---------------------- *
* *
* 05-24-2000 BILL VORIS PC99045 CREATED THE NEW COBOL *
* PROGRAM PRUM020 *
* *
******************************************************************
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-9672.
OBJECT-COMPUTER. IBM-9672.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
DATA DIVISION.
FILE SECTION.
WORKING-STORAGE SECTION.
COPY COBIMATT.
COPY COBIFUNC.
COPY COBIRACF.
*-----------> COMMENTS
*
* INPUT AREA FOR ON-LINE SCREEN
*
01 I1-AREA.
05 FILLER PIC X(04).
05 I1-TRAN-CODE.
10 I1-TRANCODE PIC X(07).
10 FILLER PIC X(01).
05 I1-PARM PIC X(01).
05 I1-FILL1 PIC X(04).
05 I1-PAGE PIC X(03).
05 I1-FUNCI PIC X(01).
05 I1-SUPP-1I PIC X(04).
05 I1-SUPP-2I PIC X(01).
05 I1-DOCKI PIC X(02).
05 I1-PARTNO-1 PIC X(05).
05 I1-PARTNO-2 PIC X(05).
05 I1-PARTNO-3 PIC X(02).
05 DETAIL-LINES-IN OCCURS 13 TIMES.
15 I1-OPCODE PIC X(01).
15 I1-PARTNO PIC X(14).
15 I1-SUPP PIC X(06).
15 I2-DOCKI PIC X(02).
15 I1-TIMEFR PIC X(06).
15 I1-TIMETO PIC X(06).
15 I1-TO-PC PIC X(04).
15 I1-PC-SAFETY PIC X(04).
15 I1-TO-LS PIC X(04).
15 I1-LS-SAFETY PIC X(04).
15 I1-INTKBN1 PIC X(02).
15 I1-INTKBN2 PIC X(02).
15 I1-INTKBN3 PIC X(02).
15 I1-CALCBVSC PIC X(01).
15 I1-SHIPDOCK PIC X(03).
05 I1-INQFUN PIC X(01).
05 I1-HIDE-BEI PIC X(02).
05 I1-HIDE-USERI PIC X(08).
05 I1-NEWTRNI PIC X(08).
05 I1-NEWKEYI PIC X(30).
05 I1-CMNT PIC X(78).
01 MSI-MSG REDEFINES I1-AREA.
05 MSI-LL PIC X(2).
05 MSI-ZZ PIC X(2).
05 MSI-TRAN PIC X(8).
05 MSI-KEY PIC X(30).
05 FILLER PIC X(800).
*-----------> COMMENTS
*
* OUTPUT AREA FOR ON-LINE SCREEN
*
01 O1-AREA.
05 O1-LL COMP PIC S9(4) VALUE +1385.
05 O1-ZZ COMP PIC S9(4).
05 O1-PAGEA PIC X(02).
05 O1-PAGE PIC X(03).
05 O1-FUNCA PIC X(02).
05 O1-FUNC PIC X(01).
05 O1-SUPP-1A PIC X(02).
05 O1-SUPP-1 PIC X(04).
05 O1-SUPP-2A PIC X(02).
05 O1-SUPP-2 PIC X(01).
05 O1-DOCKA PIC X(02).
05 O1-DOCK PIC X(02).
05 O1-PARTNO-1A PIC X(02).
05 O1-PARTNO-1 PIC X(05).
05 O1-PARTNO-2A PIC X(02).
05 O1-PARTNO-2 PIC X(05).
05 O1-PARTNO-3A PIC X(02).
05 O1-PARTNO-3 PIC X(02).
05 DETAIL-LINES OCCURS 13 TIMES.
15 O1-OPCODEA PIC X(02).
15 O1-OPCODE PIC X(01).
15 O1-PARTNO-A PIC X(02).
15 O1-PARTNO PIC X(14).
15 O1-SUPP-A PIC X(02).
15 O1-SUPP PIC X(06).
15 O2-DOCKA PIC X(02).
15 O2-DOCK PIC X(02).
15 O1-TIMEFRA PIC X(02).
15 O1-TIMEFR PIC X(06).
15 O1-TIMETOA PIC X(02).
15 O1-TIMETO PIC X(06).
15 O1-TO-PCA PIC X(02).
15 O1-TO-PC PIC X(04).
15 O1-TO-PC-N REDEFINES O1-TO-PC PIC ZZZ9.
15 O1-PC-SAFETYA PIC X(02).
15 O1-PC-SAFETY PIC X(04).
15 O1-PC-SAFETY-N REDEFINES O1-PC-SAFETY
PIC ZZZ9.
15 O1-TO-LSA PIC X(02).
15 O1-TO-LS PIC X(04).
15 O1-TO-LS-N REDEFINES O1-TO-LS PIC ZZZ9.
15 O1-LS-SAFETYA PIC X(02).
15 O1-LS-SAFETY PIC X(04).
15 O1-LS-SAFETY-N REDEFINES O1-LS-SAFETY
PIC ZZZ9.
15 O1-INTKBN1A PIC X(02).
15 O1-INTKBN1 PIC X(02).
15 O1-INTKBN2A PIC X(02).
15 O1-INTKBN2 PIC X(02).
15 O1-INTKBN3A PIC X(02).
15 O1-INTKBN3 PIC X(02).
15 O1-CALCBVSCA PIC X(02).
15 O1-CALCBVSC PIC X(01).
15 O1-SHIPDOCKA PIC X(02).
15 O1-SHIPDOCK PIC X(03).
05 O1-INQFUNA PIC X(02).
05 O1-INQFUN PIC X(01).
05 O1-HIDE-BEA PIC X(02).
05 O1-HIDE-BE PIC X(02).
05 O1-HIDE-USERA PIC X(02).
05 O1-HIDE-USER PIC X(08).
05 O1-NEWTRNA PIC X(02).
05 O1-NEWTRN PIC X(08).
05 O1-NEWKEYA PIC X(02).
05 O1-NEWKEY PIC X(30).
05 O1-CMNTA PIC X(02).
05 O1-CMNT PIC X(78).
01 MSO-MSG.
05 MSO-LL COMP PIC S9(4) VALUE +43.
05 MSO-ZZ COMP PIC S9(4) VALUE +0.
05 MSO-TRAN.
10 MSO-PAR PIC X(03).
10 MSO-NEWTRAN PIC X(05).
05 MSO-KEY PIC X(30).
05 MSO-EOM PIC X(01).
01 HOST-VARIABLES-PM.
05 HV-PM-CUSTOMER-SUPP PIC X(07).
05 HV-PM-LOCATION PIC X(12).
05 HV-PM-ITEMID PIC X(12).
05 HV-PM-EFF-START PIC X(10).
05 HV-PM-EFF-STOP PIC X(10).
05 HV-PM-SHIPPING-LOCATION PIC X(10).
05 HV-PM-CATEGORY PIC X(08).
05 HV-SM-EFF-START PIC X(10).
05 HV-SM-SHIPPING-LOCATION PIC X(10).
01 HOST-VARIABLES-AU.
05 HV-AU-STORAGE-ID PIC X(08).
05 HV-AU-STORAGE-ELEMENT PIC X(16).
05 HV-AU-KEY-FEEDBACK PIC X(50).
05 HV-AU-COMMENTS PIC X(50).
05 HV-AU-NEW-VALUE PIC X(200).
05 HV-AU-FUNCTION PIC X(1).
05 KEY-FEEDBACK.
49 KEY-FEEDBACK-LEN PIC S9(4) COMP.
49 KEY-FEEDBACK-TEXT PIC X(50).
05 WS-COMMENTS.
49 COMMENTS-LEN PIC S9(4) COMP.
49 COMMENTS-TEXT PIC X(50).
05 NEW-VALUE.
49 NEW-VALUE-LEN PIC S9(4) COMP.
49 NEW-VALUE-TEXT PIC X(200).
01 NULL-IND.
05 NI-EFF-STOP PIC S9(4) COMP.
05 NI-SHIPPING-LOCATION PIC S9(4) COMP.
05 NI-SM-SHIPPING-LOCATION PIC S9(4) COMP.
05 HV-PM-SHIPNI PIC S9(4) COMP.
05 NI-CATEGORY PIC S9(4) COMP.
05 HV-AU-COMMENTS-NI VALUE 0 PIC S9(4) COMP.
05 HV-AU-NEW-VALUE-NI VALUE 0 PIC S9(4) COMP.
05 HV-KF-NI PIC S9(4) COMP.
05 COMMENTS-NI VALUE 0 PIC S9(4) COMP.
05 HV-NI-PERIOD VALUE 0 PIC S9(4) COMP.
01 HV-PRUKBPD.
05 HV-PP-CSI-TYPE PIC X(02).
05 HV-PP-CUSTOMER-SUPP PIC X(07).
05 HV-PP-LOCATION PIC X(12).
05 HV-PP-ITEMID PIC X(12).
05 HV-PP-EFF-START PIC X(10).
05 HV-PP-PERIOD-TYPE PIC X(02).
05 HV-PP-DATE-TIME PIC X(26).
05 HV-PP-USERID PIC X(08).
05 HV-PP-PERIOD PIC X(08).
01 HV-CSULDPD.
05 HV-SP-PERIOD PIC X(08).
05 HV-SP-PERIOD-TYPE PIC X(02).
01 SYS-TERM-MSG PIC X(50).
01 WS-WORK-AREAS.
05 WS-PART PIC X(12).
05 WS-DOCK PIC X(02).
05 WS-SUPP PIC X(05).
05 WS-IO-MOD-X VALUE 'PRUX020 ' PIC X(08).
05 WS-PAGE-DIS PIC X(03).
05 WS-PAGE-CNT REDEFINES WS-PAGE-DIS PIC 9(03).
05 WS-THREE COMP VALUE 3 PIC S9(9).
05 WS-SPACES-8 VALUE SPACES PIC X(08).
05 WS-KEY VALUE SPACES PIC X(30).
05 WS-LOCATION PIC X(10).
05 WS-CHG-ON-SCREEN VALUE 'N' PIC X(01).
05 NULL-SWITCH VALUE 'N' PIC X(01).
01 WS-DATE-REFORMAT-AREAS.
05 WS-WORK-DATE.
10 WS-WORK-DATE-CCYY PIC X(4).
10 DASH-1 PIC X(1).
10 WS-WORK-DATE-MM PIC X(2).
10 DASH-2 PIC X(1).
10 WS-WORK-DATE-DD PIC X(2).
05 WS-CCYYMMDD.
10 WS-CCYY-DATE PIC X(4).
10 WS-MM-DATE PIC X(2).
10 WS-DD-DATE PIC X(2).
05 WS-YYMMDDR REDEFINES WS-CCYYMMDD.
10 WS-CC PIC X(2).
10 WS-YYMMDD PIC X(6).
10 WS-YYMMDD-YY REDEFINES WS-YYMMDD.
15 WS-YY PIC X(2).
15 FILLER PIC X(4).
05 WS-DATE PIC X(10).
05 WS-CURRENT-DATE PIC X(10) VALUE '0000-00-00'.
05 WS-TODAY-DATE PIC X(08).
01 WS-SWITCHES.
05 WS-PARKANB-SWITCH PIC X(01) VALUE 'Y'.
88 WS-MORE-PARKANB VALUE 'Y'.
88 WS-NO-MORE-PARKANB VALUE 'N'.
05 WS-PRUKBPD-SWITCH PIC X(01) VALUE 'Y'.
88 WS-MORE-PRUKBPD VALUE 'Y'.
88 WS-NO-MORE-PRUKBPD VALUE 'N'.
05 WS-CSULDPD-SWITCH PIC X(01) VALUE 'Y'.
88 WS-MORE-CSULDPD VALUE 'Y'.
88 WS-NO-MORE-CSULDPD VALUE 'N'.
05 WS-PARAMETER PIC X(02) VALUE SPACES.
05 WS-CSULOCD-FOUND PIC X(01) VALUE 'N'.
05 WS-FOUND-IK PIC X(01) VALUE 'N'.
88 WS-NOT-FOUND-IK VALUE 'N'.
05 WS-FOUND-ES PIC X(01) VALUE 'N'.
88 WS-NOT-FOUND-ES VALUE 'N'.
05 WS-FOUND-IS PIC X(01) VALUE 'N'.
88 WS-NOT-FOUND-IS VALUE 'N'.
05 WS-FOUND-DL PIC X(01) VALUE 'N'.
88 WS-NOT-FOUND-DL VALUE 'N'.
05 WS-FOUND-DP PIC X(01) VALUE 'N'.
88 WS-NOT-FOUND-DP VALUE 'N'.
01 WS-IO-PCBMASK.
05 WS-IO-TERMINAL PIC X(08).
05 WS-IO-RESERVED PIC X(02).
05 WS-IO-STCD PIC X(02).
05 WS-IO-DATE PIC S9(07) COMP-3.
05 WS-IO-TIME PIC S9(06)V9 COMP-3.
05 WS-IO-ISN PIC X(04).
05 WS-IO-MOD PIC X(08).
05 WS-IO-USER-ID PIC X(08).
01 W-RESOURCE.
05 W-TRANCODE PIC X(08) VALUE SPACES.
05 W-FUNC PIC X(01) VALUE SPACES.
05 FILLER PIC X(13) VALUE SPACES.
01 WS-VARIABLES.
05 A-ERR PIC 9(03) VALUE ZEROS.
05 ERR-IND PIC X(02) VALUE ZEROS.
05 H-FUNC PIC X(01) VALUE SPACES.
05 I PIC 9(2) VALUE 1.
05 WS-SHIPDOCK PIC X(03).
05 WS-SHIPDOCK-RED REDEFINES WS-SHIPDOCK.
10 WS-SHIPDOCK-1 PIC X(1).
88 WS-SHIPDOCK-1-VALID VALUES
'A' 'B' 'C' 'D' 'E' 'F' 'G' 'H' 'I' 'J' 'K' 'L'
'M' 'N' 'O' 'P' 'Q' 'R' 'S' 'T' 'U' 'V' 'W' 'X'
'Y' 'Z' '0' '1' '2' '3' '4' '5' '6' '7' '8' '9'.
10 WS-SHIPDOCK-2 PIC X(1).
88 WS-SHIPDOCK-2-VALID VALUES
'A' 'B' 'C' 'D' 'E' 'F' 'G' 'H' 'I' 'J' 'K' 'L'
'M' 'N' 'O' 'P' 'Q' 'R' 'S' 'T' 'U' 'V' 'W' 'X'
'Y' 'Z' '0' '1' '2' '3' '4' '5' '6' '7' '8' '9'.
10 WS-SHIPDOCK-3 PIC X(1).
88 WS-SHIPDOCK-3-VALID VALUES
'A' 'B' 'C' 'D' 'E' 'F' 'G' 'H' 'I' 'J' 'K' 'L'
'M' 'N' 'O' 'P' 'Q' 'R' 'S' 'T' 'U' 'V' 'W' 'X'
'Y' 'Z' '0' '1' '2' '3' '4' '5' '6' '7' '8' '9'.
05 CONVT-NUMBER PIC X(04).
05 PARSE-NUMBER REDEFINES CONVT-NUMBER.
10 PARSE-NUM-1 PIC X(01).
10 PARSE-NUM-2 PIC X(01).
10 PARSE-NUM-3 PIC X(01).
10 PARSE-NUM-4 PIC X(01).
05 FIXED-NUMBER PIC 9(04).
05 PIC-4 PIC 9(04).
05 ERROR-CODE PIC X(01) VALUE SPACES.
05 WS-SCREEN-FIELDS.
10 WS-SCREEN-TO-PC PIC X(04) VALUE SPACES.
10 WS-SCREEN-PC-SAFETY PIC X(04) VALUE SPACES.
10 WS-SCREEN-TO-LS PIC X(04) VALUE SPACES.
10 WS-SCREEN-LS-SAFETY PIC X(04) VALUE SPACES.
10 WS-SCREEN-INTKBN PIC X(06) VALUE SPACES.
05 WS-KANB-FIELDS.
10 WS-KANB-SHIPPING-LOCATION PIC X(03).
10 WS-KANB-CATEGORY PIC X(01).
05 WS-KBPD-FIELDS.
10 WS-KBPD-TO-PC PIC X(04) VALUE SPACES.
10 WS-KBPD-PC-SAFETY PIC X(04) VALUE SPACES.
10 WS-KBPD-TO-LS PIC X(04) VALUE SPACES.
10 WS-KBPD-LS-SAFETY PIC X(04) VALUE SPACES.
10 WS-KBPD-INTKBN PIC X(06) VALUE SPACES.
05 WS-LDPD-FIELDS.
10 WS-LDPD-TO-PC PIC X(04) VALUE SPACES.
10 WS-LDPD-PC-SAFETY PIC X(04) VALUE SPACES.
10 WS-LDPD-TO-LS PIC X(04) VALUE SPACES.
10 WS-LDPD-LS-SAFETY PIC X(04) VALUE SPACES.
10 WS-LDPD-INTKBN PIC X(06) VALUE SPACES.
05 WS-CSULOCD-SHIPPING-LOCATION PIC X(10) VALUE SPACES.
05 WS-UPDATE-PRUKANB PIC X(01) VALUE 'N'.
05 WS-UPDATE-PRUKBPD PIC X(01) VALUE 'N'.
05 WS-UPDATE-FIELDS.
10 WS-UPDATE-TO-PC PIC X(01) VALUE 'N'.
10 WS-UPDATE-PC-SAFETY PIC X(01) VALUE 'N'.
10 WS-UPDATE-TO-LS PIC X(01) VALUE 'N'.
10 WS-UPDATE-LS-SAFETY PIC X(01) VALUE 'N'.
10 WS-UPDATE-INTKBN PIC X(01) VALUE 'N'.
01 WS-MESSAGE-AREA.
05 DIS-SQL PIC -(5)9(3).
05 M-SIGNON-FIRST.
10 FILLER PIC X(51) VALUE
'FIRST SIGNON'.
05 M-SWITCH-ERROR-1.
10 FILLER PIC X(44) VALUE
'ERROR ATTEMPTING TO SWITCH MESSAGES, STAT = '.
10 M-SWITCH-1-STATUS PIC XX VALUE SPACES.
05 M-SWITCH-ERROR-2.
10 FILLER PIC X(30) VALUE
'ERROR ATTEMPTING TO SWITCH TO '.
10 M-SWITCH-TXN PIC X(08) VALUE SPACES.
10 FILLER PIC X(34) VALUE
', WHICH IS NOT A VALID TRANSACTION'.
05 M-SIGNON-ERROR.
10 FILLER PIC X(50) VALUE SPACES.
05 INV-FUN-MSG.
10 FILLER PIC X(35) VALUE
'INVALID FUNCTION/PFKEY COMBINATION '.
10 FILLER PIC X(30) VALUE
SPACES.
05 KEY-VALUE-MSG.
10 FILLER PIC X(35) VALUE
'KEY VALUES NOT FOUND '.
10 FILLER PIC X(30) VALUE
SPACES.
05 HI-LIGHT-MSG.
10 FILLER PIC X(35) VALUE
'HIGHLIGHTED FIELDS ARE IN ERROR '.
05 NO-CHG-MSG.
10 FILLER PIC X(35) VALUE
'THERE ARE NO CHANGES TO PROCESS '.
05 NO-DATA-MSG.
10 FILLER PIC X(35) VALUE
'NO MORE DATA EXISTS '.
10 FILLER PIC X(30) VALUE
SPACES.
05 M-INFO-MSG.
10 FILLER PIC X(35) VALUE
'INFORMATION NOT FOUND IN PRUKANB. I'.
10 FILLER PIC X(30) VALUE
'NQUIRE AGAIN. '.
05 PFKEY-MSG.
10 FILLER PIC X(35) VALUE
'F2=INQ F3=EXIT F4=UPD F7=BWD F8=FWD'.
10 FILLER PIC X(30) VALUE
' F9=PMNT F11=MHMN F12=AUDT'.
05 FUNCTION-MSG.
10 FILLER PIC X(35) VALUE
'VALID FUNCTIONS ARE B,E,F,G,I,K,S,T'.
10 FILLER PIC X(30) VALUE
', AND U '.
05 PARM-MSG.
10 FILLER PIC X(35) VALUE
'VALID PFKEYS ARE 2,3,4,7,8,9,10,11,'.
10 FILLER PIC X(30) VALUE
'12 '.
05 TO-PC-MSG.
10 FILLER PIC X(40) VALUE
'INTERNAL DELIVERY TIME TO PC IS MEASURED'.
10 FILLER PIC X(38) VALUE
' IN MINUTES AND MUST BE NUMERIC '.
05 PC-SAFETY-MSG.
10 FILLER PIC X(40) VALUE
'EXTERNAL SAFETY IS MEASURED IN MINUTES A'.
10 FILLER PIC X(38) VALUE
'ND MUST BE NUMERIC '.
05 TO-LS-MSG.
10 FILLER PIC X(40) VALUE
'INTERNAL DELIVERY TIME TO LS IS MEASURED'.
10 FILLER PIC X(38) VALUE
' IN MINUTES AND MUST BE NUMERIC '.
05 LS-SAFETY-MSG.
10 FILLER PIC X(40) VALUE
'INTERNAL SAFETY IS MEASURED IN MINUTES A'.
10 FILLER PIC X(38) VALUE
'ND MUST BE NUMERIC '.
05 INTKBN-MSG-1.
10 FILLER PIC X(40) VALUE
'INVALID INTERNAL KANBAN CYCLE. FIRST TWO'.
10 FILLER PIC X(38) VALUE
' POSITIONS MUST BE 01 OR 05 '.
05 INTKBN-MSG-2.
10 FILLER PIC X(40) VALUE
'INTERNAL KANBAN CYCLE MUST BE NUMERIC '.
10 FILLER PIC X(38) VALUE
' '.
05 CALCBVSC-MSG.
10 FILLER PIC X(40) VALUE
'INVALID CALC BVSC. VALID VALUES ARE Y, N'.
10 FILLER PIC X(38) VALUE
' '.
05 SHIPDOCK-MSG.
10 FILLER PIC X(40) VALUE
'SHIP DOCK MUST BE ALPHA NUMERIC (A-Z, 0-'.
10 FILLER PIC X(38) VALUE
'9) '.
05 CATEGORY-MSG.
10 FILLER PIC X(40) VALUE
'INVALID CATEGORY '.
10 FILLER PIC X(38) VALUE
' '.
05 SUPP-MSG.
10 FILLER PIC X(40) VALUE
'SUPPLIER CODE AND DOCK CODE, OR PART NUM'.
10 FILLER PIC X(38) VALUE
'BER IS REQUIRED '.
05 CHANGE-MSG.
10 FILLER PIC X(40) VALUE
'UPDATE COMPLETE '.
10 FILLER PIC X(38) VALUE
' '.
05 WS-CHANGE-MSG.
10 FILLER PIC X(40) VALUE
'CHANGE EXISTING INFORMATION ONLY. TO ADD'.
10 FILLER PIC X(38) VALUE
' PARTS GO TO PRUPMNT. '.
05 OPCODE-MSG.
10 FILLER PIC X(40) VALUE
'VALID OPERATION CODE FOR UPDATE IS "C" '.
10 FILLER PIC X(38) VALUE
' '.
05 M-NOT-AUTH.
10 FILLER PIC X(39) VALUE
'YOU ARE NOT AUTHORIZED FOR TRANSACTION '.
10 M-TXN-AUTH PIC X(08) VALUE SPACES.
05 M-NOT-AUTH-FUNCTION.
10 FILLER PIC X(47) VALUE
'YOU ARE NOT AUTHORIZED TO PERFORM THIS FUNCTION'.
05 M-INQ-COMPLETED.
10 FILLER PIC X(78) VALUE
'INQUIRY COMPLETE '.
05 M-INQ-FIRST.
10 FILLER PIC X(72) VALUE
'PLEASE INQUIRE FIRST'.
*-----------> COMMENTS
*
* SQL AND CURSOR PROCESSING FOR DB2
*
EXEC SQL
INCLUDE SQLCA
END-EXEC.
EXEC SQL
DECLARE F1-PRUKANB-SUPP CURSOR FOR
SELECT CUSTOMER_SUPP,
LOCATION,
ITEMID,
EFF_START,
EFF_STOP,
SHIPPING_LOCATION,
CATEGORY
FROM PRUKANB
WHERE BUSINESS_ENTITY = :I1-HIDE-BEI
AND TYPE = 'CD'
AND CSI_TYPE = 'SU'
AND CUSTOMER_SUPP = :HV-PM-CUSTOMER-SUPP
AND LOCATION = :HV-PM-LOCATION
AND ITEMID ³³ CHAR(EFF_START) >=
:HV-PM-ITEMID ³³ :HV-PM-EFF-START
ORDER BY ITEMID, EFF_START
END-EXEC.
EXEC SQL
DECLARE B1-PRUKANB-SUPP CURSOR FOR
SELECT CUSTOMER_SUPP,
LOCATION,
ITEMID,
EFF_START,
EFF_STOP,
SHIPPING_LOCATION,
CATEGORY
FROM PRUKANB
WHERE BUSINESS_ENTITY = :I1-HIDE-BEI
AND TYPE = 'CD'
AND CSI_TYPE = 'SU'
AND CUSTOMER_SUPP = :HV-PM-CUSTOMER-SUPP
AND LOCATION = :HV-PM-LOCATION
AND ITEMID ³³ CHAR(EFF_START) <=
:HV-PM-ITEMID ³³ :HV-PM-EFF-START
ORDER BY ITEMID DESC, EFF_START DESC
END-EXEC.
EXEC SQL
DECLARE F1-PRUKANB-PART CURSOR FOR
SELECT CUSTOMER_SUPP,
LOCATION,
ITEMID,
EFF_START,
EFF_STOP,
SHIPPING_LOCATION,
CATEGORY
FROM PRUKANB
WHERE BUSINESS_ENTITY = :I1-HIDE-BEI
AND TYPE = 'CD'
AND CSI_TYPE = 'SU'
AND ITEMID = :HV-PM-ITEMID
AND CUSTOMER_SUPP ³³ LOCATION ³³ CHAR(EFF_START) >=
:HV-PM-CUSTOMER-SUPP ³³ :HV-PM-LOCATION ³³
:HV-PM-EFF-START
ORDER BY CUSTOMER_SUPP, LOCATION, EFF_START
END-EXEC.
EXEC SQL
DECLARE B1-PRUKANB-PART CURSOR FOR
SELECT CUSTOMER_SUPP,
LOCATION,
ITEMID,
EFF_START,
EFF_STOP,
SHIPPING_LOCATION,
CATEGORY
FROM PRUKANB
WHERE BUSINESS_ENTITY = :I1-HIDE-BEI
AND TYPE = 'CD'
AND CSI_TYPE = 'SU'
AND ITEMID = :HV-PM-ITEMID
AND CUSTOMER_SUPP ³³ LOCATION ³³ CHAR(EFF_START) <=
:HV-PM-CUSTOMER-SUPP ³³ :HV-PM-LOCATION ³³
:HV-PM-EFF-START
ORDER BY CUSTOMER_SUPP DESC, LOCATION DESC,
EFF_START DESC
END-EXEC.
EXEC SQL
DECLARE C1-PRUKBPD CURSOR FOR
SELECT PERIOD_TYPE,
PERIOD
FROM PRUKBPD
WHERE BUSINESS_ENTITY = :I1-HIDE-BEI
AND TYPE = 'CD'
AND CSI_TYPE = 'SU'
AND CUSTOMER_SUPP = :HV-PM-CUSTOMER-SUPP
AND LOCATION = :HV-PM-LOCATION
AND ITEMID = :HV-PM-ITEMID
AND EFF_START = :HV-PM-EFF-START
END-EXEC.
EXEC SQL
DECLARE C1-CSULDPD CURSOR FOR
SELECT PERIOD_TYPE,
PERIOD
FROM CSULDPD
WHERE BUSINESS_ENTITY = :I1-HIDE-BEI
AND CSI_TYPE = 'SU'
AND CUSTOMER_SUPP = :HV-PM-CUSTOMER-SUPP
AND LOCATION = :WS-LOCATION
AND EFF_START = :HV-SM-EFF-START
END-EXEC.
*-----------> COMMENTS
*
* LINKAGE PCB'S, MAST NOT USED
*
LINKAGE SECTION.
COPY COBIMIO.
COPY COBIMSTR.
COPY COBIALT.
*-----------> COMMENTS
*
* MAIN PROCESSING LOGIC SECTIONS
*
PROCEDURE DIVISION.
ENTRY 'DLITCBL' USING IO-PCBMASK
MAST-PCBMASK
ALT-PCBMASK.
0000-MAIN-MODULE.
PERFORM 1000-INITIALIZATION THRU
1000-INITIALIZATION-EXIT.
IF A-ERR = 0
PERFORM 2000-MAINLINE THRU
2000-MAINLINE-EXIT.
PERFORM 3500-SEND-MSG-AND-RETURN THRU
3500-SEND-MSG-AND-RETURN-EXIT.
GOBACK.
0000-MAIN-MODULE-EXIT. EXIT.
1000-INITIALIZATION.
PERFORM UNTIL IO-STCD NOT EQUAL SPACES
CALL 'CBLTDLI' USING GU,
IO-PCBMASK,
I1-AREA
END-PERFORM.
ACCEPT WS-TODAY-DATE FROM DATE YYYYMMDD.
MOVE WS-TODAY-DATE TO WS-CCYYMMDD
MOVE WS-CCYY-DATE TO WS-WORK-DATE-CCYY
MOVE WS-MM-DATE TO WS-WORK-DATE-MM
MOVE WS-DD-DATE TO WS-WORK-DATE-DD
MOVE '-' TO DASH-1, DASH-2.
MOVE WS-WORK-DATE TO WS-CURRENT-DATE.
MOVE IO-PCBMASK TO WS-IO-PCBMASK.
PERFORM 1100-CHECK-ENTRANCE THRU
1100-CHECK-ENTRANCE-EXIT.
IF I1-NEWTRNI > SPACES
PERFORM 7500-SWAP-RTN THRU
7500-SWAP-RTN-EXIT.
IF I1-HIDE-BEI NOT NUMERIC
PERFORM 1200-BUSINESS-ENTITY THRU
1200-BUSINESS-ENTITY-EXIT.
IF A-ERR = 0
PERFORM 1300-CHECK-FUNCTION THRU
1300-CHECK-FUNCTION-EXIT.
IF A-ERR = 0
PERFORM 1400-CHECK-AUTHORIZATION THRU
1400-CHECK-AUTHORIZATION-EXIT.
IF A-ERR = 0
PERFORM 1500-CHECK-REQ-FIELDS THRU
1500-CHECK-REQ-FIELDS-EXIT.
1000-INITIALIZATION-EXIT. EXIT.
1100-CHECK-ENTRANCE.
IF IO-MOD NOT = 'PRUX020 '
MOVE MSI-KEY TO WS-KEY
IF WS-KEY(1:10) = SPACES
MOVE SPACE TO O1-FUNC
MOVE PFKEY-MSG TO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN THRU
3500-SEND-MSG-AND-RETURN-EXIT
ELSE
IF WS-KEY(1:4) EQUAL SPACES
MOVE WS-KEY(8:5) TO I1-PARTNO-1
MOVE WS-KEY(13:5) TO I1-PARTNO-2
MOVE WS-KEY(18:2) TO I1-PARTNO-3
MOVE SPACES TO I1-SUPP-1I
MOVE SPACES TO I1-SUPP-2I
MOVE SPACES TO I1-DOCKI
ELSE
MOVE WS-KEY(1:4) TO I1-SUPP-1I
MOVE WS-KEY(5:1) TO I1-SUPP-2I
MOVE WS-KEY(6:2) TO I1-DOCKI
MOVE SPACES TO I1-PARTNO-1
MOVE SPACES TO I1-PARTNO-2
MOVE SPACES TO I1-PARTNO-3
END-IF
MOVE 'I' TO I1-PARM, I1-FUNCI, O1-FUNC
END-IF
END-IF.
1100-CHECK-ENTRANCE-EXIT. EXIT.
1200-BUSINESS-ENTITY.
MOVE '00' TO ERR-IND.
MOVE IO-PCBMASK TO WS-IO-PCBMASK
CALL 'PRUM003' USING WS-IO-PCBMASK
I1-HIDE-BEI
ERR-IND.
IF ERR-IND = '00'
MOVE I1-HIDE-BEI TO O1-HIDE-BE
MOVE IO-USER-ID TO O1-HIDE-USER
ELSE
ADD 1 TO A-ERR
MOVE 'BUSINESS ENTITY ERROR' TO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN THRU
3500-SEND-MSG-AND-RETURN-EXIT
END-IF.
IF O1-HIDE-BE NOT EQUAL '02'
MOVE ATR-BRT-CURSR-MOD TO O1-HIDE-BEA
MOVE 'BUSINESS ENTITY ERROR' TO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN THRU
3500-SEND-MSG-AND-RETURN-EXIT
END-IF.
1200-BUSINESS-ENTITY-EXIT. EXIT.
1300-CHECK-FUNCTION.
IF I1-FUNCI = 'I'
MOVE SPACES TO I1-FUNCI.
IF I1-FUNCI = 'C'
MOVE 'U' TO I1-FUNCI.
IF (I1-FUNCI EQUAL 'B' OR 'F') AND
(I1-PARM EQUAL 'B' OR 'F')
CONTINUE
ELSE
IF I1-FUNCI NOT EQUAL SPACES
IF I1-PARM NOT EQUAL SPACES
IF I1-FUNCI = I1-PARM
CONTINUE
ELSE
MOVE INV-FUN-MSG TO O1-CMNT
ADD 1 TO A-ERR
MOVE ATR-BRT-CURSR-MOD TO O1-FUNCA
MOVE I1-PAGE TO O1-PAGE
PERFORM 3000-MOVE-IN-TO-OUT THRU
3000-MOVE-IN-TO-OUT-EXIT
PERFORM 3500-SEND-MSG-AND-RETURN THRU
3500-SEND-MSG-AND-RETURN-EXIT
END-IF
END-IF
END-IF.
IF I1-PARM = SPACES
MOVE I1-FUNCI TO H-FUNC
ELSE
IF I1-PARM = 'I'
MOVE SPACES TO H-FUNC
ELSE
MOVE I1-PARM TO H-FUNC
END-IF
END-IF.
MOVE H-FUNC TO O1-FUNC.
EVALUATE H-FUNC
WHEN ' '
CONTINUE
WHEN 'I'
CONTINUE
WHEN 'U'
CONTINUE
WHEN 'B'
CONTINUE
WHEN 'F'
CONTINUE
WHEN 'S'
CONTINUE
WHEN 'K'
CONTINUE
WHEN 'T'
CONTINUE
WHEN 'G'
CONTINUE
WHEN 'E'
CONTINUE
WHEN 'X'
CONTINUE
WHEN OTHER
MOVE ATR-BRT-CURSR-MOD TO O1-FUNCA
MOVE FUNCTION-MSG TO O1-CMNT
MOVE 1 TO A-ERR
MOVE I1-PAGE TO O1-PAGE
PERFORM 3000-MOVE-IN-TO-OUT THRU
3000-MOVE-IN-TO-OUT-EXIT
PERFORM 3500-SEND-MSG-AND-RETURN THRU
3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
IF I1-INQFUN = 'S' OR 'P'
IF I1-PARM EQUAL 'X'
MOVE 1 TO A-ERR
MOVE PARM-MSG TO O1-CMNT
MOVE ATR-BRT-CURSR-MOD TO O1-FUNCA
MOVE I1-PAGE TO O1-PAGE
PERFORM 3000-MOVE-IN-TO-OUT THRU
3000-MOVE-IN-TO-OUT-EXIT
PERFORM 3500-SEND-MSG-AND-RETURN THRU
3500-SEND-MSG-AND-RETURN-EXIT
END-IF
ELSE
MOVE SPACES TO O1-CMNT
END-IF.
1300-CHECK-FUNCTION-EXIT. EXIT.
1400-CHECK-AUTHORIZATION.
IF H-FUNC NOT = 'U'
GO TO 1400-CHECK-AUTHORIZATION-EXIT.
IF IO-USER-ID = IO-TERMINAL
MOVE M-SIGNON-FIRST TO O1-CMNT
ADD 1 TO A-ERR
GO TO 1400-CHECK-AUTHORIZATION-EXIT.
MOVE I1-TRANCODE TO W-TRANCODE.
MOVE H-FUNC TO W-FUNC.
MOVE W-RESOURCE TO RACF-RESOURCE
MOVE IO-PCBMASK TO WS-IO-PCBMASK.
CALL 'IMSRACF' USING WS-THREE,
AUTH,
WS-IO-PCBMASK,
RACF-AREA.
IF WS-IO-STCD NOT = SPACES
MOVE M-NOT-AUTH-FUNCTION TO O1-CMNT
ADD 1 TO A-ERR
END-IF.
1400-CHECK-AUTHORIZATION-EXIT. EXIT.
*-------------> COMMENTS
*
* CHECK REQUIRED FIELDS (KEY)
* THIS PROGRAM CAN HAVE TWO KEYS INCLUDING
* SUPPLIER CODE AND DOCK LOCATION OR PART NUMBER
*
1500-CHECK-REQ-FIELDS.
IF I1-PAGE NOT GREATER THAN SPACES
MOVE ' 1' TO O1-PAGE, I1-PAGE
ELSE
MOVE I1-PAGE TO O1-PAGE
END-IF.
IF (I1-FUNCI = 'K' OR 'T' OR 'G' OR 'E' OR 'S') OR
(I1-PARM = 'K' OR 'T' OR 'G' OR 'E' OR 'S')
MOVE ATR-CURSR TO O1-FUNCA
GO TO 1500-CHECK-REQ-FIELDS-EXIT.
IF (I1-FUNCI = 'B' OR 'F') OR
(I1-PARM = 'B' OR 'F')
IF I1-SUPP-1I EQUAL SPACES AND
I1-PARTNO-1 EQUAL SPACES
MOVE M-INQ-FIRST TO O1-CMNT
MOVE ATR-BRT-CURSR-MOD TO O1-SUPP-1A
MOVE '?' TO O1-SUPP-1
MOVE ' ' TO O1-FUNC
PERFORM 3500-SEND-MSG-AND-RETURN THRU
3500-SEND-MSG-AND-RETURN-EXIT.
IF I1-SUPP-1I = SPACES AND
I1-SUPP-2I = SPACES AND
I1-DOCKI = SPACES AND
I1-PARTNO-1 = SPACES AND
I1-PARTNO-2 = SPACES AND
I1-PARTNO-3 = SPACES
MOVE M-INQ-FIRST TO O1-CMNT
MOVE ATR-BRT-CURSR-MOD TO O1-SUPP-1A
MOVE '?' TO O1-SUPP-1
MOVE ' ' TO O1-FUNC
PERFORM 3500-SEND-MSG-AND-RETURN THRU
3500-SEND-MSG-AND-RETURN-EXIT.
IF I1-PARTNO-1 EQUAL SPACES
IF I1-DOCKI = SPACES
MOVE '?' TO O1-DOCK
MOVE ATR-BRT-CURSR TO O1-DOCKA
ADD 1 TO A-ERR
ELSE
MOVE I1-DOCKI TO O1-DOCK
END-IF
IF I1-SUPP-2I = SPACES
MOVE '?' TO O1-SUPP-2
MOVE ATR-BRT-CURSR TO O1-SUPP-2A
ADD 1 TO A-ERR
ELSE
MOVE I1-SUPP-2I TO O1-SUPP-2
END-IF
IF I1-SUPP-1I = SPACES
MOVE ATR-BRT-CURSR TO O1-SUPP-1A
MOVE '?' TO O1-SUPP-1
ADD 1 TO A-ERR
ELSE
MOVE I1-SUPP-1I TO O1-SUPP-1
END-IF
MOVE SUPP-MSG TO O1-CMNT
IF A-ERR GREATER THAN ZERO
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-IF.
MOVE I1-SUPP-1I TO O1-SUPP-1
MOVE I1-SUPP-2I TO O1-SUPP-2
MOVE I1-DOCKI TO O1-DOCK
MOVE I1-PARTNO-1 TO O1-PARTNO-1
MOVE I1-PARTNO-2 TO O1-PARTNO-2
MOVE I1-PARTNO-3 TO O1-PARTNO-3.
1500-CHECK-REQ-FIELDS-EXIT. EXIT.
*-----------> COMMENTS
*
* THERE ARE FIVE MAIN LOGIC PATHS THAT CAN BE
* FOLLOWED FROM THE MAINLINE.
* 1) KEY SETUP FOR INQUIRY
* 2) UPDATE/VAILDATE OF SCREEN FIELDS
* 3) PAGE BACKWARD
* 4) PAGE FORWARD
* 5) SWAP TO ANOTHER TRANSACTION
*
2000-MAINLINE.
EVALUATE H-FUNC
WHEN ' ' PERFORM 2100-KEY-SETUP THRU
2100-KEY-SETUP-EXIT
WHEN 'U' PERFORM 2200-UPDATE-FUNCTION THRU
2200-UPDATE-FUNCTION-EXIT
WHEN 'B' PERFORM 2300-PAGE-BACK THRU
2300-PAGE-BACK-EXIT
WHEN 'F' PERFORM 2400-PAGE-FORWARD THRU
2400-PAGE-FORWARD-EXIT
WHEN 'K' PERFORM 7500-SWAP-RTN THRU
7500-SWAP-RTN-EXIT
WHEN 'T' PERFORM 7500-SWAP-RTN THRU
7500-SWAP-RTN-EXIT
WHEN 'G' PERFORM 7500-SWAP-RTN THRU
7500-SWAP-RTN-EXIT
WHEN 'E' PERFORM 7500-SWAP-RTN THRU
7500-SWAP-RTN-EXIT
WHEN 'S'
MOVE PFKEY-MSG TO O1-CMNT
MOVE SPACES TO O1-FUNC
PERFORM 3000-MOVE-IN-TO-OUT THRU
3000-MOVE-IN-TO-OUT-EXIT
WHEN OTHER
CONTINUE
MOVE ATR-BRT-CURSR-MOD TO O1-FUNCA
MOVE FUNCTION-MSG TO O1-CMNT
ADD 1 TO A-ERR
END-EVALUATE.
2000-MAINLINE-EXIT. EXIT.
2100-KEY-SETUP.
MOVE ' 1' TO O1-PAGE, I1-PAGE
IF I1-SUPP-1I > SPACES OR
I1-PARTNO-1 > SPACES
MOVE M-INQ-COMPLETED TO O1-CMNT
END-IF.
IF I1-SUPP-1I > SPACES
MOVE 'S' TO O1-INQFUN, I1-INQFUN
MOVE SPACES TO HV-PM-CUSTOMER-SUPP
STRING '00', I1-SUPP-1I, I1-SUPP-2I
DELIMITED BY SIZE INTO HV-PM-CUSTOMER-SUPP
MOVE I1-DOCKI TO HV-PM-LOCATION
MOVE SPACES TO HV-PM-EFF-START
MOVE SPACES TO HV-PM-ITEMID
PERFORM 2120-PRUKANB-SUPP THRU
2120-PRUKANB-SUPP-EXIT
ELSE
MOVE 'P' TO O1-INQFUN, I1-INQFUN
MOVE SPACES TO HV-PM-ITEMID
STRING
I1-PARTNO-1
I1-PARTNO-2
I1-PARTNO-3
DELIMITED BY SIZE INTO HV-PM-ITEMID
MOVE SPACES TO HV-PM-EFF-START
MOVE SPACES TO HV-PM-CUSTOMER-SUPP
MOVE SPACES TO HV-PM-LOCATION
PERFORM 2150-PRUKANB-PART THRU
2150-PRUKANB-PART-EXIT
END-IF.
2100-KEY-SETUP-EXIT. EXIT.
2120-PRUKANB-SUPP.
PERFORM 8000-OPEN-F1-PRUKANB-SUPP THRU
8000-OPEN-F1-PRUKANB-SUPP-EXIT.
PERFORM VARYING I FROM 1 BY 1 UNTIL I > 13
EXEC SQL
FETCH F1-PRUKANB-SUPP INTO
:HV-PM-CUSTOMER-SUPP,
:HV-PM-LOCATION,
:HV-PM-ITEMID,
:HV-PM-EFF-START,
:HV-PM-EFF-STOP:NI-EFF-STOP,
:HV-PM-SHIPPING-LOCATION:NI-SHIPPING-LOCATION,
:HV-PM-CATEGORY:NI-CATEGORY
END-EXEC
EVALUATE SQLCODE
WHEN 0
PERFORM 7300-MOVE-REFORMAT THRU
7300-MOVE-REFORMAT-EXIT
PERFORM 7400-PROCESS-PRUKBPD THRU
7400-PROCESS-PRUKBPD-EXIT
WHEN 100
IF I = 1
MOVE KEY-VALUE-MSG TO O1-CMNT
MOVE ATR-BRT-CURSR-MOD TO O1-SUPP-1A
MOVE ATR-BRT-CURSR-MOD TO O1-SUPP-2A
MOVE ATR-BRT-CURSR-MOD TO O1-DOCKA
MOVE I1-SUPP-1I TO O1-SUPP-1
MOVE I1-SUPP-2I TO O1-SUPP-2
MOVE I1-DOCKI TO O1-DOCK
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-IF
MOVE 14 TO I
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'DB2 ERROR FETCH F1-PRUKANB-SUPP'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE
END-PERFORM.
PERFORM 8300-CLOSE-F1-PRUKANB-SUPP THRU
8300-CLOSE-F1-PRUKANB-S-EXIT.
2120-PRUKANB-SUPP-EXIT. EXIT.
2150-PRUKANB-PART.
PERFORM 8200-OPEN-F1-PRUKANB-PART THRU
8200-OPEN-F1-PRUKANB-PART-EXIT
PERFORM VARYING I FROM 1 BY 1 UNTIL I > 13
EXEC SQL
FETCH F1-PRUKANB-PART INTO
:HV-PM-CUSTOMER-SUPP,
:HV-PM-LOCATION,
:HV-PM-ITEMID,
:HV-PM-EFF-START,
:HV-PM-EFF-STOP:NI-EFF-STOP,
:HV-PM-SHIPPING-LOCATION:NI-SHIPPING-LOCATION,
:HV-PM-CATEGORY:NI-CATEGORY
END-EXEC
EVALUATE SQLCODE
WHEN 0
PERFORM 7300-MOVE-REFORMAT THRU
7300-MOVE-REFORMAT-EXIT
PERFORM 7400-PROCESS-PRUKBPD THRU
7400-PROCESS-PRUKBPD-EXIT
WHEN 100
IF I = 1 AND I1-PARTNO-1 > SPACES
MOVE KEY-VALUE-MSG TO O1-CMNT
MOVE ATR-BRT-CURSR-MOD TO O1-PARTNO-1A
MOVE ATR-BRT-CURSR-MOD TO O1-PARTNO-2A
MOVE ATR-BRT-CURSR-MOD TO O1-PARTNO-3A
MOVE I1-SUPP-1I TO O1-SUPP-1
MOVE I1-SUPP-2I TO O1-SUPP-2
MOVE I1-DOCKI TO O1-DOCK
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-IF
MOVE 14 TO I
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'DB2 ERROR FETCH F1-PRUKANB-PART'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE
END-PERFORM.
PERFORM 8400-CLOSE-F1-PRUKANB-PART THRU
8400-CLOSE-F1-PRUKANB-P-EXIT.
2150-PRUKANB-PART-EXIT. EXIT.
*-----------> COMMENTS
*
* THE UPDATE LOGIC HAS TWO MAIN PATHS, ONE FOR SUPPLIER
* AND DOCK OR LOCATION CODE AND ONE FOR PART NUMBER.
* THIRTEEN DETAIL LINES ARE DISPLAYED ON THE SCREEN FOR
* INQUIRY. THEN LINE BY LINE THE UPDATE FUNCTION LOOKS
* FOR A "C" IN THE OPERATION CODE TO PROCESS CHANGES.
* WITHIN THE UPDATE FUNCTION THE FIELD A-ERR IS A
* UNIVERSAL ERROR SWITCH. IT IS USED TO PASS CONTROL
* BACK TO IMS WHENEVER ANY ERROR OCCURS.
*
2200-UPDATE-FUNCTION.
MOVE 0 TO A-ERR.
IF I1-INQFUN NOT = 'P' AND I1-INQFUN NOT = 'S'
MOVE M-INQ-FIRST TO O1-CMNT
MOVE ATR-BRT-CURSR-MOD TO O1-SUPP-1A
ADD 1 TO A-ERR
GO TO 2200-UPDATE-FUNCTION-EXIT.
PERFORM VARYING I FROM 1 BY 1 UNTIL I > 13
IF I1-OPCODE(I) GREATER THAN SPACES
IF I1-OPCODE(I) NOT = 'C'
MOVE OPCODE-MSG TO O1-CMNT
MOVE ATR-BRT-CURSR-MOD TO O1-OPCODEA(I)
ADD 1 TO A-ERR
END-IF
END-IF
END-PERFORM.
PERFORM VARYING I FROM 1 BY 1 UNTIL I > 13
IF I1-OPCODE(I) = 'C'
IF I1-PARTNO(I) = SPACES
MOVE WS-CHANGE-MSG TO O1-CMNT
MOVE ATR-BRT-CURSR-MOD TO O1-OPCODEA(I)
ADD 1 TO A-ERR
ELSE
PERFORM 2210-VALIDATE-FIELDS THRU
2210-VALIDATE-FIELDS-EXIT
END-IF
END-IF
END-PERFORM.
IF A-ERR GREATER THAN ZERO
PERFORM 3000-MOVE-IN-TO-OUT THRU
3000-MOVE-IN-TO-OUT-EXIT
PERFORM 3500-SEND-MSG-AND-RETURN THRU
3500-SEND-MSG-AND-RETURN-EXIT.
MOVE 'N' TO WS-CHG-ON-SCREEN.
PERFORM VARYING I FROM 1 BY 1 UNTIL I > 13
IF I1-OPCODE(I) = 'C'
MOVE 'Y' TO WS-CHG-ON-SCREEN
PERFORM 2220-CHANGE-ROUTINE THRU
2220-CHANGE-ROUTINE-EXIT
END-IF
END-PERFORM.
IF WS-CHG-ON-SCREEN EQUAL 'N'
MOVE NO-CHG-MSG TO O1-CMNT
PERFORM 3000-MOVE-IN-TO-OUT THRU
3000-MOVE-IN-TO-OUT-EXIT
PERFORM 3500-SEND-MSG-AND-RETURN THRU
3500-SEND-MSG-AND-RETURN-EXIT
END-IF.
PERFORM VARYING I FROM 1 BY 1 UNTIL I > 13
IF I1-OPCODE(I) = 'C'
MOVE SPACE TO I1-OPCODE(I)
END-IF
END-PERFORM.
MOVE SPACES TO I1-FUNCI
O1-FUNC.
MOVE SPACES TO HV-PM-CUSTOMER-SUPP
STRING '00', I1-SUPP-1I, I1-SUPP-2I
DELIMITED BY SIZE INTO HV-PM-CUSTOMER-SUPP
MOVE I1-DOCKI TO HV-PM-LOCATION
MOVE I1-TIMEFR(1) TO WS-YYMMDD
IF WS-YY > '50'
MOVE '19' TO WS-CC
ELSE
MOVE '20' TO WS-CC
END-IF
MOVE WS-CCYY-DATE TO WS-WORK-DATE-CCYY
MOVE '-' TO DASH-1
MOVE WS-MM-DATE TO WS-WORK-DATE-MM
MOVE '-' TO DASH-2
MOVE WS-DD-DATE TO WS-WORK-DATE-DD
MOVE WS-WORK-DATE TO HV-PM-EFF-START
MOVE SPACES TO HV-PM-ITEMID
STRING I1-PARTNO(1)(1:5)
I1-PARTNO(1)(7:5)
I1-PARTNO(1)(13:2)
DELIMITED BY SIZE INTO HV-PM-ITEMID.
* USES PREVIOUS INQUIRY ROUTINES
IF I1-SUPP-1I > SPACES
MOVE 'S' TO O1-INQFUN
PERFORM 2120-PRUKANB-SUPP THRU
2120-PRUKANB-SUPP-EXIT
ELSE
MOVE 'P' TO O1-INQFUN
PERFORM 2150-PRUKANB-PART THRU
2150-PRUKANB-PART-EXIT
END-IF.
MOVE CHANGE-MSG TO O1-CMNT.
2200-UPDATE-FUNCTION-EXIT. EXIT.
2210-VALIDATE-FIELDS.
IF I1-TO-PC(I) GREATER THAN SPACES
MOVE I1-TO-PC(I) TO CONVT-NUMBER
PERFORM 7000-CONVERT THRU 7000-CONVERT-EXIT
IF ERROR-CODE = ' '
MOVE FIXED-NUMBER TO PIC-4
MOVE PIC-4 TO O1-TO-PC-N(I)
I1-TO-PC(I)
ELSE
ADD 1 TO A-ERR
MOVE I1-TO-PC(I) TO O1-TO-PC(I)
MOVE TO-PC-MSG TO O1-CMNT
MOVE ATR-BRT-CURSR-MOD TO O1-TO-PCA(I)
END-IF
END-IF.
IF I1-PC-SAFETY(I) GREATER THAN SPACES
MOVE I1-PC-SAFETY(I) TO CONVT-NUMBER
PERFORM 7000-CONVERT THRU 7000-CONVERT-EXIT
IF ERROR-CODE = ' '
MOVE FIXED-NUMBER TO PIC-4
MOVE PIC-4 TO I1-PC-SAFETY(I)
O1-PC-SAFETY(I)
ELSE
MOVE I1-PC-SAFETY(I) TO O1-PC-SAFETY(I)
ADD 1 TO A-ERR
MOVE PC-SAFETY-MSG TO O1-CMNT
MOVE ATR-BRT-CURSR-MOD TO O1-PC-SAFETYA(I)
END-IF
END-IF.
IF I1-TO-LS(I) GREATER THAN SPACES
MOVE I1-TO-LS(I) TO CONVT-NUMBER
PERFORM 7000-CONVERT THRU 7000-CONVERT-EXIT
IF ERROR-CODE = ' '
MOVE FIXED-NUMBER TO PIC-4
MOVE PIC-4 TO I1-TO-LS(I)
O1-TO-LS(I)
ELSE
MOVE I1-TO-LS(I) TO O1-TO-LS(I)
ADD 1 TO A-ERR
MOVE TO-LS-MSG TO O1-CMNT
MOVE ATR-BRT-CURSR-MOD TO O1-TO-LSA(I)
END-IF
END-IF.
IF I1-LS-SAFETY(I) GREATER THAN SPACES
MOVE I1-LS-SAFETY(I) TO CONVT-NUMBER
PERFORM 7000-CONVERT THRU 7000-CONVERT-EXIT
IF ERROR-CODE = ' '
MOVE FIXED-NUMBER TO PIC-4
MOVE PIC-4 TO I1-LS-SAFETY(I)
O1-LS-SAFETY(I)
ELSE
MOVE I1-LS-SAFETY(I) TO O1-LS-SAFETY(I)
ADD 1 TO A-ERR
MOVE LS-SAFETY-MSG TO O1-CMNT
MOVE ATR-BRT-CURSR-MOD TO O1-LS-SAFETYA(I)
END-IF
END-IF.
IF (I1-INTKBN1(I) = SPACES AND
I1-INTKBN2(I) = SPACES AND
I1-INTKBN3(I) = SPACES) OR
(I1-INTKBN1(I) = '00' AND
I1-INTKBN2(I) = '00' AND
I1-INTKBN3(I) = '00')
CONTINUE
ELSE
IF I1-INTKBN1(I) = '01' OR '05'
CONTINUE
ELSE
ADD 1 TO A-ERR
MOVE INTKBN-MSG-1 TO O1-CMNT
MOVE ATR-BRT-CURSR-MOD TO O1-INTKBN1A(I)
END-IF
IF I1-INTKBN2(I) NUMERIC
CONTINUE
ELSE
ADD 1 TO A-ERR
MOVE INTKBN-MSG-2 TO O1-CMNT
MOVE ATR-BRT-CURSR-MOD TO O1-INTKBN2A(I)
END-IF
IF I1-INTKBN3(I) NUMERIC
CONTINUE
ELSE
ADD 1 TO A-ERR
MOVE INTKBN-MSG-2 TO O1-CMNT
MOVE ATR-BRT-CURSR-MOD TO O1-INTKBN3A(I)
END-IF
END-IF.
IF I1-CALCBVSC(I) EQUAL 'Y' OR 'N'
CONTINUE
ELSE
ADD 1 TO A-ERR
MOVE CALCBVSC-MSG TO O1-CMNT
MOVE ATR-BRT-CURSR-MOD TO O1-CALCBVSCA(I)
END-IF.
IF I1-SHIPDOCK(I) GREATER THAN SPACES
MOVE I1-SHIPDOCK(I) TO WS-SHIPDOCK
PERFORM 7100-SHIFT THRU 7100-SHIFT-EXIT
IF ERROR-CODE EQUAL SPACES
MOVE WS-SHIPDOCK TO I1-SHIPDOCK(I)
O1-SHIPDOCK(I)
MOVE 0 TO NI-SM-SHIPPING-LOCATION
NI-SHIPPING-LOCATION
ELSE
ADD 1 TO A-ERR
MOVE SHIPDOCK-MSG TO O1-CMNT
MOVE ATR-BRT-CURSR-MOD TO O1-SHIPDOCKA(I)
END-IF
ELSE
MOVE -1 TO NI-SM-SHIPPING-LOCATION
NI-SHIPPING-LOCATION
END-IF.
2210-VALIDATE-FIELDS-EXIT. EXIT.
2220-CHANGE-ROUTINE.
PERFORM 2222-PREREAD-PRUKANB THRU
2222-PREREAD-PRUKANB-EXIT.
PERFORM 2224-PREREAD-PRUKBPD THRU
2224-PREREAD-PRUKBPD-EXIT.
PERFORM 7600-CSULOCD-READ THRU
7600-CSULOCD-READ-EXIT.
IF WS-CSULOCD-FOUND = 'Y'
PERFORM 2500-READ-CSULDPD THRU
2500-READ-CSULDPD-EXIT
END-IF.
MOVE I1-TO-PC(I) TO WS-SCREEN-TO-PC.
MOVE I1-PC-SAFETY(I) TO WS-SCREEN-PC-SAFETY.
MOVE I1-TO-LS(I) TO WS-SCREEN-TO-LS.
MOVE I1-LS-SAFETY(I) TO WS-SCREEN-LS-SAFETY.
MOVE SPACES TO WS-SCREEN-INTKBN.
STRING I1-INTKBN1(I) I1-INTKBN2(I) I1-INTKBN3(I)
DELIMITED BY SIZE INTO WS-SCREEN-INTKBN.
IF WS-SCREEN-TO-PC GREATER THAN SPACES
INSPECT WS-SCREEN-TO-PC REPLACING LEADING ' ' BY '0'.
IF WS-SCREEN-PC-SAFETY GREATER THAN SPACES
INSPECT WS-SCREEN-PC-SAFETY REPLACING LEADING ' ' BY '0'.
IF WS-SCREEN-TO-LS GREATER THAN SPACES
INSPECT WS-SCREEN-TO-LS REPLACING LEADING ' ' BY '0'.
IF WS-SCREEN-LS-SAFETY GREATER THAN SPACES
INSPECT WS-SCREEN-LS-SAFETY REPLACING LEADING ' ' BY '0'.
IF WS-SCREEN-INTKBN GREATER THAN SPACES
INSPECT WS-SCREEN-INTKBN REPLACING LEADING ' ' BY '0'.
* VERIFY IF IS NECESSARY TO CALL ROUTINE TO UPDATE PRUKANB
MOVE 'N' TO WS-UPDATE-PRUKANB.
IF I1-CALCBVSC(I) NOT EQUAL WS-KANB-CATEGORY
MOVE 'Y' TO WS-UPDATE-PRUKANB
END-IF.
IF I1-SHIPDOCK(I) NOT EQUAL WS-KANB-SHIPPING-LOCATION
IF (I1-SHIPDOCK(I) NOT EQUAL
WS-CSULOCD-SHIPPING-LOCATION OR
WS-CSULOCD-SHIPPING-LOCATION EQUAL SPACES)
MOVE 'Y' TO WS-UPDATE-PRUKANB
END-IF
END-IF.
* VERIFY IF IS NECESSARY TO CALL ROUTINE TO UPDATE PRUKBPD
MOVE 'N' TO WS-UPDATE-PRUKBPD.
MOVE 'NNNNN' TO WS-UPDATE-FIELDS.
IF WS-SCREEN-TO-PC NOT EQUAL WS-KBPD-TO-PC
IF WS-SCREEN-TO-PC NOT EQUAL WS-LDPD-TO-PC OR
WS-LDPD-TO-PC EQUAL SPACES
MOVE 'Y' TO WS-UPDATE-PRUKBPD
MOVE 'Y' TO WS-UPDATE-TO-PC
END-IF
END-IF.
IF WS-SCREEN-PC-SAFETY NOT EQUAL WS-KBPD-PC-SAFETY
IF (WS-SCREEN-PC-SAFETY NOT EQUAL WS-LDPD-PC-SAFETY OR
WS-LDPD-PC-SAFETY EQUAL SPACES)
MOVE 'Y' TO WS-UPDATE-PRUKBPD
MOVE 'Y' TO WS-UPDATE-PC-SAFETY
END-IF
END-IF.
IF WS-SCREEN-TO-LS NOT EQUAL WS-KBPD-TO-LS
IF (WS-SCREEN-TO-LS NOT EQUAL WS-LDPD-TO-LS OR
WS-LDPD-TO-LS EQUAL SPACES)
MOVE 'Y' TO WS-UPDATE-PRUKBPD
MOVE 'Y' TO WS-UPDATE-TO-LS
END-IF
END-IF.
IF WS-SCREEN-LS-SAFETY NOT EQUAL WS-KBPD-LS-SAFETY
IF (WS-SCREEN-LS-SAFETY NOT EQUAL WS-LDPD-LS-SAFETY OR
WS-LDPD-LS-SAFETY EQUAL SPACES)
MOVE 'Y' TO WS-UPDATE-PRUKBPD
MOVE 'Y' TO WS-UPDATE-LS-SAFETY
END-IF
END-IF.
IF WS-SCREEN-INTKBN NOT EQUAL WS-KBPD-INTKBN
IF (WS-SCREEN-INTKBN NOT EQUAL WS-LDPD-INTKBN OR
WS-LDPD-INTKBN EQUAL SPACES)
MOVE 'Y' TO WS-UPDATE-PRUKBPD
MOVE 'Y' TO WS-UPDATE-INTKBN
END-IF
END-IF.
IF WS-UPDATE-PRUKANB = 'N' AND WS-UPDATE-PRUKBPD = 'N'
MOVE NO-CHG-MSG TO O1-CMNT
ADD 1 TO A-ERR
MOVE ATR-BRT-CURSR-MOD TO O1-OPCODEA(I)
PERFORM 3000-MOVE-IN-TO-OUT THRU
3000-MOVE-IN-TO-OUT-EXIT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
ELSE
MOVE SPACE TO O1-OPCODE(I), I1-OPCODE(I)
IF WS-UPDATE-PRUKANB = 'Y'
PERFORM 2226-UPDATE-PRUKANB THRU
2226-UPDATE-PRUKANB-EXIT
END-IF
IF WS-UPDATE-PRUKBPD = 'Y'
PERFORM 2228-UPDATE-PRUKBPD THRU
2228-UPDATE-PRUKBPD-EXIT
END-IF
END-IF.
2220-CHANGE-ROUTINE-EXIT. EXIT.
2222-PREREAD-PRUKANB.
MOVE SPACES TO HV-PM-CUSTOMER-SUPP.
STRING '00', I1-SUPP(I)(1:4), I1-SUPP(I)(6:1)
DELIMITED BY SIZE INTO HV-PM-CUSTOMER-SUPP.
MOVE I2-DOCKI(I) TO HV-PM-LOCATION.
MOVE SPACES TO HV-PM-ITEMID.
STRING I1-PARTNO(I)(1:5), I1-PARTNO(I)(7:5),
I1-PARTNO(I)(13:2)
DELIMITED BY SIZE INTO HV-PM-ITEMID.
MOVE I1-TIMEFR(I) TO WS-YYMMDD.
IF WS-YY > '50'
MOVE '19' TO WS-CC
ELSE
MOVE '20' TO WS-CC
END-IF.
MOVE WS-CCYY-DATE TO WS-WORK-DATE-CCYY.
MOVE '-' TO DASH-1.
MOVE WS-MM-DATE TO WS-WORK-DATE-MM.
MOVE '-' TO DASH-2.
MOVE WS-DD-DATE TO WS-WORK-DATE-DD.
MOVE WS-WORK-DATE TO HV-PM-EFF-START.
* EFF_STOP IS NEEDED TO READ CSULOCD IN FURTHER STEP
EXEC SQL
SELECT SHIPPING_LOCATION, CATEGORY, EFF_STOP
INTO :HV-PM-SHIPPING-LOCATION :NI-SHIPPING-LOCATION,
:HV-PM-CATEGORY :NI-CATEGORY,
:HV-PM-EFF-STOP :NI-EFF-STOP
FROM PRUKANB
WHERE BUSINESS_ENTITY = :I1-HIDE-BEI
AND TYPE = 'CD'
AND CSI_TYPE = 'SU'
AND CUSTOMER_SUPP = :HV-PM-CUSTOMER-SUPP
AND LOCATION = :HV-PM-LOCATION
AND ITEMID = :HV-PM-ITEMID
AND EFF_START = :HV-PM-EFF-START
END-EXEC.
EVALUATE SQLCODE
WHEN 0
IF NI-SHIPPING-LOCATION LESS THAN ZERO
MOVE SPACES TO WS-KANB-SHIPPING-LOCATION
MOVE 'Y' TO NULL-SWITCH
ELSE
STRING HV-PM-SHIPPING-LOCATION(1:3)
DELIMITED BY SIZE INTO
WS-KANB-SHIPPING-LOCATION
END-IF
IF NI-CATEGORY LESS THAN ZERO
MOVE SPACE TO WS-KANB-CATEGORY
ELSE
IF HV-PM-CATEGORY = 'CALCBVSC'
MOVE 'Y' TO WS-KANB-CATEGORY
ELSE
IF HV-PM-CATEGORY = 'NOCALCBC'
MOVE 'N' TO WS-KANB-CATEGORY
ELSE
MOVE SPACE TO WS-KANB-CATEGORY
END-IF
END-IF
END-IF
IF NI-EFF-STOP LESS THAN ZERO
MOVE SPACES TO HV-PM-EFF-STOP
END-IF
WHEN 100
MOVE M-INFO-MSG TO O1-CMNT
ADD 1 TO A-ERR
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'DB2 ERROR READING FOR CATEGORY'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
2222-PREREAD-PRUKANB-EXIT. EXIT.
2224-PREREAD-PRUKBPD.
MOVE SPACES TO WS-KBPD-FIELDS.
PERFORM 8100-OPEN-C1-PRUKBPD THRU
8100-OPEN-C1-PRUKBPD-EXIT.
MOVE 'Y' TO WS-PRUKBPD-SWITCH.
PERFORM 2225-FORMAT-MOVE-PRUKBPD THRU
2225-FORMAT-MOVE-PRUKBPD-EXIT
UNTIL WS-NO-MORE-PRUKBPD.
PERFORM 8500-CLOSE-C1-PRUKBPD THRU
8500-CLOSE-C1-PRUKBPD-EXIT.
2224-PREREAD-PRUKBPD-EXIT. EXIT.
2225-FORMAT-MOVE-PRUKBPD.
EXEC SQL
FETCH C1-PRUKBPD INTO
:HV-PP-PERIOD-TYPE,
:HV-PP-PERIOD
END-EXEC.
EVALUATE SQLCODE
WHEN 0
IF HV-PP-PERIOD-TYPE = 'DP'
MOVE HV-PP-PERIOD (5:4) TO
WS-KBPD-TO-PC
END-IF
IF HV-PP-PERIOD-TYPE = 'ES'
MOVE HV-PP-PERIOD (5:4) TO
WS-KBPD-PC-SAFETY
END-IF
IF HV-PP-PERIOD-TYPE = 'DL'
MOVE HV-PP-PERIOD (5:4) TO
WS-KBPD-TO-LS
END-IF
IF HV-PP-PERIOD-TYPE = 'IS'
MOVE HV-PP-PERIOD (5:4) TO
WS-KBPD-LS-SAFETY
END-IF
IF HV-PP-PERIOD-TYPE = 'IK'
MOVE HV-PP-PERIOD (1:6) TO
WS-KBPD-INTKBN
END-IF
WHEN 100
MOVE 'N' TO WS-PRUKBPD-SWITCH
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'DB2 ERROR PREREAD FETCH PRUKBPD'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
2225-FORMAT-MOVE-PRUKBPD-EXIT. EXIT.
2226-UPDATE-PRUKANB.
MOVE SPACES TO HV-AU-KEY-FEEDBACK.
STRING 'CDSU', HV-PM-CUSTOMER-SUPP,
HV-PM-LOCATION,
HV-PM-ITEMID,
HV-PM-EFF-START DELIMITED BY SIZE
INTO HV-AU-KEY-FEEDBACK.
MOVE 'PRUKANB' TO HV-AU-STORAGE-ID.
MOVE 'C' TO HV-AU-FUNCTION.
IF I1-CALCBVSC(I) NOT EQUAL WS-KANB-CATEGORY
MOVE 'CATEGORY' TO HV-AU-STORAGE-ELEMENT
MOVE WS-KANB-CATEGORY TO HV-AU-COMMENTS
MOVE NI-CATEGORY TO COMMENTS-NI
MOVE I1-CALCBVSC(I) TO HV-AU-NEW-VALUE
MOVE 0 TO HV-AU-NEW-VALUE-NI
PERFORM 7200-INSERT-PRUAUDT THRU
7200-INSERT-PRUAUDT-EXIT
END-IF.
IF I1-SHIPDOCK(I) EQUAL SPACES AND
NULL-SWITCH EQUAL 'Y'
MOVE 'N' TO NULL-SWITCH
MOVE -1 TO HV-PM-SHIPNI
ELSE
IF I1-SHIPDOCK(I) NOT EQUAL WS-KANB-SHIPPING-LOCATION
IF (I1-SHIPDOCK(I) NOT EQUAL
WS-CSULOCD-SHIPPING-LOCATION OR
WS-CSULOCD-SHIPPING-LOCATION EQUAL SPACES)
MOVE 'SHIPPING LOCATION' TO HV-AU-STORAGE-ELEMENT
MOVE WS-KANB-SHIPPING-LOCATION TO HV-AU-COMMENTS
MOVE NI-SHIPPING-LOCATION TO COMMENTS-NI
MOVE I1-SHIPDOCK(I) TO HV-AU-NEW-VALUE
IF I1-SHIPDOCK(I) EQUAL SPACES
MOVE -1 TO HV-AU-NEW-VALUE-NI
ELSE
MOVE 0 TO HV-AU-NEW-VALUE-NI
END-IF
PERFORM 7200-INSERT-PRUAUDT THRU
7200-INSERT-PRUAUDT-EXIT
* SET VALUES TO UPDATE PRUKANB
IF I1-SHIPDOCK(I) = SPACES
MOVE -1 TO HV-PM-SHIPNI
ELSE
MOVE 0 TO HV-PM-SHIPNI
MOVE I1-SHIPDOCK(I) TO HV-PM-SHIPPING-LOCATION
END-IF
ELSE
IF WS-KANB-SHIPPING-LOCATION EQUAL SPACES
MOVE -1 TO HV-PM-SHIPNI
ELSE
MOVE 0 TO HV-PM-SHIPNI
MOVE WS-KANB-SHIPPING-LOCATION TO
HV-PM-SHIPPING-LOCATION
END-IF
END-IF
END-IF
END-IF.
MOVE 0 TO NI-CATEGORY.
IF I1-CALCBVSC(I) = 'Y'
MOVE 'CALCBVSC' TO HV-PM-CATEGORY
ELSE
MOVE 'NOCALCBC' TO HV-PM-CATEGORY
END-IF.
EXEC SQL
UPDATE PRUKANB
SET CATEGORY = :HV-PM-CATEGORY :NI-CATEGORY,
SHIPPING_LOCATION = :HV-PM-SHIPPING-LOCATION:HV-PM-SHIPNI,
DATETIME = CURRENT_TIMESTAMP,
USERID = :WS-IO-USER-ID
WHERE BUSINESS_ENTITY = :I1-HIDE-BEI
AND TYPE = 'CD'
AND CSI_TYPE = 'SU'
AND CUSTOMER_SUPP = :HV-PM-CUSTOMER-SUPP
AND LOCATION = :HV-PM-LOCATION
AND ITEMID = :HV-PM-ITEMID
AND EFF_START = :HV-PM-EFF-START
END-EXEC.
IF SQLCODE = 0
CONTINUE
ELSE
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'DB2 ERROR UPDATING PRUKANB'
', SQLCODE = ' DIS-SQL
DELIMITED BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-IF.
2226-UPDATE-PRUKANB-EXIT. EXIT.
2228-UPDATE-PRUKBPD.
* VERIFY IF IT IS NECESSARY TO UPDATE PRUAUDT
MOVE SPACES TO HV-AU-KEY-FEEDBACK.
STRING 'CDSU', HV-PM-CUSTOMER-SUPP,
HV-PM-LOCATION,
HV-PM-ITEMID,
HV-PM-EFF-START DELIMITED BY SIZE
INTO HV-AU-KEY-FEEDBACK.
MOVE 'PRUKBPD' TO HV-AU-STORAGE-ID.
MOVE 'C' TO HV-AU-FUNCTION.
IF WS-UPDATE-TO-PC = 'Y'
MOVE 'TO PC' TO HV-AU-STORAGE-ELEMENT
MOVE WS-KBPD-TO-PC TO HV-AU-COMMENTS
IF WS-KBPD-TO-PC EQUAL SPACES
MOVE -1 TO COMMENTS-NI
ELSE
MOVE 0 TO COMMENTS-NI
END-IF
MOVE WS-SCREEN-TO-PC TO HV-AU-NEW-VALUE
IF WS-SCREEN-TO-PC EQUAL SPACES
MOVE -1 TO HV-AU-NEW-VALUE-NI
ELSE
MOVE 0 TO HV-AU-NEW-VALUE-NI
END-IF
PERFORM 7200-INSERT-PRUAUDT THRU
7200-INSERT-PRUAUDT-EXIT
END-IF.
IF WS-UPDATE-PC-SAFETY = 'Y'
MOVE 'PC SAFETY' TO HV-AU-STORAGE-ELEMENT
MOVE WS-KBPD-PC-SAFETY TO HV-AU-COMMENTS
IF WS-KBPD-PC-SAFETY EQUAL SPACES
MOVE -1 TO COMMENTS-NI
ELSE
MOVE 0 TO COMMENTS-NI
END-IF
MOVE WS-SCREEN-PC-SAFETY TO HV-AU-NEW-VALUE
IF WS-SCREEN-PC-SAFETY EQUAL SPACES
MOVE -1 TO HV-AU-NEW-VALUE-NI
ELSE
MOVE 0 TO HV-AU-NEW-VALUE-NI
END-IF
PERFORM 7200-INSERT-PRUAUDT THRU
7200-INSERT-PRUAUDT-EXIT
END-IF.
IF WS-UPDATE-TO-LS = 'Y'
MOVE 'TO LS' TO HV-AU-STORAGE-ELEMENT
MOVE WS-KBPD-TO-LS TO HV-AU-COMMENTS
IF WS-KBPD-TO-LS EQUAL SPACES
MOVE -1 TO COMMENTS-NI
ELSE
MOVE 0 TO COMMENTS-NI
END-IF
MOVE WS-SCREEN-TO-LS TO HV-AU-NEW-VALUE
IF WS-SCREEN-TO-LS EQUAL SPACES
MOVE -1 TO HV-AU-NEW-VALUE-NI
ELSE
MOVE 0 TO HV-AU-NEW-VALUE-NI
END-IF
PERFORM 7200-INSERT-PRUAUDT THRU
7200-INSERT-PRUAUDT-EXIT
END-IF.
IF WS-UPDATE-LS-SAFETY = 'Y'
MOVE 'LS SAFETY' TO HV-AU-STORAGE-ELEMENT
MOVE WS-KBPD-LS-SAFETY TO HV-AU-COMMENTS
IF WS-KBPD-LS-SAFETY EQUAL SPACES
MOVE -1 TO COMMENTS-NI
ELSE
MOVE 0 TO COMMENTS-NI
END-IF
MOVE WS-SCREEN-LS-SAFETY TO HV-AU-NEW-VALUE
IF WS-SCREEN-LS-SAFETY EQUAL SPACES
MOVE -1 TO HV-AU-NEW-VALUE-NI
ELSE
MOVE 0 TO HV-AU-NEW-VALUE-NI
END-IF
PERFORM 7200-INSERT-PRUAUDT THRU
7200-INSERT-PRUAUDT-EXIT
END-IF.
IF WS-UPDATE-INTKBN = 'Y'
MOVE 'INT KBN CYCLE' TO HV-AU-STORAGE-ELEMENT
MOVE WS-KBPD-INTKBN TO HV-AU-COMMENTS
IF WS-KBPD-INTKBN EQUAL SPACES
MOVE -1 TO COMMENTS-NI
ELSE
MOVE 0 TO COMMENTS-NI
END-IF
MOVE WS-SCREEN-INTKBN TO HV-AU-NEW-VALUE
IF WS-SCREEN-INTKBN EQUAL SPACES
MOVE -1 TO HV-AU-NEW-VALUE-NI
ELSE
MOVE 0 TO HV-AU-NEW-VALUE-NI
END-IF
PERFORM 7200-INSERT-PRUAUDT THRU
7200-INSERT-PRUAUDT-EXIT
END-IF.
* VERIFY IF IT IS NECESSARY TO INSERT/DELETE/UPDATE PRUKBPD
IF WS-UPDATE-TO-PC = 'Y'
IF WS-SCREEN-TO-PC NOT EQUAL SPACES AND
WS-KBPD-TO-PC EQUAL SPACES
MOVE 'DP' TO HV-PP-PERIOD-TYPE
MOVE SPACES TO HV-PP-PERIOD
STRING 'MN00', I1-TO-PC(I) DELIMITED BY SIZE
INTO HV-PP-PERIOD
PERFORM 7725-ADD-PRUKBPD THRU
7725-ADD-PRUKBPD-EXIT
END-IF
IF WS-KBPD-TO-PC NOT EQUAL SPACES AND
WS-SCREEN-TO-PC EQUAL SPACES
MOVE 'DP' TO HV-PP-PERIOD-TYPE
PERFORM 7750-DELETE-PRUKBPD THRU
7750-DELETE-PRUKBPD-EXIT
END-IF
IF WS-KBPD-TO-PC GREATER THAN SPACES AND
WS-SCREEN-TO-PC GREATER THAN SPACES
IF WS-KBPD-TO-PC NOT EQUAL WS-SCREEN-TO-PC
MOVE 'DP' TO HV-PP-PERIOD-TYPE
MOVE SPACES TO HV-PP-PERIOD
STRING 'MN00', I1-TO-PC(I) DELIMITED BY SIZE
INTO HV-PP-PERIOD
PERFORM 7775-UPDATE-PRUKBPD THRU
7775-UPDATE-PRUKBPD-EXIT
END-IF
END-IF
END-IF.
IF WS-UPDATE-PC-SAFETY = 'Y'
IF WS-KBPD-PC-SAFETY EQUAL SPACES AND
WS-SCREEN-PC-SAFETY NOT EQUAL SPACES
MOVE 'ES' TO HV-PP-PERIOD-TYPE
MOVE SPACES TO HV-PP-PERIOD
STRING 'MN00', I1-PC-SAFETY(I) DELIMITED BY SIZE
INTO HV-PP-PERIOD
PERFORM 7725-ADD-PRUKBPD THRU
7725-ADD-PRUKBPD-EXIT
END-IF
IF WS-KBPD-PC-SAFETY NOT EQUAL SPACES AND
WS-SCREEN-PC-SAFETY EQUAL SPACES
MOVE 'ES' TO HV-PP-PERIOD-TYPE
PERFORM 7750-DELETE-PRUKBPD THRU
7750-DELETE-PRUKBPD-EXIT
END-IF
IF WS-KBPD-PC-SAFETY GREATER THAN SPACES AND
WS-SCREEN-PC-SAFETY GREATER THAN SPACES
IF WS-KBPD-PC-SAFETY NOT EQUAL WS-SCREEN-PC-SAFETY
MOVE 'ES' TO HV-PP-PERIOD-TYPE
MOVE SPACES TO HV-PP-PERIOD
STRING 'MN00', I1-PC-SAFETY(I) DELIMITED BY SIZE
INTO HV-PP-PERIOD
PERFORM 7775-UPDATE-PRUKBPD THRU
7775-UPDATE-PRUKBPD-EXIT
END-IF
END-IF
END-IF.
IF WS-UPDATE-TO-LS = 'Y'
IF WS-KBPD-TO-LS EQUAL SPACES AND
WS-SCREEN-TO-LS NOT EQUAL SPACES
MOVE 'DL' TO HV-PP-PERIOD-TYPE
MOVE SPACES TO HV-PP-PERIOD
STRING 'MN00', I1-TO-LS(I) DELIMITED BY SIZE
INTO HV-PP-PERIOD
PERFORM 7725-ADD-PRUKBPD THRU
7725-ADD-PRUKBPD-EXIT
END-IF
IF WS-KBPD-TO-LS NOT EQUAL SPACES AND
WS-SCREEN-TO-LS EQUAL SPACES
MOVE 'DL' TO HV-PP-PERIOD-TYPE
PERFORM 7750-DELETE-PRUKBPD THRU
7750-DELETE-PRUKBPD-EXIT
END-IF
IF WS-KBPD-TO-LS GREATER THAN SPACES AND
WS-SCREEN-TO-LS GREATER THAN SPACES
IF WS-KBPD-TO-LS NOT EQUAL WS-SCREEN-TO-LS
MOVE 'DL' TO HV-PP-PERIOD-TYPE
MOVE SPACES TO HV-PP-PERIOD
STRING 'MN00', I1-TO-LS(I) DELIMITED BY SIZE
INTO HV-PP-PERIOD
PERFORM 7775-UPDATE-PRUKBPD THRU
7775-UPDATE-PRUKBPD-EXIT
END-IF
END-IF
END-IF.
IF WS-UPDATE-LS-SAFETY = 'Y'
IF WS-KBPD-LS-SAFETY EQUAL SPACES AND
WS-SCREEN-LS-SAFETY NOT EQUAL SPACES
MOVE 'IS' TO HV-PP-PERIOD-TYPE
MOVE SPACES TO HV-PP-PERIOD
STRING 'MN00', I1-LS-SAFETY(I) DELIMITED BY SIZE
INTO HV-PP-PERIOD
PERFORM 7725-ADD-PRUKBPD THRU
7725-ADD-PRUKBPD-EXIT
END-IF
IF WS-KBPD-LS-SAFETY NOT EQUAL SPACES AND
WS-SCREEN-LS-SAFETY EQUAL SPACES
MOVE 'IS' TO HV-PP-PERIOD-TYPE
PERFORM 7750-DELETE-PRUKBPD THRU
7750-DELETE-PRUKBPD-EXIT
END-IF
IF WS-KBPD-LS-SAFETY GREATER THAN SPACES AND
WS-SCREEN-LS-SAFETY GREATER THAN SPACES
IF WS-KBPD-LS-SAFETY NOT EQUAL WS-SCREEN-LS-SAFETY
MOVE 'IS' TO HV-PP-PERIOD-TYPE
MOVE SPACES TO HV-PP-PERIOD
STRING 'MN00', I1-LS-SAFETY(I) DELIMITED BY SIZE
INTO HV-PP-PERIOD
PERFORM 7775-UPDATE-PRUKBPD THRU
7775-UPDATE-PRUKBPD-EXIT
END-IF
END-IF
END-IF.
IF WS-UPDATE-INTKBN = 'Y'
IF WS-KBPD-INTKBN EQUAL SPACES AND
WS-SCREEN-INTKBN NOT EQUAL SPACES
MOVE 'IK' TO HV-PP-PERIOD-TYPE
MOVE WS-SCREEN-INTKBN TO HV-PP-PERIOD
PERFORM 7725-ADD-PRUKBPD THRU
7725-ADD-PRUKBPD-EXIT
END-IF
IF WS-KBPD-INTKBN NOT EQUAL SPACES AND
WS-SCREEN-INTKBN EQUAL SPACES
MOVE 'IK' TO HV-PP-PERIOD-TYPE
PERFORM 7750-DELETE-PRUKBPD THRU
7750-DELETE-PRUKBPD-EXIT
END-IF
IF WS-KBPD-INTKBN GREATER THAN SPACES AND
WS-SCREEN-INTKBN GREATER THAN SPACES
IF WS-KBPD-INTKBN NOT EQUAL WS-SCREEN-INTKBN
MOVE 'IK' TO HV-PP-PERIOD-TYPE
MOVE WS-SCREEN-INTKBN TO HV-PP-PERIOD
PERFORM 7775-UPDATE-PRUKBPD THRU
7775-UPDATE-PRUKBPD-EXIT
END-IF
END-IF
END-IF.
2228-UPDATE-PRUKBPD-EXIT. EXIT.
*-------------> COMMENTS
*
* 2300- AND 2400- ARE THE PAGING ROUTINES
*
2300-PAGE-BACK.
IF I1-PAGE EQUAL ' 1'
MOVE NO-DATA-MSG TO O1-CMNT
PERFORM 3000-MOVE-IN-TO-OUT THRU
3000-MOVE-IN-TO-OUT-EXIT
MOVE SPACE TO O1-FUNC
GO TO 2300-PAGE-BACK-EXIT.
IF I1-SUPP-1I > SPACES OR
I1-PARTNO-1 > SPACES
MOVE 'BACKWARD COMPLETE' TO O1-CMNT
MOVE ATR-CURSR TO O1-FUNCA
ELSE
MOVE M-INQ-FIRST TO O1-CMNT
END-IF.
PERFORM VARYING I FROM 1 BY 1 UNTIL I > 13
MOVE SPACES TO O1-TO-PC(I)
O1-PC-SAFETY(I)
O1-TO-LS(I)
O1-LS-SAFETY(I)
O1-INTKBN1(I)
O1-INTKBN2(I)
O1-INTKBN3(I)
END-PERFORM.
MOVE SPACES TO HV-PM-ITEMID.
STRING I1-PARTNO(1)(1:5)
I1-PARTNO(1)(7:5)
I1-PARTNO(1)(13:2) DELIMITED BY SIZE INTO
HV-PM-ITEMID.
MOVE SPACES TO HV-PM-CUSTOMER-SUPP.
STRING '00'
I1-SUPP(1)(1:4)
I1-SUPP(1)(6:1) DELIMITED BY SIZE INTO
HV-PM-CUSTOMER-SUPP.
MOVE I2-DOCKI(1) TO HV-PM-LOCATION
MOVE I1-TIMEFR(1) TO WS-YYMMDD
IF WS-YY > '50'
MOVE '19' TO WS-CC
ELSE
MOVE '20' TO WS-CC
END-IF.
MOVE WS-CCYY-DATE TO WS-WORK-DATE-CCYY
MOVE WS-MM-DATE TO WS-WORK-DATE-MM
MOVE WS-DD-DATE TO WS-WORK-DATE-DD
MOVE '-' TO DASH-1, DASH-2
MOVE WS-WORK-DATE TO HV-PM-EFF-START.
PERFORM VARYING I FROM 1 BY 1 UNTIL I > 13
MOVE SPACES TO I1-TO-PC(I)
I1-PC-SAFETY(I)
I1-TO-LS(I)
I1-LS-SAFETY(I)
I1-INTKBN1(I)
I1-INTKBN2(I)
I1-INTKBN3(I)
END-PERFORM.
IF I1-SUPP-1I > SPACES
PERFORM 2310-PRUKANB-SUPP THRU
2310-PRUKANB-SUPP-EXIT
ELSE
PERFORM 2340-PRUKANB-PART THRU
2340-PRUKANB-PART-EXIT
END-IF.
MOVE I1-PAGE TO WS-PAGE-DIS
INSPECT WS-PAGE-DIS REPLACING LEADING ' ' BY '0'
COMPUTE WS-PAGE-CNT = WS-PAGE-CNT - 1
INSPECT WS-PAGE-DIS REPLACING LEADING '0' BY ' '
MOVE WS-PAGE-DIS TO O1-PAGE.
2300-PAGE-BACK-EXIT. EXIT.
2310-PRUKANB-SUPP.
PERFORM 8150-OPEN-B1-PRUKANB-SUPP THRU
8150-OPEN-B1-PRUKANB-SUPP-EXIT.
PERFORM VARYING I FROM 13 BY -1 UNTIL I < 1
EXEC SQL
FETCH B1-PRUKANB-SUPP INTO
:HV-PM-CUSTOMER-SUPP,
:HV-PM-LOCATION,
:HV-PM-ITEMID,
:HV-PM-EFF-START,
:HV-PM-EFF-STOP:NI-EFF-STOP,
:HV-PM-SHIPPING-LOCATION:NI-SHIPPING-LOCATION,
:HV-PM-CATEGORY:NI-CATEGORY
END-EXEC
EVALUATE SQLCODE
WHEN 0
PERFORM 7300-MOVE-REFORMAT THRU
7300-MOVE-REFORMAT-EXIT
PERFORM 7400-PROCESS-PRUKBPD THRU
7400-PROCESS-PRUKBPD-EXIT
WHEN 100
MOVE 0 TO I
WHEN OTHER
MOVE 'DB2 ERROR FETCH B1-PRUKANB-SUPP'
TO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE
END-PERFORM.
PERFORM 8350-CLOSE-B1-PRUKANB-SUPP THRU
8350-CLOSE-B1-PRUKANB-S-EXIT.
2310-PRUKANB-SUPP-EXIT. EXIT.
2340-PRUKANB-PART.
PERFORM 8250-OPEN-B1-PRUKANB-PART THRU
8250-OPEN-B1-PRUKANB-PART-EXIT.
PERFORM VARYING I FROM 13 BY -1 UNTIL I < 1
EXEC SQL
FETCH B1-PRUKANB-PART INTO
:HV-PM-CUSTOMER-SUPP,
:HV-PM-LOCATION,
:HV-PM-ITEMID,
:HV-PM-EFF-START,
:HV-PM-EFF-STOP:NI-EFF-STOP,
:HV-PM-SHIPPING-LOCATION:NI-SHIPPING-LOCATION,
:HV-PM-CATEGORY:NI-CATEGORY
END-EXEC
EVALUATE SQLCODE
WHEN 0
PERFORM 7300-MOVE-REFORMAT THRU
7300-MOVE-REFORMAT-EXIT
PERFORM 7400-PROCESS-PRUKBPD THRU
7400-PROCESS-PRUKBPD-EXIT
WHEN 100
MOVE 0 TO I
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'DB2 ERROR FETCH B1-PRUKANB-PART'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE
END-PERFORM.
PERFORM 8450-CLOSE-B1-PRUKANB-PART THRU
8450-CLOSE-B1-PRUKANB-P-EXIT.
2340-PRUKANB-PART-EXIT. EXIT.
*--------------> COMMENTS
*
* THE PAGE FORWARD ROUTINES USE THE SAME PARAGRAPHS AS
* THE INQUIRY FUNCTIONS, I.E. 2120- AND 2150-
*
2400-PAGE-FORWARD.
MOVE SPACES TO O1-CMNT.
IF I2-DOCKI(13) NOT GREATER THAN SPACES
MOVE NO-DATA-MSG TO O1-CMNT
PERFORM 3000-MOVE-IN-TO-OUT THRU
3000-MOVE-IN-TO-OUT-EXIT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT.
IF I1-SUPP-1I > SPACES OR
I1-PARTNO-1 > SPACES
MOVE 'FORWARD COMPLETE' TO O1-CMNT
MOVE ATR-CURSR TO O1-FUNCA
ELSE
MOVE M-INQ-FIRST TO O1-CMNT
END-IF.
PERFORM VARYING I FROM 1 BY 1 UNTIL I > 13
MOVE SPACES TO O1-TO-PC(I)
O1-PC-SAFETY(I)
O1-TO-LS(I)
O1-LS-SAFETY(I)
O1-INTKBN1(I)
O1-INTKBN2(I)
O1-INTKBN3(I)
END-PERFORM.
MOVE SPACES TO HV-PM-ITEMID.
STRING I1-PARTNO(13)(1:5)
I1-PARTNO(13)(7:5)
I1-PARTNO(13)(13:2) DELIMITED BY SIZE INTO
HV-PM-ITEMID.
MOVE SPACES TO HV-PM-CUSTOMER-SUPP.
STRING '00'
I1-SUPP(13)(1:4)
I1-SUPP(13)(6:1) DELIMITED BY SIZE INTO
HV-PM-CUSTOMER-SUPP.
MOVE I2-DOCKI(13) TO HV-PM-LOCATION
MOVE I1-TIMEFR(13) TO WS-YYMMDD
IF WS-YY > '50'
MOVE '19' TO WS-CC
ELSE
MOVE '20' TO WS-CC
END-IF.
MOVE WS-CCYY-DATE TO WS-WORK-DATE-CCYY
MOVE WS-MM-DATE TO WS-WORK-DATE-MM
MOVE WS-DD-DATE TO WS-WORK-DATE-DD
MOVE '-' TO DASH-1, DASH-2
MOVE WS-WORK-DATE TO HV-PM-EFF-START.
PERFORM VARYING I FROM 1 BY 1 UNTIL I > 13
MOVE SPACES TO I1-TO-PC(I)
I1-PC-SAFETY(I)
I1-TO-LS(I)
I1-LS-SAFETY(I)
I1-INTKBN1(I)
I1-INTKBN2(I)
I1-INTKBN3(I)
END-PERFORM.
IF I1-SUPP-1I > SPACES
PERFORM 2120-PRUKANB-SUPP THRU
2120-PRUKANB-SUPP-EXIT
ELSE
PERFORM 2150-PRUKANB-PART THRU
2150-PRUKANB-PART-EXIT
END-IF.
MOVE I1-PAGE TO WS-PAGE-DIS
INSPECT WS-PAGE-DIS REPLACING LEADING ' ' BY '0'
COMPUTE WS-PAGE-CNT = WS-PAGE-CNT + 1
INSPECT WS-PAGE-DIS REPLACING LEADING '0' BY ' '
MOVE WS-PAGE-DIS TO O1-PAGE.
2400-PAGE-FORWARD-EXIT. EXIT.
2500-READ-CSULDPD.
MOVE SPACES TO WS-LDPD-FIELDS.
PERFORM 8110-OPEN-C1-CSULDPD THRU
8110-OPEN-C1-CSULDPD-EXIT.
MOVE 'Y' TO WS-CSULDPD-SWITCH.
PERFORM 2510-FORMAT-MOVE-CSULDPD THRU
2510-FORMAT-MOVE-CSULDPD-EXIT
UNTIL WS-NO-MORE-CSULDPD.
PERFORM 8510-CLOSE-C1-CSULDPD THRU
8510-CLOSE-C1-CSULDPD-EXIT.
2500-READ-CSULDPD-EXIT. EXIT.
2510-FORMAT-MOVE-CSULDPD.
EXEC SQL
FETCH C1-CSULDPD INTO
:HV-SP-PERIOD-TYPE,
:HV-SP-PERIOD
END-EXEC.
EVALUATE SQLCODE
WHEN 0
IF HV-SP-PERIOD-TYPE = 'DP'
MOVE HV-SP-PERIOD (5:4) TO WS-LDPD-TO-PC
END-IF
IF HV-SP-PERIOD-TYPE = 'ES'
MOVE HV-SP-PERIOD (5:4) TO WS-LDPD-PC-SAFETY
END-IF
IF HV-SP-PERIOD-TYPE = 'DL'
MOVE HV-SP-PERIOD (5:4) TO WS-LDPD-TO-LS
END-IF
IF HV-SP-PERIOD-TYPE = 'IS'
MOVE HV-SP-PERIOD (5:4) TO WS-LDPD-LS-SAFETY
END-IF
IF HV-SP-PERIOD-TYPE = 'IK'
MOVE HV-SP-PERIOD (1:6) TO WS-LDPD-INTKBN
END-IF
WHEN 100
MOVE 'N' TO WS-CSULDPD-SWITCH
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'DB2 ERROR PREREAD FETCH CSULDPD'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
2510-FORMAT-MOVE-CSULDPD-EXIT. EXIT.
*-----------> COMMENTS
*
* THIS ROUTINE READS FROM THE INPUT AREA
* AND WRITES/FORMATS THE OUTPUT AREA
*
3000-MOVE-IN-TO-OUT.
MOVE I1-SUPP-1I TO O1-SUPP-1
MOVE I1-SUPP-2I TO O1-SUPP-2
MOVE I1-DOCKI TO O1-DOCK
MOVE I1-PARTNO-1 TO O1-PARTNO-1
MOVE I1-PARTNO-2 TO O1-PARTNO-2
MOVE I1-PARTNO-3 TO O1-PARTNO-3.
PERFORM VARYING I FROM 1 BY 1 UNTIL I > 13
MOVE I1-OPCODE(I) TO O1-OPCODE(I)
MOVE I1-PARTNO(I) TO O1-PARTNO(I)
MOVE I1-SUPP(I) TO O1-SUPP(I)
MOVE I2-DOCKI(I) TO O2-DOCK(I)
MOVE I1-TIMEFR(I) TO O1-TIMEFR(I)
MOVE I1-TIMETO(I) TO O1-TIMETO(I)
MOVE I1-TO-PC(I) TO O1-TO-PC(I)
MOVE I1-PC-SAFETY(I) TO O1-PC-SAFETY(I)
MOVE I1-TO-LS(I) TO O1-TO-LS(I)
MOVE I1-LS-SAFETY(I) TO O1-LS-SAFETY(I)
MOVE I1-INTKBN1(I) TO O1-INTKBN1(I)
MOVE I1-INTKBN2(I) TO O1-INTKBN2(I)
MOVE I1-INTKBN3(I) TO O1-INTKBN3(I)
MOVE I1-CALCBVSC(I) TO O1-CALCBVSC(I)
MOVE I1-SHIPDOCK(I) TO O1-SHIPDOCK(I)
IF I1-TO-PC(I) NOT EQUAL ' 0'
IF I1-TO-PC(I) GREATER THAN SPACES
INSPECT O1-TO-PC(I) REPLACING LEADING '0' BY ' '
END-IF
END-IF
IF I1-PC-SAFETY(I) NOT EQUAL ' 0'
IF I1-PC-SAFETY(I) GREATER THAN SPACES
INSPECT O1-PC-SAFETY(I) REPLACING LEADING '0' BY ' '
END-IF
END-IF
IF I1-TO-LS(I) NOT EQUAL ' 0'
IF I1-TO-LS(I) GREATER THAN SPACES
INSPECT O1-TO-LS(I) REPLACING LEADING '0' BY ' '
END-IF
END-IF
IF I1-LS-SAFETY(I) NOT EQUAL ' 0'
IF I1-LS-SAFETY(I) GREATER THAN SPACES
INSPECT O1-LS-SAFETY(I) REPLACING LEADING '0' BY ' '
END-IF
END-IF
IF I1-TO-PC(I) EQUAL '0000'
MOVE ' 0' TO O1-TO-PC(I)
END-IF
IF I1-PC-SAFETY(I) EQUAL '0000'
MOVE ' 0' TO O1-PC-SAFETY(I)
END-IF
IF I1-TO-LS(I) EQUAL '0000'
MOVE ' 0' TO O1-TO-LS(I)
END-IF
IF I1-LS-SAFETY(I) EQUAL '0000'
MOVE ' 0' TO O1-LS-SAFETY(I)
END-IF
END-PERFORM.
MOVE I1-HIDE-BEI TO O1-HIDE-BE.
MOVE I1-HIDE-USERI TO O1-HIDE-USER.
MOVE I1-NEWKEYI TO O1-NEWKEY.
3000-MOVE-IN-TO-OUT-EXIT. EXIT.
*-----------> COMMENTS
*
* ROUTINE TO SEND THE SCREEN AND RETURN TO IMS
*
3500-SEND-MSG-AND-RETURN.
MOVE SPACES TO O1-NEWKEY.
IF I1-SUPP-1I > SPACES
STRING I1-SUPP-1I, I1-SUPP-2I, I1-DOCKI
DELIMITED BY SIZE INTO O1-NEWKEY.
MOVE I1-INQFUN TO O1-INQFUN.
IF A-ERR > 1
MOVE HI-LIGHT-MSG TO O1-CMNT
END-IF.
IF O1-FUNC = 'F' OR 'B' OR 'X'
MOVE SPACES TO O1-FUNC
END-IF.
IF M-INQ-COMPLETED = O1-CMNT
MOVE ATR-CURSR TO O1-FUNCA
END-IF.
IF O1-CMNT = SPACES
MOVE PFKEY-MSG TO O1-CMNT
END-IF.
MOVE 'PRUX020 ' TO WS-IO-MOD-X
MOVE 1379 TO O1-LL.
MOVE 0 TO O1-ZZ.
CALL 'CBLTDLI' USING ISRT,
IO-PCBMASK,
O1-AREA,
WS-IO-MOD-X
GOBACK.
3500-SEND-MSG-AND-RETURN-EXIT. EXIT.
*-------------> COMMENTS
*
* THIS ROUTINE VALIDATES A FOUR DIGIT ALPHA FIELD
* FOR NUMERIC VALUES AND REFORMATS
*
7000-CONVERT.
MOVE SPACES TO ERROR-CODE.
INSPECT CONVT-NUMBER REPLACING LEADING SPACES BY ZEROS
IF PARSE-NUM-1 NUMERIC AND PARSE-NUM-2 NUMERIC AND
PARSE-NUM-3 NUMERIC
IF PARSE-NUM-4 EQUAL SPACES OR LOW-VALUE
MOVE PARSE-NUM-3 TO PARSE-NUM-4
MOVE PARSE-NUM-2 TO PARSE-NUM-3
MOVE PARSE-NUM-1 TO PARSE-NUM-2
MOVE ZERO TO PARSE-NUM-1.
IF PARSE-NUM-2 NUMERIC AND PARSE-NUM-3 NUMERIC AND
PARSE-NUM-4 NUMERIC
IF PARSE-NUM-1 EQUAL SPACES OR LOW-VALUE
MOVE ZERO TO PARSE-NUM-1.
IF PARSE-NUM-3 NUMERIC AND PARSE-NUM-4 NUMERIC
IF PARSE-NUM-1 EQUAL SPACES OR LOW-VALUE
IF PARSE-NUM-2 EQUAL SPACES OR LOW-VALUE
MOVE ZERO TO PARSE-NUM-2
MOVE ZERO TO PARSE-NUM-1.
IF PARSE-NUM-1 NUMERIC AND PARSE-NUM-2 NUMERIC
IF PARSE-NUM-3 EQUAL SPACES OR LOW-VALUE
IF PARSE-NUM-4 EQUAL SPACES OR LOW-VALUE
MOVE PARSE-NUM-2 TO PARSE-NUM-4
MOVE PARSE-NUM-1 TO PARSE-NUM-3
MOVE ZERO TO PARSE-NUM-2
MOVE ZERO TO PARSE-NUM-1.
IF PARSE-NUM-1 NUMERIC
IF PARSE-NUM-2 EQUAL SPACES OR LOW-VALUE
IF PARSE-NUM-3 EQUAL SPACES OR LOW-VALUE
IF PARSE-NUM-4 EQUAL SPACES OR LOW-VALUE
MOVE PARSE-NUM-1 TO PARSE-NUM-4
MOVE ZERO TO PARSE-NUM-3
MOVE ZERO TO PARSE-NUM-2
MOVE ZERO TO PARSE-NUM-1.
IF PARSE-NUM-2 NUMERIC
IF PARSE-NUM-1 EQUAL SPACES OR LOW-VALUE
IF PARSE-NUM-3 EQUAL SPACES OR LOW-VALUE
IF PARSE-NUM-4 EQUAL SPACES OR LOW-VALUE
MOVE PARSE-NUM-2 TO PARSE-NUM-4
MOVE ZERO TO PARSE-NUM-3
MOVE ZERO TO PARSE-NUM-2
MOVE ZERO TO PARSE-NUM-1.
IF PARSE-NUM-3 NUMERIC
IF PARSE-NUM-1 EQUAL SPACES OR LOW-VALUE
IF PARSE-NUM-2 EQUAL SPACES OR LOW-VALUE
IF PARSE-NUM-4 EQUAL SPACES OR LOW-VALUE
MOVE PARSE-NUM-3 TO PARSE-NUM-4
MOVE ZERO TO PARSE-NUM-3
MOVE ZERO TO PARSE-NUM-2
MOVE ZERO TO PARSE-NUM-1.
IF PARSE-NUM-4 NUMERIC
IF PARSE-NUM-1 EQUAL SPACES OR LOW-VALUE
IF PARSE-NUM-2 EQUAL SPACES OR LOW-VALUE
IF PARSE-NUM-3 EQUAL SPACES OR LOW-VALUE
MOVE ZERO TO PARSE-NUM-3
MOVE ZERO TO PARSE-NUM-2
MOVE ZERO TO PARSE-NUM-1.
IF PARSE-NUM-2 NUMERIC
IF PARSE-NUM-3 NUMERIC
IF PARSE-NUM-1 EQUAL SPACES OR LOW-VALUE
IF PARSE-NUM-4 EQUAL SPACES OR LOW-VALUE
MOVE PARSE-NUM-3 TO PARSE-NUM-4
MOVE PARSE-NUM-2 TO PARSE-NUM-3
MOVE ZERO TO PARSE-NUM-2
MOVE ZERO TO PARSE-NUM-1.
IF CONVT-NUMBER NUMERIC
MOVE CONVT-NUMBER TO FIXED-NUMBER
ELSE
MOVE 'Y' TO ERROR-CODE
END-IF.
7000-CONVERT-EXIT. EXIT.
*-------------> COMMENTS
*
* THIS ROUTINE LEFT SHIFTS ALPHAMERIC VALUES AND
* VALIDATES THEM EQUAL TO (A-Z, 0-9)
*
* ERROR-CODE = E FOR ERROR, SPACE IF VALID
7100-SHIFT.
MOVE SPACES TO ERROR-CODE.
IF WS-SHIPDOCK-1-VALID AND
WS-SHIPDOCK-2-VALID AND
WS-SHIPDOCK-3-VALID
GO TO 7100-SHIFT-EXIT.
IF WS-SHIPDOCK-1-VALID AND
WS-SHIPDOCK-2 EQUAL SPACES AND
WS-SHIPDOCK-3 EQUAL SPACES
GO TO 7100-SHIFT-EXIT.
IF WS-SHIPDOCK-2-VALID AND
WS-SHIPDOCK-1 EQUAL SPACES AND
WS-SHIPDOCK-3 EQUAL SPACES
MOVE WS-SHIPDOCK-2 TO WS-SHIPDOCK-1
MOVE SPACES TO WS-SHIPDOCK-2
GO TO 7100-SHIFT-EXIT.
IF WS-SHIPDOCK-3-VALID AND
WS-SHIPDOCK-1 EQUAL SPACES AND
WS-SHIPDOCK-2 EQUAL SPACES
MOVE WS-SHIPDOCK-3 TO WS-SHIPDOCK-1
MOVE SPACES TO WS-SHIPDOCK-3
GO TO 7100-SHIFT-EXIT.
IF WS-SHIPDOCK-1-VALID AND
WS-SHIPDOCK-3-VALID AND
WS-SHIPDOCK-2 EQUAL SPACES
MOVE WS-SHIPDOCK-3 TO WS-SHIPDOCK-2
MOVE SPACES TO WS-SHIPDOCK-3
GO TO 7100-SHIFT-EXIT.
IF WS-SHIPDOCK-2-VALID AND
WS-SHIPDOCK-3-VALID AND
WS-SHIPDOCK-1 EQUAL SPACES
MOVE WS-SHIPDOCK-2 TO WS-SHIPDOCK-1
MOVE WS-SHIPDOCK-3 TO WS-SHIPDOCK-2
MOVE SPACES TO WS-SHIPDOCK-3
GO TO 7100-SHIFT-EXIT.
IF WS-SHIPDOCK-1-VALID AND
WS-SHIPDOCK-2-VALID AND
WS-SHIPDOCK-3 EQUAL SPACES
GO TO 7100-SHIFT-EXIT.
IF NOT WS-SHIPDOCK-1-VALID
MOVE 'E' TO ERROR-CODE
GO TO 7100-SHIFT-EXIT.
IF NOT WS-SHIPDOCK-2-VALID
MOVE 'E' TO ERROR-CODE
GO TO 7100-SHIFT-EXIT.
IF NOT WS-SHIPDOCK-3-VALID
MOVE 'E' TO ERROR-CODE
GO TO 7100-SHIFT-EXIT.
MOVE 'E' TO ERROR-CODE.
7100-SHIFT-EXIT. EXIT.
7200-INSERT-PRUAUDT.
MOVE +50 TO KEY-FEEDBACK-LEN.
MOVE +50 TO COMMENTS-LEN
MOVE +192 TO NEW-VALUE-LEN.
MOVE HV-AU-KEY-FEEDBACK TO KEY-FEEDBACK-TEXT
MOVE HV-AU-COMMENTS TO COMMENTS-TEXT
MOVE HV-AU-NEW-VALUE TO NEW-VALUE-TEXT
EXEC SQL
INSERT INTO PRUAUDT
(DATETIME,
STORAGE_TYPE,
STORAGE_ID,
STORAGE_ELEMENT,
USERID,
TRANSACTION,
TERMINAL,
FUNCTION,
KEY_FEEDBACK,
COMMENTS,
NEW_VALUE)
VALUES (CURRENT TIMESTAMP,
'D',
:HV-AU-STORAGE-ID,
:HV-AU-STORAGE-ELEMENT,
:WS-IO-USER-ID,
'PRUPKRS ',
:WS-IO-TERMINAL,
:HV-AU-FUNCTION,
:KEY-FEEDBACK,
:WS-COMMENTS:COMMENTS-NI,
:NEW-VALUE:HV-AU-NEW-VALUE-NI)
END-EXEC.
IF SQLCODE = 0
CONTINUE
ELSE
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'DB2 ERROR INSERTING PRUAUDT'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3000-MOVE-IN-TO-OUT THRU
3000-MOVE-IN-TO-OUT-EXIT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-IF.
7200-INSERT-PRUAUDT-EXIT. EXIT.
7300-MOVE-REFORMAT.
MOVE SPACES TO O1-PARTNO(I)
STRING HV-PM-ITEMID (1:5) '-'
HV-PM-ITEMID (6:5) '-'
HV-PM-ITEMID (11:2)
DELIMITED BY SIZE INTO O1-PARTNO(I)
MOVE SPACES TO O1-SUPP(I)
STRING HV-PM-CUSTOMER-SUPP (3:4) '-'
HV-PM-CUSTOMER-SUPP (7:1)
DELIMITED BY SIZE INTO O1-SUPP(I)
MOVE HV-PM-LOCATION (1:2) TO O2-DOCK(I)
MOVE HV-PM-EFF-START TO WS-WORK-DATE.
MOVE WS-WORK-DATE-CCYY TO WS-CCYY-DATE.
MOVE WS-WORK-DATE-MM TO WS-MM-DATE.
MOVE WS-WORK-DATE-DD TO WS-DD-DATE.
MOVE WS-YYMMDD TO O1-TIMEFR(I).
IF NI-EFF-STOP LESS THAN ZERO
MOVE SPACES TO O1-TIMETO(I)
MOVE SPACES TO HV-PM-EFF-STOP
ELSE
MOVE HV-PM-EFF-STOP TO WS-WORK-DATE
MOVE WS-WORK-DATE-CCYY TO WS-CCYY-DATE
MOVE WS-WORK-DATE-MM TO WS-MM-DATE
MOVE WS-WORK-DATE-DD TO WS-DD-DATE
MOVE WS-YYMMDD TO O1-TIMETO(I)
END-IF.
IF NI-CATEGORY LESS THAN ZERO
MOVE ' ' TO O1-CALCBVSC(I)
ELSE
IF HV-PM-CATEGORY > SPACES
IF HV-PM-CATEGORY EQUAL 'CALCBVSC'
MOVE 'Y' TO O1-CALCBVSC(I)
END-IF
IF HV-PM-CATEGORY EQUAL 'NOCALCBC'
MOVE 'N' TO O1-CALCBVSC(I)
END-IF
END-IF
END-IF.
PERFORM 7600-CSULOCD-READ THRU
7600-CSULOCD-READ-EXIT
IF NI-SHIPPING-LOCATION LESS THAN ZERO or
HV-PM-SHIPPING-LOCATION EQUAL SPACES
MOVE WS-CSULOCD-SHIPPING-LOCATION
TO O1-SHIPDOCK(I)
ELSE
MOVE ATR-NORM TO O1-SHIPDOCKA(I)
MOVE HV-PM-SHIPPING-LOCATION (1:3)
TO O1-SHIPDOCK(I)
END-IF.
7300-MOVE-REFORMAT-EXIT. EXIT.
7400-PROCESS-PRUKBPD.
PERFORM 8100-OPEN-C1-PRUKBPD THRU
8100-OPEN-C1-PRUKBPD-EXIT.
MOVE 'Y' TO WS-PRUKBPD-SWITCH.
MOVE 'N' TO WS-FOUND-IK,
WS-FOUND-ES,
WS-FOUND-IS,
WS-FOUND-DL,
WS-FOUND-DP.
PERFORM 7410-FORMAT-MOVE-PRUKBPD THRU
7410-FORMAT-MOVE-PRUKBPD-EXIT
UNTIL WS-NO-MORE-PRUKBPD.
PERFORM 8500-CLOSE-C1-PRUKBPD THRU
8500-CLOSE-C1-PRUKBPD-EXIT.
7400-PROCESS-PRUKBPD-EXIT. EXIT.
7410-FORMAT-MOVE-PRUKBPD.
EXEC SQL
FETCH C1-PRUKBPD INTO
:HV-PP-PERIOD-TYPE,
:HV-PP-PERIOD:HV-NI-PERIOD
END-EXEC.
IF HV-NI-PERIOD LESS THAN ZERO
MOVE SPACES TO HV-PP-PERIOD.
EVALUATE SQLCODE
WHEN 0
IF HV-PP-PERIOD-TYPE = 'IK'
MOVE HV-PP-PERIOD (1:2) TO O1-INTKBN1(I)
MOVE HV-PP-PERIOD (3:2) TO O1-INTKBN2(I)
MOVE HV-PP-PERIOD (5:2) TO O1-INTKBN3(I)
MOVE 'Y' TO WS-FOUND-IK
END-IF
IF HV-PP-PERIOD-TYPE = 'ES'
MOVE HV-PP-PERIOD (5:4) TO O1-PC-SAFETY-N(I)
MOVE 'Y' TO WS-FOUND-ES
END-IF
IF HV-PP-PERIOD-TYPE = 'IS'
MOVE HV-PP-PERIOD (5:4) TO O1-LS-SAFETY-N(I)
MOVE 'Y' TO WS-FOUND-IS
END-IF
IF HV-PP-PERIOD-TYPE = 'DL'
MOVE HV-PP-PERIOD (5:4) TO O1-TO-LS-N(I)
MOVE 'Y' TO WS-FOUND-DL
END-IF
IF HV-PP-PERIOD-TYPE = 'DP'
MOVE HV-PP-PERIOD (5:4) TO O1-TO-PC-N(I)
MOVE 'Y' TO WS-FOUND-DP
END-IF
WHEN 100
MOVE 'N' TO WS-PRUKBPD-SWITCH
IF WS-NOT-FOUND-IK
MOVE SPACES TO O1-INTKBN1(I)
MOVE SPACES TO O1-INTKBN2(I)
MOVE SPACES TO O1-INTKBN3(I)
IF WS-CSULOCD-FOUND EQUAL 'Y'
MOVE 'IK' TO WS-PARAMETER
PERFORM 7415-READ-CSULDPD THRU
7415-READ-CSULDPD-EXIT
END-IF
END-IF
IF WS-NOT-FOUND-ES
MOVE SPACES TO O1-PC-SAFETY(I)
IF WS-CSULOCD-FOUND EQUAL 'Y'
MOVE 'ES' TO WS-PARAMETER
PERFORM 7415-READ-CSULDPD THRU
7415-READ-CSULDPD-EXIT
END-IF
END-IF
IF WS-NOT-FOUND-IS
MOVE SPACES TO O1-LS-SAFETY(I)
IF WS-CSULOCD-FOUND EQUAL 'Y'
MOVE 'IS' TO WS-PARAMETER
PERFORM 7415-READ-CSULDPD THRU
7415-READ-CSULDPD-EXIT
END-IF
END-IF
IF WS-NOT-FOUND-DL
MOVE SPACES TO O1-TO-LS(I)
IF WS-CSULOCD-FOUND EQUAL 'Y'
MOVE 'DL' TO WS-PARAMETER
PERFORM 7415-READ-CSULDPD THRU
7415-READ-CSULDPD-EXIT
END-IF
END-IF
IF WS-NOT-FOUND-DP
MOVE SPACES TO O1-TO-PC(I)
IF WS-CSULOCD-FOUND EQUAL 'Y'
MOVE 'DP' TO WS-PARAMETER
PERFORM 7415-READ-CSULDPD THRU
7415-READ-CSULDPD-EXIT
END-IF
END-IF
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'DB2 ERROR FETCH PRUKBPD'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
7410-FORMAT-MOVE-PRUKBPD-EXIT. EXIT.
*-----------> COMMENTS
*
* NOTE THAT WHEN SCREEN FIELDS ARE POPULATED FROM
* THIS TABLE THAT THEY ARE HIGHLIGHTED ON THE SCREEN.
* THIS IS NOT INDICATIVE OF AN ERROR CONDITION, BUT
* OF THE SOURCE FOR THE DATA ONLY
*
7415-READ-CSULDPD.
EXEC SQL
SELECT PERIOD
INTO :HV-SP-PERIOD
FROM CSULDPD
WHERE BUSINESS_ENTITY = :I1-HIDE-BEI
AND CSI_TYPE = 'SU'
AND CUSTOMER_SUPP = :HV-PM-CUSTOMER-SUPP
AND LOCATION = :HV-PM-LOCATION
AND EFF_START = :HV-SM-EFF-START
AND PERIOD_TYPE = :WS-PARAMETER
END-EXEC.
EVALUATE SQLCODE
WHEN 0
IF WS-PARAMETER = 'IK'
MOVE HV-SP-PERIOD (1:2) TO O1-INTKBN1(I)
MOVE HV-SP-PERIOD (3:2) TO O1-INTKBN2(I)
MOVE HV-SP-PERIOD (5:2) TO O1-INTKBN3(I)
MOVE ATR-BRT-MOD TO O1-INTKBN1A(I)
MOVE ATR-BRT-MOD TO O1-INTKBN2A(I)
MOVE ATR-BRT-MOD TO O1-INTKBN3A(I)
END-IF
IF WS-PARAMETER = 'ES'
MOVE HV-SP-PERIOD (5:4) TO O1-PC-SAFETY-N(I)
MOVE ATR-BRT-MOD TO O1-PC-SAFETYA(I)
END-IF
IF WS-PARAMETER = 'IS'
MOVE HV-SP-PERIOD (5:4) TO O1-LS-SAFETY-N(I)
MOVE ATR-BRT-MOD TO O1-LS-SAFETYA(I)
END-IF
IF WS-PARAMETER = 'DL'
MOVE HV-SP-PERIOD (5:4) TO O1-TO-LS-N(I)
MOVE ATR-BRT-MOD TO O1-TO-LSA(I)
END-IF
IF WS-PARAMETER = 'DP'
MOVE HV-SP-PERIOD (5:4) TO O1-TO-PC-N(I)
MOVE ATR-BRT-MOD TO O1-TO-PCA(I)
END-IF
WHEN 100
CONTINUE
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'DB2 ERROR SELECT ON CSULDPD'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3000-MOVE-IN-TO-OUT THRU
3000-MOVE-IN-TO-OUT-EXIT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
7415-READ-CSULDPD-EXIT. EXIT.
*-------------> COMMENTS
*
* THIS ROUTINE EXITS THIS TRANSACTION AND STARTS
* ANOTHER PASSING KEY VALUES
*
7500-SWAP-RTN.
MOVE SPACES TO WS-PART
WS-DOCK
WS-SUPP.
STRING I1-SUPP-1I,
I1-SUPP-2I
DELIMITED BY SIZE INTO
WS-SUPP.
STRING I1-PARTNO-1,
I1-PARTNO-2,
I1-PARTNO-3,
DELIMITED BY SIZE INTO
WS-PART.
MOVE I1-DOCKI TO WS-DOCK.
PERFORM VARYING I FROM 1 BY 1 UNTIL I > 13
IF I1-OPCODE(I) = 'S'
MOVE SPACES TO WS-PART
WS-DOCK
WS-SUPP
STRING I1-SUPP(I)(1:4),
I1-SUPP(I)(6:1)
DELIMITED BY SIZE INTO
WS-SUPP
STRING I1-PARTNO(I)(1:5),
I1-PARTNO(I)(7:5),
I1-PARTNO(I)(13:2),
DELIMITED BY SIZE INTO
WS-PART
MOVE I2-DOCKI(I) TO WS-DOCK
MOVE 14 TO I
END-IF
END-PERFORM.
IF I1-NEWTRNI > SPACES
IF I1-NEWTRNI(6:3) = SPACES
MOVE SPACES TO MSO-TRAN
STRING 'PRU' I1-NEWTRNI(1:5)
DELIMITED BY SIZE INTO MSO-TRAN
ELSE
MOVE SPACES TO MSO-TRAN
MOVE I1-NEWTRNI TO MSO-TRAN
END-IF
END-IF.
IF I1-NEWTRNI > SPACES
MOVE SPACES TO O1-NEWKEY
STRING WS-SUPP, WS-DOCK, WS-PART
DELIMITED BY SIZE INTO O1-NEWKEY
PERFORM 7550-CHANGE-TRXN
THRU 7550-CHANGE-TRXN-EXIT.
IF I1-FUNCI = 'K' OR I1-PARM = 'K'
MOVE 'PRUPMNT' TO O1-NEWTRN
MOVE O1-NEWTRN TO MSO-TRAN
MOVE WS-PART TO O1-NEWKEY
PERFORM 7550-CHANGE-TRXN
THRU 7550-CHANGE-TRXN-EXIT.
IF I1-FUNCI = 'T' OR I1-PARM = 'T'
MOVE 'PRUMHMN' TO O1-NEWTRN
MOVE O1-NEWTRN TO MSO-TRAN
MOVE SPACES TO O1-NEWKEY
STRING WS-SUPP, WS-DOCK, WS-PART
DELIMITED BY SIZE INTO O1-NEWKEY
PERFORM 7550-CHANGE-TRXN
THRU 7550-CHANGE-TRXN-EXIT.
IF I1-FUNCI = 'G' OR I1-PARM = 'G'
MOVE 'PRUAUDT' TO O1-NEWTRN
MOVE O1-NEWTRN TO MSO-TRAN
MOVE SPACES TO O1-NEWKEY
STRING WS-SUPP, WS-DOCK, WS-PART
DELIMITED BY SIZE INTO O1-NEWKEY
PERFORM 7550-CHANGE-TRXN
THRU 7550-CHANGE-TRXN-EXIT.
IF I1-FUNCI = 'E' OR I1-PARM = 'E'
MOVE 'PRUMENU' TO O1-NEWTRN
MOVE O1-NEWTRN TO MSO-TRAN
MOVE SPACES TO O1-NEWKEY
PERFORM 7550-CHANGE-TRXN
THRU 7550-CHANGE-TRXN-EXIT.
7500-SWAP-RTN-EXIT. EXIT.
7550-CHANGE-TRXN.
MOVE O1-NEWKEY TO MSO-KEY
MOVE 43 TO MSO-LL
MOVE 0 TO MSO-ZZ
CALL 'CBLTDLI' USING CHNG,
ALT-PCBMASK,
MSO-TRAN
EVALUATE ALT-STCD
WHEN SPACES
CALL 'CBLTDLI' USING ISRT,
ALT-PCBMASK,
MSO-MSG,
WS-SPACES-8
IF ALT-STCD = SPACES
GOBACK
END-IF
IF ALT-STCD NOT = SPACES
MOVE SPACES TO O1-CMNT
STRING 'STCD = ', ALT-STCD, ' '
M-SWITCH-ERROR-1 DELIMITED
BY SIZE INTO O1-CMNT
ADD 1 TO A-ERR
END-IF
WHEN 'A1'
MOVE ATR-BRT-CURSR-MOD TO O1-NEWTRNA
MOVE MSO-TRAN TO M-SWITCH-TXN
MOVE M-SWITCH-ERROR-2 TO O1-CMNT
ADD 1 TO A-ERR
WHEN 'A4'
MOVE ATR-BRT-CURSR-MOD TO O1-NEWTRNA
IF IO-USER-ID = IO-TERMINAL
MOVE M-SIGNON-ERROR TO O1-CMNT
ELSE
MOVE MSO-TRAN TO M-TXN-AUTH
MOVE M-NOT-AUTH TO O1-CMNT
END-IF
ADD 1 TO A-ERR
WHEN OTHER
MOVE ATR-BRT-CURSR-MOD TO O1-NEWTRNA
MOVE SPACES TO O1-CMNT
STRING M-SWITCH-ERROR-1, ALT-STCD
DELIMITED BY SIZE INTO O1-CMNT
ADD 1 TO A-ERR
END-EVALUATE.
7550-CHANGE-TRXN-EXIT. EXIT.
7600-CSULOCD-READ.
MOVE HV-PM-LOCATION TO WS-LOCATION.
*--> ACTIVE PART
IF (HV-PM-EFF-START NOT GREATER THAN WS-CURRENT-DATE) AND
(HV-PM-EFF-STOP >= WS-CURRENT-DATE OR
HV-PM-EFF-STOP = SPACES)
MOVE WS-CURRENT-DATE TO WS-DATE
ELSE
*--> FUTURE PART
IF HV-PM-EFF-START > WS-CURRENT-DATE
MOVE HV-PM-EFF-START TO WS-DATE
ELSE
*--> OBSOLETE PART
MOVE HV-PM-EFF-STOP TO WS-DATE
END-IF
END-IF.
EXEC SQL
SELECT EFF_START,
SHIPPING_LOCATION
INTO :HV-SM-EFF-START,
:HV-SM-SHIPPING-LOCATION:NI-SM-SHIPPING-LOCATION
FROM CSULOCD
WHERE BUSINESS_ENTITY = :I1-HIDE-BEI
AND CSI_TYPE = 'SU'
AND CUSTOMER_SUPP = :HV-PM-CUSTOMER-SUPP
AND LOCATION = :WS-LOCATION
AND EFF_START <= :WS-DATE
AND (EFF_STOP >= :WS-DATE OR
EFF_STOP IS NULL)
END-EXEC.
MOVE 'N' TO WS-CSULOCD-FOUND.
EVALUATE SQLCODE
WHEN 0
MOVE 'Y' TO WS-CSULOCD-FOUND
IF NI-SM-SHIPPING-LOCATION LESS THAN ZERO
MOVE SPACES TO
WS-CSULOCD-SHIPPING-LOCATION
MOVE ATR-NORM TO O1-SHIPDOCKA(I)
ELSE
*---> NOTE FIELD IS HIGHLIGHTED IF COMING FROM
* THIS TABLE, OTHERWISE NORMAL INTENSITY
MOVE HV-SM-SHIPPING-LOCATION (1:3) TO
WS-CSULOCD-SHIPPING-LOCATION
MOVE ATR-BRT-MOD TO O1-SHIPDOCKA(I)
END-IF
WHEN 100
MOVE SPACES TO WS-CSULOCD-SHIPPING-LOCATION
MOVE ATR-NORM TO O1-SHIPDOCKA(I)
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'DB2 ERROR READING CSULOCD'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3000-MOVE-IN-TO-OUT THRU
3000-MOVE-IN-TO-OUT-EXIT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
7600-CSULOCD-READ-EXIT. EXIT.
7725-ADD-PRUKBPD.
EXEC SQL
INSERT INTO PRUKBPD
(BUSINESS_ENTITY,
TYPE,
CSI_TYPE,
CUSTOMER_SUPP,
LOCATION,
ITEMID,
EFF_START,
PERIOD_TYPE,
DATE_TIME,
USERID,
PERIOD
)
VALUES
(:I1-HIDE-BEI,
'CD',
'SU',
:HV-PM-CUSTOMER-SUPP,
:HV-PM-LOCATION,
:HV-PM-ITEMID,
:HV-PM-EFF-START,
:HV-PP-PERIOD-TYPE,
CURRENT TIMESTAMP,
:WS-IO-USER-ID,
:HV-PP-PERIOD
)
END-EXEC.
IF SQLCODE = 0
CONTINUE
ELSE
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'DB2 ERROR INSERTING PRUKBPD'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3000-MOVE-IN-TO-OUT THRU
3000-MOVE-IN-TO-OUT-EXIT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-IF.
7725-ADD-PRUKBPD-EXIT. EXIT.
7750-DELETE-PRUKBPD.
EXEC SQL
DELETE FROM PRUKBPD
WHERE BUSINESS_ENTITY = :I1-HIDE-BEI AND
TYPE = 'CD' AND
CSI_TYPE = 'SU' AND
CUSTOMER_SUPP = :HV-PM-CUSTOMER-SUPP AND
LOCATION = :HV-PM-LOCATION AND
ITEMID = :HV-PM-ITEMID AND
EFF_START = :HV-PM-EFF-START AND
PERIOD_TYPE = :HV-PP-PERIOD-TYPE
END-EXEC.
IF SQLCODE = 0
CONTINUE
ELSE
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'DB2 ERROR DELETING PRUKBPD'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3000-MOVE-IN-TO-OUT THRU
3000-MOVE-IN-TO-OUT-EXIT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-IF.
7750-DELETE-PRUKBPD-EXIT. EXIT.
7775-UPDATE-PRUKBPD.
EXEC SQL
UPDATE PRUKBPD
SET DATE_TIME = CURRENT_TIMESTAMP,
USERID = :WS-IO-USER-ID,
PERIOD = :HV-PP-PERIOD
WHERE BUSINESS_ENTITY = :I1-HIDE-BEI AND
TYPE = 'CD' AND
CSI_TYPE = 'SU' AND
CUSTOMER_SUPP = :HV-PM-CUSTOMER-SUPP AND
LOCATION = :HV-PM-LOCATION AND
ITEMID = :HV-PM-ITEMID AND
EFF_START = :HV-PM-EFF-START AND
PERIOD_TYPE = :HV-PP-PERIOD-TYPE
END-EXEC.
IF SQLCODE = 0
CONTINUE
ELSE
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'DB2 ERROR UPDATING PRUKBPD'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3000-MOVE-IN-TO-OUT THRU
3000-MOVE-IN-TO-OUT-EXIT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-IF.
7775-UPDATE-PRUKBPD-EXIT. EXIT.
*---------------> COMMENTS
*
* OPEN AND CLOSE CURSOR PROCESSING
*
8000-OPEN-F1-PRUKANB-SUPP.
EXEC SQL
OPEN F1-PRUKANB-SUPP
END-EXEC.
EVALUATE SQLCODE
WHEN 0
CONTINUE
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'BAD OPEN ON F1-PRUKANB-SUPP'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
8000-OPEN-F1-PRUKANB-SUPP-EXIT. EXIT.
8150-OPEN-B1-PRUKANB-SUPP.
EXEC SQL
OPEN B1-PRUKANB-SUPP
END-EXEC.
EVALUATE SQLCODE
WHEN 0
CONTINUE
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'BAD OPEN ON B1-PRUKANB-SUPP'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
8150-OPEN-B1-PRUKANB-SUPP-EXIT. EXIT.
8100-OPEN-C1-PRUKBPD.
EXEC SQL
OPEN C1-PRUKBPD
END-EXEC.
EVALUATE SQLCODE
WHEN 0
CONTINUE
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'BAD OPEN ON C1-PRUKBPD'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
8100-OPEN-C1-PRUKBPD-EXIT. EXIT.
8110-OPEN-C1-CSULDPD.
EXEC SQL
OPEN C1-CSULDPD
END-EXEC.
EVALUATE SQLCODE
WHEN 0
CONTINUE
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'BAD OPEN ON C1-CSULDPD'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
8110-OPEN-C1-CSULDPD-EXIT. EXIT.
8200-OPEN-F1-PRUKANB-PART.
EXEC SQL
OPEN F1-PRUKANB-PART
END-EXEC.
EVALUATE SQLCODE
WHEN 0
CONTINUE
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'BAD OPEN ON F1-PRUKANB-PART'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
8200-OPEN-F1-PRUKANB-PART-EXIT. EXIT.
8250-OPEN-B1-PRUKANB-PART.
EXEC SQL
OPEN B1-PRUKANB-PART
END-EXEC.
EVALUATE SQLCODE
WHEN 0
CONTINUE
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'BAD OPEN ON B1-PRUKANB-PART'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
8250-OPEN-B1-PRUKANB-PART-EXIT. EXIT.
8300-CLOSE-F1-PRUKANB-SUPP.
EXEC SQL
CLOSE F1-PRUKANB-SUPP
END-EXEC.
EVALUATE SQLCODE
WHEN 0
CONTINUE
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'BAD CLOSE ON F1-PRUKANB-SUPP'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
8300-CLOSE-F1-PRUKANB-S-EXIT. EXIT.
8350-CLOSE-B1-PRUKANB-SUPP.
EXEC SQL
CLOSE B1-PRUKANB-SUPP
END-EXEC.
EVALUATE SQLCODE
WHEN 0
CONTINUE
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'BAD CLOSE ON B1-PRUKANB-SUPP'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
8350-CLOSE-B1-PRUKANB-S-EXIT. EXIT.
8400-CLOSE-F1-PRUKANB-PART.
EXEC SQL
CLOSE F1-PRUKANB-PART
END-EXEC.
EVALUATE SQLCODE
WHEN 0
CONTINUE
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'BAD CLOSE ON F1-PRUKANB-PART'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
8400-CLOSE-F1-PRUKANB-P-EXIT. EXIT.
8450-CLOSE-B1-PRUKANB-PART.
EXEC SQL
CLOSE B1-PRUKANB-PART
END-EXEC.
EVALUATE SQLCODE
WHEN 0
CONTINUE
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'BAD CLOSE ON B1-PRUKANB-PART'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
8450-CLOSE-B1-PRUKANB-P-EXIT. EXIT.
*************************************************************
* CLOSE C2 PRUKBPD CURSOR *
*************************************************************
8500-CLOSE-C1-PRUKBPD.
EXEC SQL
CLOSE C1-PRUKBPD
END-EXEC.
EVALUATE SQLCODE
WHEN 0
CONTINUE
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'BAD CLOSE ON C1-PRUKBPD'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
8500-CLOSE-C1-PRUKBPD-EXIT. EXIT.
8510-CLOSE-C1-CSULDPD.
EXEC SQL
CLOSE C1-CSULDPD
END-EXEC.
EVALUATE SQLCODE
WHEN 0
CONTINUE
WHEN OTHER
MOVE SPACES TO O1-CMNT
MOVE SQLCODE TO DIS-SQL
STRING 'BAD CLOSE ON C1-CSULDPD'
', SQLCODE = ' DIS-SQL DELIMITED
BY SIZE INTO O1-CMNT
PERFORM 3500-SEND-MSG-AND-RETURN
THRU 3500-SEND-MSG-AND-RETURN-EXIT
END-EVALUATE.
8510-CLOSE-C1-CSULDPD-EXIT. EXIT.
END PROGRAM PRUM020.
0