Re: Deleteing Messages

[Chuck Lewis <CLEWIS@xxxxxxxxxx>]

Thanks Chris (JUST noticed your reply..).

I'll check it out !

Chuck

Spirinckx Chris wrote:

> Chuck,
>
> Sometime ago, I wrote this little command to cleanup messages from a
> specified message queue.
>
> It's not the "cleanest" coding but it works ;-).
>
> ======================================================================
>
> CMD PROMPT('Clear messages by period')
>
> PARM KWD(MSGQ) TYPE(MSGQUAL) PROMPT('Message Queue')
> PARM KWD(DAYS) TYPE(*DEC) LEN(5 0) PROMPT('Days to keep') DFT(14)
>
> MSGQUAL: +
>    QUAL TYPE(*NAME) LEN(10) DFT(FTPMSGQ)
>    QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) +
>         SPCVAL((*LIBL '*LIBL')) PROMPT('Library')
>
> ======================================================================
>
> PGM PARM(&MSGLIB &DAYS)
>
> DCL VAR(&MSGLIB) TYPE(*CHAR) LEN(20)
> DCL VAR(&DAYS) TYPE(*DEC) LEN(5 0)
>
> DCL VAR(&MSGINF) TYPE(*CHAR) LEN(3000)
> DCL VAR(&MSGLEN) TYPE(*CHAR) LEN(4)
> DCL VAR(&MSGFMT) TYPE(*CHAR) LEN(8)
> DCL VAR(&MSGTYP) TYPE(*CHAR) LEN(10)
> DCL VAR(&MSGKEY) TYPE(*CHAR) LEN(4)
> DCL VAR(&MSGWAI) TYPE(*CHAR) LEN(4)
> DCL VAR(&MSGACT) TYPE(*CHAR) LEN(10)
> DCL VAR(&APIERR) TYPE(*CHAR) LEN(100)
> DCL VAR(&MSGYMD) TYPE(*CHAR) LEN(6)
> DCL VAR(&CURYMD) TYPE(*CHAR) LEN(6)
> DCL VAR(&REFYMD) TYPE(*CHAR) LEN(6)
> DCL VAR(&FSTYMD) TYPE(*CHAR) LEN(6)
> DCL VAR(&BIN0) TYPE(*CHAR) LEN(4) VALUE(X'00000000')
> DCL VAR(&BIN8) TYPE(*CHAR) LEN(4) VALUE(X'00000008')
> DCL VAR(&COUNT) TYPE(*DEC) LEN(5 0)
> DCL VAR(&COUNTA) TYPE(*CHAR) LEN(5)
> DCL VAR(&ERRMSGID) TYPE(*CHAR) LEN(7)
> DCL VAR(&ERRMSGTX) TYPE(*CHAR) LEN(256)
>
> ADDLIBLE LIB(TAATOOL) POSITION(*LAST)
> MONMSG MSGID(CPF2103)
> RTVSYSVAL SYSVAL(QDATE) RTNVAR(&CURYMD)
> CHGVAR VAR(&DAYS) VALUE(&DAYS * (-1))
> ADDDAT DAYS(&DAYS) TOVAR(&REFYMD) DATE(&CURYMD)
> CHGVAR VAR(&MSGLEN) VALUE(X'000003E8')
> CHGVAR VAR(&MSGFMT) VALUE('RCVM0200')
> CHGVAR VAR(&MSGTYP) VALUE('*NEXT     ')
> CHGVAR VAR(&MSGWAI) VALUE(X'00000000')
> CHGVAR VAR(&MSGACT) VALUE('*SAME     ')
> CHGVAR VAR(&FSTYMD) VALUE('999999')
>
> LOOP:
> CHGVAR VAR(&APIERR) VALUE(X'00000064')
> CHGVAR VAR(&MSGKEY) VALUE(X'00000000')
> CALL PGM(QMHRCVM) PARM(&MSGINF &MSGLEN &MSGFMT &MSGLIB &MSGTYP +
>                        &MSGKEY &MSGWAI &MSGACT &APIERR)
> IF COND(%SST(&APIERR 5 4) *NE &BIN0) THEN(GOTO ERROR)
> IF COND(%SST(&MSGINF 1 4) *EQ &BIN8 *AND +
>         %SST(&MSGINF 5 4) *EQ &BIN0) THEN(GOTO END)
>
> CHGVAR VAR(&MSGKEY) VALUE(%SST(&MSGINF 22 4))
> CHGVAR VAR(&MSGYMD) VALUE(%SST(&MSGINF 99 6))
> IF COND(&FSTYMD *EQ '999999') THEN(CHGVAR VAR(&FSTYMD) VALUE(&MSGYMD))
> IF COND(&REFYMD *GT &MSGYMD) THEN(DO)
>    CALL PGM(QMHRMVM) PARM(&MSGLIB &MSGKEY '*BYKEY    ' &APIERR)
>    IF COND(%SST(&APIERR 5 4) *NE &BIN0) THEN(GOTO ERROR)
>    CHGVAR VAR(&COUNT) VALUE(&COUNT + 1)
>    GOTO LOOP
>    ENDDO
> GOTO END
>
> ERROR:
> CHGVAR VAR(&ERRMSGID) VALUE(%SST(&APIERR 9 7))
> RTVMSG MSGID(&ERRMSGID) MSGF(QCPFMSG) MSG(&ERRMSGTX)
> SNDPGMMSG MSG(&ERRMSGTX)
> GOTO ENDPGM
>
> END:
> CHGVAR VAR(&COUNTA) VALUE(&COUNT)
> SNDPGMMSG MSG(&COUNTA *BCAT 'Messages removed from messagequeue' +
>               *BCAT %SST(&MSGLIB 11 10) *TCAT '/' +
>               *CAT %SST(&MSGLIB 1 10) +
>               *BCAT &FSTYMD)
>
> ENDPGM:
> RETURN
> ENDPGM
>
> ======================================================================
>
> Should you need more info, please let me know.
>
> HTH
>
> Chris
>
> ===========================================================================
> Chris Spirinckx            # E-mail live : Chris.Spirinckx@village.uunet.be
> F. van Eedenplein 4a/5     # ICQ number  : 14033396
> B2050 Antwerpen            # E-mail work : cspirinc@pee.pioneer.be
> BELGIUM (Europe)           # Tel/Fax : + 32 3 219.09.12
> +---
> | This is the Midrange System Mailing List!
> | To submit a new message, send your mail to MIDRANGE-L@midrange.com.
> | To subscribe to this list send email to MIDRANGE-L-SUB@midrange.com.
> | To unsubscribe from this list send email to MIDRANGE-L-UNSUB@midrange.com.
> | Questions should be directed to the list owner/operator: david@midrange.com
> +---

+---
| This is the Midrange System Mailing List!
| To submit a new message, send your mail to MIDRANGE-L@midrange.com.
| To subscribe to this list send email to MIDRANGE-L-SUB@midrange.com.
| To unsubscribe from this list send email to MIDRANGE-L-UNSUB@midrange.com.
| Questions should be directed to the list owner/operator: david@midrange.com
+---