PGM (&OBJNAM &LIBNAM) /* NORMAL SET OF FIELDS */
/*01234567890123456789*/
DCL &USRSPC *CHAR 20 'XXXXXX QTEMP '
DCL &SIZE *CHAR 4 /* SIZE OF USERSPACE */
DCL &HDRDTA *CHAR 24 /* HEADER OF USER SPACE */ DCL &RTVSTRB *CHAR 4 /* RETRIEVE START IN USRSPC */
DCL &RTVLENB *CHAR 4 /* RETRIEVE LENGTH OF EACH ITEMS */ DCL &LSTCNT *DEC (9 0) /* COUNTER OF ITEMS IN USRSPC */
DCL &WRKCNT *DEC (9 0) /* WORK FIELD OF COUNTER */ DCL &ERR_BYT *CHAR 4 /* ERROR STRUCTURE */
DCL &ERR_AVA *CHAR 4 /* ERROR STRUCTURE */
DCL &ERR_ID *CHAR 7 /* ERROR STRUCTURE */
DCL &ERR_RSV *CHAR 1 /* ERROR STRUCTURE */
DCL &ERR_MSG *CHAR 100 /* ERROR STRUCTURE */
DCL &ERRDTA *CHAR 116 /* ERROR STRUCTURE */ /* OPTIONAL SET OF FIELDS */ DCL &OBJNAM *CHAR 10 /* OBJECT NAME */
DCL &LIBNAM *CHAR 10 /* OBJECT LIBRARY */
DCL &OBJLIB *CHAR 20 /* OBJ + LIB */
DCL &LSTHDR *CHAR 200 /* RETREIVED LIST DATA FM USRSPC */
/* ~~~ OR MORE */
DCL &LSTDTA *CHAR 100 /* RETREIVED LIST DATA FM USRSPC */
/* ~~~ OR MORE */ DCL &FILTXT *CHAR 50 /* OPTIONAL FIELD */
DCL &MBRNAME *CHAR 10 /* OPTIONAL FIELD */
DCL &MBR *CHAR 10 '*ALL' /* OPTION FOR API */ /*--------------------------------------*/
/* INITIAL ROUTINE */
/*--------------------------------------*/ CHGVAR &OBJLIB (&OBJNAM || &LIBNAM) /*--------------------------------------*/
/* CREATE USER SPACE */
/*--------------------------------------*/ CHGVAR %BIN(&SIZE) 1024
CHKOBJ %SST(&USRSPC 11 10)/%SST(&USRSPC 1 10) *USRSPC
MONMSG CPF9801 *N +
CALL QUSCRTUS (&USRSPC 'WRK ' &SIZE ' ' '*ALL' ' ') /*--------------------------------------*/
/* MAKE AN ERROR STRUCTURE */
/*--------------------------------------*/ CHGVAR %BIN(&ERR_BYT) 116 /* TOTAL LENGTH OF ERRDTA */
CHGVAR %BIN(&ERR_AVA) 0
CHGVAR &ERRDTA (&ERR_BYT||&ERR_AVA||&ERR_ID||&ERR_RSV||&ERR_MSG) /****************************************/
/* SPREAD DATA BY API : OPTIONAL !!!! */
/****************************************/ CALL QUSLMBR (&USRSPC 'MBRL0100' &OBJLIB &MBR '0' &ERRDTA)
/* ~~~~~~~ */ IF (%BIN(&ERRDTA 5 4) *NE 0) DO
CHGVAR &ERR_BYT %SST(&ERRDTA 1 4)
CHGVAR &ERR_AVA %SST(&ERRDTA 5 4)
CHGVAR &ERR_ID %SST(&ERRDTA 9 7)
CHGVAR &ERR_MSG %SST(&ERRDTA 17 100)
/* YOU CAN CODE ERROR MESSAGE ROUTINE LIKE BELOW. */
SNDPGMMSG MSGID(&ERR_ID) MSGF(QCPFMSG) +
MSGDTA(&ERR_MSG) MSGTYPE(*ESCAPE)
MONMSG CPF0000
GOTO \END
ENDDO /*--------------------------------------*/
/* RETRIEVE HEADER FROM USER SPACE */
/*--------------------------------------*/ CHGVAR %BIN(&RTVSTRB) 117 /* OFFSET OF HEADER */
CHGVAR %BIN(&RTVLENB) 24 /* LENGTH OF HDRDTA */ CALL QUSRTVUS (&USRSPC &RTVSTRB &RTVLENB &HDRDTA) CHGVAR &LSTCNT %BIN(&HDRDTA 17 4) /* COUNT OF ITEMS IN LIST */ IF (&LSTCNT = 0 ) DO
/* NO ITEM ROUTINE ; SNDMSG OR SOMETHING LIKE THAT IYW. */
GOTO \END /* AS YOU LIKE */
ENDDO /*--------------------------------------*/
/* RETRIEVE HEADER OF LIST DATA */
/*--------------------------------------*/ CHGVAR %BIN(&RTVSTRB) (%BIN(&HDRDTA 1 4) + 1) /* OFFSET */
CHGVAR &RTVLENB %SST(&HDRDTA 5 4) /* ITEM LENGTH */ CALL QUSRTVUS (&USRSPC &RTVSTRB &RTVLENB &LSTHDR) /***************************************/
/* (1) USE HEADER OF LIST DATA */
/***************************************/ /* YOU CAN USE HEADER OF LIST DATA LIKE BELOW. */ CHGVAR &FILTXT %SST(&LSTHDR 31 50)
SNDPGMMSG MSG(&FILTXT) /*--------------------------------------*/
/* PREPARATION OF RETRIEVE LIST DATA */
/*--------------------------------------*/ CHGVAR &WRKCNT 0
CHGVAR %BIN(&RTVSTRB) (%BIN(&HDRDTA 9 4) + 1) /* LIST OFFSET */
CHGVAR &RTVLENB %SST(&HDRDTA 21 4) /* ITEM LENGTH */ /*--------------------------------------*/
/* RETRIEVE LIST DATA FORM USER SPACE */
/*--------------------------------------*/ \RTVUSP:
CHGVAR &WRKCNT (&WRKCNT + 1)
CALL QUSRTVUS (&USRSPC &RTVSTRB &RTVLENB &LSTDTA) /***************************************/
/* (2) USE ITEM DATA FROM &LSTDATA */
/***************************************/ /* YOU CAN USE LIST DATA HERE LIKE BELOW. */ CHGVAR &MBRNAME %SST(&LSTDTA 1 10)
SNDPGMMSG MSG(&MBRNAME) /*--------------------------------------*/
/* PREPARATION FOR NEXT LIST ITME */
/*--------------------------------------*/ IF (&LSTCNT = &WRKCNT) GOTO \END
CHGVAR %BIN(&RTVSTRB) (%BIN(&RTVSTRB) + %BIN(&RTVLENB))
GOTO \RTVUSP \END: IF (%SST(&USRSPC 11 10)='QTEMP') DO
DLTUSRSPC %SST(&USRSPC 11 10)/%SST(&USRSPC 1 10)
ENDDO RETURN
ENDPGM | 
