COBOL - Retorna o extenso de um valor fornecido até 999.999.999,99


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 - retorna o extenso de um valor fornecido ate 999.999.999,99
O programa abaixo listado tem por finalidade retornar o extenso de um valor fornecido ate 999.999.999,99.

Código
         1         2         3         4         5         6         7   
123456789012345678901234567890123456789012345678901234567890123456789012

      *---------------------------------------------------------------- 
       IDENTIFICATION DIVISION.                                         
      *---------------------------------------------------------------- 
                                                                        
       PROGRAM-ID.           CADEXTEN.                                  
       AUTHOR.               CADEXTEN.                                  
                                                                        
      *---------------------------------------------------------------- 
      * TRANSFORMA UM VALOR INFORMADO EM EXTENSO ATE 999999999,99       
      *---------------------------------------------------------------- 
                                                                        
      *---------------------------------------------------------------- 
       ENVIRONMENT DIVISION.                                            
      *---------------------------------------------------------------- 
       CONFIGURATION SECTION.                                           
       SPECIAL-NAMES.                                                   
                             DECIMAL-POINT IS COMMA.                    
                                                                        
      *---------------------------------------------------------------- 
       DATA DIVISION.                                                   
      *---------------------------------------------------------------- 
       FILE SECTION.                                                    
                                                                        
                                                                        
      *---------------------------------------------------------------- 
       WORKING-STORAGE SECTION.                                         
      *---------------------------------------------------------------- 
                                                                        
      * VARIAVEIS DO EXTENSO                                            
                                                                        
       01  TABELA.                                                      
           05  FILLER        PIC X(016)   VALUE "HUM           04".     
           05  FILLER        PIC X(016)   VALUE "DOIS          05".     
           05  FILLER        PIC X(016)   VALUE "TRES          05".     
           05  FILLER        PIC X(016)   VALUE "QUATRO        07".     
           05  FILLER        PIC X(016)   VALUE "CINCO         06".     
           05  FILLER        PIC X(016)   VALUE "SEIS          05".     
           05  FILLER        PIC X(016)   VALUE "SETE          05".     
           05  FILLER        PIC X(016)   VALUE "OITO          05".     
           05  FILLER        PIC X(016)   VALUE "NOVE          05".     
           05  FILLER        PIC X(016)   VALUE "DEZ           04".     
           05  FILLER        PIC X(016)   VALUE "ONZE          05".     
           05  FILLER        PIC X(016)   VALUE "DOZE          05".     
           05  FILLER        PIC X(016)   VALUE "TREZE         06".     
           05  FILLER        PIC X(016)   VALUE "QUATORZE      09".     
           05  FILLER        PIC X(016)   VALUE "QUINZE        07".     
           05  FILLER        PIC X(016)   VALUE "DEZESSEIS     10".     
           05  FILLER        PIC X(016)   VALUE "DEZESSETE     10".     
           05  FILLER        PIC X(016)   VALUE "DEZOITO       08".     
           05  FILLER        PIC X(016)   VALUE "DEZENOVE      09".     
           05  FILLER        PIC X(016)   VALUE "VINTE         06".     
           05  FILLER        PIC X(016)   VALUE "TRINTA        07".     
           05  FILLER        PIC X(016)   VALUE "QUARENTA      09".     
           05  FILLER        PIC X(016)   VALUE "CINQUENTA     10".     
           05  FILLER        PIC X(016)   VALUE "SESSENTA      09".     
           05  FILLER        PIC X(016)   VALUE "SETENTA       08".     
           05  FILLER        PIC X(016)   VALUE "OITENTA       08".     
           05  FILLER        PIC X(016)   VALUE "NOVENTA       08".     
           05  FILLER        PIC X(016)   VALUE "CENTO         06".     
           05  FILLER        PIC X(016)   VALUE "DUZENTOS      09".     
           05  FILLER        PIC X(016)   VALUE "TREZENTOS     10".     
           05  FILLER        PIC X(016)   VALUE "QUATROCENTOS  13".     
           05  FILLER        PIC X(016)   VALUE "QUINHENTOS    11".     
           05  FILLER        PIC X(016)   VALUE "SEISCENTOS    11".     
           05  FILLER        PIC X(016)   VALUE "SETECENTOS    11".     
           05  FILLER        PIC X(016)   VALUE "OITOCENTOS    11".     
           05  FILLER        PIC X(016)   VALUE "NOVECENTOS    11".     
           05  FILLER        PIC X(016)   VALUE "CEM           04".     
           05  FILLER        PIC X(016)   VALUE "MIL           04".     
           05  FILLER        PIC X(016)   VALUE "MILHAO        07".     
           05  FILLER        PIC X(016)   VALUE "MILHOES       08".     
           05  FILLER        PIC X(016)   VALUE "REAL          05".     
           05  FILLER        PIC X(016)   VALUE "REAIS         06".     
           05  FILLER        PIC X(016)   VALUE "CENTAVO       08".     
           05  FILLER        PIC X(016)   VALUE "CENTAVOS      09".     
       01  TB                REDEFINES    TABELA.                       
           05  NOMES         OCCURS 44    TIMES.                        
               10  NOME      PIC X(014).                                
               10  QTDL      PIC 9(002).                                
                                                                        
       01  CONTADORES.                                                  
           05  INDI          PIC 9(002)   VALUE ZEROES.                 
           05  FLG           PIC 9(001)   VALUE ZEROES.                 
           05  AUX           PIC 9(003)   VALUE ZEROES.                 
           05  I             PIC 9(001)   VALUE ZEROES.                 
           05  J             PIC 9(002)   VALUE ZEROES.                 
           05  K             PIC 9(003)   VALUE ZEROES.                 
           05  X             PIC 9(002)   VALUE ZEROES.                 
           05  WS-CONTRO1    PIC 9(002)   VALUE ZEROES.                 
           05  WS-CONTRO2    PIC 9(002)   VALUE ZEROES.                 
                                                                        
       01  NUMERO.                                                      
           05  NUM           PIC 9(12)V99 VALUE ZEROES.                 
                                                                        
       01  NUM1              REDEFINES    NUMERO.                       
           05  N             PIC 9(003)   OCCURS 3 TIMES.               
           05  CENT          PIC 9(002).                                
                                                                        
       01  CAMPO.                                                       
           05  CMP1          PIC 9(001)   VALUE ZEROES.                 
           05  CMP2          PIC 9(002)   VALUE ZEROES.                 
           05  CMPOS         REDEFINES    CMP2.                         
               10  CMP3      PIC 9(001).                                
               10  CMP4      PIC 9(001).                                
                                                                        
       01  PALAVRA.                                                     
           05  PAL           PIC X(015)   VALUE SPACES.                 
                                                                        
       01  LETRAS            REDEFINES    PALAVRA.                      
           05  LET           PIC X(001)   OCCURS 15 TIMES.              
                                                                        
       01  EXTENSO.                                                     
           03  T-NUM         PIC 9(12)V99 VALUE ZEROES.                 
           03  ASTERIX.                                                 
               05 FILLER     PIC X(001)   VALUE SPACES.                 
               05 ASTERES    PIC X(199)   VALUE SPACES.                 
           03  EXT           REDEFINES    ASTERIX                       
                             PIC X(001)   OCCURS 200                    
                                          INDEXED BY CONTA.             
                                                                        
      *---------------------------------------------------------------- 
       LINKAGE SECTION.                                                 
      *---------------------------------------------------------------- 
                                                                        
       01  WL-PARAMETROS-EXT.                                           
           03  FILLER        PIC S9(04) COMP.                           
           03  WS-VALOR-EXT  PIC 9(16)V99.                              
           03  WS-EXTENSO    PIC X(200).                                
                                                                        
      *---------------------------------------------------------------- 
       PROCEDURE DIVISION USING WL-PARAMETROS-EXT.                      
      *---------------------------------------------------------------- 
                                                                        
           PERFORM P0000-INICIAL                                        
           PERFORM P1000-PRINCIPAL                                      
           PERFORM P9000-FINAL.                                         
                                                                        
      *---------------------------------------------------------------- 
       P0000-INICIAL.                                                   
      *---------------------------------------------------------------- 
                                                                        
           MOVE WS-VALOR-EXT TO T-NUM                                   
           MOVE SPACES TO WS-EXTENSO.                                   
                                                                        
      *---------------------------------------------------------------- 
       P1000-PRINCIPAL.                                                 
      *---------------------------------------------------------------- 
                                                                        
           MOVE T-NUM   TO NUM.                                         
           COMPUTE NUM = NUM * 1000                                     
           MOVE " "     TO ASTERIX                                      
           MOVE ASTERIX TO ASTERES                                      
           MOVE ZEROES  TO CONTADORES                                   
                                                                        
           PERFORM 3 TIMES                                              
                   ADD 1 TO J                                           
                   IF  N (J) NOT EQUAL ZEROES                           
                       ADD J TO FLG                                     
                       MOVE N (J) TO AUX                                
                   END-IF                                               
           END-PERFORM                                                  
                                                                        
           PERFORM P1100-EXTENSO THRU P1100-FIM UNTIL I EQUAL 4         
                                                                        
           PERFORM VARYING CONTA FROM 1 BY 1                            
                   UNTIL CONTA GREATER THAN 124                         
                   IF EXT (CONTA)     EQUAL SPACES AND                  
                      EXT (CONTA + 1) EQUAL SPACES                      
                      MOVE "*" TO EXT (CONTA)                           
                   END-IF                                               
           END-PERFORM.                                                 
                                                                        
      *---------------------------------------------------------------- 
       P1100-EXTENSO.                                                   
      *---------------------------------------------------------------- 
                                                                        
           MOVE ZEROES TO WS-CONTRO1                                    
                                                                        
           ADD 1 TO I                                                   
           IF  I EQUAL 4                                                
               PERFORM P1500-CENTAVO                                    
               MOVE 1 TO WS-CONTRO1                                     
           END-IF.                                                      
                                                                        
           IF WS-CONTRO1 EQUAL ZEROES                                   
              IF  N (I) GREATER THAN 0                                  
                  MOVE N (I) TO CAMPO                                   
                  PERFORM P1200-ESCREVE THRU P1200-FIM                  
              ELSE                                                      
                  MOVE 1 TO WS-CONTRO1                                  
              END-IF                                                    
           END-IF.                                                      
                                                                        
           IF WS-CONTRO1 EQUAL ZEROES                                   
              IF  I EQUAL 1                                             
                  PERFORM P1300-MILHAO                                  
              END-IF                                                    
           END-IF                                                       
                                                                        
           IF WS-CONTRO1 EQUAL ZEROES                                   
              IF  I EQUAL 2                                             
                  PERFORM P1400-MILHAR                                  
              END-IF                                                    
           END-IF.                                                      
                                                                        
       P1100-FIM.                                                       
           EXIT.                                                        
                                                                        
      *---------------------------------------------------------------- 
       P1200-ESCREVE.                                                   
      *---------------------------------------------------------------- 
                                                                        
           MOVE ZEROES TO WS-CONTRO2                                    
                                                                        
           IF  CAMPO EQUAL 100                                          
               MOVE 37 TO INDI                                          
               PERFORM P2200-MONTA                                      
               MOVE 1 TO WS-CONTRO2                                     
           END-IF.                                                      
                                                                        
           IF  WS-CONTRO2 EQUAL ZEROES                                  
               IF  CMP1 NOT EQUAL ZEROES                                
                   ADD 27 CMP1 GIVING INDI                              
                   PERFORM P2200-MONTA                                  
                   PERFORM P1800-TEST2                                  
               END-IF                                                   
           END-IF                                                       
                                                                        
           IF  WS-CONTRO2 EQUAL ZEROES                                  
               IF  CMP2 EQUAL ZEROES                                    
                   MOVE 1 TO WS-CONTRO2                                 
               END-IF                                                   
           END-IF                                                       
                                                                        
           IF  WS-CONTRO2 EQUAL ZEROES                                  
               IF  CMP2 LESS THAN 21                                    
                   MOVE CMP2 TO INDI                                    
                   PERFORM P2200-MONTA                                  
                   MOVE 1 TO WS-CONTRO2                                 
               ELSE                                                     
                   ADD 18 CMP3 GIVING INDI                              
                   PERFORM P2200-MONTA                                  
                   PERFORM P1900-TEST3                                  
               END-IF                                                   
           END-IF                                                       
                                                                        
           IF  WS-CONTRO2 EQUAL ZEROES                                  
               IF  CMP4 NOT EQUAL ZEROES                                
                   MOVE CMP4 TO INDI                                    
                   PERFORM P2200-MONTA                                  
               END-IF                                                   
           END-IF.                                                      
                                                                        
       P1200-FIM.                                                       
           EXIT.                                                        
                                                                        
      *---------------------------------------------------------------- 
       P1300-MILHAO.                                                    
      *---------------------------------------------------------------- 
                                                                        
           IF  N (1) EQUAL 1                                            
               MOVE 39 TO INDI                                          
           ELSE                                                         
               MOVE 40 TO INDI                                          
           END-IF                                                       
                                                                        
           PERFORM P2200-MONTA.                                         
                                                                        
           EVALUATE FLG                                                 
               WHEN 1                                                   
                    MOVE "DE" TO PALAVRA                                
                    PERFORM P2300-WRITER 3 TIMES                        
               WHEN 3                                                   
                    PERFORM P2100-MOVE-E                                
               WHEN 4                                                   
                    PERFORM P2000-TEST4                                 
               WHEN 6                                                   
                    SUBTRACT 1 FROM K                                   
                    MOVE "," TO PALAVRA                                 
                    PERFORM P2300-WRITER 2 TIMES                        
           END-EVALUATE.                                                
                                                                        
      *---------------------------------------------------------------- 
       P1400-MILHAR.                                                    
      *---------------------------------------------------------------- 
                                                                        
           MOVE 38 TO INDI                                              
           PERFORM P2200-MONTA                                          
                                                                        
           IF  FLG GREATER THAN 4                                       
               PERFORM P2000-TEST4                                      
           END-IF.                                                      
                                                                        
      *---------------------------------------------------------------- 
       P1500-CENTAVO.                                                   
      *---------------------------------------------------------------- 
                                                                        
           IF  FLG NOT EQUAL ZEROES                                     
               PERFORM P1600-CRUZEIRO                                   
           END-IF                                                       
                                                                        
           IF CENT NOT EQUAL ZEROES                                     
               MOVE 0 TO CMP1                                           
               MOVE CENT TO CMP2                                        
               PERFORM P1200-ESCREVE THRU P1200-FIM                     
               MOVE 43 TO INDI                                          
               PERFORM P2200-MONTA                                      
           END-IF                                                       
                                                                        
           IF  CENT GREATER THAN 1                                      
               PERFORM P1700-PLURAL                                     
           END-IF.                                                      
                                                                        
      *---------------------------------------------------------------- 
       P1600-CRUZEIRO.                                                  
      *---------------------------------------------------------------- 
                                                                        
           IF  AUX GREATER THAN 1                                       
               MOVE 42 TO INDI                                          
           ELSE                                                         
               MOVE 41 TO INDI                                          
           END-IF                                                       
                                                                        
           PERFORM P2200-MONTA.                                         
           IF  CENT NOT EQUAL ZEROES                                    
               PERFORM P2100-MOVE-E                                     
           END-IF.                                                      
                                                                        
      *---------------------------------------------------------------- 
       P1700-PLURAL.                                                    
      *---------------------------------------------------------------- 
                                                                        
           MOVE "S" TO EXT (K)                                          
           ADD 1    TO K                                                
           MOVE " " TO EXT (K).                                         
                                                                        
      *---------------------------------------------------------------- 
       P1800-TEST2.                                                     
      *---------------------------------------------------------------- 
                                                                        
           IF  CMP2 NOT EQUAL ZEROES                                    
               PERFORM P2100-MOVE-E                                     
           END-IF.                                                      
                                                                        
      *---------------------------------------------------------------- 
       P1900-TEST3.                                                     
      *---------------------------------------------------------------- 
                                                                        
           IF  CMP4 NOT EQUAL ZEROES                                    
               PERFORM P2100-MOVE-E                                     
           END-IF.                                                      
                                                                        
      *---------------------------------------------------------------- 
       P2000-TEST4.                                                     
      *---------------------------------------------------------------- 
                                                                        
           IF  CENT NOT EQUAL ZEROES                                    
               SUBTRACT 1 FROM K                                        
               MOVE "," TO PALAVRA                                      
               PERFORM P2300-WRITER 2 TIMES                             
           ELSE                                                         
               PERFORM P2100-MOVE-E                                     
           END-IF.                                                      
                                                                        
      *---------------------------------------------------------------- 
       P2100-MOVE-E.                                                    
      *---------------------------------------------------------------- 
                                                                        
           MOVE "E" TO PALAVRA                                          
           PERFORM P2300-WRITER 2 TIMES.                                
                                                                        
      *---------------------------------------------------------------- 
       P2200-MONTA.                                                     
      *---------------------------------------------------------------- 
                                                                        
           MOVE 0           TO J                                        
           MOVE NOME (INDI) TO PALAVRA                                  
           MOVE QTDL (INDI) TO X                                        
           PERFORM P2300-WRITER X TIMES                                 
           MOVE 0           TO J.                                       
                                                                        
      *---------------------------------------------------------------- 
       P2300-WRITER.                                                    
      *---------------------------------------------------------------- 
                                                                        
           ADD 1        TO J                                            
           ADD 1        TO K                                            
           MOVE LET (J) TO EXT (K).                                     
                                                                        
      *---------------------------------------------------------------- 
       P9000-FINAL.                                                     
      *---------------------------------------------------------------- 
                                                                        
           MOVE FUNCTION LOWER-CASE (ASTERES) TO ASTERES                
           MOVE ASTERIX TO WS-EXTENSO.                                  
           GOBACK.