📄 afcpo5.txt
字号:
INITIALIZE MQ-INPUT
* GET ACCOUNTING WAYBILL ID
PERFORM U-100-READ-CAF00RBR
IF DA-OK
* GET THIRD PARTY CUST 333
MOVE 'PF' TO R39-CUST-TYP-CD
PERFORM U-100-READ-CAF00R39
MOVE R39-CUST-633 TO MQ-TP-633
* GET RULE 11 CUST 333
MOVE '11' TO R39-CUST-TYP-CD
PERFORM U-100-READ-CAF00R39
MOVE R39-CUST-633 TO MQ-RULE-11-633
END-IF
* POPULATE RPMS DATA
MOVE CGB-EFF-DT TO MQ-EFF-DT
MOVE CGB-EXP-DT TO MQ-EXP-DT
MOVE CGB-ISU-CARR-PA-ID TO MQ-ISS-CARR
MOVE CGB-PA-ID TO MQ-PA-ID
MOVE CGB-ITEM-N TO MQ-ITEM-N
MOVE CGB-PA-N TO MQ-PA-N
IF CGB-PRC-PKG-N > ZEROES
MOVE CGB-PRC-PKG-N TO TMP-PRC-PKG-N
MOVE TMP-PRC-PKG-N TO MQ-PRC-PKG-N
ELSE
MOVE SPACES TO MQ-PRC-PKG-N
END-IF
IF CGB-REN-PA-N > ZEROES
MOVE CGB-REN-PA-N TO TMP-REN-PA-N
MOVE TMP-REN-PA-N TO MQ-REN-PA-N
ELSE
MOVE SPACES TO MQ-REN-PA-N
END-IF
MOVE 'EPS' TO MQ-APPL-CD
MOVE CGB-CUST-633-SHPR TO MQ-SHPR-633
MOVE CGB-CUST-633-CNSG TO MQ-CNSG-633
MOVE CGB-ORIG-333 TO MQ-ORIG-CITY
MOVE CGB-ORIG-ST TO MQ-ORIG-ST
MOVE CGB-DEST-333 TO MQ-DEST-CITY
MOVE CGB-DEST-ST TO MQ-DEST-ST
MOVE CGB-STCC-NUMBER TO MQ-STCC-NUMB
MOVE CGB-PRC-AUTH-ID TO MQ-PRC-AUTH
MOVE CGB-EQP-INIT TO MQ-EQP-INIT
INITIALIZE IDX
INSPECT CGB-EQP-NUMB TALLYING IDX
FOR LEADING SPACES
MOVE CGB-EQP-NUMB(IDX + 1 :) TO MQ-EQP-NUMB
MOVE CGB-BGN-RPC-DT TO MQ-BGN-RPC-DT
MOVE CGB-BGN-RPC-TM TO MQ-BGN-RPC-TM
INSPECT MQ-BGN-RPC-TM REPLACING ALL "." BY ":"
MOVE CGB-POT-OVRPMT-CD TO MQ-OVR-PMT-CD
MOVE CGB-FGN-SYS-CD TO MQ-FGN-SYS-CD
.
Z-100-EXIT.
EXIT.
Z-200-WRITE-MSG.
INITIALIZE IC-SEND-AREA
IC-API-AREA
IC-BUF
IC-RTN-CDE
IC-RSN-CDE
MOVE 'INITAREQ' TO IC-OPTION-TYPE
MOVE WFMS500B TO IC-REQUEST-TYPE
MOVE 'CAS00000' TO IC-APP-RTN-CODE
MOVE 'CASCBRRV' TO I-PROCESS-NAME
MOVE 'CASCBRRV' TO IC-ACTIVITY-NAME
MOVE 'AFCPO5' TO IC-USER-ID
MOVE ZEROES TO IC-MQ-I-MSG-PRIORITY
IC-MQ-I-BUFFER-TYPE
IC-MQ-O-MSG-PRIORITY
IC-MQ-O-OBJ-HANDLE
IC-MQ-I-BUFFER-TYPE
MOVE WS-MESSAGE TO IC-USER-DATA
COMPUTE IC-BUF-LEN = WS-STRPTR + 200
CALL WFMS500B USING IC-SEND-AREA
IC-API-AREA
IC-BUF
IF IC-RTN-CDE = 0 AND
IC-RSN-CDE = 0
CONTINUE
ELSE
DISPLAY '*************************'
DISPLAY ' RTN-CDE ' IC-RTN-CDE
DISPLAY ' RSN-CDE ' IC-RSN-CDE
DISPLAY '*************************'
MOVE 1111 TO ABT-ERROR-ABEND-CODE
MOVE 'WRITEMSG' TO ABT-DA-FUNCTION
MOVE 'MQ ' TO ABT-ERROR-ACTIVITY
MOVE 'AFCPO5 ' TO ABT-DA-ACCESS-NAME
CALL 'ADMAAT0'
PERFORM Z-980-ABNORMAL-TERM
END-IF
.
Z-200-EXIT.
EXIT.
*
* FORMAT THE MESSAGE FOR MQ
*
Z-300-BUILD-MSG.
INITIALIZE WS-MESSAGE
IF MQ-SHPR-633 <= SPACES
MOVE '"' TO MQ-SHPR-633
END-IF
IF MQ-CNSG-633 <= SPACES
MOVE '"' TO MQ-CNSG-633
END-IF
IF MQ-TP-633 <= SPACES
MOVE '"' TO MQ-TP-633
END-IF
IF MQ-RULE-11-633<= SPACES
MOVE '"' TO MQ-RULE-11-633
END-IF
IF MQ-ORIG-CITY <= SPACES
MOVE '"' TO MQ-ORIG-CITY
END-IF
IF MQ-ORIG-ST <= SPACES
MOVE '"' TO MQ-ORIG-ST
END-IF
IF MQ-DEST-CITY <= SPACES
MOVE '"' TO MQ-DEST-CITY
END-IF
IF MQ-DEST-ST <= SPACES
MOVE '"' TO MQ-DEST-ST
END-IF
IF MQ-STCC-NUMB <= SPACES
MOVE '"' TO MQ-STCC-NUMB
END-IF
IF MQ-PRC-AUTH <= SPACES
MOVE '"' TO MQ-PRC-AUTH
END-IF
IF MQ-ISS-CARR <= SPACES
MOVE '"' TO MQ-ISS-CARR
END-IF
IF MQ-PA-ID <= SPACES
MOVE '"' TO MQ-PA-ID
END-IF
IF MQ-ITEM-N <= SPACES
MOVE '"' TO MQ-ITEM-N
END-IF
IF MQ-PA-N <= SPACES
MOVE '"' TO MQ-PA-N
END-IF
IF MQ-PRC-PKG-N <= SPACES
MOVE '"' TO MQ-PRC-PKG-N
END-IF
IF MQ-REN-PA-N <= SPACES
MOVE '"' TO MQ-REN-PA-N
END-IF
IF MQ-FGN-SYS-CD <= SPACES
MOVE '"' TO MQ-FGN-SYS-CD
END-IF
MOVE ZEROES TO IDX1
IDX2
INSPECT MQ-PRC-PKG-N TALLYING IDX1 FOR LEADING SPACES
INSPECT MQ-REN-PA-N TALLYING IDX2 FOR LEADING SPACES
MOVE +1 TO WS-STRPTR
STRING MQ-APPL-CD
, ',' , MQ-OVR-PMT-CD
, ',' , MQ-EQP-INIT
, ',' , MQ-EQP-NUMB
, ',' , MQ-BGN-RPC-DT
, ',' , MQ-BGN-RPC-TM
, ',' , MQ-EFF-DT
, ',' , MQ-EXP-DT
, ',' , MQ-SHPR-633
, ',' , MQ-CNSG-633
, ',' , MQ-TP-633
, ',' , MQ-RULE-11-633
, ',' , MQ-ORIG-CITY
, ',' , MQ-ORIG-ST
, ',' , MQ-DEST-CITY
, ',' , MQ-DEST-ST
, ',' , MQ-STCC-NUMB
, ',' , MQ-PRC-AUTH
, ',' , MQ-ISS-CARR
, ',' , MQ-PA-ID
, ',' , MQ-ITEM-N
, ',' , MQ-PA-N
, ',' , MQ-PRC-PKG-N(IDX1 + 1:11 - IDX1)
, ',' , MQ-REN-PA-N(IDX2 + 1:11 - IDX2)
, ',' , MQ-FGN-SYS-CD
DELIMITED BY SPACES
INTO WS-MESSAGE
WITH POINTER WS-STRPTR
END-STRING
INSPECT WS-MESSAGE REPLACING ALL '"' BY ' '
.
Z-300-EXIT.
EXIT.
*
* UPDATE LOG TABLE
*
Z-400-UPDATE-LOG.
MOVE CGB-EQP-INIT TO AFCPO1IK-EQP-INIT
MOVE CGB-EQP-NUMB TO AFCPO1IK-EQP-NUMB
MOVE CGB-BGN-RPC-DT TO AFCPO1IK-BGN-RPC-DT
MOVE CGB-BGN-RPC-TM TO AFCPO1IK-BGN-RPC-TM
MOVE 'BNSF' TO AFCPO1IK-CAS-OWNER
MOVE CGB-LOG-USER TO AFCPO1I-LOG-USER
SET ONE-CAR TO TRUE
SET MSG-PRE-IMG-SENT TO TRUE
CALL AFCPO1 USING AFCPO1-IO-AREA
IF AFCPO1O-ERR-FLG = 'Y'
MOVE 3333 TO ABT-ERROR-ABEND-CODE
MOVE 'LOGMSG' TO ABT-DA-FUNCTION
MOVE 'CALL' TO ABT-ERROR-ACTIVITY
MOVE 'AFCPO1BD' TO ABT-DA-ACCESS-NAME
CALL 'ADMAAT0'
PERFORM Z-980-ABNORMAL-TERM
END-IF
.
Z-400-EXIT.
EXIT.
.
Z-500-SEND-MAIL.
PERFORM U-100-READ-CAF00CEH
MOVE CGB-EQP-INIT TO WS-L7-EQPINT
MOVE CGB-EQP-NUMB TO WS-L8-EQPNUM
MOVE CGB-BGN-RPC-DT TO WS-L9-BGNDT
MOVE CGB-BGN-RPC-TM TO WS-L10-BGNTM
MOVE CGB-WB-DT TO WS-L11-WBDT
MOVE CGB-WB-NUMB TO WS-L12-WBNUM
MOVE CURRENT-DATE TO WS-L4-DT
MOVE CURRENT-TIME TO WS-L4-TM
MOVE CEH-APPL-CD-DESC TO WS-F33-MAILID
IF CURRENT-SERVER = 'DB2FDDF'
MOVE SPACES TO WS-L15-REGN
ELSE
MOVE 'DEV' TO WS-L15-REGN
END-IF
PERFORM VARYING SUB FROM 1 BY 1 UNTIL SUB > 56
MOVE WS-JCL-MAIL-LN(SUB) TO JCLFILE-RECORD
PERFORM U-100-CREATE-JCLFILE
END-PERFORM
CLOSE JCLFILE-FILE
OPEN OUTPUT JCLFILE-FILE
MOVE JCLFILE-STATUS TO DA-STATUS-FILE
PERFORM U-100-SET-DA-STATUS-BATCH
IF JCLFILE-STATUS NOT = DATASET-OK
MOVE 4444 TO ABT-ERROR-ABEND-CODE
MOVE 'OPNCLS' TO ABT-DA-FUNCTION
MOVE 'SEQ ' TO ABT-ERROR-ACTIVITY
MOVE 'JCLFILE ' TO ABT-DA-ACCESS-NAME
PERFORM Z-980-ABNORMAL-TERM
END-IF
.
Z-500-EXIT.
EXIT.
.
Z-600-MQ-COMMIT.
INITIALIZE IC-SEND-AREA
IC-API-AREA
IC-BUF
IC-RTN-CDE
IC-RSN-CDE
MOVE 'CKPTBTCH' TO IC-OPTION-TYPE
MOVE WFMS500B TO IC-REQUEST-TYPE
MOVE 'CAS00000' TO IC-APP-RTN-CODE
MOVE 'CASCBRRV' TO I-PROCESS-NAME
MOVE 'CASCBRRV' TO IC-ACTIVITY-NAME
MOVE 'AFCPO5' TO IC-USER-ID
MOVE ZEROES TO IC-MQ-I-MSG-PRIORITY
IC-MQ-I-BUFFER-TYPE
IC-MQ-O-MSG-PRIORITY
IC-MQ-O-OBJ-HANDLE
IC-MQ-I-BUFFER-TYPE
MOVE SPACES TO IC-USER-DATA
MOVE 200 TO IC-BUF-LEN
CALL WFMS500B USING IC-SEND-AREA
IC-API-AREA
IC-BUF
IF IC-RTN-CDE = 0 AND
IC-RSN-CDE = 0
CONTINUE
ELSE
DISPLAY '*************************'
DISPLAY ' RTN-CDE ' IC-RTN-CDE
DISPLAY ' RSN-CDE ' IC-RSN-CDE
DISPLAY '*************************'
MOVE 2222 TO ABT-ERROR-ABEND-CODE
MOVE 'COMITMSG' TO ABT-DA-FUNCTION
MOVE 'MQ ' TO ABT-ERROR-ACTIVITY
MOVE 'AFCPO5 ' TO ABT-DA-ACCESS-NAME
CALL 'ADMAAT0'
PERFORM Z-980-ABNORMAL-TERM
END-IF
.
Z-600-EXIT.
EXIT.
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -