H/TITLE ** Common Function Service Program **
     H DEBUG(*YES)
     H COPYRIGHT('Copyright (C) 2005 Logical Systems Design')
     H nomain
     ****************************************************************
     * PROGRAM NAME - SWCMMNRI                                      *
     *                                                              *
     * FUNCTION     - This is a service program designed to serve   *
     *                common program functions                      *
     *                                                              *
     * PROGRAMMER   - STEVE CROY        01/31/05                    *
     ****************************************************************
     ****************************************************************
     *                   MODIFICATION LOG                           *
     *                                                              *
     *  DATE   PROGRAMMER      DESCRIPTION                          *
     *                                                              *
     ****************************************************************
     ****************************************************************
     *               PROGRAM INTERFACE SECTION                      *
     *                                                              *
     *  CALLS PROGRAMS:                                             *
     *                                                              *
     ****************************************************************
     * Prototypes
     *---
     /copy qrpglesrc,swcmmn_pr
     *---
     DExecCmd          PR                  EXTPGM('QCMDEXC')
     D  Command                     256
     D  Length                       15  5
     *---
     * Global Variables
     *---
     D W$CMD           S            256    INZ
     D W$LEN           S             15  5 INZ(256)

     D DspTxtMsg       PR
     D  InString                    255
     D  InTitle                      27    options(*nopass)

     *//=================================================================//
     * Convert character to numeric
     * pass in a character string, receive a 30 9 numeric value
     *//=================================================================//
     P getNum          B                   Export
     D getNum          pi            30p 9
     D  string                      100a   const varying
     D  decComma                      2a   const options(*nopass)
     D  currency                      1a   const options(*nopass)
     * defaults for optional parameters
     D decPoint        s              1a   inz('.')
     D comma           s              1a   inz(',')
     D cursym          s              1a   inz(' ')
     * structure for building result
     D                 ds
     D result                        30s 9 inz(0)
     D resChars                      30a   overlay(result)
     * variables for gathering digit information
     * pNumPart points to the area currently being gathered
     * (the integer part or the decimal part)
     D pNumPart        s               *
     D numPart         s             30a   varying based(pNumPart)
     D intPart         s             30a   varying inz('')
     D decPart         s             30a   varying inz('')
     * other variables
     D intStart        s             10i 0
     D decStart        s             10i 0
     D sign            s              1a   inz('+')
     D i               s             10i 0
     D len             s             10i 0
     D c               s              1a
     * override defaults if optional parameters were passed
     /free
        IF %parms > 1;
           decPoint = %subst(decComma : 1 : 1);
           comma = %subst(decComma : 2 :1);
        ENDIF;
        IF %parms > 2;
          cursym = currency;
        ENDIF;
        //* initialization
         len = %len(string);
        //* begin reading the integer part
         pNumPart = %addr(intPart);
        //* loop through characters
        FOR I = 1 to len;
            c = %subst(string : i : 1);

           SELECT; //* ignore blanks, digit separator, currency symbol
              WHEN c = comma or c = *blank or c = cursym;
                //* decimal point: switch to reading the decimal part
              WHEN c = decPoint;
                pNumPart = %addr(decPart);
               //* sign: remember the most recent sign
              WHEN c = '+' or c = '-';
                sign = c;
                //* more signs: cr, CR, () are all negative signs
              WHEN c = 'C' or c = 'R' or
                c = 'c' or c = 'r' or
                c = '(' or c = ')';
                sign = '-';
              OTHER; //* a digit: add it to the current build area
                numPart = numPart + c;
           ENDSL;
        ENDFOR;
        //* copy the digit strings into the correct positions in the
        //* zoned variable, using the character overlay

         decStart = %len(result) - %decPos(result) + 1;
         intStart = decStart - %len(intPart);
         %subst(resChars: intStart: %len(intPart)) = intPart;
         %subst(resChars: decStart : %len(decPart)) = decPart;

        //* if the sign is negative, return a negative value

        IF sign = '-';
           RETURN    - result;
        ELSE; //* otherwise, return the postive value
           RETURN result;
        ENDIF;
     /end-free
     p                 e
     *//=================================================================//
     * Test for valid numeric data using a pointer to a field. Test the
     * value to determine if the contents are numeric. An indicator is
     * returned. Example: *in91 = testZoned(%addr(FLDNAM): %size(FLDNAM))
     *//=================================================================//

     P testZoned       b                   export
     D testZoned       pi             1n
     D   pZoned                        *   value
     D   len                         10i 0 value

     D wrkfld          s             30a   inz(*zeros)
     D zonedBytes      s             30a   based(pZoned)
     D retInd          s              1n

     C                   EVAL      %SUBST(WRKFLD : 30 - len + 1)
     C                             = %SUBST(zonedBytes : 1 : len)
     C                   TESTN                   WRKFLD               91
     C                   EVAL      retInd = *IN91
     C                   RETURN    retInd

     P testZoned       e

     *//=================================================================//
     * Execute command
     *//=================================================================//

     P Command         B                   export
     D Command         PI
     D   Cmd                        256
     D   Len                         15  5
     D ErrorMsg        S            255    INZ('Error executing command, -
     D                                     Check joblog')
     D Errttl          S             27    inz('Error Alert')
     /free
        MONITOR;
           ExecCmd( cmd: len);
        ON-ERROR;
           DspTxtMsg( ErrorMsg );
        ENDMON;
         RETURN;
     /end-free
     P Command         E

     *//=================================================================//
     *// Center text within field of specified length.
     *// Parameters: I: instr - string to center
     *//             I: len   - length of field to center within
     *// Returns:  String of length "len" with text "instr" centered
     *//=================================================================//

     P centerTxt       b                   Export
     D centerTxt       pi           100a   varying
     D   instr                      100a   value varying
     D   len                         10i 0 value
     D outstr          s            100a   varying
     D pos             s             10i 0
     /free
        // Check if input string is bigger than desired output
         instr = %trim(instr);
        if %len(instr) > len;
           %len(instr) = len;
        endif;

        // Find position of centered string in output
         pos = %div(len - %len(instr):2) + 1;

        // Build and return centered output string
         %len(outstr) = len;
         %subst(outstr:pos) = instr;
         return outstr;
     /end-free
     P centerTxt       e

     *//=================================================================//
     * Procedure: RtvSysName
     * Parm.....: SysName = name of system returned.
     * Returns..: 0 = Success
     *//=================================================================//

     P RtvSysName      B                   Export
     D RtvSysName      PI            10I 0
     D   SysName                      8A

     D QWCRNETA        PR                  ExtPgm('QWCRNETA')
     D   RcvVar                   32766A   OPTIONS(*VARSIZE)
     D   RcvVarLen                   10I 0 const
     D   NbrNetAtr                   10I 0 const
     D   AttrNames                   10A   const
     D   ErrorCode                  256A
     *--
    D* Error code structure
     *--
     D EC              DS
     D  EC_BytesP              1      4B 0 INZ(256)                             Bytes provided/size
     D  EC_BytesA              5      8B 0 INZ(0)                               Bytes returned/API
     D  EC_MsgID               9     15                                         Error msg ID
     D  EC_Reserve            16     16                                         Reserved
     D  EC_MsgDta             17    256                                         Error msg data
     *--
    D* Receiver variable for QWCRNETA with only one attribute
     *--
     D RV              ds
     D   RV_Attrs                    10I 0                                      Nbr/attrs returned
     D   RV_Offset                   10I 0                                      Offset to first attr
     D   RV_Data                      1A   DIM(1000)                            Addtional data
    D* Network attribute structure
     D p_NA            S               *
    D*                                    Type of Data.  C=Char, B=Binary
     D NA              ds                  based(p_NA)
     D   NA_Attr                     10A                                        Attribute name
     D   NA_Type                      1A                                        status L=locked
     D   NA_Status                    1A                                        length of data
     D   NA_Length                   10I 0                                      data (character)
     D   NA_DataChr                1000A                                        data (binary)
     D   NA_DataInt                  10I 0 overlay(NA_DataChr:1)

     /free
       //* Call API to get system name

        CALLP QWCRNETA(RV: %size(RV): 1: 'SYSNAME': EC);
       IF EC_BytesA > 0;
          RETURN -1;    //*  API returned an error
       ENDIF;

       IF RV_Attrs <> 1 or RV_Offset < 8  or RV_Offset > 1000;
          RETURN -2;    //*  RcvVar contained undefined data
       ENDIF;

        //* Attach NetAttr structure
        RV_Offset = RV_Offset - 7;
        p_NA = %addr(RV_Data(RV_Offset));


       IF NA_Attr <> 'SYSNAME'  or NA_Length < 1  or NA_Length > 8;
          RETURN -3;   //*  NetAttr structure had undefined data
       ENDIF;

       IF NA_Status = 'L';
          RETURN  -4;   //* Network attributes are locked
       ENDIF;

       //* Return system name
        SysName = %subst(NA_DataChr:1:NA_Length);
        RETURN 0;
     /end-free
     P                 E
     *//=================================================================//
     * Get job attributes
     *//=================================================================//

     P GetJobAtr       B                   export
     D GetJobAtr       PI             1A

     DRtvJobA          Pr                  extpgm('QUSRJOBI')
     D rtv_Data                     100a
     D rtv_Length                    10i 0 const
     D rtv_Format                     8a
     D rtv_Job                       26a
     D rtv_IntJob                    16a

     D p_Rcvr          S            100
     D p_Format        S              8    INZ('JOBI0100')
     D p_ThisJob       S             26    INZ('*')
     D p_IntJob        S             16

     D JobType         S              1
     /free
         RtvJoba( p_Rcvr: %len(p_Rcvr): p_Format: p_ThisJob: p_IntJob);
        //* B/atch I/nteractive P/restart?
         JobType = %SUBST(P_Rcvr : 61 :1);
         RETURN JobType;
     /end-free

     P GetJobAtr       E

     *//=================================================================//
     * Delay job: Wait nnnnnnnnnn.nnnnn seconds before resuming
     *//=================================================================//

     P DelayJob        B                   export
     D DelayJob        PI
     D  NbrSecs                      15  5

     DWait             pr                  extproc('_WAITTIME')
     D                               16

     DTemplate         ds
     D Interval                      20u 0
     D Options                        8    inz(*loval)

     DOneSecond        s             20u 0 inz(4096000000)

     /free
        IF NbrSecs > 0;
           Interval = NbrSecs * OneSecond;
           Wait(Template);
        ENDIF;
         RETURN;
     /end-free
     P DelayJob        E

     *//=================================================================//
     *// Translate string into upper case.
     *//=================================================================//

     P UpperCase       b                   Export
     D UpperCase       pi           256a   varying
     D   inString                   256a   value varying
     D   len                         10i 0 value
     D xString         s            256a
     D Up              C                   'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
     D Lo              C                   'abcdefghijklmnopqrstuvwxyz'

     /free
        // translate string
         xstring = *blanks;
         IF inString <> *blanks;
            xString = %xlate(Lo: Up: inString);
         ENDIF;
         RETURN xString;
     /end-free
     P UpperCase       e

     *//=================================================================//
     *// Translate string into lower case.
     *//=================================================================//

     P LowerCase       b                   Export
     D LowerCase       pi           256a   varying
     D   inString                   256a   value varying
     D   len                         10i 0 value
     D   pos                         10i 0 options(*nopass)
     D xString         s            256a
     D  Spos           s              9S 0
     D Up              C                   'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
     D Lo              C                   'abcdefghijklmnopqrstuvwxyz'

     /free
        // translate string
         IF %parms < 3;
            Spos = 1;
         ELSE;
            Spos = pos;
         ENDIF;
         xstring = *blanks;
         IF inString <> *blanks;
            IF Spos > 1;
               xString = %xlate(Up: Lo: inString: Spos);
            ELSE;
               xString = %xlate(Up: Lo: inString);
            ENDIF;
         ENDIF;
         RETURN xString;
     /end-free
     P LowerCase       e

     P DspTxtMsg       B

     D DspTxtMsg       PI
     D  InString                    255
     D  InTitle                      27    options(*nopass)

     DMsgBox           pr                  extpgm('QUILNGTX')
     D LngTxt                       255a
     D TextLen                       10i 0 const
     D TxtTitle                       7a
     D TxtMsgF                       20a
     D ErrCode                       16a

     d Text            s            255a   inz(*blank)
     d String          s            255a   inz(*blank)
     d Title           s              7a   inz(*blank)
     d MessageF        s             20a   inz(*blank)
     d Error           s             16a
     d TitleString     s             27    varying inz(*blank)
     d tx              s              2  0
     d BlankString     s             27    inz(*blank)
     D JobType         S              1

     /free

         title = *blanks;
         messagef = *blanks;

        IF %parms = 1;
            String = inString;
        ENDIF;

        IF %parms = 2;
           String = inString;
           TitleString = %trim(inTitle);
        ENDIF;

        IF TitleString <> *blank;
           IF %len(titlestring)< 27;
              tx = ((27-%len(titlestring))/2);
              titlestring = %subst(blankstring:1:tx)
                          + titlestring;
              titlestring = titlestring
                          + %subst(blankstring:1:%len(titlestring));
              IF %subst(titlestring:1:1)=*blank;
                 %subst(titlestring:1:1)='.';
              endif;
              IF %subst(titlestring:27:1)=*blank;
                 %subst(titlestring:27:1)='.';
              ENDIF;
              title=%subst(titlestring:1:7);
              messageF=%subst(titlestring:8:20);
           ENDIF;
        ENDIF;

         JobType = GetJobAtr();
       //* B/atch I/nteractive P/restart?
        IF JobType = 'I';
           Text=%trim(String);
           Error='';
           MsgBox(Text: %len(Text): Title: MessageF:  Error);
        ENDIF;
         RETURN;

     /end-free

     P DspTxtMsg       E

Previous page

>© 2005 Steve Croy