iSeries & System i

#1 API - Table of Contents #3

API Name # Description
QYASPOL   Open List of ASPs
QWCRJBLK 6 Retrieve Job Lock
QUSRMBRD 2 Retrieve Member Description
QSZRTVPR 1 Retrieve CPU Information
QWCCVTDT 3 Convert Date and Time Format
QBNLPGMI   List ILE Program Information
QBNLSPGM   List ILE Service Program Information
QWVRCSTK & QGY..... 1 Retrieve Call Stack
QWCRSVAL 1 Retrieve System Value
QSYGETPH   Get Profile Handle
QMHMOVPM   Move Program Messages
QMHRSNEM   Resend Escape Message
QMHRMQAT   Retrieve Nonprogram Message Queue Attributes
QUSLJOB 1 List Job
QWDRSBSD   Retrieve Subsystem Information
QOKSCHD 4 Search System Directory
QZLSLSTI   List Server Information
QLIRLIBD   Retrieve Library Description
QUSLSPL   List Spooled Files
QtocLstNetIfc 4 List Network Interfaces
QLGCNVCS   Convert Case


Open List of ASPs
(not sure if QYASPOL is working as is, because of the '4B 0' vs '10I 0').

	D QYASPOL         PR                  ExtPgm('QYASPOL')
	D  PR_Rcvr                      64
	D  PR_RcvLen                    10I 0
	D  PR_LstInfo                   80
	D  PR_NbrRcds                   10I 0
	D  PR_NbrFltr                   10I 0
	D  PR_FltrInf                   13
	D  PR_FmtCode                    8
	D  PR_Code                     116

	D AS_FltrInf      DS            13
	D  AS_FltSize             1      4B 0 Inz(9)
	D  AS_FltKey              5      8B 0 Inz(1)
	D  AS_SzFltD              9     12B 0 Inz(1)
	D  AS_FltDta             13     13    Inz('1')

	D AS_RcvLen       s             10I 0 Inz(64)
	D AS_LstInfo      s             80
	D AS_NbrRcds      s             10I 0 Inz(1)
	D AS_NbrFltr      s             10I 0 Inz(1)
	D AS_FmtCode      s              8    Inz('YASP0200')

	DAS_RCVR          DS            64                    YASP0200
	D QYAUMBER00              1      4B 0
	D QYADISKS                5      8B 0                 Disks
	D QYATOTAL                9     12B 0                 Total
	D QYAAVAIL               13     16B 0                 Avail
	D QYAPT                  17     20B 0                 Prot Total
	D QYAPA                  21     24B 0                 Prot Avail
	D QYAUT                  25     28B 0                 Unprot Total
	D QYAUA                  29     32B 0                 Unprot Avail
	D QYASS                  33     36B 0                 System Stg
	D QYAOS                  37     40B 0                 Ovrflow Stg
	D QYAEL                  41     44B 0                 Error Log
	D QYAML                  45     48B 0                 Mach Log
	D QYAMT                  49     52B 0                 Mach Trace
	D QYAMSD                 53     56B 0                 M S Dump
	D QYAOCODE               57     60B 0                 Microcode
	D QYASHOLD               61     64B 0                 Threshold

	D ER_Code         ds
	D  ER_BytPrv              1      4b 0 Inz(116)
	D  ER_BytAvl              5      8b 0
	D  ER_MsgID               9     15
	D  ER_ErNbr              16     16
	D  ER_MsgDta             17    116

	C                   CallP     QYASPOL(AS_Rcvr   :
	C                                     AS_RcvLen :
	C                                     AS_LstInfo:
	C                                     AS_NbrRcds:
	C                                     AS_NbrFltr:
	C                                     AS_FltrInf:
	C                                     AS_FmtCode:
	C                                     ER_Code   )

	C                   Eval      *InLr = *On

Thanks to Chris Beck

I was trying to make a program using API QYASPOL. I’ve found a nice source on your website. But there is a small error in the source: The ‘filter data’ should be binary instead of character (with effects on the sizes), it should be like this: D AS_FltrInf DS 16 D AS_FltSize 1 4B 0 Inz(16) D AS_FltKey 5 8B 0 Inz(1) D AS_SzFltD 9 12B 0 Inz(4) D AS_FltDta 13 16B 0 Inz(1) Thanks to Jan Wijnants


Retrieve Job Lock

     **-- Header specifications:  --------------------------------**
     H Option( *SrcStmt )
     **-- Api error data structure:  -----------------------------**
     D ApiError        Ds
     D  AeBytPro                     10i 0 Inz( %Size( ApiError ))
     D  AeBytAvl                     10i 0 Inz
     D  AeMsgId                       7a
     D                                1a
     D  AeMsgDta                    128a
     **-- Global variables:  -------------------------------------**
     D Idx                            5i 0
     **-- Job lock information:  ---------------------------------**
     D JBLK0100        Ds         65535
     D  JlBytAvl                     10i 0
     D  JlBytRtn                     10i 0
     D  JlNbrObjLck                  10i 0
     D  JlOfsObjLck                  10i 0
     D  JlNbrLckObjRt                10i 0
     D  JlLckObjEntLn                10i 0
     D LckInf          Ds                  Based( pLckInf )
     D  LiObjNam                     10a
     D  LiObjLib                     10a
     D  LiObjTyp                     10a
     D  LiObjExtAtr                  10a
     D  LiLckStt                     10a
     D                                2a
     D  LiLckSts                     10i 0
     D  LiMbrLcks                    10i 0
     D  LiLckCnt                     10i 0
     D  LiLckScp                      1a
     D                                2a
     D  LiThrId                       8a
     **-- Job id:  -----------------------------------------------**
     D JlJobId         Ds
     D  JiJobNam                     10a   Inz( '*' )
     D  JiUsrNam                     10a
     D  JiJobNbr                      6a
     D  JiIntJobId                   16a   Inz( *Blanks )
     D                                2a   Inz( *Allx'00' )
     D  JlThrInd                     10i 0 Inz( 2 )
     D  JlThrId                       8a
     **-- Retrieve job record locks:  ----------------------------**
     D RtvJobLck       Pr                  ExtPgm( 'QWCRJBLK' )
     D  JlRcvVar                  65535a         Options( *VarSize )
     D  JlRcvVarLen                  10i 0 Const
     D  JlFmtNam                      8a   Const
     D  JlJobId                      56a   Const
     D  JlFmtJobId                    8a   Const
     D  JlError                   32767a         Options( *VarSize )
     **-- Mainline:  ---------------------------------------------**
     C                   CallP     RtvJobLck( JBLK0100
     C                                      : %Size( JBLK0100 )
     C                                      : 'JBLK0100'
     C                                      : JlJobId
     C                                      : 'JIDF0100'
     C                                      : ApiError
     C                                      )
     C                   If        AeBytAvl    = *Zero
     C                   ExSr      PrcJobLck
     C                   EndIf
     C                   Return
     **-- Process job locks:  ------------------------------------**
     C     PrcJobLck     BegSr
     C                   Eval      pLckInf     = %Addr( JBLK0100 ) +
     C                                           JlOfsObjLck
     C                   For       Idx         = 1  to JlNbrLckObjRt
     **-- Do whatever...
     C                   If        Idx         < JlNbrLckObjRt
     C                   Eval      pLckInf     = pLckInf + JlLckObjEntLn
     C                   EndIf
     C                   EndFor
     C                   EndSr

Dennis Lovelady wrote: Thanks for sharing that code, Carsten. Yeah, that looks useful in the right places. :) Not to fault your code (which, again, I do appreciate!), I'm curious why you don't use QSYSINC items for some of that stuff (like QUSEC, for example). If it's because of variable data being left undefined (such as QUSED01), you might find the following useful: * PLEASE keep the next two lines TOGETHER!!! D/Copy qsysinc/qrpglesrc,qusec D QUSED01 1024 * PLEASE keep the previous two lines TOGETHER!!!
Carsten Flensburg replied: Well, it's partly due to the circumstance that I started coding APIs before QSYSINC became an option and thus invented my own set of naming standards - and partly due to the fact that I've run into some problems actually using the library because of errors in the header files. I also just checked the include file for the QWCRJBLK API and though it was introduced just recently - V5R1- it still uses positional definition of the structure subfields and defines numeric subfields as Binary instead of Integer data type... - I prefer using the more recent options in both cases. On the other hand - as I'm confronted with more and more C code and style - I really start liking the idea of a general header file set to ease both the use of APIs and functions and the maintainance of a global coding standard. Speaking of RPG/IV I just don't think that QSYSINC - in general - has the adequate level of quality yet. Thanks to Carsten Flensburg & Dennis Lovelady

Retrieve Member Description

	P SrcChanged      B
	D SrcChanged      PI            13P 0
	D   peSrcFile                   10A   const
	D   peSrcLib                    10A   const
	D   peSrcMbr                    10A   const

	D dsEC            DS
	D  dsECBytesP             1      4I 0 Inz(256)
	D  dsECBytesA             5      8I 0 Inz(0)
	D  dsECMsgID              9     15
	D  dsECReserv            16     16
	D  dsECMsgDta            17    256

	D RtvMbrD         PR                  ExtPgm('QUSRMBRD')
	D   RcvVar                       1A
	D   RcvVarLen                   10I 0 Const
	D   Format                       8A   Const
	D   QualDBF                     20A   Const
	D   Member                      10A   Const
	D   UseOvrDbf                    1A   Const
	D   ErrorCode                    1A

	D dsSM            ds
	D   dsSMBytRtn                  10I 0
	D   dsSMBytAvl                  10I 0
	D   dsSMFilNam                  10A
	D   dsSMFilLib                  10A
	D   dsSMFilMbr                  10A
	D   dsSMFilAtr                  10A
	D   dsSMSrcTyp                  10A
	D   dsSMCrtDat                  13A
	D   dsSMChgDat                  13A
	D   dsSMText                    50A
	D   dsSMSrcFil                   1A

	D wkReturn        s             13P 0

	C                   callp     RtvMbrD(dsSM: %size(dsSM):
	C                            'MBRD0100':
	C                             (peSrcFile+peSrcLib):
	C                             peSrcMbr: '0': dsEC)

	c                   if        dsECBytesA>0
	c                   return    -1
	c                   endif

	c                   testn                   dsSMChgDat           99
	c                   if        *in99 = *off
	c                   return    -2
	c                   endif

	c                   move      dsSMChgDat    wkReturn
	c                   return    wkReturn
	P                 E

Thanks to Scott Klement

Retrieve CPU Information

     DsndMsg           pr
     D msgText                       80    const

     D matmatr         PR                  EXTPROC('matmatr')
     D   attributes                    *   VALUE
     D   attrLen                      5I 0 VALUE

     D machineAttributes...
     D                 DS                  INZ
     D   MMTR_Template_Size...
     D                               10I 0
     D   MMTR_Bytes_Used...
     D                               10I 0
     D   MMTR_VPD                  4096

     D VPDOffsets      DS                  INZ
     D  vRes1                         8
     D  vMemOff                      10i 0
     D  vPrcOff                      10i 0
     D  vColOff                      10i 0
     D  vCecOff                      10i 0
     D  vPnlOff                      10i 0
     D  vRes2                        12
     D  vMemInstalled                 5i 0
     D  vMemRequired                  5i 0

     d cecVPD          DS                  INZ
     d  cCEC_read                     4
     d  cManufacturin                 4
     d  creserved1                    4
     d  cType                         4
     d  cModel                        4
     d  cPseudo_Model                 4
     d  cGroup_Id                     4
     d  creserved2                    4
     d  cSys_Type_Ext                 1
     d  cFeature_Code                 4
     d  cSerial_No                   10
     d  creserved3                    1

     d panelVPD        DS                  INZ
     d  preserved1                    2
     d  pPanel_Type                   4
     d  pModel                        3
     d  pPart                        12
     d  preserved2                    4
     d  pManufacturin                 4
     d  pROS_Part                    12
     d  pROS_Card                    10
     d  pROS_ID                       1
     d  pROS_Flag                     1
     d  pROS_Fix                      1
     d  pSerial_No                   10

     D $MMTR_SERIAL_   S              5I 0 INZ(4)
     D $MMTR_VPD_      S              5i 0 INZ(x'012c')

     D prErrStruc      DS                  inz
     D  prErrSSize                   10i 0 inz(%len(prErrStruc))
     D  PrErrSUse                    10i 0
     D  prErrSmsgID                   7
     D  prErrSResrv                   1
     D  prErrSData                   80

     d prRcvr          s            128
     d prRcvrLen       s             10i 0 inz(%size(prRcvr))
     d prFormat        s              8    inz('PRDR0100')
     d prPrdInfo       s             27    inz('*OPSYS *CUR  0000*CODE    ')
     d prErr           s                   like(prErrStruc)
     d prRelease       s              6

     C                   EVAL      MMTR_Template_Size =
     C                   CALLP     matmatr( %ADDR(machineAttributes) :
     C                                      $MMTR_VPD_ )

     c                   eval      VPDOffsets = %subst(MMTR_VPD:
     c                                                 1:
     c                                                 %len(VPDOffsets))

     c                   eval      cecVPD   = %subst(MMTR_VPD:
     c                                               vCecOff-7:
     c                                               %len(cecVPD))
     c                   eval      panelVPD = %subst(MMTR_VPD:
     c                                               vPnlOff-7:
     c                                               %len(panelVPD))

     C                   eval      prErr = prErrStruc
     c                   call      'QSZRTVPR'
     c                   parm                    prRcvr
     c                   parm                    prRcvrLen
     c                   parm                    prFormat
     c                   parm                    prPrdInfo
     c                   parm                    prErr
     C                   eval      prErrStruc = prErr
     C                   eval      prRelease  = %subst(prRcvr: 20: 6)

     c                   callp     sndMsg('Type '     + %trim(cType) +
     c                                    ' model '   + %trim(cModel) +
     c                                    ' prc grp ' + %trim(cGroup_ID) +
     c                                    ' fc '      + %trim(cFeature_Code)
     c                                    ' serial '  + %trim(cSerial_No) +
     c                                    ' '         + %trim(
     c                                                  %editc(vMemInstalled:
     c                                                  'Z')) + ' meg' +
     c                                    ' rel '     + %trim(prRelease)
     c                                   )

     C                   SETON                                        LR
     C                   RETURN

     PsndMsg           b
     DsndMsg           pi
     D inpText                       80    const

      * Send message API parameters
     D msgID           s              7    inz('CPF9898')
     D msgFil          s             20    inz('QCPFMSG   *LIBL     ')
     D msgData         s                   like(inpText)
     D msgDataLen      s             10i 0 inz(%size(msgData))
     D msgType         s             10    inz('*INFO')
     D msgStackEnt     s             10    inz('*')
     D msgStackCnt     s             10i 0 inz(3)
     D msgKey          s              4
     D msgErrStruc     s                   like(ErrStruc)

      * API error structure
     D errStruc        DS                  inz
     D  errSSize                     10i 0 inz(%len(errStruc))
     D  errSUse                      10i 0
     D  errSmsgID                     7
     D  errSResrv                     1
     D  errSData                     80

     C                   eval      msgData = inpText
     C                   eval      msgErrStruc = errStruc

     C                   Call      'QMHSNDPM'
     C                   Parm                    msgID
     C                   Parm                    msgFil
     C                   Parm                    msgData
     C                   Parm                    msgDataLen
     C                   Parm                    msgType
     C                   Parm                    msgStackEnt
     C                   Parm                    msgStackCnt
     C                   Parm                    msgKey
     C                   Parm                    msgErrStruc

     C                   Eval      errStruc = msgErrStruc

     PsndMsg           e

Thanks to Buck Calabro

Convert Date and Time Format

     H Option( *SrcStmt )
     **-- Globalariables:
     D DTS             s              8a
     D LongJul         s             17a
     D YYMD            s             17a
     **-- API error datatructure:
     D ApiError        Ds
     D  AeBytPro                     10i 0 Inz( %Size( ApiError ))
     D  AeBytAvl                     10i 0
     D  AeExcpId                      7a
     D                                1a
     D  AaExcpDta                   256a
     **-- Convert date & time:
     D CvtDtf          Pr                  ExtPgm( 'QWCCVTDT' )
     D  CdInpFmt                     10a   Const
     D  CdInpVar                     17a   Const  Options( *VarSize )
     D  CdOutFmt                     10a   Const  Options( *VarSize )
     D  CdOutVar                     17a          Options( *VarSize )
     D  CdError                   32767a          Options( *VarSize )
     C                   CallP     CvtDtf( '*YYMD'
     C                                   : '20010919180055000'
     C                                   : '*DTS'
     C                                   : DTS
     C                                   : ApiError
     C                                   )
     C                   CallP     CvtDtf( '*DTS'
     C                                   : DTS
     C                                   : '*LONGJUL'
     C                                   : LongJul
     C                                   : ApiError
     C                                   )
     C                   Return

Thanks to Carsten Flensburg


List ILE Program Information and List ILE Service Program Information


     **  This program will find all places that a bound module is called.
     **    (by searching all ILE programs in the user libraries)
     **         Scott Klement,  May 7, 1997

     FQSYSPRT   O    F   80        PRINTER OFLIND(*INOF)

     D EC_Escape       PR
     D   When                        60A   const
     D   CallStackCnt                10I 0 value
     D   ErrorCode                32766A   options(*varsize)

      * List ILE program information API
     D QBNLPGMI        PR                  ExtPgm('QBNLPGMI')
     D   UsrSpc                      20A   const
     D   Format                       8A   const
     D   PgmName                     20A   const
     D   Errors                   32766A   options(*varsize)

      * List ILE service program information API
     D QBNLSPGM        PR                  ExtPgm('QBNLSPGM')
     D   UsrSpc                      20A   const
     D   Format                       8A   const
     D   SrvPgm                      20A   const
     D   Errors                   32766A   options(*varsize)

      * Create User Space API
     D QUSCRTUS        PR                  ExtPgm('QUSCRTUS')
     D   UsrSpc                      20A   const
     D   ExtAttr                     10A   const
     D   InitSize                    10I 0 const
     D   InitVal                      1A   const
     D   PublicAuth                  10A   const
     D   Text                        50A   const
     D   Replace                     10A   const
     D   Errors                   32766A   options(*varsize)

      * Retrieve pointer to user space API
     D QUSPTRUS        PR                  ExtPgm('QUSPTRUS')
     D   UsrSpc                      20A   const
     D   Pointer                       *

      * API error code structure
     D dsEC            DS
     D  dsECBytesP                   10I 0 inz(%size(dsEC))
     D  dsECBytesA                   10I 0 inz(0)
     D  dsECMsgID                     7A
     D  dsECReserv                    1A
     D  dsECMsgDta                  240A

      *  List API generic header structure
     D p_Header        S               *
     D dsLH            DS                   BASED(p_Header)
     D*                                     Filler
     D   dsLHFill1                  103A
     D*                                     Status (I=Incomplete,C=Complete
     D*                                             F=Partially Complete)
     D   dsLHStatus                   1A
     D*                                     Filler
     D   dsLHFill2                   12A
     D*                                     Header Offset
     D   dsLHHdrOff                  10I 0
     D*                                     Header Size
     D   dsLHHdrSiz                  10I 0
     D*                                     List Offset
     D   dsLHLstOff                  10I 0
     D*                                     List Size
     D   dsLHLstSiz                  10I 0
     D*                                     Count of Entries in List
     D   dsLHEntCnt                  10I 0
     D*                                     Size of a single entry
     D   dsLHEntSiz                  10I 0

      * PGML0100 format: modules in program
      * SPGL0100 format: modules in service program
      * (these fields are the same in both APIs)
     D p_Entry         S               *
     D dsPgm           DS                  based(p_Entry)
     D   dsPgm_Pgm                   10A
     D   dsPgm_PgmLib                10A
     D   dsPgm_Module                10A
     D   dsPgm_ModLib                10A
     D   dsPgm_SrcF                  10A
     D   dsPgm_SrcLib                10A
     D   dsPgm_SrcMbr                10A
     D   dsPgm_Attrib                10A
     D   dsPgm_CrtDat                13A
     D   dsPgm_SrcDat                13A

     D peModule        S             10A
     D Entry           S             10I 0

     c     *entry        plist
     c                   parm                    peModule

     c                   except    PrtHeader
      * Create a user space to stuff module info into
     c                   callp     QUSCRTUS('MODULES   QTEMP': 'USRSPC':
     c                                1024*1024: x'00': '*ALL':
     c                                'List of modules': '*YES': dsEC)
     c                   if        dsECBytesA > 0
     c                   callp     EC_Escape('Calling QUSCRTUS API':3:dsEC)
     c                   endif
     c                   callp     QUSPTRUS('MODULES   QTEMP': p_Header)
      * List all ILE programs modules to space
     c                   callp     QBNLPGMI('MODULES   QTEMP': 'PGML0100':
     c                                '*ALL      *ALLUSR': dsEC)
     c                   if        dsECBytesA > 0
     c                   callp     EC_Escape('Calling QBNLPGMI API':3:dsEC)
     c                   endif
      * List occurrances of our module
     c                   eval      p_Entry = p_Header + dsLHLstOff

     c                   for       Entry = 1 to dsLHEntCnt
     c                   if        dsPgm_Module = peModule
     c                   except    PrtModule
     c                   endif
     c                   eval      p_Entry = p_Entry + dsLHEntSiz

     c                   endfor
      * List all ILE service program modules to space
     c                   callp     QBNLSPGM('MODULES   QTEMP': 'SPGL0100':
     c                                '*ALL      *ALLUSR': dsEC)
     c                   if        dsECBytesA > 0
     c                   callp     EC_Escape('Calling QBNLSPGM API':3:dsEC)
     c                   endif
      * List occurrances of our module
     c                   eval      p_Entry = p_Header + dsLHLstOff

     c                   for       Entry = 1 to dsLHEntCnt
     c                   if        dsPgm_Module = peModule
     c                   except    PrtModule
     c                   endif
     c                   eval      p_Entry = p_Entry + dsLHEntSiz
     c                   endfor
      * And that's about the size of it
     c                   eval      *inlr = *on

     OQSYSPRT   E            PrtHeader         2  3
     O                       *DATE         Y     10
     O                                           +3 'Listing of programs'
     O                                           +1 'that use module'
     O                       peModule            +1
     O                                           75 'Page'
     O                       PAGE          Z     80

     O          E            PrtModule         2  3
     O                       dsPgm_Pgm           10
     O                       dsPgm_PgmLib        +1
     O                       dsPgm_SrcF          +1
     O                       dsPgm_SrcLib        +1
     O                       dsPgm_SrcMbr        +1
     O                       dsPgm_SrcDat        +1

      * Send back an escape message based on an API error code DS
     P EC_Escape       B
     D EC_Escape       PI
     D   When                        60A   const
     D   CallStackCnt                10I 0 value
     D   ErrorCode                32766A   options(*varsize)

      * Send Program Message API
     D QMHSNDPM        PR                  ExtPgm('QMHSNDPM')
     D   MessageID                    7A   Const
     D   QualMsgF                    20A   Const
     D   MsgData                    256A   Const
     D   MsgDtaLen                   10I 0 Const
     D   MsgType                     10A   Const
     D   CallStkEnt                  10A   Const
     D   CallStkCnt                  10I 0 Const
     D   MessageKey                   4A
     D   Errors                       1A

      * API error code (passed from caller)
     D p_EC            S               *
     D dsEC            DS                  based(p_EC)
     D  dsECBytesP                   10I 0
     D  dsECBytesA                   10I 0
     D  dsECMsgID                     7A
     D  dsECReserv                    1A
     D  dsECMsgDta                  240A

      * API error code (no error handling requested)
     D dsNullError     DS
     D  dsNullError0                 10I 0 inz(0)

     D MsgDtaLen       S             10I 0
     D MsgKey          S              4A

     c                   eval      p_EC = %addr(ErrorCode)
     c                   if        dsECBytesA <= 16
     c                   eval      MsgDtaLen = 0
     c                   else
     c                   eval      MsgDtaLen = dsECBytesA - 16
     c                   endif

     C* diagnostic msg tells us when the error occurred in our pgm
     c                   callp     QMHSNDPM('CPF9897': 'QCPFMSG   *LIBL':
     c                               When: %Len(%trimr(when)): '*DIAG':
     c                               '*': 1:  MsgKey: dsNullError)

     C* send back actual error from API
     c                   callp     QMHSNDPM(dsECMsgID: 'QCPFMSG   *LIBL':
     c                               dsECMsgDta: MsgDtaLen: '*ESCAPE':
     c                               '*': CallStackCnt: MsgKey:
     c                               dsNullError)
     P                 E

Thanks to Scott Klement


I want to get some job's call stack, but the QWVRCSTK API need the Thread
identifier in JIDF0100 Format. How do I get the job thread identifier ?

A: Here's an example using the QWVRCSTK API without a specific thread identifier: The open job list API locates the most CPU consuming jobs on a system and subsequently retrieves the program currently running in that job:
** Open list APIs are located in library QGY. ** **-- Control spec: H Option( *SrcStmt: *NoDebugIo ) BndDir( 'QC2LE' ) **-- API error data structure: D ApiError Ds D AeBytPrv 10i 0 Inz( %Size( ApiError )) D AeBytAvl 10i 0 D AeExcpId 7a D 1a D AeExcpDta 128a **-- API parameters: D JlRtnRcdNbr s 10i 0 Inz( 1 ) D JlNbrFldRtn s 10i 0 Inz( %Elem( JlKeyFld )) D JlKeyFld s 10i 0 Dim( 3 ) **-- Job information: D JlJobInf Ds 512 D JbJobId 26a D JbJobUsd 10a Overlay( JbJobId: 1 ) D JbUsrUsd 10a Overlay( JbJobId: *Next ) D JbNbrUsd 6a Overlay( JbJobId: *Next ) D JbActSts 4a D JbJobTyp 1a D JbJobSubTyp 1a D JbDtaLen 10i 0 D 4a **-- Key information: D JlKeyInf Ds D KiFldNbrRtn 10i 0 D KiKeyInf 20a Dim( %Elem( JlKeyFld )) D KiFldInfLen 10i 0 Overlay( KiKeyInf : 1 ) D KiKeyFld 10i 0 Overlay( KiKeyInf : 5 ) D KiDtaTyp 1a Overlay( KiKeyInf : 9 ) D 3a Overlay( KiKeyInf : 10 ) D KiDtaLen 10i 0 Overlay( KiKeyInf : 13 ) D KiDtaOfs 10i 0 Overlay( KiKeyInf : 17 ) **-- Sort information: D JlSrtInf Ds D SiNbrKeys 10i 0 Inz( 1 ) D SiSrtInf 12a Dim( 10 ) D SiKeyFldOfs 10i 0 Overlay( SiSrtInf : 1 ) D SiKeyFldLen 10i 0 Overlay( SiSrtInf : 5 ) D SiKeyFldTyp 5i 0 Overlay( SiSrtInf : 9 ) D SiSrtOrd 1a Overlay( SiSrtInf : 11 ) D SiRsv 1a Overlay( SiSrtInf : 12 ) **-- List information: D JlLstInf Ds D LiRcdNbrTot 10i 0 D LiRcdNbrRtn 10i 0 D LiHandle 4a D LiRcdLen 10i 0 D LiInfSts 1a D LiDts 13a D LiLstSts 1a D 1a D LiInfLen 10i 0 D LiRcd1 10i 0 D 40a **-- Selection information: D JlSltInf Ds D SiJobNam 10a Inz( '*ALL' ) D SiUsrNam 10a Inz( '*ALL' ) D SiJobNbr 6a Inz( '*ALL' ) D SiJobTyp 1a Inz( '*' ) D 1a D SiOfsPriSts 10i 0 Inz( 60 ) D SiNbrPriSts 10i 0 Inz( 0 ) D SiOfsActSts 10i 0 Inz( 70 ) D SiNbrActSts 10i 0 Inz( 0 ) D SiOfsJbqSts 10i 0 Inz( 78 ) D SiNbrJbqSts 10i 0 Inz( 0 ) D SiOfsJbqNam 10i 0 Inz( 88 ) D SiNbrJbqNam 10i 0 Inz( 0 ) ** D SiPriSts 10a Dim( 1 ) D SiActSts 4a Dim( 2 ) D SiJbqSts 10a Dim( 1 ) D SiJbqNam 20a Dim( 1 ) **-- Job information key fields: D JbKeyDta Ds D JbPrcUniTim 20u 0 D JbPrcUniPct 10i 0 D JbPrcUniTimE 20u 0 **-- General return data: D JlGenDta Ds D GdBytRtn 10i 0 D GdBytAvl 10i 0 D GdElpTim 20u 0 D 16a **-- Global variables: D Ix s 5i 0 D Msg s 256a Varying D MsgKey s 4a D PgmNam_q s 20a **-- API constants: D JOB_RESET_STAT c '1' D JOB_KEEP_STAT c '0' **-- Open list of jobs: D LstJobs Pr ExtPgm( 'QGYOLJOB' ) D LjRcvVar 65535a Options( *VarSize ) D LjRcvVarLen 10i 0 Const D LjFmtNam 8a Const D LjRcvVarDfn 65535a Options( *VarSize ) D LjRcvDfnLen 10i 0 Const D LjLstInf 80a D LjNbrRcdRtn 10i 0 Const D LjSrtInf 1024a Const Options( *VarSize ) D LjJobSltInf 1024a Const Options( *VarSize ) D LjJobSltLen 10i 0 Const D LjNbrFldRtn 10i 0 Const D LjKeyFldRtn 10i 0 Const Options( *VarSize ) D Dim( 32 ) D LjError 1024a Options( *VarSize ) ** D LjJobSltFmt 8a Const Options( *NoPass ) ** D LjResStc 1a Const Options( *NoPass ) D LjGenRtnDta 32a Options( *NoPass:*VarSize) D LjGenRtnDtaLn 10i 0 Const Options( *NoPass ) **-- Get list entry: D GetLstEnt Pr ExtPgm( 'QGYGTLE' ) D GlRcvVar 65535a Options( *VarSize ) D GlRcvVarLen 10i 0 Const D GlHandle 4a Const D GlLstInf 80a D GlNbrRcdRtn 10i 0 Const D GlRtnRcdNbr 10i 0 Const D GlError 1024a Options( *VarSize ) **-- Close list: D CloseLst Pr ExtPgm( 'QGYCLST' ) D ClHandle 4a Const D ClError 1024a Options( *VarSize ) **-- Copy memory: D MemCpy Pr * ExtProc( '_MEMMOVE' ) D pOutMem * Value D pInpMem * Value D iMemSiz 10u 0 Value **-- Delay job: D sleep Pr 10i 0 ExtProc( 'sleep' ) D seconds 10u 0 Value **-- Get job program: D GetJobPgmX Pr 20a D PxJobId 26a Const **-- Mainline: C* Eval SiNbrActSts = SiNbrActSts + 1 C* Eval SiActSts(SiNbrActSts) = 'HLD ' ** C Eval JlKeyFld(1) = 312 C Eval JlKeyFld(2) = 314 C Eval JlKeyFld(3) = 315 ** C Eval SiNbrKeys = 1 C Eval SiKeyFldOfs(1) = 49 C Eval SiKeyFldLen(1) = 4 C Eval SiKeyFldTyp(1) = 0 C Eval SiSrtOrd(1) = '2' C Eval SiRsv(1) = x'00' ** C CallP LstJobs( JlJobInf C : %Size( JlJobInf ) C : 'OLJB0300' C : JlKeyInf C : %Size( JlKeyInf ) C : JlLstInf C : 0 C : JlSrtInf C : JlSltInf C : %Size( JlSltInf ) C : JlNbrFldRtn C : JlKeyFld C : ApiError C : 'OLJS0100' C : JOB_RESET_STAT C : JlGenDta C : %Size( JlGenDta ) C ) ** C CallP sleep( 30 ) ** C CallP LstJobs( JlJobInf C : %Size( JlJobInf ) C : 'OLJB0300' C : JlKeyInf C : %Size( JlKeyInf ) C : JlLstInf C : 1 C : JlSrtInf C : JlSltInf C : %Size( JlSltInf ) C : JlNbrFldRtn C : JlKeyFld C : ApiError C : 'OLJS0100' C : JOB_KEEP_STAT C : JlGenDta C : %Size( JlGenDta ) C ) ** C If AeBytAvl = *Zero ** C DoW LiLstSts <> '2' Or C LiRcdNbrTot > JlRtnRcdNbr ** C If JbJobTyp <> 'X' C ExSr GetKeyDta C ExSr GetJobPgm C EndIf ** C Eval JlRtnRcdNbr = JlRtnRcdNbr + 1 ** C CallP GetLstEnt( JlJobInf C : %Size( JlJobInf ) C : LiHandle C : JlLstInf C : 1 C : JlRtnRcdNbr C : ApiError C ) ** C If JbPrcUniTimE <= *Zero C Leave C EndIf ** C EndDo ** C CallP CloseLst( LiHandle C : ApiError C ) ** C EndIf ** C Eval *InLr = *On ** C Return **-- Get Key Field Data: C GetKeyDta BegSr ** C Clear JbKeyDta ** C For Ix = 1 To KiFldNbrRtn ** C Select C When KiKeyFld(Ix)= 312 C CallP MemCpy( %Addr( JbPrcUniTim ) C : %Addr( JlJobInf ) + C KiDtaOfs(Ix) C : KiDtaLen(Ix) C ) ** C When KiKeyFld(Ix)= 314 C CallP MemCpy( %Addr( JbPrcUniPct ) C : %Addr( JlJobInf ) + C KiDtaOfs(Ix) C : KiDtaLen(Ix) C ) ** C When KiKeyFld(Ix)= 315 C CallP MemCpy( %Addr( JbPrcUniTimE ) C : %Addr( JlJobInf ) + C KiDtaOfs(Ix) C : KiDtaLen(Ix) C ) C EndSl ** C EndFor ** C EndSr **-- Get job program: C GetJobPgm BegSr ** C Eval PgmNam_q = GetJobPgmX( JbJobId ) ** C EndSr **-- Get job program: P GetJobPgmX B Export D Pi 20a D PxJobId 26a Const **-- API error data structure: D ApiError Ds D AeBytPrv 10i 0 Inz( %Size( ApiError )) D AeBytAvl 10i 0 D AeExcpId 7a D 1a D AeExcpDta 128a **-- Retrieve call stack API parameters: D CsRcvVar Ds D CsBytRtn 10i 0 D CsBytAvl 10i 0 D CsNbrStkE 10i 0 D CsOfsStkE 10i 0 D CsNbrEntRtn 10i 0 D CsThrId 8a D CsInfSts 1a D CsCalStk 32767a ** D CsCalStkE Ds Based( pCalStkE ) D CsStkEntLen 10i 0 D CsOfsStmIds 10i 0 D CsNbrStmIds 10i 0 D CsOfsPrcNam 10i 0 D CsLenPrcNam 10i 0 D CsRqsLvl 10i 0 D CsPgmNam 10a D CsPgmLib 10a D CsMiInst 10i 0 D CsModNam 10a D CsModLib 10a D CsCtlBdy 1a D CsRsv 3a D CsActGrpNbr 10u 0 D CsActGrpNam 10a D CsAddInf 4096a ** D CsStmIds 10a Dim( 16 ) D CsPrcNam 512a ** D CsJobId Ds D JiJobId 26a D JiJobNam 10a Overlay( JiJobId: 1 ) D JiUsrNam 10a Overlay( JiJobId: *Next ) D JiJobNbr 6a Overlay( JiJobId: *Next ) D JiIntId 16a D JiRsv 2a Inz( *Allx'00' ) D JiThrInd 10i 0 Inz( 2 ) D JiThrId 8a Inz( *Allx'00' ) ** D RtvCalStk Pr ExtPgm( 'QWVRCSTK' ) D RcRcvVar 32767a D RcRcvVarLen 10i 0 Const D RcRcvInfFmt 8a Const D RcJobId 56a Const D RcJobIdFmt 8a Const D RcError 32767a Options( *VarSize ) ** D EntNbr s 5u 0 ** **-- Mainline: ** C Eval JiJobId = PxJobId ** C CallP RtvCalStk( CsRcvVar C : %Size( CsRcvVar ) C : 'CSTK0100' C : CsJobId C : 'JIDF0100' C : ApiError C ) ** C If AeBytAvl = *Zero C Eval pCalStkE = %Addr( CsRcvVar ) + C CsOfsStkE ** C For EntNbr = 1 to CsNbrEntRtn ** C If EntNbr = 1 ** C Eval CsStmIds = *Blanks C Eval CsPrcNam = *Blanks ** C If CsOfsStmIds > *Zero C CallP MemCpy( %Addr( CsStmIds ) C : %Addr( CsCalStkE ) + C CsOfsStmIds C : CsNbrStmIds * %Size( CsStmIds ) C ) C EndIf ** C If CsOfsPrcNam > *Zero C CallP MemCpy( %Addr( CsPrcNam ) C : %Addr( CsCalStkE ) + C CsOfsPrcNam C : CsLenPrcNam C ) C EndIf ** C Leave C EndIf ** C If EntNbr < CsNbrEntRtn C Eval pCalStkE = PCalStkE + CsStkEntLen C EndIf ** C EndFor C EndIf ** C Return CsPgmNam + CsPgmLib ** P GetJobPgmX E Thanks to Carsten Flensburg

