| 
PGM PARM(&USRIDXQ &SELECT &RTNVAR2002)
DCL &USRIDXQ *CHAR 20
DCL &SELECT *CHAR 4010
DCL &RTNVAR2002 *CHAR 2002
DCL &VAR2008 *CHAR 2008
DCL &BIN2008 *CHAR 4
DCL &OFFSET *CHAR 16
DCL &NBENTRY *CHAR 4 X'00000001'
DCL &RTNLIB *CHAR 10
DCL &CRITERE *CHAR 4000
DCL &CRITERL *CHAR 4 X'00000000'
DCL &CRITEROFF *CHAR 4 X'00000000'
DCL &TEST *CHAR 4
DCL &VAL1 *CHAR 2000
DCL &VAL2 *CHAR 2000
DCL &LG1 *DEC (5 0)
DCL &LG2 *DEC (5 0)
DCL &RTNVARLG *DEC (5 0)
DCL &NBELEM *DEC (3 0)
DCL &X0 *CHAR 1 X'00'
DCL &X6 *CHAR 4 X'00000006'
DCL &X8 *CHAR 4 X'00000008'
DCL &RETOURLG *DEC (5 0)
/* VARIABLES UTILISEES PAR LA GESTION DE MESSGAES */
DCL &ERRORSW *LGL /* SWITCH */
DCL &MSGID *CHAR LEN(7) /* ID MSG */
DCL &MSGDTA *CHAR LEN(100) /* DATA */
DCL &MSGF *CHAR LEN(10) /* FICHIER */
DCL &MSGFLIB *CHAR LEN(10) /* BIBLI */
MONMSG MSGID(CPF0000) EXEC(GOTO ERREUR)
CHGVAR VAR(%BIN(&BIN2008)) VALUE(2008)
/* CONTROLES */
CHGVAR &NBELEM %BIN(&SELECT 1 2)
IF (&NBELEM = 0) +
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
MSGDTA('Paramètre SELECT doit être +
renseigné') MSGTYPE(*ESCAPE)
CHGVAR &TEST %SST(&SELECT 3 4)
CHGVAR &LG1 %BIN(&SELECT 7 2)
IF (&LG1 ^= 0) CHGVAR &VAL1 %SST(&SELECT 9 &LG1)
IF COND((&LG1 *EQ 0) *OR ((&LG1 *EQ 1) *AND +
(%SST(&VAL1 1 1) = &X0))) THEN(DO)
|
|
IF COND((&TEST < &X6) *OR (&TEST = &X8)) +
THEN(SNDPGMMSG MSGID(CPF9898) +
MSGF(QCPFMSG) MSGDTA('VALEUR 1 doit être +
renseignée') MSGTYPE(*ESCAPE))
ENDDO
CHGVAR &LG2 %BIN(&SELECT 2009 2)
IF (&LG2 ^= 0) CHGVAR &VAL2 %SST(&SELECT 2011 &LG2)
IF COND((&LG2 *EQ 0) *OR ((&LG2 *EQ 1) *AND +
(%SST(&VAL2 1 1) = &X0))) THEN(DO)
IF COND(&TEST = &X8) THEN(SNDPGMMSG +
MSGID(CPF9898) MSGF(QCPFMSG) +
MSGDTA('VALEUR 2 doit être renseignée') +
MSGTYPE(*ESCAPE))
ENDDO
IF (&TEST = &X8) THEN(DO) /* *RANGE */
IF (&LG1 < &LG2) CHGVAR %BIN(&CRITERL) &LG2
ELSE CHGVAR %BIN(&CRITERL) &LG1
CHGVAR &CRITERE (&VAL1 *CAT &VAL2)
CHGVAR %BIN(&CRITEROFF) 2000
ENDDO
ELSE DO
IF (&TEST *LT &X6) THEN(DO) /* <> *FIRST , *LAST */
CHGVAR %BIN(&CRITERL) &LG1
CHGVAR &CRITERE (&VAL1)
ENDDO
ENDDO
/* APPEL API */
CALL QUSRTVUI PARM( &VAR2008 &BIN2008 &OFFSET +
X'00000010' &NBENTRY &RTNLIB +
&USRIDXQ 'IDXE0100' X'00000001' +
&TEST &CRITERE &CRITERL &CRITEROFF +
X'00000000')
/* RETOUR DES INFOS DANS VARIABLE */
CHGVAR &RETOURLG %BIN(&VAR2008 1 4) /* LG EXTRAITE */
CHGVAR &RTNVARLG %BIN(&RTNVAR2002 1 2) /* LG RTNVAR */
IF COND(&RTNVARLG < &RETOURLG) THEN(DO)
CHGVAR VAR(%SST(&RTNVAR2002 3 &RTNVARLG)) +
VALUE(%SST(&VAR2008 9 &RTNVARLG))
SNDPGMMSG MSG('Données tronquées') MSGTYPE(*DIAG)
ENDDO
ELSE DO
CHGVAR %SST(&RTNVAR2002 3 &RTNVARLG) ' '
CHGVAR VAR(%SST(&RTNVAR2002 3 &RETOURLG)) +
|
|
VALUE(%SST(&VAR2008 9 &RETOURLG)) ENDDO /* RENVOI DES MESSAGES DE TYPE *COMP SI FIN NORMALE */ COMPMSG: RCVMSG MSGTYPE(*COMP) MSGDTA(&MSGDTA) MSGID(&MSGID) + MSGF(&MSGF) SNDMSGFLIB(&MSGFLIB) IF (&MSGID *EQ ' ') RETURN /* FIN DU PGM */ SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) + MSGDTA(&MSGDTA) MSGTYPE(*COMP) GOTO COMPMSG /* BOUCLE SUR MESSAGES *COMP */ /*----------------------------------------*/ ERREUR: /* GESTION DES ERREURS */ /*----------------------------------------*/ IF &ERRORSW SNDPGMMSG MSGID(CPF9899) + MSGF(QCPFMSG) MSGTYPE(*ESCAPE) /* 2EME FOIS*/ /* ARRET PGM*/ CHGVAR &ERRORSW '1' /* MISE EN PLACE DU SWTICH */ /* RENVOI DES MESSAGES DE TYPE *DIAG SI FIN ANORMALE */ DIAGMSG: RCVMSG MSGTYPE(*DIAG) MSGDTA(&MSGDTA) MSGID(&MSGID) + MSGF(&MSGF) SNDMSGFLIB(&MSGFLIB) IF (&MSGID *EQ ' ') GOTO EXCPMSG SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) + MSGDTA(&MSGDTA) MSGTYPE(*DIAG) GOTO DIAGMSG /* BOUCLE SUR MESSAGES *DIAG */ /* RENVOI DU MESSAGE D'ERREUR */ EXCPMSG: RCVMSG MSGTYPE(*EXCP) MSGDTA(&MSGDTA) MSGID(&MSGID) + MSGF(&MSGF) SNDMSGFLIB(&MSGFLIB) SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) + MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE) ENDPGM |
