Re: Deleteing Messages -- MIDRANGE-L

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
+---