O programa abaixo listado tem por finalidade o cálculo ou a validação dos dígitos verificadores dos números do CPF, CNPJ ou PIS/PASEP.
O código pode ser copiado e colado dentro de um programa ou utilizá-lo como um outro a ser chamado usando a area da LINKAGE SECTION para o tratamento
do retorno.
A linha abaixo só deve ser usada para processamento BATCH (LINKAGE SECTION)
05 COMPRIMENTO PIC S9(04) COMP.
|
1 2 3 4 5 6 7
123456789012345678901234567890123456789012345678901234567890123456789012
*-----------------------------------------------------------------
IDENTIFICATION DIVISION.
*-----------------------------------------------------------------
PROGRAM-ID. CADDIGIT.
AUTHOR. CARLOS ALBERTO DORNELLES.
*-----------------------------------------------------------------
* PROGRAMA : CADDIGIT
* OBJETIVO : VERIFICA O DIGITO DO CPF CNPJ OU PIS/PSASEP
* ANALISTA : CARLOS ALBERTO DORNELLES
* LINGUAGEM : COBOL
* MODO OPERACAO : BATCH
* COMO USAR : LKS-NUMERO-I ....: NUMERO INFORMADO
* : LKS-NUMERO-F ....: NUMERO CALCULADO
* : LKS-TIPO-CALCULO : CPF, CGC OU PIS
* : LKS-ACAO ........: C - CALCULA
* V - VERIFICA
*-----------------------------------------------------------------
* VERSAO DD.MM.AAAA HISTORICO/AUTOR
* ------ ---------- ---------------
* 001 24.09.2004 PROGRAMA INICIAL
*-----------------------------------------------------------------
*-----------------------------------------------------------------
ENVIRONMENT DIVISION.
*-----------------------------------------------------------------
CONFIGURATION SECTION.
SPECIAL-NAMES. DECIMAL-POINT IS COMMA.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
*-----------------------------------------------------------------
DATA DIVISION.
*-----------------------------------------------------------------
FILE SECTION.
*-----------------------------------------------------------------
WORKING-STORAGE SECTION.
*-----------------------------------------------------------------
01 WS-AUXILIARES.
05 WSS-IND-N PIC 9(002) VALUE ZEROES.
05 WSS-IND-O PIC 9(002) VALUE ZEROES.
05 WSS-IND-P PIC 9(002) VALUE ZEROES.
05 WSS-SOMA PIC 9(008) VALUE ZEROES.
05 WSS-NUMERO PIC 9(015) VALUE ZEROES.
05 WSS-NUMERO-R REDEFINES WSS-NUMERO.
10 WSS-NUMERO-T PIC 9(001) OCCURS 15 TIMES.
05 WSS-PESOS PIC X(028) VALUE SPACES.
05 WSS-PESOS-R REDEFINES WSS-PESOS.
10 WSS-PESOS-T PIC 9(002) OCCURS 14 TIMES.
05 WSS-QUOCI PIC 9(008) VALUE ZEROES.
05 WSS-RESTO PIC 9(008) VALUE ZEROES.
05 WSS-MENSAGEM PIC X(078) VALUE SPACES.
05 WSS-PESOS-CPF PIC X(028) VALUE
'0000000011100908070605040302'.
05 WSS-PESOS-CGC PIC X(028) VALUE
'0706050403020908070605040302'.
05 WSS-PESOS-PIS PIC X(028) VALUE
'0000000003020908070605040302'.
*-----------------------------------------------------------------
LINKAGE SECTION.
*-----------------------------------------------------------------
01 LKS-PARAMETRO.
05 COMPRIMENTO PIC S9(04) COMP.
05 LKS-NUMERO-I PIC 9(015).
05 FILLER PIC X(001).
05 LKS-NUMERO-F PIC 9(015).
05 FILLER PIC X(001).
05 LKS-TIPO-CALCULO PIC X(003).
05 FILLER PIC X(001).
05 LKS-ACAO PIC X(001).
05 LKS-RETORNO PIC 9(001).
*-----------------------------------------------------------------
* LKS-NUMERO-I = número da ser informado
* LKS-NUMERO-F = número retornado do programa
* LKS-TIPO-CALCULO = CPF ou CGC ou PIS
* LKS-ACAO = C (calcula) V (verifica)
* LKS-RETORNO = 0 - codigo verificado está correto
* = 1 - LKS-TIPO-CALCULO está incorreto
* = 2 - LKS-ACAO está incorreta
* = 3 - código verificado está com erro
*-----------------------------------------------------------------
*-----------------------------------------------------------------
PROCEDURE DIVISION USING LKS-PARAMETRO.
*-----------------------------------------------------------------
PERFORM P1000-INICIAL
PERFORM P2000-PRINCIPAL
PERFORM P9500-FINAL
GOBACK.
*-----------------------------------------------------------------
P1000-INICIAL.
*-----------------------------------------------------------------
MOVE ZEROES TO LKS-RETORNO
EVALUATE TRUE
WHEN LKS-ACAO = 'C'
EVALUATE LKS-TIPO-CALCULO
WHEN 'CPF'
MOVE LKS-NUMERO-I (07:09) TO WSS-NUMERO (05:09)
WHEN 'CGC'
MOVE LKS-NUMERO-I (03:13) TO WSS-NUMERO (01:13)
WHEN 'PIS'
MOVE LKS-NUMERO-I (06:10) TO WSS-NUMERO (05:10)
WHEN OTHER
MOVE 1 TO LKS-RETORNO
GOBACK
END-EVALUATE
WHEN LKS-ACAO = 'V'
EVALUATE LKS-TIPO-CALCULO
WHEN 'CPF'
WHEN 'CGC'
WHEN 'PIS'
MOVE LKS-NUMERO-I TO WSS-NUMERO
WHEN OTHER
MOVE 1 TO LKS-RETORNO
GOBACK
END-EVALUATE
WHEN OTHER
MOVE 2 TO LKS-RETORNO
GOBACK
END-EVALUATE.
P1000-FIM.
EXIT.
*-----------------------------------------------------------------
P2000-PRINCIPAL.
*-----------------------------------------------------------------
EVALUATE LKS-TIPO-CALCULO
WHEN 'CPF'
PERFORM P2100-CALCULO-CPF THRU P2100-FIM
WHEN 'CGC'
PERFORM P3100-CALCULO-CGC THRU P3100-FIM
WHEN OTHER
PERFORM P2400-CALCULO-PIS THRU P4100-FIM
END-EVALUATE.
P2000-FIM.
EXIT.
*-----------------------------------------------------------------
P2100-CALCULO-CPF.
*-----------------------------------------------------------------
MOVE WSS-PESOS-CPF TO WSS-PESOS
MOVE 05 TO WSS-IND-N
MOVE 06 TO WSS-IND-P
MOVE 13 TO WSS-IND-O
MOVE ZEROES TO WSS-SOMA
PERFORM P7000-CALC-DIGITO-1 THRU P7000-FIM
MOVE 05 TO WSS-IND-N
MOVE 05 TO WSS-IND-P
MOVE 14 TO WSS-IND-O
MOVE ZEROES TO WSS-SOMA
PERFORM P8000-CALC-DIGITO-2 THRU P8000-FIM.
P2100-FIM.
EXIT.
*-----------------------------------------------------------------
P3100-CALCULO-CGC.
*-----------------------------------------------------------------
MOVE WSS-PESOS-CGC TO WSS-PESOS
MOVE 01 TO WSS-IND-N
MOVE 02 TO WSS-IND-P
MOVE 13 TO WSS-IND-O
MOVE ZEROES TO WSS-SOMA
PERFORM P7000-CALC-DIGITO-1 THRU P7000-FIM
MOVE 01 TO WSS-IND-N
MOVE 01 TO WSS-IND-P
MOVE 14 TO WSS-IND-O
MOVE ZEROES TO WSS-SOMA
PERFORM P8000-CALC-DIGITO-2 THRU P8000-FIM.
P3100-FIM.
EXIT.
*-----------------------------------------------------------------
P2400-CALCULO-PIS.
*-----------------------------------------------------------------
MOVE WSS-PESOS-PIS TO WSS-PESOS
MOVE 05 TO WSS-IND-N
MOVE 05 TO WSS-IND-P
MOVE 14 TO WSS-IND-O
MOVE ZEROES TO WSS-SOMA
PERFORM P8000-CALC-DIGITO-2 THRU P8000-FIM.
P4100-FIM.
EXIT.
*-----------------------------------------------------------------
P7000-CALC-DIGITO-1.
*-----------------------------------------------------------------
MOVE ZEROES TO WSS-SOMA
PERFORM UNTIL WSS-IND-N GREATER WSS-IND-O
COMPUTE WSS-SOMA = WSS-SOMA +
(WSS-NUMERO-T (WSS-IND-N) *
WSS-PESOS-T (WSS-IND-P))
ADD 1 TO WSS-IND-N
WSS-IND-P
END-PERFORM
DIVIDE WSS-SOMA BY 11 GIVING WSS-QUOCI REMAINDER WSS-RESTO
IF WSS-RESTO EQUAL 0 OR 1
MOVE ZEROES TO WSS-NUMERO-T (14)
ELSE
SUBTRACT WSS-RESTO FROM 11 GIVING WSS-NUMERO-T (14)
END-IF.
P7000-FIM.
EXIT.
*-----------------------------------------------------------------
P8000-CALC-DIGITO-2.
*-----------------------------------------------------------------
MOVE ZEROES TO WSS-SOMA
PERFORM UNTIL WSS-IND-N GREATER WSS-IND-O
COMPUTE WSS-SOMA = WSS-SOMA +
(WSS-NUMERO-T (WSS-IND-N) *
WSS-PESOS-T (WSS-IND-P))
ADD 1 TO WSS-IND-N
WSS-IND-P
END-PERFORM
DIVIDE WSS-SOMA BY 11 GIVING WSS-QUOCI REMAINDER WSS-RESTO
IF WSS-RESTO EQUAL 0 OR 1
MOVE ZEROES TO WSS-NUMERO-T (15)
ELSE
SUBTRACT WSS-RESTO FROM 11 GIVING WSS-NUMERO-T (15)
END-IF.
P8000-FIM.
EXIT.
*-----------------------------------------------------------------
P9500-FINAL.
*-----------------------------------------------------------------
MOVE WSS-NUMERO TO LKS-NUMERO-F
IF LKS-ACAO EQUAL 'V'
IF LKS-NUMERO-I EQUAL LKS-NUMERO-F
MOVE 0 TO LKS-RETORNO
ELSE
MOVE 3 TO LKS-RETORNO
END-IF
ELSE
MOVE 0 TO LKS-RETORNO
END-IF.
P9500-FIM.
EXIT.
|