Retrieve System Value

     h dftactgrp(*no) actgrp('QILE') bnddir('QC2LE')

      * Prototype for QWCRSVAL API - Retrieve QUSRLIBL
     d QWCRSVALU       pr                  ExtPgm('QWCRSVAL')
     d  p_Rcvr                             Like(u_Rcvr)
     d  p_RcvrLngth                        Like(u_RcvrLngth)
     d  p_NbrToRtv                         Like(u_NbrToRtv)
     d  p_SysVal                           Like(u_SysVal)
     d  p_Error                            Like(u_APIError)

      * Prototype for QWCRSVAL API - Retrieve QSYSLIBL
     d QWCRSVALS       pr                  ExtPgm('QWCRSVAL')
     d  p_Rcvr                             Like(s_Rcvr)
     d  p_RcvrLngth                        Like(s_RcvrLngth)
     d  p_NbrToRtv                         Like(s_NbrToRtv)
     d  p_SysVal                           Like(s_SysVal)
     d  p_Error                            Like(s_APIError)

     d #QUSRLIBL       pr           250a
     d #QSYSLIBL       pr           150a

     d                 ds
     d UsrLibl                      250
     d SysLibl                      150

     d USRLIBLDS       ds                  inz
     d  u_Rcvr                      278a
     d  u_RcvrLngth                   9b 0 inz(%len(u_Rcvr))
     d  u_NbrToRtv                    9b 0 inz(1)
     d  u_SysVal                     10a   inz('QUSRLIBL')
     d  u_APIError                    1

     d SYSLIBLDS       ds                  inz
     d  s_Rcvr                      178a
     d  s_RcvrLngth                   9b 0 inz(%len(s_Rcvr))
     d  s_NbrToRtv                    9b 0 inz(1)
     d  s_SysVal                     10a   inz('QSYSLIBL')
     d  s_APIError                    1

      * Program Mainline

      * #QUSRLIBL  - Retrieve the QUSRLIBL library list
     p #QUSRLIBL       b                   Export
     d #QUSRLIBL       pi           250a

     d DS_SysValTbl    ds                  inz
     d  d_ValsRtn                     9b 0
     d  d_Offset                      9b 0
     d  d_SysVal                     10a
     d  d_ValType                     1a
     d  d_InfoSts                     1a
     d  d_DtaLngth                    9b 0
     d  d_Data                      250a

       reset u_APIError;
       qwcrsvalu(u_Rcvr: u_RcvrLngth: u_NbrToRtv: u_SysVal: u_APIError);
       ds_SysValTbl = u_Rcvr;
       return %subst(d_Data:1:d_DtaLngth);
     p #QUSRLIBL       e

      * #QSYSLIBL  - Retrieve the QSYSLIBL library list
     p #QSYSLIBL       b                   Export
     d #QSYSLIBL       pi           150a

     d DS_SysValTbl    ds                  inz
     d  d_ValsRtn                     9b 0
     d  d_Offset                      9b 0
     d  d_SysVal                     10a
     d  d_ValType                     1a
     d  d_InfoSts                     1a
     d  d_DtaLngth                    9b 0
     d  d_Data                      150a

       reset s_APIError;
       qwcrsvals(s_Rcvr: s_RcvrLngth: s_NbrToRtv: s_SysVal: s_APIError);
       ds_SysValTbl = s_Rcvr;
       return %subst(d_Data:1:d_DtaLngth);
     p #QSYSLIBL       e

Thanks to Tom H.

And one more ... D QWCRSVALD PR EXTPGM('QWCRSVAL') D QRSYS LIKE(QRSYSD) D QRLEN LIKE(QRLEND) D QRNUM LIKE(QRNUMD) D QRVAR LIKE(QRVARD) D QRERR 200A OPTIONS(*VARSIZE) CONST D* D* system value reciver: date format D QRTVFMTD DS D QRSYSD 31A INZ(' ') Receiver variable D QRLEND 10I 0 INZ(%len(QRSYSD)) Length recevr var D QRNUMD 10I 0 INZ(1) Number of sys val D QRVARD 10A INZ('QDATFMT') System value name D* D QFORMAT DS D QNBR 10I 0 INZ(0) Number of sys val D QOFF 10I 0 INZ(0) Offset to sys val D QVAL 5000A INZ(' ') System value info D* D SYSDATA DS D SYSVAL 10A INZ(' ') D SYSTYP 1A INZ(' ') D SYSSTA 1A INZ(' ') D SYSLEN 10I 0 INZ(0) D SYSDAT 3000A INZ(' ') D* D ERRC0100 DS D ERRBYT 10I 0 INZ(0) Bytes provided D ERRAVAL 10I 0 INZ(0) Bytes available D ERREXC 7A INZ(' ') Exception ID D ERRRES 1A INZ(' ') Reserved D ERROUT 84A INZ(' ') Output /FREE // get QDATFMT system value using API's CALLP QWCRSVALD (QRSYSD : QRLEND : QRNUMD : QRVARD : ERRC0100); EVAL QFORMAT = QRSYSD; EVAL SYSDATA = QVAL; /END-FREE Thanks Joe M. Wesson

Get Profile Handle
I am developing a web front end using ASP on W2K. I would like the user to sign in using AS/400 UserId and PWD. Is there a way I can pass those to an API which will verify on the AS/400 and confirm if the userid and pwd is correct ??
**** copy of QUSEC error code data structure from QSYSINC/QRPGLESRC D/Copy QSYSINC/QRPGLESRC,QUSEC * C Call 'QSYGETPH' C Parm WKUser C Parm WKPassword C Parm ProfileHandle C Parm QUSEC * C If QUSBAVL > 0 C Eval Error = *ON C Endif * Call with userprofile and password. If it is valid (QUSBAVL = 0) then it returns with a 12 byte profile handle which can be used to set the server job to run as the user or just ignored. If it is invalid the QUSEC data structure will contain error information which is explained in the system API manual
The API with CLLE: V5R3: PGM PARM(&Usr &Pwd &Error) */ DCL &Usr *CHAR LEN(10) DCL &Pwd *CHAR LEN(10) DCL &Err *CHAR LEN(1024) DCL &PwdLen *INT Len(4) VALUE(10) DCL &PwdCcsid *INT Len(4) VALUE(0) /* job CCSID */ DCL VAR(&ERROR) TYPE(*CHAR) LEN(5) DCL VAR(&PH) TYPE(*CHAR) LEN(12) CHGVAR VAR(&ERROR) VALUE(' ') */ CALL PGM(QSYGETPH) PARM(&USR &PWD &PH &ERR &PwdLen &PwdCcsid) MONMSG MSGID(CPF22E2 CPF22E3 CPF22E4 CPF22E5 + CPF2203 CPF2204) EXEC(DO) CHGVAR VAR(&ERROR) VALUE('Error') ENDDO RETURN ENDPGM Prior to V5R3: DCL &PwdLen *CHAR Len(4) DCL &PwdCcsid *CHAR Len(4) CHGVAR %BIN(&PwdLen) 10 CHGVAR %BIN(&PwdCcsid) 37 /* CCSID 37 */ Thanks to Bryan Yates, Pete Helgren and Barbara Morris

Move Program Messages & Resend Escape Message
To disallow *PUBLIC to see messages in a message queue but still be able to send messages to it, set *PUBLIC authority to *CHANGE and remove read data authority. - And check that the user profile relating to the message queue has *ALL authority to avoid problems on that account. Here's a small CL program that will do it for a single user profile message queue:
/*-- Compile instructions: ------------------------------------------*/ /*-- USRPRF(*OWNER) and transfer ownership to QSECOFR */ /*-- Parameters: ---------------------------------------------------*/ Pgm &UsrPrf Dcl &UsrPrf *Char 10 /*-- Global variables: ---------------------------------------------*/ Dcl &MsgQ *Char 10 Dcl &MsgQlib *Char 10 Dcl &UsrPrf *Char 10 Dcl &MsgKey *Char 4 ' ' Dcl &ToCalStkE *Char 38 /*-- Global monitor: -----------------------------------------------*/ MonMsg CPF0000 *None GoTo Error /*-- Message API parameter inz: ------------------------------------*/ ChgVar %Bin( &ToCalStkE 1 4 ) 1 ChgVar %Sst( &ToCalStkE 5 20 ) '*NONE *NONE ' ChgVar %Bin( &ToCalStkE 25 4 ) 10 ChgVar %Sst( &ToCalStkE 29 10 ) '*PGMBDY ' /*-- Set user message queue authority: -----------------------------*/ If ( &UsrPrf = ' ' ) Do ChgVar &UsrPrf '*CURRENT' EndDo Else Do ChkObj &UsrPrf *USRPRF EndDo RtvUsrPrf &UsrPrf MsgQ( &MsgQ ) MsgQlib( &MsgQlib ) + RtnUsrPrf( &UsrPrf ) AlcObj (( &MsgQlib/&MsgQ *MSGQ *EXCL )) Wait( 0 ) RvkObjAut &MsgQlib/&MsgQ *MSGQ + User( *ALL ) Aut( *ALL ) GrtObjAut &MsgQlib/&MsgQ *MSGQ + User( *PUBLIC ) Aut( *OBJOPR *ADD *UPD *DLT *EXECUTE ) GrtObjAut &MsgQlib/&MsgQ *MSGQ + User( &UsrPrf ) Aut( *ALL ) DlcObj (( &MsgQlib/&MsgQ *MSGQ *EXCL )) /*-- Return: -------------------------------------------------------*/ Return: Call QMHMOVPM ( &MsgKey + '*COMP' + x'00000001' + '*PGMBDY ' + x'00000001' + x'0000000000000008' + ) Return /*-- Error routines: -----------------------------------------------*/ Error: Call QMHMOVPM ( &MsgKey + '*DIAG' + x'00000001' + '*PGMBDY ' + x'00000001' + x'0000000000000008' + ) Call QMHRSNEM ( &MsgKey + x'0000000000000008' + &ToCalStkE + x'00000026' + 'RSNM0100' + '* ' + x'00000000' + ) EndPgm: EndPgm Thanks to Carsten Flensburg


Review documentation for the Retrieve Nonprogram Message Queue Attributes
(QMHRMQAT) API. The following CLP might help illustrate the documentation:

	   dcl   &ErrCod       *char    8   value( x'0000000000000000' )
	   dcl   &qMQ          *char   20
	   dcl   &rcvvar       *char  150
	   dcl   &MQfull       *char   10
	   dcl   &CurSiz       *dec  (  9 0 )

	   chgvar    &qMQ       ( 'JIMD      ' *cat '*LIBL     ' )

	   call QMHRMQAT         ( +
	                           &rcvvar      +
	                           x'00000096'  +
	                           'RMQA0100'   +
	                           &qMQ         +
	                           &ErrCod      +

	   chgvar    &MQFull       %sst( &RcvVar  141  10 )
	   chgvar    &CurSiz       %bin( &RcvVar   33   4 )


Thanks to Tom Liotta


List Job

      * List jobs API
     D QUSLJOB         PR                  ExtPgm('QUSLJOB')
     D   UsrSpc                      20A   const
     D   Format                       8A   const
     D   QualJob                     26A   const
     D   Status                      10A   const
     D   ErrorCode                32767A   options(*varsize)
     D   JobType                      1A   const options(*nopass)
     D   NumFldsToRtn                10I 0 const options(*nopass)
     D   FldsToRtn                   10I 0 const options(*nopass)
      * Create User Space API
     D QUSCRTUS        PR                  ExtPgm('QUSCRTUS')
     D   UserSpc                     20A   const
     D   ExtAttr                     10A   const
     D   InitSize                    10I 0 const
     D   InitVal                      1A   const
     D   PublicAuth                  10A   const
     D   Text                        50A   const
     D   Replace                     10A   const
     D   ErrorCode                32766A   options(*varsize)
      * retrieve pointer to user space API
     D QUSPTRUS        PR                  ExtPgm('QUSPTRUS')
     D   UserSpc                     20A   CONST
     D   Pointer                       *
      * API error code structure
      * (we inz to 0 to cause the APIs to return errors using normal
      *  OS/400 error handling)
     D dsEC            DS
     D  dsECBytesP                   10I 0 INZ(0)
     D  dsECBytesA                   10I 0 INZ(0)

     D* List API header data structure
     D p_UsrSpc        S               *
     D dsLH            DS                   BASED(p_UsrSpc)
     D*                                     Filler
     D   dsLHFill1                  103A
     D*                                     Status (I=Incomplete,C=Complete
     D*                                             F=Partially Complete)
     D   dsLHStatus                   1A
     D*                                     Filler
     D   dsLHFill2                   12A
     D*                                     Header Offset
     D   dsLHHdrOff                  10I 0
     D*                                     Header Size
     D   dsLHHdrSiz                  10I 0
     D*                                     List Offset
     D   dsLHLstOff                  10I 0
     D*                                     List Size
     D   dsLHLstSiz                  10I 0
     D*                                     Count of Entries in List
     D   dsLHEntCnt                  10I 0
     D*                                     Size of a single entry
     D   dsLHEntSiz                  10I 0

     D p_Job           S               *
     D dsJob           DS                  based(p_Job)
     D   dsJobName                   10A
     D   dsJobUser                   10A
     D   dsJobNbr                     6A
     D   dsJobIntID                  16A
     D   dsJobSts                    10A
     D   dsJobType                    1A
     D   dsJobSubType                 1A
     D   dsJobReserv                  2A
     D   dsJobInfSts                  1A
     D   dsJobReserv2                 3A
     D   dsJobNbrFlds                10I 0
     D   dsJobKeyAry                  1A

     D p_KeyAry        S               *
     D dsKeyAry        DS                  based(p_KeyAry)
     D   dsKA_Len                    10I 0
     D   dsKA_Field                  10I 0
     D   dsKA_Type                    1A
     D   dsKA_Reserv                  3A
     D   dsKA_DtaLen                 10I 0
     D   dsKA_Data                   20A

     D JOBLIST         C                   'JOBLIST   QTEMP'
     D SBSDNAME        C                   1906

     D peSbsName       S             10A
     D msg             s             50A
     D Ent             s             10I 0

      *  Check parms
     C     *entry        plist
     c                   parm                    peSbsName

     c                   if        %parms < 1
     c                   eval      msg = 'You need to pass a subsystem name'
     c                   dsply                   msg
     c                   eval      *inlr = *on
     c                   return
     c                   endif

      *  Create a user space
     c                   callp     QUSCRTUS(JOBLIST: 'USRSPC':
     c                                %size(dsJob) * 1000: *Blank:
     c                                '*ALL': 'List of jobs on system':
     c                                '*YES': dsEC)

      *  List jobs to the user space
     c                   callp     QUSLJOB(JOBLIST: 'JOBL0200':
     c                               '*ALL      *ALL      *ALL': '*ACTIVE':
     c                               dsEC: '*': 1:  SBSDNAME)

      *  Read entries in user space
     c                   callp     QUSPTRUS(JOBLIST: p_UsrSpc)

     c                   for       Ent = 0 to (dsLHEntCnt - 1)

     c                   eval      p_Job = p_UsrSpc + dsLHLstOff +
     c                                (dsLhEntSiz * Ent)
     c                   eval      p_KeyAry = %addr(dsJobKeyAry)

     c                   if        dsKA_Field <> SBSDNAME
     c                              or dsKA_Type <> 'C'
     c                              or dsKA_DtaLen <> 20
     c                   eval      msg = 'Unknown key in key array'
     c                   dsply                   msg
     c                   leave
     c                   endif

      ** only print jobs in requested subsystem.
      ** and ignore subsystem monitor jobs.
     c                   if        %subst(dsKA_Data: 1: 10) = peSbsName
     c                               and dsJobType <> 'M'
     c                   eval      msg = %trim(dsJobNbr) + '/' +
     c                                   %trim(dsJobUser) + '/' +
     c                                   %trim(dsJobName)
     c     msg           dsply
     c                   endif

     c                   endfor

     c                   eval      msg = 'Hit ENTER when done'
     c                   dsply                   msg
     c                   eval      *inlr = *on

Thanks to Scott Klement


Retrieve Subsystem Information

	DCL &ERROR *CHAR 8 (X'0000000000000000')
	             CHGVAR     VAR(%BIN(&LEN)) VALUE('100')
	             CALL       PGM(QWDRSBSD) PARM(&SPACE &LEN SBSI0100 +
	                          &SBSLIB &ERROR)
	             CHGVAR     VAR(&NBR) VALUE(%SST(&SPACE 73 4))
	             CHGVAR     VAR(&TOT) VALUE(%BIN(&NBR))
	             CHGVAR     VAR(&ACT) VALUE(%SST(&SPACE 29 10))
	                          number of jobs active in ' || &SBS *BCAT +
	                          'is ' || &TOT || ' & the sbs is ' || &ACT)

	CMD        PROMPT('Number of Jobs in Subsystem')
	             PROMPT('Subsystem Name')
	             PROMPT('Library Name')



Search System Directory

     **-- Header specifications:  ----------------------------------**
     H NoMain  Option( *SrcStmt )
     **-- System Info Data Structure:  -----------------------------**
     D PgmSts         SDs
     D  PsJobUsr                     10a   Overlay( PgmSts: 254 )
     D  PsCurUsr                     10a   Overlay( PgmSts: 358 )
     **-- Get user SMTP address:  ----------------------------------**
     D GetSmtpAddr     Pr           321a
     D  PxUser                       10a
     D  PxAddr                        8a   Options( *NoPass )
     **-- Get user SMTP address:  ----------------------------------**
     P GetSmtpAddr     B                   Export
     D                 Pi           321a
     D  PxUser                       10a
     D  PxAddr                        8a   Options( *NoPass )
     **-- API error data structure:  -------------------------------**
     D ApiError        Ds
     D  AeBytPrv                     10i 0 Inz( %Size( ApiError ))
     D  AeBytAvl                     10i 0 Inz
     D  AeMsgId                       7a
     D                                1a
     D  AeMsgDta                    128a
     **-- Search directory parameters:  ----------------------------**
     D Sreq0100        Ds
     D  SrCcsId                      10i 0 Inz( 0 )
     D  SrChrSet                     10i 0 Inz
     D  SrCodPag                     10i 0 Inz
     D  SrWldCrd                      4a   Inz
     D  SrCvtRcv                      1a   Inz( '0' )
     D  SrSchDta                      1a   Inz( '0' )
     D  SrRunVfy                      1a   Inz( '1' )
     D  SrConHdl                      1a   Inz( '0' )
     D  SrRscHdl                     16a   Inz
     D  SrSrqFmt                      8a   Inz( 'SREQ0101' )
     D  SrSrqOfs                     10i 0 Inz( 110 )
     D  SrSrqNbrElm                  10i 0 Inz
     D  SrRtnFmt                      8a   Inz( 'SREQ0103' )
     D  SrRtnOfs                     10i 0 Inz( 100 )
     D  SrRtnNbrElm                  10i 0 Inz( 1 )
     D  SrRcvFmt                      8a   Inz( 'SRCV0101' )
     D  SrRcvNbrElm                  10i 0 Inz( 1 )
     D  SrUsrFmt                      8a   Inz( 'SRCV0111' )
     D  SrOrdFmt                      8a   Inz
     D  SrOrdRtnOpt                   1a   Inz( '0' )
     D                                3a
     D  Sr0103                             Like( Sreq0103 )
     D  Sr0101                             Like( Sreq0101 )
     D Sreq0101        Ds                  Inz
     D  S1Entry                            Dim( 2 )
     D  S1EntLen                     10i 0 Inz( %Size( S1Entry ))
     D                                     Overlay( S1Entry: 1 )
     D  S1CmpVal                      1a   Inz( '1' )
     D                                     Overlay( S1Entry: *Next )
     D  S1FldNam                     10a   Overlay( S1Entry: *Next )
     D  S1PrdId                       7a   Inz( '*IBM' )
     D                                     Overlay( S1Entry: *Next )
     D  S1DtaCas                      1a   Overlay( S1Entry: *Next )
     D                                1a   Overlay( S1Entry: *Next )
     D  S1ValLen                     10i 0 Inz( %Size( S1ValMtc ))
     D                                     Overlay( S1Entry: *Next )
     D  S1ValMtc                     10a   Overlay( S1Entry: *Next )
     D Sreq0103        Ds
     D  S3SpcRtn                     10a   Inz( '*SMTP' )
     D Srcv0100        Ds         32767
     D  R00BytRtn                    10i 0
     D  R00OrdFldOfs                 10i 0
     D  R00UsrEntOfs                 10i 0
     D  R00DirEntNbr                 10i 0
     D  R00ConHdl                     1a
     D  R00RscHdl                    16a
     D  R00UsrMtcAry                       Like( Srcv0101 )
     D Srcv0101        Ds                  Based( pSrcv0101 )
     D  R01UsrDtaLen                 10i 0
     D  R01RtnNbrFld                 10i 0
     D Srcv0111        Ds                  Based( pSrcv0111 )
     D  R11FldNam                    10a
     D  R11PrdId                      7a
     D                                3a
     D  R11CcsId                     10i 0
     D  R11CodPag                    10i 0
     D  R11RtnFldLen                 10i 0
     D Srcv0111v       Ds                  Based( pSrcv0111v )
     D  R11RtnFld                   256a
     **-- Local constanst & variables:  ----------------------------**
     D SmtpDmn         s            256a   Varying
     D SmtpUsrId       s             64a   Varying
     D At              c                   '@'
     **-- Search directory:  ---------------------------------------**
     D SchDir          Pr                  Extpgm( 'QOKSCHD' )
     D  SdRcvVar                                 Like( Srcv0100)
     D  SdRcvVarLen                  10i 0 Const
     D  SdFmtNam                      8a   Const
     D  SdFunction                   10a   Const
     D  SdKeepTmpRsc                  1a   Const
     D  SdRqsVar                           Const Like( Sreq0100 )
     D  SdRqsVarLen                  10i 0 Const
     D  SdRqsFmtNam                   8a   Const
     D  SdError                       8a
     **-- Get SMTP address:  ---------------------------------------**
     C                   If        PxUser      = '*CURRENT'
     C                   Eval      PxUser      = PsCurUsr
     C                   EndIf
     C                   If        %Parms      = 1
     C                   Eval      SrSrqNbrElm = 1
     C                   Eval      S1ValMtc(1) = PxUser
     C                   Eval      S1FldNam(1) = 'USER   '
     C                   Else
     C                   Eval      SrSrqNbrElm = 2
     C                   Eval      S1ValMtc(1) = PxUser
     C                   Eval      S1ValMtc(2) = PxAddr
     C                   Eval      S1FldNam(1) = 'USRID  '
     C                   Eval      S1FldNam(2) = 'USRADDR'
     C                   EndIf
     C                   Eval      Sr0103      = Sreq0103
     C                   Eval      Sr0101      = Sreq0101
     C                   Callp     SchDir( Srcv0100
     C                                   : %size( Srcv0100 )
     C                                   : 'SRCV0100'
     C                                   : '*SEARCH'
     C                                   : '0'
     C                                   : Sreq0100
     C                                   : %Size( Sreq0100 )
     C                                   : 'SREQ0100'
     C                                   : ApiError
     C                                   )
     C                   If        AeBytAvl     >  0          Or
     C                             R00DirEntNbr =  0
     C                   Return    *Blanks
     C                   Else
     C                   Eval      pSrcv0101    =  %Addr( Srcv0100 ) +
     C                                             R00UsrEntOfs
     C                   Eval      pSrcv0111    =  pSrcv0101         +
     C                                             %Size( Srcv0101 )
     C                   Do        R01RtnNbrFld
     C                   Eval      pSrcv0111v   =  pSrcv0111         +
     C                                             %Size( Srcv0111 )
     C                   Select
     C                   When      R11FldNam    =  'SMTPUSRID'
     C                   Eval      SmtpUsrId    =  %Subst( R11RtnFld
     C                                                   : 1
     C                                                   : R11RtnFldLen )
     C                   When      R11FldNam    =  'SMTPDMN'
     C                   Eval      SmtpDmn      =  %Subst( R11RtnFld
     C                                                   : 1
     C                                                   : R11RtnFldLen )
     C                   EndSl
     C                   Eval      pSrcv0111    =  pSrcv0111         +
     C                                             %Size( Srcv0111 ) +
     C                                             R11RtnFldLen
     C                   EndDo
     C                   Return    SmtpUsrId +  At +  SmtpDmn
     C                   EndIf
     P GetSmtpAddr     E

Thanks to Carsten Flensburg


List Server Information

*** Use it as a guideline ***
   dcl   &NSDate      *char      7  /* NetServer start date */
   dcl   &X00         *char      1  value( x'00' )
   dcl   &a_pos       *char      4  /* Data Start Pos.-Binary */
   dcl   &InfoQual    *char     15  value( '*ALL           ' )

/* Create a *usrspc to work with... */
   call  QUSCRTUS         ( +
                            'NETS      QTEMP     '  +
                            'TMPLST    '            +
                            x'00001000'             +
                            X'00'                   +
                            '*ALL      '            +
                            'Temporary IFS space    ' +
                            '*YES      '            +
                            x'0000000000000000'     +

/* List NetServer status info into our *usrspc... */
   call  QZLSLSTI         ( +
                            'NETS      QTEMP     '  +
                            'ZLSL0400'              +
                            &InfoQual               +
                            x'0000000000000000'     +

/* Get the starting position of the list from the header... */
   call  QUSRTVUS         ( +
                            'NETS      QTEMP     '  +
                            x'00000004'             +
                            &a_pos                  +

/* NetServer Start-Date is at offset 60 into the list... */
   chgvar     %bin( &a_pos )     ( %bin( &a_pos ) + 60 + 1 )

/* Get the NetServer Start-Date from the *usrspc... */
   call  QUSRTVUS         ( +
                            'NETS      QTEMP     '  +
                            &a_pos                  +
                            x'00000007'             +
                            &NSDate                 +

/* If the StartDate is binary zeroes, then NetServer isn't started... */
   if   ( %sst( &NSDate 1 1 ) *eq &X00 )         do
         sndusrmsg  'NetServer is NOT active.'  tomsgq( *EXT )

/* ...otherwise NetServer is started... */
   else   do
         sndusrmsg  'NetServer IS active.    '  tomsgq( *EXT )

Thanks to Tom Liotta

Retrieve library description
It is used in a loop based on DSPOBJD *ALL *LIB OUTPUT(*OUTFILE). It puts the library name, size, and description to your joblog.
dcl &rtnvar *char 104 dcl &rtnlen *char 4 x'00000068' dcl &attrib *char 12 x'000000020000000500000006' dcl &desc *char 50 dcl &size *dec (9 0) dcl &mult *dec (9 0) dcl &sizedec *dec (15 0) dcl &sizechar *char 15 call qlirlibd (&rtnvar + &rtnlen + &odobnm + &attrib + x'0000000000000000') chgvar &desc %sst(&rtnvar 29 50) chgvar &size %bin(&rtnvar 93 4) chgvar &mult %bin(&rtnvar 97 4) chgvar &sizedec (&size * &mult) chgvar &sizechar &sizedec sndpgmmsg (&odobnm *cat ' ' *cat &sizechar + *cat ' ' *cat &desc) Thanks to Vern Hamberg

List Spooled Files
Here's a program written in free-form RPG which demonstrates a simple use of the QUSLSPL API. Perhaps you can use this to help you understand what needs to be changed in your program... H DFTACTGRP(*NO) D QUSLSPL PR ExtPgm('QUSLSPL') * required parameters D UsrSpc 20A const D Format 8A const D UserName 10A const D QualOutQ 20A const D FormType 10A const D UserData 10A const * optional group 1: D ErrorCode 32766A options(*nopass: *varsize) * optional group 2: D QualJob 26A options(*nopass) const D FieldKeys 10I 0 options(*nopass: *varsize) D dim(9999) D NumFields 10I 0 options(*nopass) const * optional group 3: D AuxStgPool 10I 0 options(*nopass) const * optional group 4: D JobSysName 8A options(*nopass) const D StartCrtDate 7A options(*nopass) const D StartCrtTime 6A options(*nopass) const D EndCrtDate 7A options(*nopass) const D EndCrtTime 6A options(*nopass) const D QUSCRTUS PR ExtPgm('QUSCRTUS') D UsrSpc 20A CONST D ExtAttr 10A CONST D InitialSize 10I 0 CONST D InitialVal 1A CONST D PublicAuth 10A CONST D Text 50A CONST D Replace 10A CONST D ErrorCode 32766A options(*nopass: *varsize) D QUSPTRUS PR ExtPgm('QUSPTRUS') D UsrSpc 20A CONST D Pointer * D QUSDLTUS PR ExtPgm('QUSDLTUS') D UsrSpc 20A CONST D ErrorCode 32766A options(*varsize) D GetStatus PR 4A D StatusCode 10I 0 value D p_UsrSpc s * D dsLH DS BASED(p_UsrSpc) D qualified D Filler1 103A D Status 1A D Filler2 12A D HdrOffset 10I 0 D HdrSize 10I 0 D ListOffset 10I 0 D ListSize 10I 0 D NumEntries 10I 0 D EntrySize 10I 0 D p_Entry s * D dsSF DS BASED(p_Entry) D qualified D JobName 10A D UserName 10A D JobNumber 6A D SplfName 10A D SplfNbr 10I 0 D SplfStatus 10I 0 D OpenDate 7A D OpenTime 6A D Schedule 1A D SysName 10A D UserData 10A D FormType 10A D OutQueue 10A D OutQueueLib 10A D AuxPool 10I 0 D SplfSize 10I 0 D SizeMult 10I 0 D TotalPages 10I 0 D CopiesLeft 10I 0 D Priority 1A D Reserved 3A D dsEC DS qualified D BytesProvided 10I 0 inz(%size(dsEC)) D BytesAvail 10I 0 inz(0) D MessageID 7A D Reserved 1A D MessageData 240A D MYSPACE C CONST('SPLLIST QTEMP ') D Keys s 10I 0 dim(1) D size s 10I 0 D sf s 10I 0 D msg s 52A /free // set this to zero to let OS/400 handle errors, instead // of handling them ourselves... dsEC.BytesProvided = 0; // Create a user space.. make space for (approx) 300 // spooled files to be listed. size = %size(dsLH) + 512 + (%size(dsSF) * 300); QUSCRTUS(MYSPACE: 'USRSPC': size: x'00': '*ALL': 'Temp User Space for QUSLSPL API': '*YES': dsEC); // List spooled files to the user space QUSLSPL(MYSPACE: 'SPLF0300': *blanks: *blanks: *blanks: *blanks: dsEC: '*': Keys: 0); // Get a pointer to the returned user space QUSPTRUS(MYSPACE: p_UsrSpc); // Loop through list, for each spooled file, display the // spooled file name, number and status. p_Entry = p_UsrSpc + dsLH.ListOffset; for sf = 1 to dsLH.NumEntries; if (dsSF.SplfStatus <> 10); msg = %trim(dsSF.SplfName) + ' ' + %trim(%editc(dsSF.SplfNbr:'L')) + ' ' + GetStatus(dsSF.SplfStatus); dsply msg; endif; p_Entry += dsLH.EntrySize; endfor; // delete user space, we're done with it QUSDLTUS(MYSPACE: dsEC); // give user a chance to read the screen before ending msg = 'Press ENTER to end'; dsply '' '' msg; *inlr = *on; /end-free *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * get human-readable status code for a numeric status code: *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P GetStatus B D GetStatus PI 4A D StatusCode 10I 0 value /free if (StatusCode = 1); return 'RDY'; elseif (StatusCode = 2); return 'OPN'; elseif (StatusCode = 3); return 'CLO'; elseif (StatusCode = 4); return 'SAV'; elseif (StatusCode = 5); return 'WTR'; elseif (StatusCode = 6); return 'HLD'; elseif (StatusCode = 7); return 'MSGW'; elseif (StatusCode = 8); return 'PND'; elseif (StatusCode = 9); return 'PRT'; elseif (StatusCode = 10); return 'FIN'; elseif (StatusCode = 11); return 'SND'; elseif (StatusCode = 12); return 'DFR'; else; return '???'; endif; /end-free P E Thanks to Scott Klement

Retrieve Member Description
Here's an example of call the Retrieve Member Description API in RPG IV. I use this with CodeStudio to retrieve information about the member via FTP which unfortunately requires you to send and Escape message. :( But look at the example call to the QUSRMBRD API for an example of calling it. H BNDDIR('QC2LE') actgrp('QILE') DFTACTGRP(*NO) **---------------------------------------------------------------- ** RTVMBRD - Retrieve a member description ** and write as an *ESCAPE message to the FTP client. ** Used by CodeStudio to retrieve a member description ** (i.e., Source Type - SEU Attributes) **---------------------------------------------------------------- ** COMPILING INSTRUCTIONS: ** NOTE: This program is NOT Release Sensitive ** 1. Upload to the AS/400 ** 2. Compile to the library of your choice ** a) CRTBNDRPG PGM(QGPL/RTVMBRD) SRCFILE(mylib/QRPLESRC) + ** DFTACTGRP(*NO) ** 3. In CodeStudio, on the TOOLS menu, select OPTIONS ** 4. Select the "Add-Ins" tab/page ** 5. Set the host program to call to this program name: ** a) Heading: CL command to retrieve member description... ** b) Entry: CALL QGPL/RTVMBRD PARM(&F &L &M) ** ** When these steps have been completed, this add-in will ** transfer the Source Member's SEU Type, Text, Last Change Date ** to CodeStudio when a member is selected for download. **---------------------------------------------------------------- ** int sprintf( char *buffer, const char *format [, argument] ... ); D sprintf4 PR 10I 0 ExtProc('sprintf') D szRecvVar * VALUE Options(*STRING) D szFormat * VALUE Options(*STRING) D szData1 * VALUE OPTIONS(*STRING) D szData2 * VALUE OPTIONS(*STRING: *NOPASS) D szData3 * VALUE OPTIONS(*STRING: *NOPASS) D szData4 * VALUE OPTIONS(*STRING: *NOPASS) ** The general purpose API error data structure that is usually ignored. D api_error S 21A ** The fields used by the SndPgmMsg API D szMsgID S 7A Inz('CPF9898') D szMsgFile S 20A Inz('QCPFMSG QSYS' ) D szMsgText S 255A D nMsgLen S 10I 0 D szMsgType S 10A D szToPgmQ S 10A D nToPgmQ S 10I 0 D szMsgKey S 4A ** A pointer to the receiving buffer, used by sprintf D pBuffer S * D szBuffer S Like(szMsgText) ** Tells the APIs how long the buffers are that are being used. D nBufLen S 10I 0 **---------------------------------------------------------------- **---------------------------------------------------------------- ** The structure returned by the QusRMBRD API. **---------------------------------------------------------------- **---------------------------------------------------------------- D szMbrd0100 DS INZ D nBytesRtn 10I 0 D nBytesAval 10I 0 D szFileName 10A D szLibName 10A D szMbrName 10A D szFileAttr 10A D szSrcType 10A D dtCrtDate 13A D dtLstChg 13A D szMbrText 50A D bIsSource 1A D pMbrText S * **---------------------------------------------------------------- ** Input Parameters for the program. **---------------------------------------------------------------- ** Source file name D szSrcFile S 10A D szSrcLib S 10A D szSrcMbr S 10A **---------------------------------------------------------------- ** Input Parameters to the QUSRMBRD API **---------------------------------------------------------------- ** Format to be returned D szFmt S 8A Inz('MBRD0100') ** Qualified source file and library name D szQualName S 20A ** Whether or not to ignore overrides (0=Ignore, 1 = Apply) D bOvr S 1A Inz('0') **---------------------------------------------------------------- ** Call this program with 3 parameters: ** Parm(QRPGLESRC myLibr ORDENTRY) ** srcfile srclib srcmbr **---------------------------------------------------------------- C *ENTRY PLIST C Parm szSrcFile C Parm szSrcLib C Parm szSrcMbr ** If we don't have at least 3 parameters, too bad for the caller! C if %Parms < 3 C Eval szMsgText = 'CE3-Invalid parameter list' C else **---------------------------------------------------------------- ** Call QusRMBRD to retrieve the specified source member's attributes **---------------------------------------------------------------- C Eval szQualName = szSrcFile + szSrcLib C Eval nBufLen = %size(szMbrD0100) **---------------------------------------------------------------- C Call(E) 'QUSRMBRD' C Parm szMbrD0100 C Parm nBufLen C Parm szFmt C Parm szQualName C Parm szSrcMbr C Parm bOvr **---------------------------------------------------------------- ** If RTFMBRD failed, we tell the FTP client that it failed. **---------------------------------------------------------------- C if %Error C Eval szMsgText = 'CE3-RTVMBRD Failed' ** Otherwise, just keep on going! C else ** Although not required, C like NULL terminated strings C Eval szBuffer= *ALLX'00' C Eval pBuffer = %addr(szBuffer) C eval szMbrText = %TrimR(szMbrText)+X'00' C eval pMbrText = %addr(szMbrText) **---------------------------------------------------------------- ** Use the C runtime sprintf() to concatenate everything nicely **---------------------------------------------------------------- C CallP sprintf4(pBuffer : C 'CX3%s%s%s%s' : C szSrcType : C bIsSource : C dtLstChg : C pMbrText ) ** The formatted response text gets sent as msg data C Eval szMsgText = %str(pBuffer) C endif C endif ** Tell the API how long the message text (actually Msgdata) is. C Eval nMsgLen = %Len(%trimr(szMsgText)) **---------------------------------------------------------------- ** SndPgmMsg MSGID(CPF9898) MSGF(QSYS/QCPFMSG) TOPGMQ(*PRV) + ** MSGDTA(szMsgText) MSGTYPE(*ESCAPE) **---------------------------------------------------------------- C Call 'QMHSNDPM' C Parm 'CPF9898' szMsgID C Parm szMsgFile C Parm szMsgText C Parm nMsgLen C Parm '*ESCAPE' szMsgType C Parm '*PGMBDY' szToPgmQ C Parm 1 nToPgmQ C Parm szMsgKey C Parm api_error ** Note, we return here to improve performance for subsequent calls ** The program will end when the FTP server's job itself ends. ** If you are uncomfortable with this, uncomment the *INLR line: C**** MOVE *ON *INLR C return Thanks to Bob Cozzi

List Network Interfaces
Q: Greetings! I would like to check the status of a TCP/IP interface. If the status is not *active I would want to get a notification to the system operator, and if the status is failed to vary off and on. Can this be accomplished in a CL?

A: Netstat has no output other than the display. And the Work with interfaces option of CFGTCP menu has no command equivalent. But if you are on v5r1, or later, there are now APIs that let you retrieve the status of interfaces, as well as other TCP/IP operational info. In tnis case, List Network Interface (QtocLstNetIfc) puts all the interface info into a user space. You'd need to poll the status from time to time. This can be called (CALLPRC) from a CLLE - Service Program: QTOCNETSTS. You don't need to name the service program in the compile - it's included automatically. CALLPRC PRC('QtocLstNetIfc') + PARM('X QTEMP ' + 'NIFC0100' + X'0000000000000000') does the trick, putting the data into *USRSPC QTEMP/X. Then use the appropriate user space APIs to get the information. Look up CL & APIs under Programming in InfoCenter. Thanks to Vern Hamberg

And with RPG: * CRTRPGMOD MODULE(NETIFCR) SRCFILE(xxx/QRPGLESRC) SRCMBR(NETIFCR) * CRTPGM PGM(NETIFCR) BNDSRVPGM(QTOCNETSTS) * H DEBUG OPTION(*SRCSTMT:*NODEBUGIO) BNDDIR('QC2LE') H dftactgrp(*NO) FQSYSPRT O F 198 Printer USROPN D uSpaceName s 20 inz('NETIFC QTEMP ') D cmdStr1 s 256 inz('OVRPRTF FILE(QSYSPRT) PAGESIZE(- D *N 198) CPI(15) OVRSCOPE(*JOB)') D cmdStr2 s 256 inz('DLTOVR FILE(QSYSPRT) LVL(*JOB)') *---------------------------------------------------------------- * Get user space list info from header section. *---------------------------------------------------------------- D ds based(uHeadPtr) D uOffSetToList 125 128i 0 D uNumOfEntrys 133 136i 0 D uSizeOfEntry 137 140i 0 * D uListEntry1 ds Based(uListPtr ) D InetAdr 15 overlay(uListEntry1:1) D Reservedr 1 overlay(uListEntry1:16) D InetAdrb 10i 0 overlay(uListEntry1:17) D NetAdr 15 overlay(uListEntry1:21) D Reserved1 1 overlay(uListEntry1:36) D NetAdrb 10i 0 overlay(uListEntry1:37) D NetName 10 overlay(uListEntry1:41) D LineDsc 10 overlay(uListEntry1:51) D IfcName 10 overlay(uListEntry1:61) D Reserved2 2 overlay(uListEntry1:71) D IfcSts 10i 0 overlay(uListEntry1:73) D IfcTypSrv 10i 0 overlay(uListEntry1:77) D IfcMtu 10i 0 overlay(uListEntry1:81) D IfcLinTyp 10i 0 overlay(uListEntry1:85) D HostAdr 15 overlay(uListEntry1:89) D Reserved3 1a overlay(uListEntry1:104) D HostAdrb 10i 0 overlay(uListEntry1:105) D IfcSbnMask 15 overlay(uListEntry1:109) D Reserved4 1a overlay(uListEntry1:124) D IfcSbnMaskb 10i 0 overlay(uListEntry1:125) D DrtBrdCstAdr 15 overlay(uListEntry1:129) D Reserved5 1a overlay(uListEntry1:144) D DrtBrdCstAdrb 10i 0 overlay(uListEntry1:145) D ChgDate 8 overlay(uListEntry1:149) D ChgTime 6 overlay(uListEntry1:157) D AsoLclIfc 15 overlay(uListEntry1:163) D Reserved6 3a overlay(uListEntry1:178) D AsoLclIfcb 10i 0 overlay(uListEntry1:181) D ChgSts 10i 0 overlay(uListEntry1:185) D PacketRules 10i 0 overlay(uListEntry1:189) D AutoStart 10i 0 overlay(uListEntry1:193) D TorkenRingSeq 10i 0 overlay(uListEntry1:197) D IfcType 10i 0 overlay(uListEntry1:201) D ProxyARPEbl 10i 0 overlay(uListEntry1:205) D ProxyARPAlw 10i 0 overlay(uListEntry1:209) D CfgMTU 10i 0 overlay(uListEntry1:213) D NetNameFull 24 overlay(uListEntry1:217) D IfcNameFull 24 overlay(uListEntry1:241) *---------------------------------------------------------------- * Error return code parm for APIs. *---------------------------------------------------------------- D vApiErrDs ds D vbytpv 10i 0 inz(%size(vApiErrDs)) D vbytav 10i 0 inz(0) D vmsgid 7a D vresvd 1a D vrpldta 50a *---------------------------------------------------------------- * Create Prototypes for calls *---------------------------------------------------------------- **-- Create user space: ----------------------------------------- D quscrtus PR ExtPgm('QUSCRTUS') D 20 D 10 const D 10i 0 const D 1 const D 10 const D 50 const D 10 const Db like(vApiErrDS) **-- Delete user space: ------------------------------------------ D qusdltus Pr ExtPgm( 'QUSDLTUS' ) D 20 Const Db like(vApiErrDS) **-- Call system command: --------------------------------------- D system PR 10I 0 extproc('system') D i_cmd * value options(*string) * D EXCP_MSGID S 7A import('_EXCP_MSGID') **-- List network connections: ---------------------------------- D LstNetIfc PR ExtProc('QtocLstNetIfc') D 20 D 8 const Db like(vApiErrDS) **-- Retrieve pointer to user space: ---------------------------- D qusptrus PR ExtPgm('QUSPTRUS') D 20 D * Db like(vApiErrDS) D main PR extpgm('NETIFCR') D main PI *---------------------------------------------------------------- * Create user space C callp QUSCRTUS( C uSpaceName: C 'TEST': C 1500000: C x'00': C '*ALL': C 'User Space JCR ': C '*NO': C vApiErrDs) * Get pointer to user space C callp QUSPTRUS( C uSpaceName: C uHeadPtr: C vApiErrDs) * call api to load job log into user space. C callp LstNetIfc( C uSpaceName: C 'NIFC0100': C vApiErrDs) * Process elements * C callp system(cmdStr1) C open QSYSPRT C eval uListPtr = uHeadPtr + uOffSetToList C except Head 1B C do uNumOfEntrys C exsr cvtTxtSr C except Out C eval uListPtr = uListPtr + uSizeOfEntry 1E C enddo C close QSYSPRT C callp system(cmdStr2) * Delete user space C callp qusdltus( C uSpaceName: C vApiErrDs) * C eval *inlr = *on C return **-- Convert text : ---------------------------------------------- C cvtTxtSr BegSr C Move *blanks IfcStsC 11 C Select C When IfcSts = 0 c eval IfcStsC = 'Inactive' C When IfcSts = 1 c eval IfcStsC = 'Active' C When IfcSts = 2 c eval IfcStsC = 'Starting' C When IfcSts = 3 c eval IfcStsC = 'Ending' C When IfcSts = 4 c eval IfcStsC = 'RCYPND' C When IfcSts = 5 c eval IfcStsC = 'RCYCNL' C When IfcSts = 6 c eval IfcStsC = 'Failed' C When IfcSts = 7 c eval IfcStsC = 'Failed(TCP)' C When IfcSts = 8 c eval IfcStsC = 'DOD' C EndSl C EndSr OQSYSPRT E HEAD 1 O 8 'Inet Adr' O 23 'Net Adr' O 40 'Net Name' O 51 'Line Dsc' O 61 'Ifc Name' O 75 'Ifc Status' O 85 'Host Adr' O E OUT 1 O InetAdr O NetAdr + 1 O NetName + 1 O LineDsc + 1 O IfcName + 1 O IfcStsC + 1 O HostAdr + 1 Thanks to Vengoal Chang


Convert Case
Here is a sample of converting one paramter to lowercase using the current CCSID of the requesting job. The one value that would need changing is &DATASIZE and the LEN() of &PARM1 -- these two must match and represent the size of the variable to lowercase. To handle three input parameters simply vary the second and fourth parameters being passed to QLGCNVCS (Convert Case).
PGM PARM(&PARM1) DCL VAR(&PARM1) TYPE(*CHAR) LEN(10) DCL VAR(&REQCTLBLK) TYPE(*CHAR) LEN(22) + VALUE(X'00000001000000000000000100000000000+ 000000000') /* Use Job CCSID to convert + input data to lowercase */ /* DCL VAR(&REQCTLBLK) TYPE(*CHAR) LEN(22) + VALUE(X'00000001000000000000000000000000000+ 000000000') */ /* Use Job CCSID to convert + input data to uppercase */ DCL VAR(&DATASIZE) TYPE(*DEC) LEN(2 0) VALUE(10) DCL VAR(&DATALEN) TYPE(*CHAR) LEN(4) CHGVAR %BINARY(&DATALEN) VALUE(&DATASIZE) CALL PGM(QLGCNVCS) PARM(&REQCTLBLK &PARM1 + &PARM1 &DATALEN 0) ENDPGM Thanks to Bruce Vining

Page #1 Page #3