- Dettagli
- Visite: 819
IDENTIFICATION DIVISION.
PROGRAM-ID. PRTAQ061.
*--------------------------------------------------------------*
* PROGETTO RETTIFICHE *
* ------------------- *
* AUTORE : FRANCO D'AMICO C.O.DI MARSALA *
* *
* FUNZIONE : VARIAZ.PAGAMENTI - SUBFILE *
* PGM CHIAMANTI : PRTAQ05 *
* PGM CHIAMATI : PRTUT02 *
* MAPPE : MRTAQ051 *
* AREA DI INPUT : CRTMN01 - *
* ARCHIVI : LRTDEU4 *
*--------------------------------------------------------------*
ENVIRONMENT DIVISION.
SOURCE-COMPUTER. AS400.
OBJECT-COMPUTER. AS400.
SPECIAL-NAMES. DECIMAL-POINT IS COMMA.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT VIDEO ASSIGN TO WORKSTATION-MRTAQ05
ORGANIZATION IS TRANSACTION
ACCESS IS DYNAMIC
RELATIVE KEY IS CONTSUBF
FILE STATUS IS F-STATUS.
SELECT LRTDEU4 ASSIGN TO DATABASE-LRTDEU4
ORGANIZATION IS INDEXED
ACCESS IS DYNAMIC
RECORD KEY IS EXTERNALLY-DESCRIBED-KEY
WITH DUPLICATES
FILE STATUS IS F-STATUS.
DATA DIVISION.
FILE SECTION.
FD VIDEO
LABEL RECORD IS OMITTED.
01 REC-VIDEO.
COPY DDS-ALL-FORMAT OF MRTAQ05.
FD LRTDEU4
LABEL RECORD IS OMITTED.
01 REC-ARTDEUL4.
COPY DDS-ALL-FORMAT OF LRTDEU4 .
WORKING-STORAGE SECTION.
01 F-STATUS PIC XX.
01 CONTSUBF PIC 9(5).
01 IND-ON PIC 1 VALUE B"1".
01 IND-OFF PIC 1 VALUE B"0".
01 WFINE PIC 9.
01 MIO-SC7 PIC 9(12).
01 MIO-PROG PIC 9(4).
01 SUOPERI.
03 ANNO PIC 9(4).
03 MESE PIC 99.
01 MIOPERI.
03 MESE PIC 99.
03 FILLER PIC X VALUE "/".
03 ANNO PIC 9(4).
01 SUADATA.
03 WAAAA PIC 9(4).
03 WMM PIC 99.
03 WGG PIC 99.
01 MIADATA.
03 WGG PIC 99.
03 FILLER PIC X VALUE "/".
03 WMM PIC 99.
03 FILLER PIC X VALUE "/".
03 WAAAA PIC 9(4).
01 WSUBAREA.
03 WSCELTA PIC X.
03 WMATR PIC 9(10).
03 WIMP PIC 9(12).
03 WPERI PIC X(7).
03 WSC7 PIC 9(12).
03 WVERSAM PIC X(10).
03 WPROGR PIC 9(4).
01 BASE PIC Z(11).
01 WQUANTI PIC 9(5).
01 VIDEO-OPEN PIC 9 VALUE 0.
01 AREA-INDIC.
COPY DDS-ALL-FORMATS-INDIC OF MRTAQ05.
****************************************************************
* AREA DI COLLOQUIO COL PGM CHIAMANTE *
****************************************************************
LINKAGE SECTION.
BPINFO* CVR2019 Found explicit reference to library or file DCBCPY;
BPINFO* manual handling may be required
BPCHCK COPY CRTMN01 OF DCBCPY.
*****************************************************************
* P R O C E D U R E D I V I S I O N *
*****************************************************************
BPEURO PROCEDURE DIVISION USING AREA-MN01.
BPINFO* CVG1011 In field AREA-MN01 found the following classes:
BPINFO* CVG1010 Field CM1-IMPDA contains class AMOUNT.
BPINFO* CVG1010 Field CM1-IMPA contains class AMOUNT.
MAIN.
MOVE 0 TO CONTSUBF WQUANTI WFINE.
PERFORM APRI THRU EX-APRI.
MOVE IND-OFF TO IN12 OF MQ06CTL-I-INDIC.
PERFORM RIEMPI-MAPPA THRU EX-RIEMPI-MAPPA.
IF WQUANTI = 1
MOVE SPACES TO CM1-MSG
MOVE MIO-SC7 TO CM1-SC7
MOVE MIO-PROG TO CM1-PROG
BPEURO CALL "PRTAQ07" USING AREA-MN01
BPINFO* CVG1011 In field AREA-MN01 found the following classes:
BPINFO* CVG1010 Field CM1-IMPDA contains class AMOUNT.
BPINFO* CVG1010 Field CM1-IMPA contains class AMOUNT.
END-IF.
IF WQUANTI > 1
MOVE SPACES TO CM1-MSG
MOVE IND-OFF TO IN03 OF MQ06CTL-I-INDIC
IN12 OF MQ06CTL-I-INDIC
PERFORM SCRIVI-LEGGI THRU EX-SCRIVI-LEGGI
UNTIL IN03 OF MQ06CTL-I-INDIC = IND-ON
OR IN12 OF MQ06CTL-I-INDIC = IND-ON
OR WFINE = 1
END-IF.
IF WQUANTI = 0
MOVE "NESSUN PAGAMENTO SODDISFA LA RICHIESTA!"
TO CM1-MSG
END-IF.
FINE.
CLOSE LRTDEU4 VIDEO.
IF IN03 OF MQ06CTL-I-INDIC = IND-ON
STOP RUN
ELSE
GOBACK
END-IF.
APRI.
IF VIDEO-OPEN = 0
OPEN I-O VIDEO
MOVE 1 TO VIDEO-OPEN
IF F-STATUS NOT EQUAL "00"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "MRTAQ05" TO CM1-ERRFILE
MOVE "PRTAQ06" TO CM1-ERRPGM
MOVE 1 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
BPINFO* CVG1011 In field AREA-MN01 found the following classes:
BPINFO* CVG1010 Field CM1-IMPDA contains class AMOUNT.
BPINFO* CVG1010 Field CM1-IMPA contains class AMOUNT.
END-IF.
OPEN INPUT LRTDEU4.
IF F-STATUS NOT EQUAL "00"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "LRTDEU4 " TO CM1-ERRFILE
MOVE "PRTAQ06" TO CM1-ERRPGM
MOVE 2 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
BPINFO* CVG1011 In field AREA-MN01 found the following classes:
BPINFO* CVG1010 Field CM1-IMPDA contains class AMOUNT.
BPINFO* CVG1010 Field CM1-IMPA contains class AMOUNT.
END-IF.
EX-APRI.
EXIT.
RIEMPI-MAPPA.
IF VIDEO-OPEN = 1
CLOSE VIDEO
OPEN I-O VIDEO
END-IF.
MOVE 0 TO RDEUFLUTIL RDEUDTCAR RDEUMATAZI.
BPEURO READ LRTDEU4 NEXT.
BPINFO* CVG1011 In field LRTDEU4 found the following classes:
BPINFO* CVG1010 Field AIMPCONTR contains class AMOUNT.
BPINFO* CVG1010 Field AIMPCOMPE contains class AMOUNT.
BPINFO* CVG1010 Field AIMPORPAG contains class AMOUNT.
BPINFO* CVG1010 Field ATOTIMPCA contains class AMOUNT.
BPINFO* CVG1010 Field RDEUIMPUT contains class AMOUNT.
BPINFO* CVG1010 Field RDEUIMPDIS contains class AMOUNT.
IF F-STATUS NOT EQUAL "00" AND F-STATUS NOT = "10"
AND F-STATUS NOT = "23"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "LRTDEU4 " TO CM1-ERRFILE
MOVE "PRTAQ06" TO CM1-ERRPGM
MOVE 3 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
BPINFO* CVG1011 In field AREA-MN01 found the following classes:
BPINFO* CVG1010 Field CM1-IMPDA contains class AMOUNT.
BPINFO* CVG1010 Field CM1-IMPA contains class AMOUNT.
END-IF
PERFORM UNTIL F-STATUS NOT = "00" OR RDEUFLUTIL > 0
IF (CM1-SC7 = 0 OR
(CM1-SC7 > 0 AND RDEUSC724 = CM1-SC7))
AND (CM1-PROG = 0 OR
(CM1-PROG > 0 AND RDEUPROGR = CM1-PROG))
AND (CM1-MATRICOLA = 0 OR
(CM1-MATRICOLA > 0 AND RDEUMATAZI = CM1-MATRICOLA))
AND (CM1-D10PER = 0 OR
(RDEUPERCED = CM1-D10PER AND CM1-D10PER > 0))
BPEURO AND (CM1-IMPDA = 0 OR
BPEURO (CM1-IMPDA > 0 AND AIMPORPAG NOT < CM1-IMPDA))
BPEURO AND (CM1-IMPA = 0 OR
(CM1-IMPA > 0 AND AIMPORPAG NOT > CM1-IMPA))
AND (CM1-EMIDA = 0 OR
(CM1-EMIDA > 0 AND ADATARISC = CM1-EMIDA))
AND (CM1-COD-FISC = SPACES OR
(CM1-COD-FISC NOT = SPACES AND
ACODICFIS = CM1-COD-FISC))
AND RDEUFLUTIL = 0
BPINFO* CVG1110 Field CM1-IMPDA contains class AMOUNT.
BPINFO* CVG1110 Field AIMPORPAG contains class AMOUNT.
BPINFO* CVG1110 Field CM1-IMPA contains class AMOUNT.
ADD 1 TO CONTSUBF WQUANTI
IF WQUANTI = 1
MOVE RDEUSC724 TO MIO-SC7
MOVE RDEUPROGR TO MIO-PROG
END-IF
MOVE RDEUMATAZI TO MQ6MATR OF MQ06-O
MOVE RDEUPERCED TO SUOPERI
MOVE CORRESPONDING SUOPERI TO MIOPERI
MOVE MIOPERI TO MQ6PERI OF MQ06-O
MOVE ADATARISC TO SUADATA
MOVE CORRESPONDING SUADATA TO MIADATA
MOVE MIADATA TO MQ6VERS OF MQ06-O
BPDSPF MOVE AIMPORPAG TO MQ6IMP OF MQ06-O
BPINFO* CVG1118 Fields AIMPORPAG and MQ6IMP contain the following
BPINFO* class AMOUNT
MOVE RDEUSC724 TO MQ6SC7 OF MQ06-O
MOVE RDEUPROGR TO MQ6PROGR OF MQ06-O
BPDSPF WRITE SUBFILE REC-VIDEO FORMAT "MQ06"
BPINFO* CVG1011 In field REC-VIDEO found the following classes:
BPINFO* CVG1010 Field MQ5IMPDA contains class AMOUNT.
BPINFO* CVG1010 Field MQ5IMPA contains class AMOUNT.
IF F-STATUS NOT EQUAL "00"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "MRTAQ05" TO CM1-ERRFILE
MOVE "PRTAQ06" TO CM1-ERRPGM
MOVE 4 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
BPINFO* CVG1011 In field AREA-MN01 found the following classes:
BPINFO* CVG1010 Field CM1-IMPDA contains class AMOUNT.
BPINFO* CVG1010 Field CM1-IMPA contains class AMOUNT.
END-IF
END-IF
BPEURO READ LRTDEU4 NEXT
BPINFO* CVG1011 In field LRTDEU4 found the following classes:
BPINFO* CVG1010 Field AIMPCONTR contains class AMOUNT.
BPINFO* CVG1010 Field AIMPCOMPE contains class AMOUNT.
BPINFO* CVG1010 Field AIMPORPAG contains class AMOUNT.
BPINFO* CVG1010 Field ATOTIMPCA contains class AMOUNT.
BPINFO* CVG1010 Field RDEUIMPUT contains class AMOUNT.
BPINFO* CVG1010 Field RDEUIMPDIS contains class AMOUNT.
IF F-STATUS NOT EQUAL "00" AND F-STATUS NOT = "10"
AND F-STATUS NOT = "23"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "LRTDEU4 " TO CM1-ERRFILE
MOVE "PRTAQ06" TO CM1-ERRPGM
MOVE 5 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
BPINFO* CVG1011 In field AREA-MN01 found the following classes:
BPINFO* CVG1010 Field CM1-IMPDA contains class AMOUNT.
BPINFO* CVG1010 Field CM1-IMPA contains class AMOUNT.
END-IF
END-PERFORM.
EX-RIEMPI-MAPPA.
EXIT.
SCRIVI-LEGGI.
BPDSPF WRITE REC-VIDEO FORMAT "MQ05CODA".
BPINFO* CVG1011 In field REC-VIDEO found the following classes:
BPINFO* CVG1010 Field MQ5IMPDA contains class AMOUNT.
BPINFO* CVG1010 Field MQ5IMPA contains class AMOUNT.
MOVE CM1-DATACHIARO TO MQ6OGGI.
BPDSPF WRITE REC-VIDEO FORMAT "MQ06CTL".
BPINFO* CVG1011 In field REC-VIDEO found the following classes:
BPINFO* CVG1010 Field MQ5IMPDA contains class AMOUNT.
BPINFO* CVG1010 Field MQ5IMPA contains class AMOUNT.
BPDSPF READ VIDEO FORMAT "MQ06CTL"
INDICATORS ARE MQ06CTL-I-INDIC.
BPINFO* CVG1011 In field VIDEO found the following classes:
BPINFO* CVG1010 Field MQ5IMPDA contains class AMOUNT.
BPINFO* CVG1010 Field MQ5IMPA contains class AMOUNT.
IF F-STATUS NOT EQUAL "00"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "MRTAQ05" TO CM1-ERRFILE
MOVE "PRTAQ06" TO CM1-ERRPGM
MOVE 5 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
BPINFO* CVG1011 In field AREA-MN01 found the following classes:
BPINFO* CVG1010 Field CM1-IMPDA contains class AMOUNT.
BPINFO* CVG1010 Field CM1-IMPA contains class AMOUNT.
END-IF.
IF IN12 OF MQ06CTL-I-INDIC = IND-ON
GO TO EX-SCRIVI-LEGGI
END-IF.
BPDSPF READ SUBFILE VIDEO MODIFIED INTO WSUBAREA FORMAT "MQ06"
AT END
BPINFO* CVG1011 In field VIDEO found the following classes:
BPINFO* CVG1010 Field MQ5IMPDA contains class AMOUNT.
BPINFO* CVG1010 Field MQ5IMPA contains class AMOUNT.
MOVE 0 TO WFINE
NOT AT END
MOVE 1 TO WFINE.
IF WFINE = 0
GO TO FINE
END-IF.
IF WFINE = 1
MOVE SPACES TO MQ6SCEL OF MQ06-I CM1-MSG
MOVE 0 TO CM1-SC7 CM1-PROG
BPDSPF REWRITE SUBFILE REC-VIDEO FORMAT IS "MQ06"
BPINFO* CVG1011 In field REC-VIDEO found the following classes:
BPINFO* CVG1010 Field MQ5IMPDA contains class AMOUNT.
BPINFO* CVG1010 Field MQ5IMPA contains class AMOUNT.
MOVE MQ6SC7 OF MQ06-O TO CM1-SC7
MOVE MQ6PROGR OF MQ06-O TO CM1-PROG
BPEURO CALL "PRTAQ07" USING AREA-MN01
BPINFO* CVG1011 In field AREA-MN01 found the following classes:
BPINFO* CVG1010 Field CM1-IMPDA contains class AMOUNT.
BPINFO* CVG1010 Field CM1-IMPA contains class AMOUNT.
END-IF.
EX-SCRIVI-LEGGI.
EXIT.
