H COPYRIGHT('copyright 2005 EMI-Music France') H OPTION(*NODEBUGIO:*SRCSTMT:*SHOWCPY:*EXT:*SHOWSKP) H DATFMT(*EUR) H DEBUG(*NO) H DECEDIT(',') H DFTNAME(SYS400) ˜************************************************************************** ˜* Spιcifique : EMI ˜* Programme : SYS400 ˜* ˜* Fonction : AFFICHAGE WINDOW GESTION DE L'AIDE ˜* ˜* Mode appel: ˜* ˜* Remarques : Window en mode drag'n drop ˜* ˜*‚Date Crιa.: xx/01/05 Auteur : Y. BOSSE ˜*‚Date Modif Objet modification ˜*‚°°°°°°°°°° °°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° ˜************************************************************************** ‚**----------------------------------------------------------------------** ‚* DECLARATION FICHIERS * ‚**----------------------------------------------------------------------** ‚* Fichier ιcran FSYS400E CF E WORKSTN INFDS(INFECR) F SFILE(WSFL1:WLIG01) F SFILE(WSFL2:WLIG02) ‚* Fichier d'aide FSYS400L00 UF A E K DISK FSYS400L01 UF E K DISK F RENAME(TFAID:TFAIDZ) F PREFIX(Z) ‚**----------------------------------------------------------------------** ‚* DECLARATION DS / ZONES / TABLEAUX * ‚**----------------------------------------------------------------------** ‚* D/COPY QCOPYSRC,CPY_DS_SDS D/COPY QCOPYSRC,CPY_INFECR ‚* šD DSAIDE E DS EXTNAME(SYS400P) ‚* D DIVISEUR S 1S 0 INZ(*ZEROS) D LaZone S 10A INZ(*BLANKS) D DATSYS S D INZ(*JOB) D IN S 1N DIM(99) INZ(*OFF) D ERR S 1N DIM(99) INZ(*OFF) D REL S 1N DIM(99) INZ(*OFF) D LOA S 1N DIM(99) INZ(*OFF) D XX S 2S 0 INZ(0) D WMAX01 S 5S 0 INZ(*ZEROS) D WMAX02 S 5S 0 INZ(*ZEROS) D OPENCURSO1 S 1N INZ(*OFF) D OPENCURSO2 S 1N INZ(*OFF) D BestNumRcd S 5S 0 INZ(*ZEROS) D LastNumRcd S 5S 0 INZ(*ZEROS) D UNTIL S 5S 0 INZ(*ZEROS) D WLIGNE S 4S 0 INZ(*ZEROS) D POSLIG S 4S 0 INZ(*ZEROS) ‚* ‚* dιfintition constante D VBF02 S 15 INZ('F2 Modifier ') D VBF08 S 15 INZ('F8 Autr.Class') D VBF12 S 15 INZ('F12 Annuler ') D VBF99 S 15 INZ('ENTREE Valide') ‚* šD DSFORSQL DS D WH1 10A DIM(6) INZ(*BLANKS) D WH2 50A DIM(%ELEM(WH1)) INZ(*BLANKS) D WH3 1A DIM(%ELEM(WH1)) INZ(*BLANKS) D WW 5S 0 INZ(0) D WZ 5S 0 INZ(0) ‚* D INZREQUETE S 5000A D COTE S 1A INZ('''') šD DSREQUETE DS D REQUETE 5000A INZ('select * from WSYS400P') D WHERE 2000A INZ(*BLANKS) D Connecteur 50A INZ(*BLANKS) ‚* šD DS šD SVMLTCHXVx 1 5S 0 D SVMLTCHXV1 1 1S 0 INZ(*ZEROS) D SVMLTCHXV2 2 2S 0 INZ(*ZEROS) D SVMLTCHXV3 3 3S 0 INZ(*ZEROS) D SVMLTCHXV4 4 4S 0 INZ(*ZEROS) D SVMLTCHXV5 5 5S 0 INZ(*ZEROS) ‚* ‚**----------------------------------------------------------------------** ‚* CLES D'ACCES FICHIERS ‚**----------------------------------------------------------------------** ‚* C KAIa KLIST C KFLD TAPGM C KAIb KLIST C KFLD TAPGM C KFLD TAECR C KAIc KLIST C KFLD TAPGM C KFLD TAECR C KFLD TAFMT C KAId KLIST C KFLD TAPGM C KFLD TAECR C KFLD TAFMT C KFLD TAZONE C KAIe KLIST C KFLD TAPGM C KFLD TAECR C KFLD TAFMT C KFLD TAZONE C KFLD TANUMRCD C KAIf KLIST C KFLD TAPGM C KFLD TAECR C KFLD TAFMT C KFLD TAZONE C KFLD TANUMRCD C KFLD TAFORUSER ‚* C KAIfZ KLIST C KFLD ZTAPGM C KFLD ZTAECR C KFLD ZTAFMT C KFLD ZTAZONE C KFLD ZTANUMRCD C KFLD ZTAFORUSER ‚* ‚**----------------------------------------------------------------------** ‚* PARAMETRES EN ENTREE * ‚**----------------------------------------------------------------------** ‚* C *ENTRY PLIST C PARM PROGRAMME 10 C PARM ECRAN 10 C PARM FORMAT 10 C PARM ZONE 10 C PARM PMBACK 1 C PARM PMERR 1 ‚* ‰************************************************************************** ‰*------------------------------------------------------------------------* ‰* ˆ DEBUT DE PROGRAMME ‰ * ‰*------------------------------------------------------------------------* ‰************************************************************************** ‚* C EVAL XX = 1 ‚* ˜C DOW NOT *INLR C IN(01) CASEQ *ON ECR01 C IN(02) CASEQ *ON ECR02 C IN(03) CASEQ *ON ECR03 C ENDCS šC IF NOT *INLR C AND NOT IN(01) C AND NOT IN(02) C AND NOT IN(03) C EVAL XX = 1 C EVAL IN(01) = *ON C EVAL REL(01) = *ON šC ENDIF ˜C ENDDO ‚* ›* ›* €ECRAN 01 › ›* š************************************************************************** š* ECR01 - AFFICHAGE DE L'AIDE š************************************************************************** ‚* C ECR01 BEGSR ‚* C EVAL XX = 1 C EVAL IN(XX) = *OFF ‚* ˆC IF REL(XX) C EVAL REL(XX) = *OFF C EXSR LOA01 ˆC ENDIF ‚* ˆC DOU NOT ERR(XX) C MOVEA '010' *IN(25) C WMAX01 COMP *ZERO 25 C EVAL TAFORUSER = %TRIM(WH2(1)) ˜C IF NOT *IN25 C EVAL TAPGM = PROGRAMME C EVAL TAECR = ECRAN C EVAL TAFMT = FORMAT C EVAL TAZONE = ZONE C MOVEA '0000000100' *IN(01) C MOVEA '01' *IN(11) C MOVEA '0' *IN(99) ˜C ELSE C MOVEA '0100000100' *IN(01) C MOVEA '01' *IN(11) C MOVEA '1' *IN(99) ˜C ENDIF ‚* ˜C SELECT ˜C WHEN TAFORUSER = '*USER' C EVAL *IN02 = *ON ˜C WHEN TAFORUSER = '*PGMR' šC SELECT šC WHEN CLASSE = '*USER' C EVAL *IN02 = *OFF šC OTHER C EVAL *IN02 = *ON šC ENDSL ˜C WHEN TAFORUSER = '*SYSOPR' šC SELECT šC WHEN CLASSE = '*USER' šC OR CLASSE = '*PGMR' šC OR CLASSE = '*SECADM' C EVAL *IN02 = *OFF šC OTHER C EVAL *IN02 = *ON šC ENDSL ˜C WHEN TAFORUSER = '*SECADM' šC SELECT šC WHEN CLASSE = '*USER' šC OR CLASSE = '*PGMR' šC OR CLASSE = '*SYSOPR' C EVAL *IN02 = *OFF šC OTHER C EVAL *IN02 = *ON šC ENDSL ˜C WHEN TAFORUSER = '*SECOFR' šC SELECT šC WHEN CLASSE <> '*SECOFR' C EVAL *IN02 = *OFF šC OTHER C EVAL *IN02 = *ON šC ENDSL ˜C ENDSL ‚* C EXFMT WCTL1 C EVAL ERR(XX) = *OFF ‚* ˜C SELECT ‚* ENTREE ˜C WHEN KEY = ΰENTER C EXSR SFL1ENT ‚* F02 MODIFIER ˜C WHEN KEY = ΰF02 C EXSR SFL1F02 ‚* F08 AUTRES AIDES ˜C WHEN KEY = ΰF08 C EXSR SFL1F08 ‚* F12 ANNULER ˜C WHEN KEY = ΰF12 C EXSR SFL1F12 ‚* AUTRE ˜C OTHER C EVAL ERR(XX) = *ON ‚* ˜C ENDSL ‚* ˆC ENDDO ‚* C ENDSR ‚* š************************************************************************** š* LOA01 - CHARGEMENT SFL1 š************************************************************************** ‚* C LOA01 BEGSR ‚* C MOVEA '001' *IN(25) C WRITE WCTL1 C MOVEA '100' *IN(25) ‚* C EXSR PREP_REQUETE ‚* C EVAL WMAX01 = *ZEROS ‚* C/exec sql prepare reque1 from :REQUETE C/end-exec ‚* C/exec sql declare curs1 cursor for reque1 C/end-exec ‚* C/exec sql open curs1 C/end-exec ‚* C EVAL OPENCURSO1 = *ON ‚* C/exec sql fetch curs1 into :DSAIDE C/end-exec ‚* ˆC DOW SQLSTT = '00000' ˜C IF TACRTUSER = USER C EVAL *IN50 = *ON ˜C ELSE C EVAL *IN50 = *OFF ˜C ENDIF C EVAL WMAX01 = WMAX01 + 1 C EVAL WLIG01 = WMAX01 C WRITE WSFL1 C/exec sql fetch curs1 into :DSAIDE C/end-exec ˆC ENDDO ‚* C/exec sql close curs1 C/end-exec C EVAL OPENCURSO1 = *OFF ‚* C EVAL WLIG01 = 1 ‚* C ENDSR ‚* š************************************************************************** š* SFL1ENT - ENTREE š************************************************************************** ‚* C SFL1ENT BEGSR ‚* C EXSR E1_CHK_FONC ‚* C ENDSR ‚* š************************************************************************** š* SFL1F02 - MODIFIER š************************************************************************** ‚* C SFL1F02 BEGSR ‚* C EVAL XX = 2 C EVAL IN(XX) = *ON C EVAL REL(XX) = *ON C RESET SVMLTCHXVx ‚* C ENDSR ‚* š************************************************************************** š* SFL1F08 - AUTRES AIDES š************************************************************************** ‚* C SFL1F08 BEGSR ‚* C EVAL XX = 3 C EVAL IN(XX) = *ON C EVAL REL(XX) = *ON ‚* C ENDSR ‚* š************************************************************************** š* SFL1F12 - ANNULER (FIN PROG) š************************************************************************** ‚* C SFL1F12 BEGSR ‚* C EVAL *INLR = *ON ‚* C ENDSR ‚* š************************************************************************** š* E1_CHK_FONC š************************************************************************** ‚* C E1_CHK_FONC BEGSR ‚* C SELECT C WHEN FONCTION = 2 C EXSR SFL1F02 C WHEN FONCTION = 8 C EXSR SFL1F08 C WHEN FONCTION = 12 C EXSR SFL1F12 C WHEN FONCTION = 99 C OTHER C EVAL ERR(XX) = *ON C ENDSL ‚* C ENDSR ‚* ›* ›* €ECRAN 02 › ›* š************************************************************************** š* ECR02 - AFFICHAGE DE L'AIDE š************************************************************************** ‚* C ECR02 BEGSR ‚* C EVAL XX = 2 C EVAL IN(XX) = *OFF C MOVEA '00' *IN(50) ‚* ˆC IF REL(XX) C EVAL REL(XX) = *OFF C EXSR LOA02 ˆC ENDIF ‚* ˆC DOU NOT ERR(XX) C MOVEA '010' *IN(25) C EVAL CURLIG = 11 C EVAL CURCOL = 05 C WMAX02 COMP *ZERO 25 C EVAL SVMLTCHXV1 = MLTCHXV1 C EVAL SVMLTCHXV2 = MLTCHXV2 C EVAL SVMLTCHXV3 = MLTCHXV3 C EVAL SVMLTCHXV4 = MLTCHXV4 C EVAL SVMLTCHXV5 = MLTCHXV5 C EXFMT WCTL2 C EVAL ERR(XX) = *OFF ‚* ˜C SELECT ‚* ENTREE ˜C WHEN KEY = ΰENTER C EXSR SFL2ENT ‚* F12 ANNULER ˜C WHEN KEY = ΰF12 C EXSR SFL2F12 ‚* AUTRE ˜C OTHER C EVAL ERR(XX) = *ON ‚* ˜C ENDSL ‚* ˆC ENDDO ‚* C EVAL CURLIG = 0 C EVAL CURCOL = 0 ‚* C ENDSR ‚* š************************************************************************** š* LOA02 - CHARGEMENT SFL2 š************************************************************************** ‚* C LOA02 BEGSR ‚* C MOVEA '001' *IN(25) C WRITE WCTL2 C MOVEA '100' *IN(25) ‚* C* EXSR PREP_REQUETE ‚* C EVAL WMAX02 = *ZEROS C EVAL BestNumRcd = *ZEROS ‚* C/exec sql prepare reque2 from :REQUETE C/end-exec C/exec sql declare curs2 cursor for reque2 C/end-exec ‚* C/exec sql open curs2 C/end-exec ‚* C EVAL OPENCURSO2 = *ON ‚* C/exec sql fetch curs2 into :DSAIDE C/end-exec ‚* ˆC DOW SQLSTT = '00000' ˜C IF TACRTUSER = USER C EVAL *IN50 = *ON ˜C ELSE C EVAL *IN50 = *OFF ˜C ENDIF ‚* ˜C* IF TAFORUSER <> CLASSE C* EVAL *IN51 = *ON ˜C* ELSE C* EVAL *IN51 = *OFF ˜C* ENDIF ˜C IF TANUMRCD > BestNumRcd C EVAL BestNumRcd = TANUMRCD ˜C ENDIF C EVAL SVNUMRCD = TANUMRCD C EVAL SVAIDE = TAAIDE C EVAL SVAUTUSER = TAUTUSER C EVAL SVAUTPGMR = TAUTPGMR C EVAL SVAUTSYSO = TAUTSYSOPR C EVAL SVAUTSECA = TAUTSECADM C EVAL SVAUTSECO = TAUTSECOFR C EVAL WMAX02 = WMAX02 + 1 C EVAL WLIG02 = WMAX02 C WRITE WSFL2 C/exec sql fetch curs2 into :DSAIDE C/end-exec ˆC ENDDO ‚* C/exec sql close curs2 C/end-exec C EVAL OPENCURSO2 = *OFF ‚* C EVAL *IN51 = *OFF ‚* ˆC SELECT ˆC WHEN WH2(1) = '*USER' C EVAL SNGCHXFOR = 1 C MOVEA '10000' *IN(41) ˆC WHEN WH2(1) = '*PGMR' C EVAL SNGCHXFOR = 2 C MOVEA '01000' *IN(41) ˆC WHEN WH2(1) = '*SYSOPR' C EVAL SNGCHXFOR = 3 C MOVEA '00100' *IN(41) ˆC WHEN WH2(1) = '*SECADM' C EVAL SNGCHXFOR = 4 C MOVEA '00010' *IN(41) ˆC WHEN WH2(1) = '*SECOFR' C EVAL SNGCHXFOR = 5 C MOVEA '00001' *IN(41) ˆC ENDSL ‚* ˆC IF SVMLTCHXVx = 0 ˜C SELECT ˜C WHEN *IN45 C EVAL MLTCHXV1 = 0 C EVAL MLTCHXV2 = 0 C EVAL MLTCHXV3 = 0 C EVAL MLTCHXV4 = 0 C EVAL MLTCHXV5 = 1 ˜C WHEN *IN44 C EVAL MLTCHXV1 = 0 C EVAL MLTCHXV2 = 0 C EVAL MLTCHXV3 = 0 C EVAL MLTCHXV4 = 1 C EVAL MLTCHXV5 = 0 ˜C WHEN *IN43 C EVAL MLTCHXV1 = 0 C EVAL MLTCHXV2 = 0 C EVAL MLTCHXV3 = 1 C EVAL MLTCHXV4 = 0 C EVAL MLTCHXV5 = 0 ˜C WHEN *IN42 C EVAL MLTCHXV1 = 0 C EVAL MLTCHXV2 = 1 C EVAL MLTCHXV3 = 0 C EVAL MLTCHXV4 = 0 C EVAL MLTCHXV5 = 0 ˜C WHEN *IN41 C EVAL MLTCHXV1 = 1 C EVAL MLTCHXV2 = 0 C EVAL MLTCHXV3 = 0 C EVAL MLTCHXV4 = 0 C EVAL MLTCHXV5 = 0 ˜C ENDSL ˆC ENDIF ‚* C EVAL UNTIL = 9999 - WMAX02 ˆC IF UNTIL > 500 C EVAL UNTIL = 500 ˆC ENDIF ‚* ˆC IF WMAX02 < 9999 C EVAL TANUMRCD = BestNumRcd C* EVAL SVNUMRCD = 0 C EVAL TAAIDE = *BLANKS C EVAL SVAIDE = *BLANKS C EVAL TACRTUSER = *BLANKS C EVAL SVAUTUSER = 0 C EVAL TAUTUSER = MLTCHXV1 C EVAL SVAUTPGMR = 0 C EVAL TAUTPGMR = MLTCHXV2 C EVAL SVAUTSYSO = 0 C EVAL TAUTSYSOPR = MLTCHXV3 C EVAL SVAUTSECA = 0 C EVAL TAUTSECADM = MLTCHXV4 C EVAL SVAUTSECO = 0 C EVAL TAUTSECOFR = MLTCHXV5 C EVAL *IN50 = *ON ˜C DOU WMAX02 > 499 C EVAL TANUMRCD = TANUMRCD + 1 C EVAL SVNUMRCD = TANUMRCD C EVAL WMAX02 = WMAX02 + 1 C EVAL WLIG02 = WMAX02 C WRITE WSFL2 ˜C ENDDO ˆC ENDIF ‚* C EVAL WLIG02 = 1 ‚* C ENDSR ‚* š************************************************************************** š* SFL2ENT - ENTREE š************************************************************************** ‚* C SFL2ENT BEGSR ‚* C EXSR E2_CHK_FONC ‚* ˆC IF NOT ERR(XX) AND NOT IN(01) ˆC AND NOT IN(02) AND NOT IN(03) C EXSR E2_CHK_BLOC ˆC ENDIF ‚* ˆC IF NOT ERR(XX) AND NOT IN(01) ˆC AND NOT IN(02) AND NOT IN(03) C EXSR E2_CHK_GENE ˆC ENDIF ‚* C ENDSR ‚* š************************************************************************** š* SFL2F12 - ANNULER (RETOUR ECRAN 01) š************************************************************************** ‚* C SFL2F12 BEGSR ‚* C EVAL XX = 1 C EVAL IN(XX) = *ON C EVAL REL(XX) = *ON ‚* C ENDSR ‚* š************************************************************************** š* E2_CHK_FONC š************************************************************************** ‚* C E2_CHK_FONC BEGSR ‚* ˆC SELECT ˆC WHEN FONCTION = 12 C EXSR SFL2F12 ˆC WHEN FONCTION = 99 C ˆC OTHER C* EVAL ERR(XX) = *ON ˆC ENDSL ‚* C ENDSR ‚* š************************************************************************** š* E2_CHK_GENE š************************************************************************** ‚* C E2_CHK_GENE BEGSR ‚* C DO ‚* ˆC IF SVMLTCHXV1 <> MLTCHXV1 ˆC OR SVMLTCHXV2 <> MLTCHXV2 ˆC OR SVMLTCHXV3 <> MLTCHXV3 ˆC OR SVMLTCHXV4 <> MLTCHXV4 ˆC OR SVMLTCHXV5 <> MLTCHXV5 C EVAL IN(XX) = *ON C EVAL REL(XX) = *ON C LEAVE ˆC ENDIF ‚* ‚* ‚* ˆC SELECT ˆC WHEN SNGCHXFOR = 1 C EVAL TAFORUSER = '*USER' ˆC WHEN SNGCHXFOR = 2 C EVAL TAFORUSER = '*PGMR' ˆC WHEN SNGCHXFOR = 3 C EVAL TAFORUSER = '*SYSOPR' ˆC WHEN SNGCHXFOR = 4 C EVAL TAFORUSER = '*SECADM' ˆC WHEN SNGCHXFOR = 5 C EVAL TAFORUSER = '*SECOFR' ˆC ENDSL ‚* ‚* ‚* C EVAL LastNumRcd = *ZEROS ˆC DO WMAX02 WLIG02 C WLIG02 CHAIN WSFL2 ˜C IF %FOUND C EVAL *IN98 = *OFF šC IF TANUMRCD <> SVNUMRCD šC OR TAAIDE <> SVAIDE šC OR TAUTUSER <> SVAUTUSER šC OR TAUTPGMR <> SVAUTPGMR šC OR TAUTSYSOPR <> SVAUTSYSO šC OR TAUTSECADM <> SVAUTSECA šC OR TAUTSECOFR <> SVAUTSECO C EXSR E2_CHK_SFL C IF ERR(XX) C LEAVE C ENDIF šC ELSE C EXSR E2_PROTECT_SFL šC ENDIF C EVAL LastNumRcd = TANUMRCD ˜C ENDIF ˆC ENDDO ‚* C ENDDO ‚* C ENDSR ‚* š************************************************************************** š* E2_CHK_BLOC š************************************************************************** ‚* C E2_CHK_BLOC BEGSR ‚* C DO ‚* ˆC IF SVMLTCHXV1 <> MLTCHXV1 ˆC OR SVMLTCHXV2 <> MLTCHXV2 ˆC OR SVMLTCHXV3 <> MLTCHXV3 ˆC OR SVMLTCHXV4 <> MLTCHXV4 ˆC OR SVMLTCHXV5 <> MLTCHXV5 C EVAL IN(XX) = *ON C EVAL REL(XX) = *ON C LEAVE ˆC ENDIF ‚* C EVAL WLIG02 = 1 C EVAL POSLIG = 1 ‚* C SELECT C WHEN BLOCAGE = 01 C EVAL BLOCAGE = 0 C EVAL ERR(XX) = *ON C DO WMAX02 WLIGNE C WLIGNE CHAIN WSFL2 ˆC IF %FOUND C EVAL *IN61 = *ON ˜C IF TACRTUSER = USER C EVAL *IN50 = *ON C EVAL *IN51 = *ON ˜C ELSE šC IF TACRTUSER <> *BLANKS C EVAL *IN50 = *OFF šC ELSE C IF POSLIG = 1 C EVAL POSLIG = WLIGNE C ENDIF šC ENDIF C EVAL *IN51 = *OFF ˜C ENDIF C UPDATE WSFL2 ˆC ENDIF C ENDDO C EVAL *IN61 = *ON ‚* C WHEN DEBLOCAGE = 09 C EVAL DEBLOCAGE = 0 C EVAL ERR(XX) = *ON C DO WMAX02 WLIGNE C WLIGNE CHAIN WSFL2 ˆC IF %FOUND C EVAL *IN51 = *OFF C EVAL *IN61 = *OFF ˜C IF TACRTUSER = USER C EVAL *IN50 = *ON ˜C ELSE šC IF TACRTUSER <> *BLANKS C EVAL *IN50 = *OFF šC ENDIF ˜C ENDIF C UPDATE WSFL2 ˆC ENDIF C ENDDO C EVAL *IN61 = *OFF ‚* C ENDSL ‚* C EVAL WLIG02 = POSLIG ‚* C ENDDO ‚* C ENDSR ‚* š************************************************************************** š* E2_CHK_SFL : *IN50 => propriιtaire de l'enreg !!! š************************************************************************** ‚* C E2_CHK_SFL BEGSR ‚* C DO ‚* ˆC SELECT ˆC WHEN TAAIDE = *BLANKS C EXSR CHK_FOR_DLT C EVAL TAAIDE = '*SUPPRIMER*' C EVAL SVAIDE = '*SUPPRIMER*' C EVAL *IN51 = *ON C UPDATE WSFL2 C EVAL *IN51 = *OFF ˆC WHEN TAAIDE <> *BLANKS ˜C SELECT ˜C WHEN TANUMRCD = 0 šC SELECT šC WHEN SVNUMRCD = 0 C EVAL S20P1 = 'PROPRIO : ERREUR ???' C EVAL S20P2 = C 'TAAIDE ΰ BLANC, SVAIDE ΰ BLANC, NUMRCD ΰ ' + C 'ZERO, SVNUMRCD ΰ ZERO ???? REPERE01' C EXSR SYS420 C EVAL ERR(XX) = *ON C EVAL TANUMRCD = LastNumRcd + 1 C UPDATE WSFL2 C LEAVE šC WHEN SVNUMRCD <> 0 C EVAL S20P1 = 'PROPRIO : ERREUR ???' C EVAL S20P2 = C 'TAAIDE ΰ BLANC, SVAIDE ΰ BLANC, NUMRCD ΰ ' + C 'ZERO, SVNUMRCD = ' + x'28' + C %TRIM(%EDITC(SVNUMRCD:'4')) + x'20' + C ' ???? REPERE02' C EXSR SYS420 C EVAL TANUMRCD = SVNUMRCD C UPDATE WSFL2 C EVAL ERR(XX) = *ON C LEAVE šC ENDSL ‚* ˜C WHEN TANUMRCD <> 0 šC SELECT šC WHEN SVNUMRCD = 0 C EXSR CHK_FOR_ADD C EXSR E2_PROTECT_SFL C 98 LEAVE šC WHEN SVNUMRCD <> 0 C EXSR CHK_FOR_MAJ C EXSR E2_PROTECT_SFL C 98 LEAVE šC ENDSL ˜C ENDSL ˆC ENDSL ‚* C ENDDO ‚* C ENDSR ‚* š************************************************************************** š* E2_PROTECT_SFL: *IN51 => zones protιgιes / *IN60 zones en rouge (erreur) š************************************************************************** ‚* C E2_PROTECT_SFLBEGSR ‚* C EVAL *IN98 = *ON ‚* ˆC IF ERR(XX) C EVAL *IN60 = *ON C UPDATE WSFL2 C EVAL *IN60 = *OFF ˆC ELSE C EVAL *IN51 = *ON C UPDATE WSFL2 C EVAL *IN51 = *OFF ˆC ENDIF ‚* C ENDSR ‚* š************************************************************************** š* CHK_FOR_ADD : Controle si ajout nouvel enreg posible š************************************************************************** ‚* C CHK_FOR_ADD BEGSR ‚* C DO C EVAL TAFORUSER = WH2(1) ‚* C KAIf SETLL TFAID 90 ˆC IF *IN90 C EVAL S20P1 = 'ERREUR SUR SEQUENCE' C EVAL S20P2 = C 'La sιquence ' + %TRIM(%EDITC(TANUMRCD:'4'))+ C ' existe dιjΰ, veuillez saisir un autre ' + C ' numιro de sιquence' C EXSR SYS420 C EVAL ERR(XX) = *ON C LEAVE ˆC ELSE C EXSR ADD_ENREG ˆC ENDIF ‚* C ENDDO ‚* C ENDSR ‚* š************************************************************************** š* CHK_FOR_MAJ : Controle si mise a jour enreg possible ! š************************************************************************** ‚* C CHK_FOR_MAJ BEGSR ‚* C DO ‚* C EVAL ZTAPGM = TAPGM C EVAL ZTAECR = TAECR C EVAL ZTAFMT = TAFMT C EVAL ZTAZONE = TAZONE C EVAL ZTANUMRCD = SVNUMRCD C EVAL ZTAFORUSER = TAFORUSER C KAIfZ CHAIN TFAIDZ ˆC IF %FOUND C EXSR MAJ_ENREG ˆC ELSE C EXSR ADD_ENREG ˆC ENDIF ‚* C ENDDO ‚* C ENDSR ‚* š************************************************************************** š* CHK_FOR_DLT : Controle si suppression possible ! š************************************************************************** ‚* C CHK_FOR_DLT BEGSR ‚* C DO ‚* C EVAL TANUMRCD = SVNUMRCD C KAIf CHAIN TFAID ˆC IF %FOUND C EXSR DLT_ENREG ˆC ENDIF ‚* C ENDDO ‚* C ENDSR ‚* š************************************************************************** š* ADD_ENREG : Ajoute un commentaire d'aide š************************************************************************** ‚* C ADD_ENREG BEGSR ‚* C EVAL TAACTIF = 1 C EVAL TACRTUSER = USER C EVAL TACRTDATE = DATSYS C TIME TACRTTIME C EVAL TACRTCOMM = 'Crιation via SYS400' C EVAL TAMAJUSER = *BLANKS C EVAL TAMAJDATE = *LOVAL C EVAL TAMAJTIME = *LOVAL C EVAL TAMAJCOMM = *BLANKS C EVAL TADLTUSER = *BLANKS C EVAL TADLTDATE = *LOVAL C EVAL TADLTTIME = *LOVAL C EVAL TADLTCOMM = *BLANKS C EVAL TADLTFLG = 0 C WRITE TFAID ‚* C ENDSR ‚* š************************************************************************** š* MAJ_ENREG : Mets ΰ jour un commentaire d'aide š************************************************************************** ‚* C MAJ_ENREG BEGSR ‚* C EVAL ZTAACTIF = 1 C EVAL ZTAAIDE = TAAIDE C EVAL ZTANUMRCD = TANUMRCD C EVAL ZTAMAJUSER = USER C EVAL ZTAUTUSER = TAUTUSER C EVAL ZTAUTPGMR = TAUTPGMR C EVAL ZTAUTSYSOPR = TAUTSYSOPR C EVAL ZTAUTSECADM = TAUTSECADM C EVAL ZTAUTSECOFR = TAUTSECOFR C EVAL ZTAMAJDATE = DATSYS C TIME ZTAMAJTIME C EVAL ZTAMAJCOMM = 'Mise ΰ jour via SYS400' C UPDATE TFAIDZ ‚* C ENDSR ‚* š************************************************************************** š* DLT_ENREG : Suppression d'un commentaire d'aide š************************************************************************** ‚* C DLT_ENREG BEGSR ‚* C EVAL TAACTIF = 0 C EVAL TADLTUSER = USER C EVAL TADLTDATE = DATSYS C TIME TADLTTIME C EVAL TADLTCOMM = 'Suppression via SYS400' C EVAL TADLTFLG = 1 C UPDATE TFAID ‚* C ENDSR ‚* ›* ›* €ECRAN 03 › ›* š************************************************************************** š* ECR03 - SELECTION AUTRE CLASSE UTILISATEUR POUR L'AIDE š************************************************************************** ‚* C ECR03 BEGSR ‚* C EVAL XX = 3 C EVAL IN(XX) = *OFF ‚* ˆC DOU NOT ERR(XX) C EXFMT RCD3 C EVAL ERR(XX) = *OFF ‚* ˜C SELECT ‚* ENTREE ˜C WHEN KEY = ΰENTER C EXSR RCD3ENT ‚* F12 ANNULER ˜C WHEN KEY = ΰF12 C EXSR RCD3F12 ‚* AUTRE ˜C OTHER C EVAL ERR(XX) = *ON ‚* ˜C ENDSL ‚* ˆC ENDDO ‚* C ENDSR ‚* š************************************************************************** š* RCD3ENT - ENTREE š************************************************************************** ‚* C RCD3ENT BEGSR ‚* C EXSR E3_CHK_FONC ‚* ˆC IF NOT ERR(XX) AND NOT IN(01) ˆC AND NOT IN(02) C EXSR E3_CHK_GENE ˆC ENDIF ‚* C ENDSR ‚* š************************************************************************** š* RCD3F12 - ANNULER (RETOUR ECRAN 01) š************************************************************************** ‚* C RCD3F12 BEGSR ‚* C EVAL XX = 1 C EVAL IN(XX) = *ON C EVAL REL(XX) = *ON ‚* C ENDSR ‚* š************************************************************************** š* E3_CHK_FONC š************************************************************************** ‚* C E3_CHK_FONC BEGSR ‚* ˆC SELECT ˆC WHEN FONCTION = 12 C EXSR SFL2F12 ˆC WHEN FONCTION = 99 C EXSR E3_CHK_GENE ˆC OTHER ˆC ENDSL ‚* C ENDSR ‚* š************************************************************************** š* E3_CHK_GENE š************************************************************************** ‚* C E3_CHK_GENE BEGSR ‚* C DO ‚* ˆC SELECT ˆC WHEN SNGCHOIX = 1 C EVAL TAFORUSER = '*USER' C MOVEA '10000' *IN(41) C EXSR NEW_CLASSE ˆC WHEN SNGCHOIX = 2 C EVAL TAFORUSER = '*PGMR' C MOVEA '01000' *IN(41) C EXSR NEW_CLASSE ˆC WHEN SNGCHOIX = 3 C EVAL TAFORUSER = '*SYSOPR' C MOVEA '00100' *IN(41) C EXSR NEW_CLASSE ˆC WHEN SNGCHOIX = 4 C EVAL TAFORUSER = '*SECADM' C MOVEA '00010' *IN(41) C EXSR NEW_CLASSE ˆC WHEN SNGCHOIX = 5 C EVAL TAFORUSER = '*SECOFR' C MOVEA '00001' *IN(41) C EXSR NEW_CLASSE ˆC OTHER C EVAL ERR(XX) = *ON ˆC ENDSL ‚* C ENDDO ‚* C ENDSR ‚* š************************************************************************** š* NEW_CLASSE - š************************************************************************** ‚* C NEW_CLASSE BEGSR ‚* C RESET WH1 C RESET WH2 C RESET WH3 ‚* C EVAL WW = 1 C EVAL WH1(WW) = 'TAFORUSER' C EVAL WH2(WW) = %TRIM(TAFORUSER) C EVAL WH3(WW) = 'A' ‚* ˆC SELECT ˆC WHEN CLASSE = '*USER' C EVAL WW = 2 C EVAL WH1(WW) = 'TAUTUSER' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' ˆC WHEN CLASSE = '*PGMR' C EVAL WW = 2 C* EVAL WH1(WW) = 'TAUTUSER' C* EVAL WH2(WW) = '1' C* EVAL WH3(WW) = 'N' C* EVAL WW = 3 C EVAL WH1(WW) = 'TAUTPGMR' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' ˆC WHEN CLASSE = '*SYSOPR' C EVAL WW = 2 C* EVAL WH1(WW) = 'TAUTUSER' C* EVAL WH2(WW) = '1' C* EVAL WH3(WW) = 'N' C* EVAL WW = 3 C* EVAL WH1(WW) = 'TAUTPGMR' C* EVAL WH2(WW) = '1' C* EVAL WH3(WW) = 'N' C* EVAL WW = 4 C EVAL WH1(WW) = 'TAUTSYSOPR' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' ˆC WHEN CLASSE = '*SECADM' C EVAL WW = 2 C* EVAL WH1(WW) = 'TAUTUSER' C* EVAL WH2(WW) = '1' C* EVAL WH3(WW) = 'N' C* EVAL WW = 3 C* EVAL WH1(WW) = 'TAUTPGMR' C* EVAL WH2(WW) = '1' C* EVAL WH3(WW) = 'N' C* EVAL WW = 4 C EVAL WH1(WW) = 'TAUTSECADM' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' ˆC WHEN CLASSE = '*SECOFR' C EVAL WW = 2 C* EVAL WH1(WW) = 'TAUTUSER' C* EVAL WH2(WW) = '1' C* EVAL WH3(WW) = 'N' C* EVAL WW = 3 C* EVAL WH1(WW) = 'TAUTPGMR' C* EVAL WH2(WW) = '1' C* EVAL WH3(WW) = 'N' C* EVAL WW = 4 C* EVAL WH1(WW) = 'TAUTSYSOPR' C* EVAL WH2(WW) = '1' C* EVAL WH3(WW) = 'N' C* EVAL WW = 5 C* EVAL WH1(WW) = 'TAUTSECADM' C* EVAL WH2(WW) = '1' C* EVAL WH3(WW) = 'N' C* EVAL WW = 6 C EVAL WH1(WW) = 'TAUTSECOFR' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' ˆC ENDSL C EVAL XX = 1 C EVAL IN(XX) = *ON C EVAL REL(XX) = *ON ‚* C ENDSR ‚* š************************************************************************** š* PREP_REQUETE - prιparation requκte pour lecture€ š************************************************************************** ‚* C PREP_REQUETE BEGSR ‚* C RESET DSREQUETE C EXSR PREP_WHERE C EXSR PREP_SELECT ‚* C ENDSR ‚* š************************************************************************** š* PREP_WHERE - prιparation clause WHERE du SQL € š************************************************************************** ‚* C PREP_WHERE BEGSR ‚* ˆC IF WW = 0 C EVAL WHERE = *BLANKS C EVAL Connecteur = *BLANKS ˆC ELSE C EVAL Connecteur = 'or' C EVAL WHERE = 'where' ˆC ENDIF ‚* ˆC DO WW WZ ‚* ˜C IF WZ = WW C EVAL Connecteur = ')' ˜C ELSE šC IF WZ = 1 C EVAL Connecteur = 'and(' šC ELSE C EVAL Connecteur = 'or' šC ENDIF ˜C ENDIF ‚* C EVAL WHERE = C %TRIM(WHERE) + ' ' + %TRIM(WH1(WZ)) ‚* ˜C SELECT ˜C WHEN WH3(WZ) = 'A' C EVAL WHERE = C %TRIM(WHERE) + ' = ' + C cote + %TRIM(WH2(WZ)) + cote + C ' ' + %TRIM(Connecteur) ˜C WHEN WH3(WZ) = 'N' C EVAL WHERE = C %TRIM(WHERE) + ' = ' + C %TRIM(WH2(WZ)) + ' ' + C %TRIM(Connecteur) ˜C ENDSL ‚* ˆC ENDDO ‚* C ENDSR ‚* š************************************************************************** š* PREP_SELECT - prιparation requete SQL pour lecture š************************************************************************** ‚* C PREP_SELECT BEGSR ‚* C EVAL REQUETE = C %TRIM(REQUETE) + ' ' + C %TRIM(WHERE) + ' ' ‚* C ENDSR ‚* š************************************************************************** š* SYS420 - Window d'information š************************************************************************** ‚* C SYS420 BEGSR ‚* C CALL 'SYS420' C PARM S20P1 50 C PARM S20P2 200 ‚* C ENDSR ‚* š************************************************************************** š* INIT_VIEW š************************************************************************** ‚* C INIT_VIEW BEGSR ‚* ‚* Prιparation requκte sιlection des produits visibles par l'utilisateur en ‚* C EVAL INZREQUETE = C 'Create view QTEMP/WSYS400P as ' + C 'select * from SYS400P ' + C 'where TAPGM = ' + cote + PROGRAMME + cote + C ' and TAECR = ' + cote + ECRAN + cote + C ' and TAFMT = ' + cote + FORMAT + cote + C ' and TAZONE = ' + cote + ZONE + cote + C ' and TAACTIF = 1 ' + C ' and TADLTFLG = 0 ' ‚* C/exec sql prepare requet from :INZREQUETE C/end-exec C/EXEC SQL execute immediate :INZREQUETE C/END-EXEC ‚* C ENDSR ‚* ‰************************************************************************** ‰*ˆ*INZSR - DEBUT PROGRAMME ‰************************************************************************** ‚* C *INZSR BEGSR ‚* C DO ‚* ˆC IF PARMS < 6 C EVAL *INLR = *ON ˆC ENDIF ‚* C LR LEAVE ‚* ‚* ‚* Suppression du fichier de QTEMP ‚* C EVAL INZREQUETE = C 'drop view QTEMP/WSYS400P' ‚* C/exec sql prepare requet from :INZREQUETE C/end-exec C/EXEC SQL execute immediate :INZREQUETE C/END-EXEC ‚* C EXSR INIT_VIEW ‚* ˆC IF SQLCOD <> 0 ˆC AND SQLCOD <> 100 ˆC AND SQLCOD <> -104 C SETON LR ˆC ENDIF C LR LEAVE ‚* C CALL 'SYS490C' C PARM *BLANKS CLASSE 10 ‚* YB ˆC IF PMERR = 'Y' YB C EVAL CLASSE = '*SECOFR' YB C EVAL PMERR = *BLANKS YB ˆC ENDIF ‚* C EVAL WW = 1 C EVAL WH1(WW) = 'TAFORUSER' C EVAL WH2(WW) = '*USER' C EVAL WH3(WW) = 'A' C MOVEA '10000' *IN(41) ‚* ˆC SELECT ˆC WHEN CLASSE = '*USER' C EVAL WW = 2 C EVAL WH1(WW) = 'TAUTUSER' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' ˆC WHEN CLASSE = '*PGMR' C EVAL WW = 2 C EVAL WH1(WW) = 'TAUTUSER' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' C EVAL WW = 3 C EVAL WH1(WW) = 'TAUTPGMR' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' ˆC WHEN CLASSE = '*SYSOPR' C EVAL WW = 2 C EVAL WH1(WW) = 'TAUTUSER' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' C EVAL WW = 3 C EVAL WH1(WW) = 'TAUTPGMR' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' C EVAL WW = 4 C EVAL WH1(WW) = 'TAUTSYSOPR' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' ˆC WHEN CLASSE = '*SECADM' C EVAL WW = 2 C EVAL WH1(WW) = 'TAUTUSER' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' C EVAL WW = 3 C EVAL WH1(WW) = 'TAUTPGMR' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' C EVAL WW = 4 C EVAL WH1(WW) = 'TAUTSECADM' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' ˆC WHEN CLASSE = '*SECOFR' C EVAL WW = 2 C EVAL WH1(WW) = 'TAUTUSER' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' C EVAL WW = 3 C EVAL WH1(WW) = 'TAUTPGMR' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' C EVAL WW = 4 C EVAL WH1(WW) = 'TAUTSYSOPR' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' C EVAL WW = 5 C EVAL WH1(WW) = 'TAUTSECADM' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' C EVAL WW = 6 C EVAL WH1(WW) = 'TAUTSECOFR' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' ˆC OTHER C EVAL CLASSE = '*USER' C EVAL WW = 2 C EVAL WH1(WW) = 'TAUTUSER' C EVAL WH2(WW) = '1' C EVAL WH3(WW) = 'N' ˆC ENDSL ‚* C MOVEA '0100000100' *IN(01) C MOVEA '01' *IN(11) C MOVEA '1' *IN(99) ‚* C ENDDO ‚* C ENDSR ‚* ‰************************************************************************** ‰*ˆ*PSSR - erreur de traitement ‰************************************************************************** ‚* C *PSSR BEGSR ‚* C IF ERROR = 102 C EVAL DIVISEUR = 1 C MOVE '*GETIN' ReturnPt 6 C ELSE C MOVE '*CANCL' ReturnPt C ENDIF ‚* C IF OPENCURSO1 C/exec sql close curs1 C/end-exec C MOVE '*GETIN' ReturnPt 6 C ENDIF ‚* C IF OPENCURSO2 C/exec sql close curs2 C/end-exec C MOVE '*GETIN' ReturnPt 6 C ENDIF ‚* C ENDSR ReturnPt ‚*