contact image

Application Programming Interface (API)

This section provides introductory, conceptual, and guidance information about how to use OS/400 application programming interfaces (APIs) with your application programs.


Post Your Example

using QWCCVTDT to get UTC time


Sample from Jamie Flanary posted at 2014-12-17 17:21:15

                                                                        
ddsDateStruc      ds                  Qualified                         
d Date                           8S 0                                   
d Time                           6S 0                                   
d MilliSec                       6S 0                                   
dInputStruc       DS                  LikeDS(dsDateStruc) Inz           
dOutputStruc      DS                  LikeDS(dsDateStruc) Inz           
                                                                        
ddsTimeZone       DS                  Qualified                         
d BytesReturned                 10I 0                                   
d BytesAvailable                10I 0                                   
d TimeZoneName                  10                                      
d Reserved1                      1                                      
d DaylightSaving                 1                                      
d CurOffset                     10I 0                                   
d CurFullName                   50                                      
d CurAbbrName                   50                                      
d MsgFile                       10                                      
d MsgFileLib                    10                                      
                                                                        
ddsErrCode        ds                  Qualified                            
d BytesProvided                 10I 0 Inz(%Size(dsErrCode.MsgData))        
d BytesAvail                    10I 0                                      
d ExceptionID                    7                                         
d Reserved                       1                                         
d MsgData                      128                                         

 //                                                                 
dCvtDateTimeFmt   pr                  ExtPgm('QWCCVTDT')            
d InputFormat                   10    Const                         
d InputTS                             Const LikeDS(dsDateStruc)     
d OutputFormat                  10    Const                         
d OutputTS                            LikeDS(dsDateStruc)           
d dsErrCode                           LikeDS(dsErrCode)             
d InputTZ                       10    Const                         
d OutputTZ                      10    Const                         
d TimeZoneInfo                        LikeDs(dsTimeZone)            
d TimeZoneInfoL                 10I 0 Const                         
d PrecisionInd                   1    Const                         

                                                                                             
         // 2002-05-30T09:30:10.5                                                            
         // 2014-10-03-15.07.10.646000    jamie UTC                                          
         //  Q0000UTC    0:00 Coordinated Universal Time (UTC)   --or-- *UTC                 
         //  Q0000GMT    0:00 Greenwich Mean Time (GMT)                                      
         //  QN0400AST  -4:00 Atlantic Standard Time (AST)                                   
         //  QN0500EST  -5:00 Eastern Standard Time (EST)                                    
         //  QN0500EST2 -5:00 Eastern Standard Time (EST)                                    
         //  QN0600CST  -6:00 Central Standard Time (CST)                                    
         //  QN0700MST  -7:00 Mountain Standard Time (MST)                                   
         //  QN0700MST2 -7:00 Mountain Standard Time (MST)                                   
         //  QN0700T    -7:00 Mountain Standard Time (T)                                     
         //  QN0800PST  -8:00 Pacific Standard Time (PST)                                    
         //  QN0800U    -8:00 Pacific Standard Time (U)                                      
         //  QN0900AST  -9:00 Alaska Standard Time (AST)                                     
         //                                                                                  
         exec sql Set :MytimeStamp = current_timestamp;                                      
                                                                                             
         parmInputTS = %timestamp(MyTimeStamp);                                              
         InputStruc.Date=%Int(%Char(%Date(parmInputTS):*ISO0));                              
         InputStruc.Time=%Int(%Char(%Time(parmInputTS):*ISO0));                  
         InputStruc.MilliSec=%SubDt(parmInputTS:*MS);                            
                                                                                 
         CvtDateTimeFmt('*YYMD':                                                 
                        InputStruc:                                              
                        '*YYMD':                                                 
                        OutputStruc:                                             
                        dsErrCode:                                               
                        'QN0600CST':                                             
                        '*UTC' :                                                 
                        dsTimeZone:                                              
                        %Size(dsTimeZone):                                       
                        (InputStruc.MilliSec>0));                                
                                                                                 
         //EVAL OutputStruc                                                      
         //OUTPUTSTRUC.DATE = 20141217.                                          
         //OUTPUTSTRUC.TIME = 194032.                                            
         //OUTPUTSTRUC.MILLISEC = 002403.                                        
         // CCYY-MM-DD-HH.NN.00.000000                                           
         worktimestamp = %subst(%char(OUTPUTSTRUC.DATE):1:4)  + '-' +                 
                         %subst(%char(OUTPUTSTRUC.DATE):5:2)  + '-' +                 
                         %subst(%char(OUTPUTSTRUC.DATE):7:2)  + '-' +                 
                         %subst(%char(OUTPUTSTRUC.TIME):1:2)  + '.' +                 
                         %subst(%char(OUTPUTSTRUC.TIME):3:2)  + '.' +                 
                         %subst(%char(OUTPUTSTRUC.TIME):5:2)  + '.' +                 
                         %char(OUTPUTSTRUC.MILLISEC);                                 
                                                                                      
         test(ze)   worktimestamp;                                                    
         if not %error;                                                               
          isotimestamp = %timestamp(worktimestamp);                                   
          mytimestamp = %char(isotimestamp);                                          
         endif;  

Communicate in REXX with ordinary screens using DynamicScreenManager API's


Sample from Martin posted at 2013-05-08 08:37:53

/* converse with the user in REXX with screens */
trace n
/* this sample shows this screen:
 ------------------------------------------------------------
 |                                                          |
 | Your name:  ?                                            |
 |                                                          |
 ------------------------------------------------------------
 you enter a name and it shows:
 ------------------------------------------------------------
 |                                                          |
 | Your name:  john                                         |
 | So: your name is john                                    |
 ------------------------------------------------------------
compile the program EXFMT and run this sample to verify.
*/
 
/* define the window */
 infds.nf   = 0    /* n° fields, counted by AddFld */
 infds.aid  = 0    /* aid after exfmt: 0:enter 1-24 F.. */
 infds.row  = 3    /* initial cursor pos on screen */
 infds.col  = 16
 infds.cmd  = 'E'  /* E: exfmt */
 infds.cls  = '1'  /* Clr screen *on / *off */
 infds.msg  = ''   /* error message */

/* define each field in order Row, column */
/* the stem fld.i is obbligatory for the routines below */
 i = 1
 fld.i.row    = 1      /* field row (leave room for attribute) */
 fld.i.col    = 2      /* field column */
 fld.i.cpt    = 'T'    /* type: T:literal, C: editable field, P: protected field */
 fld.i.an     = 'A'    /* type: A: alfanumeric, U: idem uppercase, N:numeric, M:numeric zerofill */
 fld.i.attr   = ' '    /* attribute: C: Columnseparator, B: Blinking, U: Underline, H: Highlighted
                                     R: Reverse, N: Nondisplay, Else: Normal: for black/white 5250 */
 fld.i.color  = 28     /* color in hex 20:green, 28 red, etc, see QSNAPI copybook, for all 5250 */
 fld.i.len    = 60     /* n° bytes of field */
 fld.i.text   = '------------------------------------------------------------'
                       /* value of field on screen */
 fld.i.err    = '0'    /* field is in error? will be displayed reverse highlight. *on / *off */
 fld.i.mdt    = '0'    /* mdt set */
 call AddFld
 i = 2
 fld.i.row    = 2
 fld.i.col    = 2
 fld.i.cpt    = 'T'
 fld.i.an     = 'A'
 fld.i.attr   = ' '
 fld.i.color  = 28
 fld.i.len    = 1
 fld.i.text   = '|'
 fld.i.err    = '0'
 fld.i.mdt    = '0'
 call AddFld
 i = 3
 fld.i.row    = 2
 fld.i.col    = 4
 fld.i.cpt    = 'T'
 fld.i.an     = 'A'
 fld.i.attr   = ' '
 fld.i.color  = 20
 fld.i.len    = 58
 fld.i.text   = ' '
 fld.i.err    = '0'
 fld.i.mdt    = '0'
 call AddFld
 i = 4
 fld.i.row    = 2
 fld.i.col    = 61
 fld.i.cpt    = 'T'
 fld.i.an     = 'A'
 fld.i.attr   = 'H'
 fld.i.color  = 28
 fld.i.len    = 1
 fld.i.text   = '|'
 fld.i.err    = '0'
 fld.i.mdt    = '0'
 call AddFld
 i = 5
 fld.i.row    = 3
 fld.i.col    = 2
 fld.i.cpt    = 'T'
 fld.i.an     = 'A'
 fld.i.attr   = ' '
 fld.i.color  = 28
 fld.i.len    = 1
 fld.i.text   = '|'
 fld.i.err    = '0'
 fld.i.mdt    = '0'
 call AddFld
 i = 6
 fld.i.row    = 3
 fld.i.col    = 4
 fld.i.cpt    = 'T'
 fld.i.an     = 'A'
 fld.i.attr   = 'N'
 fld.i.color  = 20
 fld.i.len    = 10
 fld.i.text   = 'Your name:'
 fld.i.err    = '0'
 fld.i.mdt    = '0'
 call AddFld
 i = 7
 fld.i.row    = 3
 fld.i.col    = 16
 fld.i.cpt    = 'C'
 fld.i.an     = 'A'
 fld.i.attr   = ' '
 fld.i.color  = 20
 fld.i.len    = 20
 fld.i.text   = '?'
 fld.i.err    = '0'
 fld.i.mdt    = '0'
 call AddFld
 i = 8
 fld.i.row    = 3
 fld.i.col    = 61
 fld.i.cpt    = 'T'
 fld.i.an     = 'A'
 fld.i.attr   = 'H'
 fld.i.color  = 28
 fld.i.len    = 1
 fld.i.text   = '|'
 fld.i.err    = '0'
 fld.i.mdt    = '0'
 call AddFld
 i = 9
 fld.i.row    = 4
 fld.i.col    = 2
 fld.i.cpt    = 'T'
 fld.i.an     = 'A'
 fld.i.attr   = ' '
 fld.i.color  = 28
 fld.i.len    = 1
 fld.i.text   = '|'
 fld.i.err    = '0'
 fld.i.mdt    = '0'
 call AddFld
 i = 10
 fld.i.row    = 4
 fld.i.col    = 4
 fld.i.cpt    = 'T'
 fld.i.an     = 'A'
 fld.i.attr   = ' '
 fld.i.color  = 20
 fld.i.len    = 58
 fld.i.text   = ' '
 fld.i.err    = '0'
 fld.i.mdt    = '0'
 call AddFld
 i = 11
 fld.i.row    = 4
 fld.i.col    = 61
 fld.i.cpt    = 'T'
 fld.i.an     = 'A'
 fld.i.attr   = 'H'
 fld.i.color  = 28
 fld.i.len    = 1
 fld.i.text   = '|'
 fld.i.err    = '0'
 fld.i.mdt    = '0'
 call AddFld
 i = 12
 fld.i.row    = 5
 fld.i.col    = 2
 fld.i.cpt    = 'T'
 fld.i.an     = 'A'
 fld.i.attr   = ' '
 fld.i.color  = 28
 fld.i.len    = 60
 fld.i.text   = '------------------------------------------------------------'
 fld.i.err    = '0'
 fld.i.mdt    = '0'
 call AddFld

 call exfmt

 i = 10
 fld.i.color  = 20
 fld.i.text   = "So: your name is "||fld.7.text
 call ModFld

 call exfmt
 return

AddFld: /* add a field to the collection of fields to display */
  if flds = 'FLDS' then flds = ''
  infds.nf = infds.nf + 1
  fld = right('00'||fld.i.row,2) || ,
        right('000'||fld.i.col,3) || ,
        fld.i.cpt ||,
        '        ' ||,
        fld.i.attr ||,
        fld.i.an   ||,
        x2c(fld.i.color) ||,
        right('00'||fld.i.len,2) || ,
        left(fld.i.text,80) || ,
        fld.i.err || fld.i.mdt
  flds = flds || fld
  return

ModFld: /* modify field n° "i" in the collection of fields */
  fld = right('00'||fld.i.row,2) || ,
        right('000'||fld.i.col,3) || ,
        fld.i.cpt ||,
        '        ' ||,
        fld.i.attr ||,
        fld.i.an   ||,
        x2c(fld.i.color) ||,
        right('00'||fld.i.len,2) || ,
        left(fld.i.text,80) || ,
        fld.i.err || fld.i.mdt
  flds = substr(flds,1,(i-1)*101) || fld || substr(flds,i*101+1)
  return

Exfmt: /* show the screen and get the aid, row/col of cursor and text entered */
  InfDs = right('000'||infds.nf,3) || ,
          right('00'||infds.aid,2) || ,
          right('00'||infds.row,2) || ,
          right('000'||infds.col,3) || ,
          infds.cmd ||,
          infds.cls ||,
          right('00'||length(infds.msg),2) ||,
          left(infds.msg,78) ||,
          '0000000000'||'0000000000'||'0000000000'||'0000000000'||'0000000000'||,
          '0000000000'||'0000000000'||'0000000000'||'0000000000'||'000000000'
  "CALL EXFMT PARM(&INFDS &FLDS)"
  infds.aid = substr(infds,4,2)
  infds.row = substr(infds,6,2)
  infds.col = substr(infds,8,3)
  do i=1 to infds.nf
    sp = (i-1)*101
    if substr(flds,sp+6,1) <> 'T' then do
       fld.i.text = substr(flds,sp+20,fld.i.len)
       fld.i.mdt = substr(flds,sp+101,1)
    end
  end
  return

list *DTAARA in all Libraries


Sample from As400pro posted at 2013-03-29 05:14:44

     H OPTION(*NODEBUGIO) ACTGRP(*NEW)                                                              
‚     *************************************************************************                    €
‚     *                                                                                            €
‚     *  Stand Alone variables                                                                     €
‚     *                                                                                            €
     d AllText         s             10    Inz('*ALL')                                              
     d Chr8            s              8                                                             
     d Count           s              4  0                                                          
     d Count2          s              4  0                                                          
     d cymd            s              7  0                                                          
     d CreateDateISO   s               D                                                            
     d EntryFmt        s             10    inz('*FIRST')                                            
     d Fds#            s             10i 0                                                          
     d FFds#           s             10i 0                                                          
     d FileLib         s             20                                                             
     d GenLen          s              8                                                             
     d Header          s           2000                                                             
     d I               s             15  0                                                          
     d Infile          s             10                                                             
     d InLibrary       s             10                                                             
     d InType          s             10                                                             
     d MyFiles         s             10    dim(1000)                                                
     d MyFilesFound    s             10    dim(1000)                                                
     d ObjectLib       s             20                                                             
     d ReceiveVr2      s            100                                                             
     d RelRecNbr       s              4  0                                                          
     d RelRecHi#       s              4  0                                                          
     d SpaceVal        s              1    inz(*BLANKS)                                             
     d SpaceAuth       s             10    inz('*CHANGE')                                           
     d SpaceText       s             50    inz(*BLANKS)                                             
     d SpaceRepl       s             10    inz('*YES')                                              
     d SpaceAttr       s             10    inz(*BLANKS)                                             
     d TodayISO        s               d                                                            
     d UserSpaceOut    s             20                                                             
     d Worktype        s             10    inz('*DTAARA')                                           
‚     *                                                                                            €
‚     *  Data structures                                                                           €
     d GENDS2          ds                  qualified                                                
     d  Filler1                     116                                                             
     d  OffsetHdr                    10i 0                                                          
     d  SizeHeader                   10i 0                                                          
     d  OffsetList                   10i 0                                                          
     d  Filler2                       4                                                             
     d  NbrInList                    10i 0                                                          
     d  SizeEntry                    10i 0                                                          
                                                                                                    
     d HeaderDs        ds                                                                           
     d  OutFileNam                   10    overlay(HeaderDS:1)                                      
     d  OutLibName                   10    overlay(HeaderDS:11)                                     
     d  OutType                       5    overlay(HeaderDS:21)                                     
     d  OutFormat                    10    overlay(HeaderDS:31)                                     
     d  RecordLen                    10i 0 overlay(HeaderDS:41)                                     
                                                                                                    
     d ListDs          ds                  Qualified                                                
     d  FieldName                    10    overlay(ListDS:1)                                        
     d  FieldType                     1    overlay(ListDS:11)                                       
     d  BufferOut                    10i 0 overlay(ListDS:13)                                       
     d  FieldLen                     10i 0 overlay(ListDS:21)                                       
     d  Digits                       10i 0 overlay(ListDS:25)                                       
     d  Decimals                     10i 0 overlay(ListDS:29)                                       
     d  FieldDesc                    50    overlay(ListDS:33)                                       
                                                                                                    
     d APIErrorDS      ds                  Qualified                                                
     d  BytesP                       10I 0 inz(%size(apiErrorDS))                                   
     d  BytesA                       10I 0 inz(0)                                                   
     d  Messageid                     7                                                             
     d  Reserved                      1                                                             
     d  messagedta                  128                                                             
                                                                                                    
     d                 ds                                                                           
     d  StartPosit                   10i 0                                                          
     d  StartLen                     10i 0                                                          
     d  SpaceLen                     10i 0                                                          
     d  ReceiveLen                   10i 0                                                          
     d  MessageKey                   10i 0                                                          
     d  MsgDtaLen                    10i 0                                                          
     d  MsgQueNbr                    10i 0                                                          
      *                                                                                             
     dGenSpcPtr                        *                                                            
     dLstSpcPtr                        *                                                            
     dHdrPtr                           *                                                            
                                                                                                    
      *                                                                                             
     d GENDS           ds                                                                           
     d  OffsetHdr                    10i 0  overlay(GENDS:1)                                        
     d  NbrInList                    10i 0  overlay(GENDS:9)                                        
     d  SizeEntry                    10i 0  overlay(GENDS:13)                                       
      *                                                                                             
      * Date structure for retriving userspace info                                                 
      *                                                                                             
     d InputDs         DS                                                                           
     d  UserSpace              1     20                                                             
     d  SpaceName              1     10                                                             
     d  SpaceLib              11     20                                                             
     d  InpFileLib            29     48                                                             
     d  InpFFilNam            29     38                                                             
     d  InpFFilLib            39     48                                                             
     d  InpRcdFmt             49     58                                                             
      *                                                                                             
     d ListQPAD        ds                  qualified                                                
     d  Object                       10                                                             
     d  Library                      10                                                             
     d  ObjectType                   10                                                             
     d  InfoStatus                    1                                                             
     d  ExtObjAttrib                 10                                                             
     d  Description                  50                                                             
     **-- Object description structure OBJD0400:  ----------------------------**                    
     d ObjectDs        ds                  qualified  inz                                           
     d  ObjDscLen                    10i 0                                                          
     d  ObjDscSiz                    10i 0                                                          
     d  ObjNam                       10                                                             
     d  ObjLib                       10                                                             
     d  ObjTyp                       10                                                             
     d  ObjRtnLib                    10                                                             
     d  ObjAsp                       10i 0                                                          
     d  ObjOwnr                      10                                                             
     d  ObjDmn                        2                                                             
     d  ObjCrtDat                    13                                                             
     d  ObjChgDat                    13                                                             
      *                                                                                             
     d  ObjAtr                       10                                                             
     d  ObjTxt                       50                                                             
     d  ObjSrcFil                    10                                                             
     d  ObjSrcLib                    10                                                             
     d  ObjSrcMbr                    10                                                             
      *                                                                                             
     d  ObjSrcChgDat                 13                                                             
     d  ObjSrcSavDat                 13                                                             
     d  ObjSrcRstDat                 13                                                             
     d  ObjCrtUsr                    10                                                             
     d  ObjCrtSys                     8                                                             
     d  ObjResDat                     7                                                             
     d  ObjSavSiz                    10i 0                                                          
     d  ObjSavSeq                    10i 0                                                          
     d  ObjStg                       10                                                             
     d  ObjSavCmd                    10                                                             
     d  ObjSavVolId                  71                                                             
     d  ObjSavDvc                    10                                                             
     d  ObjSavFil                    10                                                             
     d  ObjSavLib                    10                                                             
     d  ObjSavLvl                     9                                                             
     d  ObjCompiler                  16                                                             
     d  ObjLvl                        8                                                             
     d  ObjUsrChg                     1                                                             
     d  ObjLicPgm                    16                                                             
     d  ObjPtf                       10                                                             
     d  ObjApar                      10                                                             
      *  start of four                                                                              
     d  ObjUseDat                     7                                                             
     d  ObjUsgInf                     1                                                             
     d  ObjUseDay                    10i 0                                                          
     d  ObjSiz                       10i 0                                                          
     d  ObjSizMlt                    10i 0                                                          
     d  ObjCprSts                     1                                                             
     d  ObjAlwChg                     1                                                             
     d  ObjChgByPgm                   1                                                             
     d  ObjUsrAtr                    10                                                             
     d  ObjOvrflwAsp                  1                                                             
     d  ObjSavActDat                  7                                                             
     d  ObjSavActTim                  6                                                             
     d  ObjAudVal                    10                                                             
     d  ObjPrmGrp                    10                                                             
                                                                                                    
     **-- Retrieve object description:  -------------------------------                             
     d $RtvObjD        Pr                  ExtPgm( 'QUSROBJD' )                                     
     d  RoRcvVar                  32767a         Options( *VarSize )                                
     d  RoRcvVarLen                  10i 0 Const                                                    
     d  RoFmtNam                      8a   Const                                                    
     d  RoObjNamQ                    20a   Const                                                    
     d  RoObjTyp                     10a   Const                                                    
     d  RoError                   32767a         Options( *VarSize )                                
     **-- List objects:   ---------------------------------------------                             
     d $ListObjects    Pr                  ExtPgm( 'QUSLOBJ' )                                      
     d  userspace                    20a   Const                                                    
     d  format                        8a   Const                                                    
     d  objectlib                    20a   Const                                                    
     d  type                         10a   Const                                                    
     **-- Userspace pointer: ------------------------------------------                             
     d $Userspace      Pr                  ExtPgm( 'QUSRTVUS' )                                     
     d  userspace                    20a   Const                                                    
     d  start                        10i 0 Const                                                    
     d  Length                       10i 0 Const                                                    
     d  Returned                  32767a         Options( *VarSize )                                
     **-- Create Space:   ---------------------------------------------                             
     d $CreateSpace    Pr                  ExtPgm( 'QUSCRTUS' )                                     
     d  UserSpaceOut                 20a   Const                                                    
     d  SpaceAttr                    10    Const                                                    
     d  SpaceLen                     10i 0 Const                                                    
     d  SpaceVal                      1a   Const                                                    
     d  SpaceAuth                    10a   Const                                                    
     d  SpaceText                    50a   Const                                                    
     d  SpaceRepl                    10a   Const                                                    
     d  APIErrorDs                32767a         Options( *VarSize )                                
                                                                                                    
‚     *---------------------------------------------------------------                             €
‚     *  M A I N   L I N E                                                                         €
‚     *---------------------------------------------------------------                             €
‚     *                                                                                            €
      /free                                                                                         
          // find all files in the passed in Library                                                
                 Spacename = 'MYPADS';                                                              
                 exsr $QUSCRTUS;                                                                    
                                                                                                    
                 ObjectLib =  '*ALL      ' + '*ALL';                                                
         //                                                                                         
         // List all the outqueues to the user space                                                
         //                                                                                         
                 $ListObjects( Userspace : 'OBJL0200' : ObjectLib : WorkType);                      
         //                                                                                         
         // Retrive header entry and process the user space                                         
         //                                                                                         
                 StartPosit = 125;                                                                  
                 StartLen   = 16;                                                                   
                 $UserSpace( Userspace : StartPosit : StartLen : GENDS);                            
                                                                                                    
                 StartPosit = OffsetHdr + 1;                                                        
                 StartLen = %size(ListQPAD);                                                        
         //                                                                                         
‚        // Do for number of outqueues in the userspace                            €                
         //                                                                                         
                                                                                                    
B1               for count = 1 to  NbrInList;                                                       
                  $UserSpace( Userspace : StartPosit : StartLen : ListQPAD);                        
                  StartPosit += SizeEntry;                                                          
                  if %scan('QSYS': ListQPAD.Library) = *zeros;                                      
                   // retrieve the device description                                               
                   $RtvObjD( ObjectDS                                                               
                             : %Size( ObjectDS )                                                    
                             : 'OBJD0400'                                                           
                             : ListQPAD.Object + ListQPAD.library                                   
                             : ListQPAD.ObjectType                                                  
                             : ApiErrorDS                                                           
                                              );                                                    
                                                                                                    
                  endif;                                                                            
                 endfor;                                                                            
                                                                                                    
                 clear Myfiles;                                                                     
                 reset Fds#;                                                                        
                 clear MyFiles;                                                                     
                 reset fds#;                                                                        
                                                                                                    
                 for count = 1 to FFds#;                                                            
                 endfor;                                                                            
                                                                                                    
                 *inlr = *on;                                                                       
                                                                                                    
        //--------------------------------------------------------                                  
        // $QUSCRTUS - create userspace                                                             
        //--------------------------------------------------------                                  
                 begsr $QUSCRTUS;                                                                   
                                                                                                    
                  APIErrorDS.BytesP = 116;                                                          
                  SpaceLib = 'QTEMP';                                                               
                                                                                                    
               //                                                                                   
               // Create the user space                                                             
               //                                                                                   
                  $CreateSpace( Userspace : SpaceAttr : 4096 :                                      
                                SpaceVal : SpaceAuth : SpaceText : SpaceRepl:                       
                                APIErrorDs);                                                        
                 endsr;                                                                             

RAW..example check password


Sample from Jimmyoctane posted at 2012-10-30 10:34:47

      *-------------------------------------------------------------------------------------------  
      * PROGRAM - WEBLOGIN                                                                          
      * PURPOSE - Web login validation and return                                                   
      * WRITTEN - 10/30/2012                                                                        
      * AUTHOR  - jamie flanary                                                                     
                                                                                                    
      * PROGRAM DESCRIPTION                                                                         
      *   Web login validation and return                                                           
      *                                                                                             
      * INDICATOR USAGE                                                                             
      *   03 - leave current screen                                                                 
      *                                                                                             
      *-------------------------------------------------------------------------------------------  
      *                                                                                             
      * *entry plist                                                                                
      *                                                                                             
     d WEBLOGIN        pr                                                                           
     d  userid                       10    const                                                    
     d  Password                     10    const                                                    
     d  ErrorCode                    07    options(*nopass:*omit)                                   
     d  Message                      40    options(*nopass:*omit)                                   
                                                                                                    
     d WEBLOGIN        pi                                                                           
     d  userid                       10    const                                                    
     d  Password                     10    const                                                    
     d  ErrorCode                    07    options(*nopass:*omit)                                   
     d  Message                      40    options(*nopass:*omit)                                   
                                                                                                    
      * variables                                                                                   
     d CCSID           s             10i 0 inz(37)                                                  
     d count           s              3  0 inz                                                      
     d PasswordLen     s             10i 0 inz(10)                                                  
     d ProfileHandle   s             12    inz                                                      
     d WReplaceData    s            100A   Inz(*Blanks)                                             
     d WMessage        s            100a   Inz(*blanks)                                             
     d WMsgFile        s             10A                                                            
     d WMsgLibrary     s             10A                                                            
     d WMsgFileLib     s             20A                                                            
     d WMaxMsgLen      s             10i 0 inz(%size(WMessage))                                     
                                                                                                    
     dPasswordDS       ds                  Qualified                                                
     d bytesProvided                 10i 0                                      Bytes Provided      
     d bytesAvailable                10i 0                                      Bytes Available     
     d errorID                        7                                         Exception Id        
     d reserved                       1                                         Reserved            
     d ErrorString                  250    Varying                                                  
                                                                                                    
     d ErrorDS         ds                  qualified                                                
     d    bytesProv                  10i 0 inz(0)                                                   
     d    bytesAvail                 10i 0 inz(0)                                                   
                                                                                                    
     d RTVM0100        ds                  qualified                                                
     d    WMsgLen                    10i 0 overlay(RTVM0100:9)                                      
     d    WMsgData                32767a   overlay(RTVM0100:25)                                     
                                                                                                    
      //                                                                                            
      //  external called programs                                                                  
      //                                                                                            
                                                                                                    
     d $checkpassword  pr                  ExtPgm('QSYGETPH')                                       
     d   UserID                      10a   const                                                    
     d   password                    10a   const                                                    
     d   ProfileHndl                 12a                                                            
     d   QUSEC                             likeds(PasswordDS)                                       
     d   PasswordLen                 10i 0 const                                                    
     d   CCSID                       10i 0 const                                                    
                                                                                                    
     d $GetMessage     pr                  extpgm('QMHRTVM')                                        
     d  WRcvVar                   65535A   Options(*VarSize)                                        
     d  WRcvVarLen                   10I 0 Const                                                    
     d  WFormat                       8A   Const                                                    
     d  WMsgID                        7A   Const                                                    
     d  WQualMsgF                    20A   Const                                                    
     d  WReplData                 65535A   Const Options(*VarSize)                                  
     d  WReplDataLen                 10I 0 Const                                                    
     d  WDoReplace                   10A   Const                                                    
     d  WUseCtrlChars                10A   Const                                                    
     d  WErrorCode                65535A   Options(*VarSize)                                        
     d  WRetrOpt                     10A   Const Options(*NoPass)                                   
     d  WRetrOpt                     10A   Const Options(*NoPass)                                   
     d  WCCSID_out                   10I 0 Const Options(*NoPass)                                   
     d  WCCSID_in                    10I 0 Const Options(*NoPass)                                   
      *------------------------------------------------------------                                 
      *  M A I N    L I N E                                                                         
      *------------------------------------------------------------                                 
                                                                                                    
12345 /free                                                                                         
                                                                                                    
            $checkpassword( userid :                                                                
                            Password :                                                              
                            ProfileHandle :                                                         
                            PasswordDS :                                                            
                            PasswordLen :                                                           
                            CCSID);                                                                 
                                                                                                    
            errorcode =  PasswordDS.errorID;                                                        
            if errorcode > *blanks;                                                                 
             exsr $getTheMessageDescription;                                                        
             Message = Wmessage;                                                                    
            endif;                                                                                  
                                                                                                    
            *inlr = *on;                                                                            
                                                                                                    
        //--------------------------------------------------------                                  
        // $GetTheMessageDescription - return message description                                   
        //--------------------------------------------------------                                  
             begsr $GetTheMessageDescription;                                                       
                                                                                                    
               WMsgFile = 'QCPFMSG';                                                                
               WMsgLibrary = 'QSYS';                                                                
               WMsgFileLib = WMsgFile + WMsgLibrary;                                                
               WReplaceData = userid;                                                               
                                                                                                    
               $GetMessage(RTVM0100                                                                 
                             : %size( RTVM0100 )                                   // return data   
                             : 'RTVM0100'                                          // return data   
                             : errorcode                                           // msg id        
                             : WMsgFileLib                                         // msg file,     
                             : WReplaceData                                        // msg parameter 
                             : %size(WReplaceData)                                 // msg parameter 
                             : '*YES'                                              // substitute MSG
                             : '*NO'                                               //  control chars
                             : ErrorDS                                                              
                             );                                                                     
                                                                                                    
               if (RTVM0100.WMsgLen > *Zeros);                                                      
                if (RTVM0100.WMsgLen > WMaxMsgLen);                                                 
                 RTVM0100.WMsgLen = WMaxMsgLen;                                                     
                endif;                                                                              
                // retrieve the message with message data inserted                                  
                WMessage = %subst(RTVM0100.WMsgData : 1 : RTVM0100.WMsgLen);                        
               else;                                                                                
                WMessage = *Blanks;                                                                 
               endif;                                                                               
                                                                                                    
             endsr;                                                                                 
                                                                                                    
      /end-free                                                                                     

Convert a file, typically XML, from UTF-16 Little Endian to UTF-16 Big Endian because the IBM i cannot process Little Endian xml files via XML-INTO.


Sample from Bryce Martin posted at 2012-07-25 07:54:57

     HDFTACTGRP (*NO)
     HACTGRP (*NEW)
     Hbnddir('QC2LE')
     H*/COPY QCPYLESRC,NTCSTDHDR
     H/COPY QCPYLESRC,CONVLE2BEY
     H/COPY QCPYLESRC,IFSIO_H
     H/COPY QCPYLESRC,ERRNO_H
     H/COPY QCPYLESRC,ICONV_H
     F**********************************************************************
     F* PURPOSE
     F*   CONVERT XML FILE FROM UTF-16 LE TO UTF-16 BE
     F***********************MAINTENANCE LIST*******************************
     F* PROJECT PGMR
     F*   01624 BKM
     F**********************************************************************
     F* TO COMPILE:
     F*  CRTBNDRPG PGM(xxxxx) SRCFILE(xxx/xxxx) DFTACTGRP(*NO) ACTGRP(*NEW)
     D**********************************************************************
     D* MAJORITY OF CODE TAKEN FROM
     D*  http://archive.midrange.com/rpg400-l/200003/msg00392.html
     D*  AND
     D*  http://www.scottklement.com/archives/ftpapi/201110/msg00095.html
     D*  -See project document for more details
     D**********************************************************************


      **********************************************************************
      *                                                                    *
      * oldfile has a size of 255 because that matches the NAME_MAX value. *
      * NAME_MAX is the maximum number of byes for a filename in the IFS.  *
      *                                                                    *
      **********************************************************************
     D CONVLE2BE...
     D                 PI
     D  path...
     D                              256A   const
     D  ofile...
     D                              255A   const
     D
     D CEERAN0         PR
     D  seed                         10I 0
     D  ranno                         8F
     D  fc                           12A   options(*omit)

     D seed...
     D                 S             10I 0
     D rand...
     D                 S              8F
     D oflag...
     D                 S             10U 0
     D omode...
     D                 S             10U 0
     D buffer...
     D                 S            128A
     D p_Buffer...
     D                 S               *   inz(%addr(buffer))
     D buflen...
     D                 S             10U 0
     D p_errno...
     D                 S               *
     D retval...
     D                 S             10I 0 based(p_errno)
     D newName...
     D                 S            256A
     D multiplier...
     D                 S              3S 0 inz(100)
     D result...
     D                 S              3S 0
     D pnf1...
     D                 S            256A
     D pnf2...
     D                 S            256A
     D fd1...
     D                 S             10I 0 inz(-1)
     D fd2...
     D                 S             10I 0 inz(-1)
     D info...
     D                 DS                  likeds(statds)
     D len...
     D                 S             10I 0
     D F1_size...
     D                 S             10I 0
     D memblock1...
     D                 S          16383C   based(p_memblock1)
     D memblock2...
     D                 S          16383C   based(p_memblock2) ccsid(1200)
     D inpptr...
     D                 S               *
     D outptr...
     D                 S               *
     D inpleft...
     D                 S             10U 0
     D outleft...
     D                 S             10U 0
     D outneed...
     D                 S             10U 0
      /free
         *inlr = *on;

         ///////////////////////////////////////////////////////////////////////
         //-------------------------------------------------------------------//
         //|                                                                 |//
         //| Open the UTF-16 LE file: Read Only                              |//
         //|                                                                 |//
         //-------------------------------------------------------------------//
         ///////////////////////////////////////////////////////////////////////
         pnf1 = %trim(path) + %trim(ofile);
         fd1 = open(%trimr(pnf1) : O_RDONLY);
         p_errno = sys_errno;
         if (fd1 = -1);
           dsply ('fd1: ' + %char(retval));
           return;
         endif;



         ///////////////////////////////////////////////////////////////////////
         //-------------------------------------------------------------------//
         //|                                                                 |//
         //| Create the UTF-16 BE file CCSID 1200                            |//
         //|                                                                 |//
         //-------------------------------------------------------------------//
         ///////////////////////////////////////////////////////////////////////
         seed = %subdt(%TimeStamp():*s);
         CEERAN0( seed : rand : *omit );
         result = rand * multiplier;
         newName = %char(result) + ofile;
         pnf2 = %trim(path) + %trim(newName);
         // set open flags to "create" for "read/write" with a codepage.
         oflag = O_CREAT + O_RDWR + O_CODEPAGE;

         // set mode to User=RW, Group=R, Other=R (RW-R--R--)
         omode = S_IRUSR+S_IWUSR+S_IRGRP+S_IROTH;

         fd2 = open(%trimr(pnf2): oflag: omode: CP_UCS2);

         if (fd2 < 0);
           p_errno = sys_errno;
           //Could not open the file.
           dsply ('Cannot create file!  ' + %char(retval));
           return;
         endif;

         callp close(fd2);


         ///////////////////////////////////////////////////////////////////////
         //-------------------------------------------------------------------//
         //|                                                                 |//
         //| Open the UTF-16 BE file CCSID 1200                              |//
         //|                                                                 |//
         //-------------------------------------------------------------------//
         ///////////////////////////////////////////////////////////////////////
         fd2 = open(%trimr(pnf2) : O_RDWR : O_LARGEFILE + O_TEXTDATA + O_CCSID
                                          + O_SHARE_NONE
                                 : 0 : CP_UCS2);
         p_errno = sys_errno;
         if (fd2 = -1);
           dsply ('fd2: ' + %char(retval));
           return;
         endif;


         ///////////////////////////////////////////////////////////////////////
         //-------------------------------------------------------------------//
         //|                                                                 |//
         //| Calculate filesize and reserver memory block                    |//
         //|                                                                 |//
         //-------------------------------------------------------------------//
         ///////////////////////////////////////////////////////////////////////
         if fstat(fd1: info) = -1;
           callp close(fd1);
           dsply 'fstat error';
           return;
         endif;
         F1_size = info.st_size;

         p_memblock1 = %alloc(F1_size);
         p_memblock2 = %alloc(F1_size);


         ///////////////////////////////////////////////////////////////////////
         //-------------------------------------------------------------------//
         //|                                                                 |//
         //| Read pnf1 into block of memory                                  |//
         //|                                                                 |//
         //-------------------------------------------------------------------//
         ///////////////////////////////////////////////////////////////////////
         lseek(fd1: 0: SEEK_SET);
         len = read(fd1: p_memblock1: F1_size);

         ///////////////////////////////////////////////////////////////////////
         //-------------------------------------------------------------------//
         //|                                                                 |//
         //| Convert from UTF-16 LE to UTF-16 BE CCSID 1200                  |//
         //|                                                                 |//
         //-------------------------------------------------------------------//
         ///////////////////////////////////////////////////////////////////////
         inpptr = p_memblock1;
         inpleft = len;
         outleft = len;
         outptr = p_memblock2;
         if QlgTransformUCSData( 050041
                              : inpptr
                              : inpleft
                              : outptr
                              : outleft
                              : outneed ) <> 0;
           p_errno = sys_errno;
           dsply ('Error on conversion: ' + %char(retval));
           return;
         endif;


         ///////////////////////////////////////////////////////////////////////
         //-------------------------------------------------------------------//
         //|                                                                 |//
         //| Write memory to UTF-16 BE CCSID 1200 file, close file           |//
         //| descriptors, and deallocate the memory.                         |//
         //|                                                                 |//
         //-------------------------------------------------------------------//
         ///////////////////////////////////////////////////////////////////////
         callp write(fd2: p_memblock2: len);

         callp close(fd1);
         callp close(fd2);

         dealloc p_memblock1;
         dealloc p_memblock2;


         ///////////////////////////////////////////////////////////////////////
         //-------------------------------------------------------------------//
         //|                                                                 |//
         //| Delete the original file                                        |//
         //|                                                                 |//
         //-------------------------------------------------------------------//
         ///////////////////////////////////////////////////////////////////////
         if unlink(%trimr(pnf1)) < 0;
           p_errno = sys_errno;
           dsply ('unlink error: ' + %char(retval));
           return;
         else;
           /////////////////////////////////////////////////////////////////////
           //-----------------------------------------------------------------//
           //|                                                               |//
           //| Rename the new file to be the name of the original file.      |//
           //|                                                               |//
           //-----------------------------------------------------------------//
           /////////////////////////////////////////////////////////////////////
           if rename(%trim(pnf2) : %trim(pnf1)) < 0;
             p_errno = sys_errno;
             dsply ('rename error: ' + %char(retval));
             return;
           else;
             dsply ('rename successful');
           endif;
         endif;


         return;

      /end-free

 

Example Dynamic Screen QsnWrtDta


Sample from Jamie Flanary posted at 2012-07-19 07:38:08

     h Option(*NODEBUGIO)  DFTACTGRP(*NO)                                                           
                                                                                                    
      /copy current,DYNO_CP                                                                         
                                                                                                    
     d $Screen1        pr           500a   varying                                                  
     d   Line                        78a   const dim(24) options(*varsize)                          
     d   NumLines                    10i 0 value                                                    
     d   AnsLen                      10i 0 value                                                    
     d   DataOut                    256                                                             
      *                                                                                             
      * local variables                                                                             
      *                                                                                             
     d Abort           s              1n                                                            
     d Choice#         s             10i 0                                                          
     d cmdlength       s             15  5                                                          
     d cmdstring       s            512                                                             
     d dec8            s              8  0                                                          
     d decimalanswer   s              1  0                                                          
     d end             s              3  0                                                          
     d endscreen1      s               n                                                            
     d Essay           s            500A                                                            
     d filename        s             80                                                             
     d foundAS400      s              3  0                                                          
     d Directory       s            256    varying                                                  
     d GrapTheFile     s               n                                                            
     d itemnumber      s              7  0                                                          
     d length          s             10i 0                                                          
     d Lines           s             78A   dim(24)                                                  
     d Mycount         s             10i 0                                                          
     d newname         s            512                                                             
     d password        s             10    inz('@PASSWORD')                                           
     d processing      s               n                                                            
     d Q               s              1    inz('''')                                                
      *                                        dns name or Ip address                               
     d remoteIP        s             15    inz('@SERVERNAME')                                             
     d*remoteIP        s             15    inz('192.168.1.100')                                     
     d reply           s              1                                                             
     d screenatr       s              1                                                             
     d screenerror     s               n                                                            
     d start           s              3  0                                                          
     d string          s            512                                                             
     d sqlstmt         s           2500    varying                                                  
     d teststring      s            512                                                             
     d theanswer       s              1                                                             
     d userid          s             10    inz('@USERID')                                             
     d workfile        s             80                                                             
     d workPO#         s              7  0                                                          
     d workPOLine#     s              3  0                                                          
      *                                                                                             
      * This is the return data from subprocedure $screen                                           
      * left at 256 so you can add bunch more return values                                         
      *                                                                                             
     d  dataout        ds           256    qualified inz                                            
     d    F3                           n   overlay(dataout:1)                                       
     d    Choice                      1    overlay(dataout:*next)                                   
      **---------------------------------------------------------------                             
      * external calls                                                                              
      **---------------------------------------------------------------                             
     d $command        pr                  extpgm( 'QCMDEXC' )                                      
     d   cmdstring                 2000    options( *varsize ) const                                
     d   cmdlength                   15  5                     const                                
      *                                                                                             
     d  mysqldata      ds                  qualified  inz                                           
     d   String                     512                                                             
      *                                                                                             
     d  mysqldata2     ds                  qualified  inz                                           
     d   String                     512                                                             
      *                                                                                             
     d  mysqldata3     ds                  qualified  inz                                           
     d   String                     512                                                             
      *                                                                                             
      * Sql functions                                                                               
      *                                                                                             
     d openlist        pr                                                                           
     d fetchnext       pr              n                                                            
     d closelist       pr                                                                           
                                                                                                    
      **---------------------------------------------------------------                             
      /free                                                                                         
                                                                                                    
         *inlr = *on;                                                                               
                                                                                                    
                                                                                                    
         directory = '/pdm/data/wkgshare/pfs/AS400_AuxiliaryFolder_wl ';                            
                                                                                                    
                                                                                                    
         exec sql  set option commit=*none,datfmt=*iso,                                             
                       closqlcsr=*ENDMOD;                                                           
                                                                                                    
                                                                                                    
        //--------------------------------------------------------                                  
        //     M A I N   L I N E                                                                    
        //--------------------------------------------------------                                  
                                                                                                    
         // ftp to server and get directory listing                                                 
                                                                                                    
             exsr $OverrideFiles;                                                                   
             exsr $ftpDirList;                                                                      
             exsr $startftp;                                                                        
                                                                                                    
             exsr $readoutput;                                                                      
             return;                                                                                
                                                                                                    
        //--------------------------------------------------------                                  
        // $ReadOutput - read the output file                                                       
        //--------------------------------------------------------                                  
             begsr $ReadOutput;                                                                     
                                                                                                    
                                                                                                    
              reset choice#;                                                                        
              // setup the title                                                                    
              Mycount +=1;                                                                          
              Lines(Mycount) = 'Select File to Process';                                            
              // add blank line                                                                     
              Mycount +=1;                                                                          
              Lines(Mycount) = *blanks;                                                             
                                                                                                    
                                                                                                    
              sqlstmt = 'Select * from OUTPUT';                                                     
                                                                                                    
               openList();                                                                          
               dow fetchNext();                                                                     
                // look for the direcotry listing and the file name                                 
                start = %scan('6-':mysqldata3.string);                                              
                // don't loop forever!                                                              
                FoundAS400 = %scan('AS400':mysqldata3.string);                                      
                if start > *zeros and FoundAS400 > *zeros;                                          
                 end = %scan('.txt':mysqldata3.string);                                             
                 if end > *zeros;                                                                   
                                                                                                    
                  length = end+4 - start;                                                           
                  filename = %subst(mysqldata3.string:start:length);                                
                                                                                                    
                  // increment the letter                                                           
                  Choice#+=1;                                                                       
                  Mycount+=1;                                                                       
                  lines(Mycount) = ' ' + %char(Choice#) + ') ' +                                    
                  %trim(filename);                                                                  
                                                                                                    
                  exsr $processfile;                                                                
                 endif;                                                                             
                endif;                                                                              
                                                                                                    
               enddo;                                                                               
               closeList();                                                                         
                                                                                                    
               // all files .txt are listed now show screen                                         
                                                                                                    
               if Mycount <= 2;                                                                     
                Mycount+=1;                                                                         
                lines(Mycount) = '** No Records Found **';                                          
               endif;                                                                               
                                                                                                    
               reset endscreen1;                                                                    
               dow not(EndScreen1);                                                                 
                if not(screenerror);                                                                
                 lines(20) = *blanks;                                                               
                endif;                                                                              
                reset dataout;                                                                      
                Dataout = $Screen1(lines:20:1:DataOut);                                             
                reset screenerror;                                                                  
                // this is the error line                                                           
                select;                                                                             
                 when dataout.F3 = *on;                                                             
                  EndScreen1 = *on;                                                                 
                  return;                                                                           
                 other;     // check answer                                                         
                  TheAnswer = dataout.choice;                                                       
                                                                                                    
                  exsr $validate;                                                                   
                  if not(screenerror);                                                              
                   exsr $getthefile;                                                                
                  endif;                                                                            
                                                                                                    
                endsl;                                                                              
                                                                                                    
               enddo;                                                                               
                                                                                                    
             endsr;                                                                                 
                                                                                                    
        //--------------------------------------------------------                                  
        // $Validate - validate the return selection                                                
        //--------------------------------------------------------                                  
             begsr $Validate;                                                                       
                                                                                                    
              reset screenerror;                                                                    
              // validate the answer                                                                
                                                                                                    
                                                                                                    
              if %check(' 0123456789':TheAnswer) > *zeros;                                          
               lines(20) = 'Entry ' + TheAnswer + ' is invalid';                                    
               screenerror = *on;                                                                   
              else;                                                                                 
               TheAnswer = %xlate(' ':'0':TheAnswer);                                               
               DecimalAnswer = %dec(TheAnswer:1:0);                                                 
               if DecimalAnswer > Choice#;                                                          
                lines(20) = 'Entry ' + TheAnswer + ' is Greater than ' +                            
                 %char(choice#);                                                                    
                screenerror = *on;                                                                  
               endif;                                                                               
              endif;                                                                                
                                                                                                    
                                                                                                    
             endsr;                                                                                 
                                                                                                    
        //--------------------------------------------------------                                  
        // $GettheFile - get the file from FTP and process it                                       
        //--------------------------------------------------------                                  
             begsr $GettheFile;                                                                     
                                                                                                    
                                                                                                    
                                                                                                    
             endsr;                                                                                 
                                                                                                    
        //--------------------------------------------------------                                  
        // $ProcessFile  - grab the file and do the work                                            
        //--------------------------------------------------------                                  
             begsr $ProcessFile;                                                                    
                                                                                                    
              // create pf in qtemp and do processing                                               
              cmdstring = 'CRTPF QTEMP/MYFILE RCDLEN(512) ';                                        
              cmdlength = %len(%trim(cmdstring));                                                   
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                     
              on-error;                                                                             
               cmdstring = 'CLRPFM QTEMP/MYFILE ';                                                  
               cmdlength = %len(%trim(cmdstring));                                                  
              endmon;                                                                               
                                                                                                    
              // remove any get commands from the imput file                                        
              exec sql                                                                              
               delete from QTEMP/MYFILE                                                             
               where myfile like '%MYFILE%';                                                        
                                                                                                    
              exec sql                                                                              
               delete from QTEMP/INPUT                                                              
               where myfield like '%DIR%';                                                          
                                                                                                    
              processing = *on;                                                                     
              exsr $OverrideFiles;                                                                  
              exsr $FtpDirList;                                                                     
              processing = *off;                                                                    
                                                                                                    
              mysqldata2.String = 'Get ' + %trim(filename) + ' QTEMP/MYFILE' +                      
               ' (replace ';                                                                        
              exec sql                                                                              
               insert into QTEMP/INPUT values(:mysqldata2);                                         
                                                                                                    
              // change extension of .txt file to .done                                             
              workfile = Filename;                                                                  
              end = %scan('.txt':workfile);                                                         
              %subst(workfile:end:5) = '.done';                                                     
              mysqldata2.String = 'Rename ' + %trim(filename) +                                     
              ' ' + %trim(workfile);                                                                
          //  exec sql                                                                              
          //   insert into QTEMP/INPUT values(:mysqldata2);                                         
              exsr $startFTP;                                                                       
                                                                                                    
             endsr;                                                                                 
                                                                                                    
        //--------------------------------------------------------                                  
        // $OverrideFiles - create input & output override files                                    
        //--------------------------------------------------------                                  
             begsr $OverrideFiles;                                                                  
                                                                                                    
              cmdstring = 'DLTOVR INPUT';                                                           
              cmdlength = %len(%trim(cmdstring));                                                   
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                     
              on-error;                                                                             
              endmon;                                                                               
                                                                                                    
              cmdstring = 'DLTOVR OUTPUT';                                                          
              cmdlength = %len(%trim(cmdstring));                                                   
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                     
              on-error;                                                                             
              endmon;                                                                               
                                                                                                    
              cmdstring = 'CLRPFM FILE(QTEMP/INPUT)';                                               
              cmdlength = %len(%trim(cmdstring));                                                   
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                     
              on-error;                                                                             
               exec sql                                                                             
                create table QTEMP/INPUT                                                            
                (MyField  char(512));                                                               
              endmon;                                                                               
                                                                                                    
              cmdstring = 'CLRPFM FILE(QTEMP/OUTPUT)';                                              
              cmdlength = %len(%trim(cmdstring));                                                   
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                     
              on-error;                                                                             
               exec sql                                                                             
                create table QTEMP/OUTPUT                                                           
                (MyField  char(512));                                                               
              endmon;                                                                               
                                                                                                    
             endsr;                                                                                 
        //--------------------------------------------------------                                  
        // $FtpDirList - get direcotory listing                                                     
        //--------------------------------------------------------                                  
             begsr $FtpDirList;                                                                     
                                                                                                    
             // commands to run on server                                                           
                                                                                                    
              mysqldata2.string = %trim(userid) + ' ' + %trim(password);                            
              exec sql                                                                              
               insert into QTEMP/INPUT values(:mysqldata2);                                         
                                                                                                    
              mysqldata2.String = 'ASCII';                                                          
              exec sql                                                                              
               insert into QTEMP/INPUT values(:mysqldata2);                                         
                                                                                                    
              mysqldata2.String =                                                                   
               'cd  ' + directory;                                                                  
              exec sql                                                                              
               insert into QTEMP/INPUT values(:mysqldata2);                                         
                                                                                                    
              if processing = *off;                                                                 
               mysqldata2.String =  'Dir ' ;                                                        
              endif;                                                                                
                                                                                                    
              exec sql                                                                              
               insert into QTEMP/INPUT values(:mysqldata2);                                         
                                                                                                    
              cmdstring = 'OVRDBF FILE(INPUT) TOFILE(QTEMP/INPUT)' +                                
                          ' OVRSCOPE(*JOB) ';                                                       
              cmdlength = %len(%trim(cmdstring));                                                   
              $command(cmdstring : cmdlength);                                                      
                                                                                                    
              cmdstring = 'OVRDBF FILE(OUTPUT) TOFILE(QTEMP/OUTPUT)' +                              
                          ' OVRSCOPE(*JOB) ';                                                       
              cmdlength = %len(%trim(cmdstring));                                                   
              $command(cmdstring : cmdlength);                                                      
                                                                                                    
             endsr;                                                                                 
                                                                                                    
        //--------------------------------------------------------                                  
        // $StartFTP;   Start FTP...                                                                
        //--------------------------------------------------------                                  
             begsr $StartFTP;                                                                       
                                                                                                    
              cmdstring = 'STRTCPFTP ' + Q + %trim(remoteIp)  + Q  ;                                
              cmdlength = %len(%trim(cmdstring));                                                   
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                     
              on-error;                                                                             
              endmon;                                                                               
                                                                                                    
             endsr;                                                                                 
                                                                                                    
      /end-free                                                                                     
                                                                                                    
      *--------------------------------------------------------                                     
      *  $Screen1():     Show Screen1 (Remote files via FTP)                                        
      *                                                                                             
      *     Line = (input) array of lines of text containing                                        
      *                 the question to ask                                                         
      * NumLines = (input) number of lines in the Line array                                        
      *   AnsLen = (input) size of answer blank                                                     
      *    DataOut = (output) position 1 F3 positon 2 answer                                        
      *                                                                                             
      * Returns the user's answer                                                                   
      *--------------------------------------------------------                                     
     p $Screen1        B                                                                            
                                                                                                    
     d $Screen1        PI           500A   varying                                                  
     d   Line                        78A   const                                                    
     d                                     dim(24) options(*varsize)                                
     d   NumLines                    10I 0 value                                                    
     d   AnsLen                      10I 0 value                                                    
     d   DataOut                    256                                                             
                                                                                                    
     d cmdbuf          s                   like(Qsn_Cmd_Buf_T)                                      
     d inpbuf          s                   like(Qsn_Inp_Buf_T)                                      
     d prompt          s             70A   varying                                                  
     d NRF             s             50    inz('** No Records Found **')                            
     d skipthis        s               n                                                            
     d len             s             10I 0                                                          
     d data            s            132A   varying                                                  
     d x               s             10I 0                                                          
     d Row             s              3U 0                                                          
     d Answer          s            500A   varying                                                  
      *                                                                                             
     d InputData       ds                  qualified                                                
     d                                     based(p_InputData)                                       
     d   Row                          3U 0                                                          
     d   Col                          3U 0                                                          
     d   AID                          1A                                                            
     d   Field                      500A                                                            
      /free                                                                                         
                                                                                                    
          // ----------------------------------------------                                         
          //  Create Input/Output buffers and clear them                                            
          // ----------------------------------------------                                         
          cmdbuf = QsnCrtCmdBuf(100: 50: 0: *OMIT: *OMIT);                                          
          inpbuf = QsnCrtInpBuf(200: 50: 0: *OMIT: *OMIT);                                          
          QsnClrBuf( cmdbuf : *omit );                                                              
          QsnClrBuf( inpbuf : *omit );                                                              
          // ----------------------------------------------                                         
          // Add the "Clear Screen" command to the output                                           
          //  so that the terminal starts with an empty                                             
          //  screen.                                                                               
          // ----------------------------------------------                                         
          QsnClrScr( *omit : cmdbuf : *omit : *omit );                                              
          // ----------------------------------------------                                         
          //  Put a screen title in the output buffer                                               
          // ----------------------------------------------                                         
          data = 'Select File to download and process.';                                            
          QsnWrtDta( data                                                                           
                   : %len(data)                                                                     
                   : *omit                                                                          
                   : 1                                                                              
                   : 40 - (%len(data)/2)  // center                                                 
                   : QSN_SA_HI                                                                      
                   : QSN_SA_HI                                                                      
                   : QSN_SA_WHT                                                                     
                   : QSN_SA_WHT                                                                     
                   : cmdbuf                                                                         
                   : *omit                                                                          
                   : *omit                                                                          
                   );                                                                               
          // ----------------------------------------------                                         
          // Put the filename on rows 3+ of the output buf                                          
          // ----------------------------------------------                                         
          row = 2;                                                                                  
          for x = 1 to NumLines;                                                                    
             row +=1;                                                                               
                                                                                                    
             Select;                                                                                
             when row = 3;                                                                          
              ScreenAtr = QSN_SA_PNK_UL;                                                            
              Length = 22;                                                                          
             when row = 22;                                                                         
              ScreenAtr = QSN_SA_RED;                                                               
              Length = %len(line(x));                                                               
             other;                                                                                 
              ScreenAtr = QSN_SA_GRN;                                                               
              Length = %len(line(x));                                                               
             endsl;                                                                                 
                                                                                                    
             if %scan(%trim(NRF):Line(x)) > *zeros;                                                 
              SkipThis = *on;                                                                       
             endif;                                                                                 
                                                                                                    
             QsnWrtDta( Line(x)                                                                     
                      : Length                                                                      
                      : *omit                                                                       
                      : row                                                                         
                      : 2                                                                           
                      : QSN_SA_NORM                                                                 
                      : QSN_SA_NORM                                                                 
                      : ScreenAtr                                                                   
                      : QSN_SA_GRN                                                                  
                      : cmdbuf                                                                      
                      : *omit                                                                       
                      : *omit                                                                       
                      );                                                                            
          endfor;                                                                                   
          // ----------------------------------------------                                         
          // Put an underlined blank input field into the                                           
          //  output buffer so the user has a place to                                              
          //  answer.. This is on Row 21                                                            
          // ----------------------------------------------                                         
          if not(SkipThis);                                                                         
                                                                                                    
           QsnSetFld( *omit                                                                         
                    : AnsLen                                                                        
                    : 21                                                                            
                    : 2                                                                             
                    : QSN_FFW_ALPHA_SHIFT                                                           
                    : *omit                                                                         
                    : 0                                                                             
                    : QSN_SA_UL                                                                     
                    : QSN_SA_GRN_UL                                                                 
                    : cmdbuf                                                                        
                    : *omit                                                                         
                    : *omit );                                                                      
          endif;                                                                                    
          // ----------------------------------------------                                         
          //   Let the user know how to exit  (color blue)                                          
          // ----------------------------------------------                                         
          QsnWrtDta( 'F3=Exit'                                                                      
                   : %len('F3=Exit')                                                                
                   : *omit                                                                          
                   : 23                                                                             
                   : 2                                                                              
                   : QSN_SA_HI                                                                      
                   : QSN_SA_NORM                                                                    
                   : QSN_SA_BLU                                                                     
                   : QSN_SA_GRN                                                                     
                   : cmdbuf                                                                         
                   : *omit                                                                          
                   : *omit                                                                          
                   );                                                                               
          // ----------------------------------------------                                         
          // put the "unlock keyboard" command into the                                             
          // output buffer                                                                          
          // ----------------------------------------------                                         
          QsnReadInp( QSN_CC1_MDTALL_CLRALL                                                         
                    : QSN_CC2_UNLOCKBD                                                              
                    : *omit                                                                         
                    : *omit                                                                         
                    : cmdbuf                                                                        
                    : *omit                                                                         
                    : *omit );                                                                      
          // ----------------------------------------------                                         
          // send the output buffer to the terminal, and                                            
          //  wait for input from the user                                                          
          // ----------------------------------------------                                         
          QsnPutGetBuf( cmdbuf: inpbuf: *omit: *omit);                                              
          // ----------------------------------------------                                         
          //  Get a pointer to the input data, and the                                              
          //   length of the input data.                                                            
          // ----------------------------------------------                                         
          p_InputData = QsnRtvDta( inpbuf: *omit: *omit );                                          
          Len = QsnRtvDtaLen(inpbuf: *omit: *omit)                                                  
                 - %size(InputData.ROW)                                                             
                 - %size(InputData.COL)                                                             
                 - %size(InputData.AID);                                                            
          // ----------------------------------------------                                         
          //   Copy the answer from the buffer                                                      
          // ----------------------------------------------                                         
          if (Len > 0);                                                                             
             Answer = %trim( %subst( InputData.field: 1: len) );                                    
             %subst(dataout:2:1) = Answer;                                                          
          endif;                                                                                    
          // ----------------------------------------------                                         
          //   Clean up the buffers, and return to caller                                           
          // ----------------------------------------------                                         
          QsnDltBuf(cmdbuf: *omit);                                                                 
          QsnDltBuf(inpbuf: *omit);                                                                 
          %subst(dataout:1:1) = '0';                                                                
          if (InputData.AID = QSN_F3);                                                              
           %subst(dataout:1:1) = '1';                                                               
          endif;                                                                                    
                                                                                                    
          // return Variable                                                                        
          return dataout;                                                                           
                                                                                                    
      /end-free                                                                                     
     P                 E                                                                            
      *--------------------------------------------------------                                     
      *  openList  - Open a cursor to read file                                                     
      *--------------------------------------------------------                                     
     p openList        b                                                                            
                                                                                                    
     d openList        pi                                                                           
                                                                                                    
      /free                                                                                         
                                                                                                    
       exec sql                                                                                     
        declare MyCursor cursor for statement;                                                      
                                                                                                    
       exec sql                                                                                     
        prepare statement from :sqlstmt;                                                            
                                                                                                    
       exec sql                                                                                     
        open mycursor;                                                                              
                                                                                                    
      /End-Free                                                                                     
                                                                                                    
     p openList        e                                                                            
      *--------------------------------------------------------                                     
      *  fetchNext  - read one record at a time                                                     
      *--------------------------------------------------------                                     
     p fetchNext       b                                                                            
                                                                                                    
     d fetchNext       pi              n                                                            
                                                                                                    
      /free                                                                                         
                                                                                                    
       exec sql                                                                                     
        fetch next from mycursor into : mysqldata3;                                                 
         if sqlstt < '02000';                                                                       
           return *on;                                                                              
         else;                                                                                      
           return *off;                                                                             
         endif;                                                                                     
                                                                                                    
      /end-free                                                                                     
                                                                                                    
     p fetchnext       e                                                                            
                                                                                                    
      *--------------------------------------------------------                                     
      *  closeOrderList  - Close the OrderHdr cursor                                                
      *--------------------------------------------------------                                     
     p closeList       b                                                                            
                                                                                                    
     d closeList       pi                                                                           
                                                                                                    
      /free                                                                                         
                                                                                                    
       exec sql                                                                                     
        close MyCursor;                                                                             
                                                                                                    
      /end-free                                                                                     
                                                                                                    
     p closeList       e                                                                            
      *--------------------------------------------------------                                     

QsnWrtDta - RPGLE dynamic screen API's


Sample from Jamie Flanary posted at 2012-02-16 17:34:35

     h Option(*NODEBUGIO)  DFTACTGRP(*NO)                                                           
                                                                                                    
      /copy current,DYNO_CP                                                                         
                                                                                                    
     d $Screen1        pr           500a   varying                                                  
     d   Line                        78a   const dim(24) options(*varsize)                          
     d   NumLines                    10i 0 value                                                    
     d   AnsLen                      10i 0 value                                                    
     d   DataOut                    256                                                             
      *                                                                                             
      * local variables                                                                             
      *                                                                                             
     d Abort           s              1n                                                            
     d Choice#         s             10i 0                                                          
     d cmdlength       s             15  5                                                          
     d cmdstring       s            512                                                             
     d dec8            s              8  0                                                          
     d decimalanswer   s              1  0                                                          
     d end             s              3  0                                                          
     d endscreen1      s               n                                                            
     d Essay           s            500A                                                            
     d filename        s             80                                                             
     d foundAS400      s              3  0                                                          
     d Directory       s            256    varying                                                  
     d GrapTheFile     s               n                                                            
     d itemnumber      s              7  0                                                          
     d length          s             10i 0                                                          
     d Lines           s             78A   dim(24)                                                  
     d Mycount         s             10i 0                                                          
     d newname         s            512                                                             
     d password        s             10    inz('@PASSWORD')                                           
     d processing      s               n                                                            
     d Q               s              1    inz('''')                                                
      *                                        dns name or Ip address                               
     d remoteIP        s             15    inz('@SERVERNAME')                                             
     d*remoteIP        s             15    inz('192.168.1.100')                                     
     d reply           s              1                                                             
     d screenatr       s              1                                                             
     d screenerror     s               n                                                            
     d start           s              3  0                                                          
     d string          s            512                                                             
     d sqlstmt         s           2500    varying                                                  
     d teststring      s            512                                                             
     d theanswer       s              1                                                             
     d userid          s             10    inz('@USERID')                                             
     d workfile        s             80                                                             
     d workPO#         s              7  0                                                          
     d workPOLine#     s              3  0                                                          
      *                                                                                             
      * This is the return data from subprocedure $screen                                           
      * left at 256 so you can add bunch more return values                                         
      *                                                                                             
     d  dataout        ds           256    qualified inz                                            
     d    F3                           n   overlay(dataout:1)                                       
     d    Choice                      1    overlay(dataout:*next)                                   
      **---------------------------------------------------------------                             
      * external calls                                                                              
      **---------------------------------------------------------------                             
     d $command        pr                  extpgm( 'QCMDEXC' )                                      
     d   cmdstring                 2000    options( *varsize ) const                                
     d   cmdlength                   15  5                     const                                
      *                                                                                             
     d  mysqldata      ds                  qualified  inz                                           
     d   String                     512                                                             
      *                                                                                             
     d  mysqldata2     ds                  qualified  inz                                           
     d   String                     512                                                             
      *                                                                                             
     d  mysqldata3     ds                  qualified  inz                                           
     d   String                     512                                                             
      *                                                                                             
      * Sql functions                                                                               
      *                                                                                             
     d openlist        pr                                                                           
     d fetchnext       pr              n                                                            
     d closelist       pr                                                                           
                                                                                                    
      **---------------------------------------------------------------                             
      /free                                                                                         
                                                                                                    
         *inlr = *on;                                                                               
                                                                                                    
                                                                                                    
         directory = '/pdm/data/wkgshare/pfs/AS400_AuxiliaryFolder_wl ';                            
                                                                                                    
                                                                                                    
         exec sql  set option commit=*none,datfmt=*iso,                                             
                       closqlcsr=*ENDMOD;                                                           
                                                                                                    
                                                                                                    
        //--------------------------------------------------------                                  
        //     M A I N   L I N E                                                                    
        //--------------------------------------------------------                                  
                                                                                                    
         // ftp to server and get directory listing                                                 
                                                                                                    
             exsr $OverrideFiles;                                                                   
             exsr $ftpDirList;                                                                      
             exsr $startftp;                                                                        
                                                                                                    
             exsr $readoutput;                                                                      
             return;                                                                                
                                                                                                    
        //--------------------------------------------------------                                  
        // $ReadOutput - read the output file                                                       
        //--------------------------------------------------------                                  
             begsr $ReadOutput;                                                                     
                                                                                                    
                                                                                                    
              reset choice#;                                                                        
              // setup the title                                                                    
              Mycount +=1;                                                                          
              Lines(Mycount) = 'Select File to Process';                                            
              // add blank line                                                                     
              Mycount +=1;                                                                          
              Lines(Mycount) = *blanks;                                                             
                                                                                                    
                                                                                                    
              sqlstmt = 'Select * from OUTPUT';                                                     
                                                                                                    
               openList();                                                                          
               dow fetchNext();                                                                     
                // look for the direcotry listing and the file name                                 
                start = %scan('6-':mysqldata3.string);                                              
                // don't loop forever!                                                              
                FoundAS400 = %scan('AS400':mysqldata3.string);                                      
                if start > *zeros and FoundAS400 > *zeros;                                          
                 end = %scan('.txt':mysqldata3.string);                                             
                 if end > *zeros;                                                                   
                                                                                                    
                  length = end+4 - start;                                                           
                  filename = %subst(mysqldata3.string:start:length);                                
                                                                                                    
                  // increment the letter                                                           
                  Choice#+=1;                                                                       
                  Mycount+=1;                                                                       
                  lines(Mycount) = ' ' + %char(Choice#) + ') ' +                                    
                  %trim(filename);                                                                  
                                                                                                    
                  exsr $processfile;                                                                
                 endif;                                                                             
                endif;                                                                              
                                                                                                    
               enddo;                                                                               
               closeList();                                                                         
                                                                                                    
               // all files .txt are listed now show screen                                         
                                                                                                    
               if Mycount <= 2;                                                                     
                Mycount+=1;                                                                         
                lines(Mycount) = '** No Records Found **';                                          
               endif;                                                                               
                                                                                                    
               reset endscreen1;                                                                    
               dow not(EndScreen1);                                                                 
                if not(screenerror);                                                                
                 lines(20) = *blanks;                                                               
                endif;                                                                              
                reset dataout;                                                                      
                Dataout = $Screen1(lines:20:1:DataOut);                                             
                reset screenerror;                                                                  
                // this is the error line                                                           
                select;                                                                             
                 when dataout.F3 = *on;                                                             
                  EndScreen1 = *on;                                                                 
                  return;                                                                           
                 other;     // check answer                                                         
                  TheAnswer = dataout.choice;                                                       
                                                                                                    
                  exsr $validate;                                                                   
                  if not(screenerror);                                                              
                   exsr $getthefile;                                                                
                  endif;                                                                            
                                                                                                    
                endsl;                                                                              
                                                                                                    
               enddo;                                                                               
                                                                                                    
             endsr;                                                                                 
                                                                                                    
        //--------------------------------------------------------                                  
        // $Validate - validate the return selection                                                
        //--------------------------------------------------------                                  
             begsr $Validate;                                                                       
                                                                                                    
              reset screenerror;                                                                    
              // validate the answer                                                                
                                                                                                    
                                                                                                    
              if %check(' 0123456789':TheAnswer) > *zeros;                                          
               lines(20) = 'Entry ' + TheAnswer + ' is invalid';                                    
               screenerror = *on;                                                                   
              else;                                                                                 
               TheAnswer = %xlate(' ':'0':TheAnswer);                                               
               DecimalAnswer = %dec(TheAnswer:1:0);                                                 
               if DecimalAnswer > Choice#;                                                          
                lines(20) = 'Entry ' + TheAnswer + ' is Greater than ' +                            
                 %char(choice#);                                                                    
                screenerror = *on;                                                                  
               endif;                                                                               
              endif;                                                                                
                                                                                                    
                                                                                                    
             endsr;                                                                                 
                                                                                                    
        //--------------------------------------------------------                                  
        // $GettheFile - get the file from FTP and process it                                       
        //--------------------------------------------------------                                  
             begsr $GettheFile;                                                                     
                                                                                                    
                                                                                                    
                                                                                                    
             endsr;                                                                                 
                                                                                                    
        //--------------------------------------------------------                                  
        // $ProcessFile  - grab the file and do the work                                            
        //--------------------------------------------------------                                  
             begsr $ProcessFile;                                                                    
                                                                                                    
              // create pf in qtemp and do processing                                               
              cmdstring = 'CRTPF QTEMP/MYFILE RCDLEN(512) ';                                        
              cmdlength = %len(%trim(cmdstring));                                                   
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                     
              on-error;                                                                             
               cmdstring = 'CLRPFM QTEMP/MYFILE ';                                                  
               cmdlength = %len(%trim(cmdstring));                                                  
              endmon;                                                                               
                                                                                                    
              // remove any get commands from the imput file                                        
              exec sql                                                                              
               delete from QTEMP/MYFILE                                                             
               where myfile like '%MYFILE%';                                                        
                                                                                                    
              exec sql                                                                              
               delete from QTEMP/INPUT                                                              
               where myfield like '%DIR%';                                                          
                                                                                                    
              processing = *on;                                                                     
              exsr $OverrideFiles;                                                                  
              exsr $FtpDirList;                                                                     
              processing = *off;                                                                    
                                                                                                    
              mysqldata2.String = 'Get ' + %trim(filename) + ' QTEMP/MYFILE' +                      
               ' (replace ';                                                                        
              exec sql                                                                              
               insert into QTEMP/INPUT values(:mysqldata2);                                         
                                                                                                    
              // change extension of .txt file to .done                                             
              workfile = Filename;                                                                  
              end = %scan('.txt':workfile);                                                         
              %subst(workfile:end:5) = '.done';                                                     
              mysqldata2.String = 'Rename ' + %trim(filename) +                                     
              ' ' + %trim(workfile);                                                                
          //  exec sql                                                                              
          //   insert into QTEMP/INPUT values(:mysqldata2);                                         
              exsr $startFTP;                                                                       
                                                                                                    
             endsr;                                                                                 
                                                                                                    
        //--------------------------------------------------------                                  
        // $OverrideFiles - create input & output override files                                    
        //--------------------------------------------------------                                  
             begsr $OverrideFiles;                                                                  
                                                                                                    
              cmdstring = 'DLTOVR INPUT';                                                           
              cmdlength = %len(%trim(cmdstring));                                                   
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                     
              on-error;                                                                             
              endmon;                                                                               
                                                                                                    
              cmdstring = 'DLTOVR OUTPUT';                                                          
              cmdlength = %len(%trim(cmdstring));                                                   
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                     
              on-error;                                                                             
              endmon;                                                                               
                                                                                                    
              cmdstring = 'CLRPFM FILE(QTEMP/INPUT)';                                               
              cmdlength = %len(%trim(cmdstring));                                                   
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                     
              on-error;                                                                             
               exec sql                                                                             
                create table QTEMP/INPUT                                                            
                (MyField  char(512));                                                               
              endmon;                                                                               
                                                                                                    
              cmdstring = 'CLRPFM FILE(QTEMP/OUTPUT)';                                              
              cmdlength = %len(%trim(cmdstring));                                                   
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                     
              on-error;                                                                             
               exec sql                                                                             
                create table QTEMP/OUTPUT                                                           
                (MyField  char(512));                                                               
              endmon;                                                                               
                                                                                                    
             endsr;                                                                                 
        //--------------------------------------------------------                                  
        // $FtpDirList - get direcotory listing                                                     
        //--------------------------------------------------------                                  
             begsr $FtpDirList;                                                                     
                                                                                                    
             // commands to run on server                                                           
                                                                                                    
              mysqldata2.string = %trim(userid) + ' ' + %trim(password);                            
              exec sql                                                                              
               insert into QTEMP/INPUT values(:mysqldata2);                                         
                                                                                                    
              mysqldata2.String = 'ASCII';                                                          
              exec sql                                                                              
               insert into QTEMP/INPUT values(:mysqldata2);                                         
                                                                                                    
              mysqldata2.String =                                                                   
               'cd  ' + directory;                                                                  
              exec sql                                                                              
               insert into QTEMP/INPUT values(:mysqldata2);                                         
                                                                                                    
              if processing = *off;                                                                 
               mysqldata2.String =  'Dir ' ;                                                        
              endif;                                                                                
                                                                                                    
              exec sql                                                                              
               insert into QTEMP/INPUT values(:mysqldata2);                                         
                                                                                                    
              cmdstring = 'OVRDBF FILE(INPUT) TOFILE(QTEMP/INPUT)' +                                
                          ' OVRSCOPE(*JOB) ';                                                       
              cmdlength = %len(%trim(cmdstring));                                                   
              $command(cmdstring : cmdlength);                                                      
                                                                                                    
              cmdstring = 'OVRDBF FILE(OUTPUT) TOFILE(QTEMP/OUTPUT)' +                              
                          ' OVRSCOPE(*JOB) ';                                                       
              cmdlength = %len(%trim(cmdstring));                                                   
              $command(cmdstring : cmdlength);                                                      
                                                                                                    
             endsr;                                                                                 
                                                                                                    
        //--------------------------------------------------------                                  
        // $StartFTP;   Start FTP...                                                                
        //--------------------------------------------------------                                  
             begsr $StartFTP;                                                                       
                                                                                                    
              cmdstring = 'STRTCPFTP ' + Q + %trim(remoteIp)  + Q  ;                                
              cmdlength = %len(%trim(cmdstring));                                                   
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                     
              on-error;                                                                             
              endmon;                                                                               
                                                                                                    
             endsr;                                                                                 
                                                                                                    
      /end-free                                                                                     
                                                                                                    
      *--------------------------------------------------------                                     
      *  $Screen1():     Show Screen1 (Remote files via FTP)                                        
      *                                                                                             
      *     Line = (input) array of lines of text containing                                        
      *                 the question to ask                                                         
      * NumLines = (input) number of lines in the Line array                                        
      *   AnsLen = (input) size of answer blank                                                     
      *    DataOut = (output) position 1 F3 positon 2 answer                                        
      *                                                                                             
      * Returns the user's answer                                                                   
      *--------------------------------------------------------                                     
     p $Screen1        B                                                                            
                                                                                                    
     d $Screen1        PI           500A   varying                                                  
     d   Line                        78A   const                                                    
     d                                     dim(24) options(*varsize)                                
     d   NumLines                    10I 0 value                                                    
     d   AnsLen                      10I 0 value                                                    
     d   DataOut                    256                                                             
                                                                                                    
     d cmdbuf          s                   like(Qsn_Cmd_Buf_T)                                      
     d inpbuf          s                   like(Qsn_Inp_Buf_T)                                      
     d prompt          s             70A   varying                                                  
     d NRF             s             50    inz('** No Records Found **')                            
     d skipthis        s               n                                                            
     d len             s             10I 0                                                          
     d data            s            132A   varying                                                  
     d x               s             10I 0                                                          
     d Row             s              3U 0                                                          
     d Answer          s            500A   varying                                                  
      *                                                                                             
     d InputData       ds                  qualified                                                
     d                                     based(p_InputData)                                       
     d   Row                          3U 0                                                          
     d   Col                          3U 0                                                          
     d   AID                          1A                                                            
     d   Field                      500A                                                            
      /free                                                                                         
                                                                                                    
          // ----------------------------------------------                                         
          //  Create Input/Output buffers and clear them                                            
          // ----------------------------------------------                                         
          cmdbuf = QsnCrtCmdBuf(100: 50: 0: *OMIT: *OMIT);                                          
          inpbuf = QsnCrtInpBuf(200: 50: 0: *OMIT: *OMIT);                                          
          QsnClrBuf( cmdbuf : *omit );                                                              
          QsnClrBuf( inpbuf : *omit );                                                              
          // ----------------------------------------------                                         
          // Add the "Clear Screen" command to the output                                           
          //  so that the terminal starts with an empty                                             
          //  screen.                                                                               
          // ----------------------------------------------                                         
          QsnClrScr( *omit : cmdbuf : *omit : *omit );                                              
          // ----------------------------------------------                                         
          //  Put a screen title in the output buffer                                               
          // ----------------------------------------------                                         
          data = 'Select File to download and process.';                                            
          QsnWrtDta( data                                                                           
                   : %len(data)                                                                     
                   : *omit                                                                          
                   : 1                                                                              
                   : 40 - (%len(data)/2)  // center                                                 
                   : QSN_SA_HI                                                                      
                   : QSN_SA_HI                                                                      
                   : QSN_SA_WHT                                                                     
                   : QSN_SA_WHT                                                                     
                   : cmdbuf                                                                         
                   : *omit                                                                          
                   : *omit                                                                          
                   );                                                                               
          // ----------------------------------------------                                         
          // Put the filename on rows 3+ of the output buf                                          
          // ----------------------------------------------                                         
          row = 2;                                                                                  
          for x = 1 to NumLines;                                                                    
             row +=1;                                                                               
                                                                                                    
             Select;                                                                                
             when row = 3;                                                                          
              ScreenAtr = QSN_SA_PNK_UL;                                                            
              Length = 22;                                                                          
             when row = 22;                                                                         
              ScreenAtr = QSN_SA_RED;                                                               
              Length = %len(line(x));                                                               
             other;                                                                                 
              ScreenAtr = QSN_SA_GRN;                                                               
              Length = %len(line(x));                                                               
             endsl;                                                                                 
                                                                                                    
             if %scan(%trim(NRF):Line(x)) > *zeros;                                                 
              SkipThis = *on;                                                                       
             endif;                                                                                 
                                                                                                    
             QsnWrtDta( Line(x)                                                                     
                      : Length                                                                      
                      : *omit                                                                       
                      : row                                                                         
                      : 2                                                                           
                      : QSN_SA_NORM                                                                 
                      : QSN_SA_NORM                                                                 
                      : ScreenAtr                                                                   
                      : QSN_SA_GRN                                                                  
                      : cmdbuf                                                                      
                      : *omit                                                                       
                      : *omit                                                                       
                      );                                                                            
          endfor;                                                                                   
          // ----------------------------------------------                                         
          // Put an underlined blank input field into the                                           
          //  output buffer so the user has a place to                                              
          //  answer.. This is on Row 21                                                            
          // ----------------------------------------------                                         
          if not(SkipThis);                                                                         
                                                                                                    
           QsnSetFld( *omit                                                                         
                    : AnsLen                                                                        
                    : 21                                                                            
                    : 2                                                                             
                    : QSN_FFW_ALPHA_SHIFT                                                           
                    : *omit                                                                         
                    : 0                                                                             
                    : QSN_SA_UL                                                                     
                    : QSN_SA_GRN_UL                                                                 
                    : cmdbuf                                                                        
                    : *omit                                                                         
                    : *omit );                                                                      
          endif;                                                                                    
          // ----------------------------------------------                                         
          //   Let the user know how to exit  (color blue)                                          
          // ----------------------------------------------                                         
          QsnWrtDta( 'F3=Exit'                                                                      
                   : %len('F3=Exit')                                                                
                   : *omit                                                                          
                   : 23                                                                             
                   : 2                                                                              
                   : QSN_SA_HI                                                                      
                   : QSN_SA_NORM                                                                    
                   : QSN_SA_BLU                                                                     
                   : QSN_SA_GRN                                                                     
                   : cmdbuf                                                                         
                   : *omit                                                                          
                   : *omit                                                                          
                   );                                                                               
          // ----------------------------------------------                                         
          // put the "unlock keyboard" command into the                                             
          // output buffer                                                                          
          // ----------------------------------------------                                         
          QsnReadInp( QSN_CC1_MDTALL_CLRALL                                                         
                    : QSN_CC2_UNLOCKBD                                                              
                    : *omit                                                                         
                    : *omit                                                                         
                    : cmdbuf                                                                        
                    : *omit                                                                         
                    : *omit );                                                                      
          // ----------------------------------------------                                         
          // send the output buffer to the terminal, and                                            
          //  wait for input from the user                                                          
          // ----------------------------------------------                                         
          QsnPutGetBuf( cmdbuf: inpbuf: *omit: *omit);                                              
          // ----------------------------------------------                                         
          //  Get a pointer to the input data, and the                                              
          //   length of the input data.                                                            
          // ----------------------------------------------                                         
          p_InputData = QsnRtvDta( inpbuf: *omit: *omit );                                          
          Len = QsnRtvDtaLen(inpbuf: *omit: *omit)                                                  
                 - %size(InputData.ROW)                                                             
                 - %size(InputData.COL)                                                             
                 - %size(InputData.AID);                                                            
          // ----------------------------------------------                                         
          //   Copy the answer from the buffer                                                      
          // ----------------------------------------------                                         
          if (Len > 0);                                                                             
             Answer = %trim( %subst( InputData.field: 1: len) );                                    
             %subst(dataout:2:1) = Answer;                                                          
          endif;                                                                                    
          // ----------------------------------------------                                         
          //   Clean up the buffers, and return to caller                                           
          // ----------------------------------------------                                         
          QsnDltBuf(cmdbuf: *omit);                                                                 
          QsnDltBuf(inpbuf: *omit);                                                                 
          %subst(dataout:1:1) = '0';                                                                
          if (InputData.AID = QSN_F3);                                                              
           %subst(dataout:1:1) = '1';                                                               
          endif;                                                                                    
                                                                                                    
          // return Variable                                                                        
          return dataout;                                                                           
                                                                                                    
      /end-free                                                                                     
     P                 E                                                                            
      *--------------------------------------------------------                                     
      *  openList  - Open a cursor to read file                                                     
      *--------------------------------------------------------                                     
     p openList        b                                                                            
                                                                                                    
     d openList        pi                                                                           
                                                                                                    
      /free                                                                                         
                                                                                                    
       exec sql                                                                                     
        declare MyCursor cursor for statement;                                                      
                                                                                                    
       exec sql                                                                                     
        prepare statement from :sqlstmt;                                                            
                                                                                                    
       exec sql                                                                                     
        open mycursor;                                                                              
                                                                                                    
      /End-Free                                                                                     
                                                                                                    
     p openList        e                                                                            
      *--------------------------------------------------------                                     
      *  fetchNext  - read one record at a time                                                     
      *--------------------------------------------------------                                     
     p fetchNext       b                                                                            
                                                                                                    
     d fetchNext       pi              n                                                            
                                                                                                    
      /free                                                                                         
                                                                                                    
       exec sql                                                                                     
        fetch next from mycursor into : mysqldata3;                                                 
         if sqlstt < '02000';                                                                       
           return *on;                                                                              
         else;                                                                                      
           return *off;                                                                             
         endif;                                                                                     
                                                                                                    
      /end-free                                                                                     
                                                                                                    
     p fetchnext       e                                                                            
                                                                                                    
      *--------------------------------------------------------                                     
      *  closeOrderList  - Close the OrderHdr cursor                                                
      *--------------------------------------------------------                                     
     p closeList       b                                                                            
                                                                                                    
     d closeList       pi                                                                           
                                                                                                    
      /free                                                                                         
                                                                                                    
       exec sql                                                                                     
        close MyCursor;                                                                             
                                                                                                    
      /end-free                                                                                     
                                                                                                    
     p closeList       e                                                                            
      *--------------------------------------------------------                                     

QUSLSPL - List all spooled files in an outqueue.


Sample from Jamie Flanary posted at 2012-02-14 19:05:59

      *========================================================================                     
      *                                                                                             
      * Program Info                                                                                
      *                                                                                             
     d PgmInfo        SDS                                                                           
     d  @JobName             244    253                                                             
     d  @UserId              254    263                                                             
     d  @JobNumber           264    269  0                                                          
      *                                                                                             
      * API - List spooled files                                                                    
      *                                                                                             
     d QUSLSPL         PR                  extpgm('QUSLSPL')                                        
      * required parameters                                                                         
     d   UsrSpc                      20A   const                                                    
     d   Format                       8A   const                                                    
     d   UserName                    10A   const                                                    
     d   QualOutQ                    20A   const                                                    
     d   FormType                    10A   const                                                    
     d   UserData                    10A   const                                                    
      * optional group 1:                                                                           
     d   ErrorCode                32766A   options(*nopass: *varsize)                               
      * optional group 2:                                                                           
     d   QualJob                     26A   options(*nopass) const                                   
     d   FieldKeys                   10I 0 options(*nopass: *varsize)                               
     d                                     dim(9999)                                                
     d   NumFields                   10I 0 options(*nopass) const                                   
      * optional group 3:                                                                           
     d   AuxStgPool                  10I 0 options(*nopass) const                                   
      * optional group 4:                                                                           
     d   JobSysName                   8A   options(*nopass) const                                   
     d   StartCrtDate                 7A   options(*nopass) const                                   
     d   StartCrtTime                 6A   options(*nopass) const                                   
     d   EndCrtDate                   7A   options(*nopass) const                                   
     d   EndCrtTime                   6A   options(*nopass) const                                   
      *                                                                                             
     d QUSCRTUS        PR                  extpgm('QUSCRTUS')                                       
     d   UsrSpc                      20A   const                                                    
     d   ExtAttr                     10A   const                                                    
     d   InitialSize                 10I 0 const                                                    
     d   InitialVal                   1A   const                                                    
     d   PublicAuth                  10A   const                                                    
     d   Text                        50A   const                                                    
     d   Replace                     10A   const                                                    
     d   ErrorCode                32766A   options(*nopass: *varsize)                               
      *                                                                                             
     d QUSPTRUS        PR                  extpgm('QUSPTRUS')                                       
     d   UsrSpc                      20A   const                                                    
     d   Pointer                       *                                                            
      *                                                                                             
     d QUSDLTUS        PR                  extpgm('QUSDLTUS')                                       
     d   UsrSpc                      20A   const                                                    
     d   ErrorCode                32766A   options(*varsize)                                        
      *                                                                                             
     d p_UsrSpc        s               *                                                            
     d dsLH            DS                   based(p_UsrSpc)                                         
     d                                      qualified                                               
     d   Filler1                    103A                                                            
     d   Status                       1A                                                            
     d   Filler2                     12A                                                            
     d   HdrOffset                   10I 0                                                          
     d   HdrSize                     10I 0                                                          
     d   ListOffset                  10I 0                                                          
     d   ListSize                    10I 0                                                          
     d   NumEntries                  10I 0                                                          
     d   EntrySize                   10I 0                                                          
      *                                                                                             
     d p_Entry         s               *                                                            
     d dsSF            DS                   based(p_Entry)                                          
     d                                      qualified                                               
     d   JobName                     10A                                                            
     d   UserName                    10A                                                            
     d   JobNumber                    6A                                                            
     d   SplfName                    10A                                                            
     d   SplfNbr                     10I 0                                                          
     d   SplfStatus                  10I 0                                                          
     d   OpenDate                     7A                                                            
     d   OpenTime                     6A                                                            
     d   Schedule                     1A                                                            
     d   SysName                     10A                                                            
     d   UserData                    10A                                                            
     d   FormType                    10A                                                            
     d   OutQueue                    10A                                                            
     d   OutQueueLib                 10A                                                            
     d   AuxPool                     10I 0                                                          
     d   SplfSize                    10I 0                                                          
     d   SizeMult                    10I 0                                                          
      *                                                                                             
     d   TotalPages                  10I 0                                                          
     d   CopiesLeft                  10I 0                                                          
     d   Priority                     1A                                                            
     d   Reserved                     3A                                                            
      *                                                                                             
     d dsEC            DS                  qualified                                                
     d  BytesProvided                10I 0 inz(%size(dsEC))                                         
     d  BytesAvail                   10I 0 inz(0)                                                   
     d  MessageID                     7A                                                            
     d  Reserved                      1A                                                            
     d  MessageData                 240A                                                            
      *                                                                                             
      * constants                                                                                   
      *                                                                                             
     d Low             c                   const('abcdefghijklmnopqrstuvwxyz')                      
     d MYSPACE         c                   const('SPLFLIST  QTEMP     ')                            
     d Q               c                   const('''')                                              
     d Up              c                   const('ABCDEFGHIJKLMNOPQRSTUVWXYZ')                      
                                                                                                    
     d OutQName        ds                  qualified inz                                            
     d   OutQ                        10A   overlay(OutQname:1)                                      
     d   OutQLib                     10A   overlay(OutQname:*next)                                  
      *                                                                                             
      *  Field Definitions.                                                                         
      *                                                                                             
     d size            s             10I 0                                                          
     d sf              s             10I 0 inz(1)                                                   
      *                                                                                             
      *                                                                                             
      *========================================================================                     
      * MAIN LINE                                                                                   
      *========================================================================                     
                                                                                                    
      /free                                                                                         
                                                                                                    
               OutQName.OutQLib = 'QUSRSYS';                                                        
               OutQName.OutQ = 'PRT01';                                                             
               exsr  $getsplflist;                                                                  
               *inlr = *on;                                                                         
                                                                                                    
                                                                                                    
        //===========================================                                               
        // $GetSPLFList - Get Spooled File List                                                     
        //===========================================                                               
                                                                                                    
             begsr $GetSPLFList;                                                                    
                                                                                                    
                                                                                                    
               // set this to zero to let OS/400 handle errors                                      
                                                                                                    
              dsEC.BytesProvided = 0;                                                               
                                                                                                    
              // make space for (approx) 1000 spooled files to be listed                            
                                                                                                    
              size = %size(dsLH) + 512 + (%size(dsSF) * 1000);                                      
                                                                                                    
             // create a user space                                                                 
             // List spooled files to the user space                                                
             // Get a pointer to the returned user space                                            
             // Create a user space                                                                 
             QUSCRTUS(MYSPACE: 'USRSPC': size: x'00': '*ALL':                                       
             'Temp User Space for QUSLSPL API':  '*YES': dsEC);                                     
                                                                                                    
             // List spooled files to the user space                                                
             QUSLSPL(MYSPACE: 'SPLF0300': '*ALL': OutQName:                                         
             '*ALL': '*ALL': dsEC);                                                                 
                                                                                                    
             // Get a pointer to the returned user space                                            
             QUSPTRUS(MYSPACE: p_UsrSpc);                                                           
                                                                                                    
            // Loop through list, for each spooled file, display the                                
            // Status: 1=RDY , 2=OPN, 3=CLO, 4=SAV, 5=WRT, 6=HLD,                                   
            //     7=MSGW, 8=PND, 9=PRT,10=FIN,11=SND,12=DFR                                        
                                                                                                    
              p_Entry = p_UsrSpc + dsLH.ListOffset;                                                 
              sf = 1;                                                                               
              dow  sf <= dsLH.NumEntries;                                                           
                                                                                                    
               // currently only move status = 1 ready                                              
                                                                                                    
               if  dsSF.SplfStatus = 1;                                                             
                                                                                                    
               endif;                                                                               
                                                                                                    
               p_Entry  +=  dsLH.EntrySize;                                                         
               sf +=1;                                                                              
              enddo;                                                                                
                                                                                                    
              // delete user space                                                                  
                                                                                                    
              QUSDLTUS(MYSPACE: dsEC);                                                              
                                                                                                    
             endsr;                                                                                 
                                                                                                    
        //===========================================                                               
      /end-free                                                                                     

qusrspla - list outqueues


Sample from Jamie Flanary posted at 2012-02-14 17:38:07

     H Option(*SrcStmt: *NoDebugIO) DftActGRP(*No)
      *=======================================================================
      * PROGRAM -
      * PURPOSE - print list of outqueues
      * WRITTEN -
      * AUTHOR  - AS400Pro
      *
      * PROGRAM DESCRIPTION
      *   This program will print a list of system outq's
      *
      *
      * INPUT PARAMETERS
      *   Description        Type  Size    How Used
      *   -----------        ----  ----    --------

      * AUTHORITY PARAMETERS
      *   Description                      How Used
      *   -----------                      --------
      *
      * INDICATOR USAGE
      *
      *========================================================================
     FPAGESAP   o    e             printer usropn   oflind(*in75)
     F                                              infds(PrintFDS)
      *
      * Program Info
      *
     d                SDS
     d  @PGM                 001    010
     d  @PARMS               037    039  0
     d  @MSGDTA               91    170
     d  @MSGID               171    174
     d  @JOB                 244    253
     d  @USER                254    263
     d  @JOB#                264    269  0

     d PrintFDS        ds
     d RecordFmt         *RECORD
     d LineNumber            367    368I 0
     d PageNumber            369    372I 0
     À*
     À*  Field Definitions.
     À* ~~~~~~~~~~~~~~~~~~~~~~~~
     d cmdstring       s            512
     d cmdlength       s             15  5
     d AllText         s             10    Inz('*ALL')
     d Count           s              4  0
     d Format          s              8
     d GenLen          s              8
     d InLibrary       s             10
     d InType          s             10
     d ObjectLib       s             20
     d SpaceVal        s              1    inz(*BLANKS)
     d SpaceAuth       s             10    inz('*CHANGE')
     d SpaceText       s             50    inz(*BLANKS)
     d SpaceRepl       s             10    inz('*YES')
     d SpaceAttr       s             10    inz(*BLANKS)
     d TotalPages      s              4  0 inz
     d UserSpaceOut    s             20
     d Worktype        s             10    inz('*OUTQ')
     D ObjNam          s             10a
     D ObjLib          s             10a
     D ObjTyp          s             10a
À     *                                                                                            Ä
À     * GenHdr                                                                                     Ä
À     *                                                                                            Ä
     d GenHdr          ds                  inz
     d  OffSet                 1      4B 0
     d  NumEnt                 9     12B 0
     d  Lstsiz                13     16B 0
À     *                                                                                            Ä
À     *  Data structures                                                                           Ä
À     *                                                                                            Ä
     d GENDS           ds
     d  OffsetHdr              1      4B 0
     d  NbrInList              9     12B 0
     d  SizeEntry             13     16B 0
      *
     d HeaderDs        ds
     d  OutFileNam             1     10
     d  OutLibName            11     20
     d  OutType               21     25
     d  OutFormat             31     40
     d  RecordLen             41     44B 0
      *
      * API Error Data Structure
      *
     d ErrorDs         DS                  INZ
     d  BytesPrv               1      4B 0
     d  BytesAvl               5      8B 0
     d  MessageId              9     15
     d  ERR###                16     16
     d  MessageDta            17    116
      *
     d                 DS
     d  StartPosit             1      4B 0
     d  StartLen               5      8B 0
     d  SpaceLen               9     12B 0
     d  ReceiveLen            13     16B 0
     d  MessageKey            17     20B 0
     d  MsgDtaLen             21     24B 0
     d  MsgQueNbr             25     28B 0
      *
      * Date structure for retriving userspace info
      *
     d InputDs         DS
     d  UserSpace              1     20
     d  SpaceName              1     10
     d  SpaceLib              11     20
     d  InpFileLib            29     48
     d  InpFFilNam            29     38
     d  InpFFilLib            39     48
     d  InpRcdFmt             49     58
      *
     d ObjectDs        ds                  Qualified
     d  Object                       10
     d  Library                      10
     d  ObjectType                   10
     d  InfoStatus                    1
     d  ExtObjAttrib                 10
     d  Description                  50

     **-- Retrieve object description:  -------------------------------
     d RtvObjD         Pr                  ExtPgm( 'QUSROBJD' )
     d  RoRcvVar                  32767a         Options( *VarSize )
     d  RoRcvVarLen                  10i 0 Const
     d  RoFmtNam                      8a   Const
     d  RoObjNamQ                    20a   Const
     d  RoObjTyp                     10a   Const
     d  RoError                   32767a         Options( *VarSize )
     **-- List objects:   ---------------------------------------------
     d $ListObjects    Pr                  ExtPgm( 'QUSLOBJ' )
     d  userspace                    20a   Const
     d  format                        8a   Const
     d  objectlib                    20a   Const
     d  type                         10a   Const
     **-- Userspace pointer: ------------------------------------------
     d $Userspace      Pr                  ExtPgm( 'QUSRTVUS' )
     d  userspace                    20a   Const
     d  start                        10i 0 Const
     d  Length                       10i 0 Const
     d  Returned                  32767a         Options( *VarSize )
     **-- Create Space:   ---------------------------------------------
     d $CreateSpace    Pr                  ExtPgm( 'QUSCRTUS' )
     d  UserSpaceOut                 20a   Const
     d  SpaceAttr                    10    Const
     d  SpaceLen                     10i 0 Const
     d  SpaceVal                      1a   Const
     d  SpaceAuth                    10a   Const
     d  SpaceText                    50a   Const
     d  SpaceRepl                    10a   Const
     d  ErrorDs                   32767a         Options( *VarSize )

      //
      //  external called programs
      //

     d $command        pr                  extpgm('QCMDEXC')
     d   command                    512
     d   Length                      15  5

      /free

              p1program = @pgm;
             // hold the printfile prior to opening
              cmdstring = 'OVRPRTF FILE(PAGESAP) HOLD(*YES)';
              cmdlength = %len(%trim(cmdstring));
              $command(cmdstring:cmdlength);
              open PAGESAP;
              exsr $QUSCRTUS;

              exsr $PrintOutQs;

              TotalPages = PageNumber;
              close PAGESAP;

             // delete the "FAKE" printfile
              cmdstring = 'DLTSPLF FILE(PAGESAP) SPLNBR(*LAST)';
              cmdlength = %len(%trim(cmdstring));
              $command(cmdstring:cmdlength);

             // release the printfile prior to opening
              cmdstring = 'OVRPRTF FILE(PAGESAP) HOLD(*YES)';
              cmdlength = %len(%trim(cmdstring));
              $command(cmdstring:cmdlength);
              // print it for real now ;)
              open PAGESAP;
              pages = '1 of ' + %char(TotalPages);
              exsr $PrintOutQs;

              *inlr = *on;

        //--------------------------------------------------------
        // $PrintOutQs - print the outq's
        //--------------------------------------------------------
                begsr $PrintOutQs;

                 ObjectLib =  '*ALL      ' + '*LIBL';
         //
         // List all the outqueues to the user space
         //
                 Format = 'OBJL0200';
                 $ListObjects( Userspace : Format : ObjectLib : WorkType);
         //
         // Retrive header entry and process the user space
         //
                 StartPosit = 125;
                 StartLen   = 16;
                 $UserSpace( Userspace : StartPosit : StartLen : GENDS);

                 StartPosit = OffsetHdr + 1;
                 StartLen = %size(ObjectDS);
         //
À        // Do for number of outqueues in the userspace                            Ä
         //

                 write header;
B1               for count = 1 to  NbrInList;
                  $UserSpace( Userspace : StartPosit : StartLen : ObjectDs);

                  p1outq = objectds.object;
                  p1desc = objectds.description;
                  // check overflow;

                  if *in75;
                   pages =  %char(PageNumber+1) + ' of '  + %char(TotalPages);
                   write header;
                   *in75 = *off;
                  endif;

                  write detail;

                  StartPosit += SizeEntry;
                 endfor;
                 write endrpt;
                endsr;

        //--------------------------------------------------------
        // $QUSCRTUS - create userspace
        //--------------------------------------------------------
                 begsr $QUSCRTUS;

                  BytesPrv = 116;
                  Spacename = 'LISTOUTQS';
                  SpaceLib = 'QTEMP';

               //
               // Create the user space
               //
                  $CreateSpace( Userspace : SpaceAttr : 4096 :
                                SpaceVal : SpaceAuth : SpaceText : SpaceRepl:
                                ErrorDs);
                 endsr;

      /end-free



QUSLJOB - read thru workactive jobs


Sample from Jamie Flanary posted at 2012-02-12 11:39:52

      *                                                                                             
      * CrtUsrSpc: Create User Space for OS/400 API's                                               
      *                                                                                             
     d QUSCRTUS        pr                  extpgm('QUSCRTUS')                                       
     d   UsrSpc                      20A   const                                                    
     d   ExtAttr                     10A   const                                                    
     d   InitialSize                 10I 0 const                                                    
     d   InitialVal                   1A   const                                                    
     d   PublicAuth                  10A   const                                                    
     d   Text                        50A   const                                                    
     d   Replace                     10A   const                                                    
     d   ErrorCode                32766A   options(*nopass: *varsize)                               
      *                                                                                             
      * --- Prototype for API Retrive User Space                                                    
      *                                                                                             
     d QUSRTVUS        pr                  extpgm( 'QUSRTVUS' )                                     
     d   QRtvUserSpace...                                                                           
     d                               20                                                             
     d   QRtvStartingPosition...                                                                    
     d                               10i 0                                                          
     d   QRtvLengthOfData...                                                                        
     d                               10i 0                                                          
     d   QRtvReceiverVariable...                                                                    
     d                            32048                                                             
     d   QRtvError...                                                                               
     d                              256                                                             
                                                                                                    
      * --- Prototype for API Retrive List Job                                                      
      *                                                                                             
     d QUSLJOB         pr                  extpgm( 'QUSLJOB' )                                      
     d   QJobUserSpace...                                                                           
     d                               20                                                             
     d   QJobFormatName...                                                                          
     d                                8                                                             
     d   QJobJobName...                                                                             
     d                               26                                                             
     d   QFldStatus...                                                                              
     d                               10                                                             
     d   QFldError...                                                                               
     d                              256                                                             
     d   QJobType...                                                                                
     d                                1                                                             
     d   QNbrFldRtn...                                                                              
     d                               10i 0                                                          
     d   QKeyFldRtn...                                                                              
     d                               10i 0 dim( 100 )                                               
      *                                                                                             
      * Defined variables                                                                           
      *                                                                                             
     d size            s             10I 0                                                          
     d UsrSpcName      s             20    inz( 'DSPJOB    QTEMP     ' )                            
      ******************************************************************                            
                                                                                                    
     dQUSA0100         DS                                                                           
     d QUsrSpcOffset...                                                                             
     d                               10i 0                                                          
     d QUSAreserved...                                                                              
     d                               10i 0                                                          
     d QUsrSpcEntries...                                                                            
     d                               10i 0                                                          
     d QUsrSpcEntrieSize...                                                                         
     d                               10i 0                                                          
                                                                                                    
     dLJOBINPUT        ds                           qualified                                       
     d  JobName...                                                                                  
     d                               10                                                             
     d  UserName...                                                                                 
     d                               10                                                             
     d  JobNumber...                                                                                
     d                                6                                                             
     d  Status...                                                                                   
     d                               10                                                             
     d  UserSpace...                                                                                
     d                               10                                                             
     d  UserSpaceLibrary...                                                                         
     d                               10                                                             
     d  Format...                                                                                   
     d                                8                                                             
     d  JobType...                                                                                  
     d                                1                                                             
     d  Reserved01...                                                                               
     d                                3                                                             
     d  Reserved02...                                                                               
     d                               10i 0                                                          
      *                                                                                             
     dLJOB100          ds                           qualified                                       
     d  JobName...                                                                                  
     d                         1     10                                                             
     d  UserName...                                                                                 
     d                        11     20                                                             
     d  JobNumber...                                                                                
     d                        21     26                                                             
     d  InternalJobId...                                                                            
     d                        27     42                                                             
     d  Status...                                                                                   
     d                        43     52                                                             
     d  JobType...                                                                                  
     d                        53     53                                                             
     d  JobSubType...                                                                               
     d                        54     54                                                             
     d  Reserved01...                                                                               
     d                        55     56                                                             
      *                                                                                             
     dLJOB200          ds                           qualified                                       
     d  JobName...                                                                                  
     d                               10                                                             
     d  UserName...                                                                                 
     d                               10                                                             
     d  JobNumber...                                                                                
     d                                6                                                             
     d  InternalJobId...                                                                            
     d                               16                                                             
     d  Status...                                                                                   
     d                               10                                                             
     d  JobType...                                                                                  
     d                                1                                                             
     d  JobSubType...                                                                               
     d                                1                                                             
     d  Reserved01...                                                                               
     d                                2                                                             
     d  JobInfoStatus...                                                                            
     d                                1                                                             
     d  Reserved02...                                                                               
     d                                3                                                             
     d  NumberOfFieldsReturned...                                                                   
     d                               10i 0                                                          
     d  ReturnedData...                                                                             
     d                             1000                                                             
      *                                                                                             
     dLJOB200KEY       ds                           qualified                                       
     d  KeyNumber01...                                                                              
     d                               10i 0                                                          
     d  NumberOfKeys...                                                                             
     d                               10i 0                                                          
      *                                                                                             
     dLJOBKEYINFO      ds                           qualified                                       
     d  LengthOfInformation...                                                                      
     d                               10i 0                                                          
     d  KeyField...                                                                                 
     d                               10i 0                                                          
     d  TypeOfData...                                                                               
     d                                1                                                             
     d  Reserved01...                                                                               
     d                                3                                                             
     d  LengthOfData...                                                                             
     d                               10i 0                                                          
     d  KeyData...                                                                                  
     d                             1000                                                             
      *                                                                                             
      *  APIErrDef     Standard API error handling structure.                  *                    
      *                                                                                             
     dQUSEC            DS                                                                           
     d  ErrorBytesProvided...                                                                       
     d                               10i 0                                                          
     d  ErrorBytesAvailble...                                                                       
     d                               10i 0                                                          
     d  ErrorExceptionId...                                                                         
     d                                7                                                             
     d  ErrorReserved...                                                                            
     d                                1                                                             
      *                                                                                             
     dAPIError         DS                                                                           
     d APIErrorProvied...                                                                           
     d                                     LIKE( ErrorBytesProvided )                               
     d                                     INZ( %LEN( APIError ) )                                  
     d APIErrorAvailble...                                                                          
     d                                     LIKE( ErrorBytesAvailble )                               
     d APIErrorMessageID...                                                                         
     d                                     LIKE( ErrorExceptionId )                                 
     d APIErrorReserved...                                                                          
     d                                     LIKE( ErrorReserved )                                    
     d APIErrorInformation...                                                                       
     d                              240A                                                            
      *-----------------------------------------------------------------                            
      * program status dataarea                                                                     
      *-----------------------------------------------------------------                            
     d PgmSts         SDS                                                                           
     d   P1User              254    263                                                             
     d   @PGM            *PROC                                                                      
     d  @JOB                 244    253                                                             
      *--------------------------------------------------------------*                              
      * work fields                                                  *                              
      *--------------------------------------------------------------*                              
     d Variables       ds                                                                           
     d   Q                            1    inz( '''' )                                              
     d   Count                       15  0 inz(  0   )                                              
     d   KeyCount                    15  0 inz(  0   )                                              
     d   EndPos                      15  0 inz(  0   )                                              
     d   JobbStatus                   4    inz( ' '  )                                              
     d   Subsystem                   20    inz( ' '  )                                              
     d   ReturnCode                   1    inz( ' '  )                                              
     d   FormatName                   8    inz( ' ' )                                               
     d   QualifedJobName...                                                                         
     d                               26    inz( ' ' )                                               
     d   JobStatus                   10    inz( ' ' )                                               
     d   JobType                      1    inz( ' ' )                                               
     d   NbrOfFldRtn                 10i 0 inz(  0  )                                               
     d   KeyFldRtn                   10i 0 inz(  0  ) dim( 100 )                                    
     d   StartingPosition...                                                                        
     d                               10i 0 inz(  0  )                                               
     d   LengthOfData...                                                                            
     d                               10i 0 inz(  0  )                                               
     d   KeyStartingPosition...                                                                     
     d                               10i 0 inz(  0  )                                               
     d   KeyLengthOfData...                                                                         
     d                               10i 0 inz(  0  )                                               
     d   ReceiverVariable...                                                                        
     d                            32048                                                             
     d   OS400_Cmd                 2000    inz( ' '  )                                              
     d   CmdLength                   15P 5 inz( %size( OS400_Cmd ) )                                
     d   True                         1    inz( *on  )                                              
     d   False                        1    inz( *off )                                              
      *                                                                                             
     d qcmdexc         pr                  extpgm( 'QCMDEXC' )                                      
     d   os400_cmd                 2000A   options( *varsize ) const                                
     d   cmdlength                   15P 5                     const                                
      *                                                                                             
     d emailaddress    s             50    inz('jflanary@liebovich.com')                            
                                                                                                    
      *                                                                                             
      /free                                                                                         
                                                                                                    
       //                                                                                           
       // Create a user space                                                                       
       //                                                                                           
          size = 10000;                                                                             
                                                                                                    
         // Create a user space                                                                     
         QUSCRTUS(UsrSpcName: 'USRSPC': size: x'00': '*ALL':                                        
          'Temp User Space for  QUSLJOB API':  '*YES': APIError);                                   
                                                                                                    
                                                                                                    
       exsr CheckStatusOfJob;                                                                       
                                                                                                    
       *inlr = *on;                                                                                 
       // *************************************************************                             
       // check status of an job                                                                    
       // -------------------------------------------------------------                             
       begsr CheckStatusOfJob;                                                                      
                                                                                                    
       // run API to fill user space with information about all iSeries job                         
                                                                                                    
       FormatName = 'JOBL0200';                                                                     
       QualifedJobName = '*ALL      ' + '*ALL      ' + '*ALL  ';                                    
       JobStatus = '*ACTIVE';                                                                       
       JobType = '*';                                                                               
       NbrOfFldRtn = 2;                                                                             
       KeyFldRtn( 1 ) = 0101;                                                                       
       KeyFldRtn( 2 ) = 1906;                                                                       
       callp QUSLJOB( UsrSpcName : FormatName  : QualifedJobName :                                  
                      JobStatus  : APIError    :                                                    
                      JobType    : NbrOfFldRtn : KeyFldRtn         );                               
                                                                                                    
        // if error message from the retrieve job API then dump program                             
                                                                                                    
       if APIErrorMessageID <> ' ';                                                                 
         dump;                                                                                      
         ReturnCode = True;                                                                         
         leavesr;                                                                                   
       endif;                                                                                       
                                                                                                    
       // run API to get user space attribute                                                       
                                                                                                    
       StartingPosition = 125;                                                                      
       LengthOfData = 16;                                                                           
       callp QUSRTVUS( UsrSpcName   : StartingPosition  :                                           
                       LengthOfData : ReceiverVariable  :                                           
                       APIError                           );                                        
       QUSA0100 = ReceiverVariable;                                                                 
                                                                                                    
        // if error message from the retrieve user space API then dump program                      
                                                                                                    
       if APIErrorMessageID <> ' ';                                                                 
         dump;                                                                                      
         ReturnCode = True;                                                                         
         leavesr;                                                                                   
       endif;                                                                                       
                                                                                                    
       // preperation to read from user space                                                       
                                                                                                    
       StartingPosition = QUsrSpcOffset + 1;                                                        
       LengthOfData = QUsrSpcEntrieSize;                                                            
                                                                                                    
       // read from user space                                                                      
                                                                                                    
       for count = 1 to QUsrSpcEntries;                                                             
         callp QUSRTVUS( UsrSpcName   : StartingPosition  :                                         
                         LengthOfData : ReceiverVariable  :                                         
                         APIError                           );                                      
         LJOB200 = ReceiverVariable;                                                                
         if APIErrorMessageID <> ' ';                                                               
           dump;                                                                                    
           ReturnCode = True;                                                                       
           leavesr;                                                                                 
         endif;                                                                                     
                                                                                                    
         // check status of job                                                                     
         JobbStatus = ' ';                                                                          
         Subsystem = ' ';                                                                           
         LJobKeyInfo = LJob200.ReturnedData;                                                        
                                                                                                    
         // Job type                                                                                
         // A  The job is an autostart job.                                                         
         // B  The job is a batch job.                                                              
         // I  The job is an interactive job.                                                       
         // M  The job is a subsystem monitor job.                                                  
         // R  The job is a spooled reader job.                                                     
         // S  The job is a system job.                                                             
         // W  The job is a spooled writer job.                                                     
         // X  The job is the SCPF system job.                                                      
                                                                                                    
         // Job subtype                                                                             
         // D  The job is a batch immediate job.                                                    
         // E  The job started with a procedure start request.                                      
         // F  The job is an AS/400 Advanced 36 machine server job.                                 
         // J  The job is a prestart job.                                                           
         // P  The job is a print driver job.                                                       
         // T  The job is a System/36 multiple requester terminal (MRT) job.                        
         // U  The job is an alternate spool user.                                                  
                                                                                                    
         KeyStartingPosition = 1;                                                                   
         KeyLengthOfData = LJobKeyInfo.LengthOfInformation;                                         
         for keycount = 1 to LJob200.NumberOfFieldsReturned;                                        
           LJobKeyInfo = %subst( LJob200.ReturnedData :                                             
                                 KeyStartingPosition :                                              
                                 KeyLengthOfData );                                                 
           KeyLengthOfData = LJobKeyInfo.LengthOfInformation;                                       
           LJobKeyInfo = %subst( LJob200.ReturnedData :                                             
                                 KeyStartingPosition :                                              
                                 KeyLengthOfData );                                                 
           Endpos = LJobKeyInfo.LengthOfData;                                                       
           if     LJobKeyInfo.KeyField = 0101;                                                      
              JobbStatus = %subst( LJobKeyInfo.KeyData : 1 :  Endpos );                             
           elseif LJobKeyInfo.KeyField = 1906;                                                      
              Subsystem = %subst( LJobKeyInfo.KeyData : 1 : Endpos );                               
           endif;                                                                                   
           KeyStartingPosition = KeyStartingPosition + KeyLengthOfData;                             
         endfor;                                                                                    
                                                                                                    
         // if job in message wait then email message to address in                                 
         // variable email address                                                                  
                                                                                                    
         if Jobbstatus = 'MSGW';                                                                    
                                                                                                    
                                                                                                    
           os400_cmd = 'snddst type(*lmsg) ' +                                                      
                       'tointnet((' + Q + %trim(EmailAddress) +                                     
                       Q + ')) dstd(' + Q    +                                                      
                       'Hey Its me '     +                                                          
                       %trim(@job)  + '  ' + %char(%time())  +                                      
                       Q + ') longmsg(' + Q  +                                                      
                       'Job in Message wait:  ' +                                                   
                       %trim(ljob200.jobname) + '  ' +                                              
                       %trim(ljob200.username) + '  ' +                                             
                       %trim(ljob200.jobnumber) + '  ' +                                            
                       %char(%time())   +                                                           
                       Q + ')';                                                                     
              qcmdexc ( os400_cmd : %size ( os400_cmd ) );                                          
                                                                                                    
         endif;                                                                                     
                                                                                                    
         StartingPosition = StartingPosition + LengthOfData;                                        
                                                                                                    
       endfor;                                                                                      
                                                                                                    
       endsr;                                                                                       

QLIRNMO - rename and/or move object.


Sample from Jamie Flanary posted at 2012-02-12 11:33:58

      * PROGRAM - @RENAME                                                                           
      * PURPOSE - rename object use API QLIRNMO                                                     
      * WRITTEN -                                                                                   
      * AUTHOR  -                                                                                   
                                                                                                    
      * PROGRAM DESCRIPTION                                                                         
      *--------------------------------------------------------                                     
      *                                                                                             
      * Entry Plist                                                                                 
      *                                                                                             
     d @RENAME         pr                                                                           
     d  OldFile                      10                                                             
     d  OldLib                       10                                                             
     d  NewFile                      10                                                             
     d  NewLib                       10                                                             
     d  inType                       10                                                             
      *                                                                                             
     d @RENAME         pi                                                                           
     d  OldFile                      10                                                             
     d  OldLib                       10                                                             
     d  NewFile                      10                                                             
     d  NewLib                       10                                                             
     d  inType                       10                                                             
      *                                                                                             
      * Variable Definition                                                                         
      *                                                                                             
     d Error           s             34                                                             
     d FromObject      s             20                                                             
     d ObjectType      s             10                                                             
     d ToObject        s             20                                                             
     d Replace         s              1                                                             
      *                                                                                             
      * Program Info                                                                                
      *                                                                                             
     d                SDS                                                                           
     d  @PGM                 001    010                                                             
     d  @PARMS               037    039  0                                                          
     d  @MSGDTA               91    170                                                             
     d  @MSGID               171    174                                                             
     d  @JOB                 244    253                                                             
     d  @USER                254    263                                                             
     d  @JOB#                264    269  0                                                          
       //                                                                                           
       //  external calls                                                                           
       //                                                                                           
     d $Rename         pr                  extpgm('QLIRNMO')                                        
     d   fromObject                  20                                                             
     d   ObjectType                  10                                                             
     d   ToObject                    20                                                             
     d   Replace                      1                                                             
     d   Error                       34                                                             
                                                                                                    
      /Free                                                                                         
                                                                                                    
        //--------------------------------------------------------                                  
        // MAIN LINE                                                                                
        //--------------------------------------------------------                                  
                                                                                                    
                                                                                                    
                   // take parms and rename --and/or-- move object                                  
                                                                                                    
                FromObject = OldFile + OldLib;                                                      
                ToObject = NewFile + NewLib;                                                        
                ObjectType = InType;                                                                
                replace = '1';                                                                      
                                                                                                    
                $rename(FromObject      :                                                           
                        ObjectType      :                                                           
                        ToObject        :                                                           
                        Replace         :                                                           
                        Error                                                                       
                                        );                                                          
                                                                                                    
                                                                                                    
               *inlr = *on;                                                                         
                                                                                                    
                                                                                                    
        //--------------------------------------------------------                                  
        // *Inzsr -  one time run subroutine                                                        
        //--------------------------------------------------------                                  
                                                                                                    
             begsr *inzsr;                                                                          
                                                                                                    
                                                                                                    
             endsr;                                                                                 
      /End-Free                                                                                     

CEERAN0 - Generate random number.


Sample from Jamie Flanary posted at 2012-02-12 11:23:12

     H DFTACTGRP(*NO) ACTGRP('QILE')                                                                
                                                                                                    
     d @RANDOM         PR                  extpgm('@RANDOM')                                        
     d   lowno                       15  5 const                                                    
     d   highno                      15  5 const                                                    
     d   result                      15  5                                                          
                                                                                                    
     d @RANDOM         PI                                                                           
     d   lowno                       15  5 const                                                    
     d   highno                      15  5 const                                                    
     d   result                      15  5                                                          
                                                                                                    
     d CEERAN0         PR                                                                           
     d   seed                        10I 0                                                          
     d   ranno                        8F                                                            
     d   fc                          12A   options(*omit)                                           
                                                                                                    
     d count           s              6  0                                                          
     d outNumber       s             15                                                             
     d rand            s              8F                                                            
     d range           s              5P 0                                                          
     d seed            s             10I 0 inz(4905268)                                             
     d worknumber      s             15  5                                                          
                                                                                                    
      /free                                                                                         
       for count = 1 to %subdt(%TimeStamp():*s);                                                    
       range = (highno - lowno) + 1;                                                                
       CEERAN0( seed : rand : *omit );                                                              
       result = %int(rand * range) + lowno;                                                         
       endfor;                                                                                      
       outnumber = %char(result);                                                                   
       dsply outnumber ' ';                                                                         
       *inlr = *on;                                                                                 
      /end-free                                                                                     

QWCRSVAL - Retrieve system value


Sample from Jamie Flanary posted at 2012-02-12 10:29:39

     h Option(*SrcStmt: *NoDebugIO)                                                                 
      *                                                                                             
     FQSYSPRT   O    F  132        PRINTER OFLIND(*INOF)                                            
      *--------------------------------------------------------                                     
      //                                                                                            
      //  Entry Plist                                                                               
      //                                                                                            
                                                                                                    
     d @CHGPASS        pr                                                                           
     d  InCurrent                    10                                                             
     d  InNew                        10                                                             
                                                                                                    
     d @CHGPASS        pi                                                                           
     d  InCurrent                    10                                                             
     d  InNew                        10                                                             
                                                                                                    
      *                                                                                             
      * Variable Definition                                                                         
      *                                                                                             
     d letters         c                   CONST('AEIOUBCDFGHJKLMNPQRSTVWXZ012-                     
     d                                            3456789')                                         
     d lastchar        s              1                                                             
     d newpass         s             10                                                             
     d numbercorrect   s              2  0                                                          
     d numberrequired  s              2  0                                                          
     d oldpass         s             10                                                             
     d random          s              2  0                                                          
     d value           s             10                                                             
     d BinaryValue     s              4b 0                                                          
     d  w_SrlNbr       s              8                                                             
     d  w_Rcvr         s             36a                                                            
     d  w_RcvrLngth    s             10i 0 inz(%len(w_Rcvr))                                        
     d  w_NbrToRtv     s             10i 0 inz(1)                                                   
     d  w_SysVal       s             10a   inz('QPWDRQDDIF')                                        
     d workPass        s             10                                                             
                                                                                                    
     d DS_SysValTbl    ds                                                                           
     d  d_ValsRtn                    10i 0                                                          
     d  d_Offset                     10i 0                                                          
     d  d_filler                     08a                                                            
     d  d_SysVal                     10a                                                            
     d  d_ValType                     1a                                                            
     d  d_InfoSts                     1a                                                            
     d  d_DtaLngth                   10i 0                                                          
     d  d_Data                       10a                                                            
                                                                                                    
     d changePW        PR                  EXTpgm('QSYCHGPW')                                       
     d   userid                      10                                                             
     d   currentPW                   10                                                             
     d   newPW                       10                                                             
     d   error                       15                                                             
      *                                                                                             
     d ds_Error        Ds            15                                                             
     d  BytesProvided                10I 0 inz(%size(ds_Error))                                     
     d  BytesAvail                   10I 0                                                          
     d  ErrorId                       7                                                             
                                                                                                    
     d QWCRSVAL        pr                  extpgm('QWCRSVAL')                                       
     d  p_Rcvr                             Like(w_Rcvr)                                             
     d  p_RcvrLngth                        Like(w_RcvrLngth)                                        
     d  p_NbrToRtv                         Like(w_NbrToRtv)                                         
     d  p_SysVal                           Like(w_SysVal)                                           
     d  p_Error                            Like(DS_Error)                                           
                                                                                                    
      *                                                                                             
     d area51          ds                                                                           
     d  Whole9Yards                   4                                                             
     d  MinPassLength                10i 0 overlay(Whole9Yards:1)                                   
                                                                                                    
      *                                                                                             
      * Program Info                                                                                
      *                                                                                             
     d                SDS                                                                           
     d  @PGM                   1     10                                                             
     d  @PARMS                37     39  0                                                          
     d  @MSGDTA               91    170                                                             
     d  @MSGID               171    174                                                             
     d  @JOB                 244    253                                                             
     d  @USER                254    263                                                             
     d  @JOB#                264    269  0                                                          
      *                                                                                             
     d  Shorts       e ds                  extname(INRSHRT)                                         
                                                                                                    
      /Free                                                                                         
                                                                                                    
        //--------------------------------------------------------                                  
        // MAIN PROGRAM  - QPWDRQDDIF                                                               
        //--------------------------------------------------------                                  
                                                                                                    
                                                                                                    
                                                                                                    
            exsr Hskpg;                                                                             
                                                                                                    
          if %len(%trim(InNew)) >= MinPassLength and                                                
              %subst(InNew:1:1) >= 'A' and                                                          
              %subst(InNew:1:1) <= 'Z';                                                             
                                                                                                    
            oldpass = InCurrent;                                                                    
            newpass = InNew;                                                                        
                                                                                                    
            dou ErrorId = *blanks and numbercorrect >                                               
                                      numberrequired;                                               
                                                                                                    
                clear  workpass;                                                                    
                dou %len(%trim(WorkPass)) = MinPassLength;                                          
                                                                                                    
                  dou random <> *zeros;                                                             
                    exsr $getRandom;                                                                
                  enddo;                                                                            
                                                                                                    
                  lastchar = %subst(letters:Random:1);                                              
                  workpass = %trim(workPass) + lastchar;                                            
                enddo;                                                                              
                                                                                                    
              clear ErrorId;                                                                        
              changePW( @user : OldPass : WorkPass : ds_Error );                                    
                                                                                                    
              if *inof = *on;                                                                       
                except head;                                                                        
                *inof = *off;                                                                       
              endif;                                                                                
                                                                                                    
               except detail;                                                                       
                                                                                                    
              if ErrorId = *blanks;                                                                 
                numbercorrect +=1;                                                                  
                oldpass = workpass;                                                                 
              endif;                                                                                
                                                                                                    
            enddo;                                                                                  
              changePW( @user : OldPass : newpass : ds_Error );                                     
              except detail;                                                                        
          endif;                                                                                    
                                                                                                    
               *inlr = *on;                                                                         
                                                                                                    
        //--------------------------------------------------------                                  
        // $getRandom - Generate random number                                                      
        //--------------------------------------------------------                                  
                                                                                                    
             begsr $getRandom;                                                                      
                                                                                                    
                  clear  Random;                                                                    
      /end-free                                                                                     
                                                                                                    
     c/Exec SQL                                                                                     
     c+ Select Rand() * 036 Into :Random                                                            
     c+ From SYSIBM/SYSDUMMY1                                                                       
     c/End-Exec                                                                                     
                                                                                                    
      /free                                                                                         
                                                                                                    
                                                                                                    
             endsr;                                                                                 
                                                                                                    
        //--------------------------------------------------------                                  
        // Hskpg - one time run subroutine                                                          
        //--------------------------------------------------------                                  
                                                                                                    
             begsr Hskpg;                                                                           
                                                                                                    
             except head;                                                                           
                                                                                                    
             w_SysVal = 'QPWDRQDDIF';                                                               
             QWCRSVAL(w_Rcvr :                                                                      
                      w_RcvrLngth :                                                                 
                      w_NbrToRtv :                                                                  
                      w_SysVal :                                                                    
                      ds_Error );                                                                   
                                                                                                    
             DS_SysValTbl = w_Rcvr;                                                                 
             Value = %subst(d_Data:1:d_DtaLngth);                                                   
                                                                                                    
                                                                                                    
            //0=Can be the same as old passwords                                                    
            //1=Cannot be the same as last 32                                                       
            //2=Cannot be the same as last 24                                                       
            //3=Cannot be the same as last 18                                                       
            //4=Cannot be the same as last 12                                                       
            //5=Cannot be the same as last 10                                                       
            //6=Cannot be the same as last  8                                                       
            //7=Cannot be the same as last  6                                                       
            //8=Cannot be the same as last  4                                                       
                                                                                                    
              select;                                                                               
                when value = '1';                                                                   
                numberrequired = 32;                                                                
                when value = '2';                                                                   
                numberrequired = 24;                                                                
                when value = '3';                                                                   
                numberrequired = 18;                                                                
                when value = '4';                                                                   
                numberrequired = 12;                                                                
                when value = '5';                                                                   
                numberRequired = 10;                                                                
                when value = '6';                                                                   
                numberRequired = 8;                                                                 
                when value = '7';                                                                   
                numberRequired = 6;                                                                 
                when value = '8';                                                                   
                numberRequired = 4;                                                                 
              endsl;                                                                                
                                                                                                    
                                                                                                    
             w_SysVal = 'QPWDMINLEN';                                                               
             QWCRSVAL(w_Rcvr :                                                                      
                      w_RcvrLngth :                                                                 
                      w_NbrToRtv :                                                                  
                      w_SysVal :                                                                    
                      ds_Error );                                                                   
                                                                                                    
             DS_SysValTbl = w_Rcvr;                                                                 
                                                                                                    
               // this system value is actually in binary...                                        
                                                                                                    
               if d_ValType = 'B';                                                                  
                Whole9Yards =                                                                       
                   %subst(d_Data:1:d_DtaLngth);                                                     
               endif;                                                                               
                                                                                                    
             endsr;                                                                                 
                                                                                                    
      /End-Free                                                                                     
                                                                                                    
     OQSYSPRT   E            HEAD           1 03                                                    
     O                                           10 'workpass'                                      
     O                                           30 'error'                                         
     O                                           45 'Password'                                      
                                                                                                    
     O          E            DETAIL         1                                                       
     O                       workpass            20                                                 
     O                       ErrorId             30                                                 
     O                       newpass             45                                                 

Nice tool to list actual library sizes using IBM API QLIRLIBD.


Sample from Rory Hewitt posted at 2012-02-04 07:24:06

     H DEBUG(*YES)
      *T: LSTLIBD - Retrieve library description
      *O: DBGVIEW(*SOURCE) OPTION(*NODEBUGIO) DFTACTGRP(*NO) ACTGRP(*CALLER)
      *=====================================================================
     FQSYSPRT   O    F  132        PRINTER Oflind(*INOA) Infsr(*PSSR) UsrOpn
      *=====================================================================
     D ThisProgram     C                   'LSTLIBDR'
      *---------------------------------------------------------------------
      *‚API prototypes
      *---------------------------------------------------------------------
      *
      *‚QLIRLIBD - Retrieve Library Description
      *
     D qlirlibd        PR                  Extpgm('QLIRLIBD')
     D   RcvVar                   32767A         Options(*Varsize)
     D   RcvVarLen                   10I 0 Const
     D   Library                     10A   Const
     D   LibAtrToRtv                       Const Like(LibAtrToRtvDS)
     D   ApiError                          Like(QUSEC)
      *
      *‚QUSCRTUS - Create User Space
      *
     D quscrtus        PR                  ExtPgm('QUSCRTUS')
     D   qUsrSpc                     20A   Const
     D   ExtendedAtr                 10A   Const
     D   InitialSize                 10I 0 Const
     D   InitialValue                 1A   Const
     D   PublicAuth                  10A   Const
     D   Text                        50A   Const
     D   Replace                     10A   Const Options(*Nopass)
     D   ApiError                                Like(QUSEC)
     D                                           Options(*Nopass)
      *
      *‚QUSDLTUS - Delete User Space
      *
     D qusdltus        PR                  ExtPgm('QUSDLTUS')
     D   qUsrSpc                     20A   Const
     D   ApiError                                Like(QUSEC)
      *
      *‚QUSPTRUS - Retrieve Pointer to User Space
      *
     D qusptrus        PR                  ExtPgm('QUSPTRUS')
     D   qUsrSpc                     20A   Const
     D   UsrSpc@                       *
     D   ApiError                                Like(QUSEC)
     D                                           Options(*Nopass)
      *
      *‚QUSLOBJ - List Objects
      *
     D quslobj         PR                  Extpgm('QUSLOBJ')
     D   qUsrSpc                     20A   Const
     D   Format                       8A   Const
     D   qObj                        20A   Const
     D   ObjType                     10A   Const
     D   ApiError                          Options(*Nopass) Like(QUSEC)
     D   AutCtl                   32767A   Const Options(*Nopass:*Varsize)
     D   SelCtl                   32767A   Const Options(*Nopass:*Varsize)
      *
      *---------------------------------------------------------------------
      *‚API structures
      *---------------------------------------------------------------------
      *
      *‚QUSEC - Generic API error parameter structure
      *
     D QUSEC           DS                  Qualified
     D  ErrBytesProv                 10I 0 Inz(%size(QUSEC))
     D  ErrBytesAvail                10I 0 Inz
     D  ErrMsgID                      7A
     D                                1
     D  ErrMsgDta                   512A
      *
      *‚Varying Length data structure (QLIRLIBD)
      *
     D VarLenDS        DS                  Qualified Based(VarLen@)
     D   RtnDtaLen                   10I 0
     D   KeyID                       10I 0
     D   FldSize                     10I 0
     D   FldValue                  1000A
     D     FldValInt                 10I 0 Overlay(FldValue)
      *
      *‚Library attributes to retrieve (QLIRLIBD)
      *
     D LibAtrToRtvDS   DS                  Qualified
     D   Nbr                         10I 0
     D   Elm                         10I 0 Dim(7)
      *
      *‚Returned data (QLIRLIBD)
      *
     D QLIRR           DS         32767    Qualified
     D   BytesReturn                 10I 0
     D   BytesAvail                  10I 0
     D   VarLenRcdRtn                10I 0
     D   VarLenRcdAvl                10I 0
      *
      *‚Library size data structure (QLIRLIBD)
      *
     D LibSizeDS       DS
     D   LibSize                     10I 0
     D   LibSizeMult                 10I 0
     D   LibInfSts                     N
     D                                3A
      *
      *‚List API header structure (QUSLOBJ)
      *
     D QUSH0100        DS                  Based(QUSH0100@) Qualified
     D   UserArea                    64A
     D   GenHdrSize                  10I 0
     D   StructRlsLvl                 4A
     D   FormatName                   8A
     D   ApiUsed                     10A
     D   DatTimCrt                   13A
     D   InfStatus                    1A
     D   UsrSpcSize                  10I 0
     D   InpParmOS                   10I 0
     D   InpParmSize                 10I 0
     D   HeaderOS                    10I 0
     D   HeaderSize                  10I 0
     D   ListDataOS                  10I 0
     D   ListDataSize                10I 0
     D   EntryNbr                    10I 0
     D   EntrySize                   10I 0
     D   EntryCCSID                  10I 0
     D   CountryID                    2A
     D   LanguageID                   3A
     D   SubSetInd                    1A
     D                               42A
     D APIEntryPoint                256A
     D                              128A
      *
      *‚OBJL0200 returned data structure (QUSLOBJ)
      *
     D OBJL0200        DS                  Qualified Based(OBJL0200@)
     D   ObjName                     10A
     D   ObjLib                      10A
     D   ObjType                     10A
     D   ObjInfSts                    1A
     D   ObjExtAtr                   10A
     D   ObjText                     50A
     D   ObjUsrAtr                   10A
     D                                7A
      *
      *---------------------------------------------------------------------
      *‚Global variables
      *---------------------------------------------------------------------
      *
     D UsrSpc@         S               *
     D qUsrSpc         DS
     D   UsrSpc                      10A   Inz('QUSLOBJ')
     D   UsrSpcLib                   10A   Inz('QTEMP')
     D UsrSpcSize      C                   10000000
      *
     D                 DS
     D L                             10I 0
     D LibDArr                             Dim(5000)
     D LibName                       10A   Overlay(LibdArr)
     D LibText                       50A   Overlay(LibdArr:*Next)
     D NbrLibObj                     10I 0 Overlay(LibdArr:*Next)
     D LibTotSize                    20I 0 Overlay(LibdArr:*Next)
      *
     D R                             10I 0
     D TotLibX         S             10A
     D NbrLibObjX      S             10A
     D LibTotSizeX     S             20A
      *
      *---------------------------------------------------------------------
      *‚Program interface
      *---------------------------------------------------------------------
      *
     D main            PR                  Extpgm(ThisProgram)
     D   P_Lib                       10A   Const
     D   P_Sort                       5A   Const
      *
     D main            PI
     D   P_Lib                       10A   Const
     D   P_Sort                       5A   Const
      *
      *=====================================================================
      *‚MAINLINE
      *=====================================================================
      /free

        //‚Set variables

        LibAtrToRtvDS.Nbr    = 2;
        LibAtrToRtvDS.Elm(1) = 6; //‚Library size
        LibAtrToRtvDS.Elm(2) = 7; //‚Objects in library
        L          = 0;
        LibName    = *HIVAL;
        LibText    = *HIVAL;
        NbrLibObj  = *HIVAL;
        LibTotSize = *HIVAL;

        open(e) QSYSPRT;

        //‚Create the user space

        reset QUSEC;
        quscrtus( qUsrSpc : *blanks : UsrSpcSize : x'00' : '*ALL' :
                  *blanks : '*NO' : QUSEC );
        if QUSEC.ErrBytesAvail > 0 and QUSEC.ErrMsgID <> 'CPF9870';
          exsr *pssr;
        endif;

        //‚Retrieve the pointer to the user space.

        reset QUSEC;
        qusptrus( qUsrSpc : UsrSpc@ : QUSEC );
        if QUSEC.ErrBytesAvail > 0;
          exsr *pssr;
        endif;

        //‚List all the specified libraries into the user space

        reset QUSEC;
        quslobj( qUsrSpc : 'OBJL0200' : P_Lib + 'QSYS' : '*LIB' : QUSEC );
        if QUSEC.ErrBytesAvail > 0;
          exsr *pssr;
        endif;

        //‚Process each library in the user space

        QUSH0100@ = UsrSpc@;
        OBJL0200@ = QUSH0100@ + QUSH0100.ListDataOS;
        for L = 1 to QUSH0100.EntryNbr;
          exsr RtvLibDtls;
          OBJL0200@ = OBJL0200@ + QUSH0100.EntrySize;
        endfor;

        //‚Sort the array

        select;
          when P_Sort = '*NAME';
            sorta LibName;
          when P_Sort = '*TEXT';
            sorta LibText;
          when P_Sort = '*OBJ';
            sorta NbrLibObj;
          when P_Sort = '*SIZE';
            sorta LibTotSize;
          other;
        endsl;

        //‚Write out the output

        TotLibX = %char( QUSH0100.EntryNbr );
        except Header;

        for L = 1 to QUSH0100.EntryNbr;
          evalr NbrLibObjX  = %char( NbrLibObj( L ) );
          evalr LibTotSizeX = %char( LibTotSize( L ) );
          except Detail;
        endfor;

        except Footer;

        qusdltus( qUsrSpc : QUSEC );
        close(e) QSYSPRT;

        return;

        //‚RtvLibDtls: Retrieve library details

        begsr RtvLibDtls;

          //‚Don't try to process QSYS

          if OBJL0200.ObjName = 'QSYS';
            LibName( L )    = OBJL0200.ObjName;
            LibText( L )    = OBJL0200.ObjText;
            NbrLibObj( L )  = 0;
            LibTotSize( L ) = 0;
            leavesr;
          endif;

          //‚Retrieve the library details

          clear QLIRR;
          reset QUSEC;
          qlirlibd( QLIRR : %size( QLIRR ) : OBJL0200.ObjName :
                    LibAtrToRtvDS : QUSEC );
          if QUSEC.ErrBytesAvail > 0;
            LibName( L )    = OBJL0200.ObjName;
            LibText( L )    = '**UNABLE TO RETRIEVE DETAILS**';
            NbrLibObj( L )  = 0;
            LibTotSize( L ) = 0;
            leavesr;
          endif;

          LibName( L ) = OBJL0200.ObjName;
          LibText( L ) = OBJL0200.ObjText;

          //‚Process the library detail variable-length records

          VarLen@ = %addr( QLIRR ) + 16;
          for R = 1 to QLIRR.VarLenRcdRtn;
            select;
              when VarLenDS.KeyID = 6; //‚Library total size
                LibSizeDS = VarLenDS.FldValue;
                LibTotSize( L ) = LibSize * LibSizeMult;
              when VarLenDS.KeyID = 7; //‚Number of objects in library
                NbrLibObj( L ) = VarLenDS.FldValInt;
              other;
            endsl;
            VarLen@ = VarLen@ + VarLenDS.RtnDtaLen;
          endfor;

        endsr;

        //‚*PSSR Error subroutine

        begsr *pssr;
          close(e) QSYSPRT;
          qusdltus( qUsrSpc : QUSEC );
        endsr;

      /end-free
      *=====================================================================
     OQSYSPRT   E            Header         1  3
     O                                              'Library details for -
     O                                              library '''
     O                       P_Lib
     O                                              ''' (ordered by'
     O                       P_Sort              +1
     O                                              ')'
     O          E            Header      1  1
     O                                              'Libraries processed:'
     O                       TotLibX             +1
     O          E            Header      1  1
     O                                            7 'Library'
     O                                           16 'Text'
     O                                           73 'Objects'
     O                                           96 'Total size (bytes)'
     O          E            Header      1  1
     O                                           10 '=========='
     O                                           37 '========================='
     O                                           62 '========================='
     O                                           76 '=========='
     O                                           98 '===================='
      *---------------------------------------------------------------------
     O          E            Detail      1  1
     O                       LibName(L)          10
     O                       LibText(L)          62
     O                       NbrLibObjX          76
     O                       LibTotSizeX         98
      *---------------------------------------------------------------------
     O          E            Footer      2
     O                                              'End of library details -
     O                                              for library '''
     O                       P_Lib
     O                                              ''' (ordered by'
     O                       P_Sort              +1
     O                                              ')'

Details:http://www.systeminetwork.com/
article/systems-management/
the-list-library-details-lstlibd-command-18385

Posted in linkedin:
http://www.linkedin.com/groups/

Using IBM system API QSPRJOBQ to list number of jobs in JOBQ


Sample from Jamie Flanary posted at 2012-02-03 23:45:25

      // ****************************************************************** //
      // *  Compile Options                                               * //
      // ****************************************************************** //
     H Option(*SRCSTMT:*NODEBUGIO)

      // ****************************************************************** //
      // *  Definition Specifations                                       * //
      // ****************************************************************** //
      // ------------------------------------------------------------------ //
      // - External Prototypes                                            - //
      // ------------------------------------------------------------------ //
     D GETJOBQ         PR                  EXTPGM('QSPRJOBQ')
     D  RECIEVER                    144A
     D  RCVRLEN                      10I 0 const
     D  FORMAT                        8A   const
     D  JOBQ                         20A   conST
     D  ERROR                       116A
      *
     ****** /INCLUDE QSYSINC/QRPGLESRC,QSPRJOBQ
      *
     DQSPQ010000       DS
     D*                                             Qsp JOBQ0100
     D QSPBRTN00               1      4B 0
     D*                                             Bytes Returned
     D QSPBAVL00               5      8B 0
     D*                                             Bytes Available
     D QSPJQN                  9     18
     D*                                             Job Queue Name
     D QSPJQLN                19     28
     D*                                             Job Queue Lib Name
     D QSPOC01                29     38
     D*                                             Operator Controlled
     D QSPAC                  39     48
     D*                                             Authority Check
     D QSPNBRJ                49     52B 0
     D*                                             Number Jobs
     D QSPJQS                 53     62
     D*                                             Job Queue Status
     D QSPSN                  63     72
     D*                                             Subsystem Name
     D QSPTD                  73    122
     D*                                             Text Description
     D QSPSLN                123    132
     D*                                             Subsystem Lib Name
     D QSPSNBR01             133    136B 0
     D*                                             Sequence Number
     D QSPMA00               137    140B 0
     D*                                             Maximum Active
     D QSPCA00               141    144B 0
      *                                             Current Active
      *
      *
     DQSPQ020000       DS
     D*                                             Qsp JOBQ0200
     D QSPBRTN05               1      4B 0
     D*                                             Bytes Returned
     D QSPBAVL03               5      8B 0
     D*                                             Bytes Available
     D QSPJQN02                9     18
     D*                                             Job Queue Name
     D QSPJQLN02              19     28
     D*                                             Job Queue Lib Name
     D QSPOC02                29     38
     D*                                             Operator Controlled
     D QSPAC00                39     48
     D*                                             Authority Check
     D QSPNBRJ00              49     52B 0
     D*                                             Number Jobs
     D QSPJQS01               53     62
     D*                                             Job Queue Status
     D QSPSN02                63     72
     D*                                             Subsystem Name
     D QSPSLN00               73     82
     D*                                             Subsystem Lib Name
     D QSPTD00                83    132
     D*                                             Text Description
     D QSPSNBR02             133    136B 0
     D*                                             Sequence Number
     D QSPMA01               137    140B 0
     D*                                             Maximum Active
     D QSPCA01               141    144B 0
     D*                                             Current Active
     D QSPMAP1               145    148B 0
     D*                                             Max Active Priority
     D QSPMAP2               149    152B 0
     D*                                             Max Active Priority
     D QSPMAP3               153    156B 0
     D*                                             Max Active Priority
     D QSPMAP4               157    160B 0
     D*                                             Max Active Priority
     D QSPMAP5               161    164B 0
     D*                                             Max Active Priority
     D QSPMAP6               165    168B 0
     D*                                             Max Active Priority
     D QSPMAP7               169    172B 0
     D*                                             Max Active Priority
     D QSPMAP8               173    176B 0
     D*                                             Max Active Priority
     D QSPMAP9               177    180B 0
     D*                                             Max Active Priority
     D QSPAJP0               181    184B 0
     D*                                             Active Jobs Priorit
     D QSPAJP1               185    188B 0
     D*                                             Active Jobs Priorit
     D QSPAJP2               189    192B 0
     D*                                             Active Jobs Priorit
     D QSPAJP3               193    196B 0
     D*                                             Active Jobs Priorit
     D QSPAJP4               197    200B 0
     D*                                             Active Jobs Priorit
     D QSPAJP5               201    204B 0
     D*                                             Active Jobs Priorit
     D QSPAJP6               205    208B 0
     D*                                             Active Jobs Priorit
     D QSPAJP7               209    212B 0
     D*                                             Active Jobs Priorit
     D QSPAJP8               213    216B 0
     D*                                             Active Jobs Priorit
     D QSPAJP9               217    220B 0
     D*                                             Active Jobs Priorit
     D QSPJOQP0              221    224B 0
     D*                                             RLS Jobs on Queue P
     D QSPJOQP1              225    228B 0
     D*                                             RLS Jobs on Queue P
     D QSPJOQP2              229    232B 0
     D*                                             RLS Jobs on Queue P
     D QSPJOQP3              233    236B 0
     D*                                             RLS Jobs on Queue P
     D QSPJOQP4              237    240B 0
     D*                                             RLS Jobs on Queue P
     D QSPJOQP5              241    244B 0
     D*                                             RLS Jobs on Queue P
     D QSPJOQP6              245    248B 0
     D*                                             RLS Jobs on Queue P
     D QSPJOQP7              249    252B 0
     D*                                             RLS Jobs on Queue P
     D QSPJOQP8              253    256B 0
     D*                                             RLS Jobs on Queue P
     D QSPJOQP9              257    260B 0
     D*                                             RLS Jobs on Queue P
     D QSPJOQP000            261    264B 0
     D*                                             SCH Jobs on Queue P
     D QSPJOQP100            265    268B 0
     D*                                             SCH Jobs on Queue P
     D QSPJOQP200            269    272B 0
     D*                                             SCH Jobs on Queue P
     D QSPJOQP300            273    276B 0
     D*                                             SCH Jobs on Queue P
     D QSPJOQP400            277    280B 0
     D*                                             SCH Jobs on Queue P
     D QSPJOQP500            281    284B 0
     D*                                             SCH Jobs on Queue P
     D QSPJOQP600            285    288B 0
     D*                                             SCH Jobs on Queue P
     D QSPJOQP700            289    292B 0
     D*                                             SCH Jobs on Queue P
     D QSPJOQP800            293    296B 0
     D*                                             SCH Jobs on Queue P
     D QSPJOQP900            297    300B 0
     D*                                             SCH Jobs on Queue P
     D QSPJOQP001            301    304B 0
     D*                                             HLD Jobs on Queue P
     D QSPJOQP101            305    308B 0
     D*                                             HLD Jobs on Queue P
     D QSPJOQP201            309    312B 0
     D*                                             HLD Jobs on Queue P
     D QSPJOQP301            313    316B 0
     D*                                             HLD Jobs on Queue P
     D QSPJOQP401            317    320B 0
     D*                                             HLD Jobs on Queue P
     D QSPJOQP501            321    324B 0
     D*                                             HLD Jobs on Queue P
     D QSPJOQP601            325    328B 0
     D*                                             HLD Jobs on Queue P
     D QSPJOQP701            329    332B 0
     D*                                             HLD Jobs on Queue P
     D QSPJOQP801            333    336B 0
     D*                                             HLD Jobs on Queue P
     D QSPJOQP901            337    340B 0
      *                                             HLD Jobs on Queue P
      *
      */INCLUDE QSYSINC/QRPGLESRC,QUSEC
      *
     DQUSEC            DS
      *                                             Qus EC
     D QUSBPRV                 1      4B 0
      *                                             Bytes Provided
     D QUSBAVL                 5      8B 0
      *                                             Bytes Available
     D QUSEI                   9     15
      *                                             Exception Id
     D QUSERVED               16     16
      *                                             Reserved
     D*QUSED01                17     17
     D*
     D*                                      Varying length
     DQUSC0200         DS
     D*                                             Qus ERRC0200
     D QUSK01                  1      4B 0
     D*                                             Key
     D QUSBPRV00               5      8B 0
     D*                                             Bytes Provided
     D QUSBAVL14               9     12B 0
     D*                                             Bytes Available
     D QUSEI00                13     19
     D*                                             Exception Id
     D QUSERVED39             20     20
     D*                                             Reserved
     D QUSCCSID11             21     24B 0
     D*                                             CCSID
     D QUSOED01               25     28B 0
     D*                                             Offset Exc Data
     D QUSLED01               29     32B 0
     D*                                             Length Exc Data
     D*QUSRSV214              33     33
     D*                                             Reserved2

     D QUSED01                      100A
      *
      * Standard API error data structure
      *
     d APIERROR        DS                  INZ
     d  AEBYPR                 1      4B 0
     d  AEBYAV                 5      8B 0
     d  AEEXID                 9     15
     d  AEEXDT                16    116
      *

      // ****************************************************************** //
      // *  Main Calculations                                             * //
      // ****************************************************************** //
      /Free
       GETJOBQ(QSPQ020000:%SIZE(QSPQ020000):'JOBQ0200':
                   'QINTER    QGPL':APIERROR);
       DSPLY QSPSN;
       *INLR = *On;
      /End-Free


Use QUSRJOBI API to tell if program running interactive or batch environment


Sample from Jamie Flanary posted at 2012-02-03 21:19:20

Here's the subprocedure that I use, along with a quick example:

     D IsIntJob        PR             1N
     D Msg             S             50A

     c                   if        IsIntJob
     c                   eval      Msg = 'Interactive job'
     c                   dsply                   Msg
     c                   else
     c                   eval      Msg = 'Non-interactive job.'
     c     Msg           dsply
     c                   endif

     c                   eval      *inlr = *on

      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      *   IsIntJob   --   Is this an interactive job?
      *        returns *ON if job is interactive
      *            or  *OFF if job is not interactive.
      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     P IsIntJob        B                   export
     D IsIntJob        PI             1N

     D QUSRJOBI        PR                  EXTPGM('QUSRJOBI')
     D   RcvVar                   32766A   options(*varsize)
     D   RcvVarLen                   10I 0 const
     D   Format                       8A   const
     D   QualJob                     26A   const
     D   InternJob                   16A   const
     D   ErrorCode                32766A   options(*nopass:*varsize)

     D dsJob           DS
     D  dsJobBytesRtn                10I 0
     D  dsJobBytesAvl                10I 0
     D  dsJobName                    10A
     D  dsJobUser                    10A
     D  dsJobNumber                   6A
     D  dsJobIntern                  16A
     D  dsJobStatus                  10A
     D  dsJobType                     1A
     D  dsJobSubtype                  1A
     D  dsJobReserv1                  2A
     D  dsJobRunPty                  10I 0
     D  dsJobTimeSlc                 10I 0
     D  dsJobDftWait                 10I 0
     D  dsJobPurge                   10A

     c                   callp     QUSRJOBI(dsJob: %size(dsJob):'JOBI0100': 
     c                                   '*': *blanks)
     c                   if        dsJobType = 'I'
     c                   return    *ON
     c                   else
     c                   return    *OFF
     c                   endif
     P                 E

Using IBM system API QUSROBJD to determine if object exsists.


Sample from Jamie Flanary posted at 2012-02-03 19:55:45

Here's an RPG/IV sample to test if an object exists:

     **-- Header specifications:  --------------------------------------------**
     H Option( *SrcStmt )
     **-- Global variables:  -------------------------------------------------**
     D ObjNam          s             10a
     D ObjLib          s             10a
     D ObjTyp          s             10a
     **-- Api error data structure:  -----------------------------------------**
     D ApiError        Ds
     D  AeBytPro                     10i 0 Inz( %Size( ApiError ))
     D  AeBytAvl                     10i 0 Inz
     D  AeMsgId                       7a
     D                                1a
     D  AeMsgDta                    128a
     **-- Object description structure OBJD0100:  ----------------------------**
     D RoData          Ds
     D  RoBytRtn                     10i 0
     D  RoBytAvl                     10i 0
     D  RoObjNam                     10a
     D  RoObjLib                     10a
     D  RoObjTypRt                   10a
     D  RoObjLibRt                   10a
     D  RoObjASP                     10i 0
     D  RoObjOwn                     10a
     D  RoObjDmn                      2a
     D  RoObjCrtDts                  13a
     D  RoObjChgDts                  13a
     D  RoExtAtr                     10a
     D  RoTxtDsc                     50a
     D  RoSrcF                       10a
     D  RoSrcLib                     10a
     D  RoSrcMbr                     10a
     **-- Retrieve object description:  --------------------------------------**
     D RtvObjD         Pr                  ExtPgm( 'QUSROBJD' )
     D  RoRcvVar                  32767a         Options( *VarSize )
     D  RoRcvVarLen                  10i 0 Const
     D  RoFmtNam                      8a   Const
     D  RoObjNamQ                    20a   Const
     D  RoObjTyp                     10a   Const
     D  RoError                   32767a         Options( *VarSize )
     **
     **-- Get Web value:  ----------------------------------------------------**
     **
     C                   Eval      ObjNam     =  '???'
     C                   Eval      ObjLib     =  '*LIBL'
     C                   Eval      ObjTyp     =  '*PGM'
     **
     C                   CallP     RtvObjD( RoData
     C                                    : %Size( RoData )
     C                                    : 'OBJD0100'
     C                                    : ObjNam + ObjLib
     C                                    : ObjTyp
     C                                    : ApiError
     C                                    )
     **
     C                   If        AeBytAvl   >  *Zero         And
     C                             AeMsgId    =  'CPF9801'
     **-- Object doesn't exist...
     C                   EndIf
     **
     C                   Return
     **

Best regards,
Carsten Flensburg

QUSRMBRD - List all members in a physical file.


Sample from Jamie Flanary posted at 2011-12-18 19:54:31

      *=====================================================                                        
      * PROGRAM - XXXXXX                                                                            
      * PURPOSE - List members in a file                                                            
      *                                                                                             
      * PROGRAM DESCRIPTION                                                                         
      *   This program will list all members in a file                                              
      *                                                                                             
      *                                                                                             
      *                                                                                             
      * INPUT PARAMETERS                                                                            
      *   Description        Type  Size    How Used                                                 
      *   -----------        ----  ----    --------                                                 
      *   ApiLibrary         Char  10      input                                                    
      *   ApiFile            Char  10      input                                                    
      *                                                                                             
      * INDICATOR USAGE                                                                             
      *   n/a                                                                                       
      *                                                                                             
      *=====================================================                                        
      *                                                                                             
      * Program Info                                                                                
      *                                                                                             
     d PgmInfo        SDS                                                                           
     d  @PgmName               1     10                                                             
     d  @Parms                37     39  0                                                          
     d  @MsgID                40     46                                                             
     d  @JobName             244    253                                                             
     d  @UserId              254    263                                                             
     d  @JobNumber           264    269  0                                                          
      *                                                                                             
      * constants                                                                                   
      *                                                                                             
     d Q               c                   const('''')                                              
     d Up              c                   const('ABCDEFGHIJKLMNOPQRSTUVWXYZ')                      
     d Low             c                   const('abcdefghijklmnopqrstuvwxyz')                      
      *                                                                                             
      *  Field Definitions.                                                                         
      *                                                                                             
     d AllMembers      s             10a   inz('*ALL')                                              
     d ApiFile         s             10                                                             
     d ApiLibrary      s             10                                                             
     d ApiMember       s             10                                                             
     d bOvr            s              1a   inz('0')                                                 
     d FileLib         s             20a                                                            
     d Format          s              8a                                                            
     d MemberName      s             10                                                             
     d nBufLen         s             10i 0                                                          
     d ObjectLib       s             10                                                             
     d OutData         s             30                                                             
     d ReceiverLen     s             10i 0 inz(100)                                                 
     d SpaceVal        s              1    inz(*BLANKS)                                             
     d SpaceAuth       s             10    inz('*CHANGE')                                           
     d SpaceText       s             50    inz(*BLANKS)                                             
     d SpaceRepl       s             10    inz('*YES')                                              
     d SpaceAttr       s             10    inz(*BLANKS)                                             
     d UseScreen       s               n                                                            
     d UserSpaceOut    s             20                                                             
      *                                                                                             
      * QUSRMBRD API return Struture                                                                
      * ============================                                                                
     d Mbrd0100        ds                  inz                                                      
     d  nBytesRtn                    10i 0                                                          
     d  nBytesAval                   10i 0                                                          
     d  DBXLIB                       10a                                                            
     d  DBXFIL                       10a                                                            
     d  MbrName                      10a                                                            
     d  FileAttr                     10a                                                            
     d  SrcType                      10a                                                            
     d  dtCrtDate                    13a                                                            
     d  dtLstChg                     13a                                                            
     d  MbrText                      50a                                                            
     d  bIsSource                     1a                                                            
     d  RmtFile                       1a                                                            
     d  LglPhyFile                    1a                                                            
     d  ODPSharing                    1a                                                            
     d  filler2                       2a                                                            
     d  RecCount                     10i 0                                                          
     d  DltRecCnt                    10i 0                                                          
     d  DataSpaceSz                  10i 0                                                          
     d  AccpthSz                     10i 0                                                          
     d  NbrBasedOnMbr                10i 0                                                          
      *                                                                                             
      * Create userspace datastructure                                                              
      *                                                                                             
     d  stuff          DS                                                                           
     d  StartPosit                   10i 0                                                          
     d  StartLen                     10i 0                                                          
     d  SpaceLen                     10i 0                                                          
     d  ReceiveLen                   10i 0                                                          
     d  MessageKey                   10i 0                                                          
     d  MsgDtaLen                    10i 0                                                          
     d  MsgQueNbr                    10i 0                                                          
      *                                                                                             
      * Date structure for retriving userspace info                                                 
      *                                                                                             
     d InputDs         DS                                                                           
     d  UserSpace              1     20                                                             
     d  SpaceName              1     10                                                             
     d  SpaceLib              11     20                                                             
     d  InpFileLib            29     48                                                             
     d  InpFFilNam            29     38                                                             
     d  InpFFilLib            39     48                                                             
     d  InpRcdFmt             49     58                                                             
      *                                                                                             
      *  Data structure for the retrieve user space command                                         
      *                                                                                             
     d GENDS           DS                                                                           
     d  Filler3                     116                                                             
     d  OffsetHdr                    10i 0                                                          
     d  SizeHeader                   10i 0                                                          
     d  OffsetList                   10i 0                                                          
     d  Filler4                       4                                                             
     d  NbrInList                    10i 0                                                          
     d  SizeEntry                    10i 0                                                          
      *                                                                                             
      * Datastructure for retrieving elements from userspace                                        
      *                                                                                             
     d HeaderDs        DS                                                                           
     d  OutFileNam             1     10                                                             
     d  OutLibName            11     20                                                             
     d  OutType               21     25                                                             
     d  OutFormat             31     40                                                             
     d  RecordLen             41     44i 0                                                          
      *                                                                                             
      * List the members                                                                            
      *                                                                                             
     d ListDs          DS                                                                           
     d  LmMember                     10                                                             
     d  LmType                       10                                                             
     d  LmCreationDt                  7                                                             
     d  LmCreationTm                  6                                                             
     d  LmLastChgDt                   7                                                             
     d  LmLastChgTm                   6                                                             
     d  LmDescription                50                                                             
      *                                                                                             
      * Retrive object description                                                                  
      *                                                                                             
     d RtvObjInfo      DS                                                                           
     d  RoBytRtn                     10i 0                                                          
     d  RoBytAvl                     10i 0                                                          
     d  RoObjNam                     10a                                                            
     d  RoObjLib                     10a                                                            
     d  RoObjTypRt                   10a                                                            
     d  RoObjLibRt                   10a                                                            
     d  RoObjASP                     10i 0                                                          
     d  RoObjOwn                     10a                                                            
     d  RoObjDmn                      2a                                                            
     d  RoObjCrtDts                  07a                                                            
     d  RoObjCrtTim                  06a                                                            
     d  RoObjChgDts                  07a                                                            
     d  RoObjChgTim                  06a                                                            
     d  RoExtAtr                     10a                                                            
     d  RoTxtDsc                     50a                                                            
     d  RoSrcF                       10a                                                            
     d  RoSrcLib                     10a                                                            
     d  RoSrcMbr                     10a                                                            
      *                                                                                             
      * API Error Data Structure                                                                    
      *                                                                                             
     d Errords         ds                                                                           
     d  BytesPrv               1      4I 0 inz(%size(errords))                                      
     d  BytesAvl               5      8I 0 inz(0)                                                   
     d  MessageId              9     15                                                             
     d  ERR###                16     16                                                             
     d  MessageDta            17    256                                                             
      *                                                                                             
      *=====================================================                                        
      * MAIN LINE                                                                                   
      *=====================================================                                        
      *                                                                                             
      * Now List the members of this source file to a userspace                                     
      *                                                                                             
     c                   exsr      $QUSCRTUS                                                        
      *                                                                                             
     c                   eval      MemberName = '*ALL'                                              
     c                   eval      Format  = 'MBRL0200'                                             
     c                   exsr      $QUSLMBR                                                         
      *                                                                                             
      *  Read back the members                                                                      
      *                                                                                             
     c                   eval      StartPosit = 1                                                   
     c                   eval      StartLen = 140                                                   
      *                                                                                             
      * First call to get data offsets(start)                                                       
      *                                                                                             
     c                   call(e)   'QUSRTVUS'                                                       
     c                   parm                    UserSpaceOut                                       
     c                   parm                    StartPosit                                         
     c                   parm                    StartLen                                           
     c                   parm                    GENDS                                              
     c                   parm                    ErrorDs                                            
      *                                                                                             
      * Then call to get number of entries                                                          
      *                                                                                             
     c                   eval      StartPosit = OffsetHdr + 1                                       
     c                   eval      StartLen = SizeHeader                                            
      *                                                                                             
     c                   call(e)   'QUSRTVUS'                                                       
     c                   parm                    UserSpaceOut                                       
     c                   parm                    StartPosit                                         
     c                   parm                    StartLen                                           
     c                   parm                    HeaderDs                                           
     c                   parm                    ErrorDs                                            
      *                                                                                             
     c                   eval      StartPosit = OffsetList + 1                                      
     c                   eval      StartLen = SizeEntry                                             
      *                                                                                             
      *  Do for number of members                                                                   
      *                                                                                             
     c                   do        NbrInList                                                        
     c                   call(e)   'QUSRTVUS'                                                       
     c                   parm                    UserSpaceOut                                       
     c                   parm                    StartPosit                                         
     c                   parm                    StartLen                                           
     c                   parm                    ListDs                                             
     c                   parm                    ErrorDs                                            
      *                                                                                             
     c                   eval      ApiMember = LmMember                                             
     c                   exsr      $QUSRMBRD                                                        
     c                   eval      OutData = %trim(LmMember) + '-' +                                
     c                             %char(RecCount) +' Deleted: '+                                   
     c                             %char(DltRecCnt)                                                 
     c     OutData       dsply                   reply             1                                
      *                                                                                             
     c                   eval      StartPosit = StartPosit + SizeEntry                              
     c                   enddo                                                                      
      *                                                                                             
     c                   eval      *inlr = *on                                                      
      *=====================================================                                        
      * $QUSRMBRD - API Retreive Member Description                                                 
      *=====================================================                                        
     c     $QUSRMBRD     begsr                                                                      
      *                                                                                             
     c                   eval      nBufLen = %size(MbrD0100)                                        
     c                   eval      Format  = 'MBRD0200'                                             
      *                                                                                             
     c                   call(e)   'QUSRMBRD'                                                       
     c                   parm                    MbrD0100                                           
     c                   parm                    nBufLen                                            
     c                   parm                    Format                                             
     c                   parm                    FileLib                                            
     c                   parm                    ApiMember                                          
     c                   parm                    bOvr                                               
      *                                                                                             
     c                   endsr                                                                      
      *========================================================================                     
      * $QUSCRTUS - API to create user space                                                        
      *========================================================================                     
     c     $QUSCRTUS     begsr                                                                      
      *                                                                                             
      * Create a user space named ListMember in QTEMP.                                              
      *                                                                                             
     c                   Eval      BytesPrv = 116                                                   
     c                   movel(p)  'MEMBERS'     SpaceName                                          
     c                   movel(p)  'QTEMP'       SpaceLib                                           
      *                                                                                             
      * Create the user space                                                                       
      *                                                                                             
     c                   call(e)   'QUSCRTUS'                                                       
     c                   parm      UserSpace     UserSpaceOut                                       
     c                   parm                    SpaceAttr                                          
     c                   parm      4096          SpaceLen                                           
     c                   parm                    SpaceVal                                           
     c                   parm                    SpaceAuth                                          
     c                   parm                    SpaceText                                          
     c                   parm                    SpaceRepl                                          
     c                   parm                    ErrorDs                                            
      *                                                                                             
     c                   endsr                                                                      
      *========================================================================                     
      * $QUSLMBR  - API List all members in a file                                                  
      *========================================================================                     
     c     $QUSLMBR      begsr                                                                      
      *                                                                                             
     c                   eval      nBufLen = %size(MbrD0100)                                        
      *                                                                                             
     c                   call(e)   'QUSLMBR'                                                        
     c                   parm                    UserSpaceOut                                       
     c                   parm                    Format                                             
     c                   parm                    FileLib                                            
     c                   parm                    AllMembers                                         
     c                   parm                    bOvr                                               
     c                   parm                    ErrorDs                                            
      *                                                                                             
     c                   endsr                                                                      
      *=====================================================                                        
      * Initialization                                                                              
      *=====================================================                                        
     c     *inzsr        begsr                                                                      
      *                                                                                             
     c     *entry        plist                                                                      
     c                   parm                    ApiFile                                            
     c                   parm                    ApiLibrary                                         
      *                                                                                             
     c                   eval      FileLib     = ApiFile  + ApiLibrary                              
      *                                                                                             
     c                   endsr                                                                      

QUSRJOBI - List system library list, user library list and current library.


Sample from Jamie Flanary posted at 2011-12-18 19:48:57

                                                                                                    
     d count           s              2  0                                                          
     d Current         s             10                                                             
     d SkipLibs        s              3  0                                                          
                                                                                                    
      //                                                                                            
      //  External Calls                                                                            
      //                                                                                            
                                                                                                    
     d $GetLibList     PR                  ExtPgm('QUSRJOBI')                                       
     d RcvVar                     32767    Options(*VarSize)                                        
     d LengthRcv                     10I 0 Const                                                    
     d FormatName                     8A   Const                                                    
     d QualJobName                   26    Const                                                    
     d InternalJobId                 16    Const                                                    
     d Error_ds                      15                                                             
                                                                                                    
      //                                                                                            
      //  Data Structures                                                                           
      //                                                                                            
                                                                                                    
     d ds_job10700     Ds         32767                                                             
     d  BYTRTN                       10i 0                                                          
     d  BYTVAL                       10i 0                                                          
     d  QJOBNM                 9     34                                                             
     d  JOBNAM                 9     18                                                             
     d  USRNAM                19     28                                                             
     d  JOBNBR                29     34                                                             
     d  INTID                 35     50                                                             
     d  JOBSTS                51     60                                                             
     d  JOBTYP                61     61                                                             
     d  SUBTYP                62     62                                                             
     d  RESRV                 63     64                                                             
     d  SYSLIB                       10i 0                                                          
     d  PRDLIB                       10i 0                                                          
     d  CURLIB                       10i 0                                                          
     d  USRLIB                       10i 0                                                          
     d  LIB1                  81    336                                                             
                                                                                                    
                                                                                                    
     d ds_Error        Ds            15                                                             
     d  BytesProvided                10I 0 inz(%size(ds_Error))                                     
     d  BytesAvail                   10I 0                                                          
     d  ErrorId                       7                                                             
                                                                                                    
      //                                                                                            
      // holds all the user libraries... this will be used to reset libl after                      
      //                                 processing for another company                             
                                                                                                    
     d MyLibraries     ds          2500    qualified                                                
     d  Library                      11    dim(200) overlay(MyLibraries:1)                          
                                                                                                    
      /Free                                                                                         
                                                                                                    
         //------------------------------------------------                                         
         //       C a l c u l a t i o n  S p e c s                                                  
         //------------------------------------------------                                         
                                                                                                    
            $getLibList(ds_job10700:%Size(ds_job10700):'JOBI0700'                                   
                       :'*' : *Blanks : ds_Error);                                                  
                                                                                                    
            SkipLibs  = (SysLib  + PrdLib)*11;                                                      
            Current   = %trim(%subst(LIB1:SkipLibs + 1:10));                                        
                                                                                                    
            if curlib = *zeros;                                                                     
             current = '*NONE';                                                                     
             Mylibraries = %trim(%subst(LIB1:SkipLibs + 1));                                        
            else;                                                                                   
             Mylibraries = %trim(%subst(LIB1:SkipLibs + 11));                                       
            endif;                                                                                  
                                                                                                    
                                                                                                    
            for count = 1 to %elem(MyLibraries.library);                                            
             if MyLibraries.library(count) <> *blanks;                                              
              dsply MyLibraries.Library(count) ' ';                                                 
             else;                                                                                  
              Leave;        // thats right a Leave!                                                 
             endif;                                                                                 
            endfor;                                                                                 
                                                                                                    
            *inlr = *on;                                                                            
      /end-free                                                                                     
       //--------------------------------------------------------                                   

QtmmSendMail - Send HTML email


Sample from Jamie Flanary posted at 2011-12-18 19:13:37

      * Sample of sending a HTML-only (using MIME) e-mail message                                   
      *                                                                                             
      * To compile:                                                                                 
      *    Before compiling, change the "from" and "to" e-mail address                              
      *    info at the top of the source member!                                                    
      *                                                                                             
      *    CRTRPGMOD MODULE(QTEMP/HTMLONLY) +                                                       
      *              SRCFILE(xxx/QRPGLESRC) +                                                       
      *              DBGVIEW(*LIST)                                                                 
      *                                                                                             
      *                                                                                             
      *    CRTPGM PGM(&mylib/HTMLmail) +                                                            
      *           MODULE(&mylib/HTMLmail) +                                                         
      *           BNDSRVPGM(QTCP/QTMMSNDM)                                                          
      *                                                                                             
      *                                                                                             
     H BNDDIR('QC2LE') OPTION(*SRCSTMT:*NOSHOWCPY)                                                  
     fworkfile  if   e           k disk                                                             
      *--------------------------------------------------------------------                         
      * Remove Link to File.  (Deletes Directory Entry for File, and if                             
      *    this was the last link to the file data, the file itself is                              
      *    also deleted)                                                                            
      *                                                                                             
      * int unlink(const char *path)                                                                
      *--------------------------------------------------------------------                         
     D unlink          PR            10I 0 ExtProc('unlink')                                        
     D   path                          *   Value options(*string)                                   
      *--------------------------------------------------------------------                         
      * Write to a file                                                                             
      *                                                                                             
      * ssize_t write(int fildes, const void *buf, size_t bytes)                                    
      *--------------------------------------------------------------------                         
     D write           PR            10I 0 ExtProc('write')                                         
     D  fildes                       10i 0 value                                                    
     D  buf                            *   value                                                    
     D  bytes                        10U 0 value                                                    
      *--------------------------------------------------------------------                         
      * Open a File                                                                                 
      *                                                                                             
      * int open(const char *path, int oflag, . . .);                                               
      *--------------------------------------------------------------------                         
     D open            PR            10I 0 ExtProc('open')                                          
     D  path                           *   value options(*string)                                   
     D  openflags                    10I 0 value                                                    
     D  mode                         10U 0 value options(*nopass)                                   
     D  ccsid                        10U 0 value options(*nopass)                                   
     D/if defined(*V5R2M0)                                                                          
     D  txtcreatid                   10U 0 value options(*nopass)                                   
     D/endif                                                                                        
      *--------------------------------------------------------------------                         
      * Close a file                                                                                
      *                                                                                             
      * int close(int fildes)                                                                       
      *                                                                                             
      * Note:  Because the same close() API is used for IFS, sockets,                               
      *        and pipes, it's conditionally defined here.  If it's                                 
      *        done the same in the sockets & pipe /copy members,                                   
      *        there will be no conflict.                                                           
      *--------------------------------------------------------------------                         
     D close           PR            10I 0 ExtProc('close')                                         
     D  fildes                       10I 0 value                                                    
      *--------------------------------------------------------------------                         
     d QtmmSendMail    PR                  ExtProc('QtmmSendMail')                                  
     d   FileName                   255A   const options(*varsize)                                  
     d   FileNameLen                 10I 0 const                                                    
     d   MsgFrom                    256A   const options(*varsize)                                  
     d   MsgFromLen                  10I 0 const                                                    
     d   RecipBuf                          likeds(ADDTO0100)                                        
     d                                     dim(32767)                                               
     d                                     options(*varsize)                                        
     d   NumRecips                   10I 0 const                                                    
     d   ErrorCode                 8000A   options(*varsize)                                        
     d ADDTO0100       ds                  qualified                                                
     d                                     based(Template)                                          
     d   NextOffset                  10I 0                                                          
     d   AddrLen                     10I 0                                                          
     d   AddrFormat                   8A                                                            
     d   DistType                    10I 0                                                          
     d   Reserved                    10I 0                                                          
     d   SmtpAddr                   256A                                                            
     d ADDR_NORMAL     C                   CONST(0)                                                 
     d ADDR_CC         C                   CONST(1)                                                 
     d ADDR_BCC        C                   CONST(2)                                                 
                                                                                                    
     D tmpnam          PR              *   extproc('_C_IFS_tmpnam')                                 
     D   string                      39A   options(*omit)                                           
     D MailDate        PR            31A                                                            
     D CRLF            c                   x'0d25'                                                  
     D filename        s             50A   varying                                                  
     D fd              s             10I 0                                                          
     D header          s           2000A   varying                                                  
     D body            s          32767A   varying                                                  
     D fromName        s            100A   varying                                                  
     D fromAddr        s            300A   varying                                                  
     D M_RDWR          C                   const(438)                                               
      **********************************************************************                        
      *  Flags for use in open()                                                                    
      *                                                                                             
      * More than one can be used -- add them together.                                             
      **********************************************************************                        
     D O_RDONLY        c                   1                                                        
     D O_WRONLY        c                   2                                                        
     D O_RDWR          c                   4                                                        
     D O_CREAT         c                   8                                                        
     D O_EXCL          c                   16                                                       
     D O_CCSID         c                   32                                                       
     D O_TEXTDATA      c                   16777216                                                 
     D O_CODEPAGE      C                   8388608                                                  
     D O_TEXT_CREAT    C                   33554432                                                 
     D O_INHERITMODE   C                   134217728                                                
     D O_LARGEFILE     C                   536870912                                                
     D toName          s            100A   varying                                                  
     D toAddr          s            300A   varying                                                  
     D subject         s             80A   varying                                                  
     D recip           ds                  likeds(ADDTO0100)                                        
     D                                     dim(1)                                                   
     D NullError       ds                                                                           
     D   BytesProv                   10I 0 inz(0)                                                   
     D   BytesAvail                  10I 0 inz(0)                                                   
     D wait            s              1A                                                            
                                                                                                    
      /free                                                                                         
                                                                                                    
          fromName = 'SomeOne';                                                                     
          fromAddr = 'jimmyoctane@code400.com';                                                     
          toName   = 'testname';                                                                    
          toAddr   = 'jflanary@somedomain.com';                                             
          subject  = 'Test this';                                                                   
                                                                                                    
          // ------------------------------------------                                             
          // create a temporary file in the IFS.                                                    
          // mark that file as ccsid 819 (ISO 8859-1 ASCII)                                         
          // ------------------------------------------                                             
          filename = %str(tmpnam(*omit));                                                           
          unlink(filename);                                                                         
          fd = open( filename                                                                       
                   : O_CREAT+O_EXCL+O_WRONLY+O_CCSID                                                
                   : M_RDWR                                                                         
                   : 819 );                                                                         
          if (fd = -1);                                                                             
           //*ERROR                                                                                 
          endif;                                                                                    
          // ------------------------------------------                                             
          // close file & reopen in text mode so that                                               
          // data will be automatically translated                                                  
          // ------------------------------------------                                             
          callp close(fd);                                                                          
          fd = open( filename : O_WRONLY + O_TEXTDATA );                                            
          if (fd = -1);                                                                             
           //*ERROR                                                                                 
          endif;                                                                                    
          // ------------------------------------------                                             
          //  build an e-mail header in a variable                                                  
          // ------------------------------------------                                             
          header =                                                                                  
           'From: ' + fromName + ' <' + fromAddr + '>' + CRLF                                       
          +'To: '   + toName   + ' <' + toAddr   + '>' + CRLF                                       
          +'Date: ' + maildate() + CRLF                                                             
          +'Subject: ' + subject + CRLF                                                             
          +'MIME-Version: 1.0' + CRLF                                                               
          +'Content-Type: text/html' + CRLF                                                         
          + CRLF;                                                                                   
          // ------------------------------------------                                             
          //  put the message text into a variable                                                  
          // ------------------------------------------                                             
          body =                                                                                    
           '' + CRLF                                                                          
          +''                        
          + CRLF                                                                                    
          + ''                                 
          + CRLF                                                                                    
          +'' + CRLF                                                                          
          +'' + CRLF                                                                        
          +''  + CRLF                                                                        
          +''   + CRLF                                                                        
          +'

Table: WorkFILE

' + CRLF +'Jimmy Octane

' + CRLF +'' + CRLF +'
    ' + CRLF; read workfile; dow not%eof(workfile); body = %trim(body) + '
  • ' + ' ' + %trim(claim) + ' : ' + %editc(amount:'J') + '

    ' + CRLF; read workfile; enddo; body = %trim(body) +'
' + CRLF + ' Comments' +'' + CRLF +'' + CRLF; // ------------------------------------------ // write the data to the IFS file // (since the file is in text mode, it'll // automatically be translated to ASCII ) // ------------------------------------------ callp write(fd: %addr(header)+2: %len(header)); callp write(fd: %addr(body)+2: %len(body)); callp close(fd); // ------------------------------------------ // Use the QtmmSendMail() API to send the // IFS file via SMTP // ------------------------------------------ recip(1).NextOffset = %size(ADDTO0100); recip(1).AddrFormat = 'ADDR0100'; recip(1).DistType = ADDR_NORMAL; recip(1).Reserved = 0; recip(1).SmtpAddr = toAddr; recip(1).AddrLen = %len(toAddr); QtmmSendMail( FileName : %len(FileName) : fromAddr : %len(fromAddr) : recip : %elem(recip) : NullError ); *inlr = *on; /end-free *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * MailDate(): Returns the current date, formatted for use * in an e-mail message. * * For example: 'Sat, 23 Oct 2004 14:42:06 -0500' *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P MailDate B D MailDate PI 31A D CEELOCT PR opdesc D Lilian 10I 0 D Seconds 8F D Gregorian 23A D fc 12A options(*omit) D CEEUTCO PR opdesc D Hours 10I 0 D Minutes 10I 0 D Seconds 8F D fc 12A options(*omit) D CEEDATM PR opdesc D input_secs 8F const D date_format 80A const options(*varsize) D char_date 80A options(*varsize) D feedback 12A options(*omit) D rfc2822 c 'Www, DD Mmm YYYY HH:MI:SS' D junk1 s 8F D junk2 s 10I 0 D junk3 s 23A D hours s 10I 0 D mins s 10I 0 D tz_hours s 2P 0 D tz_mins s 2P 0 D tz s 5A varying D CurTime s 8F D Temp s 25A /free // // Calculate the Timezone in format '+0000', for example // CST should show up as '-0600' CEEUTCO(hours: mins: junk1: *omit); tz_hours = %abs(hours); tz_mins = mins; if (hours < 0); tz = '-'; else; tz = '+'; endif; tz += %editc(tz_hours:'X') + %editc(tz_mins:'X'); // // Get the current time and convert it to the format // specified for e-mail in RFC 2822 // CEELOCT(junk2: CurTime: junk3: *omit); CEEDATM(CurTime: rfc2822: Temp: *omit); return Temp + ' ' + tz; /end-free P E 

QUSLJOB - program searched thru WRKACTJOB for message in *MSGW. When it finds one it emails out the error.


Sample from Jamie Flanary posted at 2011-12-18 19:06:47

     H Option( *SrcStmt: *NoDebugIo )  BndDir( 'QC2LE' ) DFTACTGRP(*No)                             
     ‚**********************************************************************                        
     ‚* Project ID     Date  Pgmr ID  Rev  Description                                              
     ‚*                                                                                             
     ‚*            11/22/11  JJF       00  program written                                          
     ‚*              ** monitors for error in wrkactjob                                             
     ‚*                                                                                             
     ‚**********************************************************************                        
      *                                                                                             
      * CrtUsrSpc: Create User Space for OS/400 API's                                               
      *                                                                                             
     d QUSCRTUS        pr                  extpgm('QUSCRTUS')                                       
     d   UsrSpc                      20A   const                                                    
     d   ExtAttr                     10A   const                                                    
     d   InitialSize                 10I 0 const                                                    
     d   InitialVal                   1A   const                                                    
     d   PublicAuth                  10A   const                                                    
     d   Text                        50A   const                                                    
     d   Replace                     10A   const                                                    
     d   ErrorCode                32766A   options(*nopass: *varsize)                               
      *                                                                                             
      * --- Prototype for API Retrive User Space                                                    
      *                                                                                             
     d QUSRTVUS        pr                  extpgm( 'QUSRTVUS' )                                     
     d   QRtvUserSpace...                                                                           
     d                               20                                                             
     d   QRtvStartingPosition...                                                                    
     d                               10i 0                                                          
     d   QRtvLengthOfData...                                                                        
     d                               10i 0                                                          
     d   QRtvReceiverVariable...                                                                    
     d                            32048                                                             
     d   QRtvError...                                                                               
     d                              256                                                             
      * --- Prototype for API Retrive List Job                                                      
      *                                                                                             
     d QUSLJOB         pr                  extpgm( 'QUSLJOB' )                                      
     d   QJobUserSpace...                                                                           
     d                               20                                                             
     d   QJobFormatName...                                                                          
     d                                8                                                             
     d   QJobJobName...                                                                             
     d                               26                                                             
     d   QFldStatus...                                                                              
     d                               10                                                             
     d   QFldError...                                                                               
     d                              256                                                             
     d   QJobType...                                                                                
     d                                1                                                             
     d   QNbrFldRtn...                                                                              
     d                               10i 0                                                          
     d   QKeyFldRtn...                                                                              
     d                               10i 0 dim( 100 )                                               
      *                                                                                             
     d qcmdexc         pr                  extpgm( 'QCMDEXC' )                                      
     d   os400_cmd                 2000A   options( *varsize ) const                                
     d   cmdlength                   15P 5                     const                                
      *                                                                                             
      ******************************************************************                            
     dQUSA0100         DS                                                                           
     d QUsrSpcOffset...                                                                             
     d                         1      4B 0                                                          
     d QUsrSpcEntries...                                                                            
     d                         9     12B 0                                                          
     d QUsrSpcEntrieSize...                                                                         
     d                        13     16B 0                                                          
                                                                                                    
     dLJOBINPUT        ds                           qualified                                       
     d  JobName                      10                                                             
     d  UserName                     10                                                             
     d  JobNumber                     6                                                             
     d  Status                       10                                                             
     d  UserSpace                    10                                                             
     d  UserSpaceLibrary...                                                                         
     d                               10                                                             
     d  Format                        8                                                             
     d  JobType                       1                                                             
     d  Reserved01                    3                                                             
     d  Reserved02                   10i 0                                                          
      *                                                                                             
     dLJOB200          ds                           qualified                                       
     d  JobName                      10                                                             
     d  UserName                     10                                                             
     d  JobNumber                     6                                                             
     d  InternalJobId                16                                                             
     d  Status                       10                                                             
     d  JobType                       1                                                             
     d  JobSubType                    1                                                             
     d  Reserved01                    2                                                             
     d  JobInfoStatus                 1                                                             
     d  Reserved02                    3                                                             
     d  NumberOfFieldsReturned...                                                                   
     d                               10i 0                                                          
     d  ReturnedData               1000                                                             
      *                                                                                             
     dLJOB200KEY       ds                           qualified                                       
     d  KeyNumber01...                                                                              
     d                               10i 0                                                          
     d  NumberOfKeys...                                                                             
     d                               10i 0                                                          
      *                                                                                             
     dLJOBKEYINFO      ds                           qualified                                       
     d  LengthOfInformation...                                                                      
     d                               10i 0                                                          
     d  KeyField                     10i 0                                                          
     d  TypeOfData                    1                                                             
     d  Reserved01                    3                                                             
     d  LengthOfData                 10i 0                                                          
     d  KeyData                    1000                                                             
      *                                                                                             
      *  APIErrDef     Standard API error handling structure.                  *                    
      *                                                                                             
     dQUSEC            DS                                                                           
     d  ErrorBytesProvided...                                                                       
     d                               10i 0                                                          
     d  ErrorBytesAvailble...                                                                       
     d                               10i 0                                                          
     d  ErrorExceptionId...                                                                         
     d                                7                                                             
     d  ErrorReserved                 1                                                             
     d                                                                                              
      *                                                                                             
     dAPIError         DS                                                                           
     d APIErrorProvied...                                                                           
     d                                     LIKE( ErrorBytesProvided )                               
     d                                     INZ( %LEN( APIError ) )                                  
     d APIErrorAvailble...                                                                          
     d                                     LIKE( ErrorBytesAvailble )                               
     d APIErrorMessageID...                                                                         
     d                                     LIKE( ErrorExceptionId )                                 
     d APIErrorReserved...                                                                          
     d                                     LIKE( ErrorReserved )                                    
     d APIErrorInformation...                                                                       
     d                              240A                                                            
      *-----------------------------------------------------------------                            
      * program status dataarea                                                                     
      *-----------------------------------------------------------------                            
     d PgmSts         SDS                                                                           
     d   P1User              254    263                                                             
     d   W1Program       *PROC                                                                      
      *--------------------------------------------------------------*                              
      *                                                                                             
      * Defined variables                                                                           
      *                                                                                             
     d dlr             s              9  0                                                          
     d emailaddress    s             24    inz('alert@abcdomain.com')                               
     d foundit         s              4  0                                                          
     d jobinerror      s               n                                                            
     d KeepLooping     s               n   inz('1')                                                 
     d sendmessage     s               n   inz('1')                                                 
     d size            s             10I 0                                                          
     d SleepMinutes    s             10i 0 inz(2)                                                   
     d SleepSeconds    s             10i 0 inz(25)                                                  
     d UsrSpcName      s             20    inz( 'DSPJOB    QTEMP' )                                 
                                                                                                    
      *--------------------------------------------------------------*                              
      * work fields                                                  *                              
      *--------------------------------------------------------------*                              
     d Variables       ds                                                                           
     d   Q                            1    inz('''')                                                
     d   Count                       15  0 inz                                                      
     d   KeyCount                    15  0 inz                                                      
     d   EndPos                      15  0 inz                                                      
     d   JobbStatus                   4    inz                                                      
     d   Subsystem                   20    inz                                                      
     d   ReturnCode                   1    inz                                                      
     d   FormatName                   8    inz                                                      
     d   QualifedJobName...                                                                         
     d                               26    inz                                                      
     d   JobStatus                   10    inz                                                      
     d   JobType                      1    inz                                                      
     d   NbrOfFldRtn                 10i 0 inz                                                      
     d   KeyFldRtn                   10i 0 inz dim(100)                                             
     d   StartingPosition...                                                                        
     d                               10i 0 inz                                                      
     d   LengthOfData                10i 0 inz                                                      
     d   KeyStartingPosition...                                                                     
     d                               10i 0 inz                                                      
     d   KeyLengthOfData...                                                                         
     d                               10i 0 inz                                                      
     d   ReceiverVariable...                                                                        
     d                            32048                                                             
     d   OS400_Cmd                 2000    inz( ' '  )                                              
     d   CmdLength                   15P 5 inz( %size( OS400_Cmd ) )                                
     d   True                         1    inz( *on  )                                              
     d   False                        1    inz( *off )                                              
      *------------------------------------------------------------                                 
      * Delay - sleep function                                                                      
      *------------------------------------------------------------                                 
     d sleep           pr            10i 0 ExtProc( 'sleep' )                                       
     d  seconds                      10u 0 Value                                                    
      *                                                                                             
     d DSLastRun       ds                           Qualified                                       
     d  LastRunArray                       Dim(50)                                                  
     d   Jobname                     10A   Overlay(LastRunArray)                                    
     d   Stamp                         Z   Overlay(LastRunArray:*Next)                              
      /free                                                                                         
                                                                                                    
            // program will loop until outside force                                                
            // stops it.                                                                            
           dow KeepLooping;                                                                         
                                                                                                    
            size = 10000;                                                                           
            QUSCRTUS(UsrSpcName: 'USRSPC': size: x'00': '*ALL':                                     
            'Temp User Space for  QUSLJOB API':  '*YES': APIError);                                 
                                                                                                    
            reset JobInError;                                                                       
            exsr CheckStatusOfJob;                                                                  
                                                                                                    
            // Delay job for a number of seconds then start                                         
            // the process all over again.                                                          
            sleep(SleepSeconds);                                                                    
                                                                                                    
           enddo;                                                                                   
                                                                                                    
            *inlr = *on;                                                                            
                                                                                                    
           // *************************************************************                         
           // check status of an job                                                                
           // -------------------------------------------------------------                         
                                                                                                    
             begsr CheckStatusOfJob;                                                                
                                                                                                    
           // run API to fill user space with information about all iSeries job                     
              FormatName = 'JOBL0200';                                                              
              QualifedJobName = '*ALL      ' + '*ALL      ' + '*ALL  ';                             
              JobStatus = '*ACTIVE';                                                                
              JobType = '*';                                                                        
              NbrOfFldRtn = 2;                                                                      
              KeyFldRtn( 1 ) = 0101;                                                                
              KeyFldRtn( 2 ) = 1906;                                                                
              QUSLJOB( UsrSpcName : FormatName  : QualifedJobName :                                 
                       JobStatus  : APIError    :                                                   
                       JobType    : NbrOfFldRtn : KeyFldRtn         );                              
           // if error message from the retrieve job API then dump program                          
              if APIErrorMessageID <> ' ';                                                          
               dump;                                                                                
               ReturnCode = True;                                                                   
               leavesr;                                                                             
              endif;                                                                                
           // run API to get user space attribute                                                   
              StartingPosition = 125;                                                               
              LengthOfData = 16;                                                                    
              callp QUSRTVUS( UsrSpcName   : StartingPosition  :                                    
              LengthOfData : ReceiverVariable  :                                                    
              APIError                           );                                                 
              QUSA0100 = ReceiverVariable;                                                          
           //  error message from the retrieve user space API then dump program                     
              if APIErrorMessageID <> ' ';                                                          
               dump;                                                                                
               ReturnCode = True;                                                                   
               leavesr;                                                                             
              endif;                                                                                
                                                                                                    
           // preperation to read from user space                                                   
              StartingPosition = QUsrSpcOffset + 1;                                                 
              LengthOfData = QUsrSpcEntrieSize;                                                     
           // read from user space                                                                  
              for count = 1 to QUsrSpcEntries;                                                      
               QUSRTVUS( UsrSpcName   : StartingPosition  :                                         
                         LengthOfData : ReceiverVariable  :                                         
                         APIError                           );                                      
                                                                                                    
               LJOB200 = ReceiverVariable;                                                          
               if APIErrorMessageID <> ' ';                                                         
                dump;                                                                               
                ReturnCode = True;                                                                  
                leavesr;                                                                            
               endif;                                                                               
                                                                                                    
           // check status of job                                                                   
               JobbStatus = ' ';                                                                    
               Subsystem = ' ';                                                                     
               LJobKeyInfo = LJob200.ReturnedData;                                                  
               KeyStartingPosition = 1;                                                             
               KeyLengthOfData = LJobKeyInfo.LengthOfInformation;                                   
                                                                                                    
               for keycount = 1 to LJob200.NumberOfFieldsReturned;                                  
                LJobKeyInfo = %subst( LJob200.ReturnedData :                                        
                                      KeyStartingPosition :                                         
                                      KeyLengthOfData );                                            
                                                                                                    
                KeyLengthOfData = LJobKeyInfo.LengthOfInformation;                                  
                                                                                                    
                LJobKeyInfo = %subst( LJob200.ReturnedData :                                        
                                       KeyStartingPosition :                                        
                                       KeyLengthOfData );                                           
                Endpos = LJobKeyInfo.LengthOfData;                                                  
                                                                                                    
                if  LJobKeyInfo.KeyField = 0101;                                                    
                 JobbStatus = %subst( LJobKeyInfo.KeyData : 1 :  Endpos );                          
                elseif LJobKeyInfo.KeyField = 1906;                                                 
                 Subsystem = %subst( LJobKeyInfo.KeyData : 1 : Endpos );                            
                endif;                                                                              
                                                                                                    
                KeyStartingPosition = KeyStartingPosition + KeyLengthOfData;                        
               endfor;                                                                              
                                                                                                    
               //only want to send a message ever ???? minutes                                      
               //this code will help do that                                                        
                                                                                                    
               reset sendmessage;                                                                   
                                                                                                    
               if Jobbstatus = 'MSGW' and Ljob200.Jobname <> 'EDH_JRNCLN';                          
                Foundit = %lookup(LJob200.JobName :DsLastRun.Jobname);                              
                if Foundit > *zeros;                                                                
                 if %diff(%timestamp():DsLastRun.Stamp(Foundit):*minutes) <                         
                    sleepMinutes;                                                                   
                  SendMessage = *off;                                                               
                  JobInError = *on;                                                                 
                 else;                                                                              
                  DsLastRun.Stamp(Foundit) =  %timestamp();                                         
                 endif;                                                                             
                else;                                                                               
                 dlr +=1;                                                                           
                 DsLastRun.Jobname(dlr) =  LJob200.JobName;                                         
                 DsLastRun.Stamp(dlr) =  %timestamp();                                              
                 JobInError = *on;                                                                  
                endif;                                                                              
                                                                                                    
                if SendMessage = *on;                                                               
                 Subsystem = %trim( %subst( Subsystem : 11 : 10 ) ) + '/' +                         
                 %trim( %subst( Subsystem :  1 : 10 ) );                                            
                 os400_cmd = 'snddst type(*lmsg) ' +                                                
                             'tointnet((' + Q + %trim(EmailAddress) +                               
                              Q + ')) dstd(' + Q    +                                               
                              'Job  is in  *MSGW'   +                                               
                              Q + ') longmsg(' + Q  +                                               
                              'Job (' +                                                             
                              %trim( LJob200.JobName ) + '/' +                                      
                              %trim( LJob200.UserName ) + '/' +                                     
                              %trim( LJob200.JobNumber ) +                                          
                              ') subsystem ' + %trim( Subsystem ) +                                 
                              ' in status *MSGW' +                                                  
                              Q + ')';                                                              
                 monitor;                                                                           
                  qcmdexc ( os400_cmd : %size ( os400_cmd ) );                                      
                 on-error;                                                                          
                  dump;                                                                             
                 endmon;                                                                            
                endif;                                                                              
                                                                                                    
               endif;                                                                               
                                                                                                    
               StartingPosition = StartingPosition + LengthOfData;                                  
              endfor;                                                                               
                                                                                                    
             endsr;                                                                                 
      /end-free                                                                                     

QSYGETPH - Validate password


Sample from Jamie Flanary posted at 2011-12-10 16:29:12

      *this api validates an as400 username and password:
     DWkUser           S             10A   inz('FLANARY')
     DWKPassword       S             10A   inz('HOGWASH')
     DProfileHandle    S             12A
     DPassWordLength   S             10i 0 inz(10)
     DCCSID            S             10i 0 inz(37)
     D*
     DQUSEC            DS
     D*                                             Qus EC
     D QUSBPRV                 1      4B 0
     D*                                             Bytes Provided
     D QUSBAVL                 5      8B 0
     D*                                             Bytes Available
     D QUSEI                   9     15
     D*                                             Exception Id
     D QUSERVED               16     16
     D*                                             Reserved
     D ERRC0100               17    274    Varying

     d error           S               n

     C*
     C                   Call      'QSYGETPH'
     C                   Parm                    WKUser
     C                   Parm                    WKPassword
     C                   Parm                    ProfileHandle
     C                   Parm                    QUSEC
     C                   Parm                    PasswordLength
     C                   Parm                    CCSID
     C*
     C                   If        QUSBAVL > 0
     C                   Eval      Error = *ON
     C                   Endif
     C*
     c                   eval      *inlr = *on
      

QSPRJOBQ - Run through all jobqueues checking to see number of jobs in each.


Sample from Jamie Flanary posted at 2011-12-10 15:16:37

      *===================================================
      * PROGRAM -
      * PURPOSE -
      * WRITTEN -
      * AUTHOR  -
      *
      * PROGRAM DESCRIPTION
      *
      *
      *
      * INPUT PARAMETERS
      *   Description        Type  Size    How Used
      *   -----------        ----  ----    --------
      *
      * INDICATOR USAGE
      *
      *===================================================
      *
      * Program Info
      *
     d                SDS
     d  @PGM                   1     10
     d  @PARMS                37     39  0
     d  @JOB                 244    253
     d  @USER                254    263
     d  @JOB#                264    269  0
      *
      *  Field Definitions.
      *
     d AllText         s             10    Inz('*ALL')
     d bOvr            s              1a   inz('0')
     d CmdString       s            256
     d CmdLength       s             15  5
     d Count           s              4  0
     d CRLF            c                   CONST(X'0d25')
     d CYMD            s              7  0
     d emailaddress    s             50    inz('helpdesk@xxxxxxxxx.com')
     d Fmt             s              8a   inz('MBRD0200')
     d fnd             s              4  0
     d Format          s              8
     d GenLen          s              8
     d heldjobq        s             10    dim(100)
     d heldjobqst      s               z   dim(100)
     d hj#             s              3  0
     d Howmany         s              8  0
     d InLibrary       s             10
     d InObject        s             10
     d InType          s             10
     d ISoDate         s               D
     d jj#             s              3  0
     d jobqlibrary     s             20
     d jobqjobs        s             10    dim(100)
     d jobqjobsst      s               z   dim(100)
     d Low             c                   CONST('abcdefghijklmnopqrstuvwxyz')
     d memberName      s             10    inz('*FIRST')
     d message         s            512    varying
     d ObjectLib       s             20
     d OS400_Cmd       s           2000    inz
     d OutNumber       s             10
     d P1deleted       s              8  0
     d P1created       s              8  0
     d P1changed       s              8  0
     d P1desc          s             50
     d P1Records       s              8  0
     d   Q             s              1    inz('''')
     d SpaceVal        s              1    inz(*BLANKS)
     d SpaceAuth       s             10    inz('*CHANGE')
     d SpaceText       s             50    inz(*BLANKS)
     d SpaceRepl       s             10    inz('*YES')
     d SpaceAttr       s             10    inz(*BLANKS)
     d subject         s             44    varying
     d subsystem       s             10    dim(999)
     d subsystemStamp  s               z   dim(999)
     d sb#             s              3  0
     d Up              c                   CONST('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
     d USA             s              8  0
     d UserSpaceOut    s             20
À     *                                                                                            Ä
À     * GenHdr                                                                                     Ä
À     *                                                                                            Ä
     d GenHdr          ds                  inz
     d  OffSet                 1      4B 0
     d  NumEnt                 9     12B 0
     d  Lstsiz                13     16B 0
À     *                                                                                            Ä
À     *  Data structures                                                                           Ä
À     *                                                                                            Ä
     d GENDS           ds
     d  OffsetHdr              1      4B 0
     d  NbrInList              9     12B 0
     d  SizeEntry             13     16B 0
      *
      *
     d HeaderDs        ds
     d  OutFileNam             1     10
     d  OutLibName            11     20
     d  OutType               21     25
     d  OutFormat             31     40
     d  RecordLen                    10i 0
      *
      * API Error Data Structure
      *
     d ErrorDs         DS                  INZ
     d  BytesPrv               1      4B 0
     d  BytesAvl               5      8B 0
     d  MessageId              9     15
     d  ERR###                16     16
     d  MessageDta            17    116
      *
      * Create userspace datastructure
      *
     d                 DS
     d  StartPosit             1      4B 0
     d  StartLen               5      8B 0
     d  SpaceLen               9     12B 0
     d  ReceiveLen            13     16B 0
     d  MessageKey            17     20B 0
     d  MsgDtaLen             21     24B 0
     d  MsgQueNbr             25     28B 0
      *
      * Date structure for retriving userspace info
      *
     d InputDs         DS
     d  UserSpace              1     20
     d  SpaceName              1     10
     d  SpaceLib              11     20
     d  InpFileLib            29     48
     d  InpFFilNam            29     38
     d  InpFFilLib            39     48
     d  InpRcdFmt             49     58
      *
     d ObjectDs        ds
     d  Object                       10
     d  Library                      10
     d  ObjectType                   10
     d  InfoStatus                    1
     d  ExtObjAttrib                 10
     d  Description                  50

     d qcmdexc         pr                  extpgm( 'QCMDEXC' )
     d   os400_cmd                 2000A   options( *varsize ) const
     d   cmdlength                   15P 5                     const

     d $getjobq        pr                  extpgm('QSPRJOBQ')
     d  RECIEVER                    144A
     d  RCVRLEN                      10I 0 const
     d  FORMAT                        8A   const
     d  JOBQ                         20A   conST
     d  ERROR                       116A
      *
     DQSPQ020000       DS
     D BytesReturned                 10i 0
     D BytesAvailable                10i 0
     D QueueName                     10
     D QueueLib                      10
     D Controlled                    10
     D Authority                     10
     D NumberJobs                    10i 0
     D Status                        10
     D SubsystemName                 10
     D SubsystemLib                  10
     D SBSDescription                50
     D Sequence#                     10i 0
     D MaxActive                     10i 0
     D CurrentActive                 10i 0
     D MaxActiveP1                   10i 0
     D MaxActiveP2                   10i 0
     D MaxActiveP3                   10i 0
     D MaxActiveP4                   10i 0
     D MaxActiveP5                   10i 0
     D MaxActiveP6                   10i 0
     D MaxActiveP7                   10i 0
     D MaxActiveP8                   10i 0
     D MaxActiveP9                   10i 0
     D ActiveJobsP0                  10i 0
     D ActiveJobsP1                  10i 0
     D ActiveJobsP2                  10i 0
     D ActiveJobsP3                  10i 0
     D ActiveJobsP4                  10i 0
     D ActiveJobsP5                  10i 0
     D ActiveJobsP6                  10i 0
     D ActiveJobsP7                  10i 0
     D ActiveJobsP8                  10i 0
     D ActiveJobsP9                  10i 0
     D ReleaseJobs0                  10i 0
     D ReleaseJobs1                  10i 0
     D ReleaseJobs2                  10i 0
     D ReleaseJobs3                  10i 0
     D ReleaseJobs4                  10i 0
     D ReleaseJobs5                  10i 0
     D ReleaseJobs6                  10i 0
     D ReleaseJobs7                  10i 0
     D ReleaseJobs8                  10i 0
     D ReleaseJobs9                  10i 0
     D ScheduledJobs0                10i 0
     D ScheduledJobs1                10i 0
     D ScheduledJobs2                10i 0
     D ScheduledJobs3                10i 0
     D ScheduledJobs4                10i 0
     D ScheduledJobs5                10i 0
     D ScheduledJobs6                10i 0
     D ScheduledJobs7                10i 0
     D ScheduledJobs8                10i 0
     D ScheduledJobs9                10i 0
     D HeldJobs0                     10i 0
     D HeldJobs1                     10i 0
     D HeldJobs2                     10i 0
     D HeldJobs3                     10i 0
     D HeldJobs4                     10i 0
     D HeldJobs5                     10i 0
     D HeldJobs6                     10i 0
     D HeldJobs7                     10i 0
     D HeldJobs8                     10i 0
     D HeldJobs9                     10i 0
      *
     dQUSEC            DS
     d QUSBPRV                 1      4B 0
     d QUSBAVL                 5      8B 0
     d QUSEI                   9     15
     d QUSERVED               16     16

     d QUSED01                      100A
      *
      * Standard API error data structure
      *
     d apierror        ds                  inz
     d  AEBYPR                 1      4B 0
     d  AEBYAV                 5      8B 0
     d  AEEXID                 9     15
     d  AEEXDT                16    116
      *
      *  Create a userspace
      *
     c                   exsr      $QUSCRTUS
      *
      * List all the objects to the user space
      *
     c                   eval      Format = 'OBJL0200'
     c                   eval      objectlib =  InObject  + InLibrary
      *
     c                   call(e)   'QUSLOBJ'
     c                   parm      Userspace     UserSpaceOut
     c                   parm                    Format
     c                   parm                    ObjectLib
     c                   parm                    InType
      *
      * Retrive header entry and process the user space
      *
     c                   eval      StartPosit = 125
     c                   eval      StartLen   = 16
      *
      * Retrive header entry and process the user space
      *
     c                   call      'QUSRTVUS'
     c                   parm      UserSpace     UserSpaceOut
     c                   parm                    StartPosit
     c                   parm                    StartLen
     c                   parm                    GENDS
      *
     c                   eval      StartPosit = OffsetHdr + 1
     c                   eval      StartLen = %size(ObjectDS)
      *
À     *  Do for number of fields                                                                   Ä
      *
     c                   z-add     NbrInList     HowMany
B1   c                   do        NbrInList
      *
      *
     c                   call(e)   'QUSRTVUS'
     c                   parm      UserSpace     UserSpaceOut
     c                   parm                    StartPosit
     c                   parm                    StartLen
     c                   parm                    ObjectDs
      *
      *  Object = the jobq Name - get jobq information
      *
      /Free

        jobqlibrary = Object + 'QGPL';
        $GetJobQ(QSPQ020000:%SIZE(QSPQ020000):'JOBQ0200':
                  jobqlibrary:apierror);

        // send email if any jobq in QGPL is held.
        // wait 15 minutes to send again
        if Status = 'HELD';
         // see if message already sent
         fnd = %lookup(object : heldjobq);

         if fnd = *zeros or %diff(%timestamp():
                            heldjobqst(fnd):*minutes) >= 15;
          if fnd = *zeros;
           hj# +=1;
           heldjobq(hj#) = object;
           heldjobqst(hj#) = %timestamp();
          else;
           heldjobqst(fnd) = %timestamp();
          endif;

          subject = 'JobQ ' + %trim(object) + ' is HELD ' + %char(%time());
          message = 'Please logon to system and release this JobQ' +
                    ' currently there are ' + %char(ReleaseJobs5) +
                    ' job(s) on the queue.';
          exsr $snddst;
         endif;
        endif;


        // send email if more than 5 jobs in jobQ.
        // wait 15 minutes to send again

         // see if message already sent
         fnd = %lookup(object : jobqjobs);
         if releaseJobs5 >= 5;
          if fnd = *zeros or %diff(%timestamp():
                            jobqjobsst(fnd):*minutes) >= 15;
           if fnd = *zeros;
            jj# +=1;
            jobqjobs(jj#) = object;
            jobqjobsst(jj#) = %timestamp();
           else;
            jobqjobsst(fnd) = %timestamp();
           endif;

           subject = 'More than Allowed Jobs in jobq ' +  %trim(object);
           message = 'Please logon to system and check subsystem ' +
                      %trim(SubsystemName) +
                     ' currently there are ' + %char(ReleaseJobs5) +
                     ' job(s) on the queue. ' + CRLF +  %char(%timestamp);
           exsr $snddst;
          endif;
         endif;


      /end-free
      *
     c                   eval      StartPosit = StartPosit + SizeEntry
     c                   enddo
      *
      *  leave open so we can keep track of last email sent
      *
     c                   return
      *===============================================
      * $QUSCRTUS - API to create user space
      *===============================================
     c     $QUSCRTUS     begsr
      *
      * Create a user space named ListObjects in QTEMP.
      *
     c                   Eval      BytesPrv = 116
     c                   movel(p)  'LISTOBJECTS' SpaceName
     c                   movel(p)  'QTEMP'       SpaceLib
      *
      * Create the user space
      *
     c                   call(e)   'QUSCRTUS'
     c                   parm      UserSpace     UserSpaceOut
     c                   parm                    SpaceAttr
     c                   parm      4096          SpaceLen
     c                   parm                    SpaceVal
     c                   parm                    SpaceAuth
     c                   parm                    SpaceText
     c                   parm                    SpaceRepl
     c                   parm                    ErrorDs
      *
     c                   endsr
      /free

        //--------------------------------------------------------
        // $snddst - send email to helpdesk
        //--------------------------------------------------------
             begsr $snddst;

              // Send email to address
              os400_cmd = 'snddst type(*lmsg) ' +
                          'tointnet((' + Q + %trim(EmailAddress) +
                          Q + ')) dstd(' + Q    +
                          %trim(subject) +
                          Q + ') longmsg(' + Q  +
                          %trim(message) +
                          Q + ')';
              qcmdexc ( os400_cmd : %size ( os400_cmd ) );



             endsr;
        //--------------------------------------------------------

      /end-free
      *=================================================
      *    *Inzsr - One time run House keeping subroutine
      *=================================================
     c     *Inzsr        begsr
      *
     c                   eval      InObject = '*ALL'
     c                   eval      InLibrary = 'QGPL'
     c                   eval      InType = '*JOBQ'

     c                   endsr
      *==============================================


Qc3EncryptData - encrypting data using system API


Sample from Jamie Flanary posted at 2011-12-10 11:35:09

     H BNDDIR('QC2LE')
     H DFTACTGRP(*NO)
     H OPTION(*NODEBUGIO:*SRCSTMT)

      *------------------------------------------------
      **  E N T R Y   P A R M S                      **
      *------------------------------------------------

     d encrypt         pr
     d  inmode                        1a
     d  invalue                      30a
     d  inkey                        30a
     d  outvalue                     30a

     d encrypt         pi
     d  inmode                        1a
     d  invalue                      30a
     d  inkey                        30a
     d  outvalue                     30a

     d workmode        s              1a
     d workinvalue     s             30a
     d workinkey       s             30a
     d workoutvalue    s             30a




      *------------------------------------------------
      **  E N C R Y P T   D A T A                    **
      *------------------------------------------------
     D Qc3EncryptData  PR                  ExtProc('Qc3EncryptData')
     D  szClearData               65535A   OPTIONS(*VARSIZE)
     D  nLenClearData                10I 0 Const
     D  clearDataFmt                  8A   Const

     D  AlgoDescript                 64A   Const OPTIONS(*VARSIZE)
     D  szAlgoFormat                  8A   Const

     D  KeyDescriptor               512A   Const OPTIONS(*VARSIZE)
     D  szKeyFormat                   8A   Const

      ** 0=Best choice, 1=Software, 2=Hardware
     D  CryptoService                 1A   Const
      **  Hardware Cryptography device name or *BLANKS
     D  CryptoDevName                10A   Const

     D  szEncryptedData...
     D                            65535A   OPTIONS(*VARSIZE)
     D  nEncryptedDataVarLen...
     D                               10I 0 Const
     D  nEncryptedDataRtnLen...
     D                               10I 0
     D  api_ErrorDS                        LikeDS(API_ErrorDS_T)
     D                                     OPTIONS(*VARSIZE)

      *------------------------------------------------
      **  D E C R Y P T   D A T A                    **
      *------------------------------------------------
     D Qc3DecryptData  PR                  ExtProc('Qc3DecryptData')
     D  szEncData                 65535A   OPTIONS(*VARSIZE)
     D  nLenEncData                  10I 0 Const

     D  AlgoDescript                 64A   Const OPTIONS(*VARSIZE)
     D  szAlgoFormat                  8A   Const

     D  KeyDescriptor               512A   Const OPTIONS(*VARSIZE)
     D  szKeyFormat                   8A   Const

      ** 0=Best choice, 1=Software, 2=Hardware
     D  CryptoService                 1A   Const
      **  Hardware Cryptography device name or *BLANKS
     D  CryptoDevName                10A   Const

     D  szClearData               65535A   OPTIONS(*VARSIZE)
     D  nClearVarLen                 10I 0 Const
     D  nRtnClearLen                 10I 0
     D  api_ErrorDS                        LikeDS(API_ErrorDS_T)
     D                                     OPTIONS(*VARSIZE)
      *------------------------------------------------
      **  Message Digest/Hash
      *------------------------------------------------
     D Qc3CalcHash     PR                  ExtProc('Qc3CalculateHash')
     D  szClearData               65535A   OPTIONS(*VARSIZE)
     D  nLenClearData                10I 0 Const
     D  clearDataFmt                  8A   Const

     D  AlgoDescr                    64A   Const OPTIONS(*VARSIZE)
     D  szAlgoFormat                  8A   Const

      ** 0=Best choice, 1=Software, 2=Hardware
     D  CryptoService                 1A   Const
      **  Hardware Cryptography device name or *BLANKS
     D  CryptoDevName                10A   Const

     D  rtnHash                      64A   OPTIONS(*VARSIZE)
     D  api_ErrorDS                        LikeDS(API_ErrorDS_T)
     D                                     OPTIONS(*VARSIZE)
      *------------------------------------------------
      **  Cryptography API Algorithm ALGD0300 Structure
      *------------------------------------------------
     D ALGD0300_T      DS                  Qualified
     D                                     BASED(DS_TEMPL)
      **  Stream algorithm: 30 = RC4
     D  Algorithm                    10I 0

     D Qc3CreateAlgorithmContext...
     D                 PR                  ExtProc('Qc3CreateAlgorithmContext')
     D  AlgoDescription...
     D                               64A   Const OPTIONS(*VARSIZE)
     D  szAlgoFormat                  8A   Const
     D  contextToken                  8A
     D  api_ErrorDS                        LikeDS(API_ErrorDS_T)
     D                                     OPTIONS(*VARSIZE)
      **  Encryption Data Structures
     D KEYD0100_T      DS                  Qualified
     D                                     BASED(DS_TEMPL)
     D  keyContext                    8A

     D KEYD0200_T      DS                  Qualified
     D                                     BASED(DS_TEMPL)
     D  type                         10I 0
     D  length                       10I 0
     D  format                        1A
     D  value                       256A
      /IF DEFINED(*V5R1M0)
     D API_ErrorDS_T   DS                  Qualified
     D  dsLen                        10I 0 Inz
     D  rtnLen                       10I 0 Inz
     D  cpfMsgID                      7A
     D  apiResv1                      1A   Inz(X'00')
     D  apiExcDta1                   64A
      /ENDIF

      **  New IBM API Error DS
     D XT_api_ErrorEx  DS                  Inz
     D  XT_apiKey                    10I 0
     D  XT_apiDSLen                  10I 0
     D  XT_apiRtnLenEx...
     D                               10I 0
     D  XT_apiMsgIDEx                 7A
     D  XT_apiResvdEx                 1A
     D  XT_apiCCSID                  10I 0
     D  XT_apiOffExc                 10I 0
     D  XT_apiExcLen                 10I 0
     D  XT_apiExcData                64A

     D Qc3DestroyAlgorithmContext...
     D                 PR                  ExtProc('Qc3DestroyAlgorithmContext')
     D  ContextToken                  8A   Const
     D  api_ErrorDS                        LikeDS(API_ErrorDS_T)
     D                                     OPTIONS(*VARSIZE)

     ** API Error Data structure
     D QUSEC_EX        DS                  Qualified
     D                                     Based(TEMPLATE_T)
     D  charKey                      10I 0
     D  nErrorDSLen                  10I 0
     D  nRtnLen                      10I 0
     D  msgid                         7A
     D  Reserved                      1A
     D  CCSID                        10I 0
     D  OffsetExcp                   10I 0
     D  excpLen                      10I 0
     D  excpData                    128A

     D ALGO_DES        C                   Const(20)
     D ALGO_TDES       C                   Const(21)
     D ALGO_AES        C                   Const(22)
     D ALGO_RC4        C                   Const(30)
     D ALGO_RSA_PUB    C                   Const(50)
     D ALGO_RSA_PRIV   C                   Const(51)

     D ANY_CRYPTO_SRV  C                   Const('0')
     D SWF_CRYPTO_SRV  C                   Const('1')
     D HWD_CRYPTO_SRV  C                   Const('2')
     D CRYPTO_SRV      S             10A   Inz(*BLANKS)

      **  Cipher API data structures.
     D myAlgo          DS                  LikeDS(ALGD0300_T)
     D myKey           DS                  LikeDS(KEYD0200_T)
     D apiError        DS                  LikeDS(qusec_ex)

      **  The clear text (data to be encrypted)

      **  The length of the data returned by the APIs
     D nRtnLen         S             10I 0
      **  The encrypted data variable
     D encData         S            500A

      /free

        workinvalue  = invalue;
        workinkey    = inkey;
        workoutvalue = outvalue;


        myAlgo.Algorithm = ALGO_RC4;

        myKey.type   = ALGO_RC4;
        myKey.length = %Len(%TrimR(workinkey));
        myKey.Format = '0';
        myKey.value  = %TrimR(workinkey);
        apiError = *ALLX'00';
        apiError.nErrorDSLen=%size(apiError);



        select;
        when  inmode = 'E';

        Qc3EncryptData(workinvalue:%len(%TrimR(workinvalue)):'DATA0100':
                          myAlgo  : 'ALGD0300' :
                          myKey   : 'KEYD0200' :
                          ANY_CRYPTO_SRV       : CRYPTO_SRV :
                          encData :  %size(encData) : nRtnLen  :
                          apiError );
        outvalue = encData;
        apiError = *ALLX'00';
        apiError.nErrorDSLen=%size(apiError);



        when  inmode = 'D';
        Qc3DecryptData(workinvalue :  %len(%TrimR(workinvalue)) :
                          myAlgo   : 'ALGD0300' :
                          myKey    : 'KEYD0200' :
                          ANY_CRYPTO_SRV        :     CRYPTO_SRV :
                          outvalue :  %size(outvalue) : nRtnLen :
                          apiError );


        endsl;

       *inlr = *on;
      /end-free



QUSROBJD - check to see if object exists.


Sample from Jamie Flanary posted at 2011-12-10 11:06:40

     **-- Header specifications:  --------------------------------------------**                    
     H Option( *SrcStmt )                                                                           
     **-- Api error data structure:  -----------------------------------------**                    
     D ApiError        Ds                                                                           
     D  AeBytPro                     10i 0 Inz( %Size( ApiError ))                                  
     D  AeBytAvl                     10i 0 Inz                                                      
     D  AeMsgId                       7a                                                            
     D                                1a                                                            
     D  AeMsgDta                    128a                                                            
     **-- Object description structure OBJD0400:  ----------------------------**                    
     D ObjDscDs        Ds                  Inz                                                      
     D  ObjDscLen                    10i 0                                                          
     D  ObjDscSiz                    10i 0                                                          
     D  ObjNam                       10                                                             
     D  ObjLib                       10                                                             
     D  ObjTyp                       10                                                             
     D  ObjRtnLib                    10                                                             
     D  ObjAsp                       10i 0                                                          
     D  ObjOwnr                      10                                                             
     D  ObjDmn                        2                                                             
     D  ObjCrtDat                    13                                                             
     D  ObjChgDat                    13                                                             
     D  ObjAtr                       10                                                             
     D  ObjTxt                       50                                                             
     D  ObjSrcFil                    10                                                             
     D  ObjSrcLib                    10                                                             
     D  ObjSrcMbr                    10                                                             
     D  ObjSrcChgDat                 13                                                             
     D  ObjSrcSavDat                 13                                                             
     D  ObjSrcRstDat                 13                                                             
     D  ObjCrtUsr                    10                                                             
     D  ObjCrtSys                     8                                                             
     D  ObjResDat                     7                                                             
     D  ObjSavSiz                    10i 0                                                          
     D  ObjSavSeq                    10i 0                                                          
     D  ObjStg                       10                                                             
     D  ObjSavCmd                    10                                                             
     D  ObjSavVolId                  71                                                             
     D  ObjSavDvc                    10                                                             
     D  ObjSavFil                    10                                                             
     D  ObjSavLib                    10                                                             
     D  ObjSavLbl                    17                                                             
     D  ObjSavLvl                     9                                                             
     D  ObjCompiler                  16                                                             
     D  ObjLvl                        8                                                             
     D  ObjUsrChg                     1                                                             
     D  ObjLicPgm                    16                                                             
     D  ObjPtf                       10                                                             
     D  ObjApar                      10                                                             
      *  start of four                                                                              
     D  ObjUseDat                     7                                                             
     D  ObjUsgInf                     1                                                             
     D  ObjUseDay                    10i 0                                                          
     D  ObjSiz                       10i 0                                                          
     D  ObjSizMlt                    10i 0                                                          
     D  ObjCprSts                     1                                                             
     D  ObjAlwChg                     1                                                             
     D  ObjChgByPgm                   1                                                             
     D  ObjUsrAtr                    10                                                             
     D  ObjOvrflwAsp                  1                                                             
     D  ObjSavActDat                  7                                                             
     D  ObjSavActTim                  6                                                             
     D  ObjAudVal                    10                                                             
     D  ObjPrmGrp                    10                                                             
                                                                                                    
      *                                                                                             
     d RtvObjD         Pr                  ExtPgm( 'QUSROBJD' )                                     
     d  RoRcvVar                  32767a         Options( *VarSize )                                
     d  RoRcvVarLen                  10i 0 Const                                                    
     d  RoFmtNam                      8a   Const                                                    
     d  RoObjNamQ                    20a   Const                                                    
     d  RoObjTyp                     10a   Const                                                    
     d  RoError                   32767a         Options( *VarSize )                                
      *                                                                                             
     **                                                                                             
     **-- Get Web value:  ----------------------------------------------------**                    
     **                                                                                             
     C                   Eval      ObjNam     =  'ARACUST'                                          
     C                   Eval      ObjLib     =  'LBIFIL'                                           
     C                   Eval      ObjTyp     =  '*FILE'                                            
     **                                                                                             
     C                   CallP     RtvObjD( ObjDscDs                                                
     C                                    : %Size( ObjDscDs )                                       
     C                                    : 'OBJD0400'                                              
     C                                    : ObjNam + ObjLib                                         
     C                                    : ObjTyp                                                  
     C                                    : ApiError                                                
     C                                    )                                                         
     **                                                                                             
     C                   If        AeBytAvl   >  *Zero         And                                  
     C                             AeMsgId    =  'CPF9801'                                          
     **-- Object doesn't exist...                                                                   
     C                   EndIf                                                                      
     **                                                                                             
     C                   Return                                                                     
     **                                                                                             

Using QUSLOBJ to list all objects in s library.


Sample from Jamie Flanary posted at 2011-12-10 11:03:07

      *===================================================                                          
                                                                                                    
      * PROGRAM - @@SPACE                                                                           
      * PURPOSE - dump objects (DSPOBJD) to userspace                                               
      * WRITTEN -                                                                                   
      * AUTHOR  - jamie                                                                             
      *                                                                                             
      * PROGRAM DESCRIPTION                                                                         
      *   This program will dump objects into a userspace                                           
      *                                                                                             
      *                                                                                             
      * INPUT PARAMETERS                                                                            
      *   Description        Type  Size    How Used                                                 
      *   -----------        ----  ----    --------                                                 
      *   InLibary           Char  10      Library to search for objects                            
      *   InType             Char  10      Type of objects to dump                                  
      *                                                                                             
      * INDICATOR USAGE                                                                             
      *   03 - Cancel current screen and return to previous screen                                  
      *   30 - SFLCLR                                                                               
      *   31 - SFLDSP                                                                               
      *   32 - SFLDSPCTL                                                                            
      *   33 - SFLEND                                                                               
      *                                                                                             
      *===================================================                                          
      *                                                                                             
      * Program Info                                                                                
      *                                                                                             
     d                SDS                                                                           
     d  @PGM                   1     10                                                             
     d  @PARMS                37     39  0                                                          
     d  @JOB                 244    253                                                             
     d  @USER                254    263                                                             
     d  @JOB#                264    269  0                                                          
      *                                                                                             
      *  Field Definitions.                                                                         
      *                                                                                             
     d AllText         s             10    Inz('*ALL')                                              
     d CmdString       s            256                                                             
     d CmdLength       s             15  5                                                          
     d Count           s              4  0                                                          
     d Format          s              8                                                             
     d GenLen          s              8                                                             
     d InLibrary       s             10                                                             
     d InType          s             10                                                             
     d ObjectLib       s             20                                                             
     d SpaceVal        s              1    inz(*BLANKS)                                             
     d SpaceAuth       s             10    inz('*CHANGE')                                           
     d SpaceText       s             50    inz(*BLANKS)                                             
     d SpaceRepl       s             10    inz('*YES')                                              
     d SpaceAttr       s             10    inz(*BLANKS)                                             
     d UserSpaceOut    s             20                                                             
‚     *                                                                                            €
‚     * GenHdr                                                                                     €
‚     *                                                                                            €
     d GenHdr          ds                  inz                                                      
     d  OffSet                 1      4B 0                                                          
     d  NumEnt                 9     12B 0                                                          
     d  Lstsiz                13     16B 0                                                          
‚     *                                                                                            €
‚     *  Data structures                                                                           €
‚     *                                                                                            €
     d GENDS           ds                                                                           
     d  OffsetHdr              1      4B 0                                                          
     d  NbrInList              9     12B 0                                                          
     d  SizeEntry             13     16B 0                                                          
      *                                                                                             
      *                                                                                             
      *                                                                                             
     d HeaderDs        ds                                                                           
     d  OutFileNam             1     10                                                             
     d  OutLibName            11     20                                                             
     d  OutType               21     25                                                             
     d  OutFormat             31     40                                                             
     d  RecordLen             41     44B 0                                                          
                                                                                                    
      *                                                                                             
      * API Error Data Structure                                                                    
      *                                                                                             
     d ErrorDs         DS                  INZ                                                      
     d  BytesPrv               1      4B 0                                                          
     d  BytesAvl               5      8B 0                                                          
     d  MessageId              9     15                                                             
     d  ERR###                16     16                                                             
     d  MessageDta            17    116                                                             
      *                                                                                             
      * Create userspace datastructure                                                              
      *                                                                                             
     d                 DS                                                                           
     d  StartPosit             1      4B 0                                                          
     d  StartLen               5      8B 0                                                          
     d  SpaceLen               9     12B 0                                                          
     d  ReceiveLen            13     16B 0                                                          
     d  MessageKey            17     20B 0                                                          
     d  MsgDtaLen             21     24B 0                                                          
     d  MsgQueNbr             25     28B 0                                                          
      *                                                                                             
      * Date structure for retriving userspace info                                                 
      *                                                                                             
     d InputDs         DS                                                                           
     d  UserSpace              1     20                                                             
     d  SpaceName              1     10                                                             
     d  SpaceLib              11     20                                                             
     d  InpFileLib            29     48                                                             
     d  InpFFilNam            29     38                                                             
     d  InpFFilLib            39     48                                                             
     d  InpRcdFmt             49     58                                                             
      *                                                                                             
     d ObjectDs        ds                                                                           
     d  Object                       10                                                             
     d  Library                      10                                                             
     d  ObjectType                   10                                                             
     d  InfoStatus                    1                                                             
     d  ExtObjAttrib                 10                                                             
     d  Description                  50                                                             
‚     *                                                                                            €
      *  Create a userspace                                                                         
      *                                                                                             
     c                   exsr      $QUSCRTUS                                                        
      *                             OBJ(*LIBL/*ALL)                                                 
     c                   eval      ObjectLib =  '*LIBL     ' + '*ALL'                               
      *                                                                                             
      * List all the objects to the user space                                                      
      *                                                                                             
     c                   eval      Format = 'OBJL0200'                                              
      *                                                                                             
     c                   call(e)   'QUSLOBJ'                                                        
     c                   parm      Userspace     UserSpaceOut                                       
     c                   parm                    Format                                             
     c                   parm                    ObjectLib                                          
     c                   parm                    InType                                             
      *                                                                                             
      * Retrive header entry and process the user space                                             
      *                                                                                             
     c                   eval      StartPosit = 125                                                 
     c                   eval      StartLen   = 16                                                  
      *                                                                                             
      * Retrive header entry and process the user space                                             
      *                                                                                             
     c                   call      'QUSRTVUS'                                                       
     c                   parm      UserSpace     UserSpaceOut                                       
     c                   parm                    StartPosit                                         
     c                   parm                    StartLen                                           
     c                   parm                    GENDS                                              
      *                                                                                             
     c                   eval      StartPosit = OffsetHdr + 1                                       
     c                   eval      StartLen = %size(ObjectDS)                                       
      *                                                                                             
      *                                                                                             
‚     *  Do for number of fields                                                                   €
      *                                                                                             
B1   c                   do        NbrInList                                                        
      *                                                                                             
     c                   call(e)   'QUSRTVUS'                                                       
     c                   parm      UserSpace     UserSpaceOut                                       
     c                   parm                    StartPosit                                         
     c                   parm                    StartLen                                           
     c                   parm                    ObjectDs                                           
      *                                                                                             
     c                   eval      StartPosit = StartPosit + SizeEntry                              
     c                   enddo                                                                      
      *                                                                                             
     c                   eval      *Inlr = *On                                                      
      *===============================================                                              
      * $QUSCRTUS - API to create user space                                                        
      *===============================================                                              
     c     $QUSCRTUS     begsr                                                                      
      *                                                                                             
      * Create a user space named ListObjects in QTEMP.                                             
      *                                                                                             
     c                   Eval      BytesPrv = 116                                                   
     c                   movel(p)  'LISTOBJECTS' SpaceName                                          
     c                   movel(p)  'QTEMP'       SpaceLib                                           
      *                                                                                             
      * Create the user space                                                                       
      *                                                                                             
     c                   call(e)   'QUSCRTUS'                                                       
     c                   parm      UserSpace     UserSpaceOut                                       
     c                   parm                    SpaceAttr                                          
     c                   parm      4096          SpaceLen                                           
     c                   parm                    SpaceVal                                           
     c                   parm                    SpaceAuth                                          
     c                   parm                    SpaceText                                          
     c                   parm                    SpaceRepl                                          
     c                   parm                    ErrorDs                                            
      *                                                                                             
     c                   endsr                                                                      
      *=================================================                                            
      *    *Inzsr - One time run House keeping subroutine                                           
      *=================================================                                            
     c     *Inzsr        begsr                                                                      
      *                                                                                             
     c     *entry        plist                                                                      
     c                   parm                    InLibrary                                          
     c                   parm                    InType                                             
      *                                                                                             
     c                   endsr                                                                      
      *==============================================