000001****************************************************************** 000002* * 000003* I D E N T I F I C A T I O N D I V I S I O N * 000004* * 000005* - PROGRAMA : RUT9123 FECHA : 23/11/1998 * 000006* * 000048****************************************************************** 000080 000081 IDENTIFICPYION DIVISION. 000082 000083 PROGRAM-ID. RUT9123. 000084 AUTHOR. USRJMP. 000085 000086****************************************************************** 000087* * 000088* E N V I R O N M E N T D I V I S I O N * 000089* * 000090****************************************************************** 000091 000092 ENVIRONMENT DIVISION. 000093 000094****************************************************************** 000095* CONFIGURATION SECTION * 000096****************************************************************** 000097 000098 CONFIGURATION SECTION. 000099 000100 SPECIAL-NAMES. 000101 DECIMAL-POINT IS COMMA. 000102 000103****************************************************************** 000104* * 000105* D A T A D I V I S I O N * 000106* * 000107****************************************************************** 000108 000109 DATA DIVISION. 000110 000111****************************************************************** 000112* WORKING STORAGE SECTION * 000113****************************************************************** 000114 000115 WORKING-STORAGE SECTION. 000120 000121****************************************************************** 000122* CONSTANTES Y LITERALES * 000123****************************************************************** 000124 000125 01 VARIABLES. 000126 05 W-COD-DPTO PIC 9(9). 000127 000128 01 LITERALES. 000129 05 RUT0113 PIC X(7) VALUE 'RUT0113'. 000130 05 RUT6131 PIC X(7) VALUE 'RUT6131'. 000131 05 RUT9040 PIC X(7) VALUE 'RUT9040'. 000132 000133 01 CONSTANTES. 000134 05 WK-COD-EMP-MATRIZ PIC 9(4) COMP VALUE 123. 000135 05 WK-FEC-ALTA PIC X(10) VALUE '2008-01-01'. 000136 05 CTTE-1 PIC X(1) VALUE '1'. 000137 05 CTTE-3 PIC X(1) VALUE '3'. 000138 000139* 000140****************************************************************** 000141* COPY PARA EL AREA DE CABECERA DE LA LLAMADA A RUT6131 000142****************************************************************** 000143 COPY COPY604. 000144* 000145****************************************************************** 000146* COPY PARA EL AREA DE DATOS DE LA LLAMADA A RUT6131 000147****************************************************************** 000148 COPY COPY399. 000149* 000150****************************************************************** 000151* COPY DE LOS CAMPOS PROPIOS DE LA RUTINA RUT6131 000152****************************************************************** 000153 COPY COPY007. 000154* 000155****************************************************************** 000156* COPY DE LOS CAMPOS DE LA LLAMADA A LA RUTINA RUT0113 000157****************************************************************** 000158 COPY COPY004. 000159* 000160****************************************************************** 000161* COPY DE LOS CAMPOS DE LA LLAMADA A LA RUTINA RUT9040 000162****************************************************************** 000163 COPY CPYERROR. 000164 COPY CPDATOSL. 000165 COPY CPKEYSDB. 000166 COPY CPYFUNCI. 000167 COPY CADEF040. 000168* 000169****************************************************************** 000170* I N D I C A D O R E S * 000171****************************************************************** 000172 000173 01 SWITCHES. 000174 05 SW-TIPO-DOCUMENTO PIC 9(2). 000175 88 EMPR-PUBLICA VALUE 1, 5, 6, 7, 8. 000176 000177 05 SW-TIPO-AVALISTA PIC 9(3). 000178 88 TIP-AVAL-OK VALUE 019, 101, 202, 212, 303. 000179 000180****************************************************************** 000181* DCLGENS * 000182****************************************************************** 000183 000184 EXEC SQL 000185 INCLUDE T0923100 000186 END-EXEC. 000187 000188 EXEC SQL 000189 INCLUDE T0536200 000190 END-EXEC. 000191 000192 EXEC SQL 000193 INCLUDE SQLCA 000194 END-EXEC. 000195 000196****************************************************************** 000197* LINKAGE SECTION * 000198****************************************************************** 000199 000200 LINKAGE SECTION. 000201 COPY COPY069. 000223 000224****************************************************************** 000225* * 000226* P R O C E D U R E D I V I S I O N * 000227* * 000228****************************************************************** 000229 000230 PROCEDURE DIVISION USING COPY069. 000231 000232****************************************************************** 000233* E S T R U C T U R A * 000234****************************************************************** 000235 PROGRAMA. 000236 000237 PERFORM PRINCIPIO-PROGRAMA 000238 PERFORM PROCESO-PROGRAMA 000239 PERFORM FIN-PROGRAMA 000240 . 000241 000242****************************************************************** 000243* N I V E L - 1 - * 000244****************************************************************** 000245****************************************************************** 000246* PROCESO PROGRAMA * 000247****************************************************************** 000248 PROCESO-PROGRAMA. 000249* 000250 IF COPY069-OPC-CD EQUAL '1' OR '2' 000251 AND (COPY069-FRM-FF NOT LESS WK-FEC-ALTA OR 000252 COPY069-ACN-IN EQUAL 'N') 000253 000254 PERFORM EXAMINAR-TIPO-EMPRESA 000255 000256* IF COPY069-TIP-EMPR-CD = 'P' 000257* OR (COPY069-TIP-EMPR-CD = 'J' AND W-INCLUIDO = 'S' ) 000258 000259 IF COPY069-TIP-ACRDO-IN = 'S' 000260 000261 PERFORM COMPROBAR-AVAL-OK 000262 000263 IF TIP-AVAL-OK 000264 MOVE 'S' TO COPY069-TIP-AVAL-IN 000265 ELSE 000266 MOVE 'N' TO COPY069-TIP-AVAL-IN 000267 END-IF 000268 000269 END-IF 000270 000271 END-IF 000272 . 000273****************************************************************** 000274* N I V E L - 2 - * 000275****************************************************************** 000276****************************************************************** 000277* EXAMINAR SI EL EXPEDIENTE SE CORRESPONDE CON UNA EMPRESA * 000278* PUBLICA Y LA DEUDA ESTA AVALADA. * 000279****************************************************************** 000280 EXAMINAR-TIPO-EMPRESA. 000281 000282 PERFORM COMPROBAR-EMPRESA-PUBLICA 000283 000284 IF EMPR-PUBLICA 000285 MOVE 'S' TO COPY069-TIP-ACRDO-IN 000286 ELSE 000287 PERFORM EXAMINAR-EMPRESA-PRIVADA 000288 END-IF 000289 000290 . 000291****************************************************************** 000292* FORMATEAR EXPEDIENTE CORRECTAMENTE. * 000293* LLAMADA A LA RUTINA RUT0113. * 000294****************************************************************** 000295 FORMATEAR-NUM-ACUERDO. 000296 000297 INITIALIZE COPY004-AREA 000298 MOVE COPY069-ACUERDO-NU TO COPY004-TEXTO 000299 000300 CALL RUT0113 USING COPY004-AREA 000301 000302 IF COPY004-ERROR EQUAL 1 000303 MOVE 1 TO COPY069-RTO-CD 000304 MOVE 'TAB016' TO COPY069-CODIG-MENS 000305 MOVE 'RUT0113' TO COPY069-VAR-1 000306 PERFORM FIN-PROGRAMA 000307 END-IF 000308 000309 MOVE COPY004-NUM11 TO COPY069-ACUERDO-NU 000310 . 000311****************************************************************** 000312* SE LLAMA A LA RUTINA RUT6131 PARA EXAMINAR SI EL ACUERDO * 000313* SE CORRESPONDE CON UNA EMPRESA PUBLICA * 000314****************************************************************** 000315* RETORNO-RUT6131 * 000316* SI ES ESPACIOS ES CORRECTO. * 000317* SI ES 'E' SERIA UN ERROR SEVERO. * 000318* SI ES 'P' ES UN ERROR EN LOS PARAMETROS DE ENTRADA. * 000319* SI ES 'I' SERA UN ERROR INFORMATIVO. * 000320* SI ES 'S' ES QUE NO HA ENCONTRADO NINGUN REGISTRO CON LAS * 000321* CARACTERISTICAS DE LOS DATOS DE ENTRADA. * 000322****************************************************************** 000323 COMPROBAR-EMPRESA-PUBLICA. 000324 000325 INITIALIZE COPY604 000326 COPY399 000327 000328* RELLENAR CABECERA 000329 MOVE 'RUT9123' TO COPY604-USUARIO 000330 MOVE COPY069-CABECERA-CD TO COPY604-FILIAL 000331 MOVE COPY069-DEPTO-CD TO COPY604-OFICINA 000332 MOVE 7 TO COPY604-SERVICIO 000333 MOVE 1 TO COPY604-VERSION 000334 COPY604-IDIOMA 000335 COPY604-BLOQUE 000336 MOVE 1 TO COPY604-FILAS 000337 000338* RELLENAR COPY DE DATOS 000339 MOVE COPY069-CABECERA-CD TO CFILIAL-COPY007 000340 MOVE COPY069-DEPTO-CD TO CD-DPTO-COPY007 000341 MOVE WK-COD-EMP-MATRIZ TO CCONTR-COPY007 000342 MOVE COPY069-ACUERDO-NU TO CFOLIO-COPY007 000343 MOVE ZEROES TO PARAM1-COPY007 000344 000345 MOVE R-COPY007 TO COPY399 000346 000347 CALL RUT6131 USING COPY604 COPY399 000348 000349 IF (COPY604-TIPOERR EQUAL SPACES OR LOW-VALUES OR 'I') OR (COPY604-NUMERTI EQUAL 'K048') 000351 IF COPY604-NUMERTI EQUAL 'K048' 000352 MOVE 1 TO COPY069-RTO-CD 000353 MOVE 'TP1343' TO COPY069-CODIG-MENS 000354 END-IF 000355 MOVE COPY399 TO R-COPY007 000356 MOVE CTIPCL-COPY007(1) TO SW-TIPO-DOCUMENTO 000357 MOVE CDPTO-COPY007(1) TO W-COD-DPTO 000358 ELSE 000359 EVALUATE COPY604-TIPOERR 000360 000361 WHEN 'E' 000362 IF COPY604-CODERR EQUAL -811 000363 MOVE '1' TO COPY069-RTO-CD 000364 MOVE 'TP9016' TO COPY069-CODIG-MENS 000365 MOVE ' ACUERDO' TO COPY069-VAR-1 000366 MOVE ' ' TO COPY069-VAR-2 000367 PERFORM FIN-PROGRAMA 000368 ELSE 000369 MOVE '9' TO COPY069-RTO-CD 000370 MOVE COPY604-CODERR TO COPY069-SQL-CD 000371 MOVE COPY604-TABERR TO COPY069-TAB-NO 000372 PERFORM FIN-PROGRAMA 000373 END-IF 000374 000375 WHEN 'S' 000376 MOVE '3' TO COPY069-RTO-CD 000377 PERFORM FIN-PROGRAMA 000378 000379 WHEN 'P' 000380 MOVE '1' TO COPY069-RTO-CD 000381 PERFORM FIN-PROGRAMA 000382 000383 WHEN OTHER 000384 MOVE '9' TO COPY069-RTO-CD 000385 MOVE COPY604-CODERR TO COPY069-SQL-CD 000386 MOVE COPY604-TABERR TO COPY069-TAB-NO 000387 PERFORM FIN-PROGRAMA 000388 000389 END-EVALUATE 000390 END-IF 000391 . 000392****************************************************************** 000393* SE LLAMA AL MODULO RUT9040 * 000394* PARA EXAMINAR LO QUE FACTURA EL PROVEEDOR * 000396****************************************************************** 000419 EXAMINAR-EMPRESA-PRIVADA. 000420 000421 INITIALIZE VALOR-FUNCION 000422 TABLA-CLAVES 000423 VALOR-DATOS 000424 CPYERROR 000425 000426* RELLENAR CABECERA 000427 MOVE COPY069-CABECERA-CD TO COD-CBANTE51-040 000428 MOVE COPY069-DEPTO-CD TO COD-COFITE51-040 000429 MOVE 'RUT9123' TO COD-CUSUAR51-040 000430 MOVE W-COD-DPTO TO COD-CDPTO-040 000431 MOVE 40 TO FUNCION-NUM 000432 000433 MOVE R-RUT9040 TO VALOR-DATOS 000434 000435 CALL RUT9040 USING VALOR-FUNCION 000436 TABLA-CLAVES 000437 VALOR-DATOS 000438 CPYERROR 000439 000440 MOVE VALOR-DATOS TO R-RUT9040 000441 000442* -------------------------- 000443* EXAMINAR ERROR 000444* -------------------------- 000445 IF COD-ERRDB2-040 OF R-RUT9040 NOT EQUAL SPACES OR COD-ERRDATOS-040 OF R-RUT9040 NOT EQUAL SPACES OR COD-NUMERR50-040 OF R-RUT9040 NOT EQUAL SPACES 000448 DISPLAY '** ERROR EN LLAMADA A MODULO RUT9040 **' 000449 DISPLAY 'COD-ERRDATOS-040 :' COD-ERRDATOS-040 000450 DISPLAY 'COD-ERRDB2-040 :' COD-ERRDB2-040 000451 DISPLAY 'COD-NUMERR50-040 :' COD-NUMERR50-040 000452 DISPLAY 'DES-CTEXTO50-040 :' DES-CTEXTO50-040 000453* 000454* EVALUATE COD-NUMERR50-040 OF R-RUT9040 000455* WHEN '255' ' ERROR DE PARAMETROS 000456* WHEN 'SQL' ' ERROR DB2 000457* WHEN '115' ' NO EXISTE EN LA BD ' NO ES ERROR 000458* END-EVALUATE 000459 000460 PERFORM FIN-PROGRAMA 000461 000462 END-IF 000463 000464* -------------------------------------------------------- 000465* LA RUTINA DEVUELVE EL IMPORTE A CONSIDERAR EN EL CAMPO 000466* IMP-FACTURA-040, EXPRESADO EN MILES DE EUROS 000467* -------------------------------------------------------- 000468 000469 IF IMP-FACTURA-040 <= 8000 000470 MOVE 'S' TO COPY069-TIP-ACRDO-IN 000471 ELSE 000472 MOVE 'N' TO COPY069-TIP-ACRDO-IN 000473 END-IF 000474 . 000475****************************************************************** 000476* COMPROBAMOS EL AVAL 000477****************************************************************** 000478 COMPROBAR-AVAL-OK. 000479 IF COPY069-OPC-CD EQUAL '1' 000480 000481 PERFORM SELECT-NUM-ACUERDO 000482 IF SQLCODE EQUAL ZEROES 000483 MOVE FLD-TIP-ACUERDO-IN TO SW-TIPO-AVALISTA 000484 ELSE 000485* DEVOLVER ERROR 9198 000486 END-IF 000487 END-IF 000488 000489 IF COPY069-OPC-CD EQUAL '2' 000490 000491 PERFORM SELECT-ACUERDO-PP 000492 IF SQLCODE EQUAL ZEROES 000493 000494 PERFORM SELECT-NUM-ACUERDO2 000495 IF SQLCODE EQUAL ZEROES 000496 MOVE FLD-TIP-ACUERDO-IN TO SW-TIPO-AVALISTA 000497 END-IF 000498 END-IF 000499 000500 END-IF 000501 . 000502****************************************************************** 000503* T R A T A M I E N T O S * 000504****************************************************************** 000505****************************************************************** 000506* PRINCIPIO PROGRAMA * 000507* VALIDA LOS VALORES BASICOS DE LAS ENTRADAS E INICIALIZA * 000508* LA SALIDA * 000509 ***************************************************************** 000510 PRINCIPIO-PROGRAMA. 000511 000512* ---------------------------------- 000513* INICIALIZACIONES 000514* ---------------------------------- 000515 MOVE ZEROES TO SW-TIPO-DOCUMENTO 000516 SW-TIPO-AVALISTA 000517 000518 MOVE ZEROES TO COPY069-RTO-CD 000519 COPY069-SQL-CD 000520 000521 MOVE SPACES TO COPY069-CODIG-MENS 000522 COPY069-TAB-NO 000523 COPY069-VAR-1 000524 COPY069-VAR-2 000525 000526* INICIALIZA INDICADORES 000527 MOVE 'N' TO COPY069-TIP-ACRDO-IN 000528 COPY069-TIP-AVAL-IN 000529 000530* CARGAR FECHA DE LA RENOVACION DEL ACUERDO 000531 MOVE WK-FEC-ALTA TO COPY069-FEC-RNV-FF 000532 000533* ---------------------------------- 000534* VALIDACIONES 000535* ---------------------------------- 000536 IF COPY069-CABECERA-CD NOT GREATER SPACES 000537 MOVE 'A' TO COPY069-RTO-CD 000538 END-IF 000539 000540 IF COPY069-DEPTO-CD NOT GREATER SPACES 000541 MOVE 'B' TO COPY069-RTO-CD 000542 END-IF 000543 000544 IF COPY069-OPC-CD NOT NUMERIC 000545 MOVE 'C' TO COPY069-RTO-CD 000546 END-IF 000547 000548 IF COPY069-OPC-CD NOT EQUAL '1' AND '2' 000549 MOVE 'D' TO COPY069-RTO-CD 000550 END-IF 000551 000552 IF COPY069-FRM-FF NOT GREATER SPACES AND 000553 (COPY069-ACN-IN NOT EQUAL 'S' AND 'N') 000554 MOVE 'E' TO COPY069-RTO-CD 000555 END-IF 000556 000557 IF COPY069-ACUERDO-NU NOT GREATER SPACES 000558 MOVE 'P' TO COPY069-RTO-CD 000559 END-IF 000560 000561 PERFORM FORMATEAR-NUM-ACUERDO 000562 . 000563****************************************************************** 000564* FIN PROGRAMA * 000565* DEVUELVE EL CONTROL AL PROGRAMA LLAMADOR * 000566****************************************************************** 000567 000568 FIN-PROGRAMA. 000569 000570 GOBACK. 000571 000572 000573****************************************************************** 000574* RUTINAS AUXILIARES * 000575****************************************************************** 000576****************************************************************** 000577* SELECT NUM-ACUERDO * 000578****************************************************************** 000579 SELECT-NUM-ACUERDO. 000580 000581 MOVE COPY069-ACUERDO-NU TO FLD-ACUERDO-NU 000582 000583 EXEC SQL 000584 SELECT FLD-TIP-ACUERDO-IN 000585 INTO :FLD-TIP-ACUERDO-IN 000586 FROM TAB92310 000587 WHERE FLD-ACUERDO-NU = :FLD-ACUERDO-NU 000588 AND (FLD-RAI-CD = :CTTE-1 000589 OR FLD-RAI-CD = :CTTE-3) 000590 END-EXEC 000591 000592 IF SQLCODE NOT EQUAL ZERO AND 100 AND -811 000593 MOVE '9' TO COPY069-RTO-CD 000594 MOVE SQLCODE TO COPY069-SQL-CD 000595 MOVE 'TAB92310' TO COPY069-TAB-NO 000596 PERFORM FIN-PROGRAMA 000597 END-IF 000598 . 000599****************************************************************** 000600* SELECT NUM-ACUERDO2 * 000601****************************************************************** 000602 SELECT-NUM-ACUERDO2. 000603 000604 MOVE FLD02-ACU-NU TO FLD-ACU-NU 000605 000606 EXEC SQL 000607 SELECT FLD-TIP-ACUERDO-IN 000608 INTO :FLD-TIP-ACUERDO-IN 000609 FROM TAB92310 000610 WHERE FLD-ACU-NU = :FLD-ACU-NU 000611 END-EXEC 000612 000613 IF SQLCODE NOT EQUAL ZERO AND 100 AND -811 000614 MOVE '9' TO COPY069-RTO-CD 000615 MOVE SQLCODE TO COPY069-SQL-CD 000616 MOVE 'TAB92310' TO COPY069-TAB-NO 000617 PERFORM FIN-PROGRAMA 000618 END-IF 000619 . 000620****************************************************************** 000621* SELECT ACUERDO-PP * 000622****************************************************************** 000623 SELECT-ACUERDO-PP. 000624 000625 MOVE COPY069-ACUERDO-NU TO FLD02-CON-CD 000626 000627 EXEC SQL 000628 SELECT FLD02-ACU-NU 000629 INTO :FLD02-ACU-NU 000630 FROM TAB253620 000631 WHERE FLD02-CON-CD = :FLD02-CON-CD 000632 END-EXEC 000633 000634 IF SQLCODE NOT EQUAL ZERO AND 100 AND -811 000635 MOVE '9' TO COPY069-RTO-CD 000636 MOVE SQLCODE TO COPY069-SQL-CD 000637 MOVE 'TAB25362' TO COPY069-TAB-NO 000638 PERFORM FIN-PROGRAMA 000639 END-IF 000640 .