RPGIV @ Work

A unique site for RPG and System i Lovers

Welcome!

Hi, this site will provide all what you need in System i and RPG developments.

My Name is Chamara Withanachchi, System i Expert and RPG Developer. And in the field for last 11 years.

I hope you will find lot of valuable information from this site

Display User Space Print E-mail
User Rating: / 1
PoorBest 
Written by Chamara Withanachchi   
Display User Space

Thanks to code400.com


RPG Program


     FUSRSPCD   cf   e             workstn sfile(sfl001:sflrn1)
     F                                     infds(wsds)
      ** Width of subfile record
     D limit           c                   const(70)
      ** Number of subfile records
     D norecs          c                   const(12)

     D SpaceLib        s             20

     D spcptr          s               *

      * API Error Data Structure
     D api_err         ds
     D  errbytes               1      4b 0
     D  errbytesava            5      8b 0
     D  exception              9     15
     D  reserved              16     16
     D  data                  17    271

     D spcarray        s              1a   based(lineptr)
     D                                     Dim(Limit)

     D lineptr         s               *   inz(%addr(spline))

     D spcdstr         ds                  based(spcptr)
     D  spcdata                       1a
     D  nextbyte                      1a

     D index           s              5p 0
     D count           s              5p 0
     D sflrn1          s              4p 0
     D returnpt        s              6a

     D pgmsds         sds
     D  @@@pgm                 1     10
     D  @@@sts                11     15  0
     D  @@@stp                16     20
     D  @@@seq                21     28
     D  @@@psr                29     36
     D  @@@prm                37     39  0
     D  @@@typ                40     42
     D  @@@nbr                43     46
     D  @@@smi                47     50
     D  @@@ara                51     80
     D  @@@lib                81     90
     D  @@@dta                91    170
     D  @@@sid               171    174
     D  @@@rs1               175    200
     D  @@@fil               201    208
     D  @@@fis               209    243
     D  @@@job               244    253
     D  @@@usr               254    263
     D  @@@jbn               264    269  0
     D  @@@jdt               270    275  0
     D  @@@pgd               276    281  0
     D  @@@pgt               282    287  0
     D  @@@cmd               288    293
     D  @@@cmt               294    299
     D  @@@cml               300    303
     D  @@@src               304    313
     D  @@@srl               314    323
     D  @@@srm               324    333
     D  @@@rs2               334    429
      *
      * Standard include for all interactive programs
      *   named hexadecimal constants for function keys
     D @f01            c                   const(x'31')
     D @f02            c                   const(x'32')
     D @f03            c                   const(x'33')
     D @f04            c                   const(x'34')
     D @f05            c                   const(x'35')
     D @f06            c                   const(x'36')
     D @f07            c                   const(x'37')
     D @f08            c                   const(x'38')
     D @f09            c                   const(x'39')
     D @f10            c                   const(x'3A')
     D @f11            c                   const(x'3B')
     D @f12            c                   const(x'3C')
     D @f13            c                   const(x'B1')
     D @f14            c                   const(x'B2')
     D @f15            c                   const(x'B3')
     D @f16            c                   const(x'B4')
     D @f17            c                   const(x'B5')
     D @f18            c                   const(x'B6')
     D @f19            c                   const(x'B7')
     D @f20            c                   const(x'B8')
     D @f21            c                   const(x'B9')
     D @f22            c                   const(x'BA')
     D @f23            c                   const(x'BB')
     D @f24            c                   const(x'BC')
     D @clear          c                   const(x'BD')
     D @enter          c                   const(x'F1')
     D @help           c                   const(x'F3')
     D @pagup          c                   const(x'F4')
     D @pagdn          c                   const(x'F5')
     D @print          c                   const(x'F6')
      * Standard include for all interactive programs
      *   display file information data structure
     D wsds            ds
      *               Identifies the key pressed
     D  key                  369    369
      *               Identifies the subfile page rrn
     D  pagrrn               378    379b 0
      *

     C                   call      'QUSPTRUS'
     C                   parm                    SpaceLib
     C                   parm                    spcptr
     C                   parm                    api_err

     C                   write     cmdfmt

     C                   exsr      loadnext
     C                   dow       key <> @f03
      ** Error trap - fell off the end of the Space - display last screen
     C     PtrError      Tag
     C                   select
     C                   when      key = @pagdn
     C                   exsr      loadnext
     C                   exfmt     sflctl
     C                   other
     C                   eval      pos = 1
     C                   exfmt     sflctl
     C                   endsl

     C                   enddo

     C                   eval      *inlr = *on
     C                   return

     C     *inzsr        begsr
     c     *entry        plist
     c                   parm                    SpaceLib
     c                   eval      Space = %subst(Spacelib:1:10)
     c                   eval      Lib   = %subst(Spacelib:11:10)
     C                   eval      sflrn1 = 1
     C                   eval      pos = 1
     C                   endsr

     C     loadnext      begsr

     C                   eval      count = 1
     C                   dow       (count <= norecs) and (not *in99)
     C                   do        limit         index
     C                   If        SpcData < X'40'
     C                   Eval      SpcArray(Index) = X'41'
     C                   Else
     C                   eval      spcarray(index) = spcdata
     C                   Endif
     C                   eval      spcptr = %addr(nextbyte)
     C                   enddo
     C                   eval      line# = (sflrn1 * limit) - (limit - 1)
     C                   write     sfl001
     C                   eval      spline = *blanks
     C                   eval      sflrn1 = sflrn1 + 1
     C                   eval      count = count + 1
     C                   enddo
     C                   eval      pos = sflrn1 - 1
     C                   endsr

     C     *Pssr         Begsr
     c                   Select
      ** Overflowed User Space - complete last line and display
     C                   When      @@@sts= 00222
     C                   Eval      *In99 = *ON
     C                   eval      line# = (sflrn1 * limit) - (limit - 1)
     C                   Write     Sfl001
     C                   Eval      Pos = sflrn1 - 1
     C                   Exfmt     SflCtl
     C                   Other
     C                   Endsl
     C                   GoTo      PtrError
     C                   Endsr

Screen


     A                                      DSPSIZ(24 80 *DS3)
     A                                      CA03
     A          R SFL001                    SFL

     A            LINE#          5Y 0O  8  2EDTCDE(3)
     A            SPLINE        70A  O  8  8
     A          R SFLCTL                    SFLCTL(SFL001)
     A                                      SFLSIZ(0013)
     A                                      SFLPAG(0012)
     A                                      PAGEDOWN
     A                                      CA12
     A                                      OVERLAY
     A N85                                  SFLDSP
     A N85                                  SFLDSPCTL
     A  85                                  SFLCLR
     A  99                                  SFLEND(*MORE)
     A            POS            4S 0H      SFLRCDNBR
     A            @@@PGM        10A  O  1  3
     A                                  1 29'Display User Space Data'
     A                                      DSPATR(HI)
     A                                  1 73DATE
     A                                      EDTCDE(Y)
     A            @@@USR        10A  O  2  3
     A                                  2 73TIME
     A                                  4  3'User Space ...:'
     A                                      DSPATR(HI)
     A            SPACE         10A  O  4 19
     A                                  5  3'Library ......:'
     A                                      DSPATR(HI)
     A            LIB           10A  O  5 19
     A                                  7  8'*...+....1....+....2....+....3....-
     A                                      +....4....+....5....+....6....+....-
     A                                      7'
     A            FLD001         3   B  4 40RANGE('000' '999')
     A                                      CHECK(RZ)
     A          R CMDFMT

     A                                 22  2'F3=Exit'
     A                                      COLOR(BLU)
 

User Comments

Please login or register to add comments

<Previous   Next>