pbsbckcd

用COBOL基于IBM大型机操作DB2及CICS的样例。

      ***********************************                                       
      *    DB2 COMMUNICATION AREA       *                                       
      ***********************************                                       
      *                                                                         
      *    NULL                                                                 
      *                                                                         
      **************************************************************            
       LINKAGE SECTION.                                                         
      **************************************************************            
      *                                                                 00230014
           COPY PBCOCKCD.                                                       
      *                                                                         
      **************************************                                    
       PROCEDURE DIVISION USING PBCOCKCD.                                       
      **************************************                                    
      *                                                                         
       A00-MAIN-PROC.                                                           
      *                                                                         
           PERFORM A00-INIT-PROC                                                
           PERFORM B00-PROCESS-ROUTINE                                          
           PERFORM Z00-PGM-EXIT                                                 
           .                                                                    
           EXIT.                                                                
      *                                                                         
       A00-INIT-PROC.                                                           
      *                                                                         
           CONTINUE                                                             
           EXIT.                                                                
      *                                                                         
      *****************************************************************         
      *    FUNSPC1: MAIN PROCESS ROUTINE                              *         
      *****************************************************************         
      *                                                                         
       B00-PROCESS-ROUTINE.                                                     
      *                                                                         
           IF WS-FLAG NOT = 'Y'                                                 
           THEN                                                                 
              MOVE 'Y'                           TO WS-FLAG                     
              PERFORM S00-OPEN-PBFCODE                                          
           END-IF                                                               
           PERFORM B10-GET-PBFCODE-INFO                                 00550014
           EXIT.                                                        00630014
      *                                                                 00640014
      *****************************************************************         
      *    FUNSPC1: READ FILE PBFDIFF                                 *         
      *****************************************************************         
      *                                                                         
       B10-GET-PBFCODE-INFO.                                            02990014
      *                                                                         
           INITIALIZE                            PBRCODE                        
           MOVE CKCD-BK                          TO CODE-BK                     
           MOVE CKCD-TYPE                        TO CODE-TYPE                   
           MOVE CKCD-CODE                        TO CODE-NAME                   
           PERFORM S00-READ-PBFCODE                                             
           MOVE CODE-REMARK                      TO CKCD-REMARK                 
           MOVE CODE-ACT-DATE                    TO CKCD-ACT-DATE               
           MOVE CODE-CTL-DATA                    TO CKCD-CTL-DATA               
           MOVE CODE-CTL-WORD                    TO CKCD-CTL-WORD               
           .                                                                    
           EXIT.                                                        03150014
      *                                                                         
      *****************************************************************         
      *    CONTROL ON ALL THE FILES                                   *         
      *****************************************************************         
      *                                                                         
       S00-OPEN-PBFCODE.                                                        
      *                                                                         
           OPEN INPUT PBFCODE                                                   
           IF WS-CODE-STS NOT = FSTS-NORMAL                                     
           THEN                                                                 
              MOVE K-6070                        TO CKCD-RC-CODE                
              MOVE K-MMO                         TO CKCD-RC-MMO                 
              INITIALIZE                         SCCBERR                        
              SET BERR-OPEN                      TO TRUE                        
              MOVE FILE-PBFCODE                  TO BERR-NAME                   
              MOVE WS-CODE-STS                   TO BERR-NO                     
              MOVE PGM-PBSBCKCD                  TO BERR-PGM-NAME               
              MOVE 'OPEN PBFCODE  ERROR'         TO BERR-KEY-OR-OTHER           
              SET BERR-ERROR                     TO TRUE                        
              PERFORM S00-APP-ERR-PROC                                          
              PERFORM Z00-PGM-EXIT                                              
           END-IF                                                               
           EXIT.                                                                
      *                                                                         
       S00-READ-PBFCODE.                                                        
      *                                                                         
           READ PBFCODE KEY IS CODE-KEY                                 03010014
           EVALUATE WS-CODE-STS                                                 
              WHEN FSTS-NORMAL                                                  
                 CONTINUE                                                       
              WHEN FSTS-NOTFND                                                  
                 MOVE K-6069                     TO CKCD-RC-CODE                
                 MOVE K-MMO                      TO CKCD-RC-MMO                 
                 PERFORM Z00-PGM-EXIT                                           
              WHEN OTHER                                                        
                 INITIALIZE                      SCCBERR                        
                 SET BERR-READ                   TO TRUE                        
                 MOVE FILE-PBFCODE               TO BERR-NAME                   
                 MOVE WS-CODE-STS                TO BERR-NO                     
                 MOVE PGM-PBSBCKCD               TO BERR-PGM-NAME               
                 MOVE CODE-KEY                   TO BERR-KEY-OR-OTHER           
                 SET BERR-ERROR                  TO TRUE                        
                 PERFORM S00-APP-ERR-PROC                                       
                 PERFORM Z00-PGM-EXIT                                           
           END-EVALUATE                                                         
           EXIT.                                                                
      *                                                                         
      *****************************************************************         
      *  SYSTEM ERROR PROCESS (PUBLIC)                                *         
      *****************************************************************         
           COPY SCSPBERR.                                                       
      *                                                                         
      *****************************************************************         
      *    PROGRAM EXIT                                               *         
      *****************************************************************         
      *                                                                         
       Z00-PGM-EXIT.                                                            
      *                                                                         
           GOBACK.                                                              
      *                                                                         
       END PROGRAM PBSBCKCD.                                            03640014
      *