Skip to content

Instantly share code, notes, and snippets.

@dncrht

dncrht/Prv34915.cob

Last active July 6, 2016 09:32
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save dncrht/81d54c59986b95808fef5aee397dd54f to your computer and use it in GitHub Desktop.
Save dncrht/81d54c59986b95808fef5aee397dd54f to your computer and use it in GitHub Desktop.
Download ZIP
Raw
Prv34915.cob
*************************
IDENTIFICATION DIVISION.
*************************
PROGRAM-ID. PRV34915.
*****************************************************************
* *
* DEPARTAMENTO PRE-VALIDACION DE DECLARACIONES *
* DE DEL MODELO 349. EJERCICIO 2015 *
* INFORMATICA TRIBUTARIA *
* *
* NOMBRE DEL PROGRAMA : PRV34915. *
* OBJETIVO : PRE-VALIDACION SOPORTES *
* TIPO DE PROCESO : BATCH. *
* LENGUAJE : COBOL II *
* VERSION : 1.0 *
*****************************************************************
**********************
ENVIRONMENT DIVISION.
**********************
CONFIGURATION SECTION.
*----------------------
SPECIAL-NAMES.
DECIMAL-POINT IS COMMA.
INPUT-OUTPUT SECTION.
*---------------------
FILE-CONTROL.
*-------------
*--ENTRADA--*
SELECT CINTA ASSIGN TO CINTA
ORGANIZATION IS SEQUENTIAL
ACCESS IS SEQUENTIAL
FILE STATUS IS ST-CINTA.
*--SALIDA--*
SELECT SALIDA ASSIGN TO SALIDA
ORGANIZATION IS SEQUENTIAL
ACCESS IS SEQUENTIAL
FILE STATUS IS ST-SALIDA.
*--LISTADO DE IMPRESION--*
SELECT IMPRE ASSIGN TO IMPRE
ORGANIZATION IS SEQUENTIAL
ACCESS IS SEQUENTIAL
FILE STATUS IS ST-IMPRE.
DATA DIVISION.
***************
FILE SECTION.
*-------------
*-- FD PARA PRUEBAS EN DISCO
FD CINTA
LABEL RECORD STANDARD.
01 REG-CINTA.
02 REG-TIPO PIC X(01).
02 FILLER PIC X(499).
*-- FD PARA FICHERO DE SALIDA
FD SALIDA
LABEL RECORD STANDARD.
01 REG-SALIDA.
02 FILLER PIC X(828).
* ---- IMPRESORA DE DETALLE
FD IMPRE
LABEL RECORD OMITTED.
01 LINEA PIC X(132).
*------------------------
WORKING-STORAGE SECTION.
*------------------------
*-------CAMPOS DE TIPO 1-------*
*----------------------------------------------------------------*
* COPY CORRESPONDIENTE AL REGISTRO TIPO 1 DEL MODELO 349 *
* LONGITUD 500 *
*----------------------------------------------------------------*
01 CMOD3491.
02 TIPO1-COMUN.
03 MCMN-1-TIPO PIC X(1).
03 MCMN-1-IDEN.
04 MCMN-1-MOD PIC X(3).
04 MCMN-1-MOD-N REDEFINES MCMN-1-MOD PIC 9(3).
04 MCMN-1-EJER PIC X(4).
04 MCMN-1-EJER-N REDEFINES MCMN-1-EJER PIC 9(4).
04 MCMN-1-NIF PIC X(9).
03 MCMN-1-NOM PIC X(40).
03 MCMN-1-TSOP PIC X.
03 MCMN-1-RELAC.
04 MCMN-1-TFNO PIC X(9).
04 MCMN-1-TFNO-N REDEFINES MCMN-1-TFNO PIC 9(9).
04 MCMN-1-NOMREL PIC X(40).
03 MCMN-1-JUST PIC X(13).
03 MCMN-1-JUST-N REDEFINES MCMN-1-JUST PIC 9(13).
03 MCMN-1-COMPL PIC X.
03 MCMN-1-SUST PIC X.
03 MCMN-1-JUSTANT PIC X(13).
03 MCMN-1-JUSTANT-N REDEFINES MCMN-1-JUSTANT PIC 9(13).
02 TIPO1-349.
03 M349-1-PERIODO PIC X(2).
03 M349-1-TOTOPERA PIC X(9).
03 M349-1-TOTOPERA-N REDEFINES M349-1-TOTOPERA PIC 9(9).
03 M349-1-TOTIMPOPE PIC X(15).
03 M349-1-TOTIMPOPE-N REDEFINES M349-1-TOTIMPOPE PIC 9(15).
03 M349-1-TOTOPEREC PIC X(9).
03 M349-1-TOTOPEREC-N REDEFINES M349-1-TOTOPEREC PIC 9(9).
03 M349-1-TOTIMPRECT PIC X(15).
03 M349-1-TOTIMPRECT-N REDEFINES M349-1-TOTIMPRECT
PIC 9(15).
03 M349-1-INDPERIO PIC X.
02 M349-1-FILLER1 PIC X(204).
02 M349-1-NIFRPTE PIC X(9).
02 M349-1-FILLER2 PIC X(88).
02 M349-1-SELLO PIC X(13).
*-------CAMPOS DE TIPO 2-------*
*----------------------------------------------------------------*
* COPY CORRESPONDIENTE AL REGISTRO TIPO 2 DEL MODELO 349 *
* LONGITUD 500 *
*----------------------------------------------------------------*
01 CMOD3492.
03 M349-2-TIPO PIC 9(1).
03 M349-2-IDEN.
04 M349-2-MOD PIC X(3).
04 M349-2-MOD-N REDEFINES M349-2-MOD PIC 9(3).
04 M349-2-EJER PIC X(4).
04 M349-2-EJER-N REDEFINES M349-2-EJER PIC 9(4).
04 M349-2-NIF PIC X(9).
03 M349-2-FILLER PIC X(58).
03 M349-2-NIFOPERADOR.
04 M349-2-CODPAIS PIC X(2).
04 M349-2-NIFOPERA PIC X(15).
04 M349-2-NIFOPERA-N REDEFINES M349-2-NIFOPERA PIC 9(15).
03 M349-2-NOMPART PIC X(40).
03 M349-2-CLOPERAC PIC X(1).
03 M349-2-BIMPONI PIC X(13).
03 M349-2-BIMPONI-N REDEFINES M349-2-BIMPONI PIC 9(13).
03 M349-2-EJERCI PIC X(4).
03 M349-2-EJERCI-N REDEFINES M349-2-EJERCI PIC 9(4).
03 M349-2-PERIODO PIC X(2).
03 M349-2-BIRECT PIC X(13).
03 M349-2-BIRECT-N REDEFINES M349-2-BIRECT PIC 9(13).
03 M349-2-BIDECL PIC X(13).
03 M349-2-BIDECL-N REDEFINES M349-2-BIDECL PIC 9(13).
03 M349-2-FILLER PIC X(322).
01 WCMOD3492.
03 W-M349-2-TIPO PIC 9(1).
03 W-M349-2-IDEN.
04 W-M349-2-MOD PIC X(3).
04 W-M349-2-MOD-N REDEFINES W-M349-2-MOD PIC 9(3).
04 W-M349-2-EJER PIC X(4).
04 W-M349-2-EJER-N REDEFINES W-M349-2-EJER PIC 9(4).
04 W-M349-2-NIF PIC X(9).
03 W-M349-2-FILLER PIC X(58).
03 W-M349-2-NIFOPERADOR.
04 W-M349-2-CODPAIS PIC X(2).
04 W-M349-2-NIFOPERA PIC X(15).
04 W-M349-2-NIFOPERA-N REDEFINES
W-M349-2-NIFOPERA PIC 9(15).
03 W-M349-2-NOMPART PIC X(40).
03 W-M349-2-CLOPERAC PIC X(1).
03 W-M349-2-BIMPONI PIC X(13).
03 W-M349-2-BIMPONI-N REDEFINES W-M349-2-BIMPONI
PIC 9(13).
03 W-M349-2-EJERCI PIC X(4).
03 W-M349-2-EJERCI-N REDEFINES W-M349-2-EJERCI PIC 9(4).
03 W-M349-2-PERIODO PIC X(2).
03 W-M349-2-BIRECT PIC X(13).
03 W-M349-2-BIRECT-N REDEFINES W-M349-2-BIRECT PIC 9(13).
03 W-M349-2-BIDECL PIC X(13).
03 W-M349-2-BIDECL-N REDEFINES W-M349-2-BIDECL PIC 9(13).
03 W-M349-2-FILLER PIC X(322).
*-------REPLICA DE CAMPOS DE TIPO 1 PARA AUTOCORRECCION-------*
01 WCMOD3491.
*----CAMPOS COMUNES A TODOS LOS TIPOS 1----*
02 W-MCMN-1-TIPO PIC X(1).
02 W-MCMN-1-IDEN.
03 W-MCMN-1-MOD PIC X(3).
03 W-MCMN-1-MOD-N REDEFINES W-MCMN-1-MOD PIC 9(3).
03 W-MCMN-1-EJER PIC X(4).
03 W-MCMN-1-EJER-N REDEFINES W-MCMN-1-EJER PIC 9(4).
03 W-MCMN-1-NIF PIC X(9).
02 W-MCMN-1-NOM PIC X(40).
02 W-MCMN-1-TSOP PIC X.
02 W-MCMN-1-RELAC.
03 W-MCMN-1-TFNO PIC X(9).
03 W-MCMN-1-TFNO-N REDEFINES W-MCMN-1-TFNO PIC 9(9).
03 W-MCMN-1-NOMREL PIC X(40).
02 W-MCMN-1-JUST PIC X(13).
02 W-MCMN-1-JUST-N REDEFINES W-MCMN-1-JUST PIC 9(13).
02 W-MCMN-1-COMPL PIC X.
02 W-MCMN-1-SUST PIC X.
02 W-MCMN-1-JUSTANT PIC X(13).
02 W-MCMN-1-JUSTANT-N REDEFINES W-MCMN-1-JUSTANT PIC 9(13).
*----CAMPOS PARTICULARES DEL MODELO 349----*
02 W-M349-1-PERIODO PIC X(2).
02 W-M349-1-TOTOPERA PIC X(9).
02 W-M349-1-TOTOPERA-N REDEFINES W-M349-1-TOTOPERA PIC 9(9).
02 W-M349-1-TOTIMPOPE PIC X(15).
02 W-M349-1-TOTIMPOPE-N REDEFINES
W-M349-1-TOTIMPOPE PIC 9(15).
02 W-M349-1-TOTOPEREC PIC X(9).
02 W-M349-1-TOTOPEREC-N REDEFINES
W-M349-1-TOTOPEREC PIC 9(9).
02 W-M349-1-TOTIMPRECT PIC X(15).
02 W-M349-1-TOTIMPRECT-N REDEFINES
W-M349-1-TOTIMPRECT PIC 9(15).
02 W-M349-1-INDPERIO PIC X.
02 W-M349-1-FILLER PIC X(204).
02 W-M349-1-NIFRPTE PIC X(9).
02 W-M349-1-FILLER PIC X(88).
02 W-M349-1-SELLO PIC X(13).
*-----TABLAS DE ERRORES PROPIOS / INDICES USADOS / SWITCHES-----*
01 SW-YA PIC 9 VALUE 0.
01 SW-RECTIF PIC 9 VALUE 0.
*----PARA VALIDAR TIPO 1----*
01 ERRPROP1.
02 T-ERRPROP1 OCCURS 40.
03 CAMPO1 PIC 99.
03 ERROR1 PIC 99.
01 IEP1 PIC 99 VALUE 0.
*----PARA VALIDAR TIPO 2----*
01 ERRPROP2.
02 T-ERRPROP2 OCCURS 40.
03 CAMPO2 PIC 99.
03 ERROR2 PIC 99.
01 IEP2 PIC 99 VALUE 0.
*----AUXILIAR----*
01 ERRPROP-AUX.
02 T-ERRPROP-AUX OCCURS 40.
03 CAMPO PIC 99.
03 ERROR-X PIC 99.
01 IEP PIC 99 VALUE 0.
*----AUXILIAR-2--*
01 ERRPROP-AUX-2.
02 T-ERRPROP-AUX-2 OCCURS 40.
03 CAMPO-2 PIC 99.
03 ERROR-X-2 PIC 99.
01 IEP-2 PIC 99 VALUE 0.
*----AUXILIAR-TRABAJO----*
01 ERRPROP-TJO.
02 T-ERRPROP-TJO OCCURS 40.
03 CAMPO-TJO PIC 99.
03 ERROR-TJO PIC 99.
*-----TABLAS DE ERRORES ACUMULADOS / INDICES USADOS-----*
01 ERRACUM1.
02 T-ERRACUM1 OCCURS 90.
03 CAMACU1 PIC 99.
03 ERRACU1 PIC 99.
03 CONACU1 PIC 9(8).
01 IEA1 PIC 99 VALUE 0.
01 ERRACUM-IMP.
02 T-ERRACUM-IMP OCCURS 90.
03 CAMACU PIC 99.
03 ERRACU PIC 99.
03 CONACU PIC 9(8).
01 IEA PIC 99 VALUE 0.
01 ERRACUM-AUX.
02 T-ERRACUM-AUX OCCURS 90.
03 CAMACU-X PIC 99.
03 ERRACU-X PIC 99.
03 CONACU-X PIC 9(8).
01 IEAUX PIC 99 VALUE 0.
01 IMP PIC 99 VALUE 0.
*----DEFINICION DE VARIABLES-----*
01 IND-I PIC 9(3) VALUE 0.
01 TIPO-DEC PIC 9(3).
01 PRIMER-TIPO1 PIC XX VALUE 'SI'.
88 ES-PRIMER-TIPO1 VALUE 'SI'.
88 NO-PRIMER-TIPO1 VALUE 'NO'.
*-----INDICADORES-----*
01 SW-SECUENCIA PIC 9 VALUE 0.
01 SW-HAYOPERADOR PIC 9 VALUE 0.
01 SW-COLECTIVO PIC 9 VALUE 0.
01 SW-ENCONTRADO PIC 9 VALUE 0.
01 SW-COMPL PIC 9 VALUE 0.
01 SW-NOERRNIFVAC PIC 9 VALUE 0.
01 SW-REPRE PIC 9 VALUE 0.
01 SW-SUST PIC 9 VALUE 0.
01 SW-ERR07 PIC 9 VALUE 0.
01 SW-ERR06 PIC 9 VALUE 0.
01 SW-ERR10 PIC 9 VALUE 0.
01 SW-HAY09 PIC 9 VALUE 0.
01 SW-D2-TIP PIC 9 VALUE 0.
01 SW-C07T0 PIC 9 VALUE 0.
01 SW-C08T0 PIC 9 VALUE 0.
01 SW-C13T1 PIC 9 VALUE 0.
01 SW-C14T1 PIC 9 VALUE 0.
01 SW-C15T1 PIC 9 VALUE 0.
01 SW-C16T1 PIC 9 VALUE 0.
01 FIN-CINTA PIC 9 VALUE 0.
01 FIN-ERRORES PIC 9 VALUE 0.
01 NO-HAY-MAS PIC 9 VALUE 0.
01 SW-DESMARCADO PIC 9 VALUE 0.
01 SW-PROPAGACION PIC X VALUE SPACES.
*-----CONTADORES------*
01 CONT-LOWVALUES PIC 9(04) COMP VALUE 0.
01 CONTADOR PIC 9(15) VALUE 0.
01 CONTA-TIPO1-ACT PIC 9(15) VALUE 0.
01 CONTA-LINEAS PIC 9(02) VALUE 0.
01 CONTA-PAGINAS PIC 9(06) VALUE 0.
01 CONTA-TIPO1 PIC 9(15) VALUE 0.
01 CONTA-TIPO2 PIC 9(15) VALUE 0.
01 CONTADOR-NORMAL PIC 9(15) VALUE 0.
01 CONT-RECTIF PIC 9(15) VALUE 0.
*-----PARA FECHA DEL SISTEMA-----*
01 WCURRENT-DATE PIC 9(8) VALUE 0.
01 FECHA-EDIT REDEFINES WCURRENT-DATE.
02 FED-ANIO.
03 FED-SIGL PIC 9(2).
03 FED-ANO PIC 9(2).
02 FED-MES PIC 9(2).
02 FED-DIA PIC 9(2).
01 W-AAAA PIC 9(4) VALUE 0.
01 MEDIO PIC 9(4) VALUE 0.
01 FECHA-AAAA PIC 9(4) VALUE 0.
* -- AUXILIARES NIF COMUNITARIO
01 NIF-CEE-I.
02 NIF-CEROS-3I PIC X(03).
02 NIF-RESTO-I PIC X(12).
02 NIF-RESTO-IR REDEFINES NIF-RESTO-I.
04 POS-CEE-I PIC X OCCURS 12.
01 NIF-CEE-V.
02 NIF-CEROS-3V PIC X(03).
02 NIF-RESTO-V PIC X(12).
02 NIF-RESTO-VR REDEFINES NIF-RESTO-V.
04 POS-CEE-V PIC X OCCURS 12.
01 INDICE-NIF PIC 99.
01 INDICE-NIF-2 PIC 99.
*-----AUXILIARES PARA LA VALIDACION DE IMPORTES-----*
01 OPERADORES PIC 9(15) VALUE 0.
01 AUX-IMPOPE PIC 9(15) VALUE 0.
01 AUX-INMUEB PIC 9(15) VALUE 0.
01 AUX-OPERECT PIC S9(15) VALUE 0.
01 AUX-1-TOTIINMUEB PIC S9(15) VALUE 0.
01 AUX-IMPORTE PIC S9(15) VALUE 0.
01 AUX-1 PIC 9(15) VALUE 0.
01 AUX-2 PIC 9(15) VALUE 0.
01 ERROR-ISIN PIC 9 VALUE 0.
01 ERROR-PAIS PIC 9 VALUE 0.
01 SW-PAIS PIC 9 VALUE 0.
01 VER-PAIS PIC 9(3).
*-----REGISTRO DE SALIDA-----*
01 REGISTRO-SALIDA.
02 NUM-REG-SAL PIC 9(08).
02 REG-DECL-SAL PIC X(500).
02 ERRORES-PROPIOS-SAL.
03 T-ERRORES-PROPIOS-SAL OCCURS 40.
04 CAMPO-SAL PIC 99 VALUE 0.
04 ERROR-SAL PIC 99 VALUE 0.
*---OTROS---*
01 EJER-ACTUAL PIC X(4).
01 EJER-ACTUAL-N REDEFINES EJER-ACTUAL PIC 9(4).
01 MODE-ACTUAL PIC X(3).
01 MODE-ACTUAL-N REDEFINES MODE-ACTUAL PIC 9(3).
01 DECIMAL-OPER1 PIC S9(15)V99.
01 DECIMAL-OPER2 PIC S9(15)V99.
01 DECIMAL-OPER3 PIC S9(15)V99.
01 DECIMAL-OPRECT1 PIC S9(15)V99.
01 DECIMAL-OPRECT2 PIC S9(15)V99.
01 DECIMAL-OPRECT3 PIC S9(15)V99.
01 W-C-DIF4 PIC S9(11) VALUE ZEROS.
01 W-C-DIF5 PIC S9(11) VALUE ZEROS.
***************************************************
* CAMPOS PARA LA VALIDACION DEL NIF *
***************************************************
01 PROPIOS-NIF.
02 NUEVE-LETRAS.
03 OCHO-LETRAS PIC X(8).
03 FILLER REDEFINES OCHO-LETRAS.
04 PRIMERA-LETRA PIC X(1).
04 LETRAS-7 PIC X(7).
03 ULTIMA-LETRA PIC X(1).
02 ERROR-NIF PIC 9 VALUE 0.
02 ES-UN-NIF PIC 9 VALUE 0.
02 ES-UN-CIF PIC 9 VALUE 0.
01 PROPIOS-NIF-W.
02 ES-UN-NIF-W PIC 9 VALUE 0.
02 ES-UN-CIF-W PIC 9 VALUE 0.
02 ERROR-NIF-W PIC 9 VALUE 0.
01 CAMPOS-GTUCNIF.
02 TIPO-DNI PIC 9 VALUE 0.
02 TIPO-PER PIC X VALUE SPACES.
02 I01 PIC 99 VALUE 0.
02 I02 PIC 99 VALUE 0.
02 COCIENTE PIC 9(9) VALUE 0.
02 RESTO PIC 99 VALUE 0.
02 IND PIC 99 VALUE 0.
02 SW-CIFRA PIC 9 VALUE 0.
02 GRUPO-F PIC 9 VALUE 0.
02 GRUPO-J PIC 9 VALUE 0.
02 ESTADO PIC X VALUE SPACES.
02 T-IND PIC 99 VALUE ZEROS.
02 TAB01.
03 DNICIF PIC X(9).
02 TAB01R REDEFINES TAB01.
03 ELEM01 PIC X OCCURS 9 TIMES.
02 TAB01R1 REDEFINES TAB01.
03 LETCI PIC X.
03 NUMCI PIC X(7).
03 DCCI PIC X.
02 TAB01R2 REDEFINES TAB01.
03 FILLER PIC X.
03 ELEM01P PIC 9 OCCURS 7.
03 FILLER PIC X.
02 TAB01R3 REDEFINES TAB01.
03 FILLER PIC X.
03 NUMEXT PIC 9(7).
03 FILLER PIC X.
02 TAB01R4 REDEFINES TAB01.
03 FILLER PIC X.
03 NUMEXTA PIC X(8).
02 TAB01R5 REDEFINES TAB01.
03 FILLER PIC X.
03 NUMEXTP PIC 9(8).
02 TAB01R6 REDEFINES TAB01.
03 FILLER PIC X.
03 NUM-REP PIC X(8).
02 TAB01R7 REDEFINES TAB01.
03 NUMEXT-N PIC 9(8).
03 FILLER PIC X.
02 DIGCON-E.
03 DIGCON-EN PIC 9(8).
02 DIGCON-N REDEFINES DIGCON-E.
03 LETEXT-EN PIC 9.
03 NUMEXT-EN PIC 9(7).
02 TAB02.
03 ELEM02 PIC X OCCURS 9 TIMES.
02 TADCCI.
03 FILLER PIC X(20) VALUE '1234567890ABCDEFGHIJ'.
02 TADCCIR REDEFINES TADCCI.
03 TANUM PIC X OCCURS 10 TIMES.
03 TADCL PIC X OCCURS 10 TIMES.
02 TALET.
03 FILLER PIC X(23) VALUE 'TRWAGMYFPDXBNJZSQVHLCKE'.
02 TALETR REDEFINES TALET.
03 LETR PIC X OCCURS 23 TIMES.
02 TACIFRA.
03 CIFRA PIC 9 OCCURS 10 TIMES.
02 CAMPOS-AUX.
03 PRODUCT PIC 99 VALUE 0.
03 SUMATOT PIC 99 VALUE 0.
03 SUMAIMP PIC 99 VALUE 0.
03 SUMAPAR PIC 99 VALUE 0.
03 DCNUM PIC 9 VALUE 0.
03 DCLET PIC X VALUE SPACES.
02 CAMPOS-AUXR REDEFINES CAMPOS-AUX.
03 PROD1 PIC 9.
03 PROD2 PIC 9.
03 SUMT1 PIC 9.
03 SUMT2 PIC 9.
03 FILLER PIC X(6).
02 DNINUM.
03 NUMERO PIC 9(9).
*DATOS DE COMUNICACION
01 COM-GTUCNIF.
02 P1.
03 P1-DNICI PIC X(9).
03 P1-DNICIN PIC X(9).
03 P1-DC PIC X.
03 P1-TIPO PIC X.
03 P1-ESTADO PIC X.
********************FIN CAMPOS VALIDACION NIF********************
****************************************************************
* CAMPOS DE WORKING PARA LA RUTINA DE VALIDACION DE APELLI- *
* DOS Y NOMBRE -- APFINOMB -- *
****************************************************************
01 CAMPOS-APFINOMB.
02 INDI-2 PIC 9(02) VALUE 0.
02 INDICE PIC 9(02) VALUE 0.
02 DESDE PIC 9(02) VALUE 0.
02 BLANCOS PIC 9(02) VALUE 0.
02 CONTA-LETRAS PIC 9(02) VALUE 0.
02 NO-MAS-LETRAS PIC 9(01) VALUE 0.
02 PRIMERA-VEZ PIC 9(01) VALUE 0.
02 APFINOMB-NOM-AUX PIC X(40) VALUE SPACES.
*-- PARA OBTENER EL CODIGO NUMERICO EBCDIC.
02 DESTINO-C PIC 9(3) COMP.
02 FILLER REDEFINES DESTINO-C.
03 DESTINO-1 PIC X(01).
03 DESTINO-2 PIC X(01).
*-- TABLA DE TRABAJO.
02 NOMBRE-T PIC X(40).
02 FILLER REDEFINES NOMBRE-T.
03 TABLA-T OCCURS 40.
04 LETRA-T PIC X(01).
*-- PARA VOLCADO DE INFORMACION
02 APFINOMB-W-CAMPOS-PASO PIC X(90).
*--AREA DE COMUNICACION
01 COM-APFINOMB.
02 APFINOMB-W-CAMPOS-PASO.
03 APFINOMB-CAMPOS-ENTRADA.
04 APFINOMB-NOMBRE-E PIC X(40).
04 FILLER REDEFINES APFINOMB-NOMBRE-E.
05 APFINOMB-TABLA-E OCCURS 40.
06 APFINOMB-LETRA-E PIC X(01).
04 APFINOMB-OPCION-E PIC X(01).
03 APFINOMB-CAMPOS-SALIDA.
04 APFINOMB-NOMBRE-S PIC X(40).
04 FILLER REDEFINES APFINOMB-NOMBRE-S.
05 APFINOMB-TABLA-S OCCURS 40.
06 APFINOMB-LETRA-S PIC X(01).
04 APFINOMB-TRES-LETRAS-S PIC X(03).
04 FILLER REDEFINES APFINOMB-TRES-LETRAS-S.
05 APFINOMB-LETRAS3 OCCURS 3 PIC X(01).
04 APFINOMB-NUMERO-PALABRAS-S PIC 9(02).
04 APFINOMB-RETORNO-S PIC 9(02).
04 APFINOMB-VACIO PIC X(01).
*-- AUXILIARES PARA CONTAR PALABRAS DEL NOMBRE (SI ES UN C.I.)
*-- Y DAR ERROR DE FORMATO
01 CAMPOS-CONTAR-PALABRAS.
02 W-TABLA40 PIC X(40).
02 FILLER REDEFINES W-TABLA40.
03 E-TABLA40 PIC X OCCURS 40.
02 SW-NUMERO PIC 9 VALUE 0.
02 CON-PAL PIC 99 VALUE 0.
02 INDCMN PIC 99 VALUE 0.
02 SW-FORMATO PIC 9 VALUE 0.
**************FIN CAMPOS VALIDACION NOMBRE************************
******************************************************************
**************CAMPOS DE LA RUTINA VICENVAT PARA NIF COMUNITARIO **
*--
77 W-PARRAFO PIC X(40) VALUE SPACES.
77 W-LON-ENTRADA PIC S9(9) COMP.
77 W-LON-PRUEBA PIC S9(9) COMP.
77 W-NUM-CEROS PIC S9(9) COMP.
77 W-CADENA-CEROS PIC X(15) VALUE ALL '0'.
77 W-FILA PIC S9(9) VALUE 0.
77 W-COLUMNA PIC S9(9) VALUE 0.
77 W-IND PIC S9(9) VALUE 0.
*--TABLA DE POSIBLES LONGITUDES DE NVAT SEGUN PAIS--
01 F-TABLA-CODPAIS.
03 FILLER PIC X(28) VALUE 'ATBEBGCYCZDEDKEEELESFIFRGBHR'.
03 FILLER PIC X(28) VALUE 'HUIEITLTLULVMTNLPLPTROSESISK'.
01 W-TABLA-CODPAIS REDEFINES F-TABLA-CODPAIS.
03 W-COD-PAIS PIC X(2) OCCURS 28.
01 F-TABLA-MAXIND.
03 FILLER PIC X(28) VALUE '0101020103010101010101010301'.
03 FILLER PIC X(28) VALUE '0102010201010101010109010101'.
01 W-TABLA-MAXIND REDEFINES F-TABLA-MAXIND.
03 W-MAX-IND PIC 99 OCCURS 28.
01 F-TABLA-LONNVAT.
03 FILLER PIC X(20) VALUE '09999999999999999999'.
03 FILLER PIC X(20) VALUE '10999999999999999999'.
03 FILLER PIC X(20) VALUE '09109999999999999999'.
03 FILLER PIC X(20) VALUE '09999999999999999999'.
03 FILLER PIC X(20) VALUE '08091099999999999999'.
03 FILLER PIC X(20) VALUE '09999999999999999999'.
03 FILLER PIC X(20) VALUE '08999999999999999999'.
03 FILLER PIC X(20) VALUE '09999999999999999999'.
03 FILLER PIC X(20) VALUE '09999999999999999999'.
03 FILLER PIC X(20) VALUE '09999999999999999999'.
03 FILLER PIC X(20) VALUE '08999999999999999999'.
03 FILLER PIC X(20) VALUE '11999999999999999999'.
03 FILLER PIC X(20) VALUE '05091299999999999999'.
03 FILLER PIC X(20) VALUE '11999999999999999999'.
03 FILLER PIC X(20) VALUE '08999999999999999999'.
03 FILLER PIC X(20) VALUE '08099999999999999999'.
03 FILLER PIC X(20) VALUE '11999999999999999999'.
03 FILLER PIC X(20) VALUE '09129999999999999999'.
03 FILLER PIC X(20) VALUE '08999999999999999999'.
03 FILLER PIC X(20) VALUE '11999999999999999999'.
03 FILLER PIC X(20) VALUE '08999999999999999999'.
03 FILLER PIC X(20) VALUE '12999999999999999999'.
03 FILLER PIC X(20) VALUE '10999999999999999999'.
03 FILLER PIC X(20) VALUE '09999999999999999999'.
03 FILLER PIC X(20) VALUE '02030405060708091099'.
03 FILLER PIC X(20) VALUE '12999999999999999999'.
03 FILLER PIC X(20) VALUE '08999999999999999999'.
03 FILLER PIC X(20) VALUE '10999999999999999999'.
01 W-TABLA-LONNVAT REDEFINES F-TABLA-LONNVAT.
03 X-LON-NVAT OCCURS 28.
05 W-LON-NVAT PIC 99 OCCURS 10.
*-------------
*--COMMAREAS--
*-------------
*
01 PARM-OPERCEE PIC X(18).
01 RDAT-OPERCEE REDEFINES PARM-OPERCEE.
03 P-OPE-ERROR PIC S9 COMP-3.
03 P-OPE-PAIS PIC XX.
03 P-OPE-NIVA PIC X(15).
*
01 DATOS-VICENVAT.
02 E-VICENVAT.
04 E-MODO PIC X.
04 E-PAIS PIC X(2).
04 M-NVAT PIC X(15).
04 T-NVAT REDEFINES M-NVAT PIC X OCCURS 15.
02 S-VICENVAT.
04 S-CODIGO-ERROR PIC 9.
04 S-LON-NVAT PIC 99.
*--CAMPOS PARA LA IMPRESION DE LAS HOJAS RESUMEN--*
01 CAMPOS-IMPRESION.
02 C1.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(21) VALUE SPACES.
03 F PIC X(30) VALUE SPACES.
03 F PIC X(30) VALUE 'OPERACIONES INTRACOMUNITARIAS '.
03 F PIC X(26) VALUE SPACES.
03 F PIC X(10) VALUE SPACES.
02 C2.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(07) VALUE 'FECHA: '.
03 C-DIA PIC 9(02).
03 F PIC X VALUE '-'.
03 C-MES PIC 9(02).
03 F PIC X VALUE '-'.
03 C-ANIO PIC 9(04).
03 F PIC X(25) VALUE SPACES.
03 F PIC X(24) VALUE ' MODELO 349 - EJERCICIO '.
03 C-ANIOEJ PIC 9(04).
03 F PIC X(3) VALUE SPACES.
03 F PIC X(07) VALUE 'PERIODO'.
03 F PIC X(02) VALUE spaces.
03 C-PERIODO PIC X(02).
03 F PIC X(31) VALUE SPACES.
03 F PIC X(09) VALUE ' PAGINA: '.
03 C-PAGINA PIC ZZZ.ZZ9.
03 F PIC X(05) VALUE SPACES.
02 C3.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(38) VALUE SPACES.
03 F PIC X(30) VALUE ' PREVALIDACION DE SOPORTES SEG'.
03 F PIC X(30) VALUE 'UN CRITERIOS A.E.A.T. '.
03 F PIC X(33) VALUE SPACES.
02 C4.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(38) VALUE SPACES.
03 F PIC X(30) VALUE ' -----------------------------'.
03 F PIC X(30) VALUE '--------------------- '.
03 F PIC X(33) VALUE SPACES.
02 C5.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(30) VALUE 'DATOS DEL PRESENTADOR (TIPO 0)'.
03 F PIC X(101) VALUE SPACES.
02 C5-BIS.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(30) VALUE 'DATOS DEL DECLARANTE (TIPO 1) '.
03 F PIC X(101) VALUE SPACES.
02 C5-BIS-EURO.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(30) VALUE 'DATOS DEL DECLARANTE (TIPO 1) '.
03 F PIC X(63) VALUE SPACES.
03 F PIC X(08) VALUE ' EUROS'.
03 F PIC X(30) VALUE SPACES.
02 C6.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(07) VALUE ' MODELO'.
03 F PIC X(10) VALUE ' EJERCICIO'.
03 F PIC X(10) VALUE ' N.I.F. '.
03 F PIC X(30) VALUE ' APELLIDOS Y NOMBRE O RAZON '.
03 F PIC X(30) VALUE 'SOCIAL '.
03 F PIC X(43) VALUE SPACES.
02 C6-BIS.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(07) VALUE ' MODELO'.
03 F PIC X(10) VALUE ' EJERCICIO'.
03 F PIC X(10) VALUE ' N.I.F. '.
03 F PIC X(30) VALUE ' APELLIDOS Y NOMBRE O RAZON '.
03 F PIC X(15) VALUE 'SOCIAL '.
03 F PIC X(18) VALUE 'N. IDENTIFICATIVO.'.
03 F PIC X(40) VALUE SPACES.
02 C7.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(07) VALUE ' ------'.
03 F PIC X(10) VALUE ' ---------'.
03 F PIC X(10) VALUE ' -------- '.
03 F PIC X(30) VALUE ' -----------------------------'.
03 F PIC X(30) VALUE '--------- '.
03 F PIC X(43) VALUE SPACES.
02 C7-BIS.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(07) VALUE ' ------'.
03 F PIC X(10) VALUE ' ---------'.
03 F PIC X(10) VALUE ' -------- '.
03 F PIC X(30) VALUE ' -----------------------------'.
03 F PIC X(14) VALUE '--------- '.
03 F PIC X(20) VALUE '--------------------'.
03 F PIC X(39) VALUE SPACES.
02 DET1.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(04) VALUE SPACES.
03 D1-MOD PIC X(03).
03 F PIC X(05) VALUE SPACES.
03 D1-EJER PIC 9(04).
03 F PIC X(03) VALUE SPACES.
03 D1-NIF PIC X(09).
03 F PIC X(01) VALUE SPACES.
03 D1-NOM PIC X(40).
03 F PIC X(62) VALUE SPACES.
02 DET1-BIS.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(04) VALUE SPACES.
03 D1-MOD1 PIC X(03).
03 F PIC X(05) VALUE SPACES.
03 D1-EJER1 PIC 9(04).
03 F PIC X(03) VALUE SPACES.
03 D1-NIF1 PIC X(09).
03 F PIC X(01) VALUE SPACES.
03 D1-NOM1 PIC X(40).
03 F PIC X(06) VALUE SPACES.
03 D1-JUS1 PIC X(13).
03 F PIC X(45) VALUE SPACES.
02 C8.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(47) VALUE SPACES.
03 F PIC X(22) VALUE ' --- DECLARADOS ---- '.
03 F PIC X(24) VALUE ' ----- CALCULADOS ----- '.
03 F PIC X(38) VALUE SPACES.
02 C8-BIS.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(47) VALUE SPACES.
03 F PIC X(22) VALUE ' --- DECLARADOS ---- '.
03 F PIC X(22) VALUE ' --- CALCULADOS ---- '.
03 F PIC X(40) VALUE SPACES.
02 C9.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(47) VALUE SPACES.
03 F PIC X(22) VALUE ' EN REGISTRO TIPO 1 '.
03 F PIC X(20) VALUE ' ACUMULADOS TIPO 2 '.
03 F PIC X(06) VALUE SPACES.
03 F PIC X(24) VALUE ' DIFERENCIAS '.
03 F PIC X(12) VALUE SPACES.
02 C9-BIS.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(47) VALUE SPACES.
03 F PIC X(22) VALUE ' EN REGISTRO TIPO 0 '.
03 F PIC X(24) VALUE ' ACUMULADOS TIPOS 1 Y 2 '.
03 F PIC X(03) VALUE SPACES.
03 F PIC X(20) VALUE ' DIFERENCIAS '.
03 F PIC X(15) VALUE SPACES.
02 C10.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(47) VALUE SPACES.
03 F PIC X(22) VALUE ' ------------------- '.
03 F PIC X(24) VALUE ' ---------------------- '.
03 F PIC X(02) VALUE SPACES.
03 F PIC X(24) VALUE ' --------------------'.
03 F PIC X(12) VALUE SPACES.
02 C10-BIS.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(47) VALUE SPACES.
03 F PIC X(22) VALUE ' ------------------- '.
03 F PIC X(20) VALUE ' -------------------'.
03 F PIC X(06) VALUE SPACES.
03 F PIC X(20) VALUE ' -------------------'.
03 F PIC X(16) VALUE SPACES.
02 C11.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(30) VALUE 'TOTAL DE DECLARANTES .........'.
03 F PIC X(23) VALUE '...............: '.
03 C-NRET0-X PIC X(11).
03 C-NRET0 REDEFINES C-NRET0-X PIC ZZZ.ZZZ.ZZ9.
03 F PIC X(13) VALUE SPACES.
03 C-NRET1 PIC ZZZ.ZZZ.ZZ9.
03 F PIC X(06) VALUE SPACES.
03 C-ERR1 PIC X(01).
03 F PIC X(5) VALUE SPACES.
03 C-DIF1-X PIC X(11).
03 C-DIF1 REDEFINES C-DIF1-X PIC ZZZ.ZZZ.ZZ9.
03 F PIC X(20) VALUE SPACES.
02 C11-BIS.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(30) VALUE 'N TOTAL OPERADORES INTRACOMUN'.
03 F PIC X(26) VALUE 'ITARIOS .......: '.
03 C-RET1-X PIC X(11).
03 C-RET1 REDEFINES C-RET1-X PIC ZZZ.ZZZ.ZZ9.
03 F PIC X(11) VALUE SPACES.
03 C-RET2-X PIC X(11).
03 C-RET2 REDEFINES C-RET2-X PIC ZZZ.ZZZ.ZZ9.
03 F PIC X(03) VALUE SPACES.
03 C-ERR3 PIC X(01).
03 F PIC X(11) VALUE SPACES.
03 C-DIF3-X PIC X(11).
03 C-DIF3 REDEFINES C-DIF3-X PIC ZZZ.ZZZ.ZZ9.
03 F PIC X(16) VALUE SPACES.
02 C12.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(30) VALUE 'TOTAL PERSONAS O ENTIDADES REL'.
03 F PIC X(23) VALUE 'ACIONADAS .....: '.
03 C-NPER0-X PIC X(11).
03 C-NPER0 REDEFINES C-NPER0-X PIC ZZZ.ZZZ.ZZ9.
03 F PIC X(13) VALUE SPACES.
03 C-NPER1 PIC ZZZ.ZZZ.ZZ9.
03 F PIC X(06) VALUE SPACES.
03 C-ERR2 PIC X(01).
03 F PIC X(5) VALUE SPACES.
03 C-DIF2-X PIC X(11).
03 C-DIF2 REDEFINES C-DIF2-X PIC ZZZ.ZZZ.ZZ9.
03 F PIC X(20) VALUE SPACES.
02 C12-EURO.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(30) VALUE 'IMPORTE OPERACIONES INTRACOMUN'.
03 F PIC X(17) VALUE 'ITARIAS .......: '.
03 C-IRET1-X-E PIC X(20).
03 C-IRET1-E REDEFINES C-IRET1-X-E
PIC Z.ZZZ.ZZZ.ZZZ.ZZ9,99.
03 F PIC X(02) VALUE SPACES.
03 C-IRET2-X-E PIC X(20).
03 C-IRET2-E REDEFINES C-IRET2-X-E
PIC Z.ZZZ.ZZZ.ZZZ.ZZ9,99.
03 F PIC X(03) VALUE SPACES.
03 C-ERR4-E PIC X(01).
03 F PIC X(02) VALUE SPACES.
03 C-DIF4-X-E PIC X(20).
03 C-DIF4-E REDEFINES C-DIF4-X-E
PIC Z.ZZZ.ZZZ.ZZZ.ZZ9,99.
03 F PIC X(16) VALUE SPACES.
02 C13-BIS.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(30) VALUE 'TOTAL OPERADORES INTRAC. CON R'.
03 F PIC X(26) VALUE 'ECTIFIC. ......: '.
03 C-INM1-X PIC X(11).
03 C-INM1 REDEFINES C-INM1-X PIC ZZZ.ZZZ.ZZ9.
03 F PIC X(11) VALUE SPACES.
03 C-INM2-X PIC X(11).
03 C-INM2 REDEFINES C-INM2-X PIC ZZZ.ZZZ.ZZ9.
03 F PIC X(03) VALUE SPACES.
03 C-ERR6 PIC X(01).
03 F PIC X(11) VALUE SPACES.
03 C-DIF6-X PIC X(11).
03 C-DIF6 REDEFINES C-DIF6-X PIC ZZZ.ZZZ.ZZ9.
03 F PIC X(16) VALUE SPACES.
02 C13-BIS2-EURO.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(29) VALUE 'IMPORTE DE LAS RECTIFICACIONE'.
03 F PIC X(18) VALUE 'S ..............: '.
03 C-IIINMUEB1-X-E PIC X(20).
03 C-IIINMUEB1-E REDEFINES C-IIINMUEB1-X-E
PIC Z.ZZZ.ZZZ.ZZZ.ZZ9,99.
03 F PIC X(02) VALUE SPACES.
03 C-IIINMUEB2-X-E PIC X(20).
03 C-IIINMUEB2-E REDEFINES C-IIINMUEB2-X-E
PIC Z.ZZZ.ZZZ.ZZZ.ZZ9,99.
03 F PIC X(03) VALUE SPACES.
03 C-ERR5-E PIC X(01).
03 F PIC X(02) VALUE SPACES.
03 C-DIF5-X-E PIC X(20).
03 C-DIF5-E REDEFINES C-DIF5-X-E
PIC Z.ZZZ.ZZZ.ZZZ.ZZ9,99.
03 F PIC X(16) VALUE SPACES.
02 C14.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(09) VALUE SPACES.
03 F PIC X(110) VALUE ALL '-'.
03 F PIC X(12) VALUE SPACES.
02 C15.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(15) VALUE SPACES.
03 F PIC X(30) VALUE ' RESUMEN DE ERRORES DETECTADOS'.
03 F PIC X(30) VALUE ' EN LOS RETENEDORES (TIPOS 1) '.
03 F PIC X(30) VALUE 'Y EN LOS DECLARADOS (TIPOS 2)'.
03 F PIC X(26) VALUE SPACES.
02 C15-BIS.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(26) VALUE SPACES.
03 F PIC X(30) VALUE ' RESUMEN DE ERRORES DETECTADOS'.
03 F PIC X(30) VALUE ' EN LA DECLARACION (TIPOS 1 Y '.
03 F PIC X(03) VALUE '2) '.
03 F PIC X(41) VALUE SPACES.
02 C16.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(11) VALUE SPACES.
03 F PIC X(27) VALUE ' CODIGO ERROR CONTADOR '.
03 F PIC X(12) VALUE SPACES.
03 F PIC X(27) VALUE ' CODIGO ERROR CONTADOR '.
03 F PIC X(12) VALUE SPACES.
03 F PIC X(27) VALUE ' CODIGO ERROR CONTADOR '.
03 F PIC X(15) VALUE SPACES.
02 C17.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(11) VALUE SPACES.
03 F PIC X(27) VALUE ' ------------ ------------'.
03 F PIC X(12) VALUE SPACES.
03 F PIC X(27) VALUE ' ------------ ------------'.
03 F PIC X(12) VALUE SPACES.
03 F PIC X(27) VALUE ' ------------ ------------'.
03 F PIC X(15) VALUE SPACES.
02 DET2.
03 F PIC X(01) VALUE SPACES.
03 F PIC X(14) VALUE SPACES.
03 D2-TIP1-X PIC X(01).
03 D2-TIP1 REDEFINES D2-TIP1-X PIC 9(01).
03 F PIC X(01) VALUE SPACES.
03 D2-ERR1.
04 D2-ERR1-CAMPO-X PIC X(02).
04 D2-ERR1-CAMPO REDEFINES D2-ERR1-CAMPO-X PIC 9(02).
04 D2-ERR1-ERROR-X PIC X(02).
04 D2-ERR1-ERROR REDEFINES D2-ERR1-ERROR-X PIC 9(02).
03 F PIC X(07) VALUE SPACES.
03 D2-CON1-X PIC X(10).
03 D2-CON1 REDEFINES D2-CON1-X PIC ZZ.ZZZ.ZZ9.
03 F PIC X(15) VALUE SPACES.
03 D2-TIP2-X PIC X(01).
03 D2-TIP2 REDEFINES D2-TIP2-X PIC 9(01).
03 F PIC X(01) VALUE SPACES.
03 D2-ERR2.
04 D2-ERR2-CAMPO-X PIC X(02).
04 D2-ERR2-CAMPO REDEFINES D2-ERR2-CAMPO-X PIC 9(02).
04 D2-ERR2-ERROR-X PIC X(02).
04 D2-ERR2-ERROR REDEFINES D2-ERR2-ERROR-X PIC 9(02).
03 F PIC X(07) VALUE SPACES.
03 D2-CON2-X PIC X(10).
03 D2-CON2 REDEFINES D2-CON2-X PIC ZZ.ZZZ.ZZ9.
03 F PIC X(15) VALUE SPACES.
03 D2-TIP3-X PIC X(01).
03 D2-TIP3 REDEFINES D2-TIP3-X PIC 9(01).
03 F PIC X(01) VALUE SPACES.
03 D2-ERR3.
04 D2-ERR3-CAMPO-X PIC X(02).
04 D2-ERR3-CAMPO REDEFINES D2-ERR3-CAMPO-X PIC 9(02).
04 D2-ERR3-ERROR-X PIC X(02).
04 D2-ERR3-ERROR REDEFINES D2-ERR3-ERROR-X PIC 9(02).
03 F PIC X(07) VALUE SPACES.
03 D2-CON3-X PIC X(10).
03 D2-CON3 REDEFINES D2-CON3-X PIC ZZ.ZZZ.ZZ9.
03 F PIC X(18) VALUE SPACES.
02 DET3.
03 F PIC X(51) VALUE SPACES.
03 F PIC X(27) VALUE '---------------------------'.
03 F PIC X(54) VALUE SPACES.
02 DET4.
03 F PIC X(51) VALUE SPACES.
03 F PIC X(27) VALUE ' DECLARACION CORRECTA '.
03 F PIC X(54) VALUE SPACES.
02 DET5.
03 F PIC X(51) VALUE SPACES.
03 F PIC X(27) VALUE ' DECLARACION ERRONEA '.
03 F PIC X(54) VALUE SPACES.
02 DET6.
03 F PIC X(51) VALUE SPACES.
03 F PIC X(27) VALUE ' PRESENTACION CORRECTA '.
03 F PIC X(54) VALUE SPACES.
02 DET7.
03 F PIC X(51) VALUE SPACES.
03 F PIC X(27) VALUE ' PRESENTACION ERRONEA '.
03 F PIC X(54) VALUE SPACES.
*---FIN CAMPOS PARA IMPRESION DE HOJAS-RESUMEN---*
*-----FILE-STATUS-----*
01 ST-CINTA PIC X(2) VALUE ZEROS.
01 ST-SALIDA PIC X(2) VALUE ZEROS.
01 ST-IMPRE PIC X(2) VALUE ZEROS.
*-------------------
PROCEDURE DIVISION.
*-------------------
INICIO.
*-------*
******************************************************************
* CAMBIAR EL CONTENIDO DE EJER-ACTUAL *
* DEPENDIENDO DEL EJERCICIO *
******************************************************************
MOVE '2015' TO EJER-ACTUAL.
MOVE '349' TO MODE-ACTUAL.
INITIALIZE ERRACUM1 ERRACUM-IMP ERRACUM-AUX
ERRPROP1 ERRPROP2 ERRPROP-AUX
ERRPROP-AUX-2 ERRPROP-TJO.
OPEN INPUT CINTA
OUTPUT SALIDA
OUTPUT IMPRE.
IF ST-CINTA NOT = '00'
DISPLAY 'ERROR AL ABRIR CINTA. ERROR: ' ST-CINTA
GO TO FIN
ELSE
IF NOT(ST-SALIDA = '00' OR '35')
DISPLAY 'ERROR AL ABRIR EL FICHERO DE SALIDA. ERROR: '
ST-SALIDA
GO TO FIN
ELSE
PERFORM LEER-CINTA THRU LEER-CINTA-E
IF FIN-CINTA = 1
DISPLAY 'FICHERO VACIO '
PERFORM FIN
END-IF
IF FIN-CINTA = 0
PERFORM PRIMER-REGISTRO THRU PRIMER-REGISTRO-E
PERFORM RESTO-REGISTROS THRU RESTO-REGISTROS-E UNTIL
FIN-CINTA = 1 OR SW-SECUENCIA = 1
ELSE
PERFORM CUADRAR-TIPO1 THRU CUADRAR-TIPO1-E
IF CAMPO1(1) NOT = 0
MOVE CONTA-TIPO1-ACT TO NUM-REG-SAL
MOVE CMOD3491 TO REG-DECL-SAL
MOVE ERRPROP1 TO ERRORES-PROPIOS-SAL
PERFORM ESCRIBIR-SALIDA
THRU ESCRIBIR-SALIDA-E
END-IF
PERFORM IMPRIMIR1 THRU IMPRIMIR1-E
END-IF
END-IF
END-IF.
FIN.
*----*
CLOSE CINTA.
CLOSE SALIDA.
CLOSE IMPRE.
DISPLAY 'TIPOS 1 PROCESADOS:....' CONTA-TIPO1.
DISPLAY 'TIPOS 2 PROCESADOS:....' CONTA-TIPO2.
STOP RUN.
LEER-CINTA.
*-----------*
MOVE SPACES TO REG-CINTA.
READ CINTA AT END MOVE 1 TO FIN-CINTA.
IF ST-CINTA NOT = '00'
IF ST-CINTA = '10'
DISPLAY 'FIN DE CINTA.'
ELSE
DISPLAY 'ERROR AL LEER CINTA. ERROR: ' ST-CINTA
GO TO FIN
END-IF
ELSE
ADD 1 TO CONTADOR.
LEER-CINTA-E.
*-------------*
EXIT.
PRIMER-REGISTRO.
*----------------*
IF REG-TIPO = '1'
PERFORM VALIDAR-TIPO1 THRU VALIDAR-TIPO1-E
ELSE
MOVE 1 TO SW-SECUENCIA
ADD 1 TO IEP1
MOVE 01 TO CAMPO1(IEP1)
MOVE 18 TO ERROR1(IEP1)
MOVE CONTADOR TO NUM-REG-SAL
MOVE REG-CINTA TO REG-DECL-SAL
MOVE ERRPROP1 TO ERRORES-PROPIOS-SAL
PERFORM ESCRIBIR-SALIDA THRU ESCRIBIR-SALIDA-E.
PRIMER-REGISTRO-E.
*------------------*
EXIT.
RESTO-REGISTROS.
*----------------*
*---------SOPORTE INDIVIDUAL---------*
EVALUATE REG-TIPO
WHEN '0'
WHEN '1'
PERFORM ERROR-SECUENCIA2
PERFORM PROPAGAR-2-AL-1
WHEN OTHER
INITIALIZE AUX-IMPOPE AUX-OPERECT ERRACUM1
PERFORM VALIDAR-TIPO2 THRU VALIDAR-TIPO2-E
UNTIL FIN-CINTA = 1 OR REG-TIPO = '1'
OR REG-TIPO = '0'
IF REG-TIPO = 1
*-----------------AVISAR DE PRESENTACION INCORRECTA-----------*
ADD 1 TO IEP1
MOVE 01 TO CAMPO1(IEP1)
MOVE 15 TO ERROR1(IEP1)
PERFORM ERROR-SECUENCIA2
PERFORM PROPAGAR-2-AL-1
ELSE
IF REG-TIPO = '0'
PERFORM ERROR-SECUENCIA2
PERFORM PROPAGAR-2-AL-1
END-IF
END-IF
END-EVALUATE
PERFORM CUADRAR-TIPO1 THRU CUADRAR-TIPO1-E
IF CAMPO1(1) NOT = 0
MOVE CONTA-TIPO1-ACT TO NUM-REG-SAL
MOVE CMOD3491 TO REG-DECL-SAL
MOVE ERRPROP1 TO ERRORES-PROPIOS-SAL
PERFORM ESCRIBIR-SALIDA THRU ESCRIBIR-SALIDA-E
END-IF
PERFORM IMPRIMIR1 THRU IMPRIMIR1-E.
RESTO-REGISTROS-E.
*------------------*
EXIT.
******************************************************************
VALIDAR-TIPO1.
*-------------*
*--GUARDAMOS EL CONTADOR ACTUAL PARA LUEGO PODER PONERLO EN EL
*--REGISTRO DE SALIDA
MOVE CONTADOR TO CONTA-TIPO1-ACT.
MOVE REG-CINTA TO CMOD3491 WCMOD3491.
*--A�ADIMOS 1 AL CONTADOR DE TIPOS 1
ADD 1 TO CONTA-TIPO1.
*--INICIALIZAMOS LA TABLA DE ERRORES PROPIOS
INITIALIZE ERRPROP1 IEP1.
*--RELLENAMOS LA TABLA DE ERRORES PROPIOS...--*
*--...DE LOS CAMPOS COMUNES
PERFORM VALIDA-COMUN-TIPO1 THRU VALIDA-COMUN-TIPO1-E.
*--...DE LOS CAMPOS PARTICULARES DEL MODELO
PERFORM VALIDA-TIPO1-349 THRU VALIDA-TIPO1-349-E.
INITIALIZE W-M349-1-TOTOPERA-N
W-M349-1-TOTIMPOPE-N
W-M349-1-TOTOPEREC-N
W-M349-1-TOTIMPRECT-N.
*--LEEMOS EL SIGUIENTE REGISTRO.
PERFORM LEER-CINTA THRU LEER-CINTA-E.
VALIDAR-TIPO1-E.
*---------------*
EXIT.
VALIDA-COMUN-TIPO1.
*-------------------*
******************************************************************
*****COPY DE LA VALIDACION DE LOS CAMPOS COMUNES DEL TIPO 1*******
******************************************************************
*----SW-COMPL: INDICADOR DE QUE COMPL ESTA A 'C'
*----SW-SUST : INDICADOR DE QUE SUST ESTA A 'S'
*----SW-ERR07: INDICADOR DE ERROR EN EL CAMPO 07
*----SW-HAY09: INDICADOR DE ERROR EN EL CAMPO 09
*----COMO SIEMPRE, LOS CAMPOS AUTOCORREGIDOS SE INICIALIZAN AL
* PRODUCIRSE UN ERROR DE TIPO 01
*----HAY QUE PASAR LAS POSICIONES 2 A 8 DEL REG TIPO 0
*----SE OBTIENE PARTE DE LA TABLA DE ERRORES PROPIOS, DEBIENDOSE
* COMPLETAR CON LA VALIDACION DE LOS CAMPOS PARTICULARES DE
* CADA MODELO.
*--BUSCAMOS LA PRIMERA OCURRENCIA VACIA DE LA TABLA--*
MOVE 0 TO SW-YA
PERFORM VARYING IEP1 FROM 1 BY 1 UNTIL IEP1 > 40 OR
SW-YA = 1
IF CAMPO1(IEP1) = 0
MOVE 1 TO SW-YA
COMPUTE IEP1 = IEP1 - 1
END-IF
END-PERFORM
COMPUTE IEP1 = IEP1 - 1.
* VALIDAMOS QUE NO VENGA NINGUN LOW-VALUES.
MOVE 0 TO TALLY.
INSPECT CMOD3491 TALLYING TALLY FOR ALL LOW-VALUES
MOVE TALLY TO CONT-LOWVALUES
IF CONT-LOWVALUES > 0
ADD 1 TO IEP1
MOVE 99 TO CAMPO1(IEP1)
MOVE 99 TO ERROR1(IEP1).
*----TIPO----*
*----HAY QUE VALIDARLO ANTES DE ENTRAR EN ESTE PARRAFO----*
*----MODELO----*
IF MCMN-1-MOD IS NOT NUMERIC
ADD 1 TO IEP1
MOVE 02 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
INITIALIZE W-MCMN-1-MOD-N
ELSE
IF MCMN-1-MOD NOT = MODE-ACTUAL AND
MCMN-1-MOD NOT = ZEROS
ADD 1 TO IEP1
MOVE 02 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
ELSE
IF MCMN-1-MOD-N = 0
ADD 1 TO IEP1
MOVE 02 TO CAMPO1(IEP1)
MOVE 03 TO ERROR1(IEP1).
*--EJERCICIO.(VARIAR EL EJERCICIO SEGUN EL A�O)
IF MCMN-1-EJER IS NOT NUMERIC
ADD 1 TO IEP1
MOVE 03 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
INITIALIZE W-MCMN-1-EJER-N
ELSE
IF MCMN-1-EJER NOT = EJER-ACTUAL AND MCMN-1-EJER-N NOT = 0
ADD 1 TO IEP1
MOVE 03 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
ELSE
IF MCMN-1-EJER-N = 0
ADD 1 TO IEP1
MOVE 03 TO CAMPO1(IEP1)
MOVE 03 TO ERROR1(IEP1).
*--NIF DEL DECLARANTE
IF NOT(MCMN-1-NIF = LOW-VALUES OR SPACES OR ZEROS)
INITIALIZE PROPIOS-NIF CAMPOS-GTUCNIF COM-GTUCNIF
MOVE MCMN-1-NIF TO NUEVE-LETRAS
PERFORM VALIDAR-NIF THRU VALIDAR-NIF-E
IF ERROR-NIF = 1
ADD 1 TO IEP1
MOVE 04 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
END-IF
ELSE
ADD 1 TO IEP1
MOVE 04 TO CAMPO1(IEP1)
MOVE 03 TO ERROR1(IEP1).
*--APELLIDOS Y NOMBRE/RAZON SOCIAL DEL RETENEDOR.
IF NOT(MCMN-1-NOM = SPACES OR LOW-VALUES)
MOVE MCMN-1-NOM TO APFINOMB-NOMBRE-E
PERFORM VALIDAR-NOMBRE THRU VALIDAR-NOMBRE-E
IF SW-FORMATO = 1
MOVE 0 TO SW-FORMATO
ADD 1 TO IEP1
MOVE 05 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
END-IF
ELSE
ADD 1 TO IEP1
MOVE 05 TO CAMPO1(IEP1)
MOVE 03 TO ERROR1(IEP1)
END-IF.
*-----TIPO DE SOPORTE DE PRESENTACION-----*
IF NOT(MCMN-1-TSOP = LOW-VALUES OR SPACES)
IF NOT(MCMN-1-TSOP = 'C' OR 'T')
ADD 1 TO IEP1
MOVE 06 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
END-IF
ELSE
ADD 1 TO IEP1
MOVE 06 TO CAMPO1(IEP1)
MOVE 03 TO ERROR1(IEP1).
*-----PERSONA CON LA QUE RELACIONARSE-TELEFONO-----*
*-----PERSONA CON LA QUE RELACIONARSE-APELLIDOS Y NOMBRE-----*
MOVE 0 TO SW-ERR07.
IF MCMN-1-TFNO IS NOT NUMERIC
INITIALIZE W-MCMN-1-TFNO-N
MOVE 1 TO SW-ERR07
ADD 1 TO IEP1
MOVE 07 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1).
IF NOT(MCMN-1-NOMREL = SPACES OR LOW-VALUES)
MOVE MCMN-1-NOMREL TO APFINOMB-NOMBRE-E
PERFORM PREV-APFINOMB THRU PREV-APFINOMB-E
*-----AQUI NO HACE FALTA VALIDAR-NOMBRE PORQUE NO SE CONTEMPLA
* LA POSIBILIDAD DE QUE SEA UNA PERSONA JURIDICA. BASTA CON IR
* A LA APFINOMB
IF APFINOMB-RETORNO-S NOT = 0 OR
APFINOMB-NUMERO-PALABRAS-S < 2
IF SW-ERR07 = 0
MOVE 1 TO SW-ERR07
ADD 1 TO IEP1
MOVE 07 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1).
IF SW-ERR07 = 0
IF (MCMN-1-TFNO = ZEROS) OR
(MCMN-1-NOMREL = SPACES OR LOW-VALUES)
ADD 1 TO IEP1
MOVE 07 TO CAMPO1(IEP1)
MOVE 03 TO ERROR1(IEP1).
*----NUMERO DE JUSTIFICANTE DE LA DECLARACION----*
IF ES-PRIMER-TIPO1
MOVE 'NO' TO PRIMER-TIPO1
MOVE MCMN-1-JUST-N(1:3) TO TIPO-DEC
END-IF
IF MCMN-1-JUST IS NOT NUMERIC
INITIALIZE W-MCMN-1-JUST-N
ADD 1 TO IEP1
MOVE 08 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
ELSE
IF MCMN-1-JUST-N(1:3) NOT = '349' AND
MCMN-1-JUST-N NOT = 0
ADD 1 TO IEP1
MOVE 08 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
ELSE
IF TIPO-DEC NOT = MCMN-1-JUST-N(1:3)
ADD 1 TO IEP1
MOVE 08 TO CAMPO1(IEP1)
MOVE 16 TO ERROR1(IEP1)
ELSE
IF MCMN-1-JUST-N = 0
ADD 1 TO IEP1
MOVE 08 TO CAMPO1(IEP1)
MOVE 03 TO ERROR1(IEP1).
*----DECLARACION COMPLEMENTARIA----*
MOVE 0 TO SW-COMPL
IF NOT(MCMN-1-COMPL = 'C' OR ' ')
ADD 1 TO IEP1
MOVE 09 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
MOVE 1 TO SW-HAY09
ELSE
IF MCMN-1-COMPL = 'C'
MOVE 1 TO SW-COMPL.
*----DECLARACION SUSTITUTIVA----*
MOVE 0 TO SW-SUST.
IF NOT(MCMN-1-SUST = 'S' OR ' ')
ADD 1 TO IEP1
MOVE 10 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
ELSE
IF MCMN-1-SUST = 'S'
MOVE 1 TO SW-SUST
IF SW-COMPL = 1
ADD 1 TO IEP1
MOVE 09 TO CAMPO1(IEP1)
MOVE 02 TO ERROR1(IEP1)
MOVE 1 TO SW-HAY09
ADD 1 TO IEP1
MOVE 10 TO CAMPO1(IEP1)
MOVE 02 TO ERROR1(IEP1).
*----NUMERO DE JUSTIFICANTE DE LA DECLARACION ANTERIOR
IF MCMN-1-JUSTANT IS NOT NUMERIC
INITIALIZE W-MCMN-1-JUSTANT-N
ADD 1 TO IEP1
MOVE 11 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
ELSE
IF MCMN-1-JUSTANT(1:3) NOT = '349' AND
MCMN-1-JUSTANT-N NOT = 0
ADD 1 TO IEP1
MOVE 11 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
ELSE
IF MCMN-1-JUSTANT NOT = ZEROS AND
MCMN-1-JUSTANT = MCMN-1-JUST
ADD 1 TO IEP1
MOVE 11 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
ELSE
IF MCMN-1-JUSTANT-N = 0
IF SW-SUST = 1
ADD 1 TO IEP1
MOVE 11 TO CAMPO1(IEP1)
MOVE 03 TO ERROR1(IEP1)
END-IF
ELSE
IF SW-COMPL = 1 OR SW-SUST = 0
IF SW-HAY09 = 0 AND SW-COMPL = 1
ADD 1 TO IEP1
MOVE 09 TO CAMPO1(IEP1)
MOVE 02 TO ERROR1(IEP1)
END-IF
ADD 1 TO IEP1
MOVE 11 TO CAMPO1(IEP1)
MOVE 02 TO ERROR1(IEP1).
VALIDA-COMUN-TIPO1-E.
*---------------------*
EXIT.
VALIDA-TIPO1-349.
*-----------------*
*----ESTAS SON LAS VALIDACIONES ESPECIFICAS DEL MODELO
*--BUSCAMOS LA PRIMERA OCURRENCIA VACIA DE LA TABLA--*
MOVE 0 TO SW-YA
PERFORM VARYING IEP1 FROM 1 BY 1 UNTIL IEP1 > 40 OR
SW-YA = 1
IF CAMPO1(IEP1) = 0
MOVE 1 TO SW-YA
COMPUTE IEP1 = IEP1 - 1
END-IF
END-PERFORM
COMPUTE IEP1 = IEP1 - 1.
INITIALIZE SW-C13T1 SW-C14T1 SW-C15T1 SW-C15T1.
IF NOT(M349-1-PERIODO = LOW-VALUES OR SPACES)
IF NOT(M349-1-PERIODO = '1T' OR '2T' OR '3T' OR '4T'
OR '0A' or '01' or '02' or '03'
OR '04' or '05' or '06' or '07'
OR '08' or '09' or '10' or '11'
OR '12')
ADD 1 TO IEP1
MOVE 12 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
END-IF
ELSE
ADD 1 TO IEP1
MOVE 12 TO CAMPO1(IEP1)
MOVE 03 TO ERROR1(IEP1).
*----TOTAL DE OPERADORES INTRACOMUNITARIOS------*
*----(AQUI NO SE VALIDA EL ERROR DE CUADRE)
MOVE 0 TO SW-C13T1.
IF M349-1-TOTOPERA NOT NUMERIC
MOVE 1 TO SW-C13T1
INITIALIZE W-M349-1-TOTOPERA-N
ADD 1 TO IEP1
MOVE 13 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
ELSE
IF M349-1-TOTOPERA-N = ZEROS
NEXT SENTENCE
ELSE
MOVE 1 TO SW-HAYOPERADOR
IF M349-1-TOTOPERA-N > 5000000
MOVE 1 TO SW-C13T1
ADD 1 TO IEP1
MOVE 13 TO CAMPO1(IEP1)
MOVE 04 TO ERROR1(IEP1).
*----IMPORTE DE LAS OPERACIONES INTRACOMUNITARIAS----*
IF M349-1-TOTIMPOPE IS NOT NUMERIC
INITIALIZE W-M349-1-TOTIMPOPE-N
MOVE 1 TO SW-C14T1
ADD 1 TO IEP1
MOVE 14 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
ELSE
IF M349-1-TOTIMPOPE > 1000000000000
MOVE 1 TO SW-C14T1
ADD 1 TO IEP1
MOVE 14 TO CAMPO1(IEP1)
MOVE 04 TO ERROR1(IEP1).
*----TOTAL DE OPERADORES INTRACOMUNITARIOS CON RECTIFICACIONES---*
MOVE 0 TO SW-C15T1.
IF M349-1-TOTOPEREC NOT NUMERIC
MOVE 1 TO SW-C15T1
INITIALIZE W-M349-1-TOTOPEREC-N
ADD 1 TO IEP1
MOVE 15 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
ELSE
IF M349-1-TOTOPEREC-N = ZEROS
NEXT SENTENCE
ELSE
MOVE 1 TO SW-HAYOPERADOR
IF M349-1-TOTOPEREC-N > 5000000
MOVE 1 TO SW-C15T1
ADD 1 TO IEP1
MOVE 15 TO CAMPO1(IEP1)
MOVE 04 TO ERROR1(IEP1)
END-IF
END-IF
END-IF.
*--COMPROBAMOS SI AL MENOS UNO DE LOS DOS TIPOS DE OPERADORES
*--TIENE CONTENIDO. SI LOS DOS ESTAN VACIOS DAMOS ERROR EN
*--LOS DOS CAMPOS DE OPERADORES (SIEMPRE QUE NO SE HAYA MARCADO
*--OTRO ERROR)--*
IF SW-HAYOPERADOR = 0
IF SW-C13T1 = 0 AND SW-C15T1 = 0
ADD 1 TO IEP1
MOVE 13 TO CAMPO1(IEP1)
MOVE 03 TO ERROR1(IEP1)
ADD 1 TO IEP1
MOVE 15 TO CAMPO1(IEP1)
MOVE 03 TO ERROR1(IEP1)
END-IF
END-IF.
*----IMPORTE DE LAS RECTIFICACIONES----*
*
IF M349-1-TOTIMPRECT NOT NUMERIC
INITIALIZE W-M349-1-TOTIMPRECT-N
MOVE 1 TO SW-C16T1
ADD 1 TO IEP1
MOVE 16 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
ELSE
IF M349-1-TOTIMPRECT > 1000000000000
MOVE 1 TO SW-C16T1
ADD 1 TO IEP1
MOVE 16 TO CAMPO1(IEP1)
MOVE 04 TO ERROR1(IEP1).
*----INDICADOR CAMBIO PERIODICIDAD EN LA OBLIGACION DE DECLARAR-*
IF NOT(M349-1-INDPERIO = SPACES)
IF M349-1-INDPERIO NOT = 'X'
ADD 1 TO IEP1
MOVE 17 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1).
*----CAMPO 18 SON ESPACIOS
*----NIF DEL REPRESENTANTE LEGAL
IF NOT(M349-1-NIFRPTE = LOW-VALUES OR SPACES OR ZEROS)
INITIALIZE PROPIOS-NIF CAMPOS-GTUCNIF COM-GTUCNIF
MOVE M349-1-NIFRPTE TO NUEVE-LETRAS
PERFORM VALIDAR-NIF THRU VALIDAR-NIF-E
IF ERROR-NIF = 1
ADD 1 TO IEP1
MOVE 19 TO CAMPO1(IEP1)
MOVE 01 TO ERROR1(IEP1)
ELSE
IF M349-1-NIFRPTE = MCMN-1-NIF
ADD 1 TO IEP1
MOVE 19 TO CAMPO1(IEP1)
MOVE 02 TO ERROR1(IEP1).
*--SI NO HA HABIDO ERRORES DE TIPO 01, INICIALIZAMOS EL AUTOCORR
IF CMOD3491 = WCMOD3491
INITIALIZE WCMOD3491.
VALIDA-TIPO1-349-E.
*-------------------*
EXIT.
******************************************************************
VALIDAR-TIPO2.
*--------------*
*--INICIALIZAMOS LA TABLA DE ERRORES PROPIOS Y SU CONTADOR
INITIALIZE ERRPROP2 IEP2.
*--A�ADIR 1 AL CONTADOR DE TIPOS 2.
ADD 1 TO CONTA-TIPO2.
MOVE REG-CINTA TO CMOD3492 WCMOD3492.
*--LLAMAMOS A LA RUTINA DE VALIDACION PROPIAMENTE DICHA:(GIRCA02S)
PERFORM VALIDAR-TIPO2-349.
*--ACUMULAMOS LOS IMPORTES DEL TIPO 2 EN EL AUTOCORR. DEL TIPO 1
*--Y A�ADIMOS UNO AL ACUMULADOR DE PERCEPTORES.
PERFORM ACUMULAR-IMPORTES.
IF CAMPO2(1) NOT = 0
MOVE CONTADOR TO NUM-REG-SAL
MOVE CMOD3492 TO REG-DECL-SAL
MOVE ERRPROP2 TO ERRORES-PROPIOS-SAL
PERFORM ESCRIBIR-SALIDA THRU ESCRIBIR-SALIDA-E
END-IF.
PERFORM PROPAGAR-2-AL-1.
PERFORM LEER-CINTA THRU LEER-CINTA-E.
VALIDAR-TIPO2-E.
*----------------*
EXIT.
******************************************************************
PROPAGAR-2-AL-1.
*----------------*
MOVE ERRPROP2 TO ERRPROP-AUX.
MOVE ERRACUM1 TO ERRACUM-AUX.
PERFORM PROPAGACION THRU PROPAGACION-E.
MOVE ERRACUM-AUX TO ERRACUM1.
ERROR-SECUENCIA2.
*-----------------*
IF CAMPO2(1) NOT = ZEROS
INITIALIZE IEP2 ERRPROP2
END-IF
MOVE 1 TO SW-SECUENCIA.
ADD 1 TO IEP2.
MOVE 01 TO CAMPO2(IEP2).
MOVE 18 TO ERROR2(IEP2).
MOVE CONTADOR TO NUM-REG-SAL.
MOVE REG-CINTA TO REG-DECL-SAL.
MOVE ERRPROP2 TO ERRORES-PROPIOS-SAL.
PERFORM ESCRIBIR-SALIDA THRU ESCRIBIR-SALIDA-E.
ERROR-SECUENCIA1.
*-----------------*
MOVE 1 TO SW-SECUENCIA.
ADD 1 TO IEP1.
MOVE 01 TO CAMPO1(IEP1).
MOVE 18 TO ERROR1(IEP1).
MOVE CONTADOR TO NUM-REG-SAL.
MOVE REG-CINTA TO REG-DECL-SAL.
MOVE ERRPROP1 TO ERRORES-PROPIOS-SAL.
PERFORM ESCRIBIR-SALIDA THRU ESCRIBIR-SALIDA-E.
******************************************************************
ACUMULAR-IMPORTES.
*------------------*(GIRCR04S)
*--ACUMULA LOS IMPORTES DEL TIPO 2 PARA AL FINAL CUADRAR CON LOS
*--DECLARADOS EN EL TIPO 1
*--TAMBIEN SUMA 1 AL NUMERO DE PERCEPTORES PARA CUADRAR CON LOS
*--DECLARADOS EN EL TIPO 1
*--DATOS A PASAR A ESTA RUTINA:
*-- *500 POSICIONES DEL TIPO 2 CORRECTO
*-- *500 POSICIONES DEL TIPO 1 AUTOCORREGIDO
*--EN WORKING DEBERA EXISTIR AUX-IMPORTE PARA CALCULOS AUXILIARES
*-- *AUX-IMPOPE : ACUMULADOR DE IMPORTES
*-- *AUX-OPERECT : ACUMULADOR DE IMPORTES RECTIFICADOS
*--
*****************
*--A�ADIMOS 1 AL ACUMULADOR DE PARTICIPES (EN TIPO 1)
IF SW-RECTIF = 0
ADD 1 TO W-M349-1-TOTOPERA-N
ELSE
ADD 1 TO W-M349-1-TOTOPEREC-N.
*---IMPORTE DE LAS OPERACIONES---*
MOVE W-M349-1-TOTIMPOPE-N TO AUX-IMPOPE
COMPUTE AUX-IMPOPE = W-M349-2-BIMPONI-N + AUX-IMPOPE
*---IMPORTE DE LAS OPERACIONES RECTIFICADAS---*
MOVE W-M349-1-TOTIMPRECT-N TO AUX-OPERECT.
COMPUTE AUX-OPERECT = W-M349-2-BIRECT-N + AUX-OPERECT
*--AHORA HACEMOS EL PASO INVERSO DEL QUE HACEMOS AL PPIO
*--ASI VAMOS ACUMULANDO LOS IMPORTES EN EL AUTOCORREGIDO
MOVE AUX-IMPOPE TO W-M349-1-TOTIMPOPE-N.
MOVE AUX-OPERECT TO W-M349-1-TOTIMPRECT-N.
*--SI NO HA HABIDO ERRORES DE TIPO 01, INICIALIZAMOS EL AUTOCORR
IF CMOD3492 = WCMOD3492
INITIALIZE WCMOD3492.
******************************************************************
VALIDAR-TIPO2-349.
*------------------*
*--PARAMETROS DE COMUNICACION:
*-- REGISTRO DE TIPO 2 (250) (CMOD3492)
*-- REGISTRO DE TIPO 2 (250)(AUTOCORR)(WCMOD3492)
*-- POSICIONES 2 A 17 REG TIPO 1
*-- TABLA DE ERRORES(CAMPO/ERROR/OC40)
*-- RESPUESTA (0:BIEN 9:MAL)
*--WORKING: ERRPROP2 :TABLA DE ERRORES PROPIOS
*-- IEP2 :INDICE PARA LA TABLA
*-- W-MCMN-1-MOD: MODELO EN TIPO 1(POS
*-- W-MCMN-1-EJER: EJERCICIO EN TIPO 1
*-- W-MCMN-1-NIF: NIF EN TIPO 1
*-- TODO LO NECESARIO PARA VALIDAR NIF Y NOMBRE
*--UTILIZA VALIDAR-NIF Y VALIDAR-NOMBRE.
*
******************************************************************
*--BUSCAMOS LA PRIMERA OCURRENCIA VACIA DE LA TABLA--*
MOVE 0 TO SW-YA
PERFORM VARYING IEP2 FROM 1 BY 1 UNTIL IEP2 > 40 OR
SW-YA = 1
IF CAMPO2(IEP2) = 0
MOVE 1 TO SW-YA
COMPUTE IEP2 = IEP2 - 1
END-IF
END-PERFORM
COMPUTE IEP2 = IEP2 - 1.
*--RELLENAMOS LA TABLA DE ERRORES PROPIOS...--*
* VALIDAMOS QUE NO VENGA NINGUN LOW-VALUES.
MOVE 0 TO TALLY.
INSPECT CMOD3492 TALLYING TALLY FOR ALL LOW-VALUES
MOVE TALLY TO CONT-LOWVALUES
IF CONT-LOWVALUES > 0
ADD 1 TO IEP2
MOVE 99 TO CAMPO2(IEP2)
MOVE 99 TO ERROR2(IEP2).
*----TIPO----*
*----VALIDACIONES DE ERROR DE SECUENCIA ANTES DE ENTRAR EN ESTE
*----PARRAFO.
*----HASTA EL CAMPO 10 SON COMUNES PARA LOS DOS TIPOS 2
IF M349-2-TIPO IS NOT NUMERIC
INITIALIZE W-M349-2-TIPO
ADD 1 TO IEP2
MOVE 01 TO CAMPO2(IEP2)
MOVE 01 TO ERROR2(IEP2)
ELSE
IF M349-2-TIPO not = '2'
ADD 1 TO IEP2
MOVE 01 TO CAMPO2(IEP2)
MOVE 01 TO ERROR2(IEP2).
MOVE 0 TO SW-RECTIF
IF CMOD3492(134:13) = SPACES OR ZEROS OR LOW-VALUES
IF (M349-2-EJERCI = SPACES OR ZEROS OR LOW-VALUES) AND
(M349-2-PERIODO = SPACES OR ZEROS OR LOW-VALUES) AND
(M349-2-BIRECT = SPACES OR ZEROS OR LOW-VALUES) AND
(M349-2-BIDECL = SPACES OR ZEROS OR LOW-VALUES)
NEXT SENTENCE
ELSE
MOVE 1 TO SW-RECTIF.
*----MODELO----*
IF M349-2-MOD NOT = MCMN-1-MOD
IF M349-2-MOD IS NOT NUMERIC
INITIALIZE W-M349-2-MOD-N
END-IF
ADD 1 TO IEP2
MOVE 02 TO CAMPO2(IEP2)
MOVE 12 TO ERROR2(IEP2).
*--EJERCICIO �
IF M349-2-EJER NOT = MCMN-1-EJER
IF M349-2-EJER IS NOT NUMERIC
INITIALIZE W-M349-2-EJER-N
END-IF
ADD 1 TO IEP2
MOVE 03 TO CAMPO2(IEP2)
MOVE 12 TO ERROR2(IEP2).
IF MCMN-1-NIF NOT = M349-2-NIF
ADD 1 TO IEP2
MOVE 04 TO CAMPO2(IEP2)
MOVE 12 TO ERROR2(IEP2).
*--LOS CAMPOS 5, 6 Y 7 NO TIENEN CONTENIDO
*--NIF DEL OPERADOR COMUNITARIO
IF M349-2-NIFOPERADOR = SPACES OR LOW-VALUES
ADD 1 TO IEP2
MOVE 08 TO CAMPO2(IEP2)
MOVE 03 TO ERROR2(IEP2)
ELSE
MOVE M349-2-CODPAIS TO E-PAIS
MOVE M349-2-NIFOPERA TO M-NVAT
PERFORM VALIDAR-NIF-VICENVAT THRU
VALIDAR-NIF-VICENVAT-E
IF (M349-2-CODPAIS NOT = 'DE' AND 'AT' AND 'BE' AND
'CY' AND 'CZ' AND 'DK' AND
'SK' AND 'SI' AND 'EE' AND
'FI' AND 'FR' AND 'EL' AND
'GB' AND 'NL' AND 'HU' AND
'IT' AND 'IE' AND 'LV' AND
'LT' AND 'LU' AND 'MT' AND
'PL' AND 'PT' AND 'SE' AND
'RO' AND 'BG' AND 'HR') OR
(M349-2-NIFOPERA (1:3) = SPACES)
ADD 1 TO IEP2
MOVE 08 TO CAMPO2(IEP2)
MOVE 01 TO ERROR2(IEP2).
*----APELLIDOS Y NOMBRE/RAZON SOCIAL DEL OPERADOR INTRAC.---*
IF M349-2-NOMPART = LOW-VALUES
ADD 1 TO IEP2
MOVE 09 TO CAMPO2(IEP2)
MOVE 01 TO ERROR2(IEP2)
ELSE
IF M349-2-NOMPART = SPACES
ADD 1 TO IEP2
MOVE 09 TO CAMPO2(IEP2)
MOVE 03 TO ERROR2(IEP2).
*----CLAVE DE OPERACION---*
IF M349-2-CLOPERAC = SPACES
ADD 1 TO IEP2
MOVE 10 TO CAMPO2(IEP2)
MOVE 03 TO ERROR2(IEP2)
ELSE
IF M349-2-CLOPERAC NOT = 'A' AND 'E' AND 'T' AND
'S' AND 'I' AND 'M' AND
'H'
ADD 1 TO IEP2
MOVE 10 TO CAMPO2(IEP2)
MOVE 01 TO ERROR2(IEP2).
*--------------------------------------------------------*
*--CAMPO PARA EL FORMATO DE OPERADOR INTRACOMUNITARIO----*
*--------------------------------------------------------*
*--IMPORTE DE LA BASE IMPONIBLE----*
IF ((M349-2-EJERCI = SPACES OR ZEROS) AND
(M349-2-PERIODO = SPACES OR ZEROS) AND
(M349-2-BIRECT = SPACES OR ZEROS) AND
(M349-2-BIDECL = SPACES OR ZEROS))
IF M349-2-BIMPONI = SPACES OR ZEROS
ADD 1 TO IEP2
MOVE 11 TO CAMPO2(IEP2)
MOVE 03 TO ERROR2(IEP2)
ELSE
IF M349-2-BIMPONI IS NOT NUMERIC
INITIALIZE W-M349-2-BIMPONI-N
ADD 1 TO IEP2
MOVE 11 TO CAMPO2(IEP2)
MOVE 01 TO ERROR2(IEP2)
ELSE
IF M349-2-BIMPONI > 0500000000000
ADD 1 TO IEP2
MOVE 11 TO CAMPO2(IEP2)
MOVE 04 TO ERROR2(IEP2).
*---------------------------------------------------------*
*--CAMPOS PARA EL FORMATO DE HOJA DE RECTIFICACIONES -----*
*---------------------------------------------------------*
*--EJERCICIO----*
IF M349-2-BIMPONI = SPACES OR ZEROS
IF M349-2-EJERCI = ZEROS OR LOW-VALUES
ADD 1 TO IEP2
MOVE 12 TO CAMPO2(IEP2)
MOVE 03 TO ERROR2(IEP2)
ELSE
IF M349-2-EJERCI IS NOT NUMERIC
ADD 1 TO IEP2
MOVE 12 TO CAMPO2(IEP2)
MOVE 01 TO ERROR2(IEP2)
ELSE
IF M349-2-EJERCI-N > M349-2-EJER-N OR
M349-2-EJERCI-N < EJER-ACTUAL-N - 11
ADD 1 TO IEP2
MOVE 12 TO CAMPO2(IEP2)
MOVE 01 TO ERROR2(IEP2)
END-IF
END-IF
END-IF
ELSE
IF NOT(M349-2-EJERCI = SPACES OR LOW-VALUES OR ZEROS)
ADD 1 TO IEP2
MOVE 12 TO CAMPO2(IEP2)
MOVE 02 TO ERROR2(IEP2).
*--PERIODO---*
IF M349-2-BIMPONI = SPACES OR ZEROS
IF M349-2-PERIODO = SPACES OR LOW-VALUES
ADD 1 TO IEP2
MOVE 13 TO CAMPO2(IEP2)
MOVE 03 TO ERROR2(IEP2)
ELSE
IF NOT(M349-2-PERIODO = '1T' OR '2T' OR '3T' OR '4T'
OR '0A' OR '01' OR '02' OR '03'
OR '04' OR '05' OR '06' OR '07'
OR '08' OR '09' OR '10' OR '11'
OR '12')
ADD 1 TO IEP2
MOVE 13 TO CAMPO2(IEP2)
MOVE 01 TO ERROR2(IEP2)
END-IF
END-IF
ELSE
IF NOT(M349-2-PERIODO = SPACES OR LOW-VALUES)
ADD 1 TO IEP2
MOVE 13 TO CAMPO2(IEP2)
MOVE 02 TO ERROR2(IEP2).
*--IMPORTE DE LA BASE IMPONIBLE RECTIFICADA ----*
IF NOT(M349-2-BIMPONI = SPACES OR ZEROS)
IF NOT(M349-2-BIRECT = SPACES OR ZEROS)
ADD 1 TO IEP2
MOVE 14 TO CAMPO2(IEP2)
MOVE 02 TO ERROR2(IEP2)
END-IF
ELSE
IF M349-2-BIRECT = ZEROS
IF M349-2-BIDECL = ZEROS OR SPACES
ADD 1 TO IEP2
MOVE 14 TO CAMPO2(IEP2)
MOVE 03 TO ERROR2(IEP2)
END-IF
ELSE
IF M349-2-BIRECT IS NOT NUMERIC
INITIALIZE W-M349-2-BIRECT-N
ADD 1 TO IEP2
MOVE 14 TO CAMPO2(IEP2)
MOVE 01 TO ERROR2(IEP2)
ELSE
IF M349-2-BIRECT > 0500000000000
ADD 1 TO IEP2
MOVE 14 TO CAMPO2(IEP2)
MOVE 04 TO ERROR2(IEP2).
*--IMPORTE DE LA BASE IMPONIBLE DECLARADA ANTERIORMENTE---*
IF NOT(M349-2-BIMPONI = SPACES OR ZEROS)
IF NOT(M349-2-BIDECL = SPACES OR ZEROS)
ADD 1 TO IEP2
MOVE 15 TO CAMPO2(IEP2)
MOVE 02 TO ERROR2(IEP2)
END-IF
ELSE
IF M349-2-BIDECL = ZEROS
IF M349-2-BIRECT = ZEROS OR SPACES
ADD 1 TO IEP2
MOVE 15 TO CAMPO2(IEP2)
MOVE 03 TO ERROR2(IEP2)
END-IF
ELSE
IF M349-2-BIDECL IS NOT NUMERIC
INITIALIZE W-M349-2-BIDECL-N
ADD 1 TO IEP2
MOVE 15 TO CAMPO2(IEP2)
MOVE 01 TO ERROR2(IEP2)
ELSE
IF M349-2-BIDECL > 0500000000000
ADD 1 TO IEP2
MOVE 15 TO CAMPO2(IEP2)
MOVE 04 TO ERROR2(IEP2).
*--- FIN DE LA VALIDACION DEL TIPO2 ---*
******************************************************************
VALIDAR-NIF.
*------------*
*COMUN PARA TODAS LAS VALIDACIONES DE NIF.
*INCLUYE LA RUTINA GTUCNIF.
*ENTRADA: NUEVE-LETRAS = NIF/CIF LEIDO
*SALIDA : ERROR-NIF : 1=FALLO 0=CORRECTO (PARA NIF Y CIF)
* ES-UN-NIF : 1=LO ES 0=NO LO ES
* ES-UN-CIF : 1=LO ES 0=NO LO ES
IF NUEVE-LETRAS = '00000001R' OR ' 1R' OR '1R '
MOVE 1 TO ERROR-NIF
GO TO VALIDAR-NIF-E.
IF PRIMERA-LETRA = 'A' OR 'B' OR 'C' OR 'D' OR 'E' OR
'F' OR 'G' OR 'H' OR 'K' OR 'L' OR
'M' OR 'P' OR 'Q' OR 'S' OR 'X' OR
'N' OR 'R' OR 'U' OR 'J' OR 'V' OR
'W' OR 'Y' OR 'Z'
MOVE NUEVE-LETRAS TO P1-DNICI
ELSE
IF ULTIMA-LETRA IS NUMERIC
MOVE NUEVE-LETRAS TO P1-DNICI
ELSE
IF OCHO-LETRAS IS NUMERIC
MOVE OCHO-LETRAS TO P1-DNICI
ELSE
MOVE 1 TO ERROR-NIF
GO TO VALIDAR-NIF-E.
PERFORM PREV-GTUCNIF.
IF P1-ESTADO = '9'
MOVE 1 TO ERROR-NIF
ELSE
IF P1-ESTADO = 'D'
MOVE 0 TO ES-UN-CIF
MOVE 1 TO ES-UN-NIF
IF ULTIMA-LETRA NOT = P1-DC
MOVE 1 TO ERROR-NIF
END-IF
ELSE
MOVE 1 TO ES-UN-CIF
MOVE 0 TO ES-UN-NIF
END-IF
END-IF.
VALIDAR-NIF-E.
*--------------*
EXIT.
PREV-GTUCNIF.
*-------------*(PRINCIPAL DE GTUCNIF)
MOVE SPACES TO P1-DNICIN P1-DC P1-ESTADO.
MOVE '9' TO P1-TIPO.
MOVE '9' TO TIPO-DNI
MOVE '9' TO ESTADO.
MOVE P1-DNICI TO TAB01.
MOVE P1-DNICI TO P1-DNICIN.
PERFORM VER-TIPO THRU
VER-TIPO-EXIT.
IF TIPO-PER = 'J'
PERFORM VER-CI THRU
VER-CI-EXIT
ELSE
IF TIPO-PER = 'F'
PERFORM VER-DNI THRU
VER-DNI-EXIT
ELSE
IF TIPO-PER = 'E'
IF TIPO-DNI = '1' OR
TIPO-DNI = '3'
PERFORM VER-EXT-ANTIGUO THRU
VER-EXT-ANTIGUO-EXIT
ELSE
IF TIPO-PER = 'E' AND TIPO-DNI = '2'
PERFORM VER-EXT-MODERNO THRU
VER-EXT-MODERNO-EXIT
ELSE
IF TIPO-PER = 'E' AND TIPO-DNI = '4'
PERFORM VER-T THRU
S-VER-T
ELSE
IF TIPO-PER = 'M'
PERFORM VER-MENOR THRU
VER-MENOR-EXIT.
MOVE TAB01 TO P1-DNICIN.
MOVE TIPO-DNI TO P1-TIPO.
MOVE ESTADO TO P1-ESTADO.
VER-TIPO.
*---------*
MOVE SPACES TO TIPO-PER.
MOVE 0 TO GRUPO-F.
MOVE 0 TO GRUPO-J.
IF ELEM01 (1) = 'A'
MOVE 'J' TO TIPO-PER
IF ELEM01 (9) IS NUMERIC
MOVE '5' TO TIPO-DNI
MOVE 1 TO GRUPO-J
GO TO VER-TIPO-EXIT
ELSE
MOVE '6' TO TIPO-DNI
MOVE 6 TO GRUPO-J
GO TO VER-TIPO-EXIT.
IF ELEM01 (1) > 'A' AND ELEM01 (1) < 'I'
MOVE 'J' TO TIPO-PER
IF ELEM01 (9) IS NUMERIC
MOVE '5' TO TIPO-DNI
MOVE 1 TO GRUPO-J
GO TO VER-TIPO-EXIT
ELSE
MOVE '6' TO TIPO-DNI
MOVE 6 TO GRUPO-J
GO TO VER-TIPO-EXIT.
IF ELEM01 (1) = 'J' OR ELEM01 (1) = 'U' OR ELEM01 (1) = 'V'
MOVE 'J' TO TIPO-PER
IF ELEM01 (9) IS NUMERIC
MOVE '5' TO TIPO-DNI
MOVE 1 TO GRUPO-J
GO TO VER-TIPO-EXIT.
IF ELEM01 (1) = 'N' OR ELEM01 (1) = 'W'
IF ELEM01 (9) IS NOT NUMERIC
MOVE 'J' TO TIPO-PER
MOVE '6' TO TIPO-DNI
MOVE 2 TO GRUPO-J
GO TO VER-TIPO-EXIT.
IF ELEM01 (1) = 'S'
MOVE 'J' TO TIPO-PER
MOVE '7' TO TIPO-DNI
MOVE 5 TO GRUPO-J
GO TO VER-TIPO-EXIT.
IF ELEM01 (1) = 'P'
MOVE 'J' TO TIPO-PER
MOVE '8' TO TIPO-DNI
MOVE 3 TO GRUPO-J
GO TO VER-TIPO-EXIT.
IF ELEM01 (1) = 'Q' OR ELEM01 (1) = 'R'
MOVE 'J' TO TIPO-PER
MOVE '8' TO TIPO-DNI
MOVE 4 TO GRUPO-J
GO TO VER-TIPO-EXIT.
IF ELEM01 (1) = 'L' OR ELEM01 (1) = 'K' OR ELEM01 (1) = 'M'
MOVE 'E' TO TIPO-PER
MOVE '2' TO TIPO-DNI
MOVE 3 TO GRUPO-F
GO TO VER-TIPO-EXIT.
IF ELEM01 (1) = 'X' OR ELEM01 (1) = 'Y' OR ELEM01 (1) = 'Z'
MOVE 'E' TO TIPO-PER
MOVE '2' TO TIPO-DNI
MOVE 2 TO GRUPO-F
GO TO VER-TIPO-EXIT.
IF ELEM01 (1) IS NUMERIC
MOVE 'F' TO TIPO-PER
MOVE '0' TO TIPO-DNI
MOVE 1 TO GRUPO-F.
VER-TIPO-EXIT.
*--------------*
EXIT.
VER-CI.
*-------*
IF NUMCI NOT NUMERIC OR NUMCI = ZEROS
GO TO VER-CI-EXIT.
PERFORM CALC-DC-CI THRU CALC-DC-CI-EXIT.
IF TIPO-DNI = '5'
IF DCCI = DCNUM
MOVE DCNUM TO P1-DC
MOVE 'C' TO ESTADO
GO TO VER-CI-EXIT.
IF TIPO-DNI = '6' OR TIPO-DNI = '7' OR TIPO-DNI = '8'
IF DCCI = DCLET
MOVE DCLET TO P1-DC
MOVE 'C' TO ESTADO
GO TO VER-CI-EXIT.
VER-CI-EXIT.
*------------*
EXIT.
VER-DNI.
*--------*
MOVE ZEROS TO TAB02.
PERFORM ALINEAR THRU ALINEAR-EXIT.
MOVE ELEM01 (I01) TO ELEM02 (I02).
MOVE TAB02 TO TAB01.
IF DNICIF NOT NUMERIC OR DNICIF = ZEROS
OR ELEM01 (1) NOT = ZEROS
GO TO VER-DNI-EXIT.
IF NUM-REP = '00000000' OR NUM-REP = '99999999'
GO TO VER-DNI-EXIT.
MOVE DNICIF TO DNINUM.
PERFORM CALC-DC-DNI THRU CALC-DC-DNI-EXIT.
MOVE DCLET TO P1-DC.
MOVE 'D' TO ESTADO.
VER-DNI-EXIT.
*-------------*
EXIT.
VER-EXT-MODERNO.
*----------------*
IF NUMCI NOT NUMERIC OR NUMCI = ZEROS
GO TO VER-EXT-MODERNO-EXIT.
MOVE 0 TO LETEXT-EN.
IF ELEM01 (1) = 'Y'
MOVE 1 TO LETEXT-EN.
IF ELEM01 (1) = 'Z'
MOVE 2 TO LETEXT-EN.
MOVE NUMEXT TO NUMEXT-EN.
MOVE DIGCON-EN TO NUMERO.
PERFORM CALC-DC-DNI THRU CALC-DC-DNI-EXIT.
IF ELEM01 (9) = DCLET
MOVE DCLET TO P1-DC
MOVE 'D' TO ESTADO.
VER-EXT-MODERNO-EXIT.
*---------------------*
EXIT.
VER-EXT-ANTIGUO.
*----------------*
MOVE ZEROS TO TAB02.
PERFORM ALINEAR THRU ALINEAR-EXIT.
MOVE ELEM01 (1) TO ELEM02 (1).
MOVE TAB02 TO TAB01.
IF NUMEXTA NOT NUMERIC OR NUMEXTA = ZEROS
GO TO VER-EXT-ANTIGUO-EXIT.
MOVE NUMEXTP TO NUMERO.
PERFORM CALC-DC-DNI THRU CALC-DC-DNI-EXIT.
MOVE DCLET TO P1-DC
MOVE 'D' TO ESTADO.
VER-EXT-ANTIGUO-EXIT.
*---------------------*
EXIT.
VER-T.
*------*
MOVE SPACES TO P1-DC ESTADO.
MOVE ZEROS TO TAB02.
PERFORM ALINEAR-T THRU S-ALINEAR-T.
IF ESTADO = '9' GO S-VER-T
ELSE MOVE 'D' TO ESTADO.
MOVE ELEM01 (1) TO ELEM02 (1).
MOVE TAB02 TO TAB01.
S-VER-T.
*--------*
EXIT.
VER-MENOR.
*----------*
IF ELEM01 (1) NOT = '0'
GO TO VER-MENOR-EXIT.
IF ELEM01 (2) NOT NUMERIC
GO TO VER-MENOR-EXIT.
IF ELEM01 (3) NOT NUMERIC
GO TO VER-MENOR-EXIT.
IF ELEM01 (5) NOT NUMERIC
GO TO VER-MENOR-EXIT.
IF ELEM01 (6) NOT NUMERIC
GO TO VER-MENOR-EXIT.
IF ELEM01 (8) NOT NUMERIC
GO TO VER-MENOR-EXIT.
IF ELEM01 (9) NOT NUMERIC
GO TO VER-MENOR-EXIT.
MOVE ' ' TO P1-DC.
MOVE 'D' TO ESTADO.
VER-MENOR-EXIT.
*---------------*
EXIT.
CALC-DC-CI.
*-----------*
MOVE ZEROS TO SUMAPAR SUMAIMP SUMATOT PRODUCT.
COMPUTE SUMAPAR = ELEM01P (2) + ELEM01P (4) + ELEM01P (6).
PERFORM SUMAIMPAR THRU S-SUMAIMPAR VARYING I01 FROM 1
BY 2 UNTIL I01 > 7.
COMPUTE SUMATOT = SUMAPAR + SUMAIMP.
COMPUTE RESTO = 10 - SUMT2.
MOVE TANUM (RESTO) TO DCNUM.
MOVE TADCL (RESTO) TO DCLET.
CALC-DC-CI-EXIT.
*----------------*
EXIT.
SUMAIMPAR.
*----------*
COMPUTE PRODUCT = ELEM01P (I01) * 2.
ADD PROD1 TO SUMAIMP.
ADD PROD2 TO SUMAIMP.
S-SUMAIMPAR.
*------------*
EXIT.
CALC-DC-DNI.
*------------*
DIVIDE NUMERO BY 23
GIVING COCIENTE REMAINDER RESTO.
ADD 1 TO RESTO.
MOVE LETR (RESTO) TO DCLET.
CALC-DC-DNI-EXIT.
*-----------------*
EXIT.
ALINEAR.
*--------*
MOVE 10 TO I01.
MOVE 9 TO I02.
ALINEAR-NUM.
*------------*
SUBTRACT 1 FROM I01.
IF I01 = 1
GO TO ALINEAR-EXIT.
IF ELEM01 (I01) = ' '
GO TO ALINEAR-NUM.
MOVE ELEM01 (I01) TO ELEM02 (I02).
SUBTRACT 1 FROM I02.
GO TO ALINEAR-NUM.
ALINEAR-EXIT.
*-------------*
EXIT.
ALINEAR-T.
*----------*
MOVE 10 TO I01.
MOVE 9 TO I02.
ALINEAR-NUM-T.
*--------------*
SUBTRACT 1 FROM I01.
IF I01 = 1
IF ELEM02 (2) = ZEROES AND ELEM02 (3) = ZEROES
AND ELEM02 (4) = ZEROES AND ELEM02 (5) = ZEROES
AND ELEM02 (6) = ZEROES AND ELEM02 (7) = ZEROES
AND ELEM02 (8) = ZEROES AND ELEM02 (9) = ZEROES
MOVE '9' TO ESTADO
GO S-ALINEAR-T
ELSE
GO S-ALINEAR-T.
IF ELEM01 (I01) = ' '
GO ALINEAR-NUM-T.
IF ELEM01 (I01) IS NUMERIC
MOVE ELEM01 (I01) TO ELEM02 (I02)
SUBTRACT 1 FROM I02
GO ALINEAR-NUM-T
ELSE
MOVE '9' TO ESTADO.
S-ALINEAR-T.
*------------*
EXIT.
******************************************************************
VALIDAR-NOMBRE.
*---------------*
*--RUTINA DE VALIDACION DE NOMBRE.
*--DATOS DE ENTRADA: APFINOMB-NOMBRE-E
*-- ES-UN-CIF=1 NOMBRE DE COMPA�IA
*-- ES-UN-CIF=0 NOMBRE DE PERSONA FISICA
*--DATOS DE SALIDA: SW-FORMATO=1 SI HAY ERROR DE FORMATO
*--DATOS DE SALIDA: SW-FORMATO=1 SI HAY ERROR DE FORMATO
MOVE APFINOMB-NOMBRE-E TO APFINOMB-NOM-AUX.
PERFORM PREV-APFINOMB THRU PREV-APFINOMB-E.
IF APFINOMB-RETORNO-S NOT = 0 OR
APFINOMB-NUMERO-PALABRAS-S < 2
IF ES-UN-CIF = 1
MOVE APFINOMB-NOM-AUX TO W-TABLA40
MOVE 0 TO CON-PAL SW-NUMERO
MOVE 1 TO INDCMN
PERFORM BUSCAR-PALABRAS THRU BUSCAR-PALABRAS-F
UNTIL INDCMN > 40
IF CON-PAL > 0 OR SW-NUMERO = 1
NEXT SENTENCE
ELSE
MOVE 1 TO SW-FORMATO
END-IF
ELSE
MOVE 1 TO SW-FORMATO
END-IF
END-IF.
VALIDAR-NOMBRE-E.
*-----------------*
EXIT.
PREV-APFINOMB.
*--------------*(PRINCIPAL DE APFINOMB)
*-- INICIALIZA LOS CAMPOS DE SALIDA/TRABAJO.
MOVE SPACES TO APFINOMB-NOMBRE-S
NOMBRE-T
APFINOMB-TRES-LETRAS-S
APFINOMB-VACIO.
MOVE 0 TO APFINOMB-NUMERO-PALABRAS-S
APFINOMB-RETORNO-S
INDI-2
DESDE
BLANCOS
CONTA-LETRAS
NO-MAS-LETRAS
PRIMERA-VEZ.
MOVE 1 TO INDICE.
*-- COMPRUEBA SI EL CAMPO DE ENTRADA VIENE VACIO.
IF APFINOMB-NOMBRE-E = SPACES OR LOW-VALUES
MOVE 9 TO APFINOMB-RETORNO-S
GO TO PREV-APFINOMB-E.
*-- REEMPLAZA LAS MINUSCULAS POR MAYUSCULAS, LAS COMAS POR ESPA-
* CIOS Y AJUSTA TODO EL CAMPO A LA IZQUIERDA.
* COMPRUEBA QUE NO HAY NUMEROS NI '*'.
MOVE 1 TO APFINOMB-NUMERO-PALABRAS-S.
PERFORM CAMB-AJUS THRU CAMB-AJUS-E UNTIL INDICE > 40.
*-- DEJA SOLO UN ESPACIO ENTRE LAS PALABRAS. CUENTA NUMERO DE
* PALABRAS Y NUMERO DE LETRAS DE LA PRIMERA PALABRA.
MOVE 1 TO INDICE.
MOVE 0 TO INDI-2 BLANCOS.
PERFORM DEJAUNBLANCO THRU DEJAUNBLANCO-E VARYING INDICE
FROM 1 BY 1 UNTIL INDICE > 40.
MOVE NOMBRE-T TO APFINOMB-NOMBRE-S.
IF APFINOMB-NUMERO-PALABRAS-S < 2 OR
CONTA-LETRAS < 2
MOVE 9 TO APFINOMB-RETORNO-S.
MOVE APFINOMB-LETRA-S (1) TO APFINOMB-LETRAS3 (1).
MOVE APFINOMB-LETRA-S (2) TO APFINOMB-LETRAS3 (2).
MOVE APFINOMB-LETRA-S (3) TO APFINOMB-LETRAS3 (3).
PREV-APFINOMB-E.
*----------------*
EXIT.
CAMB-AJUS.
*----------*(PERTENECE A APFINOMB)
*-- PRIMERO AJUSTA A LA IZQUIERDA.
IF PRIMERA-VEZ = 0
MOVE 1 TO PRIMERA-VEZ
MOVE 0 TO SW-YA
PERFORM VARYING INDICE FROM 1 BY 1
UNTIL INDICE > 40 OR
SW-YA = 1
IF APFINOMB-LETRA-E (INDICE) NOT = ' '
MOVE 1 TO SW-YA
END-IF
END-PERFORM
COMPUTE INDICE = INDICE - 1.
ADD 1 TO INDI-2.
MOVE APFINOMB-LETRA-E (INDICE) TO DESTINO-2.
MOVE LOW-VALUES TO DESTINO-1.
*-- TRANSFORMA LAS MINUSCULAS A MAYUSCULAS.
* . LOS CODIGOS EBCDIC DE LAS MAYUSCULAS = MINUSCULAS + 64
* . TRANSFORMA LAS MINUSCULAS ACENTUADAS A MAYUSCULAS:
* . TRANSFORMA LAS MINUSCULAS ACENTUADAS A MAYUSCULAS:
* � ... (69) ==> A ... (193)
* . CODIGO 160 (DEL PC) ==> # ... (123)
* . TRANSFORMA LAS , (107) POR UN ESPACIO (64).
IF DESTINO-C = 160
MOVE 123 TO DESTINO-C
MOVE DESTINO-2 TO APFINOMB-LETRA-S (INDI-2)
ELSE
IF DESTINO-C > 128 AND < 170
ADD 64 TO DESTINO-C
MOVE DESTINO-2 TO APFINOMB-LETRA-S (INDI-2)
ELSE
IF DESTINO-C = 106
MOVE 123 TO DESTINO-C
MOVE DESTINO-2 TO APFINOMB-LETRA-S (INDI-2)
ELSE
MOVE APFINOMB-LETRA-E (INDICE) TO APFINOMB-LETRA-S (INDI-2)
IF DESTINO-C = 69
MOVE 193 TO DESTINO-C
MOVE DESTINO-2 TO APFINOMB-LETRA-S (INDI-2)
ELSE
IF DESTINO-C = 81
MOVE 197 TO DESTINO-C
MOVE DESTINO-2 TO APFINOMB-LETRA-S (INDI-2)
ELSE
IF DESTINO-C = 85
MOVE 201 TO DESTINO-C
MOVE DESTINO-2 TO APFINOMB-LETRA-S (INDI-2)
ELSE
IF DESTINO-C = 206
MOVE 214 TO DESTINO-C
MOVE DESTINO-2 TO APFINOMB-LETRA-S (INDI-2)
ELSE
IF DESTINO-C = 222
MOVE 228 TO DESTINO-C
MOVE DESTINO-2 TO APFINOMB-LETRA-S (INDI-2)
ELSE
IF DESTINO-C = 107
MOVE ' ' TO APFINOMB-LETRA-S (INDI-2)
ELSE
MOVE APFINOMB-LETRA-E (INDICE) TO APFINOMB-LETRA-S (INDI-2)
IF APFINOMB-LETRA-E (INDICE) IS NUMERIC OR
APFINOMB-LETRA-E (INDICE) = '*' OR
APFINOMB-LETRA-E (INDICE) = '+'
MOVE 9 TO APFINOMB-RETORNO-S.
ADD 1 TO INDICE.
CAMB-AJUS-E.
*------------*(PERTENECE A APFINOMB)
EXIT.
DEJAUNBLANCO.
*------------*(PERTENECE A APFINOMB)
*-- SOLO CUENTA LETRAS DE LA PRIMERA PALABRA. CUANDO ENCUENTRA
* EL PRIMER BLANCO CAMBIA EL VALOR DEL SWITCH NO-MAS-LETRAS
* PARA NO SUMAR A CONTA-LETRAS.
IF APFINOMB-LETRA-S (INDICE) = ' '
ADD 1 TO BLANCOS
MOVE 1 TO NO-MAS-LETRAS
ELSE
IF BLANCOS > 0
ADD 1 TO APFINOMB-NUMERO-PALABRAS-S
MOVE 0 TO BLANCOS
IF NO-MAS-LETRAS = 0
ADD 1 TO CONTA-LETRAS
ELSE
NEXT SENTENCE
ELSE
MOVE 0 TO BLANCOS
IF NO-MAS-LETRAS = 0
ADD 1 TO CONTA-LETRAS.
*-- BLANCOS ES UN CONTADOR DE ESPACIOS. SI ES 1 MUEVE AL CAMPO
* DESTINO (LETRA-T) YA QUE TIENE QUE DEJAR UN ESPACIO ENTRE
* CADA PALABRA. SI ES 0 MUEVE CADA UNA DE LAS LETRAS AL CAMPO
* DESTINO.
* SI ES MAYOR DE UNO, NO MUEVE NADA.
IF BLANCOS > 1
NEXT SENTENCE
ELSE
ADD 1 TO INDI-2
MOVE APFINOMB-LETRA-S (INDICE) TO LETRA-T (INDI-2).
DEJAUNBLANCO-E.
*--------------*(PERTENECE A APFINOMB)
EXIT.
******************************************************************
******************************************************************
*--- RUTINAS PARA CONTAR LAS PALABRAS DEL CAMPO APELLIDOS Y NOMBRE
*--- SI ES UN C.I.
******************************************************************
BUSCAR-PALABRAS.
*---------------*
MOVE 0 TO SW-YA.
PERFORM SIG-PAL THRU SIG-PAL-F UNTIL
SW-YA = 1 OR INDCMN > 40.
IF INDCMN < 41
COMPUTE INDCMN = INDCMN - 1
END-IF.
MOVE 0 TO SW-YA.
IF INDCMN < 41
PERFORM SIG-PAL2 THRU SIG-PAL2-F UNTIL
SW-YA = 1 OR INDCMN > 40.
IF INDCMN < 41
COMPUTE INDCMN = INDCMN - 1
END-IF.
IF INDCMN < 41
ADD 1 TO INDCMN
CON-PAL.
BUSCAR-PALABRAS-F.
*------------------*
EXIT.
SIG-PAL.
*--------*
IF E-TABLA40 (INDCMN) IS NUMERIC
MOVE 1 TO SW-NUMERO.
IF E-TABLA40 (INDCMN) NOT = ' ' AND NOT = '*'
MOVE 1 TO SW-YA.
ADD 1 TO INDCMN.
SIG-PAL-F.
*----------*
EXIT.
SIG-PAL2.
*--------*
IF E-TABLA40 (INDCMN) IS NUMERIC
MOVE 1 TO SW-NUMERO.
IF E-TABLA40 (INDCMN) = ' '
MOVE 1 TO SW-YA.
ADD 1 TO INDCMN.
SIG-PAL2-F.
*----------*
EXIT.
******************************************************************
******************************************************************
PROPAGACION.
*------------*(GIRCZ01S)
*--ENTRAN: TABLA DE ERRORES PROPIOS ANTIGUA (ERRPROP-AUX-2)
* TABLA DE ERRORES PROPIOS ACTUAL (ERRPROP-AUX)
* TABLA DE ERRORES ACUMULADOS (ERRACUM-AUX)
*--SE UTILIZA UNA TABLA DE TRABAJO AUXILIAR (ERRPROP-TJO)
*--SI LA TABLA ANTIGUA VIENE CON CONTENIDO, SE DESPROPAGA,
*--SE AJUSTA LA TABLA DE ERRORES ACUMULADOS.
*--TRAS ESTO, SI VIENE CONTENIDO EN LA TABLA ACTUAL, SE PROPAGA
INITIALIZE ERRPROP-TJO.
IF CAMPO-2(1) NOT = 0
MOVE ERRPROP-AUX-2 TO ERRPROP-TJO
MOVE 'D' TO SW-PROPAGACION
PERFORM BUSCAR THRU BUSCAR-E
PERFORM AJUSTABLA THRU AJUSTABLA-E.
IF CAMPO(1) NOT = 0
MOVE ERRPROP-AUX TO ERRPROP-TJO
MOVE 'P' TO SW-PROPAGACION
PERFORM BUSCAR THRU BUSCAR-E.
PROPAGACION-E.
*--------------*
EXIT.
BUSCAR.
*-------*
MOVE 0 TO FIN-ERRORES.
PERFORM VARYING IEP FROM 1 BY 1 UNTIL FIN-ERRORES = 1
IF CAMPO-TJO(IEP) NOT = 0
PERFORM MARCAR-ACUMULADO THRU MARCAR-ACUMULADO-E
ELSE
MOVE 1 TO FIN-ERRORES
END-IF
END-PERFORM.
BUSCAR-E.
*---------*
EXIT.
MARCAR-ACUMULADO.
*-----------------*
MOVE 0 TO SW-ENCONTRADO.
PERFORM VARYING IEAUX FROM 1 BY 1 UNTIL SW-ENCONTRADO = 1
OR IEAUX > 90
IF CAMPO-TJO(IEP) = CAMACU-X(IEAUX) AND
ERROR-TJO(IEP) = ERRACU-X(IEAUX)
MOVE 1 TO SW-ENCONTRADO
IF SW-PROPAGACION = 'D'
COMPUTE CONACU-X(IEAUX) = CONACU-X(IEAUX)
ELSE
IF SW-PROPAGACION = 'P'
ADD 1 TO CONACU-X(IEAUX)
END-IF
END-IF
ELSE
IF SW-PROPAGACION = 'P'
IF CAMACU-X(IEAUX) = 0
MOVE 1 TO SW-ENCONTRADO
MOVE CAMPO-TJO(IEP) TO CAMACU-X(IEAUX)
MOVE ERROR-TJO(IEP) TO ERRACU-X(IEAUX)
MOVE 1 TO CONACU-X(IEAUX)
END-IF
END-IF
END-IF
END-PERFORM.
MARCAR-ACUMULADO-E.
*-------------------*
EXIT.
AJUSTABLA.
*----------*
*--SI SE HA DESMARCADO ALGUN ERROR, REORDENAMOS LA TABLA--*
INITIALIZE ERRACUM-IMP IEP.
PERFORM VARYING IEAUX FROM 1 BY 1 UNTIL IEAUX > 40
IF CONACU-X(IEAUX) NOT = 0
ADD 1 TO IEP
MOVE CAMACU-X(IEAUX) TO CAMACU(IEP)
MOVE ERRACU-X(IEAUX) TO ERRACU(IEP)
MOVE CONACU-X(IEAUX) TO CONACU(IEP)
END-IF
END-PERFORM.
MOVE ERRACUM-IMP TO ERRACUM-AUX.
AJUSTABLA-E.
*------------*
EXIT.
******************************************************************
CUADRAR-TIPO1.
*--------------*(GIRCR03S)
*--DATOS DE COMUNICACION:
*-- RESPUESTA : '0' BIEN '9' MAL (CICS)
*-- TABLA DE ERRORES PROPIOS DE TIPO 1
*-- TOTAL PERCEPTORES CALCULADOS
*-- TOTAL PERCEPTORES DECLARADOS
*-- TOTAL PERCEPCIONES CALCULADAS
*-- TOTAL PERCEPCIONES DECLARADAS
*-- SIGNO DE PERCEPCIONES DECLARADAS
*-- TOTAL RETENCIONES CALCULADAS
*-- TOTAL RETENCIONES DECLARADAS
*--WORKING:
*-- W-M349-1-TOTOPERA : NUMERO TOTAL DE PARTICIPES
*-- W-M349-1-TOTOPERA-N: REDEFINIR NUMERICO
*-- M349-1-TOTIMPOPE : IMPORTE DE LAS OPERACIONES
*-- M349-1-TOTIMPOPE-N : REDEFINIR NUMERICO
*-- W-M349-1-TOTOPEREC : NUMERO TOTAL DE INMUEBLES
*-- W-M349-1-TOTOPEREC-N: REDEFINIR NUMERICO
*-- W-M349-TOTIMPRECT : TOTAL INMUEBLES
*-- M349-1-TOTIMPRECT : TOTAL INMUEBLES
*-- M349-1-TOTIMPRECT-N : REDEFINIR NUMERICO
*-- IEP1 : INDICE PARA LA TABLA DE ERRORES
*-- IEP : INDICE PARA LA TABLA DE ERRORES
*-- AUXILIAR
*-- ERRPROP-AUX : TABLA DE ERRORES AUXILIAR
*-- AUX-IMPORTE : PARA OPERACIONES CON IMPORTES
*-- SW-C13T1 : INDICADOR DE ERROR EN CAMPO 12
*-- SW-C14T1 : INDICADOR DE ERROR EN CAMPO 13
*-- SW-C15T1 : INDICADOR DE ERROR EN CAMPO 14
*-- SW-C16T1 : INDICADOR DE ERROR EN CAMPO 15
*--BUSCAMOS LA PRIMERA OCURRENCIA VACIA DE LA TABLA--*
*--Y ACTIVAMOS LOS SWITCHES DE EXISTENCIA DE ERROR--*
MOVE 0 TO SW-YA
PERFORM VARYING IEP1 FROM 1 BY 1 UNTIL IEP1 > 40 OR
SW-YA = 1
IF CAMPO1(IEP1) = 13 MOVE 1 TO SW-C13T1 END-IF
IF CAMPO1(IEP1) = 14 MOVE 1 TO SW-C14T1 END-IF
IF CAMPO1(IEP1) = 15 MOVE 1 TO SW-C15T1 END-IF
IF CAMPO1(IEP1) = 16 MOVE 1 TO SW-C16T1 END-IF
IF CAMPO1(IEP1) = 0
MOVE 1 TO SW-YA
COMPUTE IEP1 = IEP1 - 1
END-IF
END-PERFORM.
COMPUTE IEP1 = IEP1 - 1.
MOVE 0 TO SW-DESMARCADO.
*--TOTAL OPERACIONES--*
IF SW-C13T1 = 0
IF M349-1-TOTOPERA IS NUMERIC
IF M349-1-TOTOPERA-N > W-M349-1-TOTOPERA-N
ADD 1 TO IEP1
MOVE 13 TO CAMPO1(IEP1)
MOVE 10 TO ERROR1(IEP1)
ELSE
IF M349-1-TOTOPERA-N < W-M349-1-TOTOPERA-N
ADD 1 TO IEP1
MOVE 13 TO CAMPO1(IEP1)
MOVE 09 TO ERROR1(IEP1)
ELSE
*--DESMARCAMOS EL ERROR SI EXISTE--*
MOVE IEP1 TO IEP
PERFORM VARYING IEP1 FROM 1 BY 1 UNTIL IEP1 > 40
IF CAMPO1(IEP1) = 13 AND (ERROR1(IEP1) = 09 OR 10)
MOVE 1 TO SW-DESMARCADO
MOVE 0 TO CAMPO1(IEP1) ERROR1(IEP1)
END-IF
END-PERFORM
MOVE IEP TO IEP1.
*--IMPORTE DE LAS OPERACIONES--*
IF SW-C14T1 = 0
IF M349-1-TOTIMPOPE-N IS NUMERIC
IF M349-1-TOTIMPOPE-N NOT = W-M349-1-TOTIMPOPE-N
ADD 1 TO IEP1
MOVE 14 TO CAMPO1(IEP1)
MOVE 11 TO ERROR1(IEP1)
ELSE
*--DESMARCAMOS EL ERROR SI EXISTE--*
MOVE IEP1 TO IEP
PERFORM VARYING IEP1 FROM 1 BY 1 UNTIL IEP1 > 40
IF CAMPO1(IEP1) = 14 AND ERROR1(IEP1) = 11
MOVE 1 TO SW-DESMARCADO
MOVE 0 TO CAMPO1(IEP1) ERROR1(IEP1)
END-IF
END-PERFORM
MOVE IEP TO IEP1.
*--TOTAL OPERACIONES RECTIFICADAS--*
IF SW-C15T1 = 0
IF M349-1-TOTOPEREC IS NUMERIC
IF M349-1-TOTOPEREC-N > W-M349-1-TOTOPEREC-N
ADD 1 TO IEP1
MOVE 15 TO CAMPO1(IEP1)
MOVE 10 TO ERROR1(IEP1)
ELSE
IF M349-1-TOTOPEREC-N < W-M349-1-TOTOPEREC-N
ADD 1 TO IEP1
MOVE 15 TO CAMPO1(IEP1)
MOVE 09 TO ERROR1(IEP1)
ELSE
*--DESMARCAMOS EL ERROR SI EXISTE--*
MOVE IEP1 TO IEP
PERFORM VARYING IEP1 FROM 1 BY 1 UNTIL IEP1 > 40
IF CAMPO1(IEP1) = 15 AND (ERROR1(IEP1) = 09 OR 10)
MOVE 1 TO SW-DESMARCADO
MOVE 0 TO CAMPO1(IEP1) ERROR1(IEP1)
END-IF
END-PERFORM
MOVE IEP TO IEP1.
*--TOTAL IMPORTE OPERAC. RECTIFICADAS ---*
IF SW-C16T1 = 0
IF M349-1-TOTIMPRECT-N IS NUMERIC
MOVE M349-1-TOTIMPRECT-N TO AUX-IMPORTE
IF W-M349-1-TOTIMPRECT-N NOT = AUX-IMPORTE
ADD 1 TO IEP1
MOVE 16 TO CAMPO1(IEP1)
MOVE 11 TO ERROR1(IEP1)
ELSE
*--DESMARCAMOS EL ERROR SI EXISTE--*
MOVE IEP1 TO IEP
PERFORM VARYING IEP1 FROM 1 BY 1 UNTIL IEP1 > 40
IF CAMPO1(IEP1) = 16 AND ERROR1(IEP1) = 11
MOVE 1 TO SW-DESMARCADO
MOVE 0 TO CAMPO1(IEP1) ERROR1(IEP1)
END-IF
END-PERFORM
MOVE IEP TO IEP1.
*--SI SE HA DESMARCADO ALGUN ERROR, REORDENAMOS LA TABLA--*
IF SW-DESMARCADO = 1
INITIALIZE ERRPROP-AUX IEP
PERFORM VARYING IEP1 FROM 1 BY 1 UNTIL IEP1 > 40
IF CAMPO1(IEP1) NOT = 0
ADD 1 TO IEP
MOVE CAMPO1(IEP1) TO CAMPO(IEP)
MOVE ERROR1(IEP1) TO ERROR-X(IEP)
END-IF
END-PERFORM
MOVE ERRPROP-AUX TO ERRPROP1.
CUADRAR-TIPO1-E.
*----------------*
EXIT.
PINTA-ERROR.
*-------------*
INITIALIZE D2-TIP1 D2-ERR1 D2-CON1
D2-TIP2 D2-ERR2 D2-CON2
D2-TIP3 D2-ERR3 D2-CON3.
IF CAMACU(IEA) NOT = 0
EVALUATE SW-D2-TIP
WHEN 0
MOVE 0 TO D2-TIP1
WHEN 1
MOVE 1 TO D2-TIP1
WHEN 2
MOVE 2 TO D2-TIP1
END-EVALUATE
MOVE CAMACU(IEA) TO D2-ERR1-CAMPO
MOVE ERRACU(IEA) TO D2-ERR1-ERROR
MOVE CONACU(IEA) TO D2-CON1
IF CAMACU(IEA + 1) NOT = 0
EVALUATE SW-D2-TIP
WHEN 0
MOVE 0 TO D2-TIP2
WHEN 1
MOVE 1 TO D2-TIP2
WHEN 2
MOVE 2 TO D2-TIP2
END-EVALUATE
MOVE CAMACU(IEA + 1) TO D2-ERR2-CAMPO
MOVE ERRACU(IEA + 1) TO D2-ERR2-ERROR
MOVE CONACU(IEA + 1) TO D2-CON2
IF CAMACU(IEA + 2) NOT = 0
EVALUATE SW-D2-TIP
WHEN 0
MOVE 0 TO D2-TIP3
WHEN 1
MOVE 1 TO D2-TIP3
WHEN 2
MOVE 2 TO D2-TIP3
END-EVALUATE
MOVE CAMACU(IEA + 2) TO D2-ERR3-CAMPO
MOVE ERRACU(IEA + 2) TO D2-ERR3-ERROR
MOVE CONACU(IEA + 2) TO D2-CON3
ELSE
MOVE 1 TO NO-HAY-MAS
END-IF
ELSE
MOVE 1 TO NO-HAY-MAS
END-IF
ELSE
MOVE 1 TO NO-HAY-MAS
END-IF.
IF CAMACU(IEA) NOT = 0
IF CAMACU(IEA + 1) = 0
MOVE SPACES TO D2-TIP2-X
MOVE SPACES TO D2-CON2-X
END-IF
IF CAMACU(IEA + 2) = 0
MOVE SPACES TO D2-TIP3-X
MOVE SPACES TO D2-CON3-X
END-IF
WRITE LINEA FROM DET2 AFTER 1
ADD 1 TO CONTA-LINEAS.
******************************************************************
IMPRIMIR1.
*----------*
ADD 1 TO CONTA-PAGINAS.
MOVE MCMN-1-MOD TO D1-MOD1.
MOVE MCMN-1-EJER TO D1-EJER1.
MOVE MCMN-1-NIF TO D1-NIF1.
MOVE MCMN-1-NOM TO D1-NOM1.
MOVE MCMN-1-JUST TO D1-JUS1.
*--- TOTAL DE OPERADORES INTRACOMUNITARIOS
IF M349-1-TOTOPERA IS NUMERIC
MOVE M349-1-TOTOPERA-N TO C-RET1
COMPUTE C-DIF3 = M349-1-TOTOPERA-N
- W-M349-1-TOTOPERA-N
IF C-DIF3-X = ' 0'
MOVE ' ' TO C-ERR3
ELSE
MOVE '*' TO C-ERR3
END-IF
ELSE
MOVE M349-1-TOTOPERA TO C-RET1-X
MOVE 0 TO C-DIF3
MOVE '*' TO C-ERR3
END-IF.
MOVE W-M349-1-TOTOPERA TO C-RET2.
*----IMPORTE OPERACIONES INTRACOMUNITARIAS
IF M349-1-TOTIMPOPE IS NUMERIC
COMPUTE DECIMAL-OPER1 = M349-1-TOTIMPOPE-N / 100
COMPUTE DECIMAL-OPER2 = W-M349-1-TOTIMPOPE-N / 100
MOVE DECIMAL-OPER1 TO C-IRET1-E
MOVE DECIMAL-OPER2 TO C-IRET2-E
COMPUTE DECIMAL-OPER3 = DECIMAL-OPER1 - DECIMAL-OPER2
*
IF DECIMAL-OPER3 = 0
MOVE SPACES TO C-ERR4-E
MOVE DECIMAL-OPER3 TO C-DIF4-E
ELSE
MOVE '*' TO C-ERR4-E
MOVE DECIMAL-OPER3 TO C-DIF4-E
END-IF
ELSE
MOVE M349-1-TOTIMPOPE TO C-IRET1-X-E
MOVE 0 TO C-DIF4-E
MOVE '*' TO C-ERR4-E
END-IF
*--- TOTAL DE OPERADORES INTRACOMUNITARIOS RECTIFICADOS
IF M349-1-TOTOPEREC IS NUMERIC
MOVE M349-1-TOTOPEREC-N TO C-INM1
COMPUTE C-DIF6 = M349-1-TOTOPEREC-N
- W-M349-1-TOTOPEREC-N
IF C-DIF6-X = ' 0'
MOVE ' ' TO C-ERR6
ELSE
MOVE '*' TO C-ERR6
END-IF
ELSE
MOVE M349-1-TOTOPEREC TO C-INM1-X
MOVE 0 TO C-DIF6
MOVE '*' TO C-ERR6
END-IF.
MOVE W-M349-1-TOTOPEREC TO C-INM2.
*----IMPORTE DE LAS OPERACIONES RECTIFICADAS
IF M349-1-TOTIMPRECT IS NUMERIC
COMPUTE DECIMAL-OPRECT1 = M349-1-TOTIMPRECT-N / 100
COMPUTE DECIMAL-OPRECT2 = W-M349-1-TOTIMPRECT-N / 100
MOVE DECIMAL-OPRECT1 TO C-IIINMUEB1-E
MOVE DECIMAL-OPRECT2 TO C-IIINMUEB2-E
COMPUTE DECIMAL-OPRECT3 = DECIMAL-OPRECT1 -
DECIMAL-OPRECT2
*
IF DECIMAL-OPRECT3 = 0
MOVE SPACES TO C-ERR5-E
MOVE DECIMAL-OPRECT3 TO C-DIF5-E
ELSE
MOVE '*' TO C-ERR5-E
MOVE DECIMAL-OPRECT3 TO C-DIF5-E
END-IF
ELSE
MOVE M349-1-TOTIMPRECT TO C-IIINMUEB1-X-E
MOVE 0 TO C-DIF5-E
MOVE '*' TO C-ERR5-E
END-IF.
PERFORM PINTAR-CABECERA THRU PINTAR-CABECERA-E.
WRITE LINEA FROM C5-BIS AFTER 2.
WRITE LINEA FROM C6-BIS AFTER 2.
WRITE LINEA FROM C7-BIS AFTER 1.
WRITE LINEA FROM DET1-BIS AFTER 1.
WRITE LINEA FROM C8-BIS AFTER 2.
WRITE LINEA FROM C9 AFTER 1.
WRITE LINEA FROM C10-BIS AFTER 1.
WRITE LINEA FROM C11-BIS AFTER 2.
WRITE LINEA FROM C12-EURO AFTER 2
WRITE LINEA FROM C13-BIS AFTER 2.
WRITE LINEA FROM C13-BIS2-EURO AFTER 2
WRITE LINEA FROM C14 AFTER 5.
WRITE LINEA FROM C15-BIS AFTER 1.
WRITE LINEA FROM C14 AFTER 1.
WRITE LINEA FROM C16 AFTER 1.
WRITE LINEA FROM C17 AFTER 1.
MOVE 1 TO CONTA-LINEAS.
MOVE 0 TO NO-HAY-MAS.
MOVE 2 TO SW-D2-TIP.
MOVE ERRACUM1 TO ERRACUM-IMP.
PERFORM PINTA-ERROR VARYING IEA FROM 1 BY 3
UNTIL NO-HAY-MAS = 1 OR IEA > 87
OR CONTA-LINEAS > 35.
IF CONTA-LINEAS NOT > 35
MOVE 0 TO NO-HAY-MAS
MOVE 1 TO SW-D2-TIP
PERFORM VARYING IMP FROM 1 BY 1 UNTIL IMP > 90
IF IMP > 40
MOVE 0 TO CAMACU(IMP)
MOVE 0 TO ERRACU(IMP)
MOVE 0 TO CONACU(IMP)
ELSE
MOVE CAMPO1(IMP) TO CAMACU(IMP)
MOVE ERROR1(IMP) TO ERRACU(IMP)
MOVE 1 TO CONACU(IMP)
END-IF
END-PERFORM
PERFORM PINTA-ERROR VARYING IEA FROM 1 BY 3
UNTIL NO-HAY-MAS = 1 OR IEA > 87
OR CONTA-LINEAS > 35.
IF CONTA-LINEAS = 1
WRITE LINEA FROM DET3 AFTER 10
WRITE LINEA FROM DET4 AFTER 1
WRITE LINEA FROM DET3 AFTER 1
ELSE
IF CONTA-LINEAS < 28
WRITE LINEA FROM DET3 AFTER 8
WRITE LINEA FROM DET5 AFTER 1
WRITE LINEA FROM DET3 AFTER 1
ELSE
WRITE LINEA FROM DET3 AFTER 2
WRITE LINEA FROM DET5 AFTER 1
WRITE LINEA FROM DET3 AFTER 1.
IMPRIMIR1-E.
*------------*
EXIT.
******************************************************************
PINTAR-CABECERA.
*----------------*
*--HAY QUE MOVER LA FECHA.
ACCEPT WCURRENT-DATE FROM DATE.
IF FED-ANO < 50
MOVE 20 TO FED-SIGL
ELSE
MOVE 19 TO FED-SIGL.
MOVE FED-ANIO TO C-ANIO.
MOVE FED-MES TO C-MES.
MOVE FED-DIA TO C-DIA.
MOVE EJER-ACTUAL TO C-ANIOEJ.
MOVE M349-1-PERIODO TO C-PERIODO
MOVE CONTA-PAGINAS TO C-PAGINA.
WRITE LINEA FROM C1 AFTER PAGE.
WRITE LINEA FROM C2 AFTER 1.
WRITE LINEA FROM C3 AFTER 1.
WRITE LINEA FROM C4 AFTER 1.
PINTAR-CABECERA-E.
*------------------*
EXIT.
******************************************************************
ESCRIBIR-SALIDA.
*----------------*
WRITE REG-SALIDA FROM REGISTRO-SALIDA.
IF ST-SALIDA NOT = '00'
DISPLAY 'ERROR AL ESCRIBIR EL FICHERO DE SALIDA. ERROR '
ST-SALIDA
GO TO FIN.
ESCRIBIR-SALIDA-E.
*------------------*
EXIT.
******************************************************************
VALIDAR-NIF-VICENVAT.
*---------------------*
MOVE 'R-VALIDAR-NVAT' TO W-PARRAFO.
*--
*--CALCULAR LONGITUD DE ENTRADA--
PERFORM VARYING W-LON-ENTRADA FROM 1 BY 1
UNTIL W-LON-ENTRADA > 15 OR
T-NVAT(W-LON-ENTRADA) = ' '
END-PERFORM.
SUBTRACT 1 FROM W-LON-ENTRADA
*--
*--BUSCAR PAIS EN TABLA--
PERFORM VARYING W-FILA FROM 1 BY 1
UNTIL W-FILA > 28 OR
W-COD-PAIS(W-FILA) = E-PAIS
END-PERFORM
IF W-FILA > 28
MOVE 1 TO S-CODIGO-ERROR
END-IF
*--
*
*--BUSCAR LONGITUD MINIMA A VALIDAR--
PERFORM VARYING W-COLUMNA FROM 1 BY 1
UNTIL W-COLUMNA > W-MAX-IND(W-FILA) OR
W-LON-NVAT(W-FILA, W-COLUMNA) >= W-LON-ENTRADA
END-PERFORM
IF W-COLUMNA > W-MAX-IND(W-FILA)
MOVE 2 TO S-CODIGO-ERROR
END-IF
MOVE 1 TO S-CODIGO-ERROR.
*
VALIDAR-NIF-VICENVAT-E.
*-----------------------*
EXIT.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment