PGM PARM(&CST)
DCL VAR(&POS) TYPE(*CHAR) LEN(4)
DCL VAR(&KEY) TYPE(*CHAR) LEN(4)
DCL VAR(&ID) TYPE(*CHAR) LEN(7)
DCL VAR(&MSG) TYPE(*CHAR) LEN(78)
DCL VAR(&DATA) TYPE(*CHAR) LEN(1024)
DCL VAR(&CST) TYPE(*CHAR) LEN(78)
RCVMSG PGMQ(*PRV) MSGTYPE(*LAST) RMV(*NO) +
KEYVAR(&KEY) MSG(&MSG) MSGDTA(&DATA) MSGID(&ID)
BOUCLE: IF (&MSG = ' ') RETURN
IF ((&ID ^= 'CPF502D') & (&ID ^= 'CPF502B') & +
(&ID ^= 'CPF5009') & (&ID ^= 'CPF503A') & +
(&ID ^= 'CPF502F') ) THEN(DO)
CHGVAR VAR(&POS) VALUE(&KEY)
RCVMSG PGMQ(*PRV) MSGTYPE(*PRV) MSGKEY(&POS) +
RMV(*NO) KEYVAR(&KEY) MSG(&MSG) +
MSGDTA(&DATA) MSGID(&ID)
GOTO BOUCLE
ENDDO
/* VIOLATION D'INTEGRITE REFERENTIELLE (CLÉ PRIMAIRE) */
IF (&ID = 'CPF5009') THEN(DO)
CHGVAR &CST 'Cette clé existe déja'
ENDDO
ELSE DO
/* VIOLATION D'INTEGRITE REFERENTIELLE (sur le fichier fils) */
IF (&ID = 'CPF502D') CHGVAR &CST %SST(&DATA 177 78)
/* (sur le fichier parent) */
IF (&ID = 'CPF503A') CHGVAR &CST %SST(&DATA 897 78)
/* VIOLATION CONTRAINTE DE DOMAINE */
IF (&ID = 'CPF502F') CHGVAR &CST %SST(&DATA 897 78)
/* OU ERREUR SUITE À TRIGGER (CPF502B) */
IF (&ID = 'CPF502B') DO
/* LE TEXTE PEUT SE TROUVER DANS LE MESSAGE DIAGNOSTIQUE PRECEDENT */
CHGVAR VAR(&POS) VALUE(&KEY)
RCVMSG PGMQ(*PRV) MSGTYPE(*PRV) MSGKEY(&POS) +
RMV(*NO) MSG(&MSG)
IF (&MSG = ' ') THEN(CHGVAR &CST 'Erreur envoyée par trigger')
ELSE CHGVAR VAR(&CST) VALUE(&MSG)
ENDDO
ENDDO
ENDPGM
| 
| 
