- Dettagli
- Visite: 805
*$ COMMIT *CHG
IDENTIFICATION DIVISION.
PROGRAM-ID. PRTAQ081.
*--------------------------------------------------------------*
* PROGETTO RETTIFICHE *
* ------------------- *
* AUTORE : FRANCO D'AMICO C.O.DI MARSALA *
* *
* FUNZIONE : PASSAGGIO PAGAMENTI A DOCUMENTI DIVERSI *
* PGM CHIAMANTI : PRTMN01 *
* PGM CHIAMATI : *
* MAPPE : MRTPA001 *
* AREA DI INPUT : CRTMN01 - *
* ARCHIVI : LRTDEU4 - ARTCOLDD - ASCO0079 *
*--------------------------------------------------------------*
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. AS400.
OBJECT-COMPUTER. AS400.
SPECIAL-NAMES. DECIMAL-POINT IS COMMA.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT DS79 ASSIGN TO DATABASE-ASCO0079
ORGANIZATION IS INDEXED
RECORD KEY IS EXTERNALLY-DESCRIBED-KEY
ACCESS IS DYNAMIC
FILE STATUS IS F-STATUS.
SELECT VIDEO ASSIGN TO WORKSTATION-MRTPA00
ORGANIZATION IS TRANSACTION
ACCESS IS DYNAMIC
RELATIVE KEY IS CONTSUBF
FILE STATUS IS F-STATUS.
SELECT ARTDEU ASSIGN TO DATABASE-LRTDEU4
ORGANIZATION IS INDEXED
ACCESS IS DYNAMIC
RECORD KEY IS EXTERNALLY-DESCRIBED-KEY
WITH DUPLICATES
FILE STATUS IS F-STATUS.
SELECT ARTCOLDD ASSIGN TO DATABASE-ARTCOLDD
ORGANIZATION IS INDEXED
ACCESS IS DYNAMIC
RECORD KEY IS EXTERNALLY-DESCRIBED-KEY
FILE STATUS IS F-STATUS.
I-O-CONTROL.
COMMITMENT CONTROL FOR ARTDEU ARTCOLDD DS79.
DATA DIVISION.
FILE SECTION.
FD VIDEO
LABEL RECORD IS OMITTED.
01 REC-VIDEO.
COPY DDS-ALL-FORMAT OF MRTPA00.
FD ARTDEU
LABEL RECORD IS OMITTED.
01 REC-ARTDEU.
COPY DDS-ALL-FORMAT OF LRTDEU4.
FD ARTCOLDD
LABEL RECORD IS OMITTED.
01 REC-COLDD.
COPY DDS-ALL-FORMAT OF ARTCOLDD.
FD DS79.
01 DS79-REC.
COPY DDS-ALL-FORMATS OF ASCO0079.
************************************************
WORKING-STORAGE SECTION.
************************************************
EXEC SQL
INCLUDE SQLCA
END-EXEC.
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 SQLERR PIC 9(5).
01 WFINE PIC 9.
01 SUADATA.
03 SANNO PIC 9(2).
03 SMESE PIC 99.
03 SGIORNO PIC 99.
01 MIADATA.
03 SGIORNO PIC 99.
03 FILLER PIC X VALUE "/".
03 SMESE PIC 99.
03 FILLER PIC X VALUE "/".
03 SANNO PIC 9(2).
01 SUOPERI.
03 ANNO PIC 9(2).
03 MESE PIC 99.
01 MIOPERI.
03 MESE PIC 99.
03 FILLER PIC X VALUE "/".
03 ANNO PIC 9(2).
01 WQUANTI PIC 9(5).
01 WSC724 PIC S9(12).
01 WPROGR PIC S9(4).
01 WPAG PIC S9(13)V9(002).
01 WDATA PIC S9(8).
01 WARC PIC X(22).
01 WANCO PIC S9(4).
01 WENTE PIC S9(5).
01 WIMPORPAG PIC S9(11)V9(002).
01 WNRESA PIC S9(5).
01 WIMESA PIC S9(11)V9(002).
01 WNRDD PIC S9(5).
01 WIMDD PIC S9(11)V9(002).
01 WDATA-COLL.
03 WANNO PIC 9(4).
03 WMESE PIC 99.
03 WGIORNO PIC 99.
01 WCM1-MATRICOLA.
05 WCM1-COD-SEDE PIC 9(2).
05 WCM1-MATR-AZ PIC 9(6).
05 WCM1-CTR-COD PIC 9(2).
01 WCM1-D10PER PIC 9(6).
01 WCM1-PROPER PIC 99.
01 AREA-INDIC.
COPY DDS-ALL-FORMATS-INDIC OF MRTPA00.
****************************************************************
* AREA DI COLLOQUIO COL PGM CHIAMANTE *
****************************************************************
LINKAGE SECTION.
COPY CRTMN01 OF DCBCPY.
03 WDATAG REDEFINES CM1-DATAG PIC S9(8).
*****************************************************************
* 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 0 TO CONTSUBF WQUANTI.
MOVE CM1-MATRICOLA TO WCM1-MATRICOLA.
MOVE CM1-D10PER TO WCM1-D10PER.
MOVE CM1-PROPER TO WCM1-PROPER.
PERFORM APRI THRU EX-APRI.
IF F-STATUS = "00"
PERFORM RIEMPI-MAPPA THRU EX-RIEMPI-MAPPA
IF WQUANTI > 0
MOVE SPACES TO CM1-MSG
PERFORM SCRIVI-LEGGI THRU EX-SCRIVI-LEGGI
IF IN11 OF MP01CTL-I-INDIC = IND-ON
READ SUBFILE VIDEO MODIFIED FORMAT "MP01"
IF F-STATUS NOT EQUAL "00" AND F-STATUS NOT EQUAL "12"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "MRTPA00" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 1 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF
PERFORM UNTIL F-STATUS NOT = "00"
IF F-STATUS = "00"
MOVE MP01SC7 OF MP01-O TO WSC724
MOVE MP01PRG OF MP01-O TO WPROGR
BPDSPF MOVE MP01IMP OF MP01-O TO WIMPORPAG
PERFORM SCRIVI-DD THRU EX-SCRIVI-DD
PERFORM SCRIVI-DS79 THRU EX-SCRIVI-DS79
PERFORM SCRIVI-ARTDEU THRU EX-SCRIVI-ARTDEU
COMMIT
MOVE SPACE TO MP01SCEL OF MP01-O
REWRITE SUBFILE REC-VIDEO FORMAT "MP01"
END-IF
READ SUBFILE VIDEO MODIFIED FORMAT "MP01"
IF F-STATUS NOT EQUAL "00" AND F-STATUS NOT = "12"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "MRTPA00" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 2 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF
END-PERFORM
END-IF
END-IF
END-IF.
IF WQUANTI = 0
MOVE "NESSUN DOCUMENTO DIVERSO SODDISFA LA RICHIESTA!"
TO CM1-MSG
END-IF.
FINE.
MOVE WCM1-MATRICOLA TO CM1-MATRICOLA.
MOVE WCM1-D10PER TO CM1-D10PER.
MOVE WCM1-PROPER TO CM1-PROPER.
CLOSE VIDEO ARTDEU ARTCOLDD DS79.
IF IN03 OF MP01CTL-I-INDIC = IND-ON
STOP RUN
ELSE
GOBACK
END-IF.
APRI.
OPEN I-O VIDEO.
IF F-STATUS NOT EQUAL "00"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "MRTPA00" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 3 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF.
OPEN I-O ARTCOLDD.
IF F-STATUS NOT EQUAL "00"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "ARTCOLDD" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 4 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF.
OPEN INPUT ARTDEU.
IF F-STATUS NOT EQUAL "00"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "ARTDEU" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 5 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF.
MOVE 0 TO RDEUFLUTIL.
MOVE 99999999 TO RDEUDTCAR.
MOVE "0000000000" TO RDEUMATAZI.
BPEURO START ARTDEU KEY IS NOT LESS EXTERNALLY-DESCRIBED-KEY.
IF F-STATUS NOT EQUAL "00" AND F-STATUS NOT = "10"
AND F-STATUS NOT = "23"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "ARTDEU" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 6 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF.
OPEN I-O DS79.
IF F-STATUS NOT EQUAL "00"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "ASCO0079" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 7 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF.
EX-APRI.
EXIT.
RIEMPI-MAPPA.
MOVE IND-OFF TO IN12 OF MP01CTL-I-INDIC.
MOVE IND-OFF TO IN03 OF MP01CTL-I-INDIC.
MOVE IND-OFF TO IN11 OF MP01CTL-I-INDIC.
MOVE IND-ON TO IN09 OF MP01-O-INDIC.
MOVE IND-ON TO IN09 OF MP01CODA-O-INDIC.
MOVE IND-OFF TO IN10.
BPEURO READ ARTDEU NEXT.
IF F-STATUS NOT EQUAL "00" AND F-STATUS NOT = "10"
AND F-STATUS NOT = "23"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "ARTDEU" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 8 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF
PERFORM UNTIL F-STATUS NOT = "00" OR WQUANTI > 9990
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 (WCM1-MATRICOLA = 0 OR
(WCM1-MATRICOLA > 0 AND RDEUMATAZI = WCM1-MATRICOLA))
AND (WCM1-D10PER = 0 OR
(RDEUPERCED = WCM1-D10PER AND WCM1-D10PER > 0))
BPEURO AND (CM1-IMPDA = 0 OR
(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
ADD 1 TO CONTSUBF WQUANTI
IF RDEUTIREC = 0
MOVE "F" TO MP01TIPO OF MP01-O
END-IF
IF RDEUTIREC = 1
MOVE "I" TO MP01TIPO OF MP01-O
END-IF
IF RDEUTIREC = 2
MOVE "T" TO MP01TIPO OF MP01-O
END-IF
IF RDEUTIREC = 3
MOVE "I" TO MP01TIPO OF MP01-O
END-IF
MOVE SPACE TO MP01SCEL OF MP01-O
MOVE RDEUMATAZI TO MP01MATR OF MP01-O
MOVE RDEUPERCED(3:4) TO SUOPERI
MOVE CORRESPONDING SUOPERI TO MIOPERI
MOVE MIOPERI TO MP01PERI OF MP01-O
BPDSPF MOVE AIMPORPAG TO MP01IMP OF MP01-O
MOVE ACODICFIS TO MP01FISC OF MP01-O
MOVE RDEUSC724 TO MP01SC7 OF MP01-O
MOVE RDEUPROGR TO MP01PRG OF MP01-O
MOVE ADATARISC(3:6) TO SUADATA
MOVE CORRESPONDING SUADATA TO MIADATA
MOVE MIADATA TO MP01DATA OF MP01-O
WRITE SUBFILE REC-VIDEO FORMAT "MP01"
INDICATORS ARE MP01-O-INDIC
IF F-STATUS NOT EQUAL "00"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "MRTPA00" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 9 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF
END-IF
BPEURO READ ARTDEU NEXT
IF F-STATUS NOT EQUAL "00" AND F-STATUS NOT = "10"
AND F-STATUS NOT = "23"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "ARTDEU" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 10 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF
END-PERFORM.
EX-RIEMPI-MAPPA.
EXIT.
SCRIVI-LEGGI.
WRITE REC-VIDEO FORMAT "MP01CODA"
INDICATORS ARE MP01CODA-O-INDIC.
IF F-STATUS NOT EQUAL "00"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "MRTPA00" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 11 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF
MOVE CM1-DATACHIARO TO MP01OGGI.
WRITE REC-VIDEO FORMAT "MP01CTL"
INDICATORS ARE MP01CTL-O-INDIC.
IF F-STATUS NOT EQUAL "00"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "MRTPA00" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 12 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF
READ VIDEO FORMAT "MP01CTL"
INDICATORS ARE MP01CTL-I-INDIC.
IF F-STATUS NOT EQUAL "00"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "MRTPA00" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 13 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF.
IF IN12 OF MP01CTL-I-INDIC = IND-ON OR
IN03 OF MP01CTL-I-INDIC = IND-ON
GO TO EX-SCRIVI-LEGGI
END-IF.
MOVE IND-ON TO IN10.
* COMPARE INVITO A CONFERMARE CON F11
WRITE REC-VIDEO FORMAT "MP01CODA"
INDICATORS ARE MP01CODA-O-INDIC.
IF F-STATUS NOT EQUAL "00"
MOVE F-STATUS TO CM1-FSTATUS
MOVE "MRTPA00" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 14 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF
WRITE REC-VIDEO FORMAT "MP01CTL"
INDICATORS ARE MP01CTL-O-INDIC
READ VIDEO FORMAT "MP01CTL"
INDICATORS ARE MP01CTL-I-INDIC.
EX-SCRIVI-LEGGI.
EXIT.
SCRIVI-DD.
EXEC SQL
BPEURO SELECT AIMPORPAG,ADATARISC,ANUARC,RDEUANCO,ACODIENTE
BPEURO INTO :WPAG,:WDATA,:WARC,:WANCO,:WENTE
FROM LRTDEU4
WHERE RDEUSC724 = :WSC724 AND RDEUPROGR = :WPROGR
END-EXEC
MOVE WSC724(1:1) TO DDTSC7
MOVE WSC724(2:6) TO DDASC7
MOVE WSC724(8:5) TO DDNSC7
MOVE 1 TO DDDM11
MOVE CM1-DATAG TO WDATA-COLL
IF WMESE < 2
MOVE 13 TO DDMM
COMPUTE WANNO = WANNO - 1
MOVE WANNO TO DDAA
ELSE
MOVE CM1-DATAG(1:4) TO DDAA
MOVE CM1-DATAG(5:2) TO DDMM
END-IF
MOVE WPROGR TO DDDM10
BPEURO MOVE WPAG TO DDIMPVE
MOVE WDATA TO DDDTPAG
MOVE WARC TO DDTEF
MOVE WANCO TO DDAACO
MOVE WENTE TO DDCODABI
MOVE "GPA" TO DDCOST
MOVE 5483 TO DDCONT
BPEURO WRITE REC-COLDD
IF F-STATUS NOT EQUAL "00"
ROLLBACK
MOVE F-STATUS TO CM1-FSTATUS
MOVE "ARTCOLDD" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 15 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF.
EX-SCRIVI-DD.
EXIT.
SCRIVI-DS79.
MOVE WSC724(1:1) TO AC0K1TIP
MOVE WSC724(2:6) TO AC0K1ART
MOVE WSC724(8:5) TO AC0K1NUM
BPEURO START DS79 KEY IS = EXTERNALLY-DESCRIBED-KEY
IF F-STATUS NOT EQUAL "00"
ROLLBACK
MOVE F-STATUS TO CM1-FSTATUS
MOVE "ASCO0079" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 16 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF.
BPEURO READ DS79 NEXT
IF F-STATUS NOT EQUAL "00"
ROLLBACK
MOVE F-STATUS TO CM1-FSTATUS
MOVE "ASCO0079" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 17 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF.
MOVE AC0NRESA TO WNRESA
BPEURO MOVE AC0IMESA TO WIMESA
MOVE AC0NRDD TO WNRDD
BPEURO MOVE AC0IMDD TO WIMDD
COMPUTE WNRESA = WNRESA - 1
BPSCCL COMPUTE WIMESA = WIMESA - WIMPORPAG
COMPUTE WNRDD = WNRDD + 1
BPSCCL COMPUTE WIMDD = WIMDD + WIMPORPAG
MOVE WNRESA TO AC0NRESA
BPEURO MOVE WIMESA TO AC0IMESA
MOVE WNRDD TO AC0NRDD
BPEURO MOVE WIMDD TO AC0IMDD
BPEURO REWRITE DS79-REC.
IF F-STATUS NOT EQUAL "00"
ROLLBACK
MOVE F-STATUS TO CM1-FSTATUS
MOVE "ASCO0079" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 18 TO CM1-RETCOD
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF.
EX-SCRIVI-DS79.
EXIT.
SCRIVI-ARTDEU.
* metto 1 in rdeuflutil e rdeufldd - in rdeudtcar la data di oggi
EXEC SQL
UPDATE LRTDEU4 SET RDEUFLDD = 1, RDEUFLUTIL = 1,
RDEUDTCAR = :WDATAG
WHERE RDEUSC724 = :WSC724 AND RDEUPROGR = :WPROGR
END-EXEC
IF SQLCODE NOT = 0 AND SQLCODE NOT = 100
ROLLBACK
MOVE "LRTDEU4" TO CM1-ERRFILE
MOVE "PRTAQ08" TO CM1-ERRPGM
MOVE 19 TO CM1-RETCOD
MOVE SQLCODE TO SQLERR
STRING "ERR.SQL(" SQLERR ")-P.1 PGM PRTAQ08"
DELIMITED BY SIZE INTO CM1-MSG
BPEURO CALL "PRTUT02" USING AREA-MN01
END-IF.
EX-SCRIVI-ARTDEU.
EXIT.