COBOL - BALANCE LINE de dois arquivos - www.cadcobol.com.br


clique aqui para imprimir esta página

Volta a página anterior

Volta ao Menu Principal


Desenvolvido por DORNELLES Carlos Alberto - Analista de Sistemas - Brasília DF. - cad_cobol@hotmail.com


COBOL - BALANCE LINE de dois arquivos
O programa abaixo listado tem por finalidade demonstrar a execução de um BALANCE LINE de dois arquivos.

Código
         1         2         3         4         5         6         7   
123456789012345678901234567890123456789012345678901234567890123456789012

      *-----------------------------------------------------------------
       IDENTIFICATION DIVISION.                                         
      *-----------------------------------------------------------------
       PROGRAM-ID.      CADBALAN.                                       
       AUTHOR.          CARLOS ALBERTO DORNELLES.                       
      *-----------------------------------------------------------------
      * SISTEMA       : PROGRAMAS EXEMPLOS                              
      * PROGRAMA      : CADBALAN                                        
      * OBJETIVO      : BALANCE LINE DE DOIS ARQUIVOS                   
      * ENTRADA       : ARQUIVO COM NOME DO FUNCIONARIO                 
      *               : ARQUIVO COM ENDERECO DO FUNCIONARIO             
      * SAIDA         : ARQUIVO COM OS DADOS DO FUNCIONARIO             
      * ANALISTA      : CARLOS ALBERTO DORNELLES                        
      * LINGUAGEM     : COBOL II - COBOL 85                             
      * MODO OPERACAO : BATCH                                           
      *-----------------------------------------------------------------
      *  VERSAO DD.MM.AAAA HISTORICO/AUTOR                              
      *  ------ ---------- ---------------                              
      *   V.001 16.08.2007 PROGRAMA INICIAL/DORNELLES                   
      *                                                                 
      *-----------------------------------------------------------------
                                                                        
      *-----------------------------------------------------------------
       ENVIRONMENT DIVISION.                                            
      *-----------------------------------------------------------------
                                                                        
      *-----------------------------------------------------------------
       CONFIGURATION SECTION.                                           
      *-----------------------------------------------------------------
       SPECIAL-NAMES.                                                   
                        DECIMAL-POINT IS COMMA.                         
                                                                        
      *-----------------------------------------------------------------
       INPUT-OUTPUT SECTION.                                            
      *-----------------------------------------------------------------
       FILE-CONTROL.                                                    
                                                                        
           SELECT ENTNOME ASSIGN TO ENTNOME                             
                  FILE STATUS IS WS-FS-ENTNOME.                         
           SELECT ENTENDE ASSIGN TO ENTENDE                             
                  FILE STATUS IS WS-FS-ENTENDE.                         
           SELECT SAIFUNC ASSIGN TO SAIFUNC                             
                  FILE STATUS IS WS-FS-SAIFUNC.                         
                                                                        
      *-----------------------------------------------------------------
       DATA DIVISION.                                                   
      *-----------------------------------------------------------------
                                                                        
      *-----------------------------------------------------------------
       FILE SECTION.                                                    
      *-----------------------------------------------------------------
                                                                        
       FD  ENTNOME                                                      
           BLOCK CONTAINS 0 RECORDS                                     
           RECORDING MODE IS F                                          
           RECORD CONTAINS 060 CHARACTERS.                              
                                                                        
       01  REG-ENTNOME.                                                 
           03  ENTNOME-MATRICULA         PIC 9(010).                    
           03  ENTNOME-NOME              PIC X(050).                    
                                                                        
       FD  ENTENDE                                                      
           BLOCK CONTAINS 0 RECORDS                                     
           RECORDING MODE IS F                                          
           RECORD CONTAINS 120 CHARACTERS.                              
                                                                        
       01  REG-ENTENDE.                                                 
           03  ENTENDE-MATRICULA         PIC 9(010).                    
           03  ENTENDE-ENDERECO          PIC X(050).                    
           03  ENTENDE-CIDADE            PIC X(050).                    
           03  ENTENDE-UF                PIC X(002).                    
           03  ENTENDE-CEP               PIC 9(008).                    
                                                                        
       FD  SAIFUNC                                                      
           BLOCK CONTAINS 0 RECORDS                                     
           RECORDING MODE IS F                                          
           RECORD CONTAINS 170 CHARACTERS.                              
                                                                        
       01  REG-SAIFUNC.                                                 
           03  SAIFUNC-MATRICULA         PIC 9(010).                    
           03  SAIFUNC-NOME              PIC X(050).                    
           03  SAIFUNC-ENDERECO          PIC X(050).                    
           03  SAIFUNC-CIDADE            PIC X(050).                    
           03  SAIFUNC-UF                PIC X(002).                    
           03  SAIFUNC-CEP               PIC 9(008).                    
                                                                        
      *-----------------------------------------------------------------
       WORKING-STORAGE SECTION.                                         
      *-----------------------------------------------------------------
                                                                        
       01  WS-AREA-AUXILIAR.                                            
           05  WS-COD-PROGRAMA           PIC X(008)  VALUE 'CADBALAN'.  
           05  WS-COD-VER                PIC X(008)  VALUE '001/2007'.  
           05  WS-FS-ENTNOME             PIC X(002)  VALUE SPACES.      
           05  WS-FS-ENTENDE             PIC X(002)  VALUE SPACES.      
           05  WS-FS-SAIFUNC             PIC X(002)  VALUE SPACES.      
           05  WS-LIDOS-NOME             PIC 9(010)  VALUE ZEROES.      
           05  WS-LIDOS-ENDE             PIC 9(010)  VALUE ZEROES.      
           05  WS-GRAVA-FUNC             PIC 9(010)  VALUE ZEROES.      
           05  WS-MENSAGEM               PIC X(070)  VALUE SPACES.      
           05  WS-PROCESSO               PIC X(070)  VALUE SPACES.      
                                                                        
      *-----------------------------------------------------------------
       PROCEDURE DIVISION.                                              
      *-----------------------------------------------------------------
                                                                        
           PERFORM P0000-INICIAL
           PERFORM P1000-PRINCIPAL
           PERFORM P9000-FINAL
           GOBACK.
                                                                        
      *-----------------------------------------------------------------
       P0000-INICIAL.                                                   
      *-----------------------------------------------------------------
                                                                        
           MOVE 'P0000-INICIAL' TO        WS-PROCESSO.                  
                                                                        
           OPEN INPUT ENTNOME.                                          
           IF WS-FS-ENTNOME NOT EQUAL '00'                              
              MOVE SPACES TO WS-MENSAGEM                                
              STRING 'ERRO ABERTURA ARQUIVO ENTNOME FILE STATUS: '      
                     WS-FS-ENTNOME                                      
                     DELIMITED BY SIZE  INTO WS-MENSAGEM                
              END-STRING                                                
              PERFORM P8000-ERRO THRU P8000-FIM                         
           END-IF.                                                      
                                                                        
           OPEN INPUT ENTENDE.                                          
           IF WS-FS-ENTENDE NOT EQUAL '00'                              
              STRING 'ERRO ABERTURA ARQUIVO ENTENDE FILE STATUS: '      
                     WS-FS-ENTENDE                                      
                     DELIMITED BY SIZE  INTO WS-MENSAGEM                
              END-STRING                                                
              PERFORM P8000-ERRO THRU P8000-FIM                         
           END-IF.                                                      
                                                                        
           OPEN OUTPUT SAIFUNC.                                         
           IF WS-FS-SAIFUNC NOT EQUAL '00'                              
              STRING 'ERRO ABERTURA ARQUIVO SAIFUNC FILE STATUS: '      
                     WS-FS-SAIFUNC                                      
                     DELIMITED BY SIZE  INTO WS-MENSAGEM                
              END-STRING                                                
              PERFORM P8000-ERRO THRU P8000-FIM                         
           END-IF.                                                      
                                                                        
        P0000-FIM.                                                      
            EXIT.                                                       
                                                                        
      *-----------------------------------------------------------------
       P1000-PRINCIPAL.                                                 
      *-----------------------------------------------------------------
                                                                        
           MOVE 'P1000-PRINCIPAL      ' TO  WS-PROCESSO.                
                                                                        
           PERFORM P2000-LER-ENTNOME THRU P2000-FIM                     
           PERFORM P3000-LER-ENTENDE THRU P3000-FIM                     
           PERFORM UNTIL WS-FS-ENTNOME EQUAL '10'                       
                     AND WS-FS-ENTENDE EQUAL '10'                       
              EVALUATE TRUE                                             
                 WHEN ENTNOME-MATRICULA EQUAL        ENTENDE-MATRICULA  
                      PERFORM P4000-GRAVA-SAIFUNC THRU P4000-FIM        
                      PERFORM P2000-LER-ENTNOME   THRU P2000-FIM        
                      PERFORM P3000-LER-ENTENDE   THRU P3000-FIM        
                 WHEN ENTNOME-MATRICULA LESS THAN    ENTENDE-MATRICULA  
                      PERFORM P2000-LER-ENTNOME   THRU P2000-FIM        
                 WHEN ENTNOME-MATRICULA GREATER THAN ENTENDE-MATRICULA  
                      PERFORM P3000-LER-ENTENDE   THRU P3000-FIM        
              END-EVALUATE                                              
           END-PERFORM.                                                 
                                                                        
       P1000-FIM.                                                       
           EXIT.                                                        
                                                                        
      *-----------------------------------------------------------------
       P2000-LER-ENTNOME.                                               
      *-----------------------------------------------------------------
                                                                        
           MOVE 'P2000-LER-ENTNOME' TO WS-PROCESSO                      
           READ ENTNOME                                                 
                AT END                                                  
                MOVE '10'       TO WS-FS-ENTNOME                        
                MOVE 9999999999 TO ENTNOME-MATRICULA                    
                NOT AT END                                              
                IF WS-FS-ENTNOME NOT EQUAL '00' AND '10'                
                   MOVE SPACES TO WS-MENSAGEM                           
                   STRING 'ERRO LEITURA ARQUIVO ENTNOME FILE STATUS: '  
                           WS-FS-ENTNOME                                
                           DELIMITED BY SIZE  INTO WS-MENSAGEM          
                   END-STRING                                           
                   PERFORM P8000-ERRO THRU P8000-FIM                    
                END-IF                                                  
                IF WS-FS-ENTNOME EQUAL '00'                             
                   ADD 1 TO WS-LIDOS-NOME                               
                END-IF                                                  
           END-READ.                                                    
                                                                        
       P2000-FIM.                                                       
           EXIT.                                                        
                                                                        
      *-----------------------------------------------------------------
       P3000-LER-ENTENDE.                                               
      *-----------------------------------------------------------------
                                                                        
           MOVE 'P3000-LER-ENTENDE' TO WS-PROCESSO                      
           READ ENTENDE                                                 
                AT END                                                  
                MOVE '10'       TO WS-FS-ENTENDE                        
                MOVE 9999999999 TO ENTENDE-MATRICULA                    
                NOT AT END                                              
                IF WS-FS-ENTENDE NOT EQUAL '00' AND '10'                
                   MOVE SPACES TO WS-MENSAGEM                           
                   STRING 'ERRO LEITURA ARQUIVO ENTENDE FILE STATUS: '  
                           WS-FS-ENTENDE                                
                           DELIMITED BY SIZE  INTO WS-MENSAGEM          
                   END-STRING                                           
                   PERFORM P8000-ERRO THRU P8000-FIM                    
                END-IF                                                  
                IF WS-FS-ENTENDE EQUAL '00'                             
                   ADD 1 TO WS-LIDOS-ENDE                               
                END-IF                                                  
           END-READ.                                                    
                                                                        
       P3000-FIM.                                                       
           EXIT.                                                        
                                                                        
                                                                        
      *-----------------------------------------------------------------
       P4000-GRAVA-SAIFUNC.                                             
      *-----------------------------------------------------------------
                                                                        
           MOVE 'P4000-GRAVA-SAIFUNC' TO WS-PROCESSO                    
           INITIALIZE REG-SAIFUNC                                       
                      REPLACING ALPHANUMERIC BY SPACES                  
                                     NUMERIC BY ZEROES                  
                                                                        
           MOVE ENTENDE-MATRICULA TO SAIFUNC-MATRICULA                  
           MOVE ENTENDE-ENDERECO  TO SAIFUNC-ENDERECO                   
           MOVE ENTENDE-CIDADE    TO SAIFUNC-CIDADE                     
           MOVE ENTENDE-UF        TO SAIFUNC-UF                         
           MOVE ENTENDE-CEP       TO SAIFUNC-CEP                        
           MOVE ENTNOME-NOME      TO SAIFUNC-NOME                       
           WRITE REG-SAIFUNC         END-WRITE                          
                                                                        
           IF WS-FS-SAIFUNC NOT EQUAL '00'                              
              MOVE SPACES TO WS-MENSAGEM                                
              STRING 'ERRO GRAVACAO ARQUIVO SAIFUNC FILE STATUS: '      
                      WS-FS-SAIFUNC                                     
                      DELIMITED BY SIZE  INTO WS-MENSAGEM               
              END-STRING                                                
              PERFORM P8000-ERRO THRU P8000-FIM                         
           END-IF                                                       
                                                                        
           ADD 1 TO WS-GRAVA-FUNC.                                      
                                                                        
       P4000-FIM.                                                       
           EXIT.                                                        
                                                                        
                                                                        
      *-----------------------------------------------------------------
       P8000-ERRO.                                                      
      *-----------------------------------------------------------------
                                                                        
           DISPLAY '---------------------------------------------'      
           DISPLAY 'PROGRAMA CADBALAN CANCELADO'                        
           DISPLAY 'PARAGRAFO   - ' WS-PROCESSO                         
           DISPLAY 'VERSAO      - ' WS-COD-VER                          
           DISPLAY 'MENSAGEM    - ' WS-MENSAGEM                         
           DISPLAY '---------------------------------------------'      
           MOVE 99 TO RETURN-CODE                                       
           GOBACK.                                                      
                                                                        
       P8000-FIM.                                                       
           EXIT.                                                        
                                                                        
      *-----------------------------------------------------------------
       P9000-FINAL.                                                     
      *-----------------------------------------------------------------
                                                                        
           DISPLAY '---------------------------------------------'      
           DISPLAY 'PROGRAMA CADBALAN - TERMINO OK'                     
           DISPLAY '                                             '      
           DISPLAY 'TOTAL DE LIDOS NOMES .. - ' WS-LIDOS-NOME           
           DISPLAY 'TOTAL DE LIDOS ENDERECO - ' WS-LIDOS-ENDE           
           DISPLAY 'TOTAL GRAVADOS ........ - ' WS-GRAVA-FUNC.          
                                                                        
       P9000-FIM.                                                       
           EXIT.