📄 rpind705
字号:
* COPY FILEDCL REPLACING == :FILENAME: == BY == LH101 ==
* ==':FILENAME:'== BY =='LH101'==.
* END DECLARATIVES.
*
A000-MAIN-PROC.
*
PERFORM A000-INITIALIZE THRU A000-INITIALIZE-EXIT
PERFORM B000-MAIN-PROCESS THRU B000-MAIN-PROCESS-EXIT
PERFORM Z099-PGM-END
*
GOBACK.
*
*****************************************************************
* INITIAL PROCESS ROUTINE *
*****************************************************************
*
A000-INITIALIZE.
*
DISPLAY 'FILE STATUS IS ' WS-RPIN705-STATUS
INITIALIZE WS-FILE-STS-AREA
WS-MESSAGE-AREA
WS-WORKING-VAR
* INCD705-RECORD
MOVE K-PGM-ID TO WS-PGM-ID
SET WS-PGM-START TO TRUE
DISPLAY WS-PGM-HEAD WS-PGM-MSG
*
SET STUS-ACTION-OPEN TO TRUE
OPEN OUTPUT RPIN705
DISPLAY 'FILE RPIN705 STATUS IS ' WS-RPIN705-STATUS
INITIALIZE INCD705-RECORD
.
EXIT.
A000-INITIALIZE-EXIT.
EXIT.
*****************************************************************
* MAIN PROCESS ROUTINE *
*****************************************************************
*
B000-MAIN-PROCESS.
*
*
*
PERFORM T100-OPEN-INVM
*
PERFORM T110-FETCH-INVM
*
IF WS-INVM-EOF
SET WS-NO-REC-FOUND TO TRUE
END-IF
PERFORM UNTIL WS-INVM-EOF
*
MOVE INCT-ACCT-NO TO WS-ACCOUNT-NO
PERFORM T200-GET-INVT
PERFORM S000-WRITE-OUTPUT
*
IF WS-NO-ERR
THEN
ADD 1 TO WS-SUCC-CNT
ELSE
ADD 1 TO WS-FAIL-CNT
END-IF
IF WS-FILE-NORMAL AND WS-DB2-NORMAL
PERFORM T110-FETCH-INVM
END-IF
END-PERFORM
PERFORM T199-CLOSE-INVM
.
B000-MAIN-PROCESS-EXIT.
EXIT.
*
*****************************************************************
* WRITE FILE OUTPUT-FILE ROUTINE *
*****************************************************************
*
S000-WRITE-OUTPUT.
*
* SET STUS-ACTION-WRITE TO TRUE
MOVE INVM-BRANCH-NO TO INCD705-BR
MOVE INVM-CURRENCY TO INCD705-CCY-CODE
MOVE INVM-CURR-BAL TO INCD705-INVM-CURR-BAL
MOVE INCT-ACCT-NO TO INCD705-INVV-ACCT-NO
MOVE INVE-VOUCHER-NO TO INCD705-INVT-VOLUME-NO
MOVE CUSVAA-NAME1 TO INCD705-CUSVAA-NAME
MOVE INVT-SEQUENCE-NO TO INCD705-INVT-SEQUENCE-NO
MOVE INVT-VOLUME-NO TO INCD705-INVT-VOLUME-NO
WRITE INCD705-RECORD.
EXIT.
*
T100-OPEN-INVM.
*
EXEC SQL OPEN CSR-INVM
END-EXEC.
*
MOVE SQLCODE TO DB2-RTCD.
EVALUATE SQLCODE
WHEN DB2-NORMAL
CONTINUE
WHEN OTHER
DISPLAY "FAILED OPEN OF " "CSR-INVM"
DISPLAY DB2-RTCD
SET MISERR01-FATAL-ERROR-FOUND
TO TRUE
MOVE K-PGM-ID TO UTDB2ER-CALL-PROG
MOVE SQLCA TO UTDB2ER-SQLCA
SET UTDB2ER-LOG-ERROR TO TRUE
CALL PGM-UTDB2ER USING UTDB2ER-CALL-AREA
END-EVALUATE.
*
EXIT.
*
T110-FETCH-INVM.
*
EXEC SQL FETCH
CSR-INVM
INTO
:INVM-BRANCH-NO,
:INVM-CURRENCY,
:INVM-CURR-BAL,
:INCT-ACCT-NO,
:INVE-VOUCHER-NO,
:CUSVAA-NAME1
END-EXEC.
MOVE SQLCODE TO DB2-RTCD.
EVALUATE SQLCODE
WHEN DB2-NORMAL
CONTINUE
WHEN DB2-NOTFOUND
SET WS-INVM-EOF TO TRUE
WHEN OTHER
DISPLAY DB2-RTCD
DISPLAY "FAILED FETCH OF " "CSR-INVM"
SET MISERR01-FATAL-ERROR-FOUND
TO TRUE
MOVE K-PGM-ID TO UTDB2ER-CALL-PROG
MOVE SQLCA TO UTDB2ER-SQLCA
SET UTDB2ER-LOG-ERROR TO TRUE
CALL PGM-UTDB2ER USING UTDB2ER-CALL-AREA
END-EVALUATE.
EXIT.
*
T199-CLOSE-INVM.
*
EXEC SQL CLOSE CSR-INVM
END-EXEC.
MOVE SQLCODE TO DB2-RTCD.
EVALUATE SQLCODE
WHEN DB2-NORMAL
CONTINUE
WHEN OTHER
DISPLAY 'FAILED CLOSE OF CSR-INVM'
DISPLAY DB2-RTCD
SET MISERR01-FATAL-ERROR-FOUND
TO TRUE
MOVE K-PGM-ID TO UTDB2ER-CALL-PROG
MOVE SQLCA TO UTDB2ER-SQLCA
SET UTDB2ER-LOG-ERROR TO TRUE
PERFORM Z000-CLOSE-FILE
CALL PGM-UTDB2ER USING UTDB2ER-CALL-AREA
END-EVALUATE.
EXIT.
*
*
T200-GET-INVT.
* EXEC SQL
* SELECT
* INVT.SEQUENCE_NO,
* INVT.VOLUME_NO
* INTO
* :INVT-SEQUENCE-NO,
* :INVT-VOLUME-NO
* FROM INVT
* WHERE
* INVT.SUB_ACCT_NO=:WS-ACCOUNT-NO
* END-EXEC.
MOVE SQLCODE TO DB2-RTCD.
EVALUATE SQLCODE
WHEN DB2-NORMAL
CONTINUE
WHEN DB2-NOTFOUND
CONTINUE
WHEN OTHER
DISPLAY DB2-RTCD
DISPLAY "FAILED FETCH OF " "T200-GET-INVT"
SET MISERR01-FATAL-ERROR-FOUND
TO TRUE
MOVE K-PGM-ID TO UTDB2ER-CALL-PROG
MOVE SQLCA TO UTDB2ER-SQLCA
SET UTDB2ER-LOG-ERROR TO TRUE
CALL PGM-UTDB2ER USING UTDB2ER-CALL-AREA
END-EVALUATE.
EXIT.
*
*
Y000-DISP-STATIS.
*
MOVE WS-READ-CNT TO WS-TOTAL-READ
MOVE WS-SUCC-CNT TO WS-SUCC-WRITE
MOVE WS-FAIL-CNT TO WS-FAIL-WRITE
*
DISPLAY WS-PGM-HEAD WS-TOTAL-ST
DISPLAY WS-PGM-HEAD WS-SUCCESS-ST
DISPLAY WS-PGM-HEAD WS-FAIL-ST
.
EXIT.
*
Z000-CLOSE-FILE.
*
SET STUS-ACTION-CLOSE TO TRUE
CLOSE RPIN705.
*
PERFORM Y000-DISP-STATIS
.
EXIT.
*
*****************************************************************
* PROGRAM EXIT *
*****************************************************************
*
Z099-PGM-END.
*
DISPLAY 'PGM IS END'
EVALUATE TRUE
WHEN MISERR01-SEVERE-WARNING-FOUND
WHEN MISERR01-ERROR-FOUND
WHEN MISERR01-FATAL-ERROR-FOUND
DISPLAY 'FETAL ERROR'
MOVE WK-RETURN-ERROR TO RETURN-CODE
SET WS-ABNORMAL-END TO TRUE
PERFORM Z200-ABNORMAL-END
WHEN MISERR01-WARNING-FOUND
DISPLAY 'WARNING BECAUSR'
MOVE WK-RETURN-WARNING TO RETURN-CODE
SET WS-ABNORMAL-END TO TRUE
PERFORM Z200-ABNORMAL-END
WHEN OTHER
MOVE WK-RETURN-NORMAL TO RETURN-CODE
SET WS-NORMAL-END TO TRUE
PERFORM Z100-NORMAL-END
END-EVALUATE.
*
MOVE WS-REC-CNT TO WS-TOTAL-RECS
DISPLAY WS-STATISTICS
*
DISPLAY WS-PGM-HEAD WS-PGM-MSG
.
EXIT.
*
Z100-NORMAL-END.
*
PERFORM Z000-CLOSE-FILE
IF WS-FAIL-CNT > 0
THEN
MOVE K-RETURN-WARNING TO RETURN-CODE
ELSE
MOVE K-RETURN-NORMAL TO RETURN-CODE
END-IF
*
SET WS-NORMAL-END TO TRUE
DISPLAY WS-PGM-HEAD WS-PGM-MSG
.
EXIT.
*
Z200-ABNORMAL-END.
*
PERFORM Z000-CLOSE-FILE
SET WS-ABNORMAL-END TO TRUE
DISPLAY WS-PGM-HEAD WS-PGM-MSG
MOVE K-RETURN-ABNORMAL TO RETURN-CODE
GOBACK
.
EXIT.
*------------------------------------------------------------------
* COMMON SYSTEM ERROR PROCESS *
*------------------------------------------------------------------
* COMMOM PROCESS ROUTINE FOR DB2 ERROR *
*------------------------------------------------------------------
* COPY DB2BSERR.
*------------------------------------------------------------------
* COMMOM PROCESS ROUTINE FOR FILE ERROR *
*------------------------------------------------------------------
* COPY FILESERR.
*
**********************
*END PROGRAM RPIND705.
**********************
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -