iSeries & System i

#6 API - Table of Contents #8

API Name # Description
QZRUCLSP   Call Service Program Procedure
QWCLSCDE   Retrieve Job Schedule Entries
QDBRTVFD 1 Retrieve Database File Description
QUSCRTUI   Create User Index
QUS.....   User Index APIs
Qp0lSetAttr   Set IFS object attribute
Qp0lGetAttr   Get IFS object attributes
QSYRTVUA   Retrieve Users Authorized to an Object
QSY.....   Validation List Object APIs
QEZSNDMG   Send Message
QLICHGLL   Change Library List



QZRUCLSP
Call Service Program Procedure
Program: VARPROC1

     H DFTACTGRP(*NO) ACTGRP(*NEW)
      *
      *  This program demonstrates using the QZRUCLSP API to do "soft
      *  coded" calls to routines in the MSGSRV service program.
      *                                Scott Klement, Nov 6, 2003
      *

      *
      * Compile me with:
      *    CRTBNDRPG VARPROC1 SRCFILE(xxx/xxx)
      *  (Note that you do NOT have to bind the MSGSRV *SRVPGM!)
      *
      * Call me with:
      *   CALL VARPROC1 PARM('COMPMSG' 'THIS IS MY COOL MESSAGE' 23)
      *   CALL VARPROC1 PARM('DIAGMSG' 'THIS IS MY COOL MESSAGE' 23)
      *   CALL VARPROC1 PARM('ESCAPEMSG' 'THIS IS MY COOL MESSAGE' 23)
      *   CALL VARPROC1 PARM('STATUSMSG' 'THIS IS MY COOL MESSAGE' 23)
      *
      *  Note that the output from DIAGMSG will go to the job log.
      *

      *
      * API error code structure
      *
     D dsEC            DS
     D   dsEC_BytesP                 10I 0 inz(%size(dsEC))
     D   dsEC_BytesA                 10I 0 inz(0)
     D   dsEC_MsgID                   7A
     D   dsEC_Resvd                   1A
     D   dsEC_MsgDta                240A

      *
      * Call Service Program Procedure API (QZRUCLSP)
      *
     d QZRUCLSP        pr                  extpgm('QZRUCLSP')
     d  QualSrvPgm                   20A   const
     d  ExportName                 4096A   options(*varsize) const
     d  RtnValFmt                    10I 0 const
     d  ParmsFmt                     10I 0 dim(256) options(*varsize)
     d  NumOfParms                   10I 0 const
     d  Errorcode                  1024a   options(*varsize)
     d  ReturnValue                  10I 0 options(*nopass)
     d  Parameter1                  256A   options(*nopass)
     d  Parameter2                   10I 0 options(*nopass)

      *
      * Parameter/Return types to use with QZRUCLSP API
      *
     d RETTYPE_NONE    C                   0
     d RETTYPE_INT     C                   1
     d RETTYPE_PTR     C                   2
     d RETTYPE_INTERR  C                   3
     d PARMTYPE_INT    C                   1
     d PARMTYPE_PTR    C                   2

     d SrvPgm          s             10A   inz('MSGSRV')
     d SrvPgmLib       s             10A   inz('*LIBL')
     d Procedure       s             32A
     d ParmType        s             10I 0 dim(2)
     d RtnVal          s             10I 0
     D Message         s            256A
     D Length          s             15P 5
     D IntLen          s             10I 0
     D Msg             s             52A

     c     *entry        plist
     c                   parm                    Procedure
     c                   parm                    Message
     c                   parm                    Length

     c                   eval      IntLen = Length

     c                   eval      ParmType(1) = PARMTYPE_PTR
     c                   eval      ParmType(2) = PARMTYPE_INT

     c                   callp     QZRUCLSP( SrvPgm+SrvPgmLib:
     c                                       %trimr(Procedure)+x'00':
     c                                       RETTYPE_INT:
     c                                       ParmType: 2:
     c                                       dsEC:
     c                                       RtnVal:
     c                                       Message:
     c                                       IntLen)

     c                   select
     c                   when      dsEC_BytesA > 0
     c                   eval      Msg = 'Call failed with ' + dsEC_MsgID
     c                   dsply                   Msg
     c                   when      RtnVal <> 0
     c                   eval      Msg = 'Procedure returned error: ' +
     c                                       %trim(%editc(RtnVal:'L'))
     c                   dsply                   Msg
     c                   endsl

     c                   eval      *inlr = *on
Program: VARPROC2
      *
      *  This program demonstrates using procedure pointers with a SELECT
      *  group to "soft-code" procedure names.
      *                                Scott Klement, Nov 6, 2003
      *
      * Compile me with:
      *    CRTRPGMOD VARPROC2 SRCFILE(xxx/xxx)
      *    CRTPGM VARPROC2 BNDSRVPGM(MSGSRV) ACTGRP(*NEW)
      *  (Note that you DO have to bind the MSGSRV *SRVPGM!)
      *
      * Call me with:
      *   CALL VARPROC2 PARM('COMPMSG' 'THIS IS MY COOL MESSAGE' 23)
      *   CALL VARPROC2 PARM('DIAGMSG' 'THIS IS MY COOL MESSAGE' 23)
      *   CALL VARPROC2 PARM('ESCAPEMSG' 'THIS IS MY COOL MESSAGE' 23)
      *   CALL VARPROC2 PARM('STATUSMSG' 'THIS IS MY COOL MESSAGE' 23)
      *
      *  Note that the output from DIAGMSG will go to the job log.
      *

     D MsgProcPtr      s               *   procptr

     D AnyMsgProc      PR            10I 0 ExtProc(MsgProcPtr)
     D   Message                    256A   options(*varsize)
     D   Length                      10I 0 value

     d Procedure       s             32A
     d RtnVal          s             10I 0
     D Message         s            256A
     D Length          s             15P 5
     D Msg             s             52A

     c     *entry        plist
     c                   parm                    Procedure
     c                   parm                    Message
     c                   parm                    Length

     c                   select
     c                   when      Procedure = 'ESCAPEMSG'
     c                   eval      MsgProcPtr = %paddr('ESCAPEMSG')
     c                   when      Procedure = 'COMPMSG'
     c                   eval      MsgProcPtr = %paddr('COMPMSG')
     c                   when      Procedure = 'STATUSMSG'
     c                   eval      MsgProcPtr = %paddr('STATUSMSG')
     c                   when      Procedure = 'DIAGMSG'
     c                   eval      MsgProcPtr = %paddr('DIAGMSG')
     c                   endsl

     c                   eval      RtnVal = AnyMsgProc(Message: Length)
     c                   if        RtnVal <> 0
     c                   eval      Msg = 'Procedure returned error: ' +
     c                                       %trim(%editc(RtnVal:'L'))
     c                   dsply                   Msg
     c                   endif

     c                   eval      *inlr = *on
Program: MSGSRV
     H NOMAIN
      *
      * This service program sends messages 4 different ways, it's used
      * by the VARPROC1 and VARPROC2 programs to demonstrate soft-coded
      * procedure calls.
      *                                Scott Klement, Nov 6, 2003

      *
      * To compile:
      *    CRTRPGMOD MODULE(mylib/MSGSRV) SRCFILE(mylib/mysrcpf)
      *    CRTSRVPGM SRVPGM(mylib/MSGSRV) MODULE(mylib/MSGSRV) EXPORT(*ALL)
      *

      *
      * API error code structure
      *
     D dsEC            DS
     D   dsEC_BytesP                 10I 0 inz(%size(dsEC))
     D   dsEC_BytesA                 10I 0 inz(0)
     D   dsEC_MsgID                   7A
     D   dsEC_Resvd                   1A
     D   dsEC_MsgDta                240A

      *
      * 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   ErrorCode                 1024A   options(*varsize)

     D CompMsg         PR            10I 0
     D   Message                    256A   options(*varsize)
     D   Length                      10I 0 value
     D EscapeMsg       PR            10I 0
     D   Message                    256A   options(*varsize)
     D   Length                      10I 0 value
     D StatusMsg       PR            10I 0
     D   Message                    256A   options(*varsize)
     D   Length                      10I 0 value
     D DiagMsg         PR            10I 0
     D   Message                    256A   options(*varsize)
     D   Length                      10I 0 value

      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      *  CompMsg(): Send a completion message.
      *
      *     Message = message to send
      *      Length = length of message to send
      *
      *  returns 0 if successful, or -1 if an error occurs
      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     P CompMsg         B                   export
     D CompMsg         PI            10I 0
     D   Message                    256A   options(*varsize)
     D   Length                      10I 0 value

     D MsgKey          s              4A

     c                   reset                   dsEC

     c                   callp     QMHSNDPM('CPF9897': 'QCPFMSG   *LIBL':
     c                                      Message: Length: '*COMP':
     c                                      '*CTLBDY': 2: MsgKey: dsEC)

     c                   if        dsEC_BytesA > 0
     c                   return    -1
     c                   else
     c                   return    0
     c                   endif
     P                 E

      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      *  EscapeMsg(): Send a completion message.
      *
      *     Message = message to send
      *      Length = length of message to send
      *
      *  returns -1 if an error occurs
      *   (If successful, program stops, so no return value is possible)
      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     P EscapeMsg       B                   export
     D EscapeMsg       PI            10I 0
     D   Message                    256A   options(*varsize)
     D   Length                      10I 0 value

     D MsgKey          s              4A

     c                   reset                   dsEC

     c                   callp     QMHSNDPM('CPF9897': 'QCPFMSG   *LIBL':
     c                                      Message: Length: '*ESCAPE':
     c                                      '*CTLBDY': 2: MsgKey: dsEC)

     c                   return    -1
     P                 E

      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      *  StatusMsg(): Send a status message, and delay for 1 second
      *
      *     Message = message to send
      *      Length = length of message to send
      *
      *  returns 0 if successful, or -1 if an error occurs
      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     P StatusMsg       B                   export
     D StatusMsg       PI            10I 0
     D   Message                    256A   options(*varsize)
     D   Length                      10I 0 value

     D MsgKey          s              4A

     D QCMDEXC         PR                  ExtPgm('QCMDEXC')
     D  command                     200A   const
     D  length                       15P 5 const

     c                   reset                   dsEC

     c                   callp     QMHSNDPM('CPF9897': 'QCPFMSG   *LIBL':
     c                                      Message: Length: '*STATUS':
     c                                      '*EXT': 0: MsgKey: dsEC)

     c                   if        dsEC_BytesA > 0
     c                   return    -1
     c                   else
     c                   callp     QCMDEXC('DLYJOB DLY(1)': 13)
     c                   return    0
     c                   endif
     P                 E

      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      *  DiagMsg(): Send a diagnostic message (to the job log)
      *
      *     Message = message to send
      *      Length = length of message to send
      *
      *  returns 0 if successful, or -1 if an error occurs
      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     P DiagMsg         B                   export
     D DiagMsg         PI            10I 0
     D   Message                    256A   options(*varsize)
     D   Length                      10I 0 value

     D MsgKey          s              4A

     c                   reset                   dsEC

     c                   callp     QMHSNDPM('CPF9897': 'QCPFMSG   *LIBL':
     c                                      Message: Length: '*DIAG':
     c                                      '*': 1: MsgKey: dsEC)

     c                   if        dsEC_BytesA > 0
     c                   return    -1
     c                   else
     c                   return    0
     c                   endif
     P                 E

Thanks to Scott Klement
Back

QWCLSCDE
Retrieve Job Schedule Entries

      ********************************************************************
      * PROGRAM     :  JOBSCDER
      * DESCRIPTION :  Retrieve Job Schedule Entries, sort by Time
      * AUTHOR      :  Joe Marx
      *
      * NOTES       :  Written for Sox Remedation
      *
      * APIs Used:   QWCLSCDE - Retrieve Job Schedule Entries
      *              QLGSORT  - Sort List
      *              QUSCRTUS - Create User Space
      *              QUSDLTUS - Delete User Space
      *              QUSPTRUS - Retrieve From User Space w/ Pointer
      *              QWCRNETA - Retrieve Network Attributes
      *              QMHSNDPM - Send Message
      *
      *
      * MAINTENANCE  PROGRAMMER, PROJECT #, AND DESCRIPTION.
      * -----------  ---------------------------------------
      * 10/26/2004   Joe Marx - Created
      ********************************************************************
     FQSYSPRT   O    F  132        PRINTER OFLIND(*INOF)
      * DATE FORMATS --------------------------------------------
     D FORMATMDY       S               D   DATFMT(*MDY)
     D FORMATUSA       S               D   DATFMT(*USA)
     D FORMATYMD       S               D   DATFMT(*YMD)
     D FORMATISO       S               D   DATFMT(*ISO)

     D PGM_INFO       SDS
     D  PGM_NAME         *PROC
     D  PGM_STATUS       *STATUS
     D  PGM_USER             254    263

      * DELETE  USER SPACE
     D DELETESPACE     PR                  EXTPGM('QUSDLTUS')
     D                               20
     D                              116

      * CREATE USER SPACE
     D USERSPACE       PR                  EXTPGM('QUSCRTUS')
     D                               20
     D                               10
     D                               10I 0
     D                                1
     D                               10
     D                               50
     D                               10
     D                              116
     D                               10

      *  GET A RESOLVED POINTER TO THE USER SPACE
     D GETPOINTER      PR                  EXTPGM('QUSPTRUS')
     D                               20    CONST
     D                                 *
     D                              116

      ***  API for List of Job Schedule Entries
     D JobSch          PR                  EXTPGM('QWCLSCDE')
     D                               20    CONST
     D                                8    CONST
     D                               10    CONST
     D                               16    CONST
     D                              116

      ***  QCMD
     DCOMMAND          PR                  EXTPGM('QCMDEXC')
     D CMDSTRING                   3000    CONST OPTIONS(*VARSIZE)
     D CMDLENGTH                     15P 5 CONST
     D CMDOPT                         3    CONST OPTIONS(*NOPASS)

     D SendMsg         PR                  extpgm('QMHSNDPM')
     D   MsgID                        7    const
     D   MsgFile                     20    const
     D   MsgDta                      80    const
     D   MsgDtaLen                   10i 0 const
     D   MsgType                     10    const
     D   MsgQ                        10    const
     D   MsgQNbr                     10i 0 const
     D   MsgKey                       4
     D   ErrorDS                     16

      ***  API Error Handling
     D                 DS
     D APIERROR                     116
     D  BYTPRV                        9B 0 OVERLAY(APIERROR) INZ(16)
     D  BYTAVA                        9B 0 OVERLAY(APIERROR:5)
     D  MSGID                         7    OVERLAY(APIERROR:9)
     D  ERR###                        1    OVERLAY(APIERROR:16)
     D  MSGDTAE                     100    OVERLAY(APIERROR:17)

      * GENERIC LIST HEADER
     D SPCPTR          S               *
     D QUSH0100        DS                  BASED(SPCPTR)
     D  QUSUA                        64                         USER AREA
     D  QUSSGH                       10I 0                      HEADER SIZE
     D  QUSSRL                        4                         RELEASE LEVEL
     D  QUSFN                         8                         FORMAT NAME
     D  QUSAU                        10                         API USED
     D  QUSDTC                       13                         DATE/TIME CREATED
     D  QUSIS                         1                         INFO STATUS
     D  QUSSUS                       10I 0                      SIZE USER SPACE
     D  QUSOIP                       10I 0                      OFSET INPUT PARM
     D  QUSSIP                       10I 0                      INPUT PARM SIZE
     D  QUSOHS                       10I 0                      OFFSET HDR SECTION
     D  QUSSHS                       10I 0                      HEADER SECTION SIZE
     D  QUSOLD                       10I 0                      OFFSET LIST DATA
     D  QUSSLD                       10I 0                      SIZE LIST DATA
     D  QUSNBRLE                     10I 0                      NUMBER LIST ENTRIES
     D  QUSSEE                       10I 0                      SIZE EACH ENTRY
     D  QUSSIDLE                     10I 0                      CCSID LIST ENT
     D  QUSCID                        2                         COUNTRY ID
     D  QUSLID                        3                         LANGUAGE ID
     D  QUSSLI                        1                         SUBSET LIST INDICO
     D  QUSERVED00                   42                         RESERVED

     D JS_PTR          S               *
     D JS              S              1    BASED(JS_PTR) DIM(32767)
     D JS_Detail       DS          1156    Based(JS_PTR)
     D  JS_Char1                      1    Overlay(JS_Detail:1)
     D  JS_Job                       10    Overlay(JS_Detail:*Next)
     D  JS_Entry                     10    Overlay(JS_Detail:*Next)
     D  JS_SchDate                   10    Overlay(JS_Detail:*Next)
     D  JS_SchDays                   70    Overlay(JS_Detail:*Next)
     D  JS_SchTime                    6    Overlay(JS_Detail:*Next)
     D  JS_Freq                      10    Overlay(JS_Detail:*Next)
     D  JS_DayofMon                  50    Overlay(JS_Detail:*Next)
     D  JS_Recovery                  10    Overlay(JS_Detail:*Next)
     D  JS_NextDate                  10    Overlay(JS_Detail:*Next)
     D  JS_Status                    10    Overlay(JS_Detail:*Next)
     D  JS_JobqNam                   10    Overlay(JS_Detail:*Next)
     D  JS_JobqLib                   10    Overlay(JS_Detail:*Next)
     D  JS_UsrPrf                    10    Overlay(JS_Detail:*Next)
     D  JS_LastDate                  10    Overlay(JS_Detail:*Next)
     D  JS_LastTime                   6    Overlay(JS_Detail:*Next)
     D  JS_Text                      50    Overlay(JS_Detail:*Next)
     D  JS_Fill1                     23    Overlay(JS_Detail:*Next)
     D  JS_JobqStatus                10    Overlay(JS_Detail:*Next)
     D  JS_DatesOmit                200    Overlay(JS_Detail:*Next)
     D  JS_JobdNam                   10    Overlay(JS_Detail:*Next)
     D  JS_JobdLib                   10    Overlay(JS_Detail:*Next)
     D  JS_UsrPrf2                   10    Overlay(JS_Detail:*Next)
     D  JS_MsgQNam                   10    Overlay(JS_Detail:*Next)
     D  JS_MsgQlib                   10    Overlay(JS_Detail:*Next)
     D  JS_SaveEnt                   10    Overlay(JS_Detail:*Next)
     D  JS_LastSubN                  10    Overlay(JS_Detail:*Next)
     D  JS_LastSubU                  10    Overlay(JS_Detail:*Next)
     D  JS_LastSubJ                   6    Overlay(JS_Detail:*Next)
     D  JS_LastAttD                  10    Overlay(JS_Detail:*Next)
     D  JS_LastAttT                   6    Overlay(JS_Detail:*Next)
     D  JS_LastAttS                  10    Overlay(JS_Detail:*Next)
     D  JS_Fill2                      2    Overlay(JS_Detail:*Next)
     D  JS_Len                        4  0 Overlay(JS_Detail:*Next)
     D  JS_Command                  512    Overlay(JS_Detail:*Next)

      * Sort Block
     DSORTBLOCK        DS
     D  BLOCKLEN               1      4B 0 INZ(0)
     D  REQTYPE                5      8B 0 INZ(8)
     D  RSVP1                  9     12B 0 INZ(0)
     D  OPTIONS               13     16B 0 INZ(0)
     D  RECLEN                17     20B 0 INZ(0)
     D  RECCOUNT              21     24B 0 INZ(0)
     D  OFF2KEY               25     28B 0 INZ(80)
     D  NBROFKEYS             29     32B 0 INZ(0)
     D  OFF2NLSI              33     36B 0 INZ(0)
     D  OFF2IFL               37     40B 0 INZ(0)
     D  NBRINF                41     44B 0 INZ(0)
     D  OFF2OFL               45     48B 0 INZ(0)
     D  NBROUTF               49     52B 0 INZ(0)
     D  KEYENTLEN             53     56B 0 INZ(16)
     D  NLSSLEN               57     60B 0 INZ(290)
     D  IFELEN                61     64B 0 INZ(0)
     D  OFELEN                65     68B 0 INZ(0)
     D  OFF2NBM               69     72B 0 INZ(0)
     D  OFF2VLRA              73     76B 0 INZ(0)
     D  RSVP2                 77     80B 0 INZ(0)
     D  KEYINF                       16A   DIM(MaxKey)

      * Sort Block IO
     DSORTIOBLOC       DS
     D  IOTYPE                 1      4B 0 INZ(0)
     D  RSVP3                  5      8B 0 INZ(0)
     D  IORECLEN               9     12B 0 INZ(0)
     D  IORECCNT              13     16B 0 INZ(0)

      * Sort INFO Data Structure
     DKEYINFDS         DS
     D  KEYSTART               1      4B 0
     D  KEYSIZE                5      8B 0
     D  KEYDTATYP              9     12B 0
     D  KEYASCDESC            13     16B 0

      *----------------------------------------------------------------
      * QWCRNETA  Retrieve network attribute - get system name
      * See SYSTEM PROGRAMMER'S INTERFACE REFERENCE for API detail.
      *----------------------------------------------------------------
     D vsd             s              5u 0                      START OF DATA
     D vso             s              5u 0                      START OFFSET

      * Load number of attributes to retrieve and attribute name
     D vapiky          ds
     D  vnkfld                       10i 0 inz(1)
     D  vkarry                       11    inz('SYSNAME')

      *     Number of keys returned and offset to attribute data
     D vrcvr1          ds           200    inz
     D  vnkyrt                       10i 0
     D  voffna                       10i 0
     D  vrcvln         s             10i 0 inz(200)

      *     Network Attribute Information Table returned
     D vnait           ds                  inz
     D  vrtatt                 1     10
     D  vrttyp                11     11
     D  vrtsta                12     12
     D  vrtlen                       10i 0

      * User Defined Variables
     D JS_Format       S             20    INZ('SCDL0200')
     D JS_Name         S              8    INZ('*ALL')
     D JS_Handle       S             10    INZ(' ')
     D SPC_LIB         S             10    INZ('QTEMP     ')
     D EXT_ATTR        S             10    INZ
     D SPACE_SIZE      S             10I 0 INZ(500000)
     D SPACE_INIT      S              1    INZ(X'00')
     D SPACE_AUT       S             10    INZ('*ALL')
     D SPACE_TEXT      S             50    INZ('MEDI001R TEXT')
     D SPACE_RPL       S             10    INZ('*YES')
     D SPACEDOMAN      S             10    INZ('*USER')
     D SPACENAME       S             20    INZ('MEDI001R  QTEMP     ')
     D TIMES           S              7  0
     D COUNT           S              7  0
     D LLEN            S              7  0
     D Ljob            S             10
     D COUNT2          S              7  0
     D #Status         S              3A
     D #Date           S             10A
     D #Command        S             31A
     D #Time           S              6  0
     D #Frequency      S             10A
     D MAXKEY          C                    4
     D EXITER          S              1A
     D NOTUSED         S             16A
     D RETURNSIZE      S              9B 0
     D SIZELIST        S              9B 0
     D SYSNAME         S              8
     D #str            S              4  0
     D #end            S              4  0
     D #Len            S              4  0
     D CMDSTRING       S           3000    VARYING
     D CMDLENGTH       S             15  5
     D MsgDta          s             80
     D MsgKey          s              4

      **  Initial Startup
     C                   EXSR      INIT

      **  Main Processing
     C                   EXSR      Main

      **  Special Processing
     C                   EXSR      Special

      * Send Message that Job has completed.
     C***                CALLP     COMMAND( CMDSTRING : %LEN(CMDSTRING))

     C                   eval      MsgDta = 'AS/400 Batch Job Schedule -
     C                             has printed'
     C                   callp     SendMsg ('CPF9898':
     C                               'QCPFMSG   QSYS':
     C                               MsgDta:
     C                               %len(MsgDta):
     C                               '*ESCAPE':
     C                               '*':
     C                               2:
     C                               MsgKey:
     C                               ApiError)

      ** End Program
     C                   EVAL      *INLR = *ON

      *==============================================================
      * Subroutine - Main
      *  This subroutine processing....
      *==============================================================
     C     Main          begsr

      **  Print Header at least 1 time....
     C                   EXCEPT    HEAD1

      **  RETRIEVE DATABASE FILE DESCRIPTION USING USER SPACE
      ** CREATE USER SPACE
     C                   CALLP     USERSPACE(SPACENAME  :
     C                                       EXT_ATTR   : SPACE_SIZE :
     C                                       SPACE_INIT : SPACE_AUT  :
     C                                       SPACE_TEXT : SPACE_RPL  :
     C                                       APIERROR   : SPACEDOMAN  )

      **  RETRIEVE WRKJOBSCDE API - QWCLSCDE
     C                   CALLP     JOBSCH(SPACENAME  :
     C                                    JS_Format  : JS_Name :
     C                                    JS_Handle  : APIERROR  )

      *  GET A RESOLVED POINTER TO THE USER SPACE
      *  RECEIVES HEADER INFO FROM USER SPACE
     C                   CALLP     GETPOINTER(SPACENAME : SPCPTR :
     C                                        APIERROR)
     C

      * SET JS_PTR TO THE FIRST BYTE OF THE USER SPACE
     C                   EVAL      JS_PTR = SPCPTR

      * Initial Sort API
     c                   EXSR      $InzSort

      * Initial Sort List
     c                   EXSR      $SortList

      * DELETE ALL USER SPACES BEFORE EXITING PROGRAM
     C                   CALLP     DELETESPACE(SPACENAME : APIERROR )

      * Print Totals
     C                   EXSR      @@HEAD
     C                   EXCEPT    TOT1
     C                   EndSr

      *==============================================================
      * Subroutine - Special
      *  This subroutine processing....
      *==============================================================
     C     Special       begsr

      **  Print Header at least 1 time....
     C                   EXCEPT    HEAD2

      **  RETRIEVE DATABASE FILE DESCRIPTION USING USER SPACE
      ** CREATE USER SPACE
     C                   CALLP     USERSPACE(SPACENAME  :
     C                                       EXT_ATTR   : SPACE_SIZE :
     C                                       SPACE_INIT : SPACE_AUT  :
     C                                       SPACE_TEXT : SPACE_RPL  :
     C                                       APIERROR   : SPACEDOMAN  )

      **  RETRIEVE WRKJOBSCDE API - QWCLSCDE
     C                   CALLP     JOBSCH(SPACENAME  :
     C                                    JS_Format  : JS_Name :
     C                                    JS_Handle  : APIERROR  )

      *  GET A RESOLVED POINTER TO THE USER SPACE
      *  RECEIVES HEADER INFO FROM USER SPACE
     C                   CALLP     GETPOINTER(SPACENAME : SPCPTR :
     C                                        APIERROR)
     C

      * SET JS_PTR TO THE FIRST BYTE OF THE USER SPACE
     C                   EVAL      JS_PTR = SPCPTR

      * Initial Sort API
     c                   EXSR      $InzSort

      * Initial Sort List
     c                   EXSR      $SortList2

      * DELETE ALL USER SPACES BEFORE EXITING PROGRAM
     C                   CALLP     DELETESPACE(SPACENAME : APIERROR )

      * Print Totals
     C                   EXSR      @@HEAD2
     C                   EXCEPT    TOT2

     C                   EndSr

      *==============================================================
      * Subroutine - Init
      *  This subroutine Initializes the Program
      *==============================================================
     C     Init          begsr

     C                   call      'QWCRNETA'                    RETRIEVE SPACE
     C                   parm                    vrcvr1
     C                   parm      200           vrcvln
     C                   parm                    vnkfld          NUMBER OF KEYS
     C                   parm                    vkarry          KEY ARRAY
     C                   parm                    ApiError

     C     voffna        add       1             vso             START OFFSET
     C     voffna        add       1             vso             START OFFSET
     C                   eval      vnait = %subst(vrcvr1:vso:16) LOAD NAIT DST
     C     vso           add       16            vsd             START OF DATA
     C     vrtlen        subst     vrcvr1:vsd    SYSNAME         EXTRACT SYSNAM

     c                   Endsr

      *==============================================================
      * Subroutine - @@HEAD
      *  Check for Overflow - Reprints Heading
      *==============================================================
     C     @@HEAD        begsr

     c                   if        *inOF = *on
     C                   EXCEPT    HEAD1
     c                   Eval      *inOF = *off
     c                   EndIf

     C                   Endsr

      *==============================================================
      * Subroutine - @@HEAD2
      *  Check for Overflow - Reprints Heading for Special
      *==============================================================
     C     @@HEAD2       begsr

     c                   if        *inOF = *on
     C                   EXCEPT    HEAD1
     c                   Eval      *inOF = *off
     c                   EndIf

     C                   Endsr

      *==============================================================
      * Subroutine - InzSort
      *  This subroutine Initializes the Sort API
      *==============================================================
     c     $InzSort      begsr

      * Initialize the key fields to sort on.
      * Load JS_Freq field as key field, 06 byte, Char, ascending sequence.
     c                   eval      KeyStart   = 107
     c                   eval      KeySize    = 10
     c                   eval      KeyDtaTyp  = 2
     c                   eval      KeyAscDesc = 1
     c                   eval      KeyInf(1)  = KeyInfDs

      * Load JS_schTime field as key field, 06 byte, Char, ascending sequence.
     c                   eval      KeyStart   = 101
     c                   eval      KeySize    = 06
     c                   eval      KeyDtaTyp  = 2
     c                   eval      KeyAscDesc = 1
     c                   eval      KeyInf(2)  = KeyInfDs

      * Load JS_Job     field as key field, 10 byte, char , ascending sequence.
     c                   eval      KeyStart   = 1
     c                   eval      KeySize    = 10
     c                   eval      KeyDtaTyp  = 6
     c                   eval      KeyAscDesc = 1
     c                   eval      KeyInf(3)  = KeyInfDs

      * Load other sort parameters.
     c                   eval      BlockLen  = 80 + 16 * MaxKey
     c                   eval      NbrOfKeys = 3                    Variable
     c                   eval      RecLen    = %size(JS_Detail)

      * Initialize Sort I/O API fields.
     c                   eval      IORecLen = RecLen
     c                   eval      IORecCnt = 1

      * All done initializing.
     c                   ENDSR

      *==============================================================
      * Subroutine - SortList
      *  This subroutine sorts the List
      *==============================================================
     c     $SortList     begsr

      * First step - Initialize the sort routine.
     c                   call      'QLGSORT'
     c                   parm                    SortBlock
     c                   parm                    NotUsed
     c                   parm                    NotUsed
     c                   parm                    SizeList
     c                   parm                    ReturnSize
     c                   parm                    ApiError

      * Next step - write records to I/O routine.
     c                   eval      IOType = 1

      * INCREMENT JS_PTR TO THE FIRST LIST ENTRY
     C                   EVAL      JS_PTR = %ADDR(JS(QUSOLD + 1))
     C                   FOR       TIMES=1 BY 1 TO QUSNBRLE

     c                   call      'QLGSRTIO'
     c                   parm                    SortIOBloc
     c                   parm                    JS_Detail
     c                   parm                    NotUsed
     c                   parm                    SizeList
     c                   parm                    NotUsed
     c                   parm                    ApiError

     C                   EVAL      JS_PTR = %ADDR(JS(QUSSEE + 1))
     C                   Endfor

      * Next step - Signal end of input, clear JS_DETAIL for reload.
     c                   eval      IOType = 2
     c                   call      'QLGSRTIO'
     c                   parm                    SortIOBloc
     c                   parm                    JS_Detail
     c                   parm                    NotUsed
     c                   parm                    SizeList
     c                   parm                    NotUsed
     c                   parm                    ApiError


      * Final step - write the records back to the subfile.
     c                   eval      IOType = 3

     C                   EVAL      JS_PTR = %ADDR(JS(QUSOLD + 1))
     C                   FOR       TIMES=1 BY 1 TO QUSNBRLE

     c                   call      'QLGSRTIO'
     c                   parm                    SortIOBloc
     c                   parm                    NotUsed
     c                   parm                    JS_Detail
     c                   parm                    IORecLen
     c                   parm                    NotUsed
     c                   parm                    ApiError

      * Set up Date of Run....
     C                   Eval      #DATE = JS_SCHDATE
     C                   Select
     C                   WHEN      JS_SCHDATE = '*NONE'
     C                             and JS_SchDays <> '*ALL'
     C                   Eval      #DATE = 'USER DEF'
     C                   WHEN      JS_SCHDATE = '*NONE'
     C                             and JS_SchDays = '*ALL'
     C                   Eval      #DATE = '*All'
     C                   EndSL

      * Set up #Status...
     C                   Eval      #Status = %subst(JS_Status:1:3)

      * Set up #Time.....
     C                   Move      JS_SCHTIME    #Time

      * Set up #command.....
     C                   Eval      #COMMAND = %subst(JS_COMMAND:1:31)
     C                   If        %subst(JS_COMMAND:1:9) = 'CALL PGM('
     C                   Eval      #str = %scan('/':  JS_Command )
     C                   Eval      #end = %scan(')':  JS_Command )

      * check if library with program(meaning / comes after program)
     C                   If        #str > #end
     C                             or #str = 0
     C                   Eval      #COMMAND = %subst(JS_COMMAND: 10
     C                                         :(#End-1) - 9)
     C                   Else
     C                   Eval      #COMMAND = %subst(JS_COMMAND: #str+1
     C                                         :(#End-1)-#Str)
     C                   Endif
     C                   Endif

     C                   Eval      #LEN  = %len(%trim(JS_COMMAND))
     C                   If        #LEN  > LLEN
     C                   Eval      LLEN = #LEN
     C                   Eval      LJOB = JS_Job
     C                   Endif

     C                   EVAL      COUNT = COUNT + 1
     C                   EXSR      @@HEAD
     C                   EXCEPT    DET1
     C                   EVAL      JS_PTR = %ADDR(JS(QUSSEE + 1))
     C                   ENDFOR

     c                   endsr

      *==============================================================
      * Subroutine - SortList2
      *  This subroutine sorts the List
      *==============================================================
     c     $SortList2    begsr

      * First step - Initialize the sort routine.
     c                   call      'QLGSORT'
     c                   parm                    SortBlock
     c                   parm                    NotUsed
     c                   parm                    NotUsed
     c                   parm                    SizeList
     c                   parm                    ReturnSize
     c                   parm                    ApiError

      * Next step - write records to I/O routine.
     c                   eval      IOType = 1

      * INCREMENT JS_PTR TO THE FIRST LIST ENTRY
     C                   EVAL      JS_PTR = %ADDR(JS(QUSOLD + 1))
     C                   FOR       TIMES=1 BY 1 TO QUSNBRLE

     c                   call      'QLGSRTIO'
     c                   parm                    SortIOBloc
     c                   parm                    JS_Detail
     c                   parm                    NotUsed
     c                   parm                    SizeList
     c                   parm                    NotUsed
     c                   parm                    ApiError

     C                   EVAL      JS_PTR = %ADDR(JS(QUSSEE + 1))
     C                   Endfor

      * Next step - Signal end of input, clear JS_DETAIL for reload.
     c                   eval      IOType = 2
     c                   call      'QLGSRTIO'
     c                   parm                    SortIOBloc
     c                   parm                    JS_Detail
     c                   parm                    NotUsed
     c                   parm                    SizeList
     c                   parm                    NotUsed
     c                   parm                    ApiError

      * Final step - write the records back to the subfile.
     c                   eval      IOType = 3

     C                   EVAL      JS_PTR = %ADDR(JS(QUSOLD + 1))
     C                   FOR       TIMES=1 BY 1 TO QUSNBRLE

     c                   call      'QLGSRTIO'
     c                   parm                    SortIOBloc
     c                   parm                    NotUsed
     c                   parm                    JS_Detail
     c                   parm                    IORecLen
     c                   parm                    NotUsed
     c                   parm                    ApiError

      * Set up Date of Run....
     C                   Eval      #DATE = JS_SCHDATE
     C                   Select
     C                   WHEN      JS_SCHDATE = '*NONE'
     C                             and JS_SchDays <> '*ALL'
     C                   Eval      #DATE = 'USER DEF'
     C                   WHEN      JS_SCHDATE = '*NONE'
     C                             and JS_SchDays = '*ALL'
     C                   Eval      #DATE = '*All'
     C                   EndSL

      * Set up #Status...
     C                   Eval      #Status = %subst(JS_Status:1:3)

      * Set up #Time.....
     C                   Move      JS_SCHTIME    #Time

      * Set up #command.....
     C                   Eval      #COMMAND = %subst(JS_COMMAND:1:31)
     C                   If        %subst(JS_COMMAND:1:9) = 'CALL PGM('
     C                   Eval      #str = %scan('/':  JS_Command )
     C                   Eval      #end = %scan(')':  JS_Command )
     C                   Eval      #COMMAND = %subst(JS_COMMAND:#str+1
     C                                         :(#End-1)-#Str)
     C                   Endif

      * Set up #Frequency....
     C                   Eval      #Frequency =  '*SUNDAY'

     c                   If        %scan('*SUN' : JS_SchDays) > 0
     C                   EVAL      COUNT2 = COUNT2 + 1
     C                   EXSR      @@HEAD2
     C                   EXCEPT    DET2
     c                   Endif

     C                   EVAL      JS_PTR = %ADDR(JS(QUSSEE + 1))
     C                   ENDFOR
     c                   endsr

     OQSYSPRT   E            HEAD1         01
     O                                         + 50 'Job Schedule List'
     O          E            HEAD1          1
     O                                         +  1 'Date of Report....:'
     O                       *Date         y   +  1
     O                                          120 'PAGE......:'
     O                       PAGE          Z    132
     O          E            HEAD1          1
     O                                         +  1 'Program Name......:'
     O                       PGM_NAME          +  1
     O                                          120 'UserId....:'
     O                       PGM_USER           132
     O          E            HEAD1          2
     O                                         +  1 'System Name.......:'
     O                       SYSNAME           +  1
     O          E            HEAD1          1
     O                                           +0 'Opt Job'
     O                                           +4 'Status'
     O                                           +2 'Date'
     O                                           +7 'Time'
     O                                           +5 'Frequency'
     O                                           +2 'Description'
     O                                          +40 'Program/Command'
     O          E            HEAD1          1
     O                                           +0 '--------------------'
     O                                           +0 '--------------------'
     O                                           +0 '--------------------'
     O                                           +0 '--------------------'
     O                                           +0 '--------------------'
     O                                           +0 '--------------------'
     O                                           +0 '------------'
     O          E            DET1           1
     O                       JS_Job              +0
     O                       #Status             +1
     O                       #Date               +5
     O                       #Time               +1 '  :  :  '
     O                       JS_Freq             +1
     O                       JS_Text             +1
     O                       #Command            +1
     O          E            TOT1        3
     O                                           +0 'COUNT:'
     O                       COUNT         4     +2
     O***       E            TOT1        1
     O***                                        +0 'Longest Length of Command:'
     O***                    LLEN          4     +2
     O***                    LJOB                +2

     OQSYSPRT   E            HEAD2            01
     O                                         + 46 'Special Job Schedule List'
     O          E            HEAD2          1
     O                                         +  1 'Date of Report....:'
     O                       *Date         y   +  1
     O                                          120 'PAGE......:'
     O                       PAGE          Z    132
     O          E            HEAD2          1
     O                                         +  1 'Program Name......:'
     O                       PGM_NAME          +  1
     O                                          120 'UserId....:'
     O                       PGM_USER           132
     O          E            HEAD2          2
     O                                         +  1 'System Name.......:'
     O                       SYSNAME           +  1
     O          E            HEAD2          1
     O                                           +0 'Opt Job'
     O                                           +4 'Status'
     O                                           +2 'Date'
     O                                           +7 'Time'
     O                                           +5 'Frequency'
     O                                           +2 'Description'
     O                                          +40 'Program/Command'
     O          E            HEAD2          1
     O                                           +0 '--------------------'
     O                                           +0 '--------------------'
     O                                           +0 '--------------------'
     O                                           +0 '--------------------'
     O                                           +0 '--------------------'
     O                                           +0 '--------------------'
     O                                           +0 '------------'
     O          E            DET2           1
     O                       JS_Job              +0
     O                       #Status             +1
     O                       #Date               +5
     O                       #Time               +1 '  :  :  '
     O                       #Frequency          +1
     O                       JS_Text             +1
     O                       #Command            +1
     O          E            TOT2        3
     O                                           +0 'COUNT:'
     O                       COUNT2        4     +2

Thanks to Joe Marx
Back

QDBRTVFD
Retrieve Database File Description

     **
     **  Program . . : CBX123
     **  Description : Print file field description
     **  Author  . . : Carsten Flensburg
     **  Published . : Club Tech iSeries Programming Tips Newsletter
     **  Date  . . . : September 9, 2004
     **
     **
     **  Program summary
     **  ---------------
     **
     **  Database and file API:
     **    QDBRTVFD      Retrieve database     Allows you to get the complete and
     **                  file description      specific information about a file.
     **
     **                                        The information is returned to a
     **                                        receiver variable in either a file
     **                                        definition template or a format
     **                                        definition mapping.
     **
     **  Message handling API:
     **    QMHSNDPM      Send program message  Sends a message to a program stack
     **                                        entry (current, previous, etc.) or
     **                                        an external message queue.
     **
     **                                        Both messages defined in a message
     **                                        file and immediate messages can be
     **                                        used. For specific message types
     **                                        only one or the other is allowed.
     **
     **  C library function:
     **    tstbts        Test bits             Tests the bit value of the bit
     **                                        located with the bit offset
     **                                        parameter, bit 0 being the
     **                                        leftmost and 64k the maximum.
     **
     **
     **  Program description:
     **    This program will retrieve and print information about a database
     **    file's fields.  The information is printed in a list and includes
     **    field attributes, key fields and, in case of a logical file being
     **    requested, any record select/omit specifications.
     **
     **
     **  Sequence of events:
     **    1. Storage is allocated to the API receiver variable.
     **
     **    2. The QDBRTVFD API is called to collect information about file
     **       key fields and select/omit specifications.  If more data is
     **       available than the storage currently allocated to the API
     **       receiver variable can hold, enough storage is reallocated,
     **       and the API call is repeated.
     **
     **    3. The key fields and select/omit specifications are retrieved
     **       and stored in two arrays for later processing.
     **
     **    4. The QDBRTVFD API is called again, this time to collect the
     **       requried information about record format and field attributes.
     **       Again storage is reallocated and the API call repeated until
     **       all available information is retrieved.
     **
     **    5. The file field list is printed and subsequently the key field
     **       information section is also printed.  In case the requested
     **       file is a logical file, a select/omit specification section is
     **       printed.
     **
     **    6. The allocated storage is released and a completion message is
     **       sent to the caller.
     **
     **    7. If during the processing described above an API error occurs,
     **       the returned error message data is retrieved from the API
     **       error data structure, and an escape message is sent to the
     **       caller, informing about the specific error.  Prior to sending
     **       the escape message, which terminates the program immediately,
     **       the allocated storage is deallocated.
     **
     **
     **  Programmer's notes:
     **    Overflow could occur during the formatting of the check values
     **    and select/omit criteria specification, if the number or size of
     **    these values result in a string larger than 70 respectively 98
     **    bytes.
     **
     **    The format of the produced list can be adapted to any desired
     **    length and overflow values by adjusting the FormLen() and
     **    FormOfl() keywords in the QSYSPRT F-specification below.
     **
     **    The 'dummy' structure specifications that are commented out, are
     **    included in order to document the bit-fields that are embedded in
     **    the return structures:
     **
     **      D  Qdbfhflg                      2a
     **      D*  Reserved_1    :2
     **      D*  Qdbfhfpl      :1
     **
     **    In the above example the field Qdbfhflg is defined as a 2 byte
     **    character field but it contains a number of bit-settings storing
     **    different flags and attributes.  The :n notation defines the
     **    number of bits that each bit-field occupies, from left to right.
     **
     **    Thus the bit-field Reserved_1 occupies the two leftmost bits in
     **    the Qdbfhflg field and Qdbfhfpl the third bit.  To extract the
     **    actual bit settings, the tstbts C library function is used.
     **
     **
     **  Compilation specification:
     **    CrtRpgMod  Module( CBX123 )
     **               DbgView( *LIST )
     **
     **    CrtPgm     Pgm( CBX123 )
     **               Module( CBX123 )
     **               ActGrp( QILE )
     **
     **
     **-- Header specifications:  --------------------------------------------**
     H BndDir( 'QC2LE' )  Option( *SrcStmt )
     **-- Printer file:
     FQSYSPRT   O    F  132        Printer InfDs( PrtInf )  OflInd( *InOf )
     F                                     FormLen( 70 )    FormOfl( 68 )
     **-- Printer file information:
     D PrtInf          Ds                  Qualified
     D  WrtCnt                       10i 0 Overlay( PrtInf: 243 )
     D  OvfLin                        5i 0 Overlay( PrtInf: 188 )
     D  CurLin                        5i 0 Overlay( PrtInf: 367 )
     D  CurPag                        5i 0 Overlay( PrtInf: 369 )
     **-- System information:
     D                SDs
     D  PsPgmNam         *Proc
     **-- API error data structure:
     D ERRC0100        Ds                  Qualified
     D  BytPro                       10i 0 Inz( %Size( ERRC0100 ))
     D  BytAvl                       10i 0 Inz
     D  MsgId                         7a
     D                                1a
     D  MsgDta                      128a
     **-- API parameters:
     D FilRtnQ         Ds                  Qualified
     D  FilNam                       10a
     D  LibNam                       10a
     D ApiRcvSiz       s             10u 0
     **-- Global variables:
     D RcdIdx          s             10i 0
     D FldIdx          s             10i 0
     D ChkIdx          s             10i 0
     D KeyIdx          s             10i 0
     D SltIdx          s             10i 0
     D ValIdx          s             10i 0
     D KeyTyp          s             10a   Varying
     D AccPth          s             10a   Varying
     **-- Output fields:
     D OutHdr          Ds                  Inz
     D  Time                          6s 0
     D  FilNam                       10a
     D  LibNam                       10a
     D  FilTyp                       10a
     D  RcdFmt                       10a
     D  RcdLen                        5i 0
     D  FldCnt                        5i 0
     **
     D OutDtl          Ds                  Inz
     D  FldNam                       10a
     D  FldTyp                       10a
     D  BufPos                        5i 0
     D  FldLen                        5i 0
     D  KeySeq                        4a
     D  FldDig                        3a
     D  FldDec                        3a
     D  FldTxt                       50a
     D  FldHdg                       62a
     D  TxtLin2                      70a
     D  SpcTxt                       98a
     **-- Key field & select/omit statement arrays:
     D KeyFld          s             10a   Dim( 120 )
     D SltStm          s            128a   Dim( 512 )  Varying
     **-- Check keyword conversion:
     D ChkDfn          Ds
     D  ChkHex                       21a   Inz( x'636466677172737475767778797A-
     D                                     A0A1A2A3A5A6A7' )
     D  ChkKwd                      231a   Inz( 'CHKMSGID   -
     D                                     CHECK(ME)  -
     D                                     CHECK(FE)  -
     D                                     CHECK(MF)  -
     D                                     RANGE      -
     D                                     VALUES     -
     D                                     COMP GT    -
     D                                     COMP GE    -
     D                                     COMP EQ    -
     D                                     COMP NE    -
     D                                     COMP LE    -
     D                                     COMP LT    -
     D                                     COMP NL    -
     D                                     COMP NG    -
     D                                     CHECK(M10) -
     D                                     CHECK(M11) -
     D                                     CHECK(VN)  -
     D                                     CHECK(AB)  -
     D                                     CHECK(VNE) -
     D                                     CHECK(M10F)-
     D                                     CHECK(M11F)' )
     D  ChkHexA                       1a   Dim( 21 )  Overlay( ChkDfn: 1 )
     D  ChkKwdA                      11a   Dim( 21 )  Overlay( ChkDfn: 22 )
     **-- Select/omit keyword conversion:
     D SltDfn          Ds
     D  SltCod                       20a   Inz( 'ALEQGEGTLELTNENGNLVA' )
     D  SltKwd                       80a   Inz( 'ALL     -
     D                                     COMP EQ -
     D                                     COMP GE -
     D                                     COMP GT -
     D                                     COMP LE -
     D                                     COMP LT -
     D                                     COMP NE -
     D                                     COMP NG -
     D                                     COMP NL -
     D                                     VALUES  ' )
     D  SltCodA                       2a   Dim( 10 )  Overlay( SltDfn: 1 )
     D  SltKwdA                       8a   Dim( 10 )  Overlay( SltDfn: 21 )
     **-- Field type conversion:
     D TypDfn          Ds
     D  TypHex                       38a   Inz( x'0000000100020003000480040005-
     D                                     800500068006000B000C000D400440054006-
     D                                     80448046FFFF' )
     D  TypTxt                      190a   Inz( 'Binary    -
     D                                     Float     -
     D                                     Zoned     -
     D                                     Packed    -
     D                                     Char      -
     D                                     Var char  -
     D                                     Graph     -
     D                                     Var graph -
     D                                     DBCS      -
     D                                     Var DBCS  -
     D                                     Date      -
     D                                     Time      -
     D                                     Timestamp -
     D                                     BLOB/CLOB -
     D                                     DBCLOB    -
     D                                     CLOB-open -
     D                                     Datalink C-
     D                                     Datalink O-
     D                                     NULL      ' )
     D  TypHexA                       2a   Dim( 19 )  Overlay( TypDfn: 1 )
     D  TypTxtA                      10a   Dim( 19 )  Overlay( TypDfn: 39 )
     **-- FILD0100 formats:
     D Qdb_Qdbfh       Ds                  Based( pQdb_Qdbfh )  Qualified
     D  Qdbfyret                     10i 0
     D  Qdbfyavl                     10i 0
     D  Qdbfhflg                      2a
     D*  Reserved_1    :2
     D*  Qdbfhfpl      :1
     D*  Reserved_2    :1
     D*  Qdbfhfsu      :1
     D*  Reserved_3    :1
     D*  Qdbfhfky      :1
     D*  Reserved_4    :1
     D*  Qdbfhflc      :1
     D*  Qdbfkfso      :1
     D*  Reserved_5    :4
     D*  Qdbfigcd      :1
     D*  Qdbfigcl      :1
     D  Reserved_7                    4a
     D  Qdbflbnum                     5i 0
     D  Qdbfkdat                     14a
     D  Qdbfknum                      5i 0 Overlay( Qdbfkdat: 1 )
     D  Qdbfkmxl                      5i 0 Overlay( Qdbfkdat: *Next )
     D  Qdbfkflg                      1a   Overlay( Qdbfkdat: *Next )
     D*  Reserved_8    :1
     D*  Qdbfkfcs      :1
     D*  Reserved_9    :4
     D*  Qdbfkfrc      :1
     D*  Qdbfkflt      :1
     D  Qdbfkfdm                      1a   Overlay( Qdbfkdat: *Next )
     D  Reserved_10                   8a   Overlay( Qdbfkdat: *Next )
     D  Qdbfhaut                     10a
     D  Qdbfhupl                      1a
     D  Qdbfhmxm                      5i 0
     D  Qdbfwtfi                      5i 0
     D  Qdbfhfrt                      5i 0
     D  Qdbfhmnum                     5i 0
     D  Reserved_11                   9a
     D  Qdbfbrwt                      5i 0
     D  Qaaf                          1a
     D*  Reserved_12   :7
     D*  Qdbfpgmd      :1
     D  Qdbffmtnum                    5i 0
     D  Qdbfhfl2                      2a
     D*  Qdbfjnap      :1
     D*  Reserved_13   :1
     D*  Qdbfrdcp      :1
     D*  Qdbfwtcp      :1
     D*  Qdbfupcp      :1
     D*  Qdbfdlcp      :1
     D*  Reserved_14   :9
     D*  Qdbfkfnd      :1
     D  Qdbfvrm                       5i 0
     D  Qaaf2                         2a
     D*  Qdbfhmcs      :1
     D*  Reserved_15   :1
     D*  Qdbfknll      :1
     D*  Qdbf_nfld     :1
     D*  Qdbfvfld      :1
     D*  Qdbftfld      :1
     D*  Qdbfgrph      :1
     D*  Qdbfpkey      :1
     D*  Qdbfunqc      :1
     D*  Reserved_118  :2
     D*  Qdbfapsz      :1
     D*  Qdbfdisf      :1
     D*  Reserved_68   :1
     D*  Reserved_69   :1
     D*  Reserved_70   :1
     D  Qdbfhcrt                     13a
     D  Qdbfhtx                      52a
     D   Reserved_18                  2a   Overlay( Qdbfhtx: 1 )
     D   Qdbfhtxt                    50a   Overlay( Qdbfhtx: *Next )
     D  Reserved_19                  13a
     D  Qdbfsrc                      30a
     D   Qdbfsrcf                    10a   Overlay( Qdbfsrc: 1 )
     D   Qdbfsrcm                    10a   Overlay( Qdbfsrc: *Next )
     D   Qdbfsrcl                    10a   Overlay( Qdbfsrc: *Next )
     D  Qdbfkrcv                      1a
     D  Reserved_20                  23a
     D  Qdbftcid                      5i 0
     D  Qdbfasp                       2a
     D  Qdbfnbit                      1a
     D*  Qdbfhudt      :1
     D*  Qdbfhlob      :1
     D*  Qdbfhdtl      :1
     D*  Qdbfhudf      :1
     D*  Qdbfhlon      :1
     D*  Qdbfhlop      :1
     D*  Qdbfhdll      :1
     D*  Reserved_21   :1
     D  Qdbfmxfnum                    5i 0
     D  Reserved_22                  76a
     D  Qdbfodic                     10i 0
     D  Reserved_23                  14a
     D  Qdbffigl                      5i 0
     D  Qdbfmxrl                      5i 0
     D  Reserved_24                   8a
     D  Qdbfgkct                      5i 0
     D  Qdbfos                       10i 0
     D  Reserved_25                   8a
     D  Qdbfocs                      10i 0
     D  Reserved_26                   4a
     D  Qdbfpact                      2a
     D  Qdbfhrls                      6a
     D  Reserved_27                  20a
     D  Qdbpfof                      10i 0
     D  Qdblfof                      10i 0
     D  Qdbfssfp                      6a
     D   Qdbfnlsb                     1a   Overlay( Qdbfssfp: 1 )
     D*   Qdbfsscs     :3
     D*   Reserved_103 :5
     D   Qdbflang                     3a   Overlay( Qdbfssfp: *Next )
     D   Qdbfcnty                     2a   Overlay( Qdbfssfp: *Next )
     D  Qdbfjorn                     10i 0
     D  Qdbfevid                     10i 0
     D  Reserved_28                  14a
     **
     D Qdb_Qdbfb       Ds                  Qualified  Based( pQdb_Qdbfb )
     D  Reserved_48                  48a
     D  Qdbfbf                       10a
     D  Qdbfbfl                      10a
     D  Qdbft                        10a
     D  Reserved_49                  37a
     D  Qdbfbgky                      5i 0
     D  Reserved_50                   2a
     D  Qdbfblky                      5i 0
     D  Reserved_51                   2a
     D  Qdbffogl                      5i 0
     D  Reserved_52                   3a
     D  Qdbfsoon                      5i 0
     D  Qdbfsoof                     10i 0
     D  Qdbfksof                     10i 0
     D  Qdbfkyct                      5i 0
     D  Qdbfgenf                      5i 0
     D  Qdbfodis                     10i 0
     D  Reserved_53                  14a
     **
     D Qdb_Qdbfk       Ds                  Qualified  Based( pQdb_Qdbfk )
     D  Qdbfkfld                     10a
     D  Reserved_59                   3a
     D  Qdbfksq                       1a
     D*  Qdbfksad      :1
     D*  Qdbfksn       :2
     D*  Reserved_60   :1
     D*  Qdbfksac      :1
     D*  Qdbfkszf      :1
     D*  Qdbfksdf      :1
     D*  Qdbfkft       :1
     D  Reserved_61                  18a
     **
     D Qdb_Qdbfss      Ds                  Qualified  Based( pQdb_Qdbfss )
     D  Reserved_54                   2a
     D  Qdbfssso                      1a
     D  Qdbfssop                      2a
     D  Qdbfssfn                     10a
     D  Qdbfsspnum                    5i 0
     D  Qsosaf                        1a
     D*  Reserved_55   :7
     D*  Qdbfssfi      :1
     D  Qdbfssfj                      5i 0
     D  Reserved_56                   8a
     D  Qdbfsoso                     10i 0
     **
     D Qdb_Qdbfsp      Ds                  Qualified  Based( pQdb_Qdbfsp )
     D  Qdbfspno                     10i 0
     D  Qdbfspln                      5i 0
     D  Qdbfspin                      1a
     D  Qasopaf                       1a
     D*  Qdbfsigc      :1
     D*  Qdbfshex      :1
     D*  Qdbfsnul      :1
     D*  Reserved_57   :5
     D  Qdbfsppj                      5i 0
     D  Reserved_58                  10a
     D  Qdbfspvl                    128a
     **
     **-- FILD0200 formats:
     D Qdb_Qddfmt      Ds                  Qualified  Based( pQdb_Qddfmt )
     D  Qddbyrtn                     10i 0
     D  Qddbyava                     10i 0
     D  Reserved_62                  24a
     D  Qddfmtf                       1a
     D  Qddfxlto                     10i 0
     D  Qddfrcao                     10i 0
     D  Qddfdico                     10i 0
     D  Qddfrcid                      5i 0
     D  Qddfsrcd                      5i 0
     D  Qddfrtcd                      5i 0
     D  Qddfrlcd                      5i 0
     D  Reserved_64                   7a
     D  Qddftflgs                     1a
     D  Qddflgs                       1a
     D  Reserved_67                   4a
     D  Qddfrlen                     10i 0
     D  Qddfname                     10a
     D  Qddfseq                      13a
     D  Qddftext                     50a
     D  Qddffldnum                    5i 0
     D  Qddf_...
     D  Identity_Off                 10i 0
     **
     D Qdb_Qddffld     Ds                  Qualified  Based( pQdb_Qddffld )
     D  Qddfdefl                     10i 0
     D  Qddffldi                     30a
     D  Qddfflde                     30a
     D  Qddfftyp                      2a
     D  Qddffiob                      1a
     D  Qddffobo                     10i 0
     D  Qddffibo                     10i 0
     D  Qddffldb                      5i 0
     D  Qddffldd                      5i 0
     D  Qddffldp                      5i 0
     D  Qddffkbs                      1a
     D  Qddffldst                     1a
     D  Qddfjref                      5i 0
     D  Qddffldst2                    1a
     D  Qddflgs2                      1a
     D  Qddfvarx                      5i 0
     D  Reserved_72                   2a
     D  Qddflalc                      5i 0
     D  Qddfdttf                      1a
     D  Qddfdtts                      1a
     D  Qddfcsid                      5i 0
     D  Qddftsid                      5i 0
     D  Qddfhsid                      5i 0
     D  Qddflsid                      5i 0
     D  Qddfldur                      1a
     D  Reserved_73                   1a
     D  Qddfwsid                      5i 0
     D  Reserved_061                  1a
     D  Reserved_062                  1a
     D  Reserved_063                  5i 0
     D  Qddflagco                     1a
     D  Reserved_74                  68a
     D  Qddfcplx                     10i 0
     D  Qddfbmaxl                    10i 0
     D  Qddfbpadl                     5i 0
     D  Qddfdicd                     10i 0
     D  Qddfdftd                     10i 0
     D  Qddfderd                     10i 0
     D  Reserved_75                   6a
     D  Qddftxtd                     10i 0
     D  Reserved_102                  2a
     D  Qddfrefd                     10i 0
     D  Qddfedtl                      5i 0
     D  Qddfedtd                     10i 0
     D  Reserved_76                   5i 0
     D  Qddfchd                      10i 0
     D  Qddfvckl                      5i 0
     D  Qddfvckd                     10i 0
     D  Qddfxals                     10i 0
     D  Qddffpnd                     10i 0
     D  Reserved_77                   8a
     D  Qddfvpx                       1a
     **
     D Qdb_Qddfvchk    Ds                  Qualified  Based( pQdb_Qddfvchk )
     D  Qddfvcnume                    5i 0
     D  Reserved_82                  14a
     D  Qddfvcen                      1a
     **
     D Qdb_Qddfvcst    Ds                  Qualified  Based( pQdb_Qddfvcst )
     D  Qddfvccd                      1a
     D  Qddfvcnump                    5i 0
     D  Qddfvcel                      5i 0
     D  Reserved_83                  11a
     D  Qddfvcpm                      1a
     **
     D Qdb_Qddfvcpr    Ds                  Qualified  Based( pQdb_Qddfvcpr )
     D  Qddfvcpl                      5i 0
     D  Reserved_84                  14a
     D  Qddfvcpv                    256a
     **
     D Qdb_Qddfftxt    Ds                  Qualified  Based( pQdb_Qddfftxt )
     D  Qddfftst                     50a
     **
     D Qdb_Qddfcolh    Ds                  Qualified  Based( pQdb_Qddfcolh )
     D  Qddfch1                      20a
     D  Qddfch2                      20a
     D  Qddfch3                      20a
     **-- Retrieve database file description:
     D RtvDbfDsc       Pr                  ExtPgm( 'QDBRTVFD' )
     D  RdRcvVar                  32767a          Options( *VarSize )
     D  RdRcvVarLen                  10i 0 Const
     D  RdFilRtnQ                    20a
     D  RdFmtNam                      8a   Const
     D  RdFilNamQ                    20a   Const
     D  RdRcdFmtNam                  10a   Const
     D  RdOvrPrc                      1a   Const
     D  RdSystem                     10a   Const
     D  RdFmtTyp                     10a   Const
     D  RdError                   32767a          Options( *VarSize )
     **-- Send program message:
     D SndPgmMsg       Pr                  ExtPgm( 'QMHSNDPM' )
     D  SpMsgId                       7a   Const
     D  SpMsgFq                      20a   Const
     D  SpMsgDta                    128a   Const
     D  SpMsgDtaLen                  10i 0 Const
     D  SpMsgTyp                     10a   Const
     D  SpCalStkE                    10a   Const  Options( *VarSize )
     D  SpCalStkCtr                  10i 0 Const
     D  SpMsgKey                      4a
     D  SpError                    1024a          Options( *VarSize )
     **-- Test bit in string:
     D tstbts          Pr            10i 0 ExtProc( 'tstbts' )
     D  String                         *   Value
     D  BitOfs                       10u 0 Value

     **-- Send escape message:
     D SndEscMsg       Pr            10i 0
     D  PxMsgId                       7a   Const
     D  PxMsgF                       10a   Const
     D  PxMsgDta                    512a   Const  Varying
     **-- Send message by type:
     D SndMsgTyp       Pr            10i 0
     D  PxMsgDta                    512a   Const  Varying
     D  PxMsgTyp                     10a   Const

     **-- Entry parameters:
     D CBX123          Pr
     D  PxDbfNamQ                    20a
     D  PxRcdFmt                     10a
     **
     D CBX123          Pi
     D  PxDbfNamQ                    20a
     D  PxRcdFmt                     10a

      /Free

        ApiRcvSiz  = 65535;
        pQdb_Qdbfh = %Alloc( ApiRcvSiz );
        Qdb_Qdbfd.Qdbfyavl = 0;

        DoU  Qdb_Qdbfh.Qdbfyavl <= ApiRcvSiz;

          If  Qdb_Qdbfh.Qdbfyavl > ApiRcvSiz;
            ApiRcvSiz = Qdb_Qdbfh.Qdbfyavl;
            pQdb_Qdbfh  = %ReAlloc( pQdb_Qdbfh: ApiRcvSiz );
          EndIf;

          RtvDbfDsc( Qdb_Qdbfh
                   : ApiRcvSiz
                   : FilRtnQ
                   : 'FILD0100'
                   : PxDbfNamQ
                   : PxRcdFmt
                   : '0'
                   : '*LCL'
                   : '*EXT'
                   : ERRC0100
                   );
        EndDo;

        If  ERRC0100.BytAvl = *Zero;

          pQdb_Qdbfb = pQdb_Qdbfh + Qdb_Qdbfh.Qdbfos;

          If  tstbts( %Addr( Qdb_Qdbfh.Qdbfhflg ): 2 ) = 1;
            FilTyp = 'LF';
          Else;
            FilTyp = 'PF';
          EndIf;

          FilNam = FilRtnQ.FilNam;
          LibNam = FilRtnQ.LibNam;

          For RcdIdx = 1  To Qdb_Qdbfh.Qdbflbnum;

            If PxRcdFmt = Qdb_Qdbfb.Qdbft  Or
               PxRcdFmt = '*FIRST';

              RcdFmt = Qdb_Qdbfb.Qdbft;

              If  Qdb_Qdbfh.Qdbfpact = 'AR';
                AccPth = '*ARRIVAL';
              Else;
                AccPth = '*KEYED';
              EndIf;

              If  tstbts( %Addr( Qdb_Qdbfh.Qdbfhflg ): 6 ) = 1;
                ExSr  GetKeyFlds;
              EndIf;

              If  tstbts( %Addr( Qdb_Qdbfh.Qdbfhflg ): 9 ) = 1;
                ExSr  GetSltOmit;
              EndIf;

              Leave;
            EndIf;

            If  RcdIdx < Qdb_Qdbfh.Qdbflbnum;
              pQdb_Qdbfb = pQdb_Qdbfb + %Size( Qdb_Qdbfb );
            EndIf;
          EndFor;

        EndIf;

        If  ERRC0100.BytAvl = *Zero;

          ApiRcvSiz   = 65535;
          pQdb_Qddfmt = %Alloc( ApiRcvSiz );

          DoU  Qdb_Qddfmt.Qddbyava <= ApiRcvSiz;

            If  Qdb_Qddfmt.Qddbyava > ApiRcvSiz;
              ApiRcvSiz   = Qdb_Qddfmt.Qddbyava;
              pQdb_Qddfmt = %ReAlloc( pQdb_Qddfmt: ApiRcvSiz );
            EndIf;

            RtvDbfDsc( Qdb_Qddfmt
                     : ApiRcvSiz
                     : FilRtnQ
                     : 'FILD0200'
                     : PxDbfNamQ
                     : PxRcdFmt
                     : '0'
                     : '*LCL'
                     : '*EXT'
                     : ERRC0100
                     );
          EndDo;

          If  ERRC0100.BytAvl = *Zero;

            pQdb_Qddffld  = %Addr( Qdb_Qddfmt ) + 256;

            RcdLen = Qdb_Qddfmt.Qddfrlen;
            FldCnt = Qdb_Qddfmt.Qddffldnum;

            For FldIdx = 1  To Qdb_Qddfmt.Qddffldnum;

              If  Qdb_Qddffld.Qddftxtd > *Zero;
                pQdb_Qddfftxt = pQdb_Qddffld + Qdb_Qddffld.Qddftxtd;
              Else;
                pQdb_Qddfftxt = *Null;
              EndIf;

              If  Qdb_Qddffld.Qddfchd > *Zero;
                pQdb_Qddfcolh = pQdb_Qddffld + Qdb_Qddffld.Qddfchd;
              Else;
                pQdb_Qddfcolh = *Null;
              EndIf;

              ExSr  PrtDtlLin;

              If  Qdb_Qddffld.Qddfvckd > *Zero;
                ExSr  PrtChkVal;
              EndIf;

              If FldIdx < Qdb_Qddfmt.Qddffldnum;
                pQdb_Qddffld = pQdb_Qddffld + Qdb_Qddffld.Qddfdefl;
              EndIf;
            EndFor;

            ExSr  PrtKeyFld;
            ExSr  PrtSltStm;
          EndIf;

          DeAlloc  pQdb_Qddfmt;
        EndIf;

        DeAlloc  pQdb_Qdbfh;

        If  ERRC0100.BytAvl > *Zero;

          SndEscMsg( ERRC0100.MsgId
                   : 'QCPFMSG'
                   : %Subst( ERRC0100.MsgDta: 1: ERRC0100.BytAvl - 16 )
                   );
        EndIf;

        SndMsgTyp( 'Field description list has been printed.': '*COMP' );

        *InLr = *On;
        Return;


        BegSr  PrtChkVal;

          pQdb_Qddfvchk = pQdb_Qddffld + Qdb_Qddffld.Qddfvckd;
          pQdb_Qddfvcst = %Addr( Qdb_Qddfvchk.Qddfvcen );

          For ChkIdx = 1  To Qdb_Qddfvchk.Qddfvcnume;

            pQdb_Qddfvcpr = %Addr( Qdb_Qddfvcst.Qddfvcpm );

            TxtLin2 = ChkKwdA( %Lookup( Qdb_Qddfvcst.Qddfvccd: ChkHexA ));

            For ValIdx = 1  To Qdb_Qddfvcst.Qddfvcnump;

              TxtLin2 = %TrimR( TxtLin2 ) + ' ' +
                       %Subst( Qdb_Qddfvcpr.Qddfvcpv
                             : 1
                             : Qdb_Qddfvcpr.Qddfvcpl
                             );

              If  ValIdx < Qdb_Qddfvcst.Qddfvcnump;
                pQdb_Qddfvcpr = pQdb_Qddfvcpr + 16 + Qdb_Qddfvcpr.Qddfvcpl;
              EndIf;
            EndFor;

            ExSr  PrtHdrLin;

            Except  DtlLin2;

            If  ChkIdx < Qdb_Qddfvchk.Qddfvcnume;
              pQdb_Qddfvcpr = %Addr( Qdb_Qddfvcst.Qddfvcpm );
              pQdb_Qddfvcst = pQdb_Qddfvcst + Qdb_Qddfvcst.Qddfvcel;
            EndIf;
          EndFor;

        EndSr;

        BegSr  PrtKeyFld;

          ExSr  PrtHdrLin;

          SpcTxt = AccPth + '  ' + KeyTyp;

          Except  HdrKey;
          Except  SpcLin;

          For KeyIdx = 1  To %Elem( KeyFld );

            If  KeyFld(KeyIdx) = *Blank;
              Leave;
            EndIf;

            ExSr  PrtHdrLin;

            SpcTxt = %Char( KeyIdx ) + '  ' + KeyFld(KeyIdx);
            Except  SpcLin;

          EndFor;

        EndSr;

        BegSr  PrtSltStm;

          If  FilTyp = 'LF';

            ExSr  PrtHdrLin;
            Except  HdrSlt;

            If  SltStm(1) = *Blank;
              SpcTxt = '*NONE';
              Except  SpcLin;

            Else;
              For SltIdx = 1  To %Elem( SltStm );

                If  SltStm(SltIdx) = *Blank;
                  Leave;
                EndIf;

                ExSr  PrtHdrLin;

                SpcTxt = SltStm(SltIdx);
                Except  SpcLin;

              EndFor;
            EndIf;
          EndIf;

        EndSr;

        BegSr  GetKeyFlds;

          If  Qdb_Qdbfh.Qdbfpact = 'KU';
            KeyTyp = '*UNIQUE';
          EndIf;

          pQdb_Qdbfk = pQdb_Qdbfh + Qdb_Qdbfb.Qdbfksof;

          For  KeyIdx = 1  To Qdb_Qdbfb.Qdbfbgky;

            KeyFld(KeyIdx) = Qdb_Qdbfk.Qdbfkfld;

            If KeyIdx < Qdb_Qdbfb.Qdbfbgky;
              pQdb_Qdbfk = pQdb_Qdbfk + %Size( Qdb_Qdbfk );
            EndIf;

          EndFor;

        EndSr;

        BegSr  GetSltOmit;

          pQdb_Qdbfss = pQdb_Qdbfh + Qdb_Qdbfb.Qdbfsoof;

          For  SltIdx = 1  To Qdb_Qdbfb.Qdbfsoon;

            If  Qdb_Qdbfss.Qdbfssop <> 'AL';

              SltStm(SltIdx) = Qdb_Qdbfss.Qdbfssso + '  ' +
                               Qdb_Qdbfss.Qdbfssfn + ' '  +
                               SltKwdA( %Lookup( Qdb_Qdbfss.Qdbfssop
                                               : SltCodA
                                               ));

              pQdb_Qdbfsp = pQdb_Qdbfh + Qdb_Qdbfss.Qdbfsoso;

              For  ValIdx = 1  To Qdb_Qdbfss.Qdbfsspnum;

                SltStm(SltIdx) = SltStm(SltIdx) + ' ' +
                                 %Subst( Qdb_Qdbfsp.Qdbfspvl
                                       : 1
                                       : Qdb_Qdbfsp.Qdbfspln - 20
                                       );

                If ValIdx < Qdb_Qdbfss.Qdbfsspnum;
                  pQdb_Qdbfsp = pQdb_Qdbfh + Qdb_Qdbfsp.Qdbfspno;
                EndIf;

              EndFor;
            EndIf;

            If SltIdx < Qdb_Qdbfb.Qdbfsoon;
              pQdb_Qdbfss = pQdb_Qdbfss + %Size( Qdb_Qdbfss );
            EndIf;

          EndFor;

        EndSr;

        BegSr  PrtDtlLin;

          ExSr  PrtHdrLin;

          Clear  OutDtl;

          FldNam = Qdb_Qddffld.Qddfflde;
          FldTyp = TypTxtA( %Lookup( Qdb_Qddffld.Qddfftyp
                                   : TypHexA
                                   ));

          KeyIdx = %Lookup( FldNam: KeyFld );

          If  KeyIdx > *Zero;
            KeySeq = %Char( KeyIdx );

            If  KeyTyp = '*UNIQUE';
              %Subst( KeySeq: %Size( KeySeq ): 1 ) = 'U';
            EndIf;
          EndIf;

          BufPos = Qdb_Qddffld.Qddffobo + 1;
          FldLen = Qdb_Qddffld.Qddffldb;

          If  Qdb_Qddffld.Qddffldd > *Zero;
            EvalR  FldDig = %Char( Qdb_Qddffld.Qddffldd );
            EvalR  FldDec = %Char( Qdb_Qddffld.Qddffldp );
          EndIf;

          If  pQdb_Qddfftxt <> *Null;
            FldTxt = Qdb_Qddfftxt.Qddfftst;
          EndIf;

          If  pQdb_Qddfcolh <> *Null;
            FldHdg = Qdb_Qddfcolh.Qddfch1 + ' ' +
                     Qdb_Qddfcolh.Qddfch2 + ' ' +
                     Qdb_Qddfcolh.Qddfch3;
          EndIf;

          Except  DtlLin;

          If FldTxt <> FldHdg  And FldTxt > *Blanks;
            TxtLin2 = FldTxt;
            Except  DtlLin2;
          EndIf;

        EndSr;

        BegSr  PrtHdrLin;

          If  PrtInf.CurLin > PrtInf.OvfLin - 6  Or
              PrtInf.WrtCnt = *Zero;

            Except  Header;
          EndIf;

        EndSr;

        Begsr  *InzSr;

          Time   = Time;

          PrtInf.WrtCnt = *Zero;
          PrtInf.CurLin = *Zero;

        EndSr;

      /End-Free
     **-- Print file definition:
     OQSYSPRT   EF           Header         2  3
     O                       UDATE         Y      8
     O                       Time                18 '  :  :  '
     O                                           74 'Print file field descrip-
     O                                              tion'
     O                                          107 'Program:'
     O                       PsPgmNam           118
     O                                          126 'Page:'
     O                       PAGE             +   1
     OQSYSPRT   EF           Header         1
     O                                           16 'File . . . . . :'
     O                       FilNam              28
     O                                           56 'Record format . . . :'
     O                       RcdFmt              68
     O                                           96 'Record length . . . :'
     O                       RcdLen        3    103
     OQSYSPRT   EF           Header         2
     O                                           16 '  Library  . . :'
     O                       LibNam              28
     O                                           56 'File type . . . . . :'
     O                       FilTyp              68
     O                                           96 'Record field count  :'
     O                       FldCnt        3    103
     OQSYSPRT   EF           Header         1
     O                                           10 'Field name'
     O                                           22 'Field type'
     O                                           30 'Buffer'
     O                                           38 'Length'
     O                                           46 'Digits'
     O                                           52 'Dec.'
     O                                           57 'Key'
     O                                           93 'Column heading/text/check -
     O                                              values'
     **
     OQSYSPRT   EF           DtlLin         1
     O                       FldNam              10
     O                       FldTyp              22
     O                       BufPos        3     29
     O                       FldLen        3     36
     O                       FldDig              44
     O                       FldDec              50
     O                       KeySeq              58
     O                       FldHdg             123
     **
     OQSYSPRT   EF           DtlLin2        1
     O                       TxtLin2            131
     **
     OQSYSPRT   EF           HdrKey      1
     O                                           31 'Access path . . . . . . . -
     O                                              . . :'
     **
     OQSYSPRT   EF           HdrSlt      1
     O                                           31 'Select/omit statements  . -
     O                                              . . :'
     **
     OQSYSPRT   EF           SpcLin         1
     O                       SpcTxt             131

     **-- Send escape message:  ----------------------------------------------**
     P SndEscMsg       B
     D                 Pi            10i 0
     D  PxMsgId                       7a   Const
     D  PxMsgF                       10a   Const
     D  PxMsgDta                    512a   Const  Varying
     **
     D MsgKey          s              4a

      /Free

        SndPgmMsg( PxMsgId
                 : PxMsgF + '*LIBL'
                 : PxMsgDta
                 : %Len( PxMsgDta )
                 : '*ESCAPE'
                 : '*PGMBDY'
                 : 1
                 : MsgKey
                 : ERRC0100
                 );

        If  ERRC0100.BytAvl > *Zero;
          Return  -1;

        Else;
          Return   0;
        EndIf;

      /End-Free

     P SndEscMsg       E
     **-- Send message by type:  ---------------------------------------------**
     P SndMsgTyp       B
     D                 Pi            10i 0
     D  PxMsgDta                    512a   Const  Varying
     D  PxMsgTyp                     10a   Const
     **
     D MsgKey          s              4a

      /Free

        SndPgmMsg( 'CPF9897'
                 : 'QCPFMSG   *LIBL'
                 : PxMsgDta
                 : %Len( PxMsgDta )
                 : PxMsgTyp
                 : '*PGMBDY'
                 : 1
                 : MsgKey
                 : ERRC0100
                 );

        If  ERRC0100.BytAvl > *Zero;
          Return  -1;

        Else;
          Return   0;
        EndIf;

      /End-Free

     P SndMsgTyp       E
Command
/*-------------------------------------------------------------------*/
/*                                                                   */
/*  Compile options:                                                 */
/*                                                                   */
/*    CrtCmd Cmd( PRTFFD )                                           */
/*           Pgm( CBX123 )                                           */
/*           SrcMbr( CBX123X )                                       */
/*           HlpPnlGrp( CBX123H )                                    */
/*           HlpId( *CMD )                                           */
/*                                                                   */
/*-------------------------------------------------------------------*/
        Cmd      Prompt( 'Print File Field Description' )


        Parm     FILE          Q0001             +
                 Min( 1 )                        +
                 File( *UNSPFD )                 +
                 Choice( *NONE )                 +
                 Prompt( 'File' )

        Parm     RCDFMT        *Name             +
                 Dft( *FIRST )                   +
                 SpcVal(( *FIRST ))              +
                 Expr( *YES )                    +
                 Prompt( 'Record format' )


Q0001:  Qual                   *Name    10       +
                 Min( 1 )                        +
                 Expr( *YES )

        Qual                   *Name    10       +
                 Dft( *LIBL )                    +
                 SpcVal(( *LIBL )                +
                        ( *CURLIB ))             +
                 Expr( *YES )                    +
                 Prompt( 'Library' )
Panel group
.*-----------------------------------------------------------------------**
.*
.*  Compile options:
.*
.*    CrtPnlGrp PnlGrp( CBX123H )
.*              SrcFile( QPNLSRC )
.*              SrcMbr( *PNLGRP )
.*
.*-----------------------------------------------------------------------**
:PNLGRP.
:HELP NAME='PRTFFD'.Print file field description - Help
:P.
The Print File Field Description (PRTFFD) command prints database file
field-level information for the specified file.  This information
includes data type, length, buffer position and check values as well as
key field specification and, for logical files, any select/omit criteria
specification.
:P.
:EHELP.
:HELP NAME='PRTFFD/FILE'.File (FILE) - Help
:XH3.File (FILE)
:P.
Specifies the name and library of the database file for which to print
the field information.
:P.
This is a required parameter.
:P.
:XH3.Library
:P.
Specify the name of the library where the database file is located.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*LIBL:EPK.
:PD.
All libraries in the job's library list are searched until the first
match is found.
:PT.:PK.*CURLIB:EPK.
:PD.
The current library for the job is searched.  If no library is
specified as the current library for the job, the QGPL library is used.
:PT.:PV.library-name:EPV.
:PD.
Specify the name of the library to qualify the file name.
:EPARML.
:EHELP.
:HELP NAME='PRTFFD/RCDFMT'.Record format (RCDFMT) - Help
:XH3.Record format (RCDFMT)
:P.
If a logical file having more than one record format was specified as
the file name, this parameter is used to identify the record format
that you want used when retrieving the field information.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*FIRST:EPK.
:PD.
The first record format found will be used to identify the file record
format.
:PT.:PV.record-format-name:EPV.
:PD.
Specify the name of the record format to use.
:EPARML.
:EHELP.
:EPNLGRP.

Thanks to Carsten Flensburg writing for
Club Tech iSeries Programming Tips Newsletter
Back

QUSCRTUI
Create User Index

/*-------------------------------------------------------------------*/
/*                                                                   */
/*  Command . . : CRTUSRIDX                                          */
/*  Description : Create user index command                          */
/*  Author  . . : Carsten Flensburg                                  */
/*  Published . : Club Tech iSeries Programming Tips Newsletter      */
/*  Date  . . . : September 23, 2004                                 */
/*                                                                   */
/*                                                                   */
/*  Command processing API:                                          */
/*    QUSCRTUI     Create user index    Creates a user index object  */
/*                                      in either the user domain    */
/*                                      or the system domain.        */
/*                                                                   */
/*                                                                   */
/*  Programmer's notes:                                              */
/*    On pre-V5R2 systems the IDXSIZOPT parameter is not supported.  */
/*                                                                   */
/*    An upcoming issue of APIs by Example will demonstrate the use  */
/*    of some of the user index APIs in RPG/IV.                      */
/*                                                                   */
/*                                                                   */
/*  Compile options:                                                 */
/*                                                                   */
/*    CrtCmd Cmd( CRTUSRIDX )                                        */
/*           Pgm( QUSCRTUI )                                         */
/*           SrcMbr( CBX124X )                                       */
/*           HlpPnlGrp( CBX124H )                                    */
/*           HlpId( *CMD )                                           */
/*                                                                   */
/*-------------------------------------------------------------------*/
             Cmd        Prompt( 'Create User Index' )

             Parm       USRIDX        Q0001                          +
                        Min( 1 )                                     +
                        Choice( *NONE )                              +
                        Prompt( 'User index' 1 )

             Parm       EXTATR        *Name     10                   +
                        Dft( *NONE )                                 +
                        SpcVal(( *NONE ' ' ))                        +
                        Expr( *YES )                                 +
                        Prompt( 'Extended attribute'  2 )

             Parm       ENTLENATR     *Char      1                   +
                        Rstd( *YES )                                 +
                        Dft( *FIXED )                                +
                        SpcVal(( *FIXED 'F' ) ( *VARYING 'V' ))      +
                        Expr( *YES )                                 +
                        Prompt( 'Entry length attribute' 3 )

             Parm       ENTLEN        *Int4                          +
                        Range( 1  2000 )                             +
                        SpcVal(( *SHORT 0 ) ( *MAX -1 ))             +
                        Expr( *YES )                                 +
                        Prompt( 'Entry length' 4 )

             Parm       SEQ           *Char      1                   +
                        Rstd( *YES )                                 +
                        Dft( *NONE )                                 +
                        SpcVal(( *NONE '0' ) ( *KEYED '1' ))         +
                        Expr( *YES )                                 +
                        Prompt( 'Sequence' 5 )

             Parm       KEYLEN        *Int4                          +
                        Range( 1  2000 )                             +
                        Expr( *YES )                                 +
                        PmtCtl( P0001 )                              +
                        Prompt( 'Key length' 6 )

             Parm       FORCE         *Char      1                   +
                        Rstd( *YES )                                 +
                        Dft( *NO )                                   +
                        SpcVal(( *NO '0' ) ( *YES '1' ))             +
                        Expr( *YES )                                 +
                        Prompt( 'Force to auxiliary storage' 7 )

             Parm       IDXOPZ        *Char      1                   +
                        Rstd( *YES )                                 +
                        Dft( *RANDOM )                               +
                        SpcVal(( *RANDOM '0' ) ( *SEQ '1' ))         +
                        Expr( *YES )                                 +
                        Prompt( 'Index optimization' 8 )

             Parm       AUT           *Name     10                   +
                        Dft( *LIBCRTAUT )                            +
                        SpcVal(( *LIBCRTAUT )                        +
                               ( *CHANGE )                           +
                               ( *ALL )                              +
                               ( *USE )                              +
                               (*EXCLUDE ))                          +
                        Expr( *YES )                                 +
                        PmtCtl( *PMTRQS )                            +
                        Prompt( 'Authority' 9 )

             Parm       TEXT          *Char     50                   +
                        Dft( *BLANK )                                +
                        SpcVal(( *BLANK '' ))                        +
                        Expr( *YES )                                 +
                        Prompt( 'Text ''description''' 10 )

             Parm       REPLACE       *Char     10                   +
                        Rstd( *YES )                                 +
                        Dft( *YES )                                  +
                        SpcVal(( *YES ) ( *NO ))                     +
                        Expr( *YES )                                 +
                        PmtCtl( *PMTRQS )                            +
                        Prompt( 'Replace' 11 )

             Parm       ERROR         *Int4                          +
                        Constant( 0 )

             Parm       DOMAIN        *Char     10                   +
                        Rstd( *YES )                                 +
                        Dft( *DEFAULT )                              +
                        SpcVal(( *DEFAULT ) ( *SYSTEM ) ( *USER ))   +
                        Expr( *YES )                                 +
                        PmtCtl( *PMTRQS )                            +
                        Prompt( 'Domain' 12 )

             Parm       USGTRK        *Char      1                   +
                        Rstd( *YES )                                 +
                        Dft( *NO )                                   +
                        SpcVal(( *NO '0' ) ( *YES '1' ))             +
                        Expr( *YES )                                 +
                        PmtCtl( *PMTRQS )                            +
                        Prompt( 'Usage tracking' 13 )

             Parm       IDXSIZOPT     *Char      1                   +
                        Rstd( *YES )                                 +
                        Dft( *MAX4GB )                               +
                        SpcVal(( *MAX4GB '0' ) ( *MAX1TB '1' ))      +
                        Expr( *YES )                                 +
                        PmtCtl( *PMTRQS )                            +
                        Prompt( 'Index size option' 14 )

 Q0001:      Qual                     *Name     10                   +
                        Min( 1 )                                     +
                        Expr( *YES )

             Qual                     *NAME     10                   +
                        Dft( *CURLIB )                               +
                        SpcVal(( *CURLIB ))                          +
                        Expr( *YES )                                 +
                        Prompt( 'Library' )

 P0001:      PmtCtl     Ctl( SEQ )                                   +
                        Cond(( *EQ '1' ))

             Dep        Ctl( &SEQ *NE '1' )                          +
                        Parm(( KEYLEN ))                             +
                        NbrTrue( *EQ  0 )                            +
                        MsgId( CPD9501 )

             Dep        Ctl( &SEQ *EQ '1' )                          +
                        Parm(( KEYLEN ))                             +
                        MsgId( CPD9502 )
Panel group
.*-----------------------------------------------------------------------**
.*
.*  Compile options:
.*
.*    CrtPnlGrp PnlGrp( CBX124H )
.*              SrcFile( QPNLSRC )
.*              SrcMbr( *PNLGRP )
.*
.*-----------------------------------------------------------------------**
:PNLGRP.
:HELP NAME='CRTUSRIDX'.Create User Index - Help
:P.
The Create User Index (CRTUSRIDX) command creates a user index and
stores it in either the user domain or the system domain.
:P.
A system-domain user index cannot be saved to a release prior to
Version 2 Release 3 Modification 0. A user-domain user index can be
directly manipulated with MI instructions and can also be accessed
using system APIs at all security levels.
:P.
:NT.
If the user index is larger than 4 gigabytes, it cannot be saved to a
release prior to Version 5 Release 2 Modification 0.
:ENT.
:P.
:NT.
For performance reasons, the *USRIDX object is created before checking
to see if it exists in the library specified for the qualified user
index name. If you have an application using this API repeatedly, even
if you are using *NO for the replace parameter, permanent system
addresses will be used.
:ENT.
:P.
:XH3.&MSG(CPX0005,QCPFMSG). CRTUSRIDX
:IMHELP NAME='CRTUSRIDX/ERROR/MESSAGES'.
:EHELP.
:HELP NAME='CRTUSRIDX/ERROR/MESSAGES'.&MSG(CPX0005,QCPFMSG).CRTUSRIDX - Help
:P.
:HP3.*ESCAPE &MSG(CPX0006,QCPFMSG).:EHP3.
:DL COMPACT.
:DT.CPF2143:DD.&MSG(CPF2143,QCPFMSG).
:DT.CPF2144:DD.&MSG(CPF2144,QCPFMSG).
:DT.CPF2283:DD.&MSG(CPF2283,QCPFMSG).
:DT.CPF24B4:DD.&MSG(CPF24B4,QCPFMSG).
:DT.CPF3CF1:DD.&MSG(CPF3CF1,QCPFMSG).
:DT.CPF3CF2:DD.&MSG(CPF3CF2,QCPFMSG).
:DT.CPF3C0A:DD.&MSG(CPF3C0A,QCPFMSG).
:DT.CPF3C0B:DD.&MSG(CPF3C0B,QCPFMSG).
:DT.CPF3C0C:DD.&MSG(CPF3C0C,QCPFMSG).
:DT.CPF3C0D:DD.&MSG(CPF3C0D,QCPFMSG).
:DT.CPF3C0E:DD.&MSG(CPF3C0E,QCPFMSG).
:DT.CPF3C03:DD.&MSG(CPF3C03,QCPFMSG).
:DT.CPD3C01:DD.&MSG(CPD3C01,QCPFMSG).
:DT.CPD3C02:DD.&MSG(CPD3C02,QCPFMSG).
:DT.CPD3C03:DD.&MSG(CPD3C03,QCPFMSG).
:DT.CPD3C05:DD.&MSG(CPD3C05,QCPFMSG).
:DT.CPD3C0A:DD.&MSG(CPD3C0A,QCPFMSG).
:DT.CPD3C0B:DD.&MSG(CPD3C0B,QCPFMSG).
:DT.CPD3C0C:DD.&MSG(CPD3C0C,QCPFMSG).
:DT.CPD3C0D:DD.&MSG(CPD3C0D,QCPFMSG).
:DT.CPD3C0E:DD.&MSG(CPD3C0E,QCPFMSG).
:DT.CPF3C2A:DD.&MSG(CPF3C2A,QCPFMSG).
:DT.CPF3C2B:DD.&MSG(CPF3C2B,QCPFMSG).
:DT.CPF3C2D:DD.&MSG(CPF3C2D,QCPFMSG).
:DT.CPF3C29:DD.&MSG(CPF3C29,QCPFMSG).
:DT.CPF3C34:DD.&MSG(CPF3C34,QCPFMSG).
:DT.CPF3C36:DD.&MSG(CPF3C36,QCPFMSG).
:DT.CPF3C45:DD.&MSG(CPF3C45,QCPFMSG).
:DT.CPF3C49:DD.&MSG(CPF3C49,QCPFMSG).
:DT.CPF3C90:DD.&MSG(CPF3C90,QCPFMSG).
:DT.CPF3C93:DD.&MSG(CPF3C93,QCPFMSG).
:DT.CPF3C95:DD.&MSG(CPF3C95,QCPFMSG).
:DT.CPF8100:DD.All CPF81xx messages could be returned. xx is from 01 to FF.
:DT.CPF9810:DD.&MSG(CPF9810,QCPFMSG).
:DT.CPF9820:DD.&MSG(CPF9820,QCPFMSG).
:DT.CPF9830:DD.&MSG(CPF9830,QCPFMSG).
:DT.CPF9838:DD.&MSG(CPF9838,QCPFMSG).
:DT.CPF9870:DD.&MSG(CPF9870,QCPFMSG).
:DT.CPF9872:DD.&MSG(CPF9872,QCPFMSG).
:EDL.
:EHELP.
:HELP NAME='CRTUSRIDX/USRIDX'.User index (USRIDX) - Help
:XH3.User index (USRIDX)
:P.
Specifies the name and library of the user index being created.
:P.
This is a required parameter.
:P.
:XH3.Library
:P.
Defines the location of the user index.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*CURLIB:EPK.
:PD.
The current library for the job is used to locate the user index.  If
no current library entry exists in the library list, QGPL is used.
:PT.:PV.library-name:EPV.
:PD.
Specify the library where the user queue is located.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/EXTATR'.Extended attribute (EXTATR) - Help
:XH3.Extended attribute (EXTATR)
:P.
The extended attribute of the user index.  For example, an object type
of *FILE has an extended attribute of PF (physical file), LF (logical
file), DSPF (display file), SAVF (save file), and so on.
:P.
The extended attribute must be a valid *NAME.  You can enter this
parameter in uppercase, lowercase, or mixed case.  The command
automatically converts it to uppercase.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*NONE:EPK.
:PD.
No extended attribute is assigned to the user queue.
:PT.:PV.extended-attribute-name:EPV.
:PD.
Specify a name to be used as the extended attribute for the user queue
object.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/ENTLENATR'.Entry length attribute (ENTLENATR) - Help
:XH3.Entry length attribute (ENTLENATR)
:P.
Specifies Whether there are fixed-length or variable-length entries in
the user index.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*FIXED:EPK.
:PD.
The user index entries have a fixed length.
:PT.:PK.*VARYING:EPK.
:PD.
The user index entries have a variable length.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/ENTLEN'.Entry length (ENTLEN) - Help
:XH3.Entry length (ENTLEN)
:P.
The length of entries in the index.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK.*SHORT:EPK.
:PD.
Enables a maximum entry length of 120 bytes and a key length from 1
through 120.
:PT.:PK.*MAX:EPK.
:PD.
Enables a maximum entry length of 2000 and a key length from 1 through
2000.
:PT.:PV.entry-length:EPV.
:PD.
The valid values for fixed-length entries are from 1 through 2000.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/SEQ'.Sequence (SEQ) - Help
:XH3.Sequence (SEQ)
:P.
Whether the inserts to the index are by key.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*NONE:EPK.
:PD.
Index entries are not inserted by key.
:PT.:PK.*KEYED:EPK.
:PD.
Index entries are inserted by key.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/KEYLEN'.Key length (KEYLEN) - Help
:XH3.Key length (KEYLEN)
:P.
The length in bytes of the index entry key from 1 to 2000 if you specify
the user index type as keyed.  If you specify that the user index is
not a keyed user index, the value must be 0.
:EHELP.
:HELP NAME='CRTUSRIDX/FORCE'.Force to auxiliary storage (FORCE) - Help
:XH3.Force to auxiliary storage (FORCE)
:P.
Whether the updates to the index are written synchronously to auxiliary
storage on each update to the index.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*NO:EPK.
:PD.
Updates to index entries are not immediately forced to auxiliary
storage.
:PT.:PK.*YES:EPK.
:PD.
Updates to index entries are immediately forced to auxiliary
storage.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/IDXOPZ'.Index optimization (IDXOPZ) - Help
:XH3.Index optimization (IDXOPZ)
:P.
Specifies the type of access in which to optimize the index.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*RANDOM:EPK.
:PD.
Optimize for random references.
:PT.:PK.*SEQ:EPK.
:PD.
Optimize for sequential references.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/AUT'.Authority (AUT) - Help
:XH3.Authority (AUT)
:P.
The authority you give to the users who do not have specific private or
group authority to the user index.  Once the user index has been
created, its public authority stays the same when it is moved to
another library or restored from backup media.
:NT.
If the replace parameter is used and a user index exists to be replaced,
this parameter is ignored.  All authorities are transferred from the
replaced user index to the new one.
:ENT.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*LIBCRTAUT:EPK.
:PD.
The public authority for the user index is taken from the CRTAUT value
for the target library when the object is created.  If the CRTAUT value
for the library changes later, that change does not affect user indexes
already created.  If the CRTAUT value contains an authorization list
name and that authorization list secures an object, do not delete the
list.  If you do, the next time you run this command with the *LIBCRTAUT
parameter, it will fail.
:PT.:PK.*CHANGE:EPK.
:PD.
The user has read, add, update, and delete authority to the user index
and can read the object description.
:PT.:PK.*ALL:EPK.
:PD.
The user can perform all authorized operations on the user index.
:PT.:PK.*USE:EPK.
:PD.
The user can read the object description and the user index' contents
but cannot change them.
:PT.:PK.*EXCLUDE:EPK.
:PD.
The user cannot access the user index in any way.
:PT.:PV.authorization-list-name:EPV.
:PD.
The user index is secured by the specified authorization list, and its
public authority is set to *AUTL.  The specified authorization list must
exist on the system when this command is issued.  If it does not exist,
the create process fails, and an error message is returned to the
caller.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/TEXT'.Text 'description' (TEXT) - Help
:XH3.Text 'description' (TEXT)
:P.
Specifies text that briefly describes the user index.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*BLANK:EPK.
:PD.
No text is specified.
:PT.:PV.text-'description':EPV.
:PD.
Specify no more than 50 characters, enclosed in apostrophes.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/REPLACE'.Replace (REPLACE) - Help
:XH3.Replace (REPLACE)
:P.
Specifies whether to replace an existing user index.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*NO:EPK.
:PD.
Do not replace an existing user index of the same name and library.
:PT.:PK.*YES:EPK.
:PD.
Replace an existing user index of the same name and library.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/DOMAIN'.Domain (DOMAIN) - Help
:XH3.Domain (DOMAIN)
:P.
The domain into which the user index should be created.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*DEFAULT:EPK.
:PD.
Allows the system to decide into which domain the object should be
created.
:PT.:PK.*SYSTEM:EPK.
:PD.
Creates the user index object into the system domain. The API can
always create a user index into the system domain, regardless of the
security level running. However, if you are running at security level
40 or greater, you must use APIs to access system-domain user index
objects.
:PT.:PK.*USER:EPK.
:PD.
Attempts to create the user index object into the user domain. This is
not always possible. If the library you are creating the user index
into does not appear in the QALWUSRDMN system value, the API cannot
create the user index into the user domain. An error message will be
returned.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/USGTRK'.Usage tracking (USGTRK) - Help
:XH3.Usage tracking (USGTRK)
:P.
The usage tracking state. Usage tracking provides machine checkpoints
to improve availability of user indexes. If a user index is found to be
a state of partial change, it will be marked as damaged.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*NO:EPK.
:PD.
Do not track usage state.
:PT.:PK.*YES:EPK.
:PD.
Track usage state.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/IDXSIZOPT'.Index size option (IDXSIZOPT) - Help
:XH3.Index size option (IDXSIZOPT)
:P.
The maximum size of the user index.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*MAX4GB:EPK.
:PD.
The maximum size of the user index is 4 gigabytes.
:PT.:PK.*MAX1TB:EPK.
:PD.
The maximum size of the user index is 1 terabyte.
:EPARML.
:EHELP.
:EPNLGRP.

Thanks to Carsten Flensburg writing for
Club Tech iSeries Programming Tips Newsletter
Back

QUS.....
User Index APIs

     **
     **  Program . . : CBX125T
     **  Description : Demonstrating the use of a user index
     **  Author  . . : Carsten Flensburg
     **  Published . : Club Tech iSeries Programming Tips Newsletter
     **  Date  . . . : October 14, 2004
     **
     **
     **  Please note the explanation of the following user index attributes:
     **
     **  Number of entries added:
     **    The number of entries added to the user index.  The number of
     **    entries currently in the index can be obtained by subtracting the
     **    number of entries removed from the number of entries added.
     **
     **  Number of retrieve operations:
     **    The number of times either the FNDINXEN (find independent index
     **    entry) MI instruction or Retrieve User Index Entry (QUSRTVUI) API
     **    has been used on this user index.  The QUSRUIAT API or MATINXAT
     **    (materialize independent index attributes) MI instruction sets the
     **    number of retrieve operations to 0 after the retrieve or materialize
     **    is completed.
     **
     **
     **  To run this sample program compile it as described below, start a
     **  debug session, call it, and then step throug the program in the
     **  debugger:
     **
     **    StrDbg     Pgm( CBX125T ) - Press F10
     **
     **    Call       Pgm( CBX125T ) - Press F10 repeatedly
     **
     **
     **  Compile options:
     **
     **    CrtRpgMod  Module( CBX125T )
     **               DbgView( *LIST )
     **
     **    CrtPgm     Pgm( CBX125T )
     **               Module( CBX125T )
     **
     **
     **-- Control spec:  -----------------------------------------------------**
     H Option( *SrcStmt )
     **-- Api error data structure:
     D ERRC0100        Ds                  Qualified
     D  BytPrv                       10i 0 Inz( %Size( ERRC0100 ))
     D  BytAvl                       10i 0
     D  MsgId                         7a
     D                                1a
     D  MsgDta                      256a
     **-- Global variables:
     D CurNbrIdxE      s             10i 0
     **-- Key & entry definition:
     D IdxEnt          Ds                  Qualified
     D  Key                          24a   Inz( *All'Key' )
     D  EntDta                      512a   Inz( *All'Data' )
     **-- User index APIs parameters:
     D IDXE0100        Ds                  Qualified
     D  BytRtn                       10i 0
     D  BytAvl                       10i 0
     D  Entry                              Like( IdxEnt )
     **
     D EntLoc          Ds                  Qualified
     D  EntOfs                       10i 0
     D  EntLen                       10i 0
     **
     D RtnLib          s             10a
     D EntAdd          s             10i 0
     **
     D SchCri          s                   Like( IdxEnt.Key )
     D RmvCri          s                   Like( IdxEnt.Key )
     D EntNbrRtv       s             10i 0
     D EntNbrRmv       s             10i 0
     **
     D IDX_NAM_Q       c                   'USRIDX    QTEMP'
     D ENT_FIX         c                   'F'
     D UPD_IMD         c                   '1'
     D AUT_CHG         c                   '*CHANGE'
     D RPL_NO          c                   '*NO'
     D IDX_OPZ_SEQ     c                   '0'
     D KEY_INS_BYKEY   c                   '1'
     D DOM_DFT         c                   '*DEFAULT'
     **
     D ENT_SCH_EQ      c                   1
     D ENT_RMV_EQ      c                   1
     D ENT_LOC_IGN     c                   x'0000000000000000'
     D IDX_INS_RPL     c                   2
     D CRI_OFS_FIRST   c                   0
     D RMV_ENT_MAX     c                   4095
     D RTN_ENT_NONE    c                   0
     D RTN_ENT_SINGLE  c                   1
     **-- Retrieve user index attributes parameters:
     D IDXA0100        Ds                  Qualified
     D  BytRtn                       10i 0
     D  BytAvl                       10i 0
     D  IdxNam                       10a
     D  LibNam                       10a
     D  EntAtr                        1a
     D  IdxUpd                        1a
     D  KeyIns                        1a
     D  IdxOpz                        1a
     D                                4a
     D  EntLen                       10i 0
     D  EntLenMax                    10i 0
     D  KeyLen                       10i 0
     D  NbrEntAdd                    10i 0
     D  NbrEntRmv                    10i 0
     D  NbrRtvOpr                    10i 0
     **-- Create user index:
     D CrtUsrIdx       Pr                  ExtPgm( 'QUSCRTUI' )
     D  CxIdxNamQ                    20a   Const
     D  CxExtAtr                     10a   Const
     D  CxEntAtr                      1a   Const
     D  CxEntLen                     10i 0 Const
     D  CxKeyIns                      1a   Const
     D  CxKeyLen                     10i 0 Const
     D  CxIdxUpd                      1a   Const
     D  CxIdxOpz                      1a   Const
     D  CxPubAut                     10a   Const
     D  CxText                       50a   Const
     ** Optional 1:
     D  CxReplace                    10a   Const  Options( *NoPass )
     D  CxError                   32767a          Options( *NoPass: *VarSize )
     ** Optional 2:
     D  CxDomain                     10a   Const  Options( *NoPass )
     **-- Add user index entries:
     D AddUsrIdxE      Pr                  ExtPgm( 'QUSADDUI' )
     D  AxRtnLib                     10a
     D  AxEntAdd                     10i 0
     D  AxIdxNamQ                    20a   Const
     D  AxInsTyp                     10i 0 Const
     D  AxEntry                    2000a   Const  Options( *VarSize )
     D  AxEntLen                     10i 0 Const
     D  AxEntLoc                      8a   Const
     D  AxEntNbr                     10i 0 Const
     D  AxError                   32767a          Options( *VarSize )
     **-- Retrieve user index entries:
     D RtvUsrIdxE      Pr                  ExtPgm( 'QUSRTVUI' )
     D  RxRcvVar                   2008a          Options( *VarSize )
     D  RxRcvVarLen                  10i 0 Const
     D  RxEntLoc                   2000a          Options( *VarSize )
     D  RxEntLocLen                  10i 0 Const
     D  RxEntNbrRtv                  10i 0
     D  RxRtnLib                     10a
     D  RxIdxNamQ                    20a   Const
     D  RxFmtNam                     10a   Const
     D  RxMaxEnt                     10i 0 Const
     D  RxSchTyp                     10i 0 Const
     D  RxSchCri                   2000a   Const  Options( *Varsize )
     D  RxSchCriLen                  10i 0 Const
     D  RxSchCriOfs                  10i 0 Const
     D  RxError                   32767a          Options( *VarSize )
     **-- Remove user index entries:
     D RmvUsrIdxE      Pr                  ExtPgm( 'QUSRMVUI' )
     D  RmEntNbrRmv                  10i 0
     D  RmRcvVar                   2008a          Options( *VarSize )
     D  RmRcvVarLen                  10i 0 Const
     D  RmEntLoc                   2000a          Options( *VarSize )
     D  RmEntLocLen                  10i 0 Const
     D  RmRtnLib                     10a   Const
     D  RmIdxNamQ                    20a   Const
     D  RmFmtNam                     10a   Const
     D  RmMaxEnt                     10i 0 Const
     D  RmRmvTyp                     10i 0 Const
     D  RmRmvCri                   2000a   Const  Options( *Varsize )
     D  RmRmvCriLen                  10i 0 Const
     D  RmRmvCriOfs                  10i 0 Const
     D  RmError                   32767a          Options( *VarSize )
     **-- Retrieve user index attributes:
     D RtvUsrIdxA      Pr                  ExtPgm( 'QUSRUIAT' )
     D  RaRcvVar                     60a          Options( *VarSize )
     D  RaRcvVarLen                  10i 0 Const
     D  RaFmtNam                     10a   Const
     D  RaIdxNamQ                    20a   Const
     D  RaError                   32767a          Options( *VarSize )
     **-- Delete user index:
     D DltUsrIdx       Pr                  ExtPgm( 'QUSDLTUI' )
     D  DxIdxNamQ                    20a   Const
     D  DxError                   32767a          Options( *VarSize )
     **-- Get current number of entries:
     D GetCurNbrE      Pr            10i 0
     D  GnIdxNamQ                    20a   Const
     **
     **-- Mainline -----------------------------------------------------------**

      /Free

        CrtUsrIdx( IDX_NAM_Q
                 : *Blanks
                 : ENT_FIX
                 : %Size( IdxEnt )
                 : KEY_INS_BYKEY
                 : %Size( IdxEnt.Key )
                 : UPD_IMD
                 : IDX_OPZ_SEQ
                 : AUT_CHG
                 : *Blanks
                 : RPL_NO
                 : ERRC0100
                 : DOM_DFT
                 );

        //-- Check number of current entries:
        CurNbrIdxE = GetCurNbrE( IDX_NAM_Q );

        AddUsrIdxE( RtnLib
                  : EntAdd
                  : IDX_NAM_Q
                  : IDX_INS_RPL
                  : IdxEnt
                  : %Size( IdxEnt )
                  : ENT_LOC_IGN
                  : RTN_ENT_SINGLE
                  : ERRC0100
                  );

        //-- Check number of current entries:
        CurNbrIdxE = GetCurNbrE( IDX_NAM_Q );

        //-- Set retrieve key and clear receiver:
        SchCri = IdxEnt.Key;
        IdxEnt = *Blanks;

        RtvUsrIdxE( IDXE0100
                  : %Size( IDXE0100 )
                  : EntLoc
                  : %Size( EntLoc )
                  : EntNbrRtv
                  : RtnLib
                  : IDX_NAM_Q
                  : 'IDXE0100'
                  : 1
                  : ENT_SCH_EQ
                  : SchCri
                  : %Size( SchCri )
                  : CRI_OFS_FIRST
                  : ERRC0100
                  );

        //-- Confirm retrieved entry:
        IdxEnt = IDXE0100.Entry;

        SchCri = IdxEnt.Key;
        IdxEnt = *Blanks;

        RtvUsrIdxE( IDXE0100
                  : %Size( IDXE0100 )
                  : EntLoc
                  : %Size( EntLoc )
                  : EntNbrRtv
                  : RtnLib
                  : IDX_NAM_Q
                  : 'IDXE0100'
                  : 1
                  : ENT_SCH_EQ
                  : SchCri
                  : %Size( SchCri )
                  : CRI_OFS_FIRST
                  : ERRC0100
                  );

        IdxEnt = IDXE0100.Entry;

        //-- Set remove key:
        RmvCri = IdxEnt.Key;

        DoW  GetCurNbrE( IDX_NAM_Q ) > *Zero;

          RmvUsrIdxE( EntNbrRmv
                    : IDXE0100
                    : RTN_ENT_NONE
                    : EntLoc
                    : RTN_ENT_NONE
                    : RtnLib
                    : IDX_NAM_Q
                    : 'IDXE0100'
                    : RMV_ENT_MAX
                    : ENT_RMV_EQ
                    : RmvCri
                    : %Size( RmvCri )
                    : CRI_OFS_FIRST
                    : ERRC0100
                    );

        EndDo;

        DltUsrIdx( IDX_NAM_Q: ERRC0100 );

        *InLr = *On;
        Return;

      /End-Free

     **-- Get current number of entries:  ------------------------------------**
     P GetCurNbrE      B
     D                 Pi            10i 0
     D  GnIdxNamQ                    20a   Const

      /Free

        RtvUsrIdxA( IDXA0100
                  : %Size( IDXA0100 )
                  : 'IDXA0100'
                  : GnIdxNamQ
                  : ERRC0100
                  );

        If  ERRC0100.BytAvl > *Zero;
          Return  -1;

        Else;
          Return  IDXA0100.NbrEntAdd - IDXA0100.NbrEntRmv;
        EndIf;

      /End-Free

     P GetCurNbrE      E

Thanks to Carsten Flensburg writing for
Club Tech iSeries Programming Tips Newsletter
Back

Qp0lSetAttr & Qp0lGetAttr
Set IFS object attribute & Get IFS object attribute

     **
     **  Program . . : CBX127
     **  Description : Change IFS attributes - CPP
     **  Author  . . : Carsten Flensburg
     **  Published . : Club Tech iSeries Programming Tips Newsletter
     **  Date  . . . : November 18, 2004
     **
     **
     **
     **  Program summary
     **  ---------------
     **
     **  Unix type APIs:
     **    Qp0lSetAttr   Set IFS object        Changes the specified attribute
     **                  attribute             for the specified IFS object.
     **                                        Not all attributes are supported
     **                                        by all file systems.
     **
     **  MI builtins:
     **    _MEMMOVE      Copy memory           Copies a string from one pointer
     **                                        specified location to another.
     **
     **  Message handling API:
     **    QMHSNDPM      Send program message  Sends a message to a program stack
     **                                        entry (current, previous, etc.) or
     **                                        an external message queue.
     **
     **                                        Both messages defined in a message
     **                                        file and immediate messages can be
     **                                        used. For specific message types
     **                                        only one or the other is allowed.
     **
     **
     **  Programmer's notes:
     **    The following Qp0lSetAttr attribute-ID is supported as of V5R1 only:
     **
     **       27  QP0L_ATTR_CCSID          Coded characer set identifier
     **
     **    The following Qp0lSetAttr attribute-IDs are supported as of V5R2 only:
     **
     **       31  QP0L_ATTR_DISK_STG_OPT   How to allocate auxiliary storage
     **       32  QP0L_ATTR_MAIN_STG_OPT   How to allocate main storage
     **      301  QP0L_ATTR_SUID           Set effective user ID
     **      302  QP0L_ATTR_SGID           Set effective group ID
     **
     **
     **  Compile options:
     **    CrtRpgMod Module( CBX127 )
     **              DbgView( *LIST )
     **
     **    CrtPgm    Pgm( CBX127 )
     **              Module( CBX127 )
     **              ActGrp( *NEW )
     **
     **
     **-- Control specifications:  -------------------------------------------**
     H Option( *SrcStmt )  BndDir( 'QC2LE' )
     **-- API error information:
     D ERRC0100        Ds                  Qualified
     D  BytPro                       10i 0 Inz( %Size( ERRC0100 ))
     D  BytAvl                       10i 0
     D  MsgId                         7a
     D                                1a
     D  MsgDta                      256a
     **-- Global variables:
     D MsgKey          s              4a
     **-- Object attributes:
     D QP0L_ATTR_CREATE_TIME...
     D                 c                   4
     D QP0L_ATTR_ACCESS_TIME...
     D                 c                   5
     D QP0L_ATTR_MODIFY_TIME...
     D                 c                   7
     D QP0L_ATTR_PC_READ_ONLY...
     D                 c                   17
     D QP0L_ATTR_PC_HIDDEN...
     D                 c                   18
     D QP0L_ATTR_PC_SYSTEM...
     D                 c                   19
     D QP0L_ATTR_PC_ARCHIVE...
     D                 c                   20
     D QP0L_ATTR_SYSTEM_ARCHIVE...
     D                 c                   21
     D QP0L_ATTR_CODEPAGE...
     D                 c                   22
     D QP0L_ATTR_ALWCKPWRT...
     D                 c                   26
     D QP0L_ATTR_CCSID...
     D                 c                   27
     D QP0L_ATTR_DISK_STG_OPT...
     D                 c                   31
     D QP0L_ATTR_MAIN_STG_OPT...
     D                 c                   32
     D QP0L_ATTR_RESET_DATE...
     D                 c                   200
     D QP0L_ATTR_SUID  c                   300
     D QP0L_ATTR_SGID  c                   301
     **-- File attribute constants:
     D QP0L_PC_NOT_READONLY...
     D                 c                   x'00'
     D QP0L_PC_READONLY...
     D                 c                   x'01'
     D QP0L_PC_NOT_HIDDEN...
     D                 c                   x'00'
     D QP0L_PC_HIDDEN...
     D                 c                   x'01'
     D QP0L_PC_NOT_SYSTEM...
     D                 c                   x'00'
     D QP0L_PC_SYSTEM...
     D                 c                   x'01'
     D QP0L_PC_NOT_CHANGED...
     D                 c                   x'00'
     D QP0L_PC_CHANGED...
     D                 c                   x'01'
     D QP0L_SYSTEM_NOT_CHANGED...
     D                 c                   x'00'
     D QP0L_SYSTEM_CHANGED...
     D                 c                   x'01'
     D QP0L_NOT_ALWCKPWRT...
     D                 c                   x'00'
     D QP0L_ALWCKPWRT...
     D                 c                   x'01'
     D QP0L_STG_NORMAL...
     D                 c                   x'00'
     D QP0L_STG_MINIMIZE...
     D                 c                   x'01'
     D QP0L_STG_DYNAMIC...
     D                 c                   x'02'
     D QP0L_SUID_OFF   c                   x'00'
     D QP0L_SUID_ON    c                   x'01'
     D QP0L_SGID_OFF   c                   x'00'
     D QP0L_SGID_ON    c                   x'01'

     **- Set attribute:
     D SetAtr          Pr            10i 0 ExtProc( 'Qp0lSetAttr' )
     D  SaPthNam                       *   Value
     D  SaAtrLst                       *   Value
     D  SaBufSizPrv                  10u 0 Value
     D  SaFlwSymLnk                  10u 0 Value
     D  SaDots                       10i 0 Options( *NoPass )
     **-- Error number:
     D sys_errno       Pr              *    ExtProc( '__errno' )
     **-- Error string:
     D sys_strerror    Pr              *    ExtProc( 'strerror' )
     D  errno                        10i 0  Value
     **-- Copy memory:
     D memcpy          Pr              *   ExtProc( '_MEMMOVE' )
     D pOutMem                         *   Value
     D pInpMem                         *   Value
     D iMemSiz                       10u 0 Value
     **-- Send program message:
     D SndPgmMsg       Pr                  ExtPgm( 'QMHSNDPM' )
     D  SpMsgId                       7a   Const
     D  SpMsgFq                      20a   Const
     D  SpMsgDta                    128a   Const
     D  SpMsgDtaLen                  10i 0 Const
     D  SpMsgTyp                     10a   Const
     D  SpCalStkE                    10a   Const  Options( *VarSize )
     D  SpCalStkCtr                  10i 0 Const
     D  SpMsgKey                      4a
     D  SpError                   32767a          Options( *VarSize )

     **-- Change IFS attribute:  ---------------------------------------------**
     D ChgIfsAtr       Pr            10i 0
     D  PxIfsObj                   5002a   Const  Varying
     D  PxAtrId                      10i 0 Const
     D  PxAtrVal_p                     *   Value
     D  PxAtrSiz                     10i 0 Const
     **-- Send diagnostic message:
     D SndDiagMsg      Pr            10i 0
     D  PxMsgDta                    512a   Const  Varying
     **-- Send escape message:
     D SndEscMsg       Pr            10i 0
     D  PxMsgDta                    512a   Const  Varying
     **-- Send completion message:
     D SndCmpMsg       Pr            10i 0
     D  PxMsgDta                    512a   Const  Varying
     **-- Error identification:
     D errno           Pr            10i 0
     D strerror        Pr           128a   Varying

     **-- Entry parameters:
     D CBX127          Pr
     D  PxIfsObj                   5002a   Varying
     D  PxFlwSymLnk                  10i 0
     D  PxRdOnly                      1a
     D  PxHidden                      1a
     D  PxPcSys                       1a
     D  PxPcArc                       1a
     D  PxSysArc                      1a
     D  PxAlwCkpWrt                   1a
     D  PxCcsId                      10i 0
     D  PxDiskStgOpt                  1a
     D  PxMainStgOpt                  1a
     D  PxSetEuid                     1a
     D  PxSetEgid                     1a
     **
     D CBX127          Pi
     D  PxIfsObj                   5002a   Varying
     D  PxFlwSymLnk                  10i 0
     D  PxRdOnly                      1a
     D  PxHidden                      1a
     D  PxPcSys                       1a
     D  PxPcArc                       1a
     D  PxSysArc                      1a
     D  PxAlwCkpWrt                   1a
     D  PxCcsId                      10i 0
     D  PxDiskStgOpt                  1a
     D  PxMainStgOpt                  1a
     D  PxSetEuid                     1a
     D  PxSetEgid                     1a

      /Free

        If  PxCcsId > *Zero;

          ChgIfsAtr( PxIfsObj
                   : QP0L_ATTR_CCSID
                   : %Addr( PxCcsId )
                   : %Size( PxCcsId )
                   );
        EndIf;

        If  PxRdOnly < x'FF';

          ChgIfsAtr( PxIfsObj
                   : QP0L_ATTR_PC_READ_ONLY
                   : %Addr( PxRdOnly )
                   : %Size( PxRdOnly )
                   );
        EndIf;

        If  PxHidden < x'FF';

          ChgIfsAtr( PxIfsObj
                   : QP0L_ATTR_PC_HIDDEN
                   : %Addr( PxHidden )
                   : %Size( PxHidden )
                   );
        EndIf;


        If  PxPcSys < x'FF';

          ChgIfsAtr( PxIfsObj
                   : QP0L_ATTR_PC_SYSTEM
                   : %Addr( PxPcSys )
                   : %Size( PxPcSys )
                   );
        EndIf;

        If  PxPcArc < x'FF';

          ChgIfsAtr( PxIfsObj
                   : QP0L_ATTR_PC_ARCHIVE
                   : %Addr( PxPcArc )
                   : %Size( PxPcArc )
                   );
        EndIf;

        If  PxSysArc < x'FF';

          ChgIfsAtr( PxIfsObj
                   : QP0L_ATTR_SYSTEM_ARCHIVE
                   : %Addr( PxSysArc )
                   : %Size( PxSysArc )
                   );
        EndIf;

        If  PxAlwCkpWrt < x'FF';

          ChgIfsAtr( PxIfsObj
                   : QP0L_ATTR_ALWCKPWRT
                   : %Addr( PxAlwCkpWrt )
                   : %Size( PxAlwCkpWrt )
                   );
        EndIf;

        If  PxDiskStgOpt < x'FF';

          ChgIfsAtr( PxIfsObj
                   : QP0L_ATTR_DISK_STG_OPT
                   : %Addr( PxDiskStgOpt )
                   : %Size( PxDiskStgOpt )
                   );
        EndIf;

        If  PxMainStgOpt < x'FF';

          ChgIfsAtr( PxIfsObj
                   : QP0L_ATTR_MAIN_STG_OPT
                   : %Addr( PxMainStgOpt )
                   : %Size( PxMainStgOpt )
                   );
        EndIf;

        If  PxSetEuid < x'FF';

          ChgIfsAtr( PxIfsObj
                   : QP0L_ATTR_SUID
                   : %Addr( PxSetEuid )
                   : %Size( PxSetEuid )
                   );
        EndIf;

        If  PxSetEgid < x'FF';

          ChgIfsAtr( PxIfsObj
                   : QP0L_ATTR_SGID
                   : %Addr( PxSetEgid )
                   : %Size( PxSetEgid )
                   );
        EndIf;

        *InLr = *On;
        Return;

      /End-Free

     **-- Change IFS attribute:  ---------------------------------------------**
     P ChgIfsAtr       B
     D                 Pi            10i 0
     D  PxIfsObj                   5002a   Const  Varying
     D  PxAtrId                      10i 0 Const
     D  PxAtrVal_p                     *   Value
     D  PxAtrSiz                     10i 0 Const
     **-- API Path constants:
     D CUR_CCSID       c                   0
     D CUR_CTRID       c                   x'0000'
     D CUR_LNGID       c                   x'000000'
     D CHR_DLM_1       c                   0
     **-- API path:
     D Path            Ds                  Qualified  Align
     D  CcsId                        10i 0 Inz( CUR_CCSID )
     D  CtrId                         2a   Inz( CUR_CTRID )
     D  LngId                         3a   Inz( CUR_LNGID )
     D                                3a   Inz( *Allx'00' )
     D  PthTypI                      10i 0 Inz( CHR_DLM_1 )
     D  PthNamLen                    10i 0
     D  PthNamDlm                     2a   Inz( '/ ' )
     D                               10a   Inz( *Allx'00' )
     D  PthNam                     5000a
     **- Set attribute buffer:
     D Buffer          Ds                  Qualified  Align
     D  OfsNxtAtr                    10u 0
     D  AtrId                        10u 0
     D  SizAtr                       10u 0
     D                                4a   Inz( *Allx'00' )
     D  AtrDta                      128a

      /Free

        Path.PthNam    = PxIfsObj;
        Path.PthNamLen = %Len( PxIfsObj );

        Buffer.OfsNxtAtr = 0;
        Buffer.AtrId     = PxAtrId;
        Buffer.SizAtr    = PxAtrSiz;

        memcpy( %Addr( Buffer.AtrDta ): PxAtrVal_p: PxAtrSiz );

        If  SetAtr( %Addr( Path )
                  : %Addr( Buffer )
                  : %Size( Buffer )
                  : PxFlwSymLnk
                  ) < *Zero;

          SndDiagMsg( %Char( errno ) + ': ' + strerror );
          SndEscMsg( 'CHGIFSATR command ended in error' );

        Else;

          SndCmpMsg( 'IFS object attribute changed.' );
        EndIf;

        Return *Zero;

      /End-Free

     **
     P ChgIfsAtr       E
     **-- Get runtime error number:  -----------------------------------------**
     P errno           B
     D                 Pi            10i 0
     **
     D Error           s             10i 0  Based( pError )  NoOpt

      /Free

        pError = sys_errno;

        Return  Error;

      /End-Free

     P Errno           E
     **-- Get runtime error text:  -------------------------------------------**
     P strerror        B
     D                 Pi           128a    Varying

      /Free

        Return  %Str( sys_strerror( Errno ));

      /End-Free

     P strerror        E
     **-- Send diagnostic message:  ------------------------------------------**
     P SndDiagMsg      B
     D                 Pi            10i 0
     D  PxMsgDta                    512a   Const  Varying
     **
     D MsgKey          s              4a

      /Free

        SndPgmMsg( 'CPF9897'
                 : 'QCPFMSG   *LIBL'
                 : PxMsgDta
                 : %Len( PxMsgDta )
                 : '*DIAG'
                 : '*PGMBDY'
                 : 1
                 : MsgKey
                 : ERRC0100
                 );

        If  ERRC0100.BytAvl > *Zero;
          Return  -1;

        Else;
          Return   0;
        EndIf;

      /End-Free

     P SndDiagMsg      E
     **-- Send escape message:  ----------------------------------------------**
     P SndEscMsg       B
     D                 Pi            10i 0
     D  PxMsgDta                    512a   Const  Varying

      /Free

        SndPgmMsg( 'CPF9898'
                 : 'QCPFMSG   *LIBL'
                 : PxMsgDta
                 : %Len( PxMsgDta )
                 : '*ESCAPE'
                 : '*PGMBDY'
                 : 1
                 : MsgKey
                 : ERRC0100
                 );

        If  ERRC0100.BytAvl > *Zero;
          Return  -1;

        Else;
          Return  0;

        EndIf;

      /End-Free

     P SndEscMsg       E
     **-- Send completion message:  ------------------------------------------**
     P SndCmpMsg       B
     D                 Pi            10i 0
     D  PxMsgDta                    512a   Const  Varying

      /Free

        SndPgmMsg( 'CPF9897'
                 : 'QCPFMSG   *LIBL'
                 : PxMsgDta
                 : %Len( PxMsgDta )
                 : '*COMP'
                 : '*PGMBDY'
                 : 1
                 : MsgKey
                 : ERRC0100
                 );

        If  ERRC0100.BytAvl > *Zero;
          Return  -1;

        Else;
          Return  0;

        EndIf;

      /End-Free

     **
     P SndCmpMsg       E

Qp0lGetAttr: Because this program example contains some special code, my HTML-editor
is messing up the code. You'll have to download the zipped code here

     **
     **  Program . . : CBX127V
     **  Description : Change IFS attributes - validity checking program
     **  Author  . . : Carsten Flensburg
     **  Published . : Club Tech iSeries Programming Tips Newsletter
     **  Date  . . . : November 18, 2004
     **
     **
     **  Program description:
     **    This program checks the existence of the specified IFS object.
     **
     **
     **  Compile options:
     **    CrtRpgMod Module( CBX127V )
     **              DbgView( *LIST )
     **
     **    CrtPgm    Pgm( CBX127V )
     **              Module( CBX127V )
     **              ActGrp( *NEW )
     **
     **
     **-- Control specification:  --------------------------------------------**
     H Option( *SrcStmt )  BndDir( 'QC2LE' )

     **-- API error data structure:
     D ERRC0100        Ds                  Qualified
     D  BytPrv                       10i 0 Inz( %Size( ERRC0100 ))
     D  BytAvl                       10i 0
     D  ExcpId                        7a
     D                                1a
     D  ExcpDta                     512a
     **-- Global variables:
     D addr            s             10u 0
     **-- access API constants:
     D F_OK            c                   0
     D X_OK            c                   1
     D W_OK            c                   2
     D R_OK            c                   4

     **-- IFS file functions:
     D access          Pr            10i 0 ExtProc( 'access' )
     D   Path                          *   Value  Options( *String )
     D   Amode                       10i 0 Value
     **-- Error number:
     D sys_errno       Pr              *    ExtProc( '__errno' )
     **-- Error string:
     D sys_strerror    Pr              *    ExtProc( 'strerror' )
     D  errno                        10i 0  Value
     **-- Send program message:
     D SndPgmMsg       Pr                  ExtPgm( 'QMHSNDPM' )
     D  SpMsgId                       7a   Const
     D  SpMsgFq                      20a   Const
     D  SpMsgDta                    128a   Const
     D  SpMsgDtaLen                  10i 0 Const
     D  SpMsgTyp                     10a   Const
     D  SpCalStkE                    10a   Const  Options( *VarSize )
     D  SpCalStkCtr                  10i 0 Const
     D  SpMsgKey                      4a
     D  SpError                    1024a          Options( *VarSize )

     **-- Send diagnostic message:
     D SndDiagMsg      Pr            10i 0
     D  PxMsgId                       7a   Const
     D  PxMsgDta                    512a   Const  Varying
     **-- Send escape message:
     D SndEscMsg       Pr            10i 0
     D  PxMsgId                       7a   Const
     D  PxMsgDta                    512a   Const  Varying
     **-- Error identification:
     D errno           Pr            10i 0
     D strerror        Pr           128a   Varying

     **-- Entry parameters:
     D CBX127V         Pr
     D  PxIfsObj                   5002a   Varying
     D  PxFlwSymLnk                  10i 0
     D  PxRdOnly                      1a
     D  PxHidden                      1a
     D  PxPcSys                       1a
     D  PxPcArc                       1a
     D  PxSysArc                      1a
     D  PxAlwCkpWrt                   1a
     D  PxCcsId                      10i 0
     D  PxDskStgOpt                   1a
     D  PxMainStgOpt                  1a
     D  PxSetEuid                     1a
     D  PxSetEgid                     1a
     **
     D CBX127V         Pi
     D  PxIfsObj                   5002a   Varying
     D  PxFlwSymLnk                  10i 0
     D  PxRdOnly                      1a
     D  PxHidden                      1a
     D  PxPcSys                       1a
     D  PxPcArc                       1a
     D  PxSysArc                      1a
     D  PxAlwCkpWrt                   1a
     D  PxCcsId                      10i 0
     D  PxDskStgOpt                   1a
     D  PxMainStgOpt                  1a
     D  PxSetEuid                     1a
     D  PxSetEgid                     1a

      /Free

        If  access( PxIfsObj: F_OK ) = -1;

          SndDiagMsg( 'CPD0006': '0000' + %Char( errno ) + ': ' + strerror );

          SndEscMsg( 'CPF0002': '' );

        EndIf;

        *InLr = *On;

        Return;


      /End-Free

     **-- Get runtime error number:  -----------------------------------------**
     P errno           B
     D                 Pi            10i 0
     **
     D Error           s             10i 0  Based( pError )  NoOpt

      /Free

        pError = sys_errno;

        Return  Error;

      /End-Free

     P errno           E
     **-- Get runtime error text:  -------------------------------------------**
     P strerror        B
     D                 Pi           128a    Varying

      /Free

        Return  %Str( sys_strerror( errno ));

      /End-Free

     P strerror        E
     **-- Send diagnostic message:  ------------------------------------------**
     P SndDiagMsg      B
     D                 Pi            10i 0
     D  PxMsgId                       7a   Const
     D  PxMsgDta                    512a   Const  Varying
     **
     D MsgKey          s              4a

      /Free

        SndPgmMsg( PxMsgId
                 : 'QCPFMSG   *LIBL'
                 : PxMsgDta
                 : %Len( PxMsgDta )
                 : '*DIAG'
                 : '*PGMBDY'
                 : 1
                 : MsgKey
                 : ERRC0100
                 );

        If  ERRC0100.BytAvl > *Zero;
          Return  -1;

        Else;
          Return   0;
        EndIf;

      /End-Free

     P SndDiagMsg      E
     **-- Send escape message:  ----------------------------------------------**
     P SndEscMsg       B
     D                 Pi            10i 0
     D  PxMsgId                       7a   Const
     D  PxMsgDta                    512a   Const  Varying
     **
     D MsgKey          s              4a

      /Free

        SndPgmMsg( PxMsgId
                 : 'QCPFMSG   *LIBL'
                 : PxMsgDta
                 : %Len( PxMsgDta )
                 : '*ESCAPE'
                 : '*PGMBDY'
                 : 1
                 : MsgKey
                 : ERRC0100
                 );

        If  ERRC0100.BytAvl > *Zero;
          Return  -1;

        Else;
          Return   0;
        EndIf;

      /End-Free

     P SndEscMsg       E

Command: CBX127X /*-------------------------------------------------------------------*/ /* */ /* Compile options: */ /* */ /* CrtCmd Cmd( CHGIFSATR ) */ /* Pgm( CBX127 ) */ /* SrcMbr( CBX127X ) */ /* VldCkr( CBX127V ) */ /* HlpPnlGrp( CBX127H ) */ /* HlpId( *CMD ) */ /* PmtOvrPgm( CBX127O ) */ /* */ /* */ /*-------------------------------------------------------------------*/ Cmd Prompt( 'Change IFS Attributes' ) Parm IFSOBJ *Pname 5000 + Min( 1 ) + Vary( *YES *INT2 ) + Case( *MIXED ) + Keyparm( *YES ) + Prompt( 'IFS object' ) Parm SYMLNK *Int4 + Rstd( *YES ) + Dft( *NO ) + SpcVal(( *NO 0 ) + ( *YES 1 )) + Expr( *YES ) + Keyparm( *YES ) + Prompt( 'Symbolic link' ) Parm READONLY *Char 1 + Rstd( *YES ) + Dft( *SAME ) + SpcVal(( *NO x'00' ) + ( *YES x'01' ) + ( *SAME x'FF' )) + Expr( *YES ) + Prompt( 'Read only' ) Parm HIDDEN *Char 1 + Rstd( *YES ) + Dft( *SAME ) + SpcVal(( *NO x'00' ) + ( *YES x'01' ) + ( *SAME x'FF' )) + Expr( *YES ) + Prompt( 'Hidden' ) Parm PCSYSTEM *Char 1 + Rstd( *YES ) + Dft( *SAME ) + SpcVal(( *NO x'00' ) + ( *YES x'01' ) + ( *SAME x'FF' )) + Expr( *YES ) + Prompt( 'System file' ) Parm PCARCHIVE *Char 1 + Rstd( *YES ) + Dft( *SAME ) + SpcVal(( *NO x'00' ) + ( *YES x'01' ) + ( *SAME x'FF' )) + Expr( *YES ) + Prompt( 'Object changed - PC' ) Parm SYSARCHIVE *Char 1 + Rstd( *YES ) + Dft( *SAME ) + SpcVal(( *NO x'00' ) + ( *YES x'01' ) + ( *SAME x'FF' )) + Expr( *YES ) + Prompt( 'Object changed - System' ) Parm ALWCKPWRT *Char 1 + Rstd( *YES ) + Dft( *SAME ) + SpcVal(( *NO x'00' ) + ( *YES x'01' ) + ( *SAME x'FF' )) + Expr( *YES ) + Prompt( 'Allow write during save' ) Parm CCSID *Int4 + Range( 1 65533 ) + Dft( *SAME ) + SpcVal(( *SAME 0 )) + Expr( *YES ) + Prompt( 'Coded character set ID' ) Parm DISKSTGOPT *Char 1 + Rstd( *YES ) + Dft( *SAME ) + SpcVal(( *NORMAL x'00' ) + ( *MINIMIZE x'01' ) + ( *DYNAMIC x'02' ) + ( *SAME x'FF' )) + Expr( *YES ) + Prompt( 'Disk storage option' ) Parm MAINSTGOPT *Char 1 + Rstd( *YES ) + Dft( *SAME ) + SpcVal(( *NORMAL x'00' ) + ( *MINIMIZE x'01' ) + ( *DYNAMIC x'02' ) + ( *SAME x'FF' )) + Expr( *YES ) + Prompt( 'Main storage option' ) Parm SETEUID *Char 1 + Rstd( *YES ) + Dft( *SAME ) + SpcVal(( *NO x'00' ) + ( *YES x'01' ) + ( *SAME x'FF' )) + Expr( *YES ) + Prompt( 'Set effective user ID' ) Parm SETEGID *Char 1 + Rstd( *YES ) + Dft( *SAME ) + SpcVal(( *NO x'00' ) + ( *YES x'01' ) + ( *SAME x'FF' )) + Expr( *YES ) + Prompt( 'Set effective group ID' )
Panel Group .*-----------------------------------------------------------------------** .* .* Compile options: .* .* CrtPnlGrp PnlGrp( CBX127H ) .* SrcFile( QPNLSRC ) .* SrcMbr( *PNLGRP ) .* .*-----------------------------------------------------------------------** :PNLGRP. :HELP NAME='CHGIFSATR'.Change IFS Attributes - Help :P. The Change IFS Attributes (CHGIFSATR) command changes one or more of the specified IFS object's attributes. The current attribute value is displayed when the command is prompted. :P. :EHELP. :HELP NAME='CHGIFSATR/IFSOBJ'.IFS object (IFSOBJ) - Help :XH3.IFS object (IFSOBJ) :P. Specify the path name to the IFS object whose attributes should be displayed and optionally changed. :P. This is a required parameter. :P. :EHELP. :HELP NAME='CHGIFSATR/SYMLNK'.Symbolic link (SYMLNK) - Help :XH3.Symbolic link (SYMLNK) :P. If the last component in the path name is a symbolic link, this parameter specifies whether or not to change the attribute of the symbolic link or of the object pointed to by the symbolic link. :P. The possible values are: :P. :PARML. :PT.:PK DEF.*NO:EPK. :PD. The attribute of the symbolic link object is not changed. The attribute of the object pointed to by the symbolic link is changed. :PT.:PK.*YES:EPK. :PD. If the object is a symbolic link, the attribute of the symbolic link is changed. The attribute of the object pointed to by the symbolic link is not changed. :EPARML. :EHELP. :HELP NAME='CHGIFSATR/READONLY'.Read only (READONLY) - Help :XH3.Read only (READONLY) :P. Whether the object can be written to or deleted, have its extended attributes changed or deleted, or have its size changed. :P. The possible values are: :P. :PARML. :PT.:PK DEF.*SAME:EPK. :PD. The current attribute value is not changed. :PT.:PK.*NO:EPK. :PD. The object can be changed or deleted. :PT.:PK.*YES:EPK. :PD. The object cannot be changed or deleted. :EPARML. :EHELP. :HELP NAME='CHGIFSATR/HIDDEN'.Hidden (HIDDEN) - Help :XH3.Hidden (HIDDEN) :P. Whether the object can be displayed using an ordinary directory list. :P. The possible values are: :P. :PARML. :PT.:PK DEF.*SAME:EPK. :PD. The current attribute value is not changed. :PT.:PK.*NO:EPK. :PD. The object is not hidden and can be displayed using an ordinary directory listing. :PT.:PK.*YES:EPK. :PD. The object is hidden and cannot be displayed using an ordinary directory listing. :EPARML. :EHELP. :HELP NAME='CHGIFSATR/PCSYSTEM'.System file (PCSYSTEM) - Help :XH3.System file (PCSYSTEM) :P. Whether the object is a PC system file and is excluded from normal directory searches. :P. The possible values are: :P. :PARML. :PT.:PK DEF.*SAME:EPK. :PD. The current attribute value is not changed. :PT.:PK.*NO:EPK. :PD. The object is not a PC system file. :PT.:PK.*YES:EPK. :PD. The object is a PC system file. :EPARML. :EHELP. :HELP NAME='CHGIFSATR/PCARCHIVE'.Object changed - PC (PCARCHIVE) - Help :XH3.Object changed - PC (PCARCHIVE) :P. Whether the object has changed since the last time the file was saved or reset by a PC client. :P. The possible values are: :P. :PARML. :PT.:PK DEF.*SAME:EPK. :PD. The current attribute value is not changed. :PT.:PK.*NO:EPK. :PD. The object has not changed. :PT.:PK.*YES:EPK. :PD. The object has changed. :EPARML. :EHELP. :HELP NAME='CHGIFSATR/SYSARCHIVE'.Object changed - System (SYSARCHIVE) - Help :XH3.Object changed - System (SYSARCHIVE) :P. Whether the object has changed and needs to be saved. It is set on when an object's change time is updated, and set off when the object has been saved. :P. The possible values are: :P. :PARML. :PT.:PK DEF.*SAME:EPK. :PD. The current attribute value is not changed. :PT.:PK.*NO:EPK. :PD. The object has not changed and does not need to be saved. :PT.:PK.*YES:EPK. :PD. The object has changed and does need to be saved. :EPARML. :EHELP. :HELP NAME='CHGIFSATR/ALWCKPWRT'.Allow write during save (ALWCKPWRT) - Help :XH3.Allow write during save (ALWCKPWRT) :P. Whether the stream file (*STMF) can be shared with readers and writers during the save-while-active checkpoint processing. Changing this attribute's current value may cause unexpected results. Please refer to the Backup and Recovery book, SC41-5304 for details on this attribute. :P. The possible values are: :P. :PARML. :PT.:PK DEF.*SAME:EPK. :PD. The current attribute value is not changed. :PT.:PK.*NO:EPK. :PD. The object can be shared with readers only. :PT.:PK.*YES:EPK. :PD. The object can be shared with readers and writers. :EPARML. :EHELP. :HELP NAME='CHGIFSATR/CCSID'.Coded character set ID (CCSID) - Help :XH3.Coded character set ID (CCSID) :P. The code character set identifier (CCSID) of the data and extended attributes of the object. :P. :NT. Changing the CCSID does not convert the data or the extended attributes. :ENT. :P. The possible values are: :P. :PARML. :PT.:PK DEF.*SAME:EPK. :PD. The current attribute value is not changed. :PT.:PV.coded-character-set-identifier:EPV. :PD. Specify the CCSID of the data and extended attributes of the object. :EPARML. :EHELP. :HELP NAME='CHGIFSATR/DISKSTGOPT'.Disk storage option (DISKSTGOPT) - Help :XH3.Disk storage option (DISKSTGOPT) :P. This determines how auxiliary storage is allocated by the system for the specified object. The option will take effect immediately and be part of the next auxiliary storage allocation for the object. This option can only be specified for stream files in the root (/), QOpenSys and user-defined file systems. This option will be ignored for *TYPE1 byte stream files. :P. The possible values are: :P. :PARML. :PT.:PK DEF.*SAME:EPK. :PD. The current attribute value is not changed. :PT.:PK.*NORMAL:EPK. :PD. The auxiliary storage will be allocated normally. That is, as additional auxiliary storage is required, it will be allocated in logically sized extents to accomodate the current space requirement, and anticipated future requirements, while minimizing the number of disk I/O operations. If the *DISKSTGOPT attribute has not been specified for an object, this value is the default. :PT.:PK.*MINIMIZE:EPK. :PD. The auxiliary storage will be allocated to minimize the space used by the object. That is, as additional auxiliary storage is required, it will be allocated in small sized extents to accomodate the current space requirement. Accessing an object composed of many small extents may increase the number of disk I/O operations for that object. :PT.:PK.*DYNAMIC:EPK. :PD. The system will dynamically determine the optimum auxiliary storage allocation for the object, balancing space used versus disk I/O operations. For example, if a file has many small extents, yet is frequently being read and written, then future auxiliary storage allocations will be larger extents to minimize the number of disk I/O operations. Or, if a file is frequently truncated, then future auxiliary storage allocations will be small extents to minimize the space used. Additionally, information will be maintained on the stream file sizes for this system and its activity. This file size information will also be used to help determine the optimum auxiliary storage allocations for this object as it relates to the other objects sizes. :EPARML. :EHELP. :HELP NAME='CHGIFSATR/MAINSTGOPT'.Main storage option (MAINSTGOPT) - Help :XH3.Main storage option (MAINSTGOPT) :P. This determines how main storage is allocated and used by the system for the specified object. The option will take effect the next time the specified object is opened. This option can only be specified for stream files in the root (/), QOpenSys and user-defined file systems. :P. The possible values are: :P. :PARML. :PT.:PK DEF.*SAME:EPK. :PD. The current attribute value is not changed. :PT.:PK.*NORMAL:EPK. :PD. The main storage will be allocated normally. That is, as much storage as possible will be allocated and used. This minimizes the number of disk I/O operations since the information is cached in main storage. If the *MAINSTGOPT attribute has not been specified for an object, this value is the default. :PT.:PK.*MINIMIZE:EPK. :PD. The main storage will be allocated to minimize the space used by the object. That is, as little main storage as possible will be allocated and used. This minimizes main storage usage while increasing the number of disk I/O operations since less information is cached in main storage. :PT.:PK.*DYNAMIC:EPK. :PD. The system will dynamically determine the optimum main storage allocation for the object depending on other system activity and main storage contention. That is, when there is little main storage contention, as much storage as possible will be allocated and used to minimize the number of disk I/O operations. And when there is significant main storage contention, less main storage will be allocated and used to minimize the main storage contention. This option only has an effect when the storage pool's paging option is *CALC. When the storage pool's paging option is *FIXED, the behavior is the same as *NORMAL. When the object is accessed through a file server, this option has no effect. Instead, its behavior is the same as *NORMAL. :EPARML. :EHELP. :HELP NAME='CHGIFSATR/SETEUID'.Set effective user ID (SETEUID) - Help :XH3.Set effective user ID (SETEUID) :P. Set effective user ID (UID) at execution time. This value is ignored if the specified object is a directory. :P. The possible values are: :P. :PARML. :PT.:PK DEF.*SAME:EPK. :PD. The current attribute value is not changed. :PT.:PK.*NO:EPK. :PD. The user ID (UID) is not set at execution time. :PT.:PK.*YES:EPK. :PD. The object owner is the effective user ID (UID) at execution time. :EPARML. :EHELP. :HELP NAME='CHGIFSATR/SETEGID'.Set effective group ID (SETEGID) - Help :XH3.Set effective group ID (SETEGID) :P. Set effective group ID (GID) at execution time. :P. The possible values are: :P. :PARML. :PT.:PK DEF.*SAME:EPK. :PD. The current attribute value is not changed. :PT.:PK.*NO:EPK. :PD. If the object is a file, the group ID (GID) is not set at execution time. If the object is a directory in the root ('/'), QOpenSys, and user-defined file systems, the group ID (GID) of objects created in the directory is set to the effective GID of the thread creating the object. This value cannot be set for other file systems. :PT.:PK.*YES:EPK. :PD. If the object is a file, the group ID (GID) is set at execution time. If the object is a directory, the group ID (GID) of objects created in the directory is set to the GID of the parent directory. :EPARML. :EHELP. :EPNLGRP.
Thanks to Carsten Flensburg writing for Club Tech iSeries Programming Tips Newsletter
Back

QSYRTVUA
Retrieve Users Authorized to an Object

     **
     **  Compile options:
     **
     **    CrtRpgMod Module( CBX119T )
     **              DbgView( *LIST )
     **
     **    CrtPgm    Pgm( CBX119T )
     **              Module( CBX119T )
     **              ActGrp( QILE )
     **
     **
     **-- Specifications -----------------------------------------------------**
     H Option( *SrcStmt )
     **-- Api error structure:  ----------------------------------------------**
     D ApiError        Ds
     D  AeBytPro                     10i 0 Inz( %Size( ApiError ))
     D  AeBytAvl                     10i 0
     D  AeExcpId                      7a
     D                                1a
     D  AaExcpDta                   256a
     **-- Global variables:  -------------------------------------------------**
     D Idx             s             10i 0
     **-- User authorization parameters:  ------------------------------------**
     D RuRcvVar        s          32767a
     D RuObjNam        s           4096a   Varying
     **
     D RuFdbInf        Ds
     D  FiBytRtnFb                   10i 0
     D  FiBytAvlFb                   10i 0
     D  FiBytRtnRv                   10i 0
     D  FiBytAvlRv                   10i 0
     D  FiNbrAutUsr                  10i 0
     D  FiUsrEntLen                  10i 0
     D  FiObjOwn                     10a
     D  FiObjPgp                     10a
     D  FiAutL                       10a
     D  FiSnsLvl                      1a
     **
     D RuInfEnt        Ds                  Based( pInfEnt )
     D  ReUsrPrf                     10a
     D  ReUsrTyp                      1a
     D  ReDtaAut                     10a
     D  ReAutlMgm                     1a
     D  ReObjMgm                      1a
     D  ReObjXst                      1a
     D  ReObjAlt                      1a
     D  ReObjRef                      1a
     D                               10a
     D  ReObjOpr                      1a
     D  ReDtaRead                     1a
     D  ReDtaAdd                      1a
     D  ReDtaUpd                      1a
     D  ReDtaDlt                      1a
     D  ReDtaExe                      1a
     D                               10a
     **-- Retrieve users authorized to an object:  ---------------------------**
     D RtvUsrObjAut    Pr                  ExtPgm( 'QSYRTVUA' )
     D  RuRcvVar                  32767a          Options( *VarSize )
     D  RuRcvVarLen                  10i 0 Const
     D  RuFdbInf                    256a          Options( *VarSize )
     D  RuFdbInfLen                  10i 0 Const
     D  RuFmtNam                      8a   Const
     D  RuObjPth                   4096a   Const  Options( *VarSize )
     D  RuObjPthLen                  10i 0 Const
     D  RuError                   32767a          Options( *VarSize )
     **
     C                   Eval      RuObjNam    = '/qopensys/QUSER/BL2005.prn'
     **
     C                   CallP     RtvUsrObjAut( RuRcvVar
     C                                         : %Size( RuRcvVar )
     C                                         : RuFdbInf
     C                                         : %Size( RuFdbInf )
     C                                         : 'RTUA0100'
     C                                         : RuObjNam
     C                                         : %Len( RuObjNam )
     C                                         : ApiError
     C                                         )
     **
     C                   If        AeBytAvl    = *Zero
     **
     C                   Eval      pInfEnt     = %Addr( RuRcvVar )
     **
     C                   For       Idx = 1  To FiNbrAutUsr
     **
     **-- Do whatever...
     **
     C                   If        Idx         < FiNbrAutUsr
     C                   Eval      pInfEnt     = pInfEnt + FiUsrEntLen
     C                   EndIf
     **
     C                   EndFor
     C                   EndIf
     **
     C                   Return
     **

Thanks to Carsten Flensburg
Back

QSY.....
Validation List Object APIs

     **
     ** Service program summary
     ** -----------------------
     **
     ** Security APIs:
     **
     **   QsyAddValidationLstEntry          Adds an entry to a validation list
     **                                     object. The entry is defined by an
     **                                     Entry Id (user name), Encrypt Data
     **                                     (user password) and Entry Data
     **                                     (user description).
     **
     **   QsyFindValidationLstEntry         Finds an entry in a validation list
     **                                     object. To be able to retrieve the
     **                                     password the system value QRETSVRSEC
     **                                     must be set to 1 and the QsyEncrypt-
     **                                     Data attribute of the entry should
     **                                     have been set to 1 when the entry
     **                                     was stored.
     **
     **   QsyChangeValidationLstEntry       Changes an entry in a validation
     **                                     list object. Eligible to change are
     **                                     the password and description values
     **                                     as well as attribute information.
     **
     **   QsyRemoveValidationLstEntry       Removes an entry from a validation
     **                                     list object.
     **
     **   QsyVerifyValidationLstEntry       Verifies the existence of the speci-
     **                                     fied validation list entry and the
     **                                     and the validity of the specified
     **                                     password.
     **
     **
     ** Exported functions:
     **                                                         Return values:
     **   VfyUsrPwd     Verifies the username and password      -1: Failure
     **                 against the specified validation        -2: Password error
     **                 list.
     **
     **   AddUsrPwd     Adds a username, a password and a       -1: Failure
     **                 description to the specified            -2: Password error
     **                 validation list.
     **
     **   ChgUsrPwd     Changes the password of the speci-      -1: Failure
     **                 fied username in the specified          -1: Password error
     **                 validation list.
     **
     **   GetUsrPwd     Returns the password of the speci-      Blanks: Failure
     **                 fied username if found in the
     **                 specified validation list.
     **
     **   RmvUsrPwd     Removes the validation list entry       -1: Failure
     **                 of the specified username in the
     **                 specified validation list.
     **
     **
     ** Compile options:
     **
     **   CRTRPGMOD      CBX003
     **
     **   CRTSRVPGM      CBX003
     **
     **
     **-- Header specifications:  --------------------------------------------**
     H NoMain  Option( *SrcStmt )
     **-- Entry Id:  ---------------------------------------------------------**
     D EntId           Ds
     D  EiDtaLen                     10i 0
     D  EiCcsId                      10i 0 Inz( 65535 )
     D  EiDta                        10a
     **-- Encryption data:  --------------------------------------------------**
     D EncDta          Ds
     D  EcDtaLen                     10i 0
     D  EcCcsId                      10i 0 Inz( 65535 )
     D  EcDta                        10a
     **-- Entry data:  -------------------------------------------------------**
     D EntDta          Ds
     D  EdDtaLen                     10i 0
     D  EdCcsID                      10i 0 Inz( 65535 )
     D  EdDta                        50a
     **-- Attribute data:  ---------------------------------------------------**
     D AtrInf          Ds
     D  AiNbrAtr                     10i 0 Inz( 1 )
     D   AiAlign                     12a
     ** Qsy_Attr_Descr_T
 1  4D   AdAtrLoc                    10i 0 Inz( 0 )
 5  8D   AdAtrTyp                    10i 0 Inz( 0 )
 9 16D   AdRes_1                      8a   Inz( *Allx'00' )
17 32D   AdAtrId_p                     *
33 64D   AdOthDsc                    32a   Inz( *Allx'00' )
     **  Attr_Data_Info
     **   Qsy_In_VLDL_T
     D    VldLstAtr                  96a
65 68D     AvAtrCcsid                10i 0 Overlay( VldLstAtr: 1 )
65 68D                                     Inz( -1 )
69 72D     AvAtrLen                  10i 0 Overlay( VldLstAtr: 5 )
69 72D                                     Inz( 1 )
73 80D     AvRes_1                    8a   Overlay( VldLstAtr: 9 )
73 80D                                     Inz( *Allx'00' )
81 96D     AvAtrVal_p                  *   Overlay( VldLstAtr: 17 )
81 96D                                     Inz( %Addr( AvAtrVal ))
97192D    VaInOther                  96a   Overlay( VldLstAtr: 1 )
     D                               64a   Overlay( VaInOther: 33 )
     D                                     Inz( *Allx'00' )
93224D   AdOtherData                 32a   Inz( *Allx'00' )
     **
     D AvAtrVal        s              1a   Inz( '1' )
     **-- Return data:  ------------------------------------------------------**
     D RtnDta          Ds
     ** Qsy_Entry_ID_Info_T
     D  RiDtaLen                     10i 0
     D  RiCcsId                      10i 0
     D  RiDta                       100a
     ** Qsy_Entry_Encr_Data_Info_T
     D  RcDtaLen                     10i 0
     D  RcCcsId                      10i 0
     D  RcDta                       600a
     ** Qsy_Entry_Data_Info_T
     D  RdDtaLen                     10i 0
     D  RdCcsID                      10i 0
     D  RdDta                      1000a
     D                                4a
     D  RaAtrPtr                       *
     **-- Verify user password:  ---------------------------------------------**
     D VfyUsrPwd       Pr            10i 0
     D  PxVldLst                     10a   Const
     D  PxVldLstLib                  10a   Const
     D  PxUsrId                      10a   Const
     D  PxUsrPwd                     10a   Const
     **-- Add user password:  ------------------------------------------------**
     D AddUsrPwd       Pr            10i 0
     D  PxVldLst                     10a   Const
     D  PxVldLstLib                  10a   Const
     D  PxUsrId                      10a   Const
     D  PxUsrPwd                     10a   Const
     D  PxUsrDsc                     50a   Const
     **-- Get user password:  ------------------------------------------------**
     D GetUsrPwd       Pr            10a
     D  PxVldLst                     10a   Const
     D  PxVldLstLib                  10a   Const
     D  PxUsrId                      10a   Const
     **-- Change user password:  ---------------------------------------------**
     D ChgUsrPwd       Pr            10i 0
     D  PxVldLst                     10a   Const
     D  PxVldLstLib                  10a   Const
     D  PxUsrId                      10a   Const
     D  PxUsrPwd                     10a   Const
     **-- Remove user password:  ---------------------------------------------**
     D RmvUsrPwd       Pr            10i 0
     D  PxVldLst                     10a   Const
     D  PxVldLstLib                  10a   Const
     D  PxUsrId                      10a   Const
     **-- Verify user password:  ---------------------------------------------**
     P VfyUsrPwd       B                   Export
     D                 Pi            10i 0
     D  PxVldL                       10a   Const
     D  PxVldLlib                    10a   Const
     D  PxUsrId                      10a   Const
     D  PxUsrPwd                     10a   Const
     **-- Verify validation list entry:
     D VfyVldLst       Pr            10i 0 ExtProc( 'QsyVerifyValidation+
     D                                     LstEntry' )
     D  VvLstNam                     20a   Const
     D  VvEntId                        *   Value
     D  VvEncDta                       *   Value
     **
     **-- Mainline:  ---------------------------------------------------------**
     **
     C                   Eval      EiDta      =  PxUsrId
     C                   Eval      EiDtaLen   =  %Len( %TrimR( EiDta ))
     **
     C                   Eval      EcDta      =  PxUsrPwd
     C                   Eval      EcDtaLen   =  %Len( %TrimR( EcDta ))
     **
     C                   Return    VfyVldLst( PxVldL + PxVldLlib
     C                                      : %Addr( EntId )
     C                                      : %Addr( EncDta )
     C                                      )
     **
     P VfyUsrPwd       E
     **-- Add user password:  ------------------------------------------------**
     P AddUsrPwd       B                   Export
     D                 Pi            10i 0
     D  PxVldL                       10a   Const
     D  PxVldLlib                    10a   Const
     D  PxUsrId                      10a   Const
     D  PxUsrPwd                     10a   Const
     D  PxUsrDsc                     50a   Const
     **-- Add validation list entry:
     D AddVldLst       Pr            10i 0 ExtProc( 'QsyAddValidation+
     D                                     LstEntry' )
     D  AvLstNam                     20a   Const
     D  AvEntId                        *   Value
     D  AvEncDta                       *   Value
     D  AvEntDta                       *   Value
     D  AvAtrDta                       *   Value
     **
     **-- Mainline:  ---------------------------------------------------------**
     **
     C                   Eval      EiDta      =  PxUsrId
     C                   Eval      EiDtaLen   =  %Len( %TrimR( EiDta ))
     **
     C                   Eval      EcDta      =  PxUsrPwd
     C                   Eval      EcDtaLen   =  %Len( %TrimR( EcDta ))
     **
     C                   Eval      EdDta      =  PxUsrDsc
     C                   Eval      EdDtaLen   =  %Len( %TrimR( EdDta ))
     **
     C                   Alloc     15            AdAtrId_p
     C                   Eval      %Str( AdAtrId_p: 15 ) = 'QsyEncryptData'
     **
     C                   Return    AddVldLst( PxVldL + PxVldLlib
     C                                      : %Addr( EntId  )
     C                                      : %Addr( EncDta )
     C                                      : %Addr( EntDta )
     C                                      : %Addr( AtrInf )
     C                                      )
     **
     P AddUsrPwd       E
     **-- Get user password:  ------------------------------------------------**
     P GetUsrPwd       B                   Export
     D                 Pi            10a
     D  PxVldL                       10a   Const
     D  PxVldLlib                    10a   Const
     D  PxUsrId                      10a   Const
     **-- Find validation list entry:
     D FndVldLst       Pr            10i 0 ExtProc( 'QsyFindValidation+
     D                                     LstEntry' )
     D  FvLstNam                     20a   Const
     D  FvEntId                        *   Value
     D  FvRtnDta                       *   Value
     **
     **-- Mainline:  ---------------------------------------------------------**
     **
     C                   Eval      EiDta      =  PxUsrId
     C                   Eval      EiDtaLen   =  %Len( %TrimR( EiDta ))
     **
     C                   If        FndVldLst( PxVldL + PxVldLlib
     C                                      : %Addr( EntId )
     C                                      : %Addr( RtnDta )
     C                                      ) =  -1
     C                   Return    *Blanks
     **
     C                   Else
     C                   Return    %SubSt( RcDta: 1: RcDtaLen )
     C                   EndIf
     **
     P GetUsrPwd       E
     **-- Change user password:  ---------------------------------------------**
     P ChgUsrPwd       B                   Export
     D                 Pi            10i 0
     D  PxVldL                       10a   Const
     D  PxVldLlib                    10a   Const
     D  PxUsrId                      10a   Const
     D  PxUsrPwd                     10a   Const
     **-- Change validation list entry:
     D ChgVldLst       Pr            10i 0 ExtProc( 'QsyChangeValidation+
     D                                     LstEntry' )
     D  CvLstNam                     20a   Const
     D  CvEntId                        *   Value
     D  CvEncDta                       *   Value
     D  CvEntDta                       *   Value
     D  CvAtrDta                       *   Value
     **
     **-- Mainline:  ---------------------------------------------------------**
     **
     C                   Eval      EiDta      =  PxUsrId
     C                   Eval      EiDtaLen   =  %Len( %TrimR( EiDta ))
     **
     C                   Eval      EcDta      =  PxUsrPwd
     C                   Eval      EcDtaLen   =  %Len( %TrimR( EcDta ))
     **
     C                   Return    ChgVldLst( PxVldL + PxVldLlib
     C                                      : %Addr( EntId )
     C                                      : %Addr( EncDta )
     C                                      : *Null
     C                                      : *Null
     C                                      )
     **
     P ChgUsrPwd       E
     **-- Remove user password:  ---------------------------------------------**
     P RmvUsrPwd       B                   Export
     D                 Pi            10i 0
     D  PxVldL                       10a   Const
     D  PxVldLlib                    10a   Const
     D  PxUsrId                      10a   Const
     **-- Remove validation list entry:
     D RmvVldLst       Pr            10i 0 ExtProc( 'QsyRemoveValidation+
     D                                     LstEntry' )
     D  RvLstNam                     20a   Const
     D  RvEntId                        *   Value
     **
     **-- Mainline:  ---------------------------------------------------------**
     **
     C                   Eval      EiDta      =  PxUsrId
     C                   Eval      EiDtaLen   =  %Len( %TrimR( EiDta ))
     **
     C                   Return    RmvVldLst( PxVldL + PxVldLlib
     C                                      : %Addr( EntId )
     C                                      )
     **
     P RmvUsrPwd       E

Test validation list functions in service program CBX003 ** ** Program description: ** ** Test validation list functions in service program CBX003. ** ** ** Program prerequisite: ** ** Create validation list in QGPL: CRTVLDL WEB001V ** ** ** Compile options: ** ** CRTRPGMOD ... DBGVIEW(*LIST) ** ** CRTPGM ... BNDSRVPGM(CBX003) ** ** **-- Header specifications: --------------------------------------------** H Option( *SrcStmt ) **-- Global variables & constants: -------------------------------------** D RtnCod s 10i 0 D UsrPwd s 10a D VldLst c 'WEB001V' D VldLib c '*LIBL' **-- Verify user password: ---------------------------------------------** D VfyUsrPwd Pr 10i 0 D PxVldLst 10a Const D PxVldLstLib 10a Const D PxUsrId 10a Const D PxUsrPwd 10a Const **-- Add user password: ------------------------------------------------** D AddUsrPwd Pr 10i 0 D PxVldLst 10a Const D PxVldLstLib 10a Const D PxUsrId 10a Const D PxUsrPwd 10a Const D PxUsrDsc 50a Const **-- Get user password: ------------------------------------------------** D GetUsrPwd Pr 10a D PxVldLst 10a Const D PxVldLstLib 10a Const D PxUsrId 10a Const **-- Change user password: ---------------------------------------------** D ChgUsrPwd Pr 10i 0 D PxVldLst 10a Const D PxVldLstLib 10a Const D PxUsrId 10a Const D PxUsrPwd 10a Const **-- Remove user password: ---------------------------------------------** D RmvUsrPwd Pr 10i 0 D PxVldLst 10a Const D PxVldLstLib 10a Const D PxUsrId 10a Const **-- Test user password functions: --------------------------------------** ** C If AddUsrPwd( VldLst C : VldLib C : 'Dexter' C : 'DeeDee' C : 'Big scientist' C ) = *Zero ** C Eval RtnCod = VfyUsrPwd( VldLst C : VldLib C : 'Dexter' C : 'DeeDee' C ) ** C Eval RtnCod = VfyUsrPwd( VldLst C : VldLib C : 'Dexter' C : 'deedee' C ) ** C Eval UsrPwd = GetUsrPwd( VldLst C : VldLib C : 'Dexter' C ) ** C Eval RtnCod = ChgUsrPwd( VldLst C : VldLib C : 'Dexter' C : 'DEEDEE' C ) ** C Eval UsrPwd = GetUsrPwd( VldLst C : VldLib C : 'Dexter' C ) ** C EndIf ** C Eval RtnCod = RmvUsrPwd( VldLst C : VldLib C : 'Dexter' C ) ** C Eval *InLr = *On **
Thanks to Carsten Flensburg
Back

QEZSNDMG
Send Message (CLLE)

/*-------------------------------------------------------------------*/
/* Program:        BRKMSG                                            */
/* Description:    Receive two parameters from any program and send  */
/*                 a message to any User using the QEZSNDMG API from */
/*                 the Operational Assistant menu.                   */
/*                                                                   */
/*                 &MSGTEXT  -  80 character message                 */
/*                 &USERID   -  10 character UserId to receive msg   */
/*                                                                   */
/*                 Notes:  -The message text passed to this program  */
/*                          should be limited to 80 chars.           */
/*                         -If the user has multiple sessions open,  */
/*                          each session will receive a message.     */
/*                         -Use *ALLACT as USERID to notify everyone */
/*-------------------------------------------------------------------*/
             PGM        PARM(&MSGTEXT &USERID)

             DCL        VAR(&MSGTYPE) TYPE(*CHAR) LEN(10) +
                          VALUE('*INFO')
             DCL        VAR(&DELMODE) TYPE(*CHAR) LEN(10) +
                          VALUE('*BREAK')
             DCL        VAR(&MSGTEXT) TYPE(*CHAR) LEN(80)
             DCL        VAR(&MSGLENG) TYPE(*CHAR) LEN(04) +
                          VALUE(X'00000050')
             DCL        VAR(&USERID) TYPE(*CHAR) LEN(10)
             DCL        VAR(&USRCNT) TYPE(*CHAR) LEN(04) +
                          VALUE(X'00000001')
             DCL        VAR(&MSGSENT) TYPE(*CHAR) LEN(04) +
                          VALUE(X'00000000')
             DCL        VAR(&FUNCREQ) TYPE(*CHAR) LEN(04) +
                          VALUE(X'00000000')
             DCL        VAR(&ERROR) TYPE(*CHAR) LEN(256) +
                          VALUE(X'00000100')
             DCL        VAR(&SHOWMSG) TYPE(*CHAR) LEN(01) VALUE('N')
             DCL        VAR(&REPLYMQ) TYPE(*CHAR) LEN(20)
             DCL        VAR(&NAMETYPE) TYPE(*CHAR) LEN(04) +
                          VALUE('*USR')

             CALL       PGM(QEZSNDMG) PARM(&MSGTYPE &DELMODE +
                          &MSGTEXT &MSGLENG &USERID &USRCNT +
                          &MSGSENT &FUNCREQ &ERROR &SHOWMSG +
                          &REPLYMQ &NAMETYPE)

 ENDJOB:     ENDPGM

Thanks to Terry Winchester

And in RPG: ** ** Program . . : CBX505 ** Description : QEZSNDMG send message API - Test ** Author . . : Carsten Flensburg ** ** ** Compile options: ** CrtRpgMod Module( CBX505 ) ** DbgView( *LIST ) ** ** CrtPgm Pgm( CBX505 ) ** Module( CBX505 ) ** ActGrp( QILE ) ** ** **-- Header specifications: --------------------------------------------** H Option( *SrcStmt ) **-- System information: D PgmSts Sds Qualified D CurJob 10a Overlay( PgmSts: 244 ) D UsrPrf 10a Overlay( PgmSts: 254 ) D JobNbr 6a Overlay( PgmSts: 264 ) D CurUsr 10a Overlay( PgmSts: 358 ) **-- Global variables & constants: D MsgTxt s 256a Varying D Inz( 'This is a test message' ) D FncRqs s 10i 0 D MsgSntInd s 10i 0 **-- Api error data structure: D ERRC0100 Ds Qualified D BytPro 10i 0 Inz( %Size( ERRC0100 )) D BytAvl 10i 0 Inz D MsgId 7a D 1a D MsgDta 128a **-- Send message: D SndMsg Pr ExtPgm( 'QEZSNDMG' ) D MsgTyp 10a Const D DlvMod 10a Const D MsgTxt 494a Const Options( *VarSize ) D MsgTxtLen 10i 0 Const D MsgRcv 10a Const Options( *VarSize ) Dim( 299 ) D MsgRcvNbr 10i 0 Const D MsgSntInd 10i 0 D FncRqs 10i 0 D Error 32767a Options( *VarSize ) D ShwSndMsgDsp 1a Const Options( *NoPass ) D MsgQueNam 20a Const Options( *NoPass ) D NamTypInd 4a Const Options( *NoPass ) D CcsId 10i 0 Const Options( *NoPass ) /Free SndMsg( '*INFO' : '*BREAK' : MsgTxt : %Len( MsgTxt ) : PgmSts.UsrPrf : 1 : MsgSntInd : FncRqs : ERRC0100 : 'N' : *Blanks : '*USR' ); *InLr = *On; Return; /End-Free Thanks to (as usual) Carsten Flensburg
Back

QLICHGLL
Change Library List

      ****************************************************************
      *  Description.. Library List Functions                        *
      *  Program Name. F.LIBL                                        *
      *  Author....... Bradley V. Stone                              *
      *                BVS/Tools - www.bvstools.com                  *
      ****************************************************************
     H NOMAIN
      ****************************************************************
      * Prototypes                                                   *
      ****************************************************************
     D #PushLib        PR
     D   PR_Lib                      10    VALUE
     D #PopLib         PR
     D   PR_text                     10    VALUE OPTIONS(*NOPASS)
     D #AddLibLE       PR
     D   PR_Lib                      10    VALUE
     D   PR_Pos                       8    VALUE OPTIONS(*NOPASS)
     D   PR_RefLib                   10    VALUE OPTIONS(*NOPASS)
     D #ChgLibLJD      PR
     D   PR_JobD                     10    VALUE
     D   PR_JobDLib                  10    VALUE
     D #RtvLibL        PR              *
     D   PR_LibType                  10    VALUE
     D #VerLib         PR             2  0
     D   PR_Lib                      10    VALUE
     D   PR_LibType                  10    VALUE
      ****************************************************************
      * Global Definitions                                           *
      ****************************************************************
     D WPError         DS
     D  EBytesP                1      4B 0 INZ(%size(EData))
     D  EBytesA                5      8B 0
     D  EMsgID                 9     15
     D  EReserverd            16     16
     D  EData                 17     56
      *
     D QCmdCmd         S            512    INZ
     D QCmdLength      S             15  5 INZ(%size(QCmdCmd))
      *//////////////////////////////////////////////////////////////*
      * (#PushLib) Push a library onto the top of the libary list.   *
      *                                                              *
      * Use: #PushLib(library)                                       *
      *//////////////////////////////////////////////////////////////*
     P #PushLib        B                   EXPORT
      *--------------------------------------------------------------*
     D #PushLib        PI
     D  Lib                          10    VALUE
      *--------------------------------------------------------------*
     C                   eval      QCmdCmd = 'ADDLIBLE LIB(' +
     C                                       %trim(Lib) +
     C                                       ') ' +
     C                                       'POSITION(*FIRST)'
      *
     C                   CALL      'QCMDEXC'                            99
     C                   PARM                    QCmdCmd
     C                   PARM                    QCmdLength
      *
      *--------------------------------------------------------------*
     C     *PSSR         BEGSR
     C                   ENDSR
      *--------------------------------------------------------------*
     P #PushLib        E
      *//////////////////////////////////////////////////////////////*
      * (#PopLib) Pop a library from the library list.  If no value  *
      *  is passed to this procedure, the first library is popped    *
      *  from the library list.                                      *
      *                                                              *
      * Use: #PopLib({library})                                      *
      *//////////////////////////////////////////////////////////////*
     P #PopLib         B                   EXPORT
      *--------------------------------------------------------------*
     D #PopLib         PI
     D  Lib                          10    VALUE OPTIONS(*NOPASS)
      *
     D LibPtr          S               *
      *
     D MaxLibs         C                   CONST(25)
      *
     D LibData         DS                  BASED(LibPtr)
     D  #Libs                         9B 0
     D  LibArr                       10    DIM(MaxLibs)
      *--------------------------------------------------------------*
      *
     C                   if        (%Parms < 1) or (Lib = '*FIRST')
     C                   eval      LibPtr = #RtvLibL('*USER')
      *
     C                   if        (LibPtr <> *NULL) and (#Libs > 0)
     C                   eval      Lib = (LibArr(1))
     C                   endif
      *
     C                   endif
      *
     C                   eval      QCmdCmd = 'RMVLIBLE LIB(' +
     C                                       %trim(Lib) +
     C                                       ') '
      *
     C                   CALL      'QCMDEXC'                            99
     C                   PARM                    QCmdCmd
     C                   PARM                    QCmdLength
      *
      *--------------------------------------------------------------*
     C     *PSSR         BEGSR
     C                   ENDSR
      *--------------------------------------------------------------*
     P #PopLib         E
      *//////////////////////////////////////////////////////////////*
      * (#AddLibLE) Add Library List Entry to the specified postion  *
      *  on the library list using the same format as the ADDLIBLE   *
      *  command.  If position and/or reference library are not      *
      *  passed, the library is pushed onto the library list.        *
      *                                                              *
      * Use: #AddLibLE(library :                                     *
      *                {*FIRST | *LAST |                             *
      *                 *AFTER | *BEFORE | *REPLACE} :               *
      *                {Reference Library})                          *
      *//////////////////////////////////////////////////////////////*
     P #AddLibLE       B                   EXPORT
      *--------------------------------------------------------------*
     D #AddLibLE       PI
     D  Lib                          10    VALUE
     D  Pos                           8    VALUE OPTIONS(*NOPASS)
     D  RefLib                       10    VALUE OPTIONS(*NOPASS)
      *--------------------------------------------------------------*
     C                   if        (%Parms < 3) or (Pos = '*FIRST')
     C                   CALLP     #PushLib(Lib)
     C                   else
     C                   eval      QCmdCmd = 'ADDLIBLE LIB(' +
     C                                       %trim(Lib) +
     C                                       ') ' +
     C                                       'POSITION(' +
     C                                       %trim(Pos) + ' ' +
     C                                       %trim(RefLib) +
     C                                       ') '
      *
     C                   CALL      'QCMDEXC'                            99
     C                   PARM                    QCmdCmd
     C                   PARM                    QCmdLength
      *
     C                   endif
      *--------------------------------------------------------------*
     C     *PSSR         BEGSR
     C                   ENDSR
      *--------------------------------------------------------------*
     P #AddLibLE       E
      *//////////////////////////////////////////////////////////////*
      * (#ChgLibLJD) Change Library List to the initial library list *
      *  given on the inputted job description.                      *
      *                                                              *
      * Use: #ChgLibLJD(job description : job description library)   *
      *//////////////////////////////////////////////////////////////*
     P #ChgLibLJD      B                   EXPORT
      *--------------------------------------------------------------*
     D #ChgLibLJD      PI
     D  JobD                         10    VALUE
     D  JobDLib                      10    VALUE
      *
     D JobDRtn         DS
     D  Filler1                1    360
     D  LLOffSet             361    364B 0
     D  #Libs                365    368B 0
     D  Filler2              369    600
      *
     D MaxLibs         C                   CONST(25)
      *
     D LibL            S             11    DIM(MaxLibs)
      *
     D JobDLen         S              9B 0 INZ(%size(JobDRtn))
     D JobDFmt         S              8    INZ('JOBD0100')
     D JobDLoc         S             20
      *
     D LLCurLib        S             11    INZ('*SAME')
     D LLPrdLib        S             11    INZ('*SAME')
     D LL2PrdLib       S             11    INZ('*SAME')
      *
     D x               S              9B 0
     D y               S              9B 0
      *--------------------------------------------------------------*
     C                   eval      JobDLoc = (JobD + JobDLib)
      *
     C                   CALL      'QWDRJOBD'
     C                   PARM                    JobDRtn
     C                   PARM                    JobDLen
     C                   PARM                    JobDFmt
     C                   PARM                    JobDLoc
     C                   PARM                    WPError
      *
     C                   eval      y = (LLOffSet + 1)
      *
     C     1             do        #Libs         x
     C                   eval      LibL(x) = %subst(JobDRtn:y:10)
     C                   eval      y = (y + 11)
     C                   enddo
      *
     C                   CALL      'QLICHGLL'
     C                   PARM                    LLCurLib
     C                   PARM                    LLPrdLib
     C                   PARM                    LL2PrdLib
     C                   PARM                    LibL
     C                   PARM                    #Libs
     C                   PARM                    WPError
      *
      *--------------------------------------------------------------*
     C     *PSSR         BEGSR
     C                   ENDSR
      *--------------------------------------------------------------*
     P #ChgLibLJD      E
      *//////////////////////////////////////////////////////////////*
      * (#RtvLibL) Retrieve Library List and return the data as a    *
      *  pointer to a data structure that contains the library       *
      *  information.  If the pointer returned contains the value    *
      *  *NULL, an error occured.                                    *
      *                                                              *
      * Use: #RtvLibL(*SYSTEM | *PRODCUT | *CURRENT | *USER)         *
      *//////////////////////////////////////////////////////////////*
     P #RtvLibL        B                   EXPORT
      *--------------------------------------------------------------*
     D #RtvLibL        PI              *
     D  LibType                      10    VALUE
      *
     D RtvRtnVar       DS
     D  RtvSysLibs            65     68B 0
     D  RtvPrdLibs            69     72B 0
     D  RtvCurLibs            73     76B 0
     D  RtvUsrLibs            77     80B 0
     D  RtvData               81    400
      *
     D MaxLibs         C                   CONST(25)
      *
     D SysData         DS                  STATIC
     D  #SysLibs                      9B 0
     D  SysArr                       10    DIM(MaxLibs)
      *
     D PrdData         DS                  STATIC
     D  #PrdLibs                      9B 0
     D  PrdArr                       10    DIM(MaxLibs)
      *
     D CurData         DS                  STATIC
     D  #CurLibs                      9B 0
     D  CurArr                       10    DIM(MaxLibs)
      *
     D UsrData         DS                  STATIC
     D  #UsrLibs                      9B 0
     D  UsrArr                       10    DIM(MaxLibs)
      *
     D RtvLen          S              9B 0 INZ(400)
     D RtvFmt          S              8    INZ('JOBI0700')
     D RtvJobName      S             26    INZ('*')
     D RtvID           S             16
      *
     D x               S              9B 0
     D y               S              9B 0
      *--------------------------------------------------------------*
     C                   CALL      'QUSRJOBI'
     C                   PARM                    RtvRtnVar
     C                   PARM                    RtvLen
     C                   PARM                    RtvFmt
     C                   PARM                    RtvJobName
     C                   PARM                    RtvID
      *
     C                   eval      y = 1
     C                   eval      #SysLibs = RtvSysLibs
     C                   eval      #PrdLibs = RtvPrdLibs
     C                   eval      #CurLibs = RtvCurLibs
     C                   eval      #UsrLibs = RtvUsrLibs
      *
     C                   select
     C                   when      (LibType = '*SYSTEM')
      *
     C     1             do        #SysLibs      x
     C                   eval      SysArr(x) = %subst(RtvData:y:10)
     C                   eval      y = (y + 11)
     C                   enddo
      *
     C                   RETURN    %addr(SysData)
      *
     C                   when      (LibType = '*PRODUCT')
     C                   eval      y = (y + (#SysLibs * 11))
      *
     C     1             do        #PrdLibs      x
     C                   eval      PrdArr(x) = %subst(RtvData:y:10)
     C                   eval      y = (y + 11)
     C                   enddo
      *
     C                   RETURN    %addr(PrdData)
      *
     C                   when      (LibType = '*CURRENT')
     C                   eval      y = (y +
     C                                 ((#SysLibs + #PrdLibs) * 11))
      *
     C     1             do        #CurLibs      x
     C                   eval      CurArr(x) = %subst(RtvData:y:10)
     C                   eval      y = (y + 11)
     C                   enddo
      *
     C                   RETURN    %addr(CurData)
      *
     C                   when      (LibType = '*USER')
     C                   eval      y = (y +
     C                                 ((#SysLibs + #PrdLibs + #CurLibs) * 11))
      *
     C     1             do        #UsrLibs      x
     C                   eval      UsrArr(X) = %subst(RtvData:y:10)
     C                   eval      y = (y + 11)
     C                   enddo
      *
     C                   RETURN    %addr(UsrData)
     C                   other
     C                   RETURN    *NULL
     C                   endsl
      *--------------------------------------------------------------*
     C     *PSSR         BEGSR
     C                   RETURN    *NULL
     C                   ENDSR
      *--------------------------------------------------------------*
     P #RtvLibL        E
      *//////////////////////////////////////////////////////////////*
      * (#VerLib) Verify that a library is in the library list and   *
      *  return the postion that the library is in.  If the value    *
      *  returned is 0, the library is not in the library list.  If  *
      *  the value -1 is returned, an error occured.                 *
      *                                                              *
      * Use: #VerLib(library :                                       *
      *              *SYSTEM | *PRODCUT | *CURRENT | *USER)          *
      *//////////////////////////////////////////////////////////////*
     P #VerLib         B                   EXPORT
      *--------------------------------------------------------------*
     D #VerLib         PI             2  0
     D  Lib                          10    VALUE
     D  LibType                      10    VALUE
      *
     D LibPtr          S               *
      *
     D MaxLibs         C                   CONST(25)
      *
     D LibData         DS                  BASED(LibPtr)
     D  #Libs                         9B 0
     D  LibArr                       10    DIM(MaxLibs)
      *
     D i               S              2  0
      *--------------------------------------------------------------*
     C                   eval      LibPtr = #RtvLibL(LibType)
      *
     C                   if        (LibPtr = *NULL)
     c                   RETURN    -1
     C                   endif
      *
     C                   eval      i = 1
     C     Lib           LOOKUP    LibArr(i)                              99
      *
     C                   if        (*IN99)
     C                   RETURN    i
     C                   else
     C                   RETURN    0
     C                   endif
      *--------------------------------------------------------------*
     C     *PSSR         BEGSR
     C                   RETURN    -1
     C                   ENDSR
      *--------------------------------------------------------------*
     P #VerLib         E

Thanks to Bradley V. Stone
Back

Page #6 Page #8

Back