Exit de usuario.
Descripción general
Elementos de entrada / salida
Condiciones de llamada
000100 IDENTIFICATION DIVISION.
000200*************************
000300 PROGRAM-ID. ZTBGBE40
000400 AUTHOR. RAE.
000500*
000600******************************************************************
000700* OBJETO: *
000800* PROGRAMA QUE GRABA UN REGISTRO EN UN FICHERO *
000900* SECUENCIAL. *
001000* *
001100******************************************************************
001200*
001300 ENVIRONMENT DIVISION.
001400**********************
001500 CONFIGURATION SECTION.
001600*----------------------
001700 SOURCE-COMPUTER. IBM-4331.
001800 OBJECT-COMPUTER. IBM-4331.
001900*
002000 INPUT-OUTPUT SECTION.
002100*---------------------
002200*
002300 FILE-CONTROL.
002400*
002500 SELECT SALIDA ASSIGN TO S-SALIDA
002600 ORGANIZATION IS SEQUENTIAL
002700 ACCESS MODE IS SEQUENTIAL
002800 FILE STATUS IS FS-SALIDA.
002900*
003000 DATA DIVISION.
003100***************
003200*
003300 FILE SECTION.
003400*-------------
003500*
003600 FD SALIDA
003700 BLOCK 0 RECORDS
003800 LABEL RECORD STANDARD.
003900*
004000 01 REG-SALIDA.
004100 02 FILLER PIC X(80).
004200*
004300 WORKING-STORAGE SECTION.
004400/*****************************************************************
004500****** WORKING ESPECIFICA DEL PROGRAMA ******
004600******************************************************************
004700*
004800 77 WRETORNO PIC S9(4) COMP VALUE +0.
004900 77 SALIDA-ABIERTO PIC XX VALUE 'NO'.
005000 77 FS-SALIDA PIC XX VALUE '00'.
005100*
005200 01 WFECHA.
005300 05 WDIA PIC 99 VALUE ZEROS.
005400 05 WMES PIC 99 VALUE ZEROS.
005500 05 WAAAA PIC 99 VALUE ZEROS.
005600*
005700 01 WREGISTRO-SALIDA.
005800 05 FILLER PIC 9 VALUE 0.
005900 05 SIGLO-SALIDA PIC 99 VALUE ZEROS.
006000 05 FECHA-SALIDA.
006100 10 AAAA-SALIDA PIC 99 VALUE ZEROS.
006200 10 MES-SALIDA PIC 99 VALUE ZEROS.
006300 10 DIA-SALIDA PIC 99 VALUE ZEROS.
006400 05 HORA-SALIDA PIC 9(6) VALUE ZEROS.
006500*
006600*
006700*---> INCLUDE DEL AREA DE COMUNICACION COMUN
006800**** EXPANSION DE /INCLUDEC ZTBGCCOM
006900*---------------------------------------------------------------*
007000* AREA DE COMUNICACION COMUN PARA CONVERSORES.
007100* CONTIENE EL REGISTRO DE PREFILES DE LA IGA
007200* Y EL REGISTRO DE PREFILES DE EDITRAN.
007300*
007400*
007500*
007600* 23-3-93
007700* LA LONGITUD TOTAL DEL AREA = 10400 BYTES.
007800*---------------------------------------------------------------*
007900*
008000 01 AREA-COMUN.
008100*
008200**** EXPANSION DE /INCLUDEC ZTBGCRPE
008300******************************************************************
008400* IGA 3.0 *
008500* CONTIENE LA PARTE DE DATOS DE LOS PERFILES DE LA IGA. *
008600* EL NIVEL 01 DEL REGISTRO ESTA EN EL LIBRO (LWREGIGA). *
008700******************************************************************
008800*
008900 03 REGISTRO-PERFILES-IGA.
009000 05 CLAVE-PERFIGA.
009100 10 PREFIJO PIC X.
009200 10 SESION.
009300 12 CODIGO-LOCAL PIC X(9).
009400 12 CODIGO-REMOTO PIC X(9).
009500 12 APLICACION PIC X(6).
009600 10 NUMERO-ORDEN PIC X(2).
009700 05 REGISTRO-PERFIGA PIC X(2973).
009800*
009900* PREFIJO DEL REG. ENTORNO: E. RESTO DE LA CLAVE A CEROS
010000*
010100 05 ENTORNO-IGA REDEFINES REGISTRO-PERFIGA.
010200 10 CODIGO-LOCAL-IGA-ENTORNO PIC X(9).
010300 10 VERSION-IGA-LOCAL-ENTORNO PIC X(4).
010400 10 VERSION-EDITRAN-LOCAL-ENTORNO PIC X(4).
010500 10 PREFIJO-INSTALACION-ENTORNO PIC X(44).
010600 10 MONITOR-ENTORNO PIC X(4).
010700 10 TIPO-UNIDAD-ENTORNO PIC X(8).
010800 10 LOG-ENTORNO PIC X(1).
010900 10 PROC-PREV-EMISION-ENTORNO PIC X(8).
011000 10 PROC-PREV-RECEPCION-ENTORNO PIC X(8).
011100 10 PROC-POST-EMISION-ENTORNO PIC X(8).
011200 10 PROC-POST-RECEPCION-ENTORNO PIC X(8).
011300 10 PROC-EXCEPCION-ENTORNO PIC X(8).
011400 10 FICHA-JOB-ENTORNO.
011500 12 LINEA-JOB-ENTORNO OCCURS 5 PIC X(59).
011600 10 PROC-ESTADOS-ENTORNO PIC X(8).
011700 10 NOMBRE-ENTORNO PIC X(20).
011800 10 FILLER PIC X(2536).
011900*
012000*
012100* PREFIJO DEL REG. SUBENTORNO: E. RESTO DE LA CLAVE A CEROS
012200*
012300 05 SUBENTORNO-IGA REDEFINES REGISTRO-PERFIGA.
012400 10 DESCRIPCION-SUBENTORNO PIC X(44).
012500 10 FILLER PIC X(2929).
012600*
012700* PREFIJO DEL REG. REMOTO : R
012800*
012900 05 C-REMOTO-IGA REDEFINES REGISTRO-PERFIGA.
013000 10 DESCRIPCION-REMOTO PIC X(20).
013100 10 VERSION-IGA-REMOTO PIC X(4).
013200 10 ASCII-EBCDIC-REMOTO PIC X.
013300 10 COMPRESION-REMOTO PIC X.
013400 10 CRIPTOGRAFIA-REMOTO PIC X.
013500 10 CRC-REMOTO PIC X.
013600 10 ALGORITMO-CONF-REMOTO PIC X(4).
013700 10 ALGORITMO-AUT-REMOTO PIC X(4).
013800 10 INTERFAZ-CLAVES-REMOTO PIC X(8).
013900 10 PARAMETROS-REMOTO PIC X(30).
014000 10 CLAVE-LOC-REMOTO PIC X(64).
014100 10 CLAVE-REM-REMOTO PIC X(64).
014200 10 FILLER PIC X(2771).
014300*
014400* PREFIJO DEL REG. APLICACION: A
014500*
014600 05 APLICACION-IGA REDEFINES REGISTRO-PERFIGA.
014700 10 DESCRIPCION-APLICACION PIC X(20).
014800 10 CONVERSOR1-EMI-APLICACION PIC X(8).
014900 10 CONVERSOR2-REC-APLICACION PIC X(8).
015000 10 CONVERSOR3-EMI-APLICACION PIC X(8).
015100 10 CONVERSOR4-REC-APLICACION PIC X(8).
015200 10 PROG-PREVIO-EMI-APLICACION PIC X(8).
015300 10 PROG-PREVIO-REC-APLICACION PIC X(8).
015400 10 PROG-POST-EMI-APLICACION PIC X(8).
015500 10 PROG-POST-REC-APLICACION PIC X(8).
015600 10 PROG-EXCEPCION-APLICACION PIC X(8).
015700 10 TRADUCCION-A-E-APLICACION PIC X.
015800 10 BORRAR-F-E-APLICACION PIC X.
015900 10 BORRAR-F-R-APLICACION PIC X.
016000 10 CRITERIO-DIVISION-APLICACION PIC X(2).
016100 10 PARAMETRO-APLICACION PIC X(60).
016200 10 TIPO-CARGA-APLICACION PIC X(01).
016300 10 TIPO-DESCARGA-APLICACION PIC X(01).
016400 10 EXIT-PREV-EMI-ANT-APLICACION PIC X(8).
016500 10 EXIT-PREV-EMI-POS-APLICACION PIC X(8).
016600 10 EXIT-POST-REC-ANT-APLICACION PIC X(8).
016700 10 EXIT-POST-REC-POS-APLICACION PIC X(8).
008500 10 EXIT-POST-REC-POS-APLICACION PIC X(8).
008600 10 LENG-DATOS-ORG-APLICACION PIC X.
008700 10 TRAD-REC-APLICACION PIC X.
008800 10 TABLA-CONV-EMI-APLICACION PIC X(8).
016800 10 FILLER PIC X(2764).
016900*
017000* PREFIJO DEL REG. SESION PRESENTACION: P
017100*
017200 05 SESION-IGA REDEFINES REGISTRO-PERFIGA.
017300 07 PARAM-ENTORNO PIC X(500).
017400 07 FILLER REDEFINES PARAM-ENTORNO.
017500 10 CODIGO-LOCAL-IGA-SESION PIC X(9).
017600 10 VERSION-IGA-LOCAL-SESION PIC X(4).
017700 10 VERSION-EDITRAN-LOCAL-SESION PIC X(4).
017800 10 PREFIJO-INSTALACION-SESION PIC X(44).
017900 10 MONITOR-SESION PIC X(4).
018000 10 TIPO-UNIDAD-SESION PIC X(8).
018100 10 LOG-SESION PIC X(1).
018200 10 PROC-PREV-EMISION-SESION PIC X(8).
018300 10 PROC-PREV-RECEPCION-SESION PIC X(8).
018400 10 PROC-POST-EMISION-SESION PIC X(8).
018500 10 PROC-POST-RECEPCION-SESION PIC X(8).
018600 10 PROC-EXCEPCION-SESION PIC X(8).
018700 10 FICHA-JOB-SESION.
018800 12 LINEA-JOB-SESION OCCURS 5 PIC X(59).
018900 10 PROC-ESTADOS-SESION PIC X(8).
019000 10 NOMBRE-ENT-SUBENTORNO-SESION PIC X(20).
019100 10 FILLER PIC X(63).
019200 07 FILLER PIC X(250).
019300 07 PARAM-REMOTO PIC X(212).
019400 07 FILLER REDEFINES PARAM-REMOTO.
019500 10 DESCRIPCION-REMOTO-SESION PIC X(20).
019600 10 VERSION-IGA-SESION PIC X(4).
019700 10 ASCII-EBCDIC-SESION PIC X.
019800 10 COMPRESION-SESION PIC X.
019900 10 CRIPTOGRAFIA-SESION PIC X.
020000 10 CRC-SESION PIC X.
020100 10 ALGORITMO-CONF-SESION PIC X(4).
020200 10 ALGORITMO-AUT-SESION PIC X(4).
020300 10 INTERFAZ-CLAVES-SESION PIC X(8).
020400 10 PARAMETROS-SESION PIC X(30).
020500 10 CLAVE-LOC-SESION PIC X(64).
020600 10 CLAVE-REM-SESION PIC X(64).
020700 10 FILLER PIC X(10).
020800 07 FILLER PIC X(250).
020900 07 PARAM-APLICACION PIC X(250).
021000 07 FILLER REDEFINES PARAM-APLICACION.
021100 10 DESCRIPCION-APL-SESION PIC X(20).
021200 10 CONVERSOR1-EMI-APL-SESION PIC X(8).
021300 10 CONVERSOR2-REC-APL-SESION PIC X(8).
021400 10 CONVERSOR3-EMI-APL-SESION PIC X(8).
021500 10 CONVERSOR4-REC-APL-SESION PIC X(8).
021600 10 PROG-PREVIO-EMI-APL-SESION PIC X(8).
021700 10 PROG-PREVIO-REC-APL-SESION PIC X(8).
021800 10 PROG-POST-EMI-APL-SESION PIC X(8).
021900 10 PROG-POST-REC-APL-SESION PIC X(8).
022000 10 PROG-EXCEPCION-APL-SESION PIC X(8).
022100 10 TRADUCCION-A-E-APL-SESION PIC X.
022200 10 BORRAR-F-E-APL-SESION PIC X.
022300 10 BORRAR-F-R-APL-SESION PIC X.
022400 10 CRITERIO-DIVISION-APL-SESION PIC X(2).
022500 10 PARAMETRO-APL-SESION PIC X(60).
022600 10 TIPO-CARGA-APL-SESION PIC X(1).
022700 10 TIPO-DESCARGA-APL-SESION PIC X(1).
022800 10 EXIT-PREV-EMI-ANT-APL-SESION PIC X(8).
022900 10 EXIT-PREV-EMI-POS-APL-SESION PIC X(8).
023000 10 EXIT-POST-REC-ANT-APL-SESION PIC X(8).
023100 10 EXIT-POST-REC-POS-APL-SESION PIC X(8).
015400 10 LENG-DATOS-ORG-APL-SESION PIC X(01).
015500 10 TRAD-REC-APL-SESION PIC X(01).
015600 10 TABLA-CONV-EMI-APL-SESION PIC X(08).
015700 10 TABLA-CONV-REC-APL-SESION PIC X(08).
015800 10 FILLER PIC X(41).
023300 07 FILLER PIC X(250).
023400 07 PARAM-PRESENTACION PIC X(1000).
023500 07 FILLER REDEFINES PARAM-PRESENTACION.
023600 10 DESCRIPCION-SESION PIC X(20).
023700 10 NUMERO-SESIONES-TRANSMISION PIC 99.
023800 10 TABLA-SESIONES.
023900 12 ELEMENTO OCCURS 20.
024000 14 SESION-TRANSMISION.
024100 16 REMOTO-TRANSMISION PIC X(9).
024200 16 APLICA-TRANSMISION PIC X(6).
024300 14 VOLUMEN-FICHERO-TAMPON PIC X(8).
024400 14 NUMERO-REGISTROS-TAMPON PIC 9(5).
024500 10 TABLA-FICHEROS-RECEPCION.
024600 12 ELEMENTO2 OCCURS 5.
024700 14 NOMBRE-FISICO-R PIC X(44).
024800 14 VOLUMEN-R PIC X(8).
024900 14 IDENTIFICADOR-R PIC X(8).
025000 14 LRECL-R PIC 9(5).
025100 10 BORRAR-FA-SI-EXISTE PIC X.
025200 10 VOLSER-O-UNIT PIC X(1).
025300 10 VOLSER-RECEP-V21 PIC X(8).
025400 10 UNIT-DE-VOLSER-V21 PIC X(8).
025500 10 TABLA-UNIT-V20.
025600 12 ELEMENTO3 OCCURS 5.
025700 14 UNIT-DE-VOLSER-V20 PIC X(8).
025800 10 INCREMENTAR-SESION PIC X(1).
018410 10 FORMATO-FICH-DESCARGA PIC X(1).
018420 10 FICHERO-UNICO-RECEPCION PIC X(1).
018500 10 VOLUMEN-POOL-TAMPONES PIC X(1).
018510 10 FILLER PIC X(31).
026000 07 FILLER PIC X(261).
026100*
026200* PREFIJO DEL REG. SESION TRANSMISION : T
026300*
026400 05 SESION-TRANSMISION-IGA REDEFINES REGISTRO-PERFIGA.
026500 10 SESION-ASOCIADA.
026600 15 CODIGO-LOCAL-P PIC X(9).
026700 15 CODIGO-REMOTO-P PIC X(9).
026800 15 APLICACION-P PIC X(6).
026900 10 FILLER PIC X(2949).
027000*
027100* PREFIJO DEL REG. FICHERO DE APLICACION : F
027200*
019900 05 FICHERO-APLICACION-IGA REDEFINES REGISTRO-PERFIGA.
020000 10 NOMBRE-FISICO-E PIC X(44).
020100 10 IDENTIFICADOR-E PIC X(8).
020101 10 FORMATO-FICHERO-E PIC X.
020102 10 LENG-DATOS-ORG-E PIC X.
020103 10 TRAD-EMI-E PIC X.
020110 10 COMPRESION-E PIC X.
020200 10 FILLER PIC X(2917).
027700*
027800**** EXPANSION DE /INCLUDEC ZTBGC004
027900*----------------------------------------------------------------*
028000*-- PARTE DE DATOS DEL PROGRAMA ZTBGB004... *
028100*-- EL NIVEL 01 DE ESTE AREA ESTA EN LA INCLUDE 'LWIGG004. *
028200*
028300* LONGITUD DE LA INCLUDE 4850 BYTES (20/08/97)
028400*-- CODIGOS INFORMATIVOS DE LOS PARAMETOS DE LAS S-T
028500* RDO-LONG-TRANS DESCRIPCION
028600* -------------- ----------------------------------------------
028700* 00 LONGITUDES DE TRANSMISION CORRECTAS
028800* 01 S-T CON LONGITUDES DE TRANSMISION DIFERENTES
028900*
029000* RDO-COMPRESION DESCRIPCION
029100* -------------- ----------------------------------------------
029200* 00 SESIONES DE TRANSMISION SIN COMPRESION
029300* 01 AL MENOS UNA SESION UTILIZA COMPRESION
029400*
029500* RDO-CIFRADO DESCRIPCION
029600* -------------- ----------------------------------------------
029700* 01 S-T CON VERSIONES DE CRIPTOGRAFIA DIFERENTES
029800* 02 VERSIONES DE CRIPTOGRAFIA NO CUMPLIMENTADAS
029900* (TODAS CON ESPACIOS O LOW-VALUES)
030000* 03 VERSION 2.20 SIN CRIPTOGRAFIA
030100* 04 VERSION 2.20 CON AUTENTICACION Y CAMBIO DE
030200* CLAVE
030300*
030400* RDO-TAMPON-E/R DESCRIPCION
030500* -------------- ----------------------------------------------
030600* 01 S-T CON TIPO (M/E) DE TAMPONES (E/R) DISTINTOS
030700* 02 S-T TAMPONES MATRICIALES (E/R) DIFERENTES
030800* 03 TAMPONES DE EMISION NO CONSECUTIVOS
030900* 04 NIGUN TAMPON DE EMISION CUMPLIMENTADO
031000* O ALGUN TAMPON DE RECEPCION NO CUMPLIMENTADO
031100*----------------------------------------------------------------*
031200*
000800 03 RESTO-AREA-ZTBGB004.
000801 05 PROCESO-LLAMANTE-ZTBGB004 PIC X(1).
000810 05 SESION-PRES-ZTBGB004 PIC X(32).
000820 05 LOG-SESION-ZTBGB004 PIC X(01).
000900 05 CODIGO-RDO-ZTBGB004 PIC 9(4).
001000 05 FILE-STATUS-ZTBGB004 PIC X(2).
001010 05 ERRCOD-ZTBGB004 PIC 9(5).
001100 05 TABLA-FICHAS-ZTBGB004.
001200 10 ELEMENTO-FICHA-ZTBGB004 PIC X(59) OCCURS 5.
001300 05 TABLA-SESIONES-ZTBGB004 PIC X(3520).
001400 05 FILLER REDEFINES TABLA-SESIONES-ZTBGB004 OCCURS 20.
001500 10 ELEMENTO-SESION-ZTBGB004.
001600 15 RDO-TRANSMISION-ZTBGB004 PIC 9(4).
001700 15 SESION-TRANSMISION-ZTBGB004.
001800 20 ORIGEN-ZTBGB004 PIC X(9).
001900 20 REMOTO-ZTBGB004 PIC X(9).
002000 20 APLICACION-ZTBGB004 PIC X(6).
002100 15 FICHERO-EMISION-ZTBGB004.
002200 20 LOGICO-EMISION-ZTBGB004 PIC X(7).
002300 20 FISICO-EMISION-ZTBGB004 PIC X(44).
002400 15 FICHERO-RECEPCION-ZTBGB004.
002500 20 LOGICO-RECEPCION-ZTBGB004 PIC X(7).
002600 20 FISICO-RECEPCION-ZTBGB004 PIC X(44).
002700 15 LONGITUD-FICHERO-ZTBGB004 PIC 9(04).
002800 15 VERSION-EDI-REMOTO-ZTBGB004 PIC 9(02).
002810 15 TIPO-TAMPON-EMIS-ZTBGB004 PIC X(1).
002900 15 TIPO-TAMPON-RECEP-ZTBGB004 PIC X(1).
003100 15 COMPRESION-ZTBGB004 PIC X(1).
003200 15 CRIPTOGRAFIA-ZTBGB004 PIC X(1).
003300 15 CAMBIO-CLAVE-ZTBGB004 PIC X(1).
003400 15 CLAVE-EMK-BAJO-AK-ZTBGB004 PIC X(8).
003500 15 CLAVE-TKE-BAJO-EMK-ZTBGB004 PIC X(8).
003600 15 CLAVE-TKR-BAJO-EMK-ZTBGB004 PIC X(8).
003700 15 VERSION-CRIP-ZTBGB004.
003800 17 VERSION-2-CRIP-ZTBGB004 PIC X(2).
003900 17 FILLER PIC X(1).
004000 15 ALGORITMO-CONF-ZTBGB004 PIC X(4).
004100 15 ALGORITMO-AUT-ZTBGB004 PIC X(4).
004200 05 DATOS-ENTORNO-ZTBGB004.
004300 10 NOMBRE-CICS-ZTBGB004 PIC X(08).
004400 10 TRANSACCION-ZTBGB004 PIC X(04).
004410 10 TRANS-EXCI-ZTBGB004 PIC X(04).
004500 * EN PRINCIPIO, VERSION Y CODIGO LOCAL EDITRAN, SON DATOS ENTRADA
004600 10 CODIGO-LOCAL-ZTBGB004 PIC X(09).
004700 10 VERSION-EDITRAN-LOCAL-ZTBGB004 PIC X(4).
004800 10 ALIAS-ENT-SUBENT-ZTBGB004 PIC X(3).
005200 05 DSNAME-ZTBGFEST-ZTBGB004 PIC X(44).
005300 05 LABEL-LOCAL-ZTBGB004 PIC X(8).
005400 05 LABEL-REMOTO-ZTBGB004 PIC X(8).
005500 05 CODIGO-LOCAL-V22-ZTBGB004 PIC 9(6).
005600 05 CODIGO-REMOTO-V22-ZTBGB004 PIC 9(6).
006100 05 NOMBRE-CPU-ZTBGB004 PIC X(8).
006110 05 NETNAME-EXCI-ZTBGB004 PIC X(08).
006200 05 DSNAME-ZTBEFMP-ZTBGB004 PIC X(44).
006300 05 TABLA-SES-INTERNAS-ZTBGB004 PIC X(640).
006400 05 FILLER REDEFINES TABLA-SES-INTERNAS-ZTBGB004 OCCURS 20.
006500 10 SESION-INTERNA-ZTBGB004 PIC X(32).
006600 * CODIGOS DE RESULTADO INFORMATIVOS SOBRE PARAMETROS DE LAS S-T
006610 05 RDO-LONG-TRANS-ZTBGB004 PIC X(2).
006611 05 IND-LONG-TRANS-ZTBGB004 PIC 9(2).
006620 05 RDO-COMPRESION-ZTBGB004 PIC X(2).
006621 05 IND-COMPRESION-ZTBGB004 PIC 9(2).
006630 05 RDO-CIFRADO-ZTBGB004 PIC X(2).
006631 05 IND-CIFRADO-ZTBGB004 PIC 9(2).
006640 05 RDO-TAMPON-E-ZTBGB004 PIC X(2).
006641 05 IND-TAMPON-E-ZTBGB004 PIC 9(2).
006650 05 RDO-TAMPON-R-ZTBGB004 PIC X(2).
006660 05 IND-TAMPON-R-ZTBGB004 PIC 9(2).
006670 05 RDO-JCLS-IGUALES-ZTBGB004 PIC X(2).
006680 05 IND-JCLS-IGUALES-ZTBGB004 PIC 9(2).
006800 05 FILLER PIC X(162).
041200 03 VBLES-PROC-COMUN PIC X(150).
041300 03 FILLER REDEFINES VBLES-PROC-COMUN.
041400 05 NRO-SESION-COMUN PIC 9(4).
05 SENTIDO-COMUN PIC X(1).
041500 05 FILLER PIC X(145).
041600 03 RESTO-AREA-COMUN PIC X(2400).
041700*
038800*---> INCLUDE DEL AREA DE COMUNICACION ESPECIFICA.
038900**** EXPANSION DE /INCLUDEC ZTBGCE40
039000*---------------------------------------------------------------*
039100* AREA ESPECIFICA DEL PROGRAMA DE EXIT. ZTBGBE40.
039200*---------------------------------------------------------------*
039300*
039400 01 AREA-ZTBGBE40.
039500 05 CODIGO-RDO-ZTBGBE40 PIC 9(4).
039600 05 FICHERO-UNICO-ZTBGBE40 PIC X.
039700 05 PRIMER-FICHERO-ZTBGBE40 PIC X.
039800 05 REG-CONTROL-TAMPON-ZTBGBE40.
039900 07 NRO-REG-ENVIADOS-ZTBGBE40 PIC 9(12).
040000 07 NRO-REG-TOTALES-ZTBGBE40 PIC 9(12).
040100 07 NRO-REG-CONFIRMADOS-ZTBGBE40 PIC 9(12).
040200 07 TRANSMITIDO-COMPL-ZTBGBE40 PIC X.
040300 07 CODIGO-RESULTADO-ZTBGBE40 PIC XX.
040400 07 FECHA-TRANSMISION-ZTBGBE40 PIC 9(6).
040500 07 HORA-TRANSMISION-ZTBGBE40 PIC 9(6).
040600 07 FECHA-ULT-CONF-ZTBGBE40 PIC 9(6).
040700 07 HORA-ULT-CONF-ZTBGBE40 PIC 9(6).
040800 07 EST-ZTBGBE40 PIC X.
040900 07 FECHA-CREACION-ZTBGBE40 PIC 9(6).
041000 07 HORA-CREACION-ZTBGBE40 PIC 9(6).
041100 07 FECHA-ULT-INSERCION-ZTBGBE40 PIC 9(6).
041200 07 HORA-ULT-INSERCION-ZTBGBE40 PIC 9(6).
041300 07 CLAVE-ULTREG-ENV-ZTBGBE40 PIC 9(12).
041400 07 CLAVE-ULTREG-CON-ZTBGBE40 PIC 9(12).
041500 07 CLAVE-ULTREG-INT-ZTBGBE40 PIC 9(12).
041600 07 SIGLO-TRANSMISION-ZTBGBE40 PIC X(2).
041700 07 SIGLO-ULT-CONF-ZTBGBE40 PIC X(2).
041800 07 SIGLO-CREACION-ZTBGBE40 PIC X(2).
041900 07 SIGLO-ULT-INSERCION-ZTBGBE40 PIC X(2).
042000 07 FILLER PIC X(18).
042100*
042200*
042300 LINKAGE SECTION.
042400*----------------
042500*
042600 01 AREA-ENTRADA PIC X(10400).
042700*
042800*
042900 PROCEDURE DIVISION USING AREA-ENTRADA.
043000***************************************
043100*
043200 N1-P-PROGRAMA.
043300*--------------
043400*
043500 MOVE AREA-ENTRADA TO AREA-COMUN.
043600 MOVE RESTO-AREA-COMUN TO AREA-ZTBGBE40.
043700 MOVE ZEROS TO CODIGO-RDO-ZTBGBE40
043800 WRETORNO.
043900*
044000 IF ( FICHERO-UNICO-ZTBGBE40 = 'S' AND
044100 PRIMER-FICHERO-ZTBGBE40 = 'S' ) OR
044200 FICHERO-UNICO-ZTBGBE40 = 'N'
044300*
044400 PERFORM N2-P-10-ABRIR-FICHEROS
044500 THRU N2-F-10-ABRIR-FICHEROS
044600*
044700 IF WRETORNO = 0
044800 PERFORM N2-P-20-PROCESO
044900 THRU N2-F-20-PROCESO
045000 PERFORM N2-P-30-CERRAR-FICHEROS
045100 THRU N2-F-30-CERRAR-FICHEROS
045200 ELSE
045300 PERFORM N2-P-30-CERRAR-FICHEROS
045400 THRU N2-F-30-CERRAR-FICHEROS.
045500*
045600 MOVE WRETORNO TO CODIGO-RDO-ZTBGBE40.
045700 MOVE AREA-ZTBGBE40 TO RESTO-AREA-COMUN.
045800 MOVE AREA-COMUN TO AREA-ENTRADA.
045900*
046000 N1-F-PROGRAMA.
046100*--------------
046200 GOBACK.
046300*
046400/*****************************************************************
046500****** - NIVEL 2 - ******
046600******************************************************************
046700*
046800*
046900 N2-P-10-ABRIR-FICHEROS.
047000*-----------------------
047100*
047200* -----> ABRE EL FICHERO DE APLICACION.
047300*
047400 OPEN OUTPUT SALIDA.
047500 IF FS-SALIDA NOT = '00'
047600 MOVE 12 TO WRETORNO
047700 DISPLAY '* ZTBGBE40 - ERROR OPEN OUTPUT DE SALIDA. FILE
047800- 'STATUS: ' FS-SALIDA
047900 ELSE
048000 MOVE 'SI' TO SALIDA-ABIERTO.
048100*
048200 N2-F-10-ABRIR-FICHEROS.
048300*-----------------------
048400 EXIT.
048500*
048600*
048700*
048800 N2-P-20-PROCESO.
048900*-----------------
049000*
049100* ---> MUEVE LOS CAMPOS AL REGISTRO DEL FICHERO DE APLICACION
049200*
049300 PERFORM N3-P-MOVER-DATOS-SALIDA
049400 THRU N3-F-MOVER-DATOS-SALIDA
049500*
049600* ---> ACTUALIZA EL FICHERO DE APLICACION
049700*
049800 PERFORM N3-P-ACTUALIZAR-SALIDA
049900 THRU N3-F-ACTUALIZAR-SALIDA.
050000*
050100 N2-F-20-PROCESO.
050200*-----------------
050300 EXIT.
050400*
050500*
050600 N2-P-30-CERRAR-FICHEROS.
050700*-----------------------
050800*
050900* ---- SI HA PODIDO ABRIR EL FICHERO DE APLICACION LO CIERRA.
051000*
051100 IF SALIDA-ABIERTO = 'SI'
051200 CLOSE SALIDA
051300 IF FS-SALIDA NOT = '00'
051400 IF WRETORNO = 0
051500 MOVE 12 TO WRETORNO
051600 DISPLAY '* ZTBGBE40 - ERROR CLOSE DE SALIDA. FILE S
051700- 'TATUS: ' FS-SALIDA
051800 ELSE
051900 NEXT SENTENCE
052000 ELSE
052100 NEXT SENTENCE.
052200*
052300 N2-F-30-CERRAR-FICHEROS.
052400*-----------------------
052500 EXIT.
052600*
052700/*****************************************************************
052800****** - NIVEL 3 - ******
052900******************************************************************
053000*
053100 N3-P-MOVER-DATOS-SALIDA.
053200*-------------------------*
053300*
053400* ---- SE MUEVEN LOS CAMPOS :
053500* ---- FECHA-ULT-CONFIRMACION-TAMPON
053600* ---- HORA-ULT-CONFIRMACION-TAMPON
053700* ---- AL AREA PARA FORMAR EL REGISTO DEL FICHERO DE APLICACION
053800* ---- CON EL SIGUIENTE FORMATO '0AAAAMMDDHHMISS'
053900*
054000 MOVE FECHA-ULT-CONF-ZTBGBE40 TO WFECHA.
054100 MOVE SIGLO-ULT-CONF-ZTBGBE40 TO SIGLO-SALIDA.
054200 MOVE WAAAA TO AAAA-SALIDA.
054300 MOVE WMES TO MES-SALIDA.
054400 MOVE WDIA TO DIA-SALIDA.
054500 MOVE HORA-ULT-CONF-ZTBGBE40 TO HORA-SALIDA.
054600*
054700 IF (WFECHA IS NOT NUMERIC) OR
054800 (WFECHA = ZEROS)
054900 MOVE ZEROS TO SIGLO-SALIDA
055000 ELSE
055100 IF (SIGLO-SALIDA = SPACES OR LOW-VALUES OR ZEROS) OR
055200 (SIGLO-SALIDA IS NOT NUMERIC)
055300 IF AAAA-SALIDA < 95
055400 MOVE 20 TO SIGLO-SALIDA
055500 ELSE
055600 MOVE 19 TO SIGLO-SALIDA.
055700*
055800 N3-F-MOVER-DATOS-SALIDA.
055900*-------------------------*
056000 EXIT.
056100*
056200*
056300 N3-P-ACTUALIZAR-SALIDA.
056400*------------------------
056500*
056600*--- ESCRIBE EL REGISTRO EN EL FICHERO DE APLICACION.
056700*
056800 WRITE REG-SALIDA FROM WREGISTRO-SALIDA.
056900*
057000 IF FS-SALIDA NOT = '00'
057100 MOVE 12 TO WRETORNO
057200 DISPLAY '* ZTBGBE40 - ERROR EN WRITE DE SALIDA. FILE STA
057300- 'TUS: ' FS-SALIDA
057400 ELSE
057500 NEXT SENTENCE.
057600*
057700 N3-F-ACTUALIZAR-SALIDA.
057800*-----------------------
057900 EXIT.
058000*
Última actualización