fork download
copy 
  1.          1         2         3         4         5         6         7   
  2. 123456789012345678901234567890123456789012345678901234567890123456789012
  3.  
  4.       *-----------------------------------------------------------------
  5.        IDENTIFICATION DIVISION.
  6.       *-----------------------------------------------------------------
  7.        PROGRAM-ID.       CADDIGIT.
  8.        AUTHOR.           CARLOS ALBERTO DORNELLES.
  9.       *-----------------------------------------------------------------
  10.       *  PROGRAMA      : CADDIGIT
  11.       *  OBJETIVO      : VERIFICA O DIGITO DO CPF CNPJ OU PIS/PSASEP
  12.       *  ANALISTA      : CARLOS ALBERTO DORNELLES
  13.       *  LINGUAGEM     : COBOL
  14.       *  MODO OPERACAO : BATCH
  15.       *  COMO USAR     : LKS-NUMERO-I ....: NUMERO INFORMADO
  16.       *                : LKS-NUMERO-F ....: NUMERO CALCULADO
  17.       *                : LKS-TIPO-CALCULO : CPF, CGC OU PIS
  18.       *                : LKS-ACAO ........: C - CALCULA
  19.       *                                     V - VERIFICA
  20.       *-----------------------------------------------------------------
  21.       *  VERSAO DD.MM.AAAA  HISTORICO/AUTOR
  22.       *  ------  ---------- ---------------
  23.       *    001  24.09.2004  PROGRAMA INICIAL
  24.       *-----------------------------------------------------------------
  25.  
  26.       *-----------------------------------------------------------------
  27.        ENVIRONMENT DIVISION.
  28.       *-----------------------------------------------------------------
  29.        CONFIGURATION SECTION.
  30.        SPECIAL-NAMES.    DECIMAL-POINT IS COMMA.
  31.        INPUT-OUTPUT SECTION.
  32.        FILE-CONTROL.
  33.  
  34.       *-----------------------------------------------------------------
  35.        DATA DIVISION.
  36.       *-----------------------------------------------------------------
  37.        FILE SECTION.
  38.  
  39.       *-----------------------------------------------------------------
  40.        WORKING-STORAGE SECTION.
  41.       *-----------------------------------------------------------------
  42.  
  43.        01  WS-AUXILIARES.
  44.            05 WSS-IND-N                  PIC 9(002)  VALUE ZEROES.
  45.            05 WSS-IND-O                  PIC 9(002)  VALUE ZEROES.
  46.            05 WSS-IND-P                  PIC 9(002)  VALUE ZEROES.
  47.            05 WSS-SOMA                   PIC 9(008)  VALUE ZEROES.
  48.            05 WSS-NUMERO                 PIC 9(015)  VALUE ZEROES.
  49.            05 WSS-NUMERO-R               REDEFINES WSS-NUMERO.
  50.               10  WSS-NUMERO-T           PIC 9(001)  OCCURS 15 TIMES.
  51.            05 WSS-PESOS                  PIC X(028)  VALUE SPACES.
  52.            05 WSS-PESOS-R                REDEFINES WSS-PESOS.
  53.               10  WSS-PESOS-T            PIC 9(002)  OCCURS 14 TIMES.
  54.            05 WSS-QUOCI                  PIC 9(008)  VALUE ZEROES.
  55.            05 WSS-RESTO                  PIC 9(008)  VALUE ZEROES.
  56.            05 WSS-MENSAGEM               PIC X(078)  VALUE SPACES.
  57.            05 WSS-PESOS-CPF              PIC X(028)  VALUE
  58.                                    '0000000011100908070605040302'.
  59.            05 WSS-PESOS-CGC              PIC X(028)  VALUE
  60.                                    '0706050403020908070605040302'.
  61.            05 WSS-PESOS-PIS              PIC X(028)  VALUE
  62.                                    '0000000003020908070605040302'.
  63.  
  64.       *-----------------------------------------------------------------
  65.        LINKAGE SECTION.
  66.       *-----------------------------------------------------------------
  67.  
  68.        01  LKS-PARAMETRO.
  69.            05 COMPRIMENTO                PIC S9(04) COMP.
  70.            05 LKS-NUMERO-I               PIC 9(015).
  71.            05 FILLER                     PIC X(001).
  72.            05 LKS-NUMERO-F               PIC 9(015).
  73.            05 FILLER                     PIC X(001).
  74.            05 LKS-TIPO-CALCULO           PIC X(003).
  75.            05 FILLER                     PIC X(001).
  76.            05 LKS-ACAO                   PIC X(001).
  77.            05 LKS-RETORNO                PIC 9(001).
  78.       *-----------------------------------------------------------------
  79.       * LKS-NUMERO-I     = número da ser informado
  80.       * LKS-NUMERO-F     = número retornado do programa
  81.       * LKS-TIPO-CALCULO = CPF ou CGC ou PIS
  82.       * LKS-ACAO         = C (calcula) V (verifica) 
  83.       * LKS-RETORNO      = 0 - codigo verificado está correto
  84.       *                  = 1 - LKS-TIPO-CALCULO está incorreto
  85.       *                  = 2 - LKS-ACAO está incorreta
  86.       *                  = 3 - código verificado está com erro	
  87.       *-----------------------------------------------------------------
  88.  
  89.       *-----------------------------------------------------------------
  90.        PROCEDURE DIVISION USING LKS-PARAMETRO.
  91.       *-----------------------------------------------------------------
  92.  
  93.            PERFORM P1000-INICIAL   THRU P1000-FIM
  94.            PERFORM P2000-PRINCIPAL THRU P2000-FIM
  95.            PERFORM P9500-FINAL     THRU P9500-FIM
  96.            GOBACK.
  97.  
  98.       *-----------------------------------------------------------------
  99.        P1000-INICIAL.
  100.       *-----------------------------------------------------------------
  101.  
  102.            MOVE ZEROES TO LKS-RETORNO  
  103.            EVALUATE TRUE
  104.               WHEN LKS-ACAO = 'C'
  105.                    EVALUATE LKS-TIPO-CALCULO
  106.                       WHEN 'CPF'
  107.                          MOVE LKS-NUMERO-I (07:09) TO WSS-NUMERO (05:09)
  108.                       WHEN 'CGC'
  109.                          MOVE LKS-NUMERO-I (03:13) TO WSS-NUMERO (01:13)
  110.                       WHEN 'PIS'
  111.                          MOVE LKS-NUMERO-I (06:10) TO WSS-NUMERO (05:10)
  112.                       WHEN OTHER
  113.                          MOVE 1 TO LKS-RETORNO 
  114.                          GOBACK
  115.                    END-EVALUATE
  116.               WHEN LKS-ACAO = 'V'
  117.                    EVALUATE LKS-TIPO-CALCULO
  118.                       WHEN 'CPF'
  119.                       WHEN 'CGC'
  120.                       WHEN 'PIS'
  121.                          MOVE LKS-NUMERO-I TO WSS-NUMERO
  122.                       WHEN OTHER
  123.                          MOVE 1 TO LKS-RETORNO 
  124.                          GOBACK
  125.                    END-EVALUATE
  126.               WHEN OTHER
  127.                    MOVE 2 TO LKS-RETORNO 
  128.                    GOBACK 
  129.            END-EVALUATE.
  130.  
  131.        P1000-FIM.
  132.            EXIT.
  133.  
  134.       *-----------------------------------------------------------------
  135.        P2000-PRINCIPAL.
  136.       *-----------------------------------------------------------------
  137.  
  138.            EVALUATE LKS-TIPO-CALCULO
  139.               WHEN 'CPF'
  140.                     PERFORM P2100-CALCULO-CPF THRU P2100-FIM
  141.               WHEN 'CGC'
  142.                     PERFORM P3100-CALCULO-CGC THRU P3100-FIM
  143.               WHEN  OTHER
  144.                     PERFORM P2400-CALCULO-PIS THRU P4100-FIM
  145.            END-EVALUATE.
  146.  
  147.        P2000-FIM.
  148.            EXIT.
  149.  
  150.       *-----------------------------------------------------------------
  151.        P2100-CALCULO-CPF.
  152.       *-----------------------------------------------------------------
  153.  
  154.            MOVE WSS-PESOS-CPF TO WSS-PESOS
  155.            MOVE 05            TO WSS-IND-N
  156.            MOVE 06            TO WSS-IND-P
  157.            MOVE 13            TO WSS-IND-O
  158.            MOVE ZEROES        TO WSS-SOMA
  159.            PERFORM P7000-CALC-DIGITO-1 THRU P7000-FIM
  160.  
  161.            MOVE 05            TO WSS-IND-N
  162.            MOVE 05            TO WSS-IND-P
  163.            MOVE 14            TO WSS-IND-O
  164.            MOVE ZEROES        TO WSS-SOMA
  165.            PERFORM P8000-CALC-DIGITO-2 THRU P8000-FIM.
  166.  
  167.  
  168.        P2100-FIM.
  169.            EXIT.
  170.  
  171.       *-----------------------------------------------------------------
  172.        P3100-CALCULO-CGC.
  173.       *-----------------------------------------------------------------
  174.  
  175.            MOVE WSS-PESOS-CGC TO WSS-PESOS
  176.            MOVE 01            TO WSS-IND-N
  177.            MOVE 02            TO WSS-IND-P
  178.            MOVE 13            TO WSS-IND-O
  179.            MOVE ZEROES        TO WSS-SOMA
  180.            PERFORM P7000-CALC-DIGITO-1 THRU P7000-FIM
  181.  
  182.            MOVE 01            TO WSS-IND-N
  183.            MOVE 01            TO WSS-IND-P
  184.            MOVE 14            TO WSS-IND-O
  185.            MOVE ZEROES        TO WSS-SOMA
  186.            PERFORM P8000-CALC-DIGITO-2 THRU P8000-FIM.
  187.  
  188.        P3100-FIM.
  189.            EXIT.
  190.  
  191.       *-----------------------------------------------------------------
  192.        P2400-CALCULO-PIS.
  193.       *-----------------------------------------------------------------
  194.  
  195.            MOVE WSS-PESOS-PIS TO WSS-PESOS
  196.            MOVE 05            TO WSS-IND-N
  197.            MOVE 05            TO WSS-IND-P
  198.            MOVE 14            TO WSS-IND-O
  199.            MOVE ZEROES        TO WSS-SOMA
  200.            PERFORM P8000-CALC-DIGITO-2 THRU P8000-FIM.
  201.  
  202.        P4100-FIM.
  203.            EXIT.
  204.  
  205.       *-----------------------------------------------------------------
  206.        P7000-CALC-DIGITO-1.
  207.       *-----------------------------------------------------------------
  208.  
  209.            MOVE ZEROES TO WSS-SOMA
  210.            PERFORM UNTIL WSS-IND-N GREATER WSS-IND-O
  211.                    COMPUTE WSS-SOMA = WSS-SOMA +
  212.                                      (WSS-NUMERO-T (WSS-IND-N) *
  213.                                       WSS-PESOS-T  (WSS-IND-P))
  214.                    ADD 1 TO WSS-IND-N
  215.                             WSS-IND-P
  216.            END-PERFORM
  217.            DIVIDE WSS-SOMA BY 11 GIVING WSS-QUOCI REMAINDER WSS-RESTO
  218.            IF WSS-RESTO EQUAL 0 OR 1
  219.               MOVE ZEROES TO WSS-NUMERO-T (14)
  220.            ELSE
  221.               SUBTRACT WSS-RESTO FROM 11 GIVING WSS-NUMERO-T (14)
  222.            END-IF.
  223.  
  224.        P7000-FIM.
  225.            EXIT.
  226.  
  227.       *-----------------------------------------------------------------
  228.        P8000-CALC-DIGITO-2.
  229.       *-----------------------------------------------------------------
  230.  
  231.            MOVE ZEROES TO WSS-SOMA
  232.            PERFORM UNTIL WSS-IND-N GREATER WSS-IND-O
  233.                    COMPUTE WSS-SOMA = WSS-SOMA +
  234.                                      (WSS-NUMERO-T (WSS-IND-N) *
  235.                                       WSS-PESOS-T  (WSS-IND-P))
  236.                    ADD 1 TO WSS-IND-N
  237.                             WSS-IND-P
  238.            END-PERFORM
  239.            DIVIDE WSS-SOMA BY 11 GIVING WSS-QUOCI REMAINDER WSS-RESTO
  240.            IF WSS-RESTO EQUAL 0 OR 1
  241.               MOVE ZEROES TO WSS-NUMERO-T (15)
  242.            ELSE
  243.               SUBTRACT WSS-RESTO FROM 11 GIVING WSS-NUMERO-T (15)
  244.            END-IF.
  245.  
  246.        P8000-FIM.
  247.            EXIT.
  248.  
  249.       *-----------------------------------------------------------------
  250.        P9500-FINAL.
  251.       *-----------------------------------------------------------------
  252.  
  253.            MOVE WSS-NUMERO    TO LKS-NUMERO-F          
  254.            IF  LKS-ACAO EQUAL 'V'                      
  255.                IF LKS-NUMERO-I EQUAL LKS-NUMERO-F      
  256.                   MOVE 0 TO LKS-RETORNO                
  257.                ELSE                                    
  258.                   MOVE 3 TO LKS-RETORNO                
  259.                END-IF                                  
  260.            ELSE                                        
  261.                MOVE 0 TO LKS-RETORNO                   
  262.            END-IF.                                      
  263.  
  264.        P9500-FIM.
  265.            EXIT.
  266.  
  267.  
Compilation error #stdin compilation error #stdout 0s 0KB
comments (?)
stdin
copy 
Standard input is empty
compilation info 
prog.cob:1: Warning: Invalid indicator '7' at column 7
prog.cob:1: Error: syntax error, unexpected LITERAL, expecting PROGRAM_ID
stdout
copy 
Standard output is empty
https://ideone.com/ipn9w
language:
Cobol (gnucobol 2.2.0)
created:
14 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!