bcb8522.pco

行业应用源码 行业应用源码 行业应用源码 行业应用源码 行业应用源码 行业应用源码

       IDENTIFICATION  DIVISION.
       PROGRAM-ID.     BCB8522.
       AUTHOR.         John.
       DATE-WRITTEN.   2001/12/01/.
       DATE-COMPILED.  2001/12/01/.
      ******************************************************************
      *** REMARKS:                                                   ***
      *** PROGRAM NAME: BCB8522                                      ***
      *** PROGRAM PURPOSE     :总帐ACTCGL横平检查                    ***
      *** PROCESS DESCRIPTION :                                      ***
      ***    1000-TXN-INIT-RTN                                       ***
      ***    5000-NORMAL-PROCESS-RTN                                 ***
      ***    8000-TXN-END-RTN                                        ***
      ******************************************************************

       ENVIRONMENT DIVISION.
       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
           SELECT RP-RP401 ASSIGN TO "./list8522"
                  FILE STATUS IS  WK-RETURN-CODE.
      ******************************************************************
      ***  DATA DIVISION                                             ***
      ******************************************************************

       DATA DIVISION.
       FILE        SECTION.
       FD  RP-RP401
           DATA  RECORD IS REPROT-401-RECORD.
       01 REPROT-401-RECORD   PIC   X(180).
       WORKING-STORAGE SECTION.
      ******************************************************************
      ***  VARIABLE  CAN'T BE INITIALIZED                            ***
      ******************************************************************

       01 WK-AERA.
          05  WK-END-FLAG       PIC X(1)  VALUE '0'.
          05  WK-MODFLG         PIC X(1)  VALUE SPACE.
          05  REC-TYP           PIC X(1)  VALUE SPACE.
          05  WK-PARA           PIC X(50) VALUE SPACE.
          05  WK-RETURN-CODE    PIC X(2)  VALUE SPACE.
          05  WK-RETURN-CODE-1  PIC 99    VALUE ZERO.
          05  WK-NUMBER-ERROR   PIC  9(7)  VALUE ZERO.
          05  WK-NUMBER-RIGHT   PIC  9(7)  VALUE ZERO.
       01  REPORT-401-HEAD      PIC  X(18)  VALUE '总帐横不平清单　'.
       01  REPORT-401-FOOT      PIC  X(6)  VALUE SPACE.
       01  REPROT-401-BODY.
          05 RP401-ORGIDT       PIC X(4) VALUE SPACES.
          05 FILLER             PIC X(2) VALUE SPACES. 
          05 RP401-RECTYP       PIC X(1) VALUE SPACE.
          05 FILLER             PIC X(2) VALUE SPACES.
          05 RP401-GLCODE       PIC X(4) VALUE SPACES.
          05 FILLER             PIC X(2) VALUE SPACES.
          05 RP401-CURCDE       PIC X(3) VALUE SPACES.
          05 FILLER             PIC X(4) VALUE SPACES.
          05 RP401-DRAMNT       PIC X(21) VALUE SPACES.
          05 FILLER             PIC X(4) VALUE SPACES.
          05 RP401-CRAMNT       PIC X(21) VALUE SPACES.
          05 FILLER             PIC X(4) VALUE SPACES.
          05 RP401-DRBALA       PIC X(21) VALUE SPACES.
          05 FILLER             PIC X(4) VALUE SPACES.
          05 RP401-CRBALA       PIC X(21) VALUE SPACES.
          05 FILLER             PIC X(4) VALUE SPACES.
          05 RP401-LST-DRBALA   PIC X(21) VALUE SPACES.
          05 FILLER             PIC X(4) VALUE SPACES.
          05 RP401-LST-CRBALA   PIC X(21) VALUE SPACES.
       01  FORMAT.
          05  FORMAT-0          PIC ZZZ,ZZZ,ZZZ,ZZZ,ZZ9-.
          05  FORMAT-1          PIC Z,ZZZ,ZZZ,ZZZ,ZZ9.9-.
          05  FORMAT-2          PIC ZZZZ,ZZZ,ZZZ,ZZ9.99-.
          05  FORMAT-3          PIC ZZZ,ZZZ,ZZZ,ZZ9.999-.

       01  WK-CRNDAT            PIC  X(10)         VALUE SPACE.
       01  FILLER               PIC X(10) VALUE '//SQLACT//'.
      *****************************************************************
      * SQL/DS HOST VARIABLE DECLARATION                            ***
      *****************************************************************

           EXEC  SQL BEGIN   DECLARE  SECTION  END-EXEC.
           EXEC  SQL INCLUDE ACKSQST  END-EXEC.
           EXEC  SQL INCLUDE SQLCOM   END-EXEC.
       01 WK-RECTYP         PIC X(1)  VALUE SPACE.
       01 WK-SQL-VAL.
           EXEC  SQL INCLUDE ACKSCT   END-EXEC.
           EXEC  SQL INCLUDE ACKCCY   END-EXEC.
           EXEC  SQL INCLUDE ACKCGL   END-EXEC.
           EXEC  SQL END     DECLARE  SECTION END-EXEC.
           EXEC  SQL INCLUDE SQLCA   END-EXEC.
       PROCEDURE DIVISION.
       0000-MAIN-PROCESS-RTN.
           DISPLAY 'BCB8522 BEGIN' UPON CONSOLE.
           PERFORM     1000-TXN-INIT-RTN           THRU 1000-EXIT.
           PERFORM     5000-NORMAL-PROCESS-RTN     THRU 5000-EXIT.
           PERFORM     8000-TXN-END-RTN            THRU 8000-EXIT.
           DISPLAY 'BCB8522 END  ' UPON CONSOLE.
           STOP  RUN.
       0000-EXIT.
           EXIT.
       1000-TXN-INIT-RTN.
      ****************************************************************
      * CONNECT TO THE DATABASE                                      *
      ****************************************************************
           MOVE   '/1000-TXN-INIT-RTN/'    TO    WK-PARA.
           INITIALIZE  WK-SQL-VAL.
           EXEC SQL INCLUDE APS999  END-EXEC.
           EXEC SQL LOCK TABLE  ACTCGL  IN EXCLUSIVE MODE END-EXEC.
           EXEC SQL WHENEVER SQLERROR   GOTO  :ERRCHK END-EXEC.
       1000-EXIT.
           EXIT.

       5000-NORMAL-PROCESS-RTN.
           MOVE   '/5000-NORMAL-PROCESS-RTN/'    TO    WK-PARA.
           EXEC SQL SELECT CRNDAT
                    INTO   :SCT-CRNDAT
                    FROM   ACTSCT
                    WHERE  SCTNUM = :CNST-M-SCTNUM-NORMAL
                      AND  RECSTS = :CNST-M-RECSTS-VALID
           END-EXEC.
           IF    SQLCODE NOT = 0
           THEN  MOVE     'ACTSCT  NOT FOUND '  TO   WK-PARA
                 GO  TO   ERRCHK
           END-IF.
           MOVE        SCT-CRNDAT          TO      WK-CRNDAT.
           OPEN     OUTPUT    RP-RP401.
           IF       WK-RETURN-CODE  NOT = '00'
           THEN     
                    DISPLAY 'OPEN RP-RP401 ERROR!' WK-RETURN-CODE
                    GO   TO   ERRCHK
           END-IF.
           ACCEPT REC-TYP.
           IF REC-TYP = 'D'
           THEN
              MOVE   CNST-M-RECTYP-D      TO     WK-RECTYP
           ELSE
              IF REC-TYP = 'M'
              THEN
                 MOVE  CNST-M-RECTYP-M    TO     WK-RECTYP
              ELSE
                 IF  REC-TYP = 'Y'
                 THEN
                    MOVE CNST-M-RECTYP-Y  TO     WK-RECTYP
                 END-IF
              END-IF
           END-IF.

           WRITE  REPROT-401-RECORD  FROM REPORT-401-HEAD AFTER 1.
           EXEC SQL DECLARE   CUR_ACTCGL  CURSOR  FOR
                     SELECT   ORGIDT,GLCODE,CURCDE,
                              DRAMNT,CRAMNT,DRBALA,
                              CRBALA,DLSBAL,CLSBAL,
                              RECTYP
                      FROM  ACTCGL
                     WHERE  RECSTS = :CNST-M-RECSTS-VALID
                       AND  RECTYP = :WK-RECTYP
	             ORDER BY ORGIDT,CURCDE,GLCODE
           END-EXEC.
           EXEC  SQL  OPEN  CUR_ACTCGL  END-EXEC.
           IF  SQLCODE NOT = 0
           THEN
               DISPLAY 'OPEN CURSOR ERR!'
               GO   TO   ERRCHK
           END-IF.
           PERFORM     5100-SCAN-ACTCGL-RTN             
                      THRU 5100-EXIT UNTIL WK-END-FLAG = '1'.
           EXEC  SQL  CLOSE CUR_ACTCGL  END-EXEC.
           IF  SQLCODE NOT = 0
           THEN
               DISPLAY 'CLOSE CURSOR ERR!'
               GO   TO   ERRCHK
           END-IF.
           WRITE  REPROT-401-RECORD  FROM REPORT-401-FOOT AFTER 1.
       5000-EXIT.
           EXIT.
     ********************************************************************
     **  5100-SCAN-ACTCGL-RTN 总帐横平检查                             **
     ********************************************************************

       5100-SCAN-ACTCGL-RTN.
           MOVE   '/5100-SCAN-ACTCGL-RTN/'    TO    WK-PARA.
           EXEC  SQL  FETCH  CUR_ACTCGL
                      INTO  :CGL-ORGIDT,:CGL-GLCODE,:CGL-CURCDE,
                            :CGL-DRAMNT,:CGL-CRAMNT,:CGL-DRBALA,
                            :CGL-CRBALA,:CGL-DLSBAL,:CGL-CLSBAL,
                            :CGL-RECTYP
           END-EXEC.
           IF    SQLCODE NOT = 0
           THEN
                 MOVE  '1'                 TO      WK-END-FLAG
                 GO       TO       5100-EXIT.
           IF  (CGL-DLSBAL + CGL-CLSBAL) +  (CGL-DRAMNT +
               CGL-CRAMNT ) NOT = (CGL-DRBALA + CGL-CRBALA)
           THEN
               EXEC SQL SELECT DECPOS
                          INTO :CCY-DECPOS
                          FROM ACTCCY
                         WHERE CURCDE = :CGL-CURCDE
                           AND RECSTS = :CNST-M-RECSTS-VALID
               END-EXEC
               IF SQLCODE NOT = 0
               THEN
                  DISPLAY 'CCY IS NOT FOUND!'
                  GO  TO   ERRCHK
               END-IF
               ADD     1                   TO      WK-NUMBER-ERROR
               MOVE    CGL-ORGIDT          TO      RP401-ORGIDT
               MOVE    CGL-RECTYP          TO      RP401-RECTYP
               MOVE    CGL-GLCODE          TO      RP401-GLCODE
               MOVE    CGL-CURCDE          TO      RP401-CURCDE
               COPY  OUTCONV1 REPLACING
               HOST-M-TMP BY CGL-DRAMNT,
               DISFOR     BY RP401-DRAMNT.
               COPY  OUTCONV1 REPLACING
               HOST-M-TMP BY CGL-CRAMNT,
               DISFOR     BY RP401-CRAMNT.
               COPY  OUTCONV1 REPLACING
               HOST-M-TMP BY CGL-DRBALA,
               DISFOR     BY RP401-DRBALA.
               COPY  OUTCONV1 REPLACING
               HOST-M-TMP BY CGL-CRBALA,
               DISFOR     BY RP401-CRBALA.
               COPY  OUTCONV1 REPLACING
               HOST-M-TMP BY CGL-DLSBAL,
               DISFOR     BY RP401-LST-DRBALA.
               COPY  OUTCONV1 REPLACING
               HOST-M-TMP BY CGL-CLSBAL,
               DISFOR     BY RP401-LST-CRBALA.
               WRITE REPROT-401-RECORD FROM REPROT-401-BODY AFTER 1
               MOVE    8                   TO      WK-RETURN-CODE-1
            ELSE
               ADD     1                   TO      WK-NUMBER-RIGHT
            END-IF.
       5100-EXIT.
           EXIT.

       8000-TXN-END-RTN.
           MOVE   '/8000-TXN-END-RTN/'    TO    WK-PARA.
           CLOSE       RP-RP401.
           IF       WK-RETURN-CODE  NOT = '00'
           THEN    
               DISPLAY  'CLOSE  RP-RP401 ERROR 'WK-RETURN-CODE 
               GO   TO   ERRCHK
           END-IF.
           DISPLAY   ' CGL-ERR-NUM = ' WK-NUMBER-ERROR.
           DISPLAY   ' CGL-RIGHT-NUM = ' WK-NUMBER-RIGHT.
           MOVE        WK-RETURN-CODE-1    TO      RETURN-CODE.
       8000-EXIT.
           EXIT.

       ERRCHK.
           DISPLAY 'ERR ON:' WK-PARA.
           DISPLAY     'SQLCODE='                  SQLCODE.
           MOVE        8                   TO      RETURN-CODE.
           STOP       RUN.