Who

Andrew Newns.

What

Independent contractor
Skill-set: RPG, SQL, Synon.

Where

UK, Netherlands, Belgium, Australia.

When

Available soon.

Code

Find a File

Utility to find a file name by searching with the file description.

Mbr: UF, Type: CMD, Text: Find a File: Command
             CMD        PROMPT('Find A File')
/* CPP UFC */
             PARM       KWD(TXT) TYPE(*CHAR) LEN(50) PROMPT('File +
                          Name')

             PARM       KWD(LIB) TYPE(*CHAR) LEN(10) DFT(DTA_LIB) +
                          PROMPT('Library Name')

Mbr: UFC, Type: CLLE, Text: Find a File: CL Program
pgm      parm(&Txt &Lib)
dcl &Txt           *char     (  50  )
dcl &Lib           *char     (  10  )

dcl &TxtQ          *char     (  52  )
dcl &LibQ          *char     (  14  )

chgvar &TxtQ ('''' *cat '%' *CAT &Txt *tcat '%' *CAT '''')
chgvar &LibQ ('''' *cat &Lib *TCAT '''')

strqmqry qmqry(QGPL/UFQ)   +
         setvar( (TXT &TxtQ) +
                 (LIB &LibQ) )


endpgm

Mbr: UFQ, Type: QMQRY, Text: Find a File: QM Query
select
          substr(TABLE_NAME,1,15) as TABLE_NAME ,
          TABLE_TYPE                            ,
          TABLE_TEXT                            ,
          SYSTEM_TABLE_SCHEMA

from      QSYS2/SYSTABLES

where     upper(TABLE_TEXT) like upper(&TXT)
and       SYSTEM_TABLE_SCHEMA = &LIB
and       TABLE_TYPE = 'P'

order by  TABLE_NAME

Find a Field

Utility to find a field name by searching with the field description.

Mbr: UFLD, Type: CMD, Text: Find a Field
             CMD        PROMPT('Find A Field')
/* CPP UFLDC */
             PARM       KWD(FLD) TYPE(*CHAR) LEN(50) PROMPT('Field +
                          Name')

             PARM       KWD(LIB) TYPE(*CHAR) LEN(10) DFT(CKJEURO) +
                          PROMPT('Library Name')

Mbr: UFLDC, Type: CLLE, Text: Find a Field
pgm      parm(&Fld &Lib)
dcl &Fld           *char     (  10  )
dcl &Lib           *char     (  10  )

dcl &FldQ          *char     (  14  )
dcl &LibQ          *char     (  14  )

chgvar &FldQ ('''' *cat &Fld *tcat '''')
chgvar &LibQ ('''' *cat &Lib *TCAT '''')

strqmqry qmqry(ANEWNS/UFLDQ)   +
         setvar( (FLD &FldQ) +
                 (LIB &LibQ) )


endpgm

Mbr: UFLDQ, Type: QMQRY, Text: Find a Field
/* Find a field name */
SELECT    substr(c.COLUMN_NAME  ,1 ,10) as COLUMN       ,
          substr(c.COLUMN_TEXT  ,1 ,50) as COLUMN_TEXT  ,
          substr(c.TABLE_NAME   ,1 ,10) as TABLE        ,
          substr(t.TABLE_TEXT   ,1 ,50) as TABLE_TEXT   ,
          substr(c.TABLE_SCHEMA ,1 ,10) as SCHEMA

FROM      qsys2/syscolumns c

join      systables  t
on        c.table_name = t.table_name
and       c.table_schema = t.table_schema

WHERE     c.COLUMN_NAME   = &FLD
and       c.TABLE_SCHEMA  = &LIB
and       t.TABLE_TYPE    = 'P'

order by  c.TABLE_NAME

Set Source to Lowercase

Utility to change source code to lowercase.

Mbr: LO, Type: CMD, Text: Set Source to Lowercase
             CMD        PROMPT('Convert SRCDTA to lowercase')

/* CONVERT SRCDTA TO LOWERCASE                                            */
/* A.NEWNS         02/09/10                                               */
/* CPP LOC                                                                */
             PARM       KWD(MBR) TYPE(*CHAR) LEN(10) MIN(1) +
                          PROMPT('Member')

/*           PARM       KWD(FILE) TYPE(FIL) DFT(QSRC) SNGVAL((QSRC +
                          QSRC)) MIN(0) PROMPT('Source File')             */
             PARM       KWD(FILE) TYPE(FIL) MIN(1) PROMPT('Source +
                          File')

 FIL:        QUAL       TYPE(*NAME)
             QUAL       TYPE(*NAME) PROMPT('Library')


Mbr: LOC, Type: CLLE, Text: Set Source to Lowercase
pgm parm( &mbr        +
          &fillib     )

/*šconvert srcdta to lowercase                                           €*/
/*ša.newns 02/09/10                                                      €*/

dcl &mbr           *char     (  10  )
dcl &fillib        *char     (  20  )

dcl &lib           *char     (  10  )
dcl &fil           *char     (  10  )
dcl &libq          *char     (  12  )
dcl &filq          *char     (  12  )

dcl &msgdta        *char     (  50  )
dcl &msgid         *char     (   7  )
dcl &msgf          *char     (  10  )
dcl &msgflib       *char     (  10  )

monmsg (cpf0000 mch0000 rnx0000) exec(goto error)

chgvar &fil      (%sst(&fillib  1  10))
chgvar &lib      (%sst(&fillib 11  10))

chkobj &lib/&fil *file &mbr
   monmsg cpf9801 exec(goto error)

ovrdbf &fil tofile(&lib/&fil) mbr(&mbr)

   chgvar &libq ('"' *cat &lib *tcat '"')
   chgvar &filq ('"' *cat &fil *tcat '"')

/*šset srcdat = lower(srcdat)                                            €*/
strqmqry qmqry(anewns/loq)   +
         setvar( (lib &libq) +
                 (fil &filq) )

dltovr &fil

/*šcompletion message                                                     */
chgvar &msgdta (&lib *tcat '/' *cat &fil *bcat &mbr *bcat 'updated')

sndpgmmsg  msgid(cpf9898) msgf(qcpfmsg) +
           msgdta(&msgdta) topgmq(*ext) msgtype(*status)

dlyjob     dly(2)

goto endpgm
/*ˆabnormal end ---------------------------------------------------------€*/
error:
rcvmsg    msgdta(&msgdta) msgid(&msgid) +
          msgf(&msgf) msgflib(&msgflib)
   monmsg cpf0001
sndpgmmsg msgid(&msgid) msgf(&msgflib/&msgf) +
          msgdta(&msgdta)
   monmsg cpf0001

 endpgm:  endpgm

Mbr: LOQ, Type: QMQRY, Text: Set Source to Lowercase
update &LIB/&FIL set srcdta = lower(srcdta),
                     srcdat = 0

SQL Execute Immediate string

Utility to execute an SQL string.

Mbr: SQL0_PR, Type: TXT, Text: Execute SQL string
     d execute_sql_i   pr                  extpgm('SQL0')

     d i_sql                       5000a         varying
     d o_return                       7a

Mbr: SQL0, Type: SQLRPGLE, Text: SQL Execute Immediate string
      /title Execute SQL Immediate
      /if defined (*CRTBNDRPG)
     h dftactgrp(*no) actgrp(*caller)
      /endif

      //‚:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
      //šSystem
      //šTitle         Execute SQL Immediate
      //šMember        SQL0        SQLRPGLE

      //šPgmr          Andrew Newns  dd/mm/yy


      //šObjective
      //šThis program will perform an execute immediate on an sql string.


      //šParameters
      //šI i_sql       sql string
      //šO o_return    Blank if OK

      //‚.......................................................................
      //šChanges:
      //šdd/mm/yyyy  xxnn  name
      //š.
      //‚:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

      //‚Prototypes
      //šPrototype: *ENTRY -------------------------------------------------------------------------
      /copy qrpglesrc,sql0_pr


     d execute_sql_i   pi
     d i_sql                       5000          varying
     d o_return                       7a

      //šPrototype: Test assertion -----------------------------------------------------------------
     d assert          pr
     d  condition                      n   value
     d  message                      80a   value

      //šPrototype: SQL error trapping -------------------------------------------------------------
     d sql_check       pr

      //‚Data structues
      //šProgram Status ds
     dProgStatus      sds
     d PsProgram         *PROC
     d PsMsgPq           *PROC
     d PsStatus          *STATUS
     d PsRoutine         *ROUTINE
     d PsParms           *PARMS
     d PsMsgArea                     30a   overlay( progstatus:51  )
     d PsJobName                     10a   overlay( progstatus:244 )
     d PsUser                        10a   overlay( progstatus:254 )
     d PsJobNbr                       6s 0 overlay( progstatus:264 )

      //šNull indicators
     d null            ds                  qualified
     d   col01                        5i 0

      //‚Constants
     d Yes             c                   const( 'Y' )
     d No              c                   const( 'N' )
     d SQ              c                   const( x'7D' )
     d true            s               n   inz( '1' )
     d false           s               n   inz( '0' )
     d #NULL           c                   -1

      //‚Workfields
     d screen          s             10a
     d screrror        s               n
     d sqlstr          s           5000a
     d w_errtxt        s            120a
     d w_jobtxt        s            100a
     d w_pgmtxt        s             20a

      //‚Mainline
      /free
       monitor ;
         exsr inz_pgm ;
         exsr inz_sql ;

         exsr process ;

         exsr end_normal ;

       on-error 1211 ;
         assert (*off : 'File not open.' + w_errtxt) ;
       on-error *FILE ;
         assert (*off : 'Unexpected *FILE error' + w_errtxt) ;
       on-error *PROGRAM ;
         assert (*off : 'Unexpected *PROGRAM error' + w_errtxt) ;
       on-error ;
         assert (*off : 'Unexpected error' + w_errtxt) ;

       endmon ;

       //š----------------------------------------------------------------------
       //šProcess
       begsr process ;

         exec sql EXECUTE IMMEDIATE : i_sql ;
         sql_check() ;

       endsr ;

       //š----------------------------------------------------------------------
       //šInitialise program
       begsr inz_pgm ;
         o_return = 'INZ' ;

         w_pgmtxt = ' PGM: ' + psprogram ;
         w_jobtxt = ' JOB: '
                  + %char(psjobnbr) + '/' + %trimr(psuser) + '/' + psjobname ;
         w_errtxt = %trimr(w_pgmtxt) + w_jobtxt ;

       endsr ;

       //š----------------------------------------------------------------------
       //šInitialise SQL
       begsr inz_SQL ;

       endsr ;

       //š----------------------------------------------------------------------
       //šNormal end
       begsr end_normal ;

         o_return = *blank ;

         exsr end_pgm ;

       endsr ;

       //š----------------------------------------------------------------------
       //šAbnormal end
       begsr end_abnormal ;

         assert (*off : 'Program has ended abnormally' + w_errtxt ) ;

       endsr ;

       //š----------------------------------------------------------------------
       //šEnd the program
       begsr end_pgm ;

         *inlr = true ;
         return ;

       endsr ;

      /end-free

       //‚======================================================================
       //‚Sub-Procedures
       //‚======================================================================

       //š----------------------------------------------------------------------
       //šSQL Error Check
     p sql_check       b
     d sql_check       pi
     d nbrofrows       s             10u 0
     d errtxt          s            200a
      /free
         select;
         when %subst(SQLSTATE :1 :2) = '00' ;  //šOK

       //   exec sql get diagnostics :NbrOfRows = ROW_COUNT ;
            return ;

         when %subst(SQLSTATE :1 :2) = '01' ;  //šWarning

            exec sql get diagnostics condition 1 :errtxt = MESSAGE_TEXT ;
            return ;

         when %subst(SQLSTATE :1 :2) = '02' ;  //šNo more rows

            exec sql get diagnostics condition 1 :errtxt = MESSAGE_TEXT ;
            return ;

         when %subst(SQLSTATE :1 :2) >= '03' ;  //šError

            exec sql get diagnostics condition 1 :errtxt = MESSAGE_TEXT ;
            o_return = 'ERR:SQL' ;
            assert (*off : %trimr(errtxt) + w_errtxt ) ;
            return ;
         endsl ;
      /end-free
     p                 e


      //š-------------------------------------------------------------------
      //šTest the assertion
     p assert          b
     d assert          pi
     d  condition                      n   value
     d  message                      80a   value

     d sendescmsg      pr                  extpgm('QMHSNDPM')
     d  msgid                         7    const
     d  msgfile                      20    const
     d  msgdta                       80    const
     d  msgdtalen                    10i 0 const
     d  msgtype                      10    const
     d  msgq                         10    const
     d  msgqnbr                      10i 0 const
     d  msgkey                        4
     d  errords                      16
     d
     d errords         ds            16
     d  bytesprov                    10i 0 inz( 16 )
     d  bytesavail                   10i 0
     d  exceptionid                   7

     d msgdta          s             80
     d msgkey          s              4
     d msgtypeA        s              7
      /free

         if (not condition);
           dump(a) ;
           *inlr  = *on;
           sendescmsg ('CPF9898' : 'QCPFMSG   QSYS':
                       message : %len(message) :
                       '*ESCAPE' : '*PGMBDY' : 1 : msgkey : errords) ;
         endif;
         return ;
      /end-free
     p                 e

SQL Execute Immediate string and return a parameter

Utility to execute an SQL string and return a numeric parameter.

Mbr: SQL1_PR, Type: TXT, Text: Execute SQL string with return parm
     d execute_sql     pr                  extpgm('SQL1')

     d i_sql                       5000a         varying
     d o_nbr                         15  5
     d o_return                       7a

Mbr: SQL1, Type: SQLRPGLE, Text: SQL Execute Immediate string with return parm
      /title Execute SQL
      /if defined (*CRTBNDRPG)
     h dftactgrp(*no) actgrp(*caller)
      /endif

      //‚:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
      //šSystem
      //šTitle         Execute SQL
      //šMember        SQL1        SQLRPGLE

      //šPgmr          Andrew Newns  dd/mm/yy


      //šObjective
      //šThis program will execute a sql string and then return a single
      //šnumeric output parameter.

      //šParameters
      //šI i_sql       sql string
      //šI o_nbr       numeric value
      //šO o_return    Blank if OK

      //‚.......................................................................
      //šChanges:
      //šdd/mm/yyyy  xxnn  name
      //š.
      //‚:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

      //‚Prototypes
      //šPrototype: *ENTRY -------------------------------------------------------------------------
      /copy qrpglesrc,sql1_pr


     d execute_sql     pi
     d i_sql                       5000          varying
     d o_nbr                         15  5
     d o_return                       7a

      //šPrototype: Test assertion -----------------------------------------------------------------
     d assert          pr
     d  condition                      n   value
     d  message                      80a   value

      //šPrototype: SQL error trapping -------------------------------------------------------------
     d sql_check       pr

      //‚Data structues
      //šProgram Status ds
     dProgStatus      sds
     d PsProgram         *PROC
     d PsMsgPq           *PROC
     d PsStatus          *STATUS
     d PsRoutine         *ROUTINE
     d PsParms           *PARMS
     d PsMsgArea                     30a   overlay( progstatus:51  )
     d PsJobName                     10a   overlay( progstatus:244 )
     d PsUser                        10a   overlay( progstatus:254 )
     d PsJobNbr                       6s 0 overlay( progstatus:264 )

      //šNull indicators
     d null            ds                  qualified
     d   col01                        5i 0

      //‚Constants
     d Yes             c                   const( 'Y' )
     d No              c                   const( 'N' )
     d SQ              c                   const( x'7D' )
     d true            s               n   inz( '1' )
     d false           s               n   inz( '0' )
     d #NULL           c                   -1

      //‚Workfields
     d screen          s             10a
     d screrror        s               n
     d sqlstr          s           5000a
     d w_errtxt        s            120a
     d w_jobtxt        s            100a
     d w_pgmtxt        s             20a

      //‚Mainline
      /free
       monitor ;
         exsr inz_pgm ;
         exsr inz_sql ;

         exsr process ;

         exsr end_normal ;

       on-error 1211 ;
         assert (*off : 'File not open.' + w_errtxt) ;
       on-error *FILE ;
         assert (*off : 'Unexpected *FILE error' + w_errtxt) ;
       on-error *PROGRAM ;
         assert (*off : 'Unexpected *PROGRAM error' + w_errtxt) ;
       on-error ;
         assert (*off : 'Unexpected error' + w_errtxt) ;

       endmon ;

       //š----------------------------------------------------------------------
       //šProcess
       begsr process ;

          exec sql FETCH   c1 into :o_nbr : null.col01 ;
          sql_check() ;
          if null.col01 = #NULL ;
             o_nbr = 0 ;
          endif ;

       endsr ;

       //š----------------------------------------------------------------------
       //šInitialise program
       begsr inz_pgm ;
         o_return = 'INZ' ;

         w_pgmtxt = ' PGM: ' + psprogram ;
         w_jobtxt = ' JOB: '
                  + %char(psjobnbr) + '/' + %trimr(psuser) + '/' + psjobname ;
         w_errtxt = %trimr(w_pgmtxt) + w_jobtxt ;

       endsr ;

       //š----------------------------------------------------------------------
       //šInitialise SQL
       begsr inz_SQL ;

         exec sql PREPARE s1 from :i_sql ;
         sql_check() ;

         exec sql DECLARE c1 cursor for s1 ;
         sql_check() ;

         exec sql OPEN    c1 ;
         sql_check() ;

       endsr ;

       //š----------------------------------------------------------------------
       //šNormal end
       begsr end_normal ;

         exec sql CLOSE   c1 ;
         sql_check() ;

         o_return = *blank ;

         exsr end_pgm ;

       endsr ;

       //š----------------------------------------------------------------------
       //šAbnormal end
       begsr end_abnormal ;

         assert (*off : 'Program has ended abnormally' + w_errtxt ) ;

       endsr ;

       //š----------------------------------------------------------------------
       //šEnd the program
       begsr end_pgm ;

         *inlr = true ;
         return ;

       endsr ;

      /end-free

       //‚======================================================================
       //‚Sub-Procedures
       //‚======================================================================

       //š----------------------------------------------------------------------
       //šSQL Error Check
     p sql_check       b
     d sql_check       pi
     d nbrofrows       s             10u 0
     d errtxt          s            200a
      /free
         select;
         when %subst(SQLSTATE :1 :2) = '00' ;                               //šOK
       //   exec sql get diagnostics :NbrOfRows = ROW_COUNT ;
            return ;

         when %subst(SQLSTATE :1 :2) = '01' ;  //šWarning

            exec sql get diagnostics condition 1 :errtxt = MESSAGE_TEXT ;
            return ;

         when %subst(SQLSTATE :1 :2) = '02' ;  //šNo more rows

            exec sql get diagnostics condition 1 :errtxt = MESSAGE_TEXT ;
            return ;

         when %subst(SQLSTATE :1 :2) >= '03' ;  //šError

            exec sql get diagnostics condition 1 :errtxt = MESSAGE_TEXT ;
            o_return = 'ERR:SQL' ;
            assert (*off : %trimr(errtxt) + w_errtxt ) ;
            return ;
         endsl ;
      /end-free
     p                 e


      //š-------------------------------------------------------------------
      //šTest the assertion
     p assert          b
     d assert          pi
     d  condition                      n   value
     d  message                      80a   value

     d sendescmsg      pr                  extpgm('QMHSNDPM')
     d  msgid                         7    const
     d  msgfile                      20    const
     d  msgdta                       80    const
     d  msgdtalen                    10i 0 const
     d  msgtype                      10    const
     d  msgq                         10    const
     d  msgqnbr                      10i 0 const
     d  msgkey                        4
     d  errords                      16
     d
     d errords         ds            16
     d  bytesprov                    10i 0 inz( 16 )
     d  bytesavail                   10i 0
     d  exceptionid                   7

     d msgdta          s             80
     d msgkey          s              4
     d msgtypeA        s              7
      /free

         if (not condition);
           dump(a) ;
           *inlr  = *on;
           sendescmsg ('CPF9898' : 'QCPFMSG   QSYS':
                       message : %len(message) :
                       '*ESCAPE' : '*PGMBDY' : 1 : msgkey : errords) ;
         endif;
         return ;
      /end-free
     p                 e

Display EBCDIC character set

Utility to display wth EBCIDIC character set and to also show the decimal, hexadecimal and binary conversion.

Mbr: SYM, Type: RPGLE, Text: Display EBCDIC character set
      /title Display EBCDIC character set
     h copyright('Andrew Newns 2010')
     h option(*nodebugio:*srcstmt)
      /if defined (*CRTBNDRPG)
     h dftactgrp(*no) actgrp(*caller)
      /endif
      //š::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
      //šAndrew Newns, dd/mm/yy

      //šDisplay EBCDIC character set

      //š::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
     fsymd      cf   e             workstn extdesc('ANEWNS/SYMD')               compile time
     f                                     extfile('ANEWNS/SYMD')               run time
     f                                     prefix(scr_)
     f                                     sfile(sfl:scr_sflrrn)
     f                                     indds(indds_1)

     d cvthex          pr             2a
     d #i                            10i 0 const

     d cvtbin          pr             8a
     d #i                            10i 0 const

     d cvtchr          pr             1a
     d #c                             3u 0 const
     d bin                            8a   const

      //šDisplay File Indicator Data Structure
     d indds_1         ds
     d  ScrExit                        n   overlay( indds_1 : 03 )

     d  SflClr                         n   overlay( indds_1 : 30 )
     d  SflDsp                         n   overlay( indds_1 : 31 )
     d  SflDspCtl                      n   overlay( indds_1 : 32 )
     d  SflEnd                         n   overlay( indds_1 : 33 )
     d  SflNxtChg                      n   overlay( indds_1 : 34 )
     d  SflMsgInd                      n   overlay( indds_1 : 35 )

     d  ScrVldCmd                      n   overlay( indds_1 : 40 )

     d true            s               n   inz( *on )
     d false           s               n   inz( *off )
     d #SCREEN01       c                   const( 'SCREEN01' )
     d screen          s             10a
     D #i              s             10i 0
     d hex             s                   like(scr_hex )
     d bin             s                   like(scr_bin )
     d chr             s                   like(scr_chr )
     d SQ              c                   const(x'7D')                         Single Quote
      //š-------------------------------------------------------------------------------------------
      //šmainline
      /free
         //šClear sfl
         sflclr = true ;
         write sflctl ;
         sflclr = false ;

         sflend = false ;
         screen = #SCREEN01 ;

         //šFill sfl
         for #i = 0 to 255 ;
            scr_dec = #i ;
            scr_hex = cvthex( #i );
            scr_bin = cvtbin( #i );
            scr_chr = cvtchr( #i : scr_bin ) ;
            scr_sflrrn += 1 ;

         if #i < 64 ;
            //šhex codes lower than '40' are invalid, but can be used as display attributes
            scr_txt = 'AAA' ;
            scr_dspatr = %bitor( x'00' : scr_chr ) ;
            scr_chr = *blank ;
         else ;
            scr_txt = *blank ;
            scr_dspatr = x'20' ;
         endif ;
            write sfl ;

         endfor ;
         sflend = true ;

         //šDisplay sfl
         dow screen = #SCREEN01 ;
            write sflftr ;
            SflDsp = true ;
            SflDspCtl = true ;
            exfmt sflctl ;
            if screxit ;
               screen = *blank ;
               leave ;
            endif ;
         enddo ;

         //šEnd
         *inlr = *on ;
         return ;
      /end-free

      //š-------------------------------------------------------------------------------------------
     p cvthex          b
     d cvthex          pi             2a
     d #i                            10i 0 const

     d hex_ds          ds
     d                               16a   inz( '0123456789ABCDEF' )

     d hex_a                          1a   dim( 16 ) overlay(hex_ds)
     d hex             s              8a
     d div             s             10u 0
     d rem             s             10u 0

      /free
         div = %div(#i :16) ;
         rem = %rem(#i :16) ;
         return hex_a( div+1 ) + hex_a( rem+1 ) ;
      /end-free
     p cvthex          e

      //š-------------------------------------------------------------------------------------------
     p cvtbin          b
     d cvtbin          pi             8a
     d #i                            10i 0 const

     d bin             ds             8
     d bin_a                          1a   dim(8) overlay(bin:1)

     d rem             s             10i 0 inz( 0 )
     d #p              s             10i 0 inz( 7 )
      /free
         rem = #i ;
         bin = '00000000' ;

         for #p = 7 downto 0 by 1;
            if rem >= 2 ** #p ;
               bin_a( 8-#p ) = '1' ;
               rem -= 2 ** #p ;
            endif ;
         endfor ;

         return bin ;
      /end-free
     p cvtbin          e

      //š-------------------------------------------------------------------------------------------
     p cvtchr          b
     d cvtchr          pi             1a
     d #c                             3u 0 const
     d bin                            8a   const

     d #p              s             10i 0 inz( 7 )
     d chr             s              1a
     d x00             s              1a   inz(x'00')
     d x01             s              1a   inz(x'01')                           2[0 =   1
     d x02             s              1a   inz(x'02')                           2[1 =   2
     d x03             s              1a   inz(x'04')                           2[2 =   4
     d x04             s              1a   inz(x'08')                           2[3 =   8
     d x05             s              1a   inz(x'10')                           2[4 =  16
     d x06             s              1a   inz(x'20')                           2[5 =  32
     d x07             s              1a   inz(x'40')                           2[6 =  64
     d x08             s              1a   inz(x'80')                           2[7 = 128
      /free
         chr = x00 ;

         if %subst( bin : 1 : 1 ) = '1' ;
            chr = %bitor( chr : x08 ) ;
         endif ;
         if %subst( bin : 2 : 1 ) = '1' ;
            chr = %bitor( chr : x07 ) ;
         endif ;
         if %subst( bin : 3 : 1 ) = '1' ;
            chr = %bitor( chr : x06 ) ;
         endif ;
         if %subst( bin : 4 : 1 ) = '1' ;
            chr = %bitor( chr : x05 ) ;
         endif ;
         if %subst( bin : 5 : 1 ) = '1' ;
            chr = %bitor( chr : x04 ) ;
         endif ;
         if %subst( bin : 6 : 1 ) = '1' ;
            chr = %bitor( chr : x03 ) ;
         endif ;
         if %subst( bin : 7 : 1 ) = '1' ;
            chr = %bitor( chr : x02 ) ;
         endif ;
         if %subst( bin : 8 : 1 ) = '1' ;
            chr = %bitor( chr : x01 ) ;
         endif ;

         return chr ;

      /end-free
     p cvtchr          e

Mbr: SYMD, Type: DDS, Text: Display EBCDIC character set
     A*%%TS  SD  20101216  022353  ANEWNS      REL-V6R1M0  5761-WDS
     A*%%EC
     A                                      DSPSIZ(24 80 *DS3)
     A                                      INDARA
     A                                      PRINT
     A                                      CA03(03 'Exit')
     A*š=================================================================
     A          R SFL                       SFL
     A*%%TS  SD  20101216  022353  ANEWNS      REL-V6R1M0  5761-WDS
     A                                      TEXT('EBCDIC Subfile')
     A            DSPATR         1A  P      TEXT('Display Attributes')
     A            DEC            3S 0O  4  2
     A            HEX            2A  O  4  7
     A            BIN            8A  O  4 11
     A            CHR            1A  O  4 21
     A            TXT            3A  O  4 27DSPATR(&DSPATR)
     A*š.................................................................
     A          R SFLCTL                    SFLCTL(SFL)
     A*%%TS  SD  20101216  022353  ANEWNS      REL-V6R1M0  5761-WDS
     A                                      SFLSIZ(0999)
     A                                      SFLPAG(0018)
     A                                      TEXT('EBCDIC Subfile control')
     A                                      OVERLAY
     A  31                                  SFLDSP
     A  32                                  SFLDSPCTL
     A  30                                  SFLCLR
     A  33                                  SFLEND(*MORE)
     A            SFLRRN         4S 0H
     A                                  1  2'SYM'
     A                                      DSPATR(HI)
     A                                  1  7'Display EBCDIC character set'
     A                                      DSPATR(HI)
     A                                  3  2'Dec'
     A                                      DSPATR(HI)
     A                                  3  7'Hex'
     A                                      DSPATR(HI)
     A                                  3 11'Bin'
     A                                      DSPATR(HI)
     A                                  3 21'Char'
     A                                      DSPATR(HI)
     A                                  3 27'DspAtr'
     A                                      DSPATR(HI)
      *š---------------------------------------------------------------
     A          R SFLFTR
     A*%%TS  SD  20100823  100336  ANEWNS      REL-V6R1M0  5761-WDS
     A            SETCSR         1A  B 23  2DSPATR(ND)
     A            PUSHBTN        2Y 0B 23  4PSHBTNFLD((*GUTTER 1))
     A                                      PSHBTNCHC(1 'F3/Exit'    CA03)

Backup IBM source on PC

Utility to backup IBM source on the local PC.

Mbr: BACKUP_IBM, Type: TXT, Text: Backup IBM to PC
:http://forums.systeminetwork.com/isnetforums/showthread.php?t=106881

open SYSTEM
USER_PROFILE
PASSWORD

ascii
quote site namefmt 0
cd anewns
lcd c:\data\source

prompt off
mget qsrc.*
mget qsqlsrc.*
mget qsrvsrc.*
quit