iSeries & System i

      Tips & Tricks - Table of Contents #2

Debug in 132x27 mode
DLYJOB inside RPG IV
CmdLine Program Call with 2 num. parameters
Search for filename in path
Convert Decimal to Fractional Notation
Restart NetServer
Check jobs for Temporary storage over 50Mb
Retrieve System Processor & Interactive Features
National Language Version & QCCSID
Encoding routine for creating XML documents
Monitor for a disabled userprofile



Debug 132x27 mode

Normally STRDBG starts in 80x24 mode. You can change this mode to 132x27 mode with the
following environment variable:

	AddEnvVar	EnvVar('ILE_DEBUGGER_1') +
			Value('ALLOW_WIDE_SCREEN') +
			Level(*Job) Replace(*Yes)

To go back to 80x24 mode, you use:

	RmvEnvVar	EnvVar('ILE_DEBUGGER_1') Level(*Job)

Create two CLLE-programs, eg. DBGWIDE and ENDWIDE. Add an extra statement MonMsg CPFA981 to the ENDWIDE - to prevent at dump, if DBGWIDE has not been initiated.
Wrap these two CLLE's into two commands with the same names, place them in QGPL and your *On/*Off the two debug-modes.
The information originated from Karl Hanson of IBM, Rochester who works/worked on the debuggers for IBM.

Back

DLYJOB inside RPG IV

To delay an internal loop inside a RPG program, or to delay a call to another program, use 'sleep' or 'usleep'

H BndDir('QC2LE') D Sleep Pr 10I 0 ExtProc('sleep') D Seconds 10U 0 Value D Usleep Pr 10I 0 ExtProc('usleep') D Microsecs 10U 0 Value * Sleep for 30 seconds C CallP Sleep(0030) * Sleep for 30 seconds C CallP Usleep(0030000000) Note from Chris: It's working now. Thanks. My testing shows that 1000000 is valid for usleep (it does the delay). And values over 1000000 don't delay and the return value is zero, not -1. Note from Mel: My testing showed the same results as yours. That is, for values <= 1,000,000, usleep sleeps that many microseconds and returns 0. For values > 1,000,000, it sleeps 0 microseconds and returns 0. Although the documentation says it should return -1 and set errno to indicate why it failed, in my testing, both the return value and the errno were always 0. Also, the documentation says the return value is an unsigned integer, which would be impossible for it to return -1. The prototype in QSYSINC/H member UNISTD, defines the return code as int, which is signed. Finally, the documentation says the "usleep() function is included for its historical usage. The setitimer() function is preferred over this function." So, it appears that both the code and documentation contain errors and we should look at setitimer() instead.

Back

CmdLine Program Call with 2 num. parameters

From a commandlinie a program can be called, as here with 2 num. parameters with the 
values of -421 og 98200:

Call Pgm(LIBRARY/PROGRAM) Parm(X'421D' X'98200F') Packed Call Pgm(LIBRARY/PROGRAM) Parm(X'F4F2D1' X'F9F8F2F0F0') Zoned

Back

Search for filename in path

But, here's a slightly more efficient method.  Rather than scanning the
string several times to find all the slashes, it uses the C "strrchr"
function which scans for a single character, starting at the end of
the string...   since it only scans the string once, it'll run slightly
faster...


     H DFTACTGRP(*NO) ACTGRP(*NEW) BNDDIR('QC2LE')

     D basename        PR           256A
     D   path                       256A   const

     D my_file         S             50A
     D my_path         S            256A

     c                   eval      my_path = '/NPR-SERVER-NT/SCANNING/' +
     c                                       'Common/Steve%20Maher/' +
     c                                       'EAR90881/AC9012F1240Y6.B.HPGL'

     c                   eval      my_file = basename(my_path)

     c                   dsply                   my_file
     c                   eval      *inlr = *on

     P basename        B
     D basename        PI           256A
     D   path                       256A   const

     d strrchr         PR              *   extproc('strrchr')
     d   wholestr                      *   value options(*string)
     d   char                        10I 0 value

     D SLASH           c                   const(97)
     D p               S               *

     c                   eval      p = strrchr(path: SLASH)
     c                   if        p = *NULL
     c                   return    *blanks
     c                   else
     c                   eval      p = p + 1
     c                   return    %str(p)
     c                   endif
     P                 E

Thanks to Scott Klement
Back

Convert Decimal to Fractional Notation

Bob O. wrote:
Does anyone have an example of converting a decimal number to it's fractional equivalent?

For example:  15.3750 = 15-3/8

The decimal field to convert is a 10/4 field. Any help is appreciated.  

Hans replied:
Hmmm, I was thinking of whipping up a procedure, so I typed "strseu qrpglesrc 
fract", and up popped a program already written! So, here it is. No promises though 
on completeness or correctness in all cases. And you'd probably want to add a parameter 
to specify some maximum for the denominator. And you'd probably want to change to 10I0 
variables to 20I0 (and atoi() to atoll()). But it should get you going.

BTW, this particular program outputs:
    > call fract
      DSPLY  123 57/125
      DSPLY  123
      DSPLY  123 17/50
      DSPLY  123 1929/15625
      DSPLY  123 4/5
      DSPLY  123 1/8


	H dftactgrp(*no) bnddir('QC2LE')

	D fraction        pr            50a   varying
	D    numstr                     50a   varying value
	  /free
	     dsply (fraction('123.4560'));
	     dsply (fraction('123.0000'));
	     dsply (fraction('123.34'));
	     dsply (fraction('123.123456'));
	     dsply (fraction('123.8'));
	     dsply (fraction('123.125'));
	     *inlr = *on;
	  /end-free
	
	  //--------------------------------------------------------------
	  // Procedure:  fraction
	  //--------------------------------------------------------------
	  // Convert number string from decimal to fractional form.
	  //
	  // Parameters:
	  //    I: numstr     -- string representing decimal numeric value
	  //
	  // Returns:
	  //    String of number in reduced fractional form.
	  //--------------------------------------------------------------
	P fraction        b
	D fraction        pi            50a   varying
	D    numstr                     50a   varying value
	D atoi            pr            10i 0 extproc('atoi')
	D   str                           *   value options(*string)
	D int             s             10i 0
	D dec             s             10i 0 inz(0)
	D decpos          s             10i 0
	D numerator       s             10i 0
	D denominator     s             10i 0
	D factor          s             10i 0
	  /free
	    // slough trailing blanks and zeros in number string
	    dow %subst(numstr:%len(numstr):1) = ' '
	    or  %subst(numstr:%len(numstr):1) = '0';
	       %len(numstr) = %len(numstr) - 1;
	    enddo;
	
	    // find decimal point
	    decpos = %scan('.':numstr);
	
	    // return now if we don't have decimal digits
	    if decpos = 0;
	       return numstr;
	    elseif decpos = %len(numstr);
	       return %subst(numstr:1:decpos-1);
	    endif;
	
	    // find digits to the left and right of the decimal point
	    int = atoi (%subst(numstr:1:decpos-1));
	    dec = atoi (%subst(numstr:decpos+1));
	
	    // determine numerator and denominator
	    numerator = dec;
	    denominator = %inth(10**(%len(numstr)-decpos));
	
	    // reduce fraction to smallest possible numerator/denominator
	    for factor = 2 to %div(denominator:2);
	       dow %rem(numerator:factor) = 0
	       and %rem(denominator:factor) = 0;
	          numerator = %div(numerator:factor);
	          denominator = %div(denominator:factor);
	       enddo;
	    endfor;
	
	    // return fractional string
	    return %char(int) + ' ' + %char(numerator)
	                      + '/' + %char(denominator);
	  /end-free
	P fraction        e

Thanks to Hans Boldt
Back

Restart NetServer
Q:

We just had our Netserver stop and now it won't start, gets error code 5 -
Start of the NetBIOS over TCP/IP failed with return code 3418.

A: Call Pgm(QZLSSTRS) Parm('1' X'00000000') The '1' tells it to reset. Passing a '0' in that first parm is how you would normally restart it through the api. Thanks to David Smith

Back

Check jobs for Temporary storage over 50Mb

This is the CHKTMPSTG routine I mentioned. Just compile & call it.
Change the size threshold (scan on L_KeyValue) from 50Mb to whatever value seems useful.


      ********************************************************************
      * CHKTMPSTG: Check jobs for Temporary storage over 50Mb
      ********************************************************************
      ********************************************************************
      *  Data Structures
      ********************************************************************
      *  Standard error code DS for API error handling
     D Error_Code      DS
     D  BytesProvd                   10I 0 INZ(0)
     D  BytesAvail                   10I 0 INZ(0)
     D  Except_ID                     7
     D  Reserved                      1
     D  Exception                   256
      *  Receiver value DS for user space header info 
      *  (used in first call to QUSRTVUS)
     D GenRcvrDS       DS
     D  UserArea                     64
     D  GenHdrSize                   10I 0
     D  StrucLevel                    4
     D  FormatName                    8
     D  APIUsed                      10
     D  CreateStamp                  13
     D  InfoStatus                    1
     D  SizeUsUsed                   10I 0
     D  InpParmOff                   10I 0
     D  InpParmSiz                   10I 0
     D  HeadOffset                   10I 0
     D  HeaderSize                   10I 0
     D  ListOffset                   10I 0
     D  ListSize                     10I 0
     D  ListNumber                   10I 0
     D  EntrySize                    10I 0
      ********************************************************************
      * Type Definition for the JOBL0100 format.
      ********************************************************************
     D ListDataDS      DS
     D  L_JobName                    10
     D  L_JobUser                    10
     D  L_JobNbr                      6
     D  L_JobIdent                   16
     D  L_Status                     10
     D  L_JobType                     1
     D  L_JobSubTy                    1
     D  L_Reserved                    2
     D  L_JobInfoSts                  1
     D  L_Reserved2                   3
     D  L_NbrFldsRtn                 10I 0
     D  L_LenInfoRtn                 10I 0
     D  L_KeyFld                     10I 0
     D  L_DataType                    1
     D  L_Reserved3                   3
     D  L_LenDataRtn                 10I 0
     D  L_KeyValue                   10I 0
      ********************************************************************
      * Field definitions
      ********************************************************************
     D DataLength      S             10I 0 INZ(140)
     D CurrentEnt      S              5P 0 INZ(1)
     D ExtendAttr      S             10    INZ('USRSPC    ')
     D InitialSiz      S             10I 0 INZ(1024)
     D InitialVal      S              1    INZ(X'00')
     D JobStatus       S             10    INZ('*ACTIVE   ')
     D JobType         S              1    INZ('*')
     D ListFormat      S              8    INZ('JOBL0200')
     D NbrToRtn        S             10I 0 INZ(1)
     D KeysToRtn       S             10I 0 INZ(2009)
     D P_DataLength    S             10I 0
     D P_MsgData       S            512
     D P_MsgFile       S             20    INZ('QCPFMSG   *LIBL')
     D P_MsgID         S              7    INZ('CPDA0FF')
     D P_MsgKey        S              4
     D P_MsgType       S             10
     D P_PgmQueue      S             10
     D P_PgmStack      S             10I 0
     D PublicAut       S             10    INZ('*ALL      ')
     D QualifyJob      S             26    INZ('*ALL      *ALL      *ALL  ')
     D ReplaceSpc      S             10    INZ('*YES      ')
     D StartPos        S             10I 0 INZ(1)
     D TextDescrp      S             50    INZ('User space for List Job API')
     D UserSpace       S             20    INZ('CHKTMPSTG QTEMP     ')
      ********************************************************************
      * MAINLINE:
      ********************************************************************
      * Create a user space to hold the job list entries
     C                   CALL      'QUSCRTUS'
     C                   PARM                    UserSpace
     C                   PARM                    ExtendAttr
     C                   PARM                    InitialSiz
     C                   PARM                    InitialVal
     C                   PARM                    PublicAut
     C                   PARM                    TextDescrp
     C                   PARM                    ReplaceSpc
     C                   PARM                    Error_Code
      * List all the jobs on the system
     C                   CALL      'QUSLJOB'
     C                   PARM                    UserSpace
     C                   PARM                    ListFormat
     C                   PARM                    QualifyJob
     C                   PARM                    JobStatus
     C                   PARM                    Error_Code
     C                   PARM                    JobType
     C                   PARM                    NbrToRtn
     C                   PARM                    KeysToRtn
      * Get the header info for this space
     C                   CALL      'QUSRTVUS'
     C                   PARM                    UserSpace
     C                   PARM                    StartPos
     C                   PARM                    DataLength
     C                   PARM                    GenRcvrDS
     C                   PARM                    Error_Code
      * Check to see if any entries returned
B001 C                   IF        ListNumber > 0
      * Set the initial offset for the start of the list entries
     C                   EVAL      ListOffset = ListOffset + 1
      * Loop through the entries held in the list section of the user space
B002 C                   DOW       CurrentEnt <= ListNumber
      * Get the header info for this space
     C                   CALL      'QUSRTVUS'
     C                   PARM                    UserSpace
     C                   PARM                    ListOffset
     C                   PARM                    EntrySize
     C                   PARM                    ListDataDS
     C                   PARM                    Error_Code
      *
B003 C                   IF        L_KeyValue > 50
     C                   EVAL      P_MsgData = 'Job ' + L_JobNbr + '/' +
     C                             %TRIM(L_JobUser) + '/' + %TRIM(L_JobName) +
     C                             ' is using temp storage of ' +
     C                             %EDITC(L_KeyValue : 'Z') + 'Mb'
     C
     C                   EVAL      P_DataLength = 78
     C                   EVAL      P_PgmStack = 0
     C                   EVAL      P_PgmQueue = '*EXT'
     C                   EVAL      P_MsgType = '*INFO'
      *
     C                   CALL (E)  'QMHSNDPM'
     C                   PARM                    P_MsgID
     C                   PARM                    P_MsgFile
     C                   PARM                    P_MsgData
     C                   PARM                    P_DataLength
     C                   PARM                    P_MsgType
     C                   PARM                    P_PgmQueue
     C                   PARM                    P_PgmStack
     C                   PARM                    P_MsgKey
     C                   PARM                    Error_Code
E003 C                   ENDIF
      *  Bump up the counter & offset for the next entry
     C                   EVAL      ListOffset = ListOffset + EntrySize
     C                   EVAL      CurrentEnt = CurrentEnt + 1
E002 C                   ENDDO
E001 C                   ENDIF
      *
     C                   EVAL      *INLR = *ON
     C                   RETURN

Thanks to Martin Rowe
Back

Retrieve System Processor & Interactive Features

The following RPGLE program gets and formats a message like:
"Type 9406 Model 720 Prc Grp P10 fc 206A Serial 10-2844M 1024mb Rel V5R1M0."


     H BndDir('QC2LE') DftActGrp(*NO) ActGrp(*CALLER)
     H Debug Option(*srcstmt : *nodebugio)

     D sndMsg          PR
     D  msgText                      80    Const

     D matmatr         PR                  ExtProc('matmatr')
     D   attributes                    *   Value
     D   attrLen                      5i 0 Value

     D machineAttributes...
     D                 DS                  inz
     D   MMTR_Template_Size...
     D                               10i 0
     D   MMTR_Bytes_Used...
     D                               10i 0
     D   MMTR_VPD                  4096

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

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

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

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

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

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

     C                   Eval      MMTR_Template_Size =
                                            %size(machineAttributes)

     C                   CallP     matmatr( %ADDR(machineAttributes) :
     C                                      $MMTR_VPD_ )

     C                   Eval      VPDOffsets = %subst(MMTR_VPD:
     C                                                 1:
     C                                                 %len(VPDOffsets))

     C                   Eval      cecVPD   = %subst(MMTR_VPD:
     C                                               vCecOff-7:
     C                                               %len(cecVPD))

     C                   Eval      panelVPD = %subst(MMTR_VPD:
     C                                               vPnlOff-7:
     C                                               %len(panelVPD))

     C                   Eval      prErr = prErrStruc

     C                   Call      'QSZRTVPR'
     C                   Parm                    prRcvr
     C                   Parm                    prRcvrLen
     C                   Parm                    prFormat
     C                   Parm                    prPrdInfo
     C                   Parm                    prErr

     C                   Eval      prErrStruc = prErr

     C                   Eval      prRelease  = %subst(prRcvr: 20: 6)

     C                   CallP     sndMsg('Type '     + %trim(cType) +
     C                                    ' Model '   + %trim(cModel) +
     C                                    ' Prc Grp ' + %trim(cGroup_ID) +
     C                                    ' fc '      + %trim(cFeature_Code) +
     C                                    ' Serial '  + %trim(cSerial_No) +
     C                                    ' ' +
                                           %trim(%editc(vMemInstalled:'Z')) +
     C                                    'mb Rel ' + %trim(prRelease) )

     C                   Eval      *inLR = *On

     C                   Return

     PsndMsg           B
     DsndMsg           PI
     D inpText                       80    Const

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

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

     C                   Eval      msgData = inpText

     C                   Eval      msgErrStruc = errStruc

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

     C                   Eval      errStruc = msgErrStruc

     PsndMsg           E

Thanks to Tom Westdorp
Back

National Language Version & QCCSID

This is out of my "Everything You Always Wanted to know about System Values
(but were afraid to ask)" pitch from COMMON.

|-----------------------------+------+--------| | National Language Version | NLV | QCCSID | |-----------------------------+------+--------| | Afrikaans (South Africa) | n/a | 00037 | |-----------------------------+------+--------| | Albanian (Albania) | 2995 | 00500 | |-----------------------------+------+--------| | Arabic | 2954 | 00420 | |-----------------------------+------+--------| | Australian English | | | | (Australia) | n/a | 00037 | |-----------------------------+------+--------| | Belgian Dutch MNCS | 2963 | 00500 | |-----------------------------+------+--------| | Belgian English | 2909 | 00500 | |-----------------------------+------+--------| | Belgian French MNCS | 2966 | 00500 | |-----------------------------+------+--------| | Brazilian Portuguese | 2980 | 00037 | |-----------------------------+------+--------| | Bulgarian (Bulgaria) | 2974 | 01025 | |-----------------------------+------+--------| | Byelorussia (Belarus) | n/a | 01025 | |-----------------------------+------+--------| | Canadian French MNCS | 2981 | 00500 | |-----------------------------+------+--------| | Croatian | 2912 | 00870 | |-----------------------------+------+--------| | Czech | 2975 | 00870 | |-----------------------------+------+--------| | Danish | 2926 | 00277 | |-----------------------------+------+--------| | Dutch Netherlands | 2923 | 00037 | |-----------------------------+------+--------| | English Uppercase | 2950 | 00037 | |-----------------------------+------+--------| | English Uppercase and | | | | Lowercase | 2924 | 00037 | |-----------------------------+------+--------| | English Uppercase DBCS | 2938 | 65535 | |-----------------------------+------+--------| | English Uppercase and | | | | Lowercase DBCS | 2984 | 65535 | |-----------------------------+------+--------| | Estonian | 2902 | 01122 | |-----------------------------+------+--------| | Farsi | 2998 | 01097 | |-----------------------------+------+--------| | Finnish | 2925 | 00278 | |-----------------------------+------+--------| | French | 2928 | 00297 | |-----------------------------+------+--------| | French MNCS | 2940 | 00500 | |-----------------------------+------+--------| | German | 2929 | 00273 | |-----------------------------+------+--------| | German MNCS | 2939 | 00500 | |-----------------------------+------+--------| | Greek | 2957 | 00875 | |-----------------------------+------+--------| | Hebrew | 2961 | 00424 | |-----------------------------+------+--------| | Hungarian | 2976 | 00870 | |-----------------------------+------+--------| | Icelandic | 2958 | 00871 | |-----------------------------+------+--------| | Irish Gaelic (Ireland) | n/a | 00285 | |-----------------------------+------+--------| | Italian | 2932 | 00280 | |-----------------------------+------+--------| | Italian MNCS | 2942 | 00500 | |-----------------------------+------+--------| | Japanese (Katakana) DBCS | 2962 | 05026 | |-----------------------------+------+--------| | Korean DBCS | 2986 | 00933 | |-----------------------------+------+--------| | Laotian | 2906 | 01132 | |-----------------------------+------+--------| | Latvian | 2904 | 01122 | |-----------------------------+------+--------| | Lithuanian | 2903 | 01122 | |-----------------------------+------+--------| | Macedonian | 2913 | 01025 | |-----------------------------+------+--------| | Norwegian | 2933 | 00277 | |-----------------------------+------+--------| | Polish | 2978 | 00870 | |-----------------------------+------+--------| | Portuguese | 2922 | 00037 | |-----------------------------+------+--------| | Portuguese MNCS | 2996 | 00500 | |-----------------------------+------+--------| | Romanian (Romania) | 2992 | 00870 | |-----------------------------+------+--------| | Russian | 2979 | 01025 | |-----------------------------+------+--------| | Serbian Cyrillic (Serbia) | 2914 | 01025 | |-----------------------------+------+--------| | Serbian Latin (Serbia) | n/a | 00870 | |-----------------------------+------+--------| | Simplified Chinese DBCS | | | | (PRC) | 2989 | 00935 | |-----------------------------+------+--------| | Slovakian | 2994 | 00870 | |-----------------------------+------+--------| | Slovenian | 2911 | 00870 | |-----------------------------+------+--------| | Spanish | 2931 | 00284 | |-----------------------------+------+--------| | Swedish | 2937 | 00278 | |-----------------------------+------+--------| | Thai | 2972 | 09030 | |-----------------------------+------+--------| | Traditional Chinese DBCS | | | | (ROC) | 2987 | 00937 | |-----------------------------+------+--------| | Turkish | 2956 | 01026 | |-----------------------------+------+--------| | UK English (United Kingdom) | n/a | 00285 | |-----------------------------+------+--------| | Vietnamese | 2905 | 01130 | |-----------------------------+------+--------|
Thanks to Al Barsa Jr.
Back

Encoding routine for creating XML documents

Just encode the string by checking each byte.  If the byte is a special
character, replace it.  Here is the encode routine I use for creating XML
documents, you should be able to use it with just a few changes:


	 *****************************************************************
	 * XML encode special characters
	 *****************************************************************
	P xml_encode      b                   export

	D xml_encode      pi           512    Varying
	D  buffer                      512    Varying Const

	D  encoded        S            512    Varying
	D  max            S             10u 0
	D  i              S             10u 0
	D  byte           S              1

	 * encode bytes
	C                   eval      max = %len(buffer)
	C     1             do        max           i
	C                   eval      byte = %subst(buffer:i:1)
	C                   select
	C     byte          wheneq    '&'
	C                   eval      encoded = encoded + '&'
	C     byte          wheneq    ''''
	C                   eval      encoded = encoded + '''
	C     byte          wheneq    '"'
	C                   eval      encoded = encoded + '"'
	C     byte          wheneq    '<'
	C                   eval      encoded = encoded + '<'
	C     byte          wheneq    '>'
	C                   eval      encoded = encoded + '>'
	C                   other
	C                   eval      encoded = encoded + byte
	C                   endsl
	C                   enddo
	C                   return    encoded
	P xml_encode      e

Thanks to Rich Duzenbury
Back

Monitor for a disabled userprofile

PGM
        DCL        VAR(&CLOCKSTS) TYPE(*CHAR) LEN(10)
TOP:
        RTVUSRPRF  USRPRF(user) STATUS(&CLOCKSTS) 
		/* retrieve 'user' profile */
		/* Do Loop     */
        IF         COND(&CLOCKSTS = '*DISABLED') THEN(DO) 
                /* check 'user' profile status */
        CHGUSRPRF  USRPRF(CLOCK) STATUS(*ENABLED) 
		/* Change to enabled  */
        CHGVAR     VAR(&CLOCKSTS) VALUE('          ') 
		/* reset variable - &clocksts */
        ENDDO
		/* End Do Loop */

        DLYJOB     DLY(300)    
		/* wait 5 minutes */
        GOTO       CMDLBL(TOP) 
		/* recheck clock status */
ENDPGM

Thanks to Mary Jo Whitcomb
Back

Page #2

Back