Code: Detail

Cobol - (Portuguese)

Balanceline de 2 arquivos

Este programa tem a finalidade demonstrar a execução de um BALANCE LINE de dois arquivos.

Last update: 11/12/2013
Cobol       
 
N/A
N/A
N/A
N/A
 

         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         THRU P0000-FIM.                
           PERFORM P1000-PRINCIPAL       THRU P1000-FIM.                
           PERFORM P9000-FINAL           THRU P9000-FIM.                
           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.                                                        

Source: http://www.cadcobol.com/cadbalan.htm
 
Users who have marked this routine as a favorite
 
 
 
The site ti4fun is not responsible for the content on sites for which you have external links

Articles, routines, tips, forums, blogs or any other content posted on ti4fun site is not tested and not validated, so you should test and validate any information collected on the ti4fun site before applying it to final use environment, such as example, production. the TI4FUN site is not responsible for quality or for any damages, direct, indirect or consequential, from use of any content posted by the authors in the site.

All content published on the ti4fun site is the responsibility of the author and do not necessarily express the views of the site ti4fun and its employees.