Difference between revisions of "Snippets"

From MidrangeWiki
Jump to: navigation, search
m (reorg)
m (reorg)
Line 738: Line 738:
 
[[#top]]
 
[[#top]]
  
 
=== RPG  FTP TEMPLATE ===
 
<pre>
 
    H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
 
    H DFTACTGRP(*NO) ACTGRP(*CALLER)
 
    H Bnddir('QC2LE')
 
      //
 
      //***************************************************************
 
      //  USE  FTP TO GET OR PUT FILES TO THE IFS
 
      //  BIN(ARY) TRANSFERS ARE USED,DATA IS ASSUMED TO BE ASCII
 
      //  IT IS ASSUMED OTHER FUNCTIONS PUT OR GET FROM IFS TO DB FILES
 
      //  SENT FILES (PUT) ARE ARCHIVED TO ARCH SUBDIRECTORY IF IT EXISTS
 
        //
 
        //  REQUIRES FILES FTPADDR AND FTPMSGLOG
 
        //  (LAYOUT CAN BE INFERRED FROM THIS PGM LOGIC)  
 
      //
 
      //  PARMS  IN
 
      // D  ADDR  10A KEY TO FILE FOR USER PWORD AND FTP_ADDR
 
      // D  FDIR  40A        LCD IFS DIRECTORY OF FILE TO PUT/GET
 
      // D  TDIR  40A CD IFS DIRECTORY OF FILE TO PUT/GET
 
      // D  FN    3A PUT  OR GET
 
      // D  FFIL  40A NAME OF FILE
 
      //
 
      //  PARMS OUT
 
      // D  FERR  1A FTP FAIL IF NOT ZERO
 
      //***************************************************************
 
      //
 
      //
 
    FFTPADDR  IF  E          K DISK
 
 
    D PROFILE        S            25
 
    D FROMDIR        S            40
 
    D TODIR          S            40
 
    D FNC            S              3
 
    D FNCFILE        S            40
 
      //
 
    D RT              S            10I 0
 
    D SRCDTA          S            100
 
    D NOK            C                  -1
 
    D OK              C                  0
 
    D TCK1            C                  'TRANSFER COMPLETE'
 
      // Program Status
 
    D                SDS
 
    D  PGM                    1    10
 
    D  WSID                244    253A
 
    D  USER                254    263A
 
    D  NBR                  264    269A
 
    D  DAT                  276    281A
 
      //
 
      //
 
      //-------------------- Prototypes
 
    D FTPPGM        PR
 
    D                              10A
 
    D                              40A
 
    D                              40A
 
    D                                3A
 
    D                              40A
 
    D                                1A
 
    D FTPPGM        PI
 
    D  ADDR                        10A
 
    D  FDIR                        40A
 
    D  TDIR                        40A
 
    D  FN                            3A
 
    D  FFIL                        40A
 
    D  FERR                          1A
 
      //  FOR RUNNING AS400 COMMANDS
 
    D SYS            PR            10I 0 Extproc('system')
 
    D  CmdString                    *  Value
 
    D                                    Options(*String)
 
      //
 
    D MAIN            PR
 
    D WRKFILES        PR
 
    D LOADFTPS        PR
 
    D DOTHEFTP        PR
 
    D RMVWRKF        PR
 
    D CKTHEFTP        PR
 
    D MOVTOARCH      PR
 
    D LOGTHEFTP      PR
 
 
      /FREE
 
                MAIN();
 
      /END-FREE
 
      //
 
      //###################################################//
 
    P    MAIN        B
 
      //
 
      //***************************************************************
 
    D MAIN            PI
 
      /FREE
 
              *INLR = *ON;
 
      //
 
        WRKFILES();  // SETUP FTP WORK FILES
 
      //
 
        LOADFTPS();  // SETUP FTP COMMANDS
 
      //
 
        DOTHEFTP();  // EXECUTE THE FTP
 
      //
 
        CKTHEFTP();  // CHECK THE TRANSFER
 
      //
 
        MOVTOARCH(); // MOVE TO ARCHIVE
 
      //
 
        LOGTHEFTP(); // LOG THE FTP OUTPUT
 
      //
 
        RMVWRKF ();  // CLEANUP THE WORK FILES
 
      RETURN;
 
      //###################################################//
 
      /END-FREE
 
    P    MAIN        E
 
      //
 
      //###################################################//
 
    P  WRKFILES      B
 
      /FREE
 
      RT  = SYS('DLTF  QTEMP/INPUT');
 
      RT  = SYS('DLTF  QTEMP/OUTPUT');
 
      RT  = SYS('CRTSRCPF  QTEMP/INPUT MBR(*FILE)');
 
      RT  = SYS('CRTSRCPF  QTEMP/OUTPUT MBR(*FILE)');
 
      RT  = SYS('OVRDBF INPUT  QTEMP/INPUT OVRSCOPE(*JOB)');
 
      RT  = SYS('OVRDBF OUTPUT  QTEMP/OUTPUT OVRSCOPE(*JOB)');
 
      /END-FREE
 
    P  WRKFILES      E
 
      //
 
      //###################################################//
 
    P  LOADFTPS      B
 
      /FREE
 
          FERR = '0';
 
          CHAIN ADDR  FTPADDR;
 
            IF NOT %FOUND;
 
                FERR = '1';
 
                RETURN;
 
              ENDIF;
 
        //
 
          PROFILE = FTUSER + ' ' + FTPASS;
 
          FROMDIR = FDIR;
 
          TODIR  = TDIR;
 
          FNCFILE = FFIL;
 
          FNC    = FN;
 
        //
 
        EXEC SQL SET OPTION COMMIT =*NONE;
 
        //
 
        EXEC SQL
 
        INSERT INTO  INPUT  VALUES
 
        (0,0 , :PROFILE                            ) ,
 
        (0,0 , 'NAMEFMT 1          '                ) ,
 
        (0,0 , 'LCD ' || :FROMDIR                  ) ,
 
        (0,0 , 'CD '  || :TODIR                    ) ,
 
        (0,0 , 'BIN '                              ) ,
 
        (0,0 , :FNC ||' ' || :FNCFILE              ) ,
 
        (0,0 , 'CLOSE '                            ) ,
 
        (0,0 , 'QUIT'                              ) ;
 
        //
 
        IF  sqlstt <> '00000';
 
                FERR = '2';
 
                RETURN;
 
        ENDIF;
 
      /END-FREE
 
    P  LOADFTPS      E
 
      //
 
      //###################################################//
 
    P  DOTHEFTP      B
 
      /FREE
 
        IF  FERR <> '0';
 
          RETURN;
 
        ENDIF;
 
      RT  = SYS('FTP ' + FTADDR );
 
      /END-FREE
 
    P  DOTHEFTP      E
 
      //
 
      //###################################################//
 
    P  CKTHEFTP      B
 
      /FREE
 
          EXEC SQL                                     
 
SELECT SRCDTA into :SRCDTA FROM OUTPUT WHERE 
 
  UPPER(SRCDTA)  like  '%TRANSFER COMPLETE%'       
 
  FETCH FIRST 1 ROW ONLY ;     
 
        //   
 
        IF  sqlstt <> '00000';
 
                FERR = '3';
 
                RETURN;
 
        ENDIF;
 
      /END-FREE
 
    P  CKTHEFTP      E
 
      //
 
      //###################################################//
 
    P  MOVTOARCH      B
 
      /FREE
 
        IF  FERR <> '0';
 
          RETURN;
 
        ENDIF;
 
        //  ONLY ARCHIVE THE SENT FILES  (PUT)
 
        IF  FNC  =  'GET';
 
          RETURN;
 
        ENDIF;
 
      RT  = SYS('MOV OBJ(''' + %TRIM(FROMDIR) +
 
                          %TRIM(FNCFILE) +  ''') ' +
 
                'TODIR('''+ %TRIM(FROMDIR) + 'ARCH'')') ;
 
      /END-FREE
 
    P  MOVTOARCH      E
 
      //
 
      //###################################################//
 
    P  LOGTHEFTP      B
 
      /FREE
 
        EXEC SQL
 
        INSERT INTO FTPMSGLOG
 
        (SELECT :WSID, :USER,:NBR, :DAT, SRCDTA FROM OUTPUT) ;
 
      /END-FREE
 
    P  LOGTHEFTP      E
 
      //
 
      //###################################################//
 
    P  RMVWRKF        B
 
      /FREE
 
      RT  = SYS('DLTF  QTEMP/INPUT');
 
      RT  = SYS('DLTF  QTEMP/OUTPUT');
 
      RT  = SYS('DLTOVR  INPUT LVL(*JOB)');
 
      RT  = SYS('DLTOVR  OUTPUT LVL(*JOB)');
 
      /END-FREE
 
    P  RMVWRKF        E
 
</pre>
 
 
[[#top]]
 
 
 
=== RPG  IFS READ TEMPLATE ===
 
<pre>
 
H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
 
    H DFTACTGRP(*NO ) ACTGRP(*CALLER)
 
  >
 
  >  *  RPGLE  IFSREADR  CHECK the files in a directory
 
  >  *  If the file exists it needs to be PROCESSED
 
  >  *
 
      *
 
      *  PARMS IN
 
      *  prefix  10 chr  10 character prefix to find a file
 
      *  path    256 chr  the path on the IFS to check 
 
      *
 
 
 
      *
 
    D p_old_dir      s              *
 
    D old_dir        s            256A
 
    D p_new_dir      s              *
 
    D new_dir        s            256A
 
 
    d* a few local variables...
 
    D dh              S              *
 
    D PathName        S            256A
 
    D Name            S            256A
 
    D cl              S            10U 0
 
    D @loop          S              1A
 
    D NameF          S            64A
 
    D Suff            S              3A
 
    D x              S              9P 0
 
    D prefixv        S            10A  varying
 
 
  >
 
      //-------------------- Prototypes
 
    D MAIN            PR
 
    D WRKFILES        PR
 
 
    D IFSREADR        PR
 
    D                              10A
 
    D                              256A
 
    D IFSREADR        PI
 
    D  prefix                      10A
 
    D  PATH                        256A
 
 
 
 
      *
 
    d**********************************************************************
 
    d*
 
    d* Directory Entry Structure (dirent)
 
    d*
 
    d* struct dirent {
 
    d*  char          d_reserved1[16];  /* Reserved                      */
 
    d*  unsigned int  d_reserved2;      /* Reserved                      */
 
    d*  ino_t          d_fileno;        /* The file number of the file    */
 
    d*  unsigned int  d_reclen;        /* Length of this directory entry
 
    d*                                    * in bytes                      */
 
    d*  int            d_reserved3;      /* Reserved                      */
 
    d*  char          d_reserved4[8];  /* Reserved                      */
 
    d*  qlg_nls_t      d_nlsinfo;        /* National Language Information
 
    d*                                    * about d_name                  */
 
    d*  unsigned int  d_namelen;        /* Length of the name, in bytes
 
    d*                                    * excluding NULL terminator      */
 
    d*  char          d_name[_QP0L_DIR_NAME]; /* Name...null terminated  */
 
    d*
 
    d* };
 
 
    D p_dirent        s              *
 
    D dirent          ds                  based(p_dirent)
 
    D  d_reserv1                  16A
 
    D  d_reserv2                  10U 0
 
    D  d_fileno                    10U 0
 
    D  d_reclen                    10U 0
 
    D  d_reserv3                  10I 0
 
    D  d_reserv4                    8A
 
    D  d_nlsinfo                  12A
 
    D    nls_ccsid                10I 0 OVERLAY(d_nlsinfo:1)
 
    D    nls_cntry                  2A  OVERLAY(d_nlsinfo:5)
 
    D    nls_lang                  3A  OVERLAY(d_nlsinfo:7)
 
    D    nls_reserv                3A  OVERLAY(d_nlsinfo:10)
 
    D  d_namelen                  10U 0
 
    D  d_name                    640A
 
 
    d*--------------------------------------------------------------------
 
    d* Open a Directory
 
    d* DIR *opendir(const char *dirname)
 
    D opendir        PR              *  EXTPROC('opendir')
 
    D  dirname                        *  VALUE
 
 
    d*--------------------------------------------------------------------
 
    d* Read Directory Entry
 
    d* struct dirent *readdir(DIR *dirp)
 
    D readdir        PR              *  EXTPROC('readdir')
 
    D  dirp                          *  VALUE
 
 
 
    d*--------------------------------------------------------------------
 
    d* Close  Directory
 
    d* int closedir(DIR *dirp)
 
    D closedir        PR            10U 0 EXTPROC('closedir')
 
    D  cldirp                        *  VALUE
 
 
 
      /FREE
 
                MAIN();
 
      /END-FREE
 
 
      //###################################################//
 
    P    MAIN        B
 
      /FREE
 
          *inlr = '1' ;
 
          prefixv = %trim(prefix);
 
 
      // Step1: Open up the directory.
 
              PathName= %trim(PATH)+ x'00';
 
              dh = opendir(%addr(PathName));
 
 
      // Step2: Read each entry from the directory
 
          dow      @loop = @loop;
 
                p_dirent = readdir(dh);
 
                  if      p_dirent =  *NULL;
 
                    leave;
 
                  endif;
 
 
                  Name = %subst(d_name:1:d_namelen);
 
      // not a file
 
          If Name = '. ' or Name = '.. ' ;
 
            Iter;
 
          Endif;
 
 
      // Strip the suffix
 
            Namef = %subst(Name:1:10);
 
            x  = %scan('.':Name:1);
 
            If x > 1;
 
            NameF = %subst(Name:1:x-1);
 
            EndIf;
 
      // not a file  (assume names without suff are not files)
 
            If x < 2;
 
            Iter;
 
            Endif;
 
      // Get the suffix
 
            Suff  = %trim(%subst(Name:x+1));
 
 
 
      //  PROCESS  THE FILE
 
 
          WRKFILES();
 
 
 
          EndDo;
 
 
      // Step3: Close  the directory.
 
              cl = closedir(dh);
 
      /END-FREE
 
 
    P    MAIN        E
 
 
 
      //###################################################//
 
    P    WRKFILES    B
 
 
    D FTPPROC        PR                  EXTPGM('FTPPGM')
 
    D                              10A  CONST
 
    D                              40A  CONST
 
    D                              40A  CONST
 
    D                                3A  CONST
 
    D                              40A  CONST
 
    D                                1A
 
 
    D WC011R          PR                  EXTPGM('WC011R')
 
    D                              10A  CONST
 
    D                              10A  CONST
 
    D                              10A  CONST
 
    D                              256A  CONST
 
    D                                1A
 
 
    D  ADDR          s            10A
 
    D  FDIR          s            40A
 
    D  TDIR          s            40A
 
    D  FFIL          s            40A
 
    D  FERR          s              1A
 
    D  CDATA        s            256A
 
    D  ERR          s              1A
 
    D  @@ENV        S              4A
 
      /FREE
 
            x  = %scan(prefixv:NameF:1);
 
 
            If x = 1;
 
        //  Found a file matching the pre fix
 
 
          ADDR = 'CAR';
 
          FFIL =  NAME;
 
        //  GET A DIR FOR A CONTROL FILE
 
        WC011R ('INVC  ':'COMPY1  ':'LOC  ': CDATA: ERR) ;
 
          TDIR =  CDATA;
 
 
          FDIR  =  %TRIM(PATH);
 
 
 
        IF (ERR = 'N') ;
 
        //  FTP SEND THE FILE
 
        FTPPROC    ( ADDR : FDIR : TDIR :'PUT': FFIL : FERR );
 
        ENDIF;
 
 
            EndIf;
 
 
      /END-FREE
 
    P    WRKFILES    E
 
 
 
</pre>
 
 
[[#top]]
 
 
 
 
=== RPG  SUBFILE  TEMPLATE ===
 
<pre>
 
   
 
 
This is a demo RPG subfile processing program.
 
It can be used as a template.
 
 
Except for the viewing SFL (S05),it uses the simplest subfile method where
 
number of SflRcds is limited to 9999.
 
SFL (S05) does a page at a time via a preloaded auto extending User Space.
 
 
For messages does NOT use message subfiles.
 
IMO message SFL are an overkill.
 
How often have you done or seen done, a position to the MSGSFL messages and scroll.
 
Users deal with one message at a time then press enter, hence the first error
 
encountered is sent to the user, and so on.
 
 
Indicators for positioning the cursor to the error are NOT used.
 
CSRLOC keywords are used.  An API converts FIELD NAMES to the row/col which is
 
what IBM should have done in the first place, instead of forcing the hard
 
coding of row, col.
 
Indicators are used sparingly, mainly for Display file interaction  F keys &
 
SFL CTL.  Two indicators 88 89 are used to flag an error.
 
A trick with Cursor Positioning is used, because if an ERRMSG type keyword is
 
actioned IBM will not position the cursor, so 88 controls a write to pos the cur
 
then 89 is done to show the message.
 
 
 
This statement is at the heart of the logic.
 
One issue with multi screen processing is the way the program logic digs itself
 
into ever deeper layers. If you know what this means then it may be of interest
 
that this programs structure only goes down ONE level, even though the program
 
seems to drop through level after level.
 
This is achieved by a looping structure and an array that carries the 'logical'
 
level. F12 will seem to step backwards through many program levels.
 
Array SCN is dimmed at 99 but this can be whatever you need.
 
To get from one screen to another the logic MUST always drop back to the
 
controlling procedure (MAIN) and tell (MAIN) what is the next panel to display.
 
 
Each subfile needs 3 procedures,  BLD  PRC and PRS.
 
BLD loads the subfile.  PRC drives the SFLCTL. PRS processes the SFL lines.
 
The SFL lines are never used as 'data entry/maintenance' rather an Option
 
brings up a Display Record panel for the actual data manipulation.
 
 
 
 
      //***************************************************************
 
      //  THIS PROGRAM ONLY GOES 1 LEVEL DOWN IN ITS CALL STRUCTURE
 
      //  Each panel is precessed by its own procedure.
 
      //  A driving procdeure  then calls the panels procedure.
 
      //  The user will see that there are many panels on top
 
      //  of each other by pressing CF12, but this is a LOGICAL
 
      //  structure ONLY, controlled by the levels array SCN.
 
      //  The TOP level in SCN will contain *END and when reached
 
      //  will cause the program to end.
 
 
 
 
    H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
 
    H DFTACTGRP(*NO) ACTGRP(*CALLER)
 
    H Bnddir('QC2LE')
 
      //***************************************************************
 
      //
 
      //  PROGRAM ID : USEDPRODRU
 
      //  Description: Entry of PRODUCT  Usage
 
 
      //
 
      //***************************************************************
 
      // MODIFICATIONS:
 
      // MOD  SR  DATE    MODIFICATION SUMMARY
 
      //
 
      //***************************************************************
 
      //
 
      //
 
    FPCODES    UF A E          K DISK
 
    FUSEDPROD  UF A E          K DISK
 
    FUSEDPROD1 IF  E          K DISK
 
    F                                    RENAME(PUP100:PUP101)
 
      //
 
    FUSEDPRODFPCF  E            WORKSTN
 
    F                                    INFDS(SFINF)
 
    F                                    SFILE(S02:RS02)
 
    F                                    SFILE(S05:RS05)
 
    F                                    SFILE(S06:RS06)
 
    F                                    SFILE(S08:RS08)
 
    F                                    SFILE(S09:RS09)
 
 
 
    D COMPANY        S              3S 0  DTAARA
 
    D DBLIB          S            10    DTAARA
 
      //  SCREEN LEVELS
 
    D @SCN            S              6    DIM(99)
 
    D @NSCN          S              6
 
    D @LV            S              5  0
 
    D @ERR            S                  LIKE(@TRUE)
 
    D @FILE          S            10A  INZ('USEDPRODFP')
 
    D WRKSWS          S              1
 
 
    D L08KEY          S                  LIKE(S08KEY)
 
 
    D @TRUE          S              1A  INZ('1')
 
    D @FALSE          S              1A  INZ('0')
 
    D @LOOP          S                  LIKE(@TRUE )
 
    D @OK            S                  LIKE(@TRUE )
 
 
      //
 
    D RS02            S              4S 0
 
    D RS05            S              4S 0
 
    D RS06            S              4S 0
 
    D RS08            S              4S 0
 
    D RS09            S              4S 0
 
      //
 
      // PARMS FOR SFL LOOPING
 
    D SFC02          S                  LIKE(RS02)
 
    D SFC05          S                  LIKE(RS05)
 
    D SFC06          S                  LIKE(RS06)
 
    D SFC08          S                  LIKE(RS08)
 
    D SFC09          S                  LIKE(RS09)
 
 
    D RCD05          S            12  0
 
      // Program Status
 
    D                SDS
 
    D  PGM                    1    10
 
    D  WSID                244    253
 
    D  USER                254    263
 
      //
 
    D PCSTKEY        DS                  likerec(PCP100  : *key)
 
    D PUSTKEY        DS                  likerec(PUP100  : *key)
 
    D PUSTKY1        DS                  likerec(PUP101  : *key)
 
      //
 
    D S05DTA          DS                  likerec(S05 : *OUTPUT)
 
      //  MESSAGE DATA
 
    D @DTA1          DS            80
 
    D @DTA2          DS          500
 
      //
 
    D SFINF          DS
 
    D  RRRN                376    377B 0
 
    D  SRN                  378    379B 0
 
      //
 
    D WFLDS          DS                  OCCURS(999)
 
    D  FNAME                        10
 
    D  FTYP                          1
 
    D  FLEN                        10i 0
 
    D  FDEC                        10i 0
 
 
    D  SDATA        DS            80
 
    D    SFMT                17    17
 
    D    SNAME              19    28
 
    D    SLEN                32    34S 0
 
    D    STYP                35    35
 
    D    SDEC                36    37
 
 
      //  FOR RUNNING AS400 COMMANDS
 
    D RT              S            10I 0
 
    D SYS            PR            10I 0 Extproc('system')
 
    D  CmdString                    *  Value
 
    D                                    Options(*String)
 
 
      //
 
    D MAIN            PR
 
    D @R01            PR
 
    D @R03            PR
 
    D @R04            PR
 
    D @S02BLD        PR
 
    D @S02PRC        PR
 
    D @S02PRS        PR
 
    D @S05BLD        PR
 
    D @S05PRC        PR
 
    D @S06BLD        PR
 
    D @S06PRC        PR
 
    D @S06PRS        PR
 
    D @R07            PR
 
    D @S08BLD        PR
 
    D @S08PRC        PR
 
    D @S08PRS        PR
 
    D @S09BLD        PR
 
    D @S09PRC        PR
 
    D
 
    D @R9999          PR
 
 
    D @OPADJ          PR            2A
 
    D  OPT                          2A
 
 
      *-------------------------------------------------------------------
 
      * QMHRTVM API (Retrieve Message text)
 
      *-------------------------------------------------------------------
 
    D  RtvMsgTxt      PR          1024
 
    D  RMsgId                      7    Const
 
    D  RMsgFle                    10    Const
 
    D  RMsgLib                    10    Const
 
    D  RMsgLvl                      1    Const
 
 
    D GETROWCOL      PR
 
    D                              10A  const
 
    D                              10A  const
 
    D                              10A  const
 
    D                              32A  const
 
    D                                3P 0
 
    D                                3P 0
 
 
    D SysDate        PR            8S 0
 
    D SysTime        PR            6S 0
 
    D DayOfWeek      PR            10I 0
 
    D                                D  value datfmt(*iso)
 
      // Message file names
 
    D  cMsgLib        C                  Const('*LIBL    ')
 
    D  cMsgF1        C                  Const('MSGF1  ')
 
    D  cMsgF2        C                  Const('MSGF2    ')
 
    D  cMsgLvl1      C                  Const('1')
 
    D  cMsgLvl2      C                  Const('2')
 
 
 
 
 
 
      /FREE
 
                MAIN();
 
                *INLR = *ON;
 
 
 
      //--------------*INZSR-------------------------------//
 
      BEGSR  *INZSR;
 
 
        //  Get Company
 
          CMPNO = 0;
 
        IN  COMPANY;
 
          CMPNO = COMPANY;
 
 
        @LOOP = @TRUE;
 
        @OK  = @TRUE;
 
        @LV = 1;
 
        @SCN(@LV)  = '*END  ';
 
        @LV = @LV + 1;
 
        @SCN(@LV) = 'R01    ';
 
 
      ENDSR;
 
 
      /END-FREE
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
 
        //*************************************************************
 
    P    MAIN        B
 
 
    D MAIN            PI
 
 
 
      /FREE
 
          EXSR @INZSR;
 
      //
 
      DOW @LOOP = @LOOP;
 
 
          @NSCN  = @SCN(@LV);
 
          SELECT;
 
            //  PROMPT FOR A DATE
 
            //  F6 TO MAINTAIN PRODUCT CODES
 
          WHEN    @NSCN = 'R01  ';
 
            @R01();
 
 
            // SFL TO MAINTAIN PRODUCT USAGE
 
          WHEN    @NSCN = 'S02BLD';
 
            @S02BLD();
 
          WHEN    @NSCN = 'S02PRC';
 
            @S02PRC();
 
          WHEN    @NSCN = 'S02PRS';
 
            @S02PRS();
 
 
            // RCD TO ADD  PRODUCT  USAGE
 
          WHEN    @NSCN = 'R03';
 
            @R03();
 
 
            // RCD TO CHG  PRODUCT  USAGE
 
          WHEN    @NSCN = 'R04';
 
            @R04();
 
 
            // SFL TO VIEW PRODUCT  USAGE (WITH POSN)
 
          WHEN    @NSCN = 'S05BLD';
 
            @S05BLD();
 
          WHEN    @NSCN = 'S05PRC';
 
            @S05PRC();
 
 
            // SFL TO MAINTAIN PRODUCT  CODES
 
          WHEN    @NSCN = 'S06BLD';
 
            @S06BLD();
 
          WHEN    @NSCN = 'S06PRC';
 
            @S06PRC();
 
          WHEN    @NSCN = 'S06PRS';
 
            @S06PRS();
 
 
            // RCD TO ADD  PRODUCT  CODE
 
          WHEN    @NSCN = 'R07';
 
            @R07();
 
 
            // SFL WDW TO LOOKUP PRODUCT  CODES
 
          WHEN    @NSCN = 'S08BLD';
 
            @S08BLD();
 
          WHEN    @NSCN = 'S08PRC';
 
            @S08PRC();
 
          WHEN    @NSCN = 'S08PRS';
 
            @S08PRS();
 
 
            // SFL FOR DEL PRODUCT  CODES (WITH VALIDATION)
 
          WHEN    @NSCN = 'S09BLD';
 
            @S09BLD();
 
          WHEN    @NSCN = 'S09PRC';
 
            @S09PRC();
 
 
          OTHER;
 
            //  CATCH ALL (NEVER USED)
 
            @R9999();
 
            LEAVE;
 
          ENDSL;
 
 
          //  CF3 EXIT
 
        IF *IN03 = *ON;
 
          LEAVE;
 
        ENDIF;
 
 
      //  CF12 PREVIOUS
 
        IF *IN12 = *ON;
 
        *IN12 = *OFF;
 
        @LV      = @LV -1;
 
        @NSCN    = @SCN(@LV);
 
        ENDIF;
 
 
        //  Backed out to last level, Exit
 
        IF @NSCN = '*END';
 
          LEAVE;
 
        ENDIF;
 
        //
 
      ENDDO;
 
      //
 
      RETURN;
 
      //
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
          @NSCN = *BLANK;
 
        ENDSR;
 
      /END-FREE
 
    P    MAIN        E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
 
    P @R01            B
 
      *
 
 
    D @R01            PI
 
 
    D @DAYNO          S            10I 0
 
    D @FORMAT        S            10    INZ('R01')
 
 
      //
 
 
      /free
 
          EXSR @INZSR;
 
 
          EXSR BLD;
 
          DOW    @LOOP  = @LOOP;
 
 
          EXFMT  R01;
 
      // setoff errors
 
          @ERR = @FALSE;
 
          *IN88 = *OFF;
 
          *IN89 = *OFF;
 
          ROW01 = 999;
 
          COL01 = 999;
 
      //Exit and Previous Screen
 
          IF        (*IN03 = *ON) or
 
                    (*IN12 = *ON);
 
                        Leave;
 
          ENDIF;
 
      // Create
 
          IF        (*IN06 = *ON) ;
 
            @LV = @LV +1;
 
            @SCN(@LV) = 'S06BLD';
 
            LEAVE;
 
          ENDIF;
 
      // View
 
          IF        (*IN07 = *ON) ;
 
            @LV = @LV +1;
 
            @SCN(@LV) = 'S05BLD';
 
            LEAVE;
 
          ENDIF;
 
 
        //  Validate the data
 
          EXSR      VAL;
 
          IF        @Err = @True;
 
                    *IN88 = *ON ;
 
                    *IN89 = *OFF;
 
                    WRITE R01;
 
                    *IN89 = *ON;
 
                    ITER;
 
          ELSE;
 
          WRITE R01;
 
            @LV = @LV +1;
 
            @SCN(@LV) = 'S02BLD';
 
            LEAVE;
 
          ENDIF;
 
 
          ENDDO;
 
 
      //
 
      RETURN;
 
 
 
      //--------------  CLR -------------------------------//
 
        BEGSR    CLR;
 
 
        CLEAR  R01MTH ;
 
 
        ENDSR;
 
 
      //--------------  BLD -------------------------------//
 
        BEGSR    BLD;
 
 
 
        ENDSR;
 
 
      //--------------  VAL -------------------------------//
 
        BEGSR    VAL;
 
 
          DOW    @LOOP  = @LOOP;
 
 
        // VALID DATE
 
        TEST(DE) *ISO  R01MTH;
 
        IF %error;
 
          @ERR  =  @TRUE ;
 
          GETROWCOL  (@FILE :'*LIBL' : @FORMAT : 'R01MTH': ROW01:COL01);
 
          R01MSG = RtvMsgTxt('MSG0001':cMsgF2:cMsgLib:cMsgLvl1);
 
          LEAVE;
 
        ENDIF;
 
 
        // SATURDAY
 
 
        @DAYNO =  DayOfWeek(%DATE(R01MTH:*ISO));
 
        IF @DAYNO <> 6;
 
          @ERR  =  @TRUE ;
 
          GETROWCOL  (@FILE :'*LIBL' : @FORMAT : 'R01MTH': ROW01:COL01);
 
          R01MSG = 'DATE MUST BE A SATURDAY';
 
          LEAVE;
 
        ENDIF;
 
 
          LEAVE;
 
 
 
          ENDDO;
 
          ENDSR;
 
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
 
        ENDSR;
 
      /END-FREE
 
    P @R01            E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
      /space 3
 
    P @S02BLD        B
 
 
    D @S02BLD        PI
 
 
          //  LOAD  PRODUCTS PANEL
 
          //
 
          //  Build/Rebuild the subfile
 
 
      /FREE
 
 
          EXSR @INZSR;
 
 
        // SAVKEY = *Blanks;
 
        EXSR BLD;
 
 
        //  SFL IS BUILT, PROCESS CONTROL RCD
 
          @LV = @LV + 1;
 
          @SCN(@LV) = 'S02PRC ';
 
      RETURN;
 
      //--------------  BLD -------------------------------//
 
      BEGSR  BLD;
 
 
        C02MTH = R01MTH;
 
        EXSR CLR;
 
 
          PUSTKEY.PUSDAT=  %DATE(R01MTH:*ISO );
 
 
          SETLL  %kds(PUSTKEY:1) PUP100 ;
 
 
          DOW @LOOP = @LOOP;
 
          READE  %kds(PUSTKEY:1) PUP100 ;
 
          IF %EOF;
 
          LEAVE;
 
          ENDIF;
 
 
        EXSR MOV;
 
 
        //
 
          RS02  = RS02 + 1;
 
        WRITE S02;
 
          ENDDO;
 
 
        // Position to TOP of subfile
 
          SRS02 = 1;
 
          SFC02 = RS02;
 
        ENDSR;
 
 
      //--------------  CLR -------------------------------//
 
        BEGSR  CLR;
 
          *IN51 = *OFF;
 
          *IN52 = *OFF;
 
          *IN53 = *ON;
 
          WRITE C02;
 
          *IN53 = *OFF;
 
          RS02 =0;
 
          SFC02=0;
 
          S02OPT=*BLANK;
 
        ENDSR;
 
 
      //--------------  MOV -------------------------------//
 
        BEGSR  MOV;
 
        //  Load the subfile record
 
 
          S02OPT = *BLANK;
 
          S02KEY =  PUSKY;
 
          S02CT  =  PUSCT;
 
          S02CT2 =  PUSCT2;
 
          S02QTY =  PUSQTY;
 
 
          PCSTKEY.PCSKY = PUSKY  ;
 
          CHAIN  %kds(PCSTKEY) PCP100 ;
 
          S02PRD =  PCDSC;
 
 
 
        ENDSR;
 
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
          @NSCN = *BLANK;
 
        ENDSR;
 
 
      /END-FREE
 
    P @S02BLD        E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
      /space 3
 
    P @S02PRC        B
 
 
    D @S02PRC        PI
 
 
          //
 
          //
 
    D WRKRC          S              4S 0
 
 
      /FREE
 
 
          EXSR @INZSR;
 
 
        WRITE R02;
 
 
      //
 
      DOW @LOOP = @LOOP;
 
 
          //
 
          // Write SFL Control
 
          IF SFC02 > 0;
 
            *IN51 = *ON;
 
          ENDIF;
 
          *IN52 = *ON;
 
          EXFMT C02;
 
          //
 
          //  Setoff errors
 
          *IN89 = *OFF;
 
          //
 
          //  Exit and Previous Screen
 
          IF *IN03 = *ON;
 
            LEAVE;
 
          ENDIF;
 
 
          IF *IN12 = *ON;
 
          @LV = @LV -1;
 
            LEAVE;
 
          ENDIF;
 
 
          IF *IN06 = *ON;
 
          @LV = @LV +1;
 
            @SCN(@LV) = 'R04  ';
 
            LEAVE;
 
          ENDIF;
 
 
        //  Process the subfile
 
            @LV = @LV + 1;
 
            @SCN(@LV) = 'S02PRS';
 
            LEAVE;
 
 
      ENDDO;
 
      //
 
      RETURN;
 
 
      /space 3
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
 
          @NSCN = *BLANK;
 
        ENDSR;
 
      /END-FREE
 
    P @S02PRC        E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
      /space 3
 
    P @S02PRS        B
 
 
    D @S02PRS        PI
 
 
          //
 
          //
 
    D WRKRC          S              4S 0
 
 
      /FREE
 
 
          EXSR @INZSR;
 
 
      //
 
 
        //  Process the subfile
 
        EXSR SFL;
 
      //
 
      RETURN;
 
 
 
 
      //--------------  SFL -------------------------------//
 
        BEGSR  SFL;
 
        //  Process the subfile
 
 
 
        FOR WRKRC = 1 TO SFC02+1;
 
          CHAIN WRKRC S02;
 
            IF NOT %FOUND;
 
        //  Finished with the subfile
 
        //  RETURN TO REBUILD LEVEL
 
            @LV = @LV -2;
 
            LEAVE;
 
            ENDIF;
 
 
        //    RIGHT ADJUST OPTION
 
          S02OPT  = @OPADJ(S02OPT);
 
 
          SELECT;
 
            // WORK WITH
 
          WHEN S02OPT = ' 2';
 
            @LV = @LV +1;
 
            @SCN(@LV) =  'R03';
 
            S02OPT = *blank;
 
            UPDATE S02;
 
            LEAVE;
 
            //
 
          OTHER;
 
            S02OPT = *blank;
 
            UPDATE S02;
 
          ENDSL;
 
          //
 
        ENDFOR;
 
        //
 
        ENDSR;
 
      //---------------------------------------------------//
 
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
 
          @NSCN = *BLANK;
 
        ENDSR;
 
      /END-FREE
 
    P @S02PRS        E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
      /space 3
 
    P @R03            B
 
      *
 
 
 
    D @R03            PI
 
 
    D @FORMAT        S            10    INZ('R03')
 
 
      //
 
 
      /free
 
          EXSR @INZSR;
 
 
          EXSR BLD;
 
          DOW    @LOOP  = @LOOP;
 
 
          EXFMT  R03;
 
      // setoff errors
 
          @ERR = @FALSE;
 
          *IN88 = *OFF;
 
          *IN89 = *OFF;
 
          ROW03 = 999;
 
          COL03 = 999;
 
      //Exit and Previous Screen
 
          IF        (*IN03 = *ON) or
 
                    (*IN12 = *ON);
 
                        Leave;
 
          ENDIF;
 
 
        //  Validate the data
 
          EXSR      VAL;
 
          IF        @Err = @True;
 
                    *IN88 = *ON ;
 
                    *IN89 = *OFF;
 
                    WRITE R03;
 
                    *IN89 = *ON;
 
                    ITER;
 
          ELSE;
 
          WRITE R03;
 
          ENDIF;
 
 
      //UPDATE  Previous Screen
 
          IF        (*IN06 = *ON);
 
              EXSR      UPD;
 
              @LV = @LV -1 ;
 
              Leave;
 
          ENDIF;
 
          ENDDO;
 
 
      //
 
      RETURN;
 
 
      //---------------------------------------------------//
 
 
      //--------------  CLR -------------------------------//
 
        BEGSR    CLR;
 
 
        CLEAR  R03QTY ;
 
 
        ENDSR;
 
 
      //--------------  BLD -------------------------------//
 
        BEGSR    BLD;
 
 
        R03KEY =  S02KEY ;
 
        R03MTH =  C02MTH ;
 
        R03PRD =  S02PRD ;
 
        R03QTY =  S02QTY ;
 
        R03CT  =  S02CT  ;
 
        R03CT2 =  S02CT2 ;
 
 
        ENDSR;
 
 
      //--------------  VAL -------------------------------//
 
        BEGSR    VAL;
 
 
          DOW    @LOOP  = @LOOP;
 
          LEAVE;
 
          ENDDO;
 
          ENDSR;
 
 
      //--------------  UPD -------------------------------//
 
        BEGSR    UPD;
 
 
          PUSTKEY.PUSDAT= %DATE(R03MTH : *ISO);
 
          PUSTKEY.PUSKY = R03KEY;
 
          PUSTKEY.PUSCT = R03CT ;
 
          PUSTKEY.PUSCT2= R03CT2;
 
          CHAIN  %kds(PUSTKEY) PUP100 ;
 
          IF  %FOUND;
 
            PUSQTY = R03QTY;
 
            UPDATE    PUP100;
 
          ELSE;
 
            PUSDAT =  %DATE(R03MTH : *ISO);
 
            PUSCT  =  R03CT ;
 
            PUSCT2 =  R03CT2;
 
            PUSKY  =  R03KEY;
 
            PUSQTY =  R03QTY;
 
            WRITE    PUP100;
 
          ENDIF;
 
 
        ENDSR;
 
 
 
 
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
 
        ENDSR;
 
      /END-FREE
 
    P @R03            E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
      /space 3
 
    P @R04            B
 
      *
 
 
 
    D @R04            PI
 
 
    D @FORMAT        S            10    INZ('R04')
 
 
      //
 
 
      /free
 
          EXSR @INZSR;
 
 
          EXSR BLD;
 
          DOW    @LOOP  = @LOOP;
 
 
          EXFMT  R04;
 
      // setoff errors
 
          @ERR = @FALSE;
 
          *IN88 = *OFF;
 
          *IN89 = *OFF;
 
          ROW04 = 999;
 
          COL04 = 999;
 
      //Exit and Previous Screen
 
          IF        (*IN03 = *ON) or
 
                    (*IN12 = *ON);
 
                        Leave;
 
          ENDIF;
 
      //Lookup Product
 
          IF        (*IN04 = *ON);
 
            @LV = @LV +1;
 
            @SCN(@LV) = 'S08BLD';
 
              Leave;
 
          ENDIF;
 
 
        //  Validate the data
 
          EXSR      VAL;
 
          IF        @Err = @True;
 
                    *IN88 = *ON ;
 
                    *IN89 = *OFF;
 
                    WRITE R04;
 
                    *IN89 = *ON;
 
                    ITER;
 
          ELSE;
 
          WRITE R04;
 
          ENDIF;
 
 
      //UPDATE  Previous Screen
 
          IF        (*IN06 = *ON);
 
              EXSR      UPD;
 
              @LV = @LV -2 ;
 
              Leave;
 
          ENDIF;
 
          ENDDO;
 
 
      //
 
      RETURN;
 
 
      //--------------  CLR -------------------------------//
 
        BEGSR    CLR;
 
 
 
        ENDSR;
 
 
      //--------------  BLD -------------------------------//
 
        BEGSR    BLD;
 
 
        IN  DBLIB;
 
          R04CT = %subst(DBLIB:2:2);
 
          R04PRD = *BLANK;
 
          R04MTH = C02MTH;
 
 
        // USE LOOKUP VALUE , IF ANY
 
        IF  L08KEY <> *BLANK;
 
          R04KEY  = L08KEY;
 
          L08KEY  = *BLANK;
 
        ENDIF;
 
 
        ENDSR;
 
 
      //--------------  VAL -------------------------------//
 
        BEGSR    VAL;
 
 
          @ERR  =  @FALSE;
 
          DOW    @LOOP  = @LOOP;
 
 
        //  CHECK THE PRODUCT KEY
 
          PCSTKEY.PCSKY = R04KEY  ;
 
          CHAIN  %kds(PCSTKEY) PCP100 ;
 
          R04PRD = *BLANK;
 
          IF %found ;
 
          R04PRD = PCDSC;
 
          ELSE;
 
          @ERR  =  @TRUE ;
 
          GETROWCOL  (@FILE :'*LIBL' : @FORMAT : 'R04KEY': ROW04:COL04);
 
          R04MSG = RtvMsgTxt('MSG0002':cMsgF2:cMsgLib:cMsgLvl1);
 
          LEAVE;
 
          ENDIF;
 
 
          IF  R04QTY  <= 0;
 
          @ERR  =  @TRUE ;
 
          GETROWCOL  (@FILE :'*LIBL' : @FORMAT : 'R04QTY': ROW04:COL04);
 
          R04MSG = RtvMsgTxt('MSG0003':cMsgF2:cMsgLib:cMsgLvl1);
 
          LEAVE;
 
          ENDIF;
 
 
 
          PUSTKEY.PUSDAT= %DATE(R04MTH : *ISO);
 
          PUSTKEY.PUSKY = R04KEY;
 
          PUSTKEY.PUSCT = R04CT ;
 
          PUSTKEY.PUSCT2= R04CT2;
 
          CHAIN  %kds(PUSTKEY) PUP100 ;
 
          IF  %FOUND;
 
          @ERR  =  @TRUE ;
 
          GETROWCOL  (@FILE :'*LIBL' : @FORMAT : 'R04KEY': ROW04:COL04);
 
          R04MSG = RtvMsgTxt('MSG0004':cMsgF2:cMsgLib:cMsgLvl1);
 
          LEAVE;
 
          ENDIF;
 
 
          LEAVE;
 
          ENDDO;
 
          ENDSR;
 
 
      //--------------  UPD -------------------------------//
 
        BEGSR    UPD;
 
 
          PUSTKEY.PUSDAT= %DATE(R04MTH : *ISO);
 
          PUSTKEY.PUSKY = R04KEY;
 
          PUSTKEY.PUSCT = R04CT ;
 
          PUSTKEY.PUSCT2= R04CT2;
 
          CHAIN  %kds(PUSTKEY) PUP100 ;
 
          IF  %FOUND;
 
            PUSQTY = R04QTY;
 
            UPDATE    PUP100;
 
          ELSE;
 
            PUSDAT =  %DATE(R04MTH : *ISO);
 
            PUSCT  =  R04CT ;
 
            PUSCT2 =  R04CT2;
 
            PUSKY  =  R04KEY;
 
            PUSQTY =  R04QTY;
 
            WRITE    PUP100;
 
          ENDIF;
 
 
        ENDSR;
 
 
 
 
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
 
        ENDSR;
 
      /END-FREE
 
    P @R04            E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
      /space 3
 
    P @S05BLD        B
 
 
    D @S05BLD        PI
 
 
          //  S05 IS A PAGE AT A TIME SFL
 
          //  A USER SPACE IS LOADED TO SUPPORT THE SFL
 
          //  ENABLE > 9999 DATA RECORDS
 
          //
 
    D X              S            10i 0
 
 
    D QUSCRTUS        PR                  ExtPgm('QUSCRTUS')
 
    D  UserSpace                  20A  CONST
 
    D  ExtAttrib                  10A  CONST
 
    D  InitialSize                10I 0 CONST
 
    D  InitialVal                  1A  CONST
 
    D  PublicAuth                  10A  CONST
 
    D  Text                        50A  CONST
 
    D  Replace                    10A  CONST options(*nopass)
 
    D  ErrorCode                32767A  options(*varsize:*nopass)
 
 
    D QUSPTRUS        PR                  ExtPgm('QUSPTRUS')
 
    D  UserSpace                  20A  CONST
 
    D  Pointer                      *
 
 
    D QUSDLTUS        PR                  ExtPgm('QUSDLTUS')
 
    D  UserSpace                  20A  CONST
 
    D  ErrorCode                32767A  options(*varsize)
 
 
    D QUSCUSAT        PR                  ExtPgm('QUSCUSAT')
 
    D  ReturnLibrary                10A
 
    D  UserSpace                    20A  Const
 
    D  Attribute                          Const
 
    D                                    LikeDS(SpaceAttr)
 
    D  ErrorCode                          LikeDS(ErrorCode)
 
 
 
    D SpaceAttr      DS                  Qualified
 
    D  NumberRecs                  10I 0
 
    D  ExtendRecord                12A
 
    D  Key                        10I 0 Overlay(ExtendRecord)
 
    D  Length                      10I 0 OverLay(ExtendRecord:*Next)
 
    D  Extend                      1A  OverLay(ExtendRecord:*Next)
 
 
 
    D ErrorCode      ds                  qualified
 
    D  BytesProv                  10I 0 inz(0)
 
    D  BytesAvail                  10I 0 inz(0)
 
 
    D DataEntry      S                  Based(DataPtr) Like(S05DTA)
 
 
    D TEMPSPC        DS            20
 
    D SpaceName                    10A  Inz('SCROLL05 ')
 
    D Library                      10A  Inz('QTEMP  ')
 
 
      * BasePtr will hold the base address of the User Space
 
      * At the beginning of the space is a count (Count) of the entries
 
    D BasePtr        S              *
 
    D Count          S            12P 0 Based(BasePtr)
 
    D CountMessage    S            30A
 
    D RtnLib          S            10A
 
    D SpaceNotFound  C                  'User Space not found'
 
 
 
      /FREE
 
 
          EXSR @INZSR;
 
 
        // SAVKEY = *Blanks;
 
        EXSR BLD;
 
 
        //  USER SPC IS  LOADED , RUN THE CONTROL
 
          @LV = @LV + 1;
 
          @SCN(@LV) = 'S05PRC ';
 
      RETURN;
 
 
      //--------------  BLD -------------------------------//
 
      BEGSR  BLD;
 
 
        EXSR CLR;
 
        *IN53 = *OFF;
 
 
          PUSTKEY.PUSDAT= *LOVAL;
 
          PUSTKEY.PUSKY = *LOVAL;
 
          SETLL  %kds(PUSTKEY) PUP100 ;
 
          IF  %FOUND;
 
 
          DOW @LOOP = @LOOP;
 
          READ    PUP100 ;
 
          IF %EOF;
 
          LEAVE;
 
          ENDIF;
 
 
        EXSR MOV;
 
 
          ENDDO;
 
          ENDIF;
 
 
        ENDSR;
 
 
      //--------------  CLR -------------------------------//
 
        BEGSR  CLR;
 
 
 
      RCD05  = 0;
 
          // --------------------------------------------------
 
          // Delete the user space if it exists (ignore errors)
 
          ErrorCode.BytesProv = %size(ErrorCode);
 
          QUSDLTUS( TEMPSPC: ErrorCode );
 
          ErrorCode.BytesProv = 0;
 
 
          // --------------------------------------------------
 
          // Create a new 128k user space
 
          QUSCRTUS( TEMPSPC : 'SCHTEXT' : 128 * 1024  : x'00'
 
                  : '*EXCLUDE' : 'List of fields in file' : '*NO'
 
                  : ErrorCode );
 
 
          //  Set the user space to Auto extend
 
            SpaceAttr.NumberRecs = 1;
 
            SpaceAttr.Key = 3;          //  3 is auto extend key
 
            SpaceAttr.Length = 1;
 
            SpaceAttr.Extend = '1';    //  1 means auto extend
 
            QUSCUSAT( Rtnlib  : TEMPSPC
 
                      : SpaceAttr  : ErrorCode );
 
 
 
          // Get a pointer to the user space
 
          QUSPTRUS( TEMPSPC: BasePtr      );
 
 
            If        BasePtr <> *Null;
 
              DataPtr = BasePtr + %Size(Count);
 
              Eval      Count = 0;
 
            Endif;
 
 
 
        ENDSR;
 
 
      //--------------  MOV -------------------------------//
 
        BEGSR  MOV;
 
 
          RCD05  = RCD05 + 1;
 
          count  = count + 1;
 
        S05DTA.S05MTH    =  %CHAR(PUSDAT : *iso);
 
        S05DTA.S05QTY    = PUSQTY;
 
        S05DTA.S05KEY    = PUSKY;
 
        S05DTA.S05CT2    = PUSCT2;
 
 
          PCSTKEY.PCSKY = S05DTA.S05KEY  ;
 
          CHAIN  %kds(PCSTKEY) PCP100 ;
 
        S05DTA.S05PRD =  PCDSC;
 
 
          DataEntry = S05DTA;
 
          DataPtr = DataPtr + %Size(S05DTA);
 
        ENDSR;
 
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
 
          @NSCN = *BLANK;
 
 
        ENDSR;
 
      /END-FREE
 
    P @S05BLD        E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
      /space 3
 
    P @S05PRC        B
 
 
    D @S05PRC        PI
 
 
 
    D QUSPTRUS        PR                  ExtPgm('QUSPTRUS')
 
    D  UserSpace                  20A  CONST
 
    D  Pointer                      *
 
 
    D DataEntry      S                  Based(DataPtr) Like(S05DTA)
 
 
    D TEMPSPC        DS            20
 
    D SpaceName                    10A  Inz('SCROLL05 ')
 
    D Library                      10A  Inz('QTEMP  ')
 
 
      * BasePtr will hold the base address of the User Space
 
      * At the beginning of the space is a count (Count) of the entries
 
    D BasePtr        S              *
 
    D Count          S            12P 0 Based(BasePtr)
 
    D CountMessage    S            30A
 
    D SpaceNotFound  C                  'User Space not found'
 
 
          //
 
          //
 
    D WRKRC          S              4S 0
 
 
    D X              S            12S 0
 
    D RECS            S              4S 0 INZ(14)
 
    D CURS            S            12S 0
 
    D TOPS            S            12S 0
 
 
      /FREE
 
 
          EXSR @INZSR;
 
 
        WRITE R05;
 
 
      //
 
      DOW @LOOP = @LOOP;
 
 
          // Write SFL Control
 
          IF SFC05 > 0;
 
            *IN51 = *ON;
 
          ENDIF;
 
          *IN52 = *ON;
 
          EXFMT C05;
 
          //
 
          //  Setoff errors
 
          *IN89 = *OFF;
 
          //  Setoff MORE
 
          *IN99 = *OFF;
 
          //
 
          //  Exit and Previous Screen
 
          IF *IN03 = *ON;
 
            LEAVE;
 
          ENDIF;
 
 
          IF *IN12 = *ON;
 
          @LV = @LV -1;
 
            LEAVE;
 
          ENDIF;
 
 
          //  PAGE UP
 
          IF *IN62 = *ON;
 
            IF TOPS = 1;
 
              ITER;
 
            ENDIF;
 
            EXSR PAGEUP;
 
            ITER;
 
          ENDIF;
 
 
          //  PAGE DOWN
 
          IF *IN61 = *ON;
 
            IF CURS = RCD05;
 
              *IN99 = *ON;
 
              ITER;
 
            ENDIF;
 
            EXSR PAGEDN;
 
            ITER;
 
          ENDIF;
 
 
        IF C05MTH  <> *BLANK;
 
          EXSR POS;
 
          ITER;
 
        ENDIF;
 
 
      ENDDO;
 
      //
 
      RETURN;
 
 
 
      /space 3
 
 
      //--------------  POS -------------------------------//
 
        BEGSR  POS;
 
 
        FOR X  = 1 TO RCD05  ;
 
 
          CURS = X-1;
 
              DataPtr = BasePtr + %Size(Count) +
 
                    + CURS *%Size(S05DTA);
 
          S05DTA = DataEntry ;
 
 
            IF S05DTA.S05MTH >= C05MTH;
 
            EXSR PAGEDN;
 
            LEAVE;
 
            ENDIF;
 
          ENDFOR;
 
 
        ENDSR;
 
 
      /space 3
 
 
      //--------------  PAGEUP ------------------------------//
 
        BEGSR PAGEUP;
 
 
        TOPS  =  TOPS - RECS;
 
 
        IF TOPS < 1;
 
          TOPS  =  1;
 
        ENDIF;
 
 
        CURS = TOPS - 1;
 
        DataPtr = BasePtr + %Size(Count) +
 
                    + CURS *%Size(S05DTA);
 
 
        EXSR  PAGEDN;
 
 
        ENDSR;
 
 
 
      /space 3
 
 
      //--------------  PAGEDN ------------------------------//
 
        BEGSR PAGEDN;
 
 
        EXSR CLR;
 
 
        TOPS = CURS + 1;
 
 
        FOR X  = 1 TO RECS;
 
 
        IF CURS = RCD05;
 
          *IN99 = *ON;
 
          LEAVE  ;
 
        ENDIF;
 
 
        CURS = CURS + 1;
 
 
          S05DTA = DataEntry ;
 
          DataPtr = DataPtr + %Size(S05DTA);
 
 
        EXSR MOV;
 
        SFC05 = 1;
 
        SRS05 = 1;
 
        RS05 = X;
 
        WRITE S05;
 
 
        ENDFOR;
 
 
        ENDSR;
 
 
      //--------------  MOV -------------------------------//
 
        BEGSR  MOV;
 
 
          S05MTH =  S05DTA.S05MTH;
 
          S05QTY =  S05DTA.S05QTY;
 
          S05KEY =  S05DTA.S05KEY;
 
          S05CT2 =  S05DTA.S05CT2;
 
          S05PRD =  S05DTA.S05PRD;
 
 
        ENDSR;
 
 
      //--------------  CLR -------------------------------//
 
        BEGSR  CLR;
 
          *IN51 = *OFF;
 
          *IN52 = *OFF;
 
          *IN53 = *ON;
 
          WRITE C05;
 
          *IN53 = *OFF;
 
          RS05 =0;
 
          SFC05=0;
 
        ENDSR;
 
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
 
          @NSCN = *BLANK;
 
          TOPS  =  0;
 
          CURS  =  0;
 
 
 
          // Get a pointer to the user space
 
          QUSPTRUS( TEMPSPC: BasePtr      );
 
 
            If        BasePtr <> *Null;
 
              DataPtr = BasePtr + %Size(Count);
 
              Eval      RCD05 = Count ;
 
            Endif;
 
 
 
          EXSR  PAGEDN;
 
        ENDSR;
 
      /END-FREE
 
    P @S05PRC        E
 
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
      /space 3
 
    P @S06BLD        B
 
 
    D @S06BLD        PI
 
 
          //  LOAD  PRODUCTS PANEL
 
          //
 
          //  Build/Rebuild the subfile
 
 
      /FREE
 
 
          EXSR @INZSR;
 
 
        // SAVKEY = *Blanks;
 
        EXSR BLD;
 
 
        //  SFL IS BUILT, PROCESS CONTROL RCD
 
          @LV = @LV + 1;
 
          @SCN(@LV) = 'S06PRC ';
 
      RETURN;
 
 
      //--------------  BLD -------------------------------//
 
      BEGSR  BLD;
 
 
        EXSR CLR;
 
 
 
          PCSTKEY.PCSKY =  *LOVAL;
 
          SETLL  %kds(PCSTKEY) PCP100 ;
 
 
          DOW @LOOP = @LOOP;
 
          READ    PCP100 ;
 
          IF %EOF;
 
          LEAVE;
 
          ENDIF;
 
 
        EXSR MOV;
 
 
        //
 
          RS06  = RS06 + 1;
 
        WRITE S06;
 
          ENDDO;
 
 
        // Position to TOP of subfile
 
          SRS06 = 1;
 
          SFC06 = RS06;
 
        ENDSR;
 
 
      //--------------  CLR -------------------------------//
 
        BEGSR  CLR;
 
          *IN51 = *OFF;
 
          *IN52 = *OFF;
 
          *IN53 = *ON;
 
          WRITE C06;
 
          *IN53 = *OFF;
 
          RS06 =0;
 
          SFC06=0;
 
          S06OPT=*BLANK;
 
        ENDSR;
 
 
      //--------------  MOV -------------------------------//
 
        BEGSR  MOV;
 
 
          S06OPT = *BLANK;
 
          S06KEY =  PCSKY;
 
          S06PRD =  PCDSC;
 
 
        ENDSR;
 
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
          @NSCN = *BLANK;
 
        ENDSR;
 
 
      /END-FREE
 
    P @S06BLD        E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
      /space 3
 
    P @S06PRC        B
 
 
    D @S06PRC        PI
 
 
          //
 
          //
 
    D WRKRC          S              4S 0
 
 
      /FREE
 
 
          EXSR @INZSR;
 
 
        WRITE R06;
 
 
      //
 
      DOW @LOOP = @LOOP;
 
 
 
          // Write SFL Control
 
          IF SFC06 > 0;
 
            *IN51 = *ON;
 
          ENDIF;
 
          *IN52 = *ON;
 
          EXFMT C06;
 
          //
 
          //  Setoff errors
 
          *IN89 = *OFF;
 
          //
 
          //  Exit and Previous Screen
 
          IF *IN03 = *ON;
 
            LEAVE;
 
          ENDIF;
 
 
          IF *IN12 = *ON;
 
          @LV = @LV -1;
 
            LEAVE;
 
          ENDIF;
 
 
          IF *IN06 = *ON;
 
            @LV = @LV + 1;
 
            @SCN(@LV) = 'R07';
 
            LEAVE;
 
          ENDIF;
 
 
        //  Process the subfile
 
            @LV = @LV + 1;
 
            @SCN(@LV) = 'S06PRS';
 
            LEAVE;
 
 
      ENDDO;
 
      //
 
      RETURN;
 
 
 
      /space 3
 
 
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
 
          @NSCN = *BLANK;
 
        ENDSR;
 
      /END-FREE
 
    P @S06PRC        E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
      /space 3
 
    P @S06PRS        B
 
 
    D @S06PRS        PI
 
 
          //
 
          //
 
    D WRKRC          S              4S 0
 
 
      /FREE
 
 
          EXSR @INZSR;
 
 
      //
 
 
        //  Process the subfile
 
        EXSR SFL;
 
      //
 
      RETURN;
 
 
 
      //--------------  SFL -------------------------------//
 
        BEGSR  SFL;
 
 
 
        FOR WRKRC = 1 TO SFC06+1;
 
          CHAIN WRKRC S06;
 
            IF NOT %FOUND;
 
        //  Finished with the subfile
 
        //  RETURN TO REBUILD LEVEL
 
            @LV = @LV -2;
 
            LEAVE;
 
            ENDIF;
 
 
        //    RIGHT ADJUST OPTION
 
          S06OPT  = @OPADJ(S06OPT);
 
 
          SELECT;
 
            // WORK WITH
 
          WHEN S06OPT = ' 4';
 
            @LV = @LV +1;
 
            @SCN(@LV) =  'S09BLD';
 
            LEAVE;
 
            //
 
          OTHER;
 
            S06OPT = *blank;
 
            UPDATE S06;
 
          ENDSL;
 
          //
 
        ENDFOR;
 
        //
 
        ENDSR;
 
      //---------------------------------------------------//
 
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
 
          @NSCN = *BLANK;
 
        ENDSR;
 
      /END-FREE
 
    P @S06PRS        E
 
 
      /space 3
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
    P @R07            B
 
    D @R07            PI
 
 
 
    D @FORMAT        S            10    INZ('R07')
 
 
      //
 
 
      /free
 
          EXSR @INZSR;
 
 
          EXSR BLD;
 
          DOW    @LOOP  = @LOOP;
 
 
          EXFMT  R07;
 
      // setoff errors
 
          @ERR = @FALSE;
 
          *IN88 = *OFF;
 
          *IN89 = *OFF;
 
          ROW07 = 999;
 
          COL07 = 999;
 
      //Exit and Previous Screen
 
          IF        (*IN03 = *ON) or
 
                    (*IN12 = *ON);
 
                        Leave;
 
          ENDIF;
 
 
        //  Validate the data
 
          EXSR      VAL;
 
          IF        @Err = @True;
 
                    *IN88 = *ON ;
 
                    *IN89 = *OFF;
 
                    WRITE R07;
 
                    *IN88 = *OFF;
 
                    ROW07 = 999;
 
                    COL07 = 999;
 
                    *IN89 = *ON;
 
                    ITER;
 
          ELSE;
 
          WRITE R07;
 
          ENDIF;
 
 
      //UPDATE  Previous Screen
 
          IF        (*IN06 = *ON);
 
              EXSR      UPD;
 
              @LV = @LV -2 ;
 
              Leave;
 
          ENDIF;
 
          ENDDO;
 
 
      //
 
      RETURN;
 
 
      //--------------  CLR -------------------------------//
 
        BEGSR    CLR;
 
 
 
        ENDSR;
 
 
      //--------------  BLD -------------------------------//
 
        BEGSR    BLD;
 
 
        R07KEY =  *BLANK ;
 
        R07PRD =  *BLANK ;
 
 
        ENDSR;
 
 
      //--------------  VAL -------------------------------//
 
        BEGSR    VAL;
 
 
          DOW    @LOOP  = @LOOP;
 
          LEAVE;
 
          ENDDO;
 
          ENDSR;
 
 
      //--------------  UPD -------------------------------//
 
        BEGSR    UPD;
 
 
          PCSTKEY.PCSKY = R07KEY  ;
 
          CHAIN  %kds(PCSTKEY) PCP100 ;
 
          IF  %FOUND;
 
            PCDSC  = R07PRD;
 
            UPDATE    PCP100;
 
          ELSE;
 
            PCSKY  =  R07KEY;
 
            PCDSC  =  R07PRD;
 
            WRITE    PCP100;
 
          ENDIF;
 
 
        ENDSR;
 
 
 
 
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
 
        ENDSR;
 
      /END-FREE
 
    P @R07            E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
      /space 3
 
    P @S08BLD        B
 
 
    D @S08BLD        PI
 
 
          //  LOAD  PRODUCTS PANEL
 
          //
 
          //  Build/Rebuild the subfile
 
 
      /FREE
 
 
          EXSR @INZSR;
 
 
        // SAVKEY = *Blanks;
 
        EXSR BLD;
 
 
        //  SFL IS BUILT, PROCESS CONTROL RCD
 
          @LV = @LV + 1;
 
          @SCN(@LV) = 'S08PRC ';
 
      RETURN;
 
 
      //--------------  BLD -------------------------------//
 
      BEGSR  BLD;
 
 
        EXSR CLR;
 
 
 
          PCSTKEY.PCSKY =  *LOVAL;
 
          SETLL  %kds(PCSTKEY) PCP100 ;
 
 
          DOW @LOOP = @LOOP;
 
          READ    PCP100 ;
 
          IF %EOF;
 
          LEAVE;
 
          ENDIF;
 
 
        EXSR MOV;
 
 
        //
 
          RS08  = RS08 + 1;
 
        WRITE S08;
 
          ENDDO;
 
 
        // Position to TOP of subfile
 
          SRS08 = 1;
 
          SFC08 = RS08;
 
        ENDSR;
 
 
      //--------------  CLR -------------------------------//
 
        BEGSR  CLR;
 
          *IN51 = *OFF;
 
          *IN52 = *OFF;
 
          *IN53 = *ON;
 
          WRITE C08;
 
          *IN53 = *OFF;
 
          RS08 =0;
 
          SFC08=0;
 
          S08OPT=*BLANK;
 
        ENDSR;
 
 
      //--------------  MOV -------------------------------//
 
        BEGSR  MOV;
 
 
          S08OPT = *BLANK;
 
          S08KEY =  PCSKY;
 
          S08PRD =  PCDSC;
 
 
        ENDSR;
 
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
          @NSCN = *BLANK;
 
        ENDSR;
 
      /END-FREE
 
    P @S08BLD        E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
      /space 3
 
    P @S08PRC        B
 
 
    D @S08PRC        PI
 
 
          //
 
          //
 
    D WRKRC          S              4S 0
 
 
      /FREE
 
 
          EXSR @INZSR;
 
 
        //  WRITE R08;
 
 
      //
 
      DOW @LOOP = @LOOP;
 
 
          //
 
          // Write SFL Control
 
          IF SFC08 > 0;
 
            *IN51 = *ON;
 
          ENDIF;
 
          *IN52 = *ON;
 
          EXFMT C08;
 
          //
 
          //  Setoff errors
 
          *IN89 = *OFF;
 
          //
 
          //  Exit and Previous Screen
 
          IF *IN03 = *ON;
 
            LEAVE;
 
          ENDIF;
 
 
          IF *IN12 = *ON;
 
          @LV = @LV -1;
 
            LEAVE;
 
          ENDIF;
 
 
        //  Process the subfile
 
            @LV = @LV + 1;
 
            @SCN(@LV) = 'S08PRS';
 
            LEAVE;
 
 
 
      ENDDO;
 
      //
 
      RETURN;
 
 
 
      /space 3
 
 
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
 
          @NSCN = *BLANK;
 
        ENDSR;
 
      /END-FREE
 
    P @S08PRC        E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
      /space 3
 
    P @S08PRS        B
 
 
    D @S08PRS        PI
 
 
          //
 
          //
 
    D WRKRC          S              4S 0
 
 
      /FREE
 
 
          EXSR @INZSR;
 
 
        //  Process the subfile
 
        EXSR SFL;
 
      //
 
      RETURN;
 
 
 
      //--------------  SFL -------------------------------//
 
        BEGSR  SFL;
 
 
        FOR WRKRC = 1 TO SFC08+1;
 
          CHAIN WRKRC S08;
 
            IF NOT %FOUND;
 
        //  Finished with the subfile
 
        //  RETURN TO REBUILD LEVEL
 
            @LV = @LV -2;
 
            LEAVE;
 
            ENDIF;
 
 
        //    RIGHT ADJUST OPTION
 
          S08OPT  = @OPADJ(S08OPT);
 
 
          SELECT;
 
            // SELECTED KEY
 
          WHEN S08OPT = ' 1';
 
            L08KEY = S08KEY;
 
            @LV = @LV -3;
 
            LEAVE;
 
            //
 
          OTHER;
 
            S08OPT = *blank;
 
            UPDATE S08;
 
          ENDSL;
 
          //
 
        ENDFOR;
 
        //
 
        ENDSR;
 
      //---------------------------------------------------//
 
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
 
          @NSCN = *BLANK;
 
        ENDSR;
 
      /END-FREE
 
    P @S08PRS        E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
      /space 3
 
    P @S09BLD        B
 
 
    D @S09BLD        PI
 
 
          //  LOAD  PRODUCTS PANEL
 
          //
 
          //  Build/Rebuild the subfile
 
    D WRKRC          S              4S 0
 
 
      /FREE
 
 
          EXSR @INZSR;
 
 
        // SAVKEY = *Blanks;
 
        EXSR BLD;
 
 
        //  SFL IS BUILT, PROCESS CONTROL RCD
 
          @LV = @LV + 1;
 
          @SCN(@LV) = 'S09PRC ';
 
      RETURN;
 
 
      //--------------  BLD -------------------------------//
 
      BEGSR  BLD;
 
 
        EXSR CLR;
 
        *IN53 = *OFF;
 
 
 
 
        FOR WRKRC = 1 TO SFC06;
 
          CHAIN WRKRC S06;
 
 
        IF @OPADJ(S06OPT) = ' 4';
 
          EXSR MOV;
 
          RS09  = RS09 + 1;
 
          WRITE S09;
 
        ENDIF;
 
 
          ENDFOR;
 
 
        // Position to TOP of subfile
 
          SRS09 = 1;
 
          SFC09 = RS09;
 
        ENDSR;
 
      //---------------------------------------------------//
 
 
      //--------------  CLR -------------------------------//
 
        BEGSR  CLR;
 
          *IN51 = *OFF;
 
          *IN52 = *OFF;
 
          *IN53 = *ON;
 
          WRITE C09;
 
          *IN53 = *OFF;
 
          RS09 =0;
 
          SFC09=0;
 
        ENDSR;
 
 
      //--------------  MOV -------------------------------//
 
        BEGSR  MOV;
 
 
          S09KEY    = S06KEY ;
 
          S09PRD    = S06PRD ;
 
        ENDSR;
 
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
          @NSCN = *BLANK;
 
        ENDSR;
 
      /END-FREE
 
    P @S09BLD        E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
      /space 3
 
    P @S09PRC        B
 
 
    D @S09PRC        PI
 
 
          //
 
 
    D WRKRC          S              4S 0
 
 
      /FREE
 
 
          EXSR @INZSR;
 
 
        WRITE R09;
 
 
      //
 
      DOW @LOOP = @LOOP;
 
 
          // Write SFL Control
 
          IF SFC09 > 0;
 
            *IN51 = *ON;
 
          ENDIF;
 
          *IN52 = *ON;
 
          EXFMT C09;
 
 
          //  Setoff errors
 
          *IN89 = *OFF;
 
          @ERR = @FALSE;
 
          //
 
          //  Exit and Previous Screen
 
          IF *IN03 = *ON;
 
            LEAVE;
 
          ENDIF;
 
 
          IF *IN12 = *ON;
 
          @LV = @LV -2;
 
            LEAVE;
 
          ENDIF;
 
 
          EXSR CHKDEL;
 
          IF @ERR = @TRUE;
 
          *IN89 = *ON ;
 
          ITER;
 
          ENDIF;
 
 
 
          EXSR DEL;
 
          @LV = @LV -4;
 
          LEAVE;
 
 
      ENDDO;
 
      //
 
      RETURN;
 
 
 
      //---------------------------------------------------//
 
      BEGSR  DEL;
 
 
 
        FOR WRKRC = 1 TO SFC06  ;
 
          CHAIN WRKRC S06;
 
 
        IF @OPADJ(S06OPT) = ' 4';
 
            S06OPT  = '  ';
 
            UPDATE  S06;
 
 
          PCSTKEY.PCSKY = S06KEY  ;
 
          DELETE %kds(PCSTKEY) PCP100 ;
 
 
        ENDIF;
 
 
          ENDFOR;
 
 
        ENDSR;
 
      //---------------------------------------------------//
 
      BEGSR  CHKDEL;
 
 
 
        FOR WRKRC = 1 TO SFC06  ;
 
          CHAIN WRKRC S06;
 
 
        IF @OPADJ(S06OPT) = ' 4';
 
 
 
          PUSTKY1.PUSKY =  S06KEY;
 
 
          SETLL  %kds(PUSTKY1:1) PUP101 ;
 
          IF  %EQUAL;
 
          @ERR = @TRUE;
 
          C09MSG = 'CANNOT DELETE ' + S06KEY +
 
                  ' AS IT IS IN USE.';
 
          LEAVE;
 
          ENDIF;
 
 
        ENDIF;
 
 
        ENDFOR;
 
 
        ENDSR;
 
      //---------------------------------------------------//
 
      /space 3
 
 
 
      //--------------*INZSR-------------------------------//
 
        BEGSR  @INZSR;
 
 
          @NSCN = *BLANK;
 
        ENDSR;
 
      /END-FREE
 
    P @S09PRC        E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
 
    P @R9999          B
 
        //  Invalid Panel
 
    D @R9999          PI
 
 
    P @R9999          E
 
 
 
      /space 3
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
    P @OPADJ          B
 
        //  RIGHT ADJ OPTION , zero suppress
 
 
    D @OPADJ          PI            2A
 
    D  OPT                          2A
 
 
      /FREE
 
        EVALR  OPT  = %trimr(OPT);
 
        If %SubSt(OPT:1:1) =  '0';
 
        OPT  = ' ' +  %SubSt(OPT:2:1);
 
        EndIf;
 
        RETURN OPT;
 
      /END-FREE
 
    P @OPADJ          E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
    P  RtvMsgTxt      B
 
      //************************************************************************
 
      // API Call: QMHRTVM Retrieve Message text
 
      //************************************************************************
 
 
 
      // USAGE
 
      // MsgTxt = RtvMsgTxt('MSG0005':cMsgF3:cMsgLib:cMsgLvl1);
 
 
    D  RtvMsgTxt      PI          1024
 
    D  RMsgId                      7    Const
 
    D  RMsgFle                    10    Const
 
    D  RMsgLib                    10    Const
 
    D  RMsgLvl                      1    Const
 
 
      // Retrieve Message Description API Prototype
 
    D  Get_Message    PR                  ExtPgm('QMHRTVM')
 
    D                            4000    Options(*VarSize)
 
    D                              10I 0 Const
 
    D                                8    Const
 
    D                                7
 
    D                              20    Const
 
    D                            32765    Options(*VarSize)
 
    D                              10I 0 Const
 
    D                              10    Const
 
    D                              10    Const
 
    D                            8192    Options(*VarSize)
 
    D                              10
 
    D                                9B 0
 
    D                                9B 0
 
 
      // Define Variables for QMHRTVM API call:
 
      // --------------------------------------
 
      // Return variables
 
    D  MessageInfo    DS          4000
 
    D  Data                  1  4000
 
    D  OSMSG                65    68B 0
 
    D  LMsgR                69    72B 0
 
    D  LMsgA                73    76B 0
 
    D  OSMSGH              77    80B 0
 
    D  LMsgHR              81    84B 0
 
    D  LMsgHA              85    88B 0
 
 
      // Required input variables
 
    D  MessageLen    S            10I 0
 
    D  MessageForm  S              8
 
    D  MessageIden  S              7
 
    D  MessageFile  S            20
 
    D  Replacement  S          32765
 
    D  ReplaceLen    S            10I 0
 
    D  ReplaceSub    S            10
 
    D  ReturnCtl    S            10
 
 
    D  RetrieveOpt  S            10
 
    D  ConvToCCSID  S              9B 0
 
    D  ReplDtaCCSID  S              9B 0
 
 
    D  Return_Text  S          1024
 
 
    D  ErrorCode      DS                  Qualified
 
    D  BytesProv                    4B 0 Inz(0)
 
    D  BytesAvail                  8B 0 Inz(0)
 
    D  ExceptionId                  7
 
    D  Reserved                    1
 
    D  ExceptionDta              512
 
      /FREE
 
 
        // Load API parameter fields
 
        MessageInfo  = *blanks;
 
        MessageLen    = 4000;
 
        MessageForm  = 'RTVM0300';
 
        MessageIden  = RMsgId;
 
        MessageFile  = RMsgFle + RMsgLib;
 
        Replacement  = *blanks;
 
        ReplaceLen    = %Len(Replacement);
 
        ReplaceSub    = '*YES';
 
        ReturnCtl    = '*YES';
 
        RetrieveOpt  = '*MSGID';
 
        ConvToCCSID  = 0;
 
        ReplDtaCCSID  = 0;
 
 
        // Retrieve message description
 
        Get_Message(MessageInfo :
 
                    MessageLen  :
 
                    MessageForm :
 
                    MessageIden :
 
                    MessageFile :
 
                    Replacement :
 
                    ReplaceLen  :
 
                    ReplaceSub  :
 
                    ReturnCtl  :
 
                    ErrorCode  :
 
                    RetrieveOpt :
 
                    ConvToCCSID :
 
                    ReplDtaCCSID);
 
 
        // Process Return variables
 
        Return_Text = *blanks;
 
 
        // If no errors, determine the correct portion of the message text
 
        If ErrorCode.BytesProv = 0;
 
          Select;
 
          When RMsgLvl = '1';
 
              Return_Text = %Subst(data:OSMSG+1:LMsgA);  // Msg Lvl 1
 
          When RMsgLvl = '2';
 
              Return_Text = %Subst(data:OSMSGH+1:LMsgHA);  // Msg Lvl 2
 
          EndSl;
 
        Else;
 
          Return_Text = 'Get_Message failed.';
 
        EndIf;
 
 
        // Return to calling point
 
        Return Return_Text;
 
 
      /END-FREE
 
    P                E
 
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
    P GETROWCOL      B
 
      *
 
      *    Retreive a DSPF FIELD  Row and Col
 
      *    Used for Setting  CSRLOC for cursor positioning
 
      *    USAGE
 
      *    GETROWCOL  (FILE :'*LIBL' : FORMAT : FLDNAM : ROW : COL)
 
      *
 
    D GETROWCOL      PR
 
    D  schFile                    10A  const
 
    D  schLib                      10A  const
 
    D  schFormat                  10A  const
 
    D  schString                  32A  const
 
    D  rtnROW                      3P 0
 
    D  RtnCOL                      3P 0
 
 
    D GETROWCOL      PI
 
    D  schFile                    10A  const
 
    D  schLib                      10A  const
 
    D  schFormat                  10A  const
 
    D  schString                  32A  const
 
    D  rtnROW                      3P 0
 
    D  RtnCOL                      3P 0
 
 
    D QUSCRTUS        PR                  ExtPgm('QUSCRTUS')
 
    D  UserSpace                  20A  CONST
 
    D  ExtAttrib                  10A  CONST
 
    D  InitialSize                10I 0 CONST
 
    D  InitialVal                  1A  CONST
 
    D  PublicAuth                  10A  CONST
 
    D  Text                        50A  CONST
 
    D  Replace                    10A  CONST options(*nopass)
 
    D  ErrorCode                32767A  options(*varsize:*nopass)
 
 
    D QUSPTRUS        PR                  ExtPgm('QUSPTRUS')
 
    D  UserSpace                  20A  CONST
 
    D  Pointer                      *
 
 
    D QUSDLTUS        PR                  ExtPgm('QUSDLTUS')
 
    D  UserSpace                  20A  CONST
 
    D  ErrorCode                32767A  options(*varsize)
 
 
    D QUSLFLD        PR                  ExtPgm('QUSLFLD')
 
    D  UsrSpc                      20A  const
 
    D  Format                      8A  const
 
    D  QualFile                    20A  const
 
    D  RcdFmt                      10A  const
 
    D  UseOvrd                      1A  const
 
    D  ErrorCode                32767A  options(*nopass:*varsize)
 
 
    D ErrorCode      ds                  qualified
 
    D  BytesProv                  10I 0 inz(0)
 
    D  BytesAvail                  10I 0 inz(0)
 
 
    D ListHeader      ds                  based(p_ListHeader)
 
    d  ListOffset                  10I 0 overlay(ListHeader:125)
 
    d  EntryCount                  10I 0 overlay(ListHeader:133)
 
    d  EntrySize                  10I 0 overlay(ListHeader:137)
 
 
    D Field          ds                  based(p_Field)
 
    D                                    qualified
 
    D  Name                        10a
 
    D  Type                          1a
 
    D  Use                          1a
 
    D  Obuff                        10i 0
 
    D  Ibuff                        10i 0
 
    D  Len                          10i 0
 
    D  Digt                        10i 0
 
    D  Dec                          10i 0
 
    D  FILLER                      416a
 
    d  DspRow                      10i 0
 
    d  DspCol                      10i 0
 
 
    D TEMPSPC        C                  'GETROWCOL QTEMP'
 
 
    D x              s            10I 0
 
 
      /free
 
 
                  rtnrow =    999;
 
                  rtnrow =    999;
 
          // --------------------------------------------------
 
          // Delete the user space if it exists (ignore errors)
 
          ErrorCode.BytesProv = %size(ErrorCode);
 
          QUSDLTUS( TEMPSPC: ErrorCode );
 
          ErrorCode.BytesProv = 0;
 
 
          // --------------------------------------------------
 
          // Create a new 128k user space
 
          QUSCRTUS( TEMPSPC : 'SCHTEXT' : 128 * 1024  : x'00'
 
                  : '*EXCLUDE' : 'List of fields in file' : '*NO'
 
                  : ErrorCode );
 
 
          // --------------------------------------------------
 
          // Dump list of fields in file to user space
 
          // Invaid data is ignored an 999 returned for row and col
 
          monitor;
 
          QUSLFLD( TEMPSPC : 'FLDL0100'  : SchFile + SchLib
 
                  : SchFormat  : *OFF  : ErrorCode );
 
              on-Error;
 
                RETURN;
 
            EndMon;
 
          // --------------------------------------------------
 
          // Get a pointer to the user space
 
          QUSPTRUS( TEMPSPC: p_ListHeader );
 
 
          // --------------------------------------------------
 
          // Loop through all fields in space, to get the field we need
 
          for x = 0 to (EntryCount - 1);
 
              p_Field = p_ListHeader + ListOffset + (EntrySize * x);
 
 
 
              if  schString = '*ALL';
 
 
                %OCCUR(WFLDS) =x+1;
 
                  rtnRow =    x+1;
 
                  rtnCol =    0;
 
                  FNAME = Field.name;
 
                  FTYP  = Field.Type;
 
                  FLEN  = Field.Len ;
 
                  FDEC  = Field.Dec ;
 
 
                else;
 
              if Field.Name = schString;
 
                  rtnRow =    Field.DspRow;
 
                  rtnCol =    Field.DspCol;
 
                leave;
 
              endif;
 
              endif;
 
 
 
 
          endfor;
 
 
          // --------------------------------------------------
 
          // Delete temp user space & end
 
          QUSDLTUS( TEMPSPC: ErrorCode );
 
 
            return;
 
 
      /end-free
 
    P                E
 
 
      //###################################################//
 
      //###################################################//
 
      //###################################################//
 
    P SysDate        B
 
      * // Procedure:  SysDate                                            //
 
      * // Purpose:  Gets the system date YYYYMMDD format 8S 0              //
 
      * // Parameters:                                                    //
 
      * // Returns:                                                        //
 
      * //    int    -- date in YYYYMMDD fmt                              //
 
      * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
 
    P
 
    D SysDate        PI            8S 0
 
    D
 
      /free
 
        Return    %INT(%CHAR(%DATE():*ISO0));
 
      /end-free
 
    P SysDate        E
 
 
      //###################################################//
 
      //###################################################//
 
      //####################################################
 
    P SysTime        B
 
      * // Procedure:  SysTime                                            //
 
      * // Purpose:  Gets the system time HHMMSS format 6S 0              //
 
      * // Parameters:                                                    //
 
      * // Returns:                                                        //
 
      * //    int    -- TMIE in HHMMSS fmt                              //
 
      * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
 
    P
 
    D SysTime        PI            6S 0
 
    D
 
      /free
 
        Return  %INT(%CHAR(%TIME():*ISO0));
 
      /end-free
 
    P SysTime        E
 
 
      //###################################################//
 
      //###################################################//
 
      //####################################################
 
    P DayOfWeek      B
 
      * // Procedure:  DayOfWeek
 
      * // Purpose:  Determine the day of week for a particular date
 
      * // Parameters:
 
      * //    I: dt  -- date
 
      *
 
      * // Returns:
 
      * //    0..6    -- 0=Sunday, 1=Monday, 2=Tuesday, etc.
 
      * // Notes:
 
      * //    January 5, 1800 is a Sunday.  This procedure only works for
 
      * //    dates later than 1800-01-05.
 
    P
 
    D DayOfWeek      pi            10i 0
 
    D  dt                            d  value datfmt(*iso)
 
 
      /free
 
        return %rem (%diff (dt: d'1800-01-05': *days): 7);
 
      /end-free
 
    P DayOfWeek      e
 
      //####################################################
 
 
      //***************************************************************
 
      //  THIS PROGRAM ONLY GOES 1 LEVEL DOWN IN ITS CALL STRUCTURE
 
      //  Each panel is precessed by its own procedure.
 
      //  A driving procdeure  then calls the panels procedure.
 
      //  The user will see that there are many panels on top
 
      //  of each other by pressing CF12, but this is a LOGICAL
 
      //  structure ONLY, controlled by the levels array SCN.
 
      //  The TOP level in SCN will contain *END and when reached
 
      //  will cause the program to end.
 
    *****************************************************************
 
    ** OBJECT ID: PCODES
 
    ** TEXT:      PRODUCT CODES
 
    *****************************************************************
 
    ** MODIFICATIONS:
 
    ** MOD  SCN    DATE  MODIFICATION SUMMARY
 
    **
 
    *****************************************************************
 
 
    A          R PCP100                    TEXT('PRODUCT CODES ')
 
    A            PCSKY        15          TEXT('KEY ')
 
    A            PCDSC        30          TEXT('DESCRIPTION')
 
 
    A          K PCSKY
 
 
    *****************************************************************
 
    ** OBJECT ID: USEDPROD
 
    ** TEXT:      USED PRODUCTS
 
    *****************************************************************
 
    ** MODIFICATIONS:
 
    ** MOD  SCN    DATE  MODIFICATION SUMMARY
 
    **
 
    *****************************************************************
 
 
    A          R PUP100                    TEXT('PRODUCT USAGE')
 
    A            PUSDAT          L        TEXT('DATE')
 
    A            PUSCT          2          TEXT('AREA ')
 
    A            PUSCT2        2          TEXT('SUBURB ')
 
    A            PUSKY        15          TEXT('KEY ')
 
    A            PUSQTY        5  0      TEXT('USED')
 
    A
 
    A          K PUSDAT
 
    A          K PUSKY
 
    A          K PUSCT
 
    A          K PUSCT2
 
 
    *****************************************************************
 
    ** OBJECT ID: USEDPROD
 
    ** TEXT:      USED PRODUCTS
 
    *****************************************************************
 
    ** MODIFICATIONS:
 
    ** MOD  SCN    DATE  MODIFICATION SUMMARY
 
    **
 
    *****************************************************************
 
 
    A          R PUP100                    TEXT('PRODUCT USAGE ')
 
    A                                      PFILE(USEDPROD)
 
    A          K PUSKY
 
    A          K PUSCT
 
    A          K PUSCT2
 
 
    A*
 
    A* File name  : USEDPRODFM
 
    A*
 
    A* Description : Used Product Entry
 
    A*
 
    A* Written    :
 
    A*
 
    A*==============================================================*
 
    A* MODIFICATIONS:
 
    A* MOD  SCN    DATE  MODIFICATION SUMMARY
 
    A*
 
    A*
 
    A*==============================================================*
 
    A*%%EC
 
    A                                      DSPSIZ(24 80 *DS3)
 
    A                                      PRINT
 
    A                                      CA03(03 'End of job')
 
    A                                      CA12(12 'Previous')
 
    A*==============================================================*
 
    A*
 
    A*
 
    A          R R01
 
    A                                      CF06(06 'Create')
 
    A*%%TS  SD  20101013  125107 
 
    A                                      CA07(07 'View')
 
    A  88                                  CSRLOC(ROW01      COL01)
 
    A  89        R01MSG        79  M
 
    A            ROW01          3S 0H
 
    A            COL01          3S 0H
 
    A*
 
    A                                  1  2'USEDPRODFM.01'
 
    A            CMPNO          3Y 0O  1 13EDTCDE(Z)
 
    A                                  1 28'USED PRODUCT REPORTING'
 
    A                                  1 60TIME
 
    A                                  1 70DATE
 
    A                                      EDTCDE(Y)
 
    A                                  2 28'Used Product Entry'
 
    A                                  5  3'Enter the Date  :'
 
    A            R01MTH        8Y 0B  5 22EDTCDE(4)
 
    A                                  5 32'(YYYYMMDD)'
 
    A                                24  2'F3=Exit  F6=Maintain PROD  F7=View-
 
    A                                        F12=Cancel'
 
    A          R S02                      SFL
 
    A*%%TS  SD  20101013  130118 
 
    A            S02OPT        2A  B 10  2
 
    A            S02PRD        30A  O 10  6
 
    A            S02QTY        6Y 0O 10 38EDTCDE(Z)
 
    A            S02CT2        2A  O 10 46
 
    A            S02CT          2A  H
 
    A            S02KEY        15A  H
 
    A*
 
    A*==============================================================*
 
    A          R C02                      SFLCTL(S02)
 
    A                                      CF06(06 'Create')
 
    A*%%TS  SD  20101013  130118 
 
    A                                      SFLSIZ(0015)
 
    A                                      SFLPAG(0014)
 
    A                                      TEXT('Used Product Entry')
 
    A                                      OVERLAY
 
    A  51                                  SFLDSP
 
    A  52                                  SFLDSPCTL
 
    A  53                                  SFLCLR
 
    A  99                                  SFLEND
 
    A  89        C02MSG        79  M
 
    A            SRS02          4S 0H      SFLRCDNBR
 
    A*
 
    A                                  1  2'USEDPRODFM.02'
 
    A            CMPNO          3Y 0O  1 13EDTCDE(Z)
 
    A                                  1 28'USED PRODUCT REPORTING'
 
    A                                  1 60TIME
 
    A                                  1 70DATE
 
    A                                      EDTCDE(Y)
 
    A                                  2 28'Used Product Entry'
 
    A                                  4  2'Maintain the Number of Used Produc-
 
    A                                      ts'
 
    A                                  5  3'For the Date :'
 
    A            C02MTH        8Y 0O  5 20EDTCDE(4)
 
    A                                  6  2'Type options, press Enter'
 
    A                                  7  2'2=Change '
 
    A                                  9  2'Act Product                      -
 
    A                                      Quantity  Area '
 
    A                                      DSPATR(UL)
 
    A*==============================================================*
 
    A          R R02
 
    A*%%TS  SD  20100512  134524 
 
    A                                24  2'F3=Exit  F6=Add  F12=Cancel'
 
    A*
 
    A          R R03
 
    A*%%TS  SD  20101013  134924 
 
    A                                      CF06(06 'UPDATE')
 
    A  88                                  CSRLOC(ROW03      COL03)
 
    A  89        R03MSG        79  M
 
    A            ROW03          3S 0H
 
    A            COL03          3S 0H
 
    A            R03KEY        15A  H
 
    A            R03CT          2A  H
 
    A*
 
    A                                  1  2'USEDPRODFM.03'
 
    A            CMPNO          3Y 0O  1 13EDTCDE(Z)
 
    A                                  1 28'USED PRODUCT REPORTING'
 
    A                                  1 60TIME
 
    A                                  1 70DATE
 
    A                                      EDTCDE(Y)
 
    A                                  2 28'Used Product Entry'
 
    A                                  5  3'For the Date . .:'
 
    A            R03MTH        8Y 0O  5 22EDTCDE(4)
 
    A                                  5 32'(YYYYMMDD)'
 
    A                                  6  3'PRODUCT    Set .:'
 
    A            R03PRD        30A  O  6 22
 
    A                                  8  3'Quantity . . . .:'
 
    A            R03QTY        6S 0B  8 22
 
    A                                  9  3'Suburb . . . . .:'
 
    A            R03CT2        2A  B  9 22
 
    A                                24  2'F3=Exit  F6=Accept  F12=Cancel'
 
    A          R R04
 
    A*%%TS  SD  20101013  155830 
 
    A                                      CF04(04 'lookup')
 
    A                                      CF06(06 'UPDATE')
 
    A  88                                  CSRLOC(ROW04      COL04)
 
    A  89        R04MSG        79  M
 
    A            ROW04          3S 0H
 
    A            COL04          3S 0H
 
    A            R04CT          2A  H
 
    A*
 
    A                                  1  2'USEDPRODFM.04'
 
    A            CMPNO          3Y 0O  1 13EDTCDE(Z)
 
    A                                  1 28'USED PRODUCT REPORTING'
 
    A                                  1 60TIME
 
    A                                  1 70DATE
 
    A                                      EDTCDE(Y)
 
    A                                  2 28'Used Product Entry'
 
    A                                  5  3'For the Date . .:'
 
    A            R04MTH        8Y 0O  5 22EDTCDE(4)
 
    A                                  5 32'(YYYYMMDD)'
 
    A                                  6  3'PRODUCT    Set .:'
 
    A            R04KEY        15  B  6 22
 
    A            R04PRD        30A  O  6 42
 
    A                                  8  3'Quantity . . . .:'
 
    A            R04QTY        6S 0B  8 22
 
    A                                  9  3'Suburb . . . . .:'
 
    A            R04CT2        2A  B  9 22VALUES('  ' 'HK')
 
    A                                24  2'F3=Exit  F4=Lookup  -
 
    A                                      F6=Accept  F12=Cancel'
 
    A**************
 
    A          R S05                      SFL
 
    A*%%TS  SD  20101013  134924 
 
    A            S05MTH        10A  O  8  2
 
    A            S05KEY        15  O  8 13
 
    A            S05PRD        30A  O  8 29
 
    A            S05CT2        2  O  8 60
 
    A            S05QTY        6Y 0O  8 63EDTCDE(Z)
 
    A*
 
    A*==============================================================*
 
    A          R C05                      SFLCTL(S05)
 
    A*%%TS  SD  20101014  102330 
 
    A                                      SFLSIZ(0014)
 
    A                                      SFLPAG(0014)
 
    A                                      TEXT('Used Product Entry')
 
    A                                      OVERLAY
 
    A  51                                  SFLDSP
 
    A  52                                  SFLDSPCTL
 
    A                                      ROLLUP(61)
 
    A                                      ROLLDOWN(62)
 
    A  53                                  SFLCLR
 
    A  99                                  SFLEND(*MORE)
 
    A  89        C05MSG        79  M
 
    A            SRS05          4S 0H      SFLRCDNBR
 
    A*
 
    A                                  1  2'USEDPRODFM.05'
 
    A            CMPNO          3Y 0O  1 13EDTCDE(Z)
 
    A                                  1 28'USED PRODUCT REPORTING'
 
    A                                  1 60TIME
 
    A                                  1 70DATE
 
    A                                      EDTCDE(Y)
 
    A                                  2 28'Used Product '
 
    A                                  4  2'View the  Used Products  '
 
    A            C05MTH        10  B  6  2
 
    A                                  7 14'Product                          -
 
    A                                              Suburb Quantity'
 
    A*==============================================================*
 
    A          R R05
 
    A*%%TS  SD  20100512  134524 
 
    A                                24  2'F3=Exit              F12=Cancel'
 
    A          R S06                      SFL
 
    A*%%TS  SD  20101013  171041 
 
    A            S06OPT        2A  B 10  2
 
    A            S06KEY        15A  O 10  6
 
    A            S06PRD        30A  O 10 23
 
    A*==============================================================*
 
    A          R C06                      SFLCTL(S06)
 
    A                                      CF06(06 'Create')
 
    A*%%TS  SD  20101013  134924 
 
    A                                      SFLSIZ(0015)
 
    A                                      SFLPAG(0014)
 
    A                                      TEXT('Used Product Entry')
 
    A                                      OVERLAY
 
    A  51                                  SFLDSP
 
    A  52                                  SFLDSPCTL
 
    A  53                                  SFLCLR
 
    A  99                                  SFLEND
 
    A  89        C06MSG        79  M
 
    A            SRS06          4S 0H      SFLRCDNBR
 
    A                                  1  2'USEDPRODFM.06'
 
    A            CMPNO          3Y 0O  1 13EDTCDE(Z)
 
    A                                  1 28'USED PRODUCT REPORTING'
 
    A                                  1 60TIME
 
    A                                  1 70DATE
 
    A                                      EDTCDE(Y)
 
    A                                  2 28'Used Product Entry'
 
    A                                  4  2'Maintain PRODUCTS      '
 
    A                                  6  2'Type options, press Enter'
 
    A                                  7  2'4=Delete'
 
    A                                  9  2'Act Product      '
 
    A                                      DSPATR(UL)
 
    A          R R06
 
    A*%%TS  SD  20101013  134924 
 
    A                                24  2'F3=Exit  F6=Create  F12=Cancel'
 
    A          R R07
 
    A*%%TS  SD  20101013  173309 
 
    A                                      CF06(06 'UPDATE')
 
    A  88                                  CSRLOC(ROW07      COL07)
 
    A  89        R07MSG        79  M
 
    A            ROW07          3S 0H
 
    A            COL07          3S 0H
 
    A*
 
    A                                  1  2'USEDPRODFM.07'
 
    A            CMPNO          3Y 0O  1 13EDTCDE(Z)
 
    A                                  1 28'USED PRODUCT REPORTING'
 
    A                                  1 60TIME
 
    A                                  1 70DATE
 
    A                                      EDTCDE(Y)
 
    A                                  2 28'Used Product Entry'
 
    A                                  5  3'Product Code  .:'
 
    A            R07KEY        15A  B  5 25
 
    A                                  6  3'Description    .:'
 
    A            R07PRD        30A  B  6 25
 
    A                                24  2'F3=Exit  F6=Accept  F1-
 
    A                                      2=Cancel'
 
    A          R S08                      SFL
 
    A*%%TS  SD  20101013  172031 
 
    A            S08OPT        2A  B  7  4
 
    A            S08KEY        15A  O  7  8
 
    A            S08PRD        30A  O  7 25
 
    A*==============================================================*
 
    A          R C08                      SFLCTL(S08)
 
    A*%%TS  SD  20101013  172031 
 
    A                                      WINDOW(7 8 14 60)
 
    A                                      WDWBORDER((*COLOR TRQ) +
 
    A                                      (*DSPATR RI))
 
    A                                      WDWTITLE((*TEXT ' PRDUCT+
 
    A                                      S        ') +
 
    A                                      (*COLOR BLU))
 
    A                                      SFLSIZ(0015)
 
    A                                      SFLPAG(0007)
 
    A                                      TEXT('Used Product Entry')
 
    A                                      OVERLAY
 
    A  51                                  SFLDSP
 
    A  52                                  SFLDSPCTL
 
    A  53                                  SFLCLR
 
    A  99                                  SFLEND
 
    A  89        C08MSG        79  M
 
    A            SRS08          4S 0H      SFLRCDNBR
 
    A*
 
    A                                  1  2'USEDPRODFM.08'
 
    A            CMPNO          3Y 0O  1 13EDTCDE(Z)
 
    A                                  1 17'USED PRODUCT REPORTING'
 
    A                                  1 38DATE
 
    A                                      EDTCDE(Y)
 
    A                                  2 17'Used Product '
 
    A                                  2 38TIME
 
    A                                  3  4'Select the Product'
 
    A                                  4  5'1=Select'
 
    A            C08KEY        15A  B  5  8
 
    A                                  6  8' Product      '
 
 
 
    A          R S09                      SFL
 
    A*%%TS  SD 
 
    A            S09KEY        15A  O  8  4
 
    A            S09PRD        30A  O  8 20
 
    A*
 
    A*==============================================================*
 
    A          R C09                      SFLCTL(S09)
 
    A*%%TS  SD 
 
    A                                      SFLSIZ(0015)
 
    A                                      SFLPAG(0014)
 
    A                                      TEXT('Used Product Entry')
 
    A                                      OVERLAY
 
    A  51                                  SFLDSP
 
    A  52                                  SFLDSPCTL
 
    A  53                                  SFLCLR
 
    A  99                                  SFLEND
 
    A  89        C09MSG        79  M
 
    A            SRS09          4S 0H      SFLRCDNBR
 
    A*
 
    A                                  1  2'USEDPRODFM.09'
 
    A            CMPNO          3Y 0O  1 13EDTCDE(Z)
 
    A                                  1 28'USED PRODUCT REPORTING'
 
    A                                  1 60TIME
 
    A                                  1 70DATE
 
    A                                      EDTCDE(Y)
 
    A                                  2 28'Used Product '
 
    A                                  7  6'Product        '
 
    A                                  4  3'Used Product selected for delet-
 
    A                                      ion.'
 
    A                                  5  3'Press ENTER to DELETE or F12 to ca-
 
    A                                      ncel deletion.'
 
    A*==============================================================*
 
    A          R R09
 
    A*%%TS  SD  20100512  134524 
 
    A                                24  2'F3=Exit              F12=Cancel'
 
 
 
</pre>
 
  
 
=== gettok  not  strtok()===
 
=== gettok  not  strtok()===

Revision as of 06:17, 7 January 2011


SNIPPETS

A snippet is a sort of code template or skeleton that allows you to quickly set up a commonly used code fragment like a subprocedure definition (in ILE RPG). Snippets are available from WDSC 7.0 up.

This differs from code templates because the code template is invoked by the code completion facility Ctrl+Space.

Code completion with templates requires you to start keying the 'trigger' (in RPG, usually the operation code.)

With snippets, you can have Lpex include anything at all, with no trigger needed aside from the double click on the selected snippet.


Snippets View

original post [1]

To open a snippets view:

  • Enable XML Developer capability:
    • Window → Preferences → General → Capabilities, and then check XML Developer.
  • Window → Show view → Other → Basic → Snippets

#top

Create a Snippets Category

original post [2]

  • You only need to create a Category once, conceptually its like CRTSRCPF.
  • Create as many Categories as you wish.
  • -Right-click in the Snippets view and select Customize...
  • -Click the New button and create a New Category
  • -Click the New button and create a New Item
  • -Click on the snippet and then click the New button that is adjacent to the Variables list
  • -Enter your snippet and use the Insert Variable Placeholder button to add the variable

alternatively use the copy, right click process below, its easier.

Use snippets for RPGLE, CLLE, DSPF and PRTF source members.


#top

Snippets RPG

original post [3]

You can use the snippets to insert stuff into your program.

To create your own RPG snippets,

  • you can open the view in RSE or iSeries Editing perspective,
  • select your source,
  • then Right Click / Paste in the snippets view, into your Previously created Category.

It will then create a new template.

To use the snippet;

  • Open a source member for editing.
  • Place the cursor where you want the code.
  • Go to the Snippets view, to the Category where the snippet is.
  • Double click on the snippet and it appears in the source


original post [4]

Another method is to create a Snippet.

  1. Open the Snippets view.
  2. Create a new 'Drawer' for your snippets.
  3. Copy some source.
  4. Right-click in your snippet drawer, paste.
  5. This will bring up the snippet creation wizard.

Long Procedure Name

original post [5]

How do I get the PR to stay at the same column position, irrespective of what name I use for the procedure ?

Use:

D ${Procedure}...
                          PR  

Otherwise the procedure name has to always be 12 characters in length. With the elipsis (...) it can be up to 60 odd characters in length.


#top

Examples

Snippets/Examples

#top

Exporting and importing snippets

ref [[6]]

Snippets can be transferred to another PC by the process of exporting and importing.

You export on the PC you want to copy the snippets from, and import on the PC you want to copy them to.

Exporting

  • In the Snippets view right click and select Customize
  • Select your custom snippet category
  • Select Export (top of the category list, left side)
  • See the 'Save as...' dialogue box, remember the file name you chose!
  • Copy/FTP/email that XML file to the target PC

Importing

  • Get a snippets XML file some place where it's available to WDSC
  • In the Snippets view right click and select Customize
  • Select your custom snippet category
  • Select Import (top of the category list, left side)
  • See the 'Open...' dialogue box.
  • Select the XML file to import

Snippets XML structure

<?xml version="1.0" encoding="UTF-16"?>
<snippets>
    <category filters="*" id="category_1185380127750" initial_state="0" label="RPG" largeicon="" smallicon="">
        <description/>
        <item category="category_1185380127750" class="" editorclass="" id="item_1207666311828" label="subprocedure" largeicon="" smallicon="">
            <description><![CDATA[Subprocedure skeleton]]></description>
            <content><![CDATA[
      * ${proc_comment}
     p ${proc_name}        b
     d ${proc_name}        pi            10i 0
     d  ${parm_name}                      1a
     
     d rc                            10i 0 inz

     c/free
        return rc;
      /end-free
     p                 e]]></content>
            <variable default="Description of procedure" id="name_3" name="proc_comment">
                <description><![CDATA[Description]]></description>
            </variable>
            <variable default="new_parm" id="name_2" name="parm_name">
                <description><![CDATA[Parameter name]]></description>
            </variable>
            <variable default="new_proc" id="name_1" name="proc_name">
                <description><![CDATA[Procedure name]]></description>
            </variable>
        </item>
    </category>
</snippets>


#top

DayOfWeek snippet

ref [[7]]


     * // Procedure:  DayOfWeek                                           //
     * // Purpose:  Determine the day of week for a particular date       //
     * // Parameters:                                                     //
     * //    I: dt   -- date                                              //
     *
     * // Returns:                                                        //
     * //    0..6    -- 0=Sunday, 1=Monday, 2=Tuesday, etc.               //
     * // Notes:                                                          //
     * //    January 5, 1800 is a Sunday.  This procedure only works for  //
     * //    dates later than 1800-01-05.                                 //
     * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
    P DayOfWeek       b
    P
    D DayOfWeek       pi            10i 0
    D
    D   dt                            d   value datfmt(*iso)
     /free
        return %rem (%diff (dt: d'1800-01-05': *days): 7);
     /end-free
    P DayOfWeek       e
                                                                                          

#top

FirstFriday snippet

    H DFTACTGRP(*NO ) OPTIMIZE(*NONE) OPTION(*NODEBUGIO)                  
                                                                          
                          
    D WDATE           S             10A                                   
                                                                          
                             
    D FirstFriday     PR             1A                                   
    D  Wdate                        10A                                   
                                                                          
               
     /FREE                                                                
        *INLR = *on;                                         
        WDATE = '2008-12-05';                                                   
        *IN01 = FirstFriday(WDATE);                                             
     /END-FREE  
                                                               
     * // Procedure:  FirstFriday                                         //
     * // Purpose:  Determine if the date is the First Friday             //
     * // Parameters:                                                     //
     * //    I: WDATE  -- 10 character ISO delim date                     //
     *
     * // Returns:                                                        //
     * //    0..1    -- 0=NO, 1=YES                                       //
     * // Notes:                                                          //
     * //    January 5, 1800 is a Sunday.  This procedure only works for  //
     * //    dates later than 1800-01-05.                                 //
     * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
    P FirstFriday     B                                                         
    P                                                                           
    D FirstFriday     PI             1A                                         
    D  WDATE                        10A                                         
                                                                                
     /free                                                                      
                                                                                
       if %rem(%abs(%diff (%DATE(WDATE) : d'1800-01-05': *days)): 7) = 5        
         and %subdt(%DATE(WDATE)  :*D) <=7;                                     
           // it is the first Friday of the month                               
           RETURN '1';                                                          
      endif;                               
          RETURN '0';                      
                                           
    /end-free                              
   P FirstFriday     E                     


#top

System Date snippet

ref [[8]]

Time also works Return  %INT(%CHAR(%TIME():*ISO0)) set PI to 6S 0.

     * // Procedure:  SysDate                                             //
     * // Purpose:  Gets the system date YYYYMMDD format 8S 0              //
     * // Parameters:                                                     //
     * // Returns:                                                        //
     * //    int    -- date in YYYYMMDD fmt                               //
    * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
    P SysDate         B                         
    P                                           
    D SysDate         PI             8S 0       
    D                                           
     /free                                      
        Return     %INT(%CHAR(%DATE():*ISO0));  
     /end-free                                  
    P SysDate         E                         

#top

CLLE Subroutine

ref [[9]]

Sample code V5R4

START:      PGM
   SAVLIB     LIB( PVCPROD)  DEV(TAP01) ENDOPT(*LEAVE)   /* Daily library backup */
   MONMSG     MSGID(PVC0001)  EXEC(DO)
      CALLSUBR BADLIBSAVE
   ENDDO
RETURN
SUBR BADLIBSAVE
 /* test */
ENDSUBR
ENDPGM

#top

RPG SYSTEM NAME

ref: [[10]]


D RtvSysName      PR             8A                                       
D   MyName        S             10A                                       
C                   eval      *inlr = *on                                 
C                   EVAL      MyName =   RtvSysName()                     
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++    
*  Retrieve System Name                         
P RtvSysName      B                   Export                              
D RtvSysName      PI             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           256                                            
D* Receiver variable for QWCRNETA                      
D DS              ds                                                          
D  Filler                       32A                                         
D  RtnSystem                     8A                                         
 * Call API to get system name                                                
C                   callp     QWCRNETA(DS: %size(DS): 1: 'SYSNAME': EC)       
C                   return    RtnSystem                  
P                 E                                                           

#top


MODS w/POINTERS

ref: [[11]]

DEdtCstRtn        PR                  ExtPgm('@EDTCSTRTN')
D SubParm                             Like(MyStruct)
D SubParm1                            Like(Struct1)

Dmystruct       e ds                  ExtName(EDTCSTPF)
D                                     occurs(500)
DStruct1        e ds                  ExtName(EDTCSTHDR)

I fill the structure and then call the second program

    %occur(myStruct) = 1;
    Callp EdtCstRtn(MyStruct:Struct1);

Here is the code from the Called program:

DCstRtnParm       PR                  ExtPgm('@EDTCSTRTN')
DPlistPR                              Like(PlistParm)
DPlist1PR                             Like(Plist1)
DCstRtnParm       PI
DPlistPI                              Like(PlistParm)
DPlist1PI                             Like(Plist1)

DPlistParm      e ds                  ExtName(EDTCSTPF)
D                                     occurs(500)
D                                     based(p_PlistParm)
DPlist1         e ds                  ExtName(EDTCSTHDR)
D                                     based(p_Plist1)

 /free
     p_PlistParm = %addr(PlistPI);
     p_Plist1    = %addr(Plist1PI);

... do NOT EVAL one to the other... ... simply access PlistParm as a normal MODS.

#top


QUSRSPLA CL with STG(*DEFINED) DEFVAR

ref: [[12]]

[| See IBM defn of the SPLA0100 format for whatever attribute you need.]

/*     GET A SPOOL FILE ATTRIBUTE                                   */     
            PGM        PARM(&SPLF &FULLJOB  &RTNWID   )                   
                                                                          
            DCL        &SPLF *CHAR LEN(10)                                
            DCL        &FULLJOB *CHAR LEN(26)                             
                                                                          
            DCL        &SPLNBR *CHAR LEN(5)                               
            DCL        &SPLNBRD *DEC LEN(9 0)                             
            DCL        &SPLNBRB *CHAR LEN(4)                              
                                                                          
            DCL        &DSLEND *DEC LEN(9 0)                              
            DCL        &DSLENB *CHAR LEN(4)                               
                                                                          
            DCL        &INTJOB *CHAR LEN(16)                              
            DCL        &INTSPLF *CHAR LEN(16)                             
            DCL        &RTNWID *DEC (15 5)                                
                                                                          
            DCL        &DS      *CHAR LEN(1000)                           
            DCL        &RTNWIDTH *DEC (15 5) STG(*DEFINED) DEFVAR(&DS 889)
                                                                     
     /* GET LAST SPOOL FILE */                                       
           CHGVAR     &SPLNBRD -1                                    
           CHGVAR     %BIN(&SPLNBRB 1 4) &SPLNBRD                    
     /* USE 1000 BYTE DS        */                                   
           CHGVAR     &DSLEND 1000                                   
           CHGVAR     %BIN(&DSLENB 1 4) &DSLEND                      
                                                                     
     /* CALL API TO GET SPLFA */                                     
     /* OFFSET 888 CONTAINS THE WIDTH AS PACKED DECIMAL 15,5 */      
           CALL       QUSRSPLA PARM(&DS &DSLENB 'SPLA0100' +         
                       &FULLJOB &INTJOB &INTSPLF &SPLF &SPLNBRB)     
           MONMSG  CPF0000                                           
                                                                     
RTNWID:     CHGVAR &RTNWID    &RTNWIDTH                               
                                                                     
           RETURN                                                    
           ENDPGM                                                    

#top


RPG WAIT sim DLYJOB

ref: [[13]]

    HBNDDIR('QC2LE') DFTACTGRP(*NO) ACTGRP(*NEW)
     * this uses the C sleep API 
     * this is a sample program named 'PSLEEP' to demo the call to the sleep API  
     * to test,  call  PSLEEP '0000000005'
     *
    D PSLEEP          PR
    D SECSA                         10A
    D PSLEEP          PI
    D SECSA                         10A
     *
    D WAIT            PR             1A
    D SECS                          10U 0
  
    D CURTIME         S               T
    D SECS            S             10U 0
    D ANS             S             20A
  
    D SECSDS          DS            10
    D SECSN                         10S 0
 
     /FREE
           *INLR = *ON;
    
           SECSDS = SECSA;
           SECS   = SECSN;
     
           CURTIME = %TIME();
           DSPLY CURTIME;
    
            WAIT(SECS);
    
           CURTIME = %TIME();
           DSPLY CURTIME ' ' ANS;
      /END-FREE
  
     * // Procedure:  Sleep                                               //
     * // Purpose:  Wait for a number of  seconds                         //
     * // Parameters:                                                     //
     * //    I: WSECS  -- 10 int                                          //
     *
     * // Returns:                                                        //
     * //    0..1    -- 0=NOT OK, 1=OK                                    //
     * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
    P WAIT            B
    P
    D WAIT            PI             1A
    D WSECS                         10U 0
 
    DSLEEP            PR             1A   EXTPROC(X'A293858597')
    D SECS                          10U 0 VALUE
 
     /FREE
          RETURN  SLEEP(WSECS);
     /END-FREE
    P WAIT            E      

#top

GET ROW AND COL FOR A DSPF FIELD FOR CSRLOC

ref: [[14]][[15]]


This is an example program showing the usage of the GETROWCOL procedure.

Its purpose is to set up the ROW and COL for CSRLOC to position to a FIELD in error without the need for indicators.

You can use a ERRMSG or ERRMSGID on a dummy O field so you will still need to use one indicator for an error.

If you use ERRMSG or ERRMSGID you will need to position the cursor with a Write before you turn on the indicators for ERRMSG and ERRMSGID.

     H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER)
      *
 
     D   FILE          S             10A   INZ('URFILE')
     D   FORMAT        S             10A   INZ('URFMT')
     D   FLDNAM        S             10A   INZ('URFLD')
     D   ROW           S              3S 0
     D   COL           S              3S 0
 
     D GETROWCOL       PR
     D                               10A   const
     D                               10A   const
     D                               10A   const
     D                               32A   const
     D                                3S 0
     D                                3S 0
      /free
           *INLR = *ON;
           GETROWCOL  (FILE :'*LIBL' : FORMAT : FLDNAM : ROW : COL);
      /end-free
  
     P GETROWCOL       B
      *
      *    Retreive a DSPF FIELD  Row and Col
      *    Used for Setting  CSRLOC for cursor positioning
      *    USAGE
      *    GETROWCOL  (FILE :'*LIBL' : FORMAT : FLDNAM : ROW : COL)
      *
     D GETROWCOL       PR
     D   schFile                     10A   const
     D   schLib                      10A   const
     D   schFormat                   10A   const
     D   schString                   32A   const
     D   rtnROW                       3S 0
     D   rtnCOL                       3S 0
 
     D GETROWCOL       PI
        //  PARMS  IN 
     D   schFile                     10A   const
     D   schLib                      10A   const
     D   schFormat                   10A   const
     D   schString                   32A   const
        //  PARMS  OUT
     D   rtnROW                       3S 0
     D   rtnCOL                       3S 0
 
     D QUSCRTUS        PR                  ExtPgm('QUSCRTUS')
     D   UserSpace                   20A   CONST
     D   ExtAttrib                   10A   CONST
     D   InitialSize                 10I 0 CONST
     D   InitialVal                   1A   CONST
     D   PublicAuth                  10A   CONST
     D   Text                        50A   CONST
     D   Replace                     10A   CONST options(*nopass)
     D   ErrorCode                32767A   options(*varsize:*nopass)
 
     D QUSPTRUS        PR                  ExtPgm('QUSPTRUS')
     D   UserSpace                   20A   CONST
     D   Pointer                       *
 
     D QUSDLTUS        PR                  ExtPgm('QUSDLTUS')
     D   UserSpace                   20A   CONST
     D   ErrorCode                32767A   options(*varsize)
 
     D QUSLFLD         PR                  ExtPgm('QUSLFLD')
     D   UsrSpc                      20A   const
     D   Format                       8A   const
     D   QualFile                    20A   const
     D   RcdFmt                      10A   const
     D   UseOvrd                      1A   const
     D   ErrorCode                32767A   options(*nopass:*varsize)
 
     D ErrorCode       ds                  qualified
     D   BytesProv                   10I 0 inz(0)
     D   BytesAvail                  10I 0 inz(0)
 
     D ListHeader      ds                  based(p_ListHeader)
     d   ListOffset                  10I 0 overlay(ListHeader:125)
     d   EntryCount                  10I 0 overlay(ListHeader:133)
     d   EntrySize                   10I 0 overlay(ListHeader:137)
 
     D Field           ds                  based(p_Field)
     D                                     qualified
     D  Name                         10a
     D  FILLER                      438a
     d  DspRow                       10i 0
     d  DspCol                       10i 0
 
     D TEMPSPC         C                   'GETROWCOL QTEMP'
 
     D x               s             10I 0
 
      /free

                  rtnROW =    999;
                  rtnCOL =    999;
           // --------------------------------------------------
           // Delete the user space if it exists (ignore errors)
           ErrorCode.BytesProv = %size(ErrorCode);
           QUSDLTUS( TEMPSPC: ErrorCode );
           ErrorCode.BytesProv = 0;
 
           // --------------------------------------------------
           // Create a new 128k user space
           QUSCRTUS( TEMPSPC : 'SCHTEXT' : 128 * 1024   : x'00'
                   : '*EXCLUDE' : 'List of fields in file' : '*NO'
                   : ErrorCode );
 
           // --------------------------------------------------
           // Dump list of fields in file to user space
           // Invalid data is ignored and is 999 returned for row and col
           monitor;
           QUSLFLD( TEMPSPC : 'FLDL0100'  : SchFile + SchLib
                  : SchFormat  : *OFF  : ErrorCode );
               on-Error;
                 RETURN;
            EndMon;
           // --------------------------------------------------
           // Get a pointer to the user space
           QUSPTRUS( TEMPSPC: p_ListHeader );
 
           // --------------------------------------------------
           // Loop through all fields in space, to get the field we need
           for x = 0 to (EntryCount - 1);
               p_Field = p_ListHeader + ListOffset + (EntrySize * x);
 
               if Field.Name = schString;
                  rtnRow =    Field.DspRow;
                  rtnCol =    Field.DspCol;
                 leave;
               endif;
           endfor;
 
           // --------------------------------------------------
           // Delete temp user space & end
           QUSDLTUS( TEMPSPC: ErrorCode );
 
            return;
 
      /end-free
     P                 E       

#top

Format the date like "Wed, 12 Dec 2001 13:21:01

ref [[16]]

RFC2822 requires a date in the format "Wed, 12 Dec 2001 13:21:01 -0500".

ILE procedure that makes use of SQL


h option(*nodebugio:*srcstmt) dftactgrp(*no) actgrp('QILE')
                                                           
d getWordyDate    pr                  like(WordyDate)      
                                                           
d WordyDate       s             31                         
d reply           s              1                         
                                                           
c                   eval      WordyDate = getWordyDate()   
c     WordyDate     dsply                   reply          
c                   eval      *inlr = *on                  
                                                           
p getWordyDate    b                                        
d getWordyDate    pi                  like(WordyDate)      
                                                          
d tz              s              6  0                      
d t               s               t                        
d d               s               d                        
d dn              s              9                         
d mn              s              9                         
d rtn             ds                                             
d  ShortDayName                  3                               
d                                2    inz(', ')                  
d  DayNumeric                    2  0                            
d                                1    inz(' ')                   
d  ShortMonthName                3                               
d                                1    inz(' ')                   
d  YearNumeric                   4  0                            
d                                1    inz(' ')                   
d  TimeOut                        t   timfmt(*hms)               
d                                1    inz(' ')                   
d  TimeZone                      5                               
                                                                 
c/exec sql                                                       
c+ set (:tz,:TimeOut,:d,:dn,:mn) = (current_timezone,            
c+ current_time, current_date, substr(dayname(current_date),1,9),
c+ substr(monthname(current_date),1,9))                          
c/end-exec                                                       
                                                                 
c                   eval      DayNumeric = %subdt(d:*d)               
c                   eval      YearNumeric = %subdt(d:*y)              
c                   eval      ShortDayName = dn                       
c                   eval      ShortMonthName = mn                     
c                   eval      TimeZone =                              
c                             %trim(%editw(%dec(tz/100:4:0):'0-    '))
                                                                      
c                   return    rtn                                     
p getWordyDate    e     


USING the CEE APIs

 ** Get local time API
d CEELOCT         PR                  opdesc
d   output_lil                        Like(discard1)
d   output_secs                       Like(cur_time)
d   output_greg                       Like(discard2)
d   output_fc                         Like(Fc) Options(*Nopass)
 ** Convert to arbitrary timestamp API
d CEEDATM         PR                  opdesc
d   input_secs                        Like(cur_time)
d   picture_str                       Like(Pictureds) const
d   output_ts                         Like(Pictureds)
d   output_fc                         Like(Fc) Options(*Nopass)
 * Get offset from UTC API
d CEEUTCO         PR
d  hours                              Like(hrs2utc)
d  minutes                            Like(mins2utc)
d  seconds                            Like(cur_time)
d  output_fc                          Like(Fc) Options(*Nopass)

d discard1        S             10I 0
d cur_time        S              8F
d discard2        S             23A
d hrs2utc         s             10I 0
d mins2utc        s                   Like(hrs2utc)
d hh              s              2A
d mm              s              2A
d discard3        s                   Like(cur_time)
d WDate           s                   Like(Pictureds) 

d Fc              ds
d  sev                           5U 0
d  msgno                         5U 0
d  flags                         1A
d  facid                         3A
d  isi                          10U 0
d Pictureds       ds
d  Piclen1                1      2I 0
d  Picture                3     34A
d  Piclen2                1      4I 0
d  Picture2               5     36A

 * Get current local time from clock:
c                   Callp     CEELOCT(discard1 : cur_time : discard2)
 * Convert to e-mail format:
c                   Callp     CEEDATM(cur_time :
c                                     'Www, DD Mmm YYYY HH:MI:SS' :
c                                     WDate)
 * Retrieve offset from UTC
c                   Callp     CEEUTCO(hrs2utc : mins2utc : discard3)
 * Format the UTC offset nicely
 *   and tack it onto the string...
c                   If        hrs2utc < *Zero
c                   Eval      WDate = %trimr(WDate) + ' -'
c                   Eval      hrs2utc = 0 - hrs2utc   
c                   Else
c                   Eval      WDate = %trimr(WDate) + ' +'
c                   EndIf
c                   Move      hrs2utc       hh
c                   Move      mins2utc      mm
c                   Eval      WDate = %TrimR(WDate) + hh + mm 


#top

Templates

Snippets/Templates

#top


gettok not strtok()

ref: [[17]]

From: Scott Klement

     H DFTACTGRP(*NO)

     D gettok          PR          1024A   varying
     D   string                   65535A   varying const options(*varsize)
     D   delims                      50A   varying const
     D   pos                         10I 0

     d blah            s            100A   varying
     D tokens          s            100A   varying dim(50)
     D x               s             10I 0
     D y               s             10I 0

     D msg             s             52A

      /free

          Blah = 'Test||||||123|x|||8900';
          x = 0;
          y = 0;

          //
          //  Get each token from the string and DSPLY it
          //

          dow ( x <= %len(blah) );
             y = y + 1;
             msg = 'token ' + %char(y) + '='
                 + gettok( blah : '|' : x );
             dsply msg;
          enddo;

          //
          // Or, perhaps just dump all tokens to an array
          //

          x = 0;
          tokens(*) = gettok( blah : '|' : x );

          for y = 1 to %elem(tokens);
             msg = 'elem ' + %char(y) + '=' + tokens(y);
             dsply msg;
          endfor;

          *inlr = *on;

      /end-free




      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      * gettok():  Get next token from string
      *
      *     string = (input) string to search
      *     delims = (input) delimiters
      *        pos = (i/o) next position to search.  At the start
      *                    of a string, set this to zero.  Pass
      *                    it on subsequent calls to remember where
      *                    you left off.
      *
      * Returns the token found.
      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     P gettok          B
     D gettok          PI          1024A   varying
     D   string                   65535A   varying const options(*varsize)
     D   delims                      50A   varying const
     D   pos                         10I 0

     D res             s           1024A   varying
     D start           s             10I 0
     D c               s              1A

      /free

          start = pos + 1;
          %len(res) = 0;

          for pos = start to %len(string);

             c = %subst(string:pos:1);

             if %check(delims:c) = 1;
                res = res + c;
             else;
                leave;
             endif;

          endfor;

          return res;

      /end-free
     P                 E

Thanks Scott. Without your work I would still be coding RPGIII.


#top



External links

The official WDSC web page [18]

The WDSC Developer blog [19]

WDSC tags on del.ici.ous [20]

Categories