Learn from sources
       star star star Member READCSFL in CGIDEV2 / QRPGLESRC

       *=====================================================================
       *  RPG ILE MODULE CGIDEV2/READCSFL
       *
       *  After compiling this RPG MODULE,
       *  create the related program with the following command:
       *
       *  CRTPGM CGIDEV2/READCSFL MODULE(CGIDEV2/READCSFL CGIDEV2/QDECFMT) ACTGRP(READCSFL)
       *
       *  To execute this program,
       *  enter the following in your WEB browser command line:
       *    http://.../cgidev2p/READCSFL.pgm
       *
       *=====================================================================
       /copy CGIDEV2/qrpglesrc,hspecs
       /copy CGIDEV2/qrpglesrc,hspecsbnd
      FITEMINV   uf a e           k disk    usropn
      F                                     extfile('CGIDEV2/ITEMINV')
       *=====================================================================
       * Includes to be used in CGIs
       *=====================================================================
       /copy CGIDEV2/qrpglesrc,prototypeb
       /copy CGIDEV2/qrpglesrc,usec
       /copy CGIDEV2/qrpglesrc,variables3
       *=====================================================================
       * Variables specific to this module
       *=====================================================================
       * Client input variables
      D request         s             10a
      D prvitmcod       s                   like(itmcod)
      D prvitmdes       s                   like(itmdes)
      D prvitmprc       s             10a
      D prvitmqty       s              7a
      D newitmcod       s                   like(itmcod)
      D newitmdes       s                   like(itmdes)
      D newitmprc       s             10a
      D newitmqty       s              9a
       *
       * Other variables
      D decfmt          s              1
      D nbrlines        s             10i 0
      D i               s             10i 0
      D l               s             10i 0
       * External HTML
      D extHtml         s           2000    inz('/cgidev/html/readcsfl.txt')
       * Indicators for GetHtmlIfsMult subprocedure
      D IfsMultIndicators...
      d                 ds
      D  NoErrors                       n
      D  NameTooLong                    n
      D  NotAccessible                  n
      D  NoFilesUsable                  n
      D  DupSections                    n
      D  FileIsEmpty                    n
       * Fields required by CHKNBR subprocedure
      D ChkNbrDs        ds
      D   anyerrs                       n
      D   invalidchrs                   n
      D   multdecpts                    n
      D   multsigns                     n
      D   nonbrs                        n
      D   toobig                        n
      D   lessthan0                     n
      D maxdigits       s             10i 0
      D badNumSW        s               n
       * Fields required by C2N2 subprocedure
      D c2n2itmprc      s             30p 9
      D c2n2itmqty      s             30p 9
       *=====================================================================
       * Main line
       *=====================================================================
       /copy CGIDEV2/qrpglesrc,prolog3
      C                   eval      request   = zhbgetvarupper('request')
       * Open file
      C                   exsr      OpenDbf
       * Load external html
      C                   eval      IfsMultIndicators = getHtmlIfsMult(
      C                             %trim(exthtml):'«as400»')
       * Retrieve decimal format
      C                   callb     'QDECFMT'
      C                   parm                    decfmt
      C                   callp     updhtmlvar('qdecfmt':decfmt)
       *
      C                   select
      C                   when      request=' '
      C                   exsr      Case1
      C                   when      request='READC'
      C                   exsr      Case2
      C                   endsl
       *
      C                   exsr      Exit
       *=====================================================================
       * Display the subfile
       *=====================================================================
      C     Case1         begsr
      C                   callp     wrtsection('top')
      C                   eval      itmcod=' '
      C     itmcod        setll     itmrcd
      C                   read      itmrcd
       *
      C                   dow       not %eof
      C                   update    itmrcd
      C                   callp     updhtmlvar('itmcod':itmcod)
      C                   callp     updhtmlvar('itmdes':itmdes)
      C                   callp     updhtmlvar('itmprc':
      C                             %trim(%editc(itmprc:'3')))
      C                   callp     updhtmlvar('itmqty':
      C                             %trim(%editc(itmqty:'3')))
      C                   callp     wrtsection('tabrow')
      C                   read      itmrcd
      C                   enddo
       *
      C                   callp     wrtsection('newitem')
       *
      C                   endsr
       *=====================================================================
       * ReadChange the subfile, then re-display it
       *=====================================================================
      C     Case2         begsr
       * ReadChange the subfile
       *  1- Get the number of subfile lines
      C                   eval      nbrlines = zhbGetVarCnt('newitmcod')
       *  2- Process each subfile line
      C                   IF        nbrlines»0
      C     1             do        nbrlines      i
      C                   eval      prvitmcod = zhbgetvar('prvitmcod':i)
      C                   eval      prvitmdes = zhbgetvar('prvitmdes':i)
      C                   eval      prvitmprc = zhbgetvar('prvitmprc':i)
      C                   eval      prvitmqty = zhbgetvar('prvitmqty':i)
      C                   eval      newitmcod = zhbgetvarupper('newitmcod':i)
      C                   eval      newitmdes = zhbgetvarupper('newitmdes':i)
      C                   eval      newitmprc = zhbgetvarupper('newitmprc':i)
      C                   eval      newitmqty = zhbgetvarupper('newitmqty':i)
      C                   exsr      AddUpd
      C                   enddo
      C                   ENDIF
       * Re-display the subfile
      C                   exsr      Case1
       *
      C                   endsr
       *=====================================================================
       * Update the database file
       *=====================================================================
      C     AddUpd        begsr
       * 1-Add a new record
      C                   IF        prvitmcod=' ' and
      C                             prvitmdes=' ' and
      C                             prvitmprc=' ' and
      C                             prvitmqty=' ' and
      C                             newitmcod«»' ' and
      C                             newitmdes«»' ' and
      C                             newitmprc«»' ' and
      C                             newitmqty«»' '
      C     newitmcod     chain     itmrcd
      C                   if        not %found
      C                   exsr      wrkNumFlds
      C                   iF        badNumSw=*off
      C                   eval      itmcod = newitmcod
      C                   eval      itmdes = newitmdes
      C                   eval      itmprc = c2n2itmprc
      C                   eval      itmqty = c2n2itmqty
      C                   write     itmrcd
      C                   endif
      C                   elsE
      C                   update    itmrcd
      C                   endiF
       *
      C                   ELSE
       *
       * 2-Update an existing record
      C                   If        prvitmcod«»newitmcod or
      C                             prvitmdes«»newitmdes or
      C                             prvitmprc«»newitmprc or
      C                             prvitmqty«»newitmqty
      C     prvitmcod     chain     itmrcd
      C                   iF        %found
      C                   exsr      wrkNumFlds
      C                   if        badNumSw=*off
      C                   eval      itmcod = newitmcod
      C                   eval      itmdes = newitmdes
      C                   eval      itmprc = c2n2itmprc
      C                   eval      itmqty = c2n2itmqty
      C                   endif
      C                   update    itmrcd
      C                   endiF
      C                   endIf
       *
      C                   ENDIF
       *
      C     AddUpdX       tag
      C                   endsr
       *=====================================================================
       * Work with numeric input fields
       *=====================================================================
      C     WrkNumFlds    begsr
       * Align right numeric input fields
      C                   exsr      AlignR
       * Check numeric input fields
      C                   exsr      ChkNum
       * Convert numeric input fields
      C                   if        badNumSw=*off
      C                   exsr      C2N2Cvt
      C                   endif
      C*
      C                   endsr
       *=====================================================================
       * Align right numeric input fields,
       * convert leading blanks to zeroes
       *=====================================================================
      C     AlignR        begsr
      C     ' '           checkr    newitmprc     l
      C                   if        l«%size(newitmprc)
      C                   eval      newitmprc=%subst(newitmprc:l+1:
      C                             %size(newitmprc)-l) +
      C                             %subst(newitmprc:1:l)
      C                   endif
      C     ' ':'0'       xlate     newitmprc     newitmprc
       *
      C     ' '           checkr    newitmqty     l
      C                   if        l«%size(newitmqty)
      C                   eval      newitmqty=%subst(newitmqty:l+1:
      C                             %size(newitmqty)-l) +
      C                             %subst(newitmqty:1:l)
      C                   endif
      C     ' ':'0'       xlate     newitmqty     newitmqty
       *
      C                   endsr
       *=====================================================================
       * Check numeric input fields
       *=====================================================================
      C     ChkNum        begsr
      C                   eval      badNumSW=*off
       * Check numeric inputs through subprocedure ChkNbr
      C                   eval      maxdigits=%size(newitmprc)
      C                   eval      ChkNbrDs=chkNbr(newitmprc:maxdigits)
      C                   if        anyerrs=*on
      C                   eval      badNumSw=*on
      C                   endif
      C                   eval      maxdigits=%size(newitmqty)
      C                   eval      ChkNbrDs=chkNbr(newitmqty:maxdigits)
      C                   if        anyerrs=*on
      C                   eval      badNumSw=*on
      C                   endif
       *
      C                   endsr
       *=====================================================================
       * Convert numeric input fields
       *=====================================================================
      C     C2N2Cvt       begsr
      C                   eval      c2n2itmprc=c2n2(newitmprc)
      C                   eval      c2n2itmqty=c2n2(newitmqty)
       *
      C                   endsr
       *=====================================================================
       * Override and open database files
       *=====================================================================
       /free
          Begsr OpenDbf;
 
          if request=' ';
             if %open(ITEMINV);
                close ITEMINV;
             endif;
             monitor;
               rc = docmd('clrpfm cgidev2/ITEMINV');
             on-error;
               rc = -1;
             endmon;
          endif;
 
          open ITEMINV;
 
          Endsr;
       /end-free
       *=====================================================================
       * Send response html and quit
       *=====================================================================
      C     Exit          begsr
      C                   callp     wrtsection('*fini')
      C                   close     ITEMINV
      C                   return
      C                   endsr
0.128 sec.s