1 2 3 4 5 6 7 8
12345678901234567890123456789012345678901234567890123456789012345678901234567890
*-----------------------------------------------------------------
IDENTIFICATION DIVISION.
*-----------------------------------------------------------------
PROGRAM-ID. CADCACGC.
AUTHOR. CARLOS ALBERTO DORNELLES.
*-----------------------------------------------------------------
* PROGRAMA : CADCACGC
* OBJETIVO : Calcula ou verifica o digito do CNPJ
* ANALISTA : CARLOS ALBERTO DORNELLES
* LINGUAGEM : COBOL
* MODO OPERACAO : BATCH
* COMO USAR : LKS-NUMERO-I ....: Numero informado
* : LKS-NUMERO-F ....: Numero calculado
* : LKS-ACAO ........: C - calcula
* V - verifica
*-----------------------------------------------------------------
* VERSAO DD.MM.AAAA HISTORICO/AUTOR
* ------ ---------- ---------------
* 001 17.11.2011 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-D PIC 9(002) VALUE ZEROES.
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-CGC PIC X(028) VALUE
'0706050403020908070605040302'.
*-----------------------------------------------------------------
LINKAGE SECTION.
*-----------------------------------------------------------------
01 LKS-PARAMETRO.
05 COMPRIMENTO PIC S9(04) COMP.
05 LKS-ACAO PIC X(001).
05 LKS-RETORNO PIC 9(001).
05 FILLER PIC X(001).
05 LKS-NUMERO-I PIC 9(015).
05 FILLER PIC X(001).
05 LKS-NUMERO-F PIC 9(015).
*-----------------------------------------------------------------
* LKS-ACAO = C - calcula o digito
* = V - verifica o digito
* LKS-RETORNO = 0 - Codigo verificado esta correto
* = 1 - LKS-ACAO esta incorreta
* = 2 - Codigo verificado esta com erro
* LKS-NUMERO-I = Numero informado ao programa
* LKS-NUMERO-F = Numero retornado do programa
*-----------------------------------------------------------------
*-----------------------------------------------------------------
PROCEDURE DIVISION USING LKS-PARAMETRO.
*-----------------------------------------------------------------
PERFORM P1000-INICIAL
PERFORM P2000-PRINCIPAL
PERFORM P9500-FINAL
GOBACK.
*-----------------------------------------------------------------
P1000-INICIAL.
*-----------------------------------------------------------------
EVALUATE TRUE
WHEN LKS-ACAO = 'C'
MOVE LKS-NUMERO-I (03:13) TO WSS-NUMERO (01:13)
WHEN LKS-ACAO = 'V'
MOVE LKS-NUMERO-I TO WSS-NUMERO
WHEN OTHER
MOVE 1 TO LKS-RETORNO
GOBACK
END-EVALUATE.
P1000-FIM.
EXIT.
*-----------------------------------------------------------------
P2000-PRINCIPAL.
*-----------------------------------------------------------------
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 14 TO WSS-IND-D
MOVE ZEROES TO WSS-SOMA
PERFORM P7000-CALC-DIGITO THRU P7000-FIM
MOVE 01 TO WSS-IND-N
MOVE 01 TO WSS-IND-P
MOVE 14 TO WSS-IND-O
MOVE 15 TO WSS-IND-D
MOVE ZEROES TO WSS-SOMA
PERFORM P7000-CALC-DIGITO THRU P7000-FIM.
P2000-FIM.
EXIT.
*-----------------------------------------------------------------
P7000-CALC-DIGITO.
*-----------------------------------------------------------------
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 (WSS-IND-D)
ELSE
SUBTRACT WSS-RESTO FROM 11 GIVING WSS-NUMERO-T (WSS-IND-D)
END-IF.
P7000-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 2 TO LKS-RETORNO
END-IF
ELSE
MOVE 0 TO LKS-RETORNO
END-IF
P9500-FIM.
EXIT.
|
