- Dettagli
- Visite: 905
*$ COMMIT *CHG
IDENTIFICATION DIVISION.
PROGRAM-ID. PRTAQ011.
*--------------------------------------------------------------*
* PROGETTO RETTIFICHE *
* ------------------- *
* AUTORE : FRANCO D'AMICO C.O.DI MARSALA *
* *
* FUNZIONE : ACQUISIZIONE INTERATTIVA PAGAMENTI *
* A FINE ACQUISIZIONE STAMPO L'SC3 PER LA RAG. *
* E SCRIVO 1 IN RDEUSTSC3 NEL RECORD CHE HA COME*
* CHIAVE L'SC3 E 1 IN RDEUNSC3 (IL 1° PROGRESS.)*
* L'ACQUIS. È INIBITA SE L'SC3 È STATO STAMPATO *
* PGM CHIAMANTI : PRTMN01 *
* PGM CHIAMATI : *
* MAPPE : MRTAQ01 *
* AREA DI INPUT : *
* ARCHIVI : LRTDEU2 *
*--------------------------------------------------------------*
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-AS400.
OBJECT-COMPUTER. IBM-AS400.
SPECIAL-NAMES. DECIMAL-POINT IS COMMA
REQUESTOR IS WORK-STATION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT VIDEO ASSIGN TO WORKSTATION-MRTAQ01-SI
ORGANIZATION IS TRANSACTION
ACCESS IS SEQUENTIAL
FILE STATUS IS F-STATUS.
SELECT ARTDEU ASSIGN TO DATABASE-LRTDEU2
ORGANIZATION IS INDEXED
ACCESS IS DYNAMIC
RECORD KEY IS EXTERNALLY-DESCRIBED-KEY
WITH DUPLICATES
FILE STATUS IS F-STATUS.
I-O-CONTROL.
COMMITMENT CONTROL FOR ARTDEU.
DATA DIVISION.
FILE SECTION.
FD VIDEO
LABEL RECORD IS OMITTED.
01 REC-VIDEO.
COPY DDS-ALL-FORMAT OF MRTAQ01.
FD ARTDEU
LABEL RECORD IS OMITTED.
01 REC-ARTDEU.
COPY DDS-ALL-FORMAT OF LRTDEU2.
WORKING-STORAGE SECTION.
*********************************************
EXEC SQL
INCLUDE SQLCA
END-EXEC.
01 F-STATUS PIC XX.
01 IND-ON PIC 1 VALUE B"1".
01 IND-OFF PIC 1 VALUE B"0".
01 WUTIL PIC S9.
01 WPROPER PIC S9(4) VALUE 0.
01 DATASC3 PIC S9(8) VALUE 0.
01 PROGSC3 PIC S9(4) VALUE 0.
01 PERI.
03 ANNOPERI PIC 9(4).
03 MESEPERI PIC 99.
01 WPERI PIC S9(6).
01 SUADATA.
03 ANNO PIC 9(4).
03 MESE PIC 99.
03 GIORNO PIC 99.
01 AREA-VIDEO.
03 WRAG PIC 9(11).
03 WMATR PIC 9(10).
03 WMEPER PIC 9(2).
03 WANPER PIC 9(4).
BPOLD2* 03 WIMPPA PIC 9(15).
BPNEW2 03 WIMPPA PIC 9(13)V9(002).
BPINFO* CVG1110 Field WIMPPA contains class AMOUNT.
03 WGIORPA PIC 9(2).
03 WMESEPA PIC 9(2).
03 WANNOPA PIC 9(4).
03 WSC3 PIC 9(8).
03 WPROGR PIC 9(4).
03 WSC3N PIC 99.
01 WSC3PR PIC S9(2).
01 WERRORE PIC 9.
01 WSTSC PIC S9(1).
01 WMATAZI PIC X(10).
01 WWMATAZI REDEFINES WMATAZI.
03 WWCODPRO PIC S99.
03 WWMATAZI PIC S9(6).
03 WWCTRCOD PIC S99.
01 ESISTE PIC S9.
01 AREA-INDIC.
COPY DDS-ALL-FORMATS-INDIC OF MRTAQ01.
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.
MAIN.
MOVE CM1-SC3 TO DATASC3.
MOVE CM1-SC3PR TO WSC3PR.
MOVE 0 TO PROGSC3 WSTSC WPROPER WMATAZI.
MOVE 9 TO WUTIL.
MOVE 0 TO WERRORE.
BPDSPF MOVE LOW-VALUE TO AREA-VIDEO.
PERFORM APRI THRU EX-APRI.
MOVE IND-OFF TO IN12 OF MA01-I-INDIC.
*se non sto acquisendo un nuovo SC3
IF CM1-SC3PR > 0
*cerco il progr. massimo cedola acquisita
EXEC SQL
SELECT MAX(RDEUNSC3) INTO :PROGSC3
FROM LRTDEU2
WHERE RDEUDTSC3 = :DATASC3
AND RDEUPRSC3 = :WSC3PR
END-EXEC
END-IF.
IF PROGSC3 > 0
*controllo se la prima cedola porta notizia della chiusura SC3
EXEC SQL
SELECT RDEUSTSC3, RDEUFLUTIL INTO :WSTSC, :WUTIL
FROM LRTDEU2
WHERE RDEUDTSC3 = :DATASC3
AND RDEUPRSC3 = :WSC3PR
AND RDEUNSC3 = 1
END-EXEC
END-IF.
*se l'SC3 è chiuso (stampato)
IF WSTSC = 1 OR WUTIL = 0
STRING "IMPOSSIBILE ACQUISIRE CON N° " DATASC3 " /"
CM1-SC3PR
DELIMITED BY SIZE INTO CM1-MSG
GO TO FINE
END-IF.
PERFORM SEQUENZA THRU EX-SEQUENZA
UNTIL IN12 OF MA01-I-INDIC = IND-ON.
*con F12 chiedo:se si vuole chiusede l'SC3
IF WERRORE = 1
GO TO FINE
END-IF
BPDSPF WRITE REC-VIDEO FORMAT "MA08".
BPDSPF READ VIDEO FORMAT "MA08".
IF MA08SN OF MA08-I IS = "N"
GO TO FINE
END-IF.
IF PROGSC3 > 0
BPEURO CALL "PRTST01" USING AREA-MN01
EXEC SQL
UPDATE ARTDEU SET RDEUSTSC3 = 1
WHERE RDEUDTSC3 = :DATASC3 AND RDEUNSC3 = 1
AND RDEUPRSC3 = :WSC3PR
END-EXEC
IF SQLCODE = 0
EXEC SQL COMMIT END-EXEC
ELSE
EXEC SQL ROLLBACK END-EXEC
END-IF
END-IF.
FINE.
CLOSE VIDEO ARTDEU.
GOBACK.
APRI.
OPEN I-O VIDEO.
IF F-STATUS NOT EQUAL "00"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "MRTAQ01" TO CM1-ERRFILE
MOVE "PRTAQ01" TO CM1-ERRPGM
MOVE 2 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF.
OPEN I-O ARTDEU.
IF F-STATUS NOT EQUAL "00"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "ARTDEU" TO CM1-ERRFILE
MOVE "PRTAQ01" TO CM1-ERRPGM
MOVE 3 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF.
EX-APRI.
EXIT.
SEQUENZA.
BPEURO CALL "PRTUT01" USING AREA-MN01.
IF WERRORE = 1
BPDSPF MOVE AREA-VIDEO TO REC-VIDEO
END-IF.
MOVE IND-OFF TO IN12 OF MA01-I-INDIC.
ADD 1 TO PROGSC3 .
MOVE DATASC3 TO MA0SC3 OF MA01-I.
MOVE CM1-SC3PR TO MA0SC3N OF MA01-I.
MOVE PROGSC3 TO MA0PROGR OF MA01-I.
BPDSPF WRITE REC-VIDEO FORMAT "MA01".
IF F-STATUS NOT EQUAL "00"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "MRTAQ01" TO CM1-ERRFILE
MOVE "PRTAQ01" TO CM1-ERRPGM
MOVE 5 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF.
BPDSPF READ VIDEO FORMAT "MA01"
INDICATORS ARE AREA-INDIC.
IF F-STATUS NOT EQUAL "00"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "MRTAQ01" TO CM1-ERRFILE
MOVE "PRTAQ01" TO CM1-ERRPGM
MOVE 6 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF.
IF IN12 OF MA01-I-INDIC = IND-ON
MOVE SPACES TO CM1-MSG
GO TO EX-SEQUENZA
END-IF.
MOVE 0 TO WERRORE.
IF MA0ANNOPA OF MA01-I IS NOT NUMERIC
OR MA0RAG OF MA01-I IS NOT NUMERIC
OR MA0MESEPA OF MA01-I IS NOT NUMERIC
OR MA0GIORPA OF MA01-I IS NOT NUMERIC
BPDSPF OR MA0IMPPA OF MA01-I IS NOT NUMERIC
MOVE "Acquisizione fallita perchè incompleta" TO CM1-MSG
COMPUTE PROGSC3 = PROGSC3 - 1
MOVE 1 TO WERRORE
PERFORM CONTROLLO THRU EX-CONTROLLO
GO TO EX-SEQUENZA
END-IF.
IF MA0ANNOPA OF MA01-I IS = 0
OR MA0RAG OF MA01-I IS = 0
OR MA0MESEPA OF MA01-I IS = 0
OR MA0GIORPA OF MA01-I IS = 0
BPDSPF OR MA0IMPPA OF MA01-I IS = 0
MOVE "Acquisizione fallita perchè incompleta" TO CM1-MSG
COMPUTE PROGSC3 = PROGSC3 - 1
MOVE 1 TO WERRORE
PERFORM CONTROLLO THRU EX-CONTROLLO
GO TO EX-SEQUENZA
END-IF.
MOVE MA0MATR OF MA01-I TO WMATAZI.
MOVE 0 TO ESISTE
EXEC SQL
SELECT COUNT(*) INTO :ESISTE FROM LAZIE009
WHERE AZCODPRO = :WWCODPRO
AND AZMATAZI = :WWMATAZI
AND AZCTRCOD = :WWCTRCOD
END-EXEC.
IF ESISTE = 0
COMPUTE PROGSC3 = PROGSC3 - 1
MOVE 1 TO WERRORE
MOVE "Matricola non presente in archivio" TO CM1-MSG
PERFORM CONTROLLO THRU EX-CONTROLLO
GO TO EX-SEQUENZA
END-IF
MOVE 0 TO WERRORE.
MOVE SPACES TO CM1-MSG.
BPDSPF MOVE LOW-VALUE TO AREA-VIDEO.
*se sto acquisendo un nuovo SC3 cerco l'ultimo progr.acquisito
IF CM1-SC3PR = 0
EXEC SQL
SELECT MAX(RDEUPRSC3) INTO :WSC3PR
FROM LRTDEU2
WHERE RDEUDTSC3 = :DATASC3
END-EXEC
ADD 1 TO WSC3PR
MOVE WSC3PR TO CM1-SC3PR
END-IF.
INITIALIZE RECDEU.
STRING DATASC3 CM1-SC3PR DELIMITED BY SIZE INTO RDEUSC724
MOVE 1 TO RDEUTIREC.
MOVE 3 TO RDEUFLUTIL.
MOVE 0 TO RDEUIMPUT.
MOVE "DMRAA" TO ACTRIBUT.
MOVE MA0RAG OF MA01-I TO RDEURIFRAG.
MOVE DATASC3 TO RDEUDTSC3.
MOVE CM1-SC3PR TO RDEUPRSC3.
MOVE PROGSC3 TO RDEUNSC3 RDEUPROGR.
MOVE MA0MATR OF MA01-I TO RDEUMATAZI.
BPDSPF MOVE MA0IMPPA OF MA01-I TO AIMPORPAG.
BPINFO* CVG1110 Field MA0IMPPA contains class AMOUNT.
MOVE MA0ANNOPA OF MA01-I TO ANNO.
MOVE MA0MESEPA OF MA01-I TO MESE.
MOVE MA0GIORPA OF MA01-I TO GIORNO.
MOVE SUADATA TO ADATARISC.
MOVE MA0ANPER OF MA01-I TO ANNOPERI.
MOVE MA0MEPER OF MA01-I TO MESEPERI.
MOVE PERI TO RDEUPERCED WPERI.
MOVE CM1-DATAG TO RDEUDTCAR.
BPEURO WRITE REC-ARTDEU.
BPINFO* CVG1011 In field REC-ARTDEU 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"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "ARTDEU" TO CM1-ERRFILE
MOVE "PRTAQ01" TO CM1-ERRPGM
MOVE 7 TO CM1-RETCOD
ROLLBACK
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 F-STATUS = "00"
COMMIT
ELSE
ROLLBACK
END-IF.
BPDSPF MOVE LOW-VALUE TO REC-VIDEO.
BPINFO* CVG1011 In field REC-VIDEO found the following classes:
BPINFO* CVG1010 Field MA0IMPPA contains class AMOUNT.
EX-SEQUENZA.
EXIT.
CONTROLLO.
IF MA0RAG OF MA01-I IS NUMERIC
MOVE MA0RAG OF MA01-I TO WRAG
END-IF.
IF MA0MATR OF MA01-I IS NUMERIC
MOVE MA0MATR OF MA01-I TO WMATR
END-IF.
IF MA0MEPER OF MA01-I IS NUMERIC
MOVE MA0MEPER OF MA01-I TO WMEPER
END-IF.
IF MA0ANPER OF MA01-I IS NUMERIC
MOVE MA0ANPER OF MA01-I TO WANPER
END-IF.
BPDSPF IF MA0IMPPA OF MA01-I IS NUMERIC
BPINFO* CVG1110 Field MA0IMPPA contains class AMOUNT.
BPDSPF MOVE MA0IMPPA OF MA01-I TO WIMPPA
BPINFO* CVG1118 Fields MA0IMPPA and WIMPPA contain the following class
BPINFO* AMOUNT
END-IF.
IF MA0GIORPA OF MA01-I IS NUMERIC
MOVE MA0GIORPA OF MA01-I TO WGIORPA
END-IF.
IF MA0MESEPA OF MA01-I IS NUMERIC
MOVE MA0MESEPA OF MA01-I TO WMESEPA
END-IF.
IF MA0ANNOPA OF MA01-I IS NUMERIC
MOVE MA0ANNOPA OF MA01-I TO WANNOPA
END-IF.
EX-CONTROLLO.
EXIT.
