1 2 3 4 5 6 7 8
12345678901234567890123456789012345678901234567890123456789012345678901234567890
*-----------------------------------------------------------------
IDENTIFICATION DIVISION.
*-----------------------------------------------------------------
PROGRAM-ID. CADCABB.
AUTHOR. CARLOS ALBERTO DORNELLES.
*-----------------------------------------------------------------
* PROGRAMA : CADCABB
* OBJETIVO : Verifica o digito c/c do Banco do Brasil
* ANALISTA : CARLOS ALBERTO DORNELLES
* LINGUAGEM : COBOL
* MODO OPERACAO : BATCH
* COMO USAR : LKS-CODAGE-I ....: Codigo da agencia com digito
* : LKS-NUMCTA-I ....: Numero da conta com digito
*-----------------------------------------------------------------
* VERSAO DD.MM.AAAA HISTORICO/AUTOR
* ------ ---------- ---------------
* 001 16.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-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-CODAGE PIC X(005) VALUE ZEROES.
05 WSS-CODAGE-R REDEFINES WSS-CODAGE.
10 WSS-CODAGE-T PIC 9(001) OCCURS 05 TIMES.
05 WSS-NUMCTA PIC X(007) VALUE ZEROES.
05 WSS-NUMCTA-R REDEFINES WSS-NUMCTA.
10 WSS-NUMCTA-T PIC 9(001) OCCURS 07 TIMES.
05 WSS-PESOS PIC X(012) VALUE SPACES.
05 WSS-PESOS-R REDEFINES WSS-PESOS.
10 WSS-PESOS-T PIC 9(002) OCCURS 06 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-CTA PIC X(012) VALUE
'040506070809'.
*-----------------------------------------------------------------
LINKAGE SECTION.
*-----------------------------------------------------------------
01 LKS-PARAMETRO.
05 COMPRIMENTO PIC S9(04) COMP.
05 LKS-CODAGE-I PIC X(005).
05 FILLER PIC X(001).
05 LKS-NUMCTA-I PIC X(007).
05 FILLER PIC X(001).
05 LKS-RETORNO PIC 9(001).
*-----------------------------------------------------------------
* LKS-CODAGE-I = Numero da agencia com o digito
* LKS-NUMCTA-I = Numero da conta com o digito
* LKS-RETORNO = 0 - Codigo verificado esta correto
* = 1 - Codigo da agencia com erro
* = 2 - Codigo da conta com erro
* = 3 - Codigo da agencia e conta com erro
*-----------------------------------------------------------------
*-----------------------------------------------------------------
PROCEDURE DIVISION USING LKS-PARAMETRO.
*-----------------------------------------------------------------
PERFORM P1000-INICIAL THRU P1000-FIM
PERFORM P2000-PRINCIPAL THRU P2000-FIM
PERFORM P9500-FINAL THRU P9500-FIM
GOBACK.
*-----------------------------------------------------------------
P1000-INICIAL.
*-----------------------------------------------------------------
MOVE LKS-CODAGE-I TO WSS-CODAGE
MOVE LKS-NUMCTA-I TO WSS-NUMCTA
.
P1000-FIM.
EXIT.
*-----------------------------------------------------------------
P2000-PRINCIPAL.
*-----------------------------------------------------------------
MOVE WSS-PESOS-CTA TO WSS-PESOS
MOVE 01 TO WSS-IND-N
MOVE 03 TO WSS-IND-P
MOVE 04 TO WSS-IND-O
MOVE ZEROES TO WSS-SOMA
PERFORM P7000-CALC-CODAGE THRU P7000-FIM
MOVE WSS-PESOS-CTA TO WSS-PESOS
MOVE 01 TO WSS-IND-N
MOVE 01 TO WSS-IND-P
MOVE 06 TO WSS-IND-O
MOVE ZEROES TO WSS-SOMA
PERFORM P8000-CALC-NUMCTA THRU P8000-FIM.
P2000-FIM.
EXIT.
*-----------------------------------------------------------------
P7000-CALC-CODAGE.
*-----------------------------------------------------------------
MOVE ZEROES TO WSS-SOMA
PERFORM UNTIL WSS-IND-N GREATER WSS-IND-O
COMPUTE WSS-SOMA = WSS-SOMA +
(WSS-CODAGE-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
EVALUATE WSS-RESTO
WHEN 10
MOVE 'X' TO WSS-CODAGE (05:01)
WHEN 0
MOVE 0 TO WSS-CODAGE-T (05)
WHEN OTHER
MOVE WSS-RESTO TO WSS-CODAGE-T (05)
END-EVALUATE.
P7000-FIM.
EXIT.
*-----------------------------------------------------------------
P8000-CALC-NUMCTA.
*-----------------------------------------------------------------
MOVE ZEROES TO WSS-SOMA
PERFORM UNTIL WSS-IND-N GREATER WSS-IND-O
COMPUTE WSS-SOMA = WSS-SOMA +
(WSS-NUMCTA-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
EVALUATE WSS-RESTO
WHEN 10
MOVE 'X' TO WSS-NUMCTA (07:01)
WHEN 0
MOVE 0 TO WSS-NUMCTA-T (07)
WHEN OTHER
MOVE WSS-RESTO TO WSS-NUMCTA-T (07)
END-EVALUATE.
P8000-FIM.
EXIT.
*-----------------------------------------------------------------
P9500-FINAL.
*-----------------------------------------------------------------
EVALUATE LKS-CODAGE-I = WSS-CODAGE ALSO
LKS-NUMCTA-I = WSS-NUMCTA
WHEN TRUE ALSO TRUE
MOVE 0 TO LKS-RETORNO
WHEN FALSE ALSO TRUE
MOVE 1 TO LKS-RETORNO
WHEN TRUE ALSO FALSE
MOVE 2 TO LKS-RETORNO
WHEN FALSE ALSO FALSE
MOVE 3 TO LKS-RETORNO
END-EVALUATE.
P9500-FIM.
EXIT.
|
