RPG - alle Varianten » SQLRPGLE-Programm:

 
     hdftactgrp(*no) actgrp(*caller) usrprf(*owner)
     hoption(*srcstmt : *nodebugio)
     hdatfmt(*iso)
     ‚*-------------------------------------------------------------------*
     
     ‚* Case Inventory File
     fidcase00  if   e           k disk
     fidcase10  if   e           k disk    rename(id00rc:id10rc)
     ‚* Reserve Location File
     fillocn01  if   e           k disk
     ‚* Reserve Location SKU Inventory
     fislocnz3  if   e           k disk
     ‚* Item Master File
     fststyl00  if   e           k disk
     ‚* Display file
     fgpk061d   cf   e             workstn
     f                                     sfile(gpk061sfl:rrnum)
 
     d ldar00        e ds                  extname(ldldar00) dtaara(*lda)
 
     ‚*------------------------------------------------------------------------*
     ‚* Work Fields
     ‚*------------------------------------------------------------------------*
     d wkinput         s             20a
     d wksku2          s             15a
     d wklbcd          s             10a
     d wksku           s             16a
     d wkpaid          s             20a
     d wkcount         s              4s 0
     d wkcount2        s              4s 0
     d wktotl1         s              5s 0
     d wktotl2         s              5s 0
     d wkvalid         s              1a
     d sfpaid          s             10a
     d sfcasn          s             20a
     d sfsku           s             16a
RS01 d sfqty           s              7S 0
     d sflbcd          s             10a
     d sflkcd          s              2a
     d sfaloc          s              5s 0
     d sflock          s              5s 0
     d sfavai          s              5s 0
     d sqlstring       s           1024a
     d svlbcd          s             10a
     d svsku           s             16a
     d svpaid          s             10a
     d svcasn          s             20a
     d svsku2          s             20a
     d prevpaid        s             10a
RS01 d WkTotl3         s              9S 0
     d maxrec          s              4s 0 inz(*zeros)
     d rrnum           s              4s 0 inz(*zeros)
     d exitpgm         s               n   inz(*off)
     d exitopt         s               n   inz(*off)
     d endpgm          s               n   inz(*off)
     d canceldsp       s               n   inz(*off)
 
     ‚*------------------------------------------------------------------------*
     ‚* constants
     ‚*------------------------------------------------------------------------*
     d @sflpag         c                   const(13)
     d @sflsiz         c                   const(9990)
 
     d lstrrn          s              4  0 inz(0)
 
     ‚*------------------------------------------------------------------------*
     ‚* Program Status data structure
     dprogram_sts     sds
     d userid                254    263
     d pgm                   334    343
 
     ‚* --------------------------------------------------------------------------------------------
     ‚*   Main Program
     ‚* --------------------------------------------------------------------------------------------
      /free
 
        in ldar00;
 
        evalr wswhcodv = 'Wh/Co/Dv: ' + %trim(ldwhse)
                       + ' ' + %trim(ldco) + ' ' + %trim(lddiv);
 
        exsr @bldsfum;
 
        // Do loop to process the subfile until exit is requested
 
        dou exitopt;
 
          write gpk061ftr;
          exfmt gpk061ctl;
 
          *in43 = *off;
          errmsg = *blanks;
 
          select;
 
            when *inkc = *on;
              exitopt = *on;
 
            when *inke = *on;
              *in70 = *off;
              wklbcd = *blanks;
              wksku = *blanks;
              wksku2 = *blanks;
              wkpaid = *blanks;
              wktotl1 = *zero;
              wktotl2 = *zero;
 RS01         wktotl3 = *zero;
 RS01         wstotl3 = *Blanks;
              wkinput = *blanks;
              wstotl1 = *blanks;
              wstotl2 = *blanks;
              exsr @clrsfum;
              exsr @validate;
              if wkvalid = 'Y';
                if wksku <> *blanks;
                  *in70 = *on;
                  wssku2 = *blanks;
                  wksku2 = *blanks;
                  exsr @bldsfum2;
                else;
                  *in70 = *off;
                  exsr @bldsfum;
                endif;
              else;
                wktotl1 = *zero;
                wktotl2 = *zero;
 RS01           wktotl3 = *zero;
 RS01           wstotl3 = *Blanks;
                wstotl1 = *blanks;
                wstotl2 = *blanks;
              endif;
 
            when *inkl = *on;
              exitopt = *on;
 
            other;
              if wsinput <> wkinput
                or wsinput = wkinput and wssku2 <> wksku2;
                if wsinput <> wkinput;
                  wssku2 = *blanks;
                  wksku2 = *blanks;
                endif;
                exsr @clrsfum;
                exsr @validate;
                if wkvalid = 'Y';
                  if wksku <> *blanks;
                    *in70 = *on;
                    wssku2 = *blanks;
                    wksku2 = *blanks;
                    exsr @bldsfum2;
                  else;
                    *in70 = *off;
                    exsr @bldsfum;
                  endif;
                else;
                  wktotl1 = *zero;
                  wktotl2 = *zero;
 RS01             wktotl3 = *zero;
 RS01             wstotl3 = *Blanks;
                  wstotl1 = *blanks;
                  wstotl2 = *blanks;
                endif;
              else;
                if rrnum = *zero;
                  wktotl1 = *zero;
                  wktotl2 = *zero;
 RS01             wktotl3 = *zero;
 RS01             wstotl3 = *Blanks;
                  wstotl1 = *blanks;
                  wstotl2 = *blanks;
                  errmsg = 'Enter search parameter';
                  wssku2 = *blanks;
                  wksku2 = *blanks;
                  *in62 = *off;
                else;
                  exsr @clrsfum;
                  exsr @validate;
                  if wkvalid = 'Y';
                    if wksku <> *blanks;
                      *in70 = *on;
                      wssku2 = *blanks;
                      wksku2 = *blanks;
                      exsr @bldsfum2;
                    else;
                      *in70 = *off;
                      exsr @bldsfum;
                    endif;
                  else;
                    wktotl1 = *zero;
                    wktotl2 = *zero;
 RS01               wktotl3 = *zero;
 RS01               wstotl3 = *Blanks;
                    wstotl1 = *blanks;
                    wstotl2 = *blanks;
                  endif;
                endif;
              endif;
 
          endsl;
 
        enddo;
 
        *inlr = *on;
 
        //‚--------------------------------------------------------------------*
        //‚ Subroutine @validate - validate select parameters
        //‚--------------------------------------------------------------------*
        begsr @validate;
 
          wkvalid = 'Y';
          wklbcd = *blanks;
          wksku = *blanks;
          wkpaid = *blanks;
          wkinput = wsinput;
          wksku2 = wssku2;
          *in61 = *off;
          *in62 = *off;
 
          //‚Check if Location Code
          chain (ldwhse:wsinput) illocn01;
          if %found (illocn01);
            wklbcd = wsinput;
RS01        WKTOTL3 = %INT(ILACTU);
RS01        WSTOTL3 = %Char(%INT(WKTOTL3));
          else;
            //‚Check if SKU
            ststyl = %subst(wsinput:1:8);
            stssfx = %subst(wsinput:9:8);
            chain (ldco:lddiv:' ':' ':ststyl:stssfx) ststyl00;
            if %found (ststyl00);
              wksku = wsinput;
            else;
              //‚Check if Pallet
              chain (ldwhse:' ':wsinput) idcase10;
              if %found (idcase10);
                wkpaid = wsinput;
RS01            Setll (ldwhse:' ':wsinput) idcase10;
 |              ReadE (ldwhse:' ':wsinput) idcase10;
 |              Dow  NOT  %EOF(IDCASE10);
 |                 WKTOTL3 =  WKTOTL3 + %INT(IDQTY);
 |              ReadE (ldwhse:' ':wsinput) idcase10;
RS01            EndDo;
RS01           WSTOTL3 = %Char(%INT(WKTOTL3));
              else;
                //‚Check if Case
                chain (wsinput:ldco:lddiv) idcase00;
                if %found (idcase00);
RS01              WKTOTL3 =  %INT(IDQTY) ;
RS01              WSTOTL3 = %Char(%INT(WKTOTL3));
                  wkpaid = wsinput;
                else;
                  //‚Display error message
                  if wsinput = *blanks;
                    errmsg = 'Enter search parameter';
                    wssku2 = *blanks;
                    wksku2 = *blanks;
                    *in62 = *off;
                  else;
                    errmsg = 'Invalid search parameter';
                  endif;
                  wkvalid = 'N';
                  *in61 = *on;
                  leavesr;
                endif;
              endif;
            endif;
          endif;
 
          //‚Validate 2nd "SKU" parameter
          if *in40 = *on and wssku2 <> *blanks;
            ststyl = %subst(wssku2:1:8);
            stssfx = %subst(wssku2:9:7);
            chain (ldco:lddiv:' ':' ':ststyl:stssfx) ststyl00;
            if not %found (ststyl00);
              errmsg = 'Enter a valid SKU';
              wkvalid = 'N';
              *in62 = *on;
              leavesr;
            endif;
          endif;
 
        endsr;
 
        //‚--------------------------------------------------------------------*
        //‚ Subroutine @clrsfum - clear header subfile
        //‚--------------------------------------------------------------------*
        begsr @clrsfum;
 
          rrnum = *zero;
          *in25 = *off;
          *in30 = *on;
          *in32 = *off;
          *in34 = *off;
          *in35 = *off;
          *in40 = *off;
          *in50 = *off;
 RS01     wktotl3 = *zero;
 RS01     wstotl3 = *Blanks;
 
          write gpk061ctl;
          *in30 = *off;
          lstrrn = *zero;
          clear gpk061sfl;
 
          sfdata = *blanks;
 
        endsr;
 
        //‚--------------------------------------------------------------------*
        //‚ Subroutine @bldsfum - build header subfile
        //‚--------------------------------------------------------------------*
        begsr @bldsfum;
 
          if wklbcd <> *blanks or wksku <> *blanks or wkpaid <> *blanks;
 
            wkcount = *zero;
            wktotl1 = *zero;
            wktotl2 = *zero;
            prevpaid = *blanks;
 
            // prepare sqlstring
RS01      //sqlstring = 'select idpaid,idcasn,idstyl||idssfx,'
RS01        sqlstring = 'select idpaid,idcasn,idstyl||idssfx,int(idqty),'
                      + 'trim(idzone)||trim(idaisl)||trim(idbay)||'
                      + 'trim(idlevl)||trim(idposn), case '
                      + 'when idlkc2 <> '' '' then idlkc2 '
                      + 'when idlkc3 <> '' '' then idlkc3 '
                      + 'when idlkc4 <> '' '' then idlkc4 '
                      + 'when idlkc5 <> '' '' then idlkc5 '
                      + 'else idlkcd end as lockcode from idcase00';
 
            sqlstring = %trim(sqlstring)
                      + ' where idwhse = ''' + %trim(ldwhse) + '''';
 
            if wklbcd <> *blanks;
              sqlstring = %trim(sqlstring)
                        + ' and idzone = ''' + %subst(wklbcd:1:2) + ''''
                        + ' and idaisl = ''' + %subst(wklbcd:3:2) + ''''
                        + ' and idbay = ''' + %subst(wklbcd:5:2) + ''''
                        + ' and idlevl = ''' + %subst(wklbcd:7:2) + ''''
                        + ' and idposn = ''' + %subst(wklbcd:9:2) + '''';
              //‚Show sku input field if there are multiple skus in the location
              exec sql
                select count(distinct(isstyl||isssfx)) into :wkcount2
                  from islocn00 where iswhse = :ldwhse and islbcd = :wklbcd;
              if wkcount2 > 1;
                *in40 = *on;
              else;
                exec sql
                  select count(distinct(idstyl||idssfx)) into :wkcount2
                    from idcase52 where idwhse  = :ldwhse
                    and idzone = substr(:wklbcd,1,2)
                    and idaisl = substr(:wklbcd,3,2)
                    and idbay  = substr(:wklbcd,5,2)
                    and idlevl = substr(:wklbcd,7,2)
                    and idposn = substr(:wklbcd,9,2);
                if wkcount2 > 1;
                  *in40 = *on;
                endif;
              endif;
            else;
              wssku2 = *blanks;
              wksku2 = *blanks;
            endif;
            if wksku <> *blanks;
              sqlstring = %trim(sqlstring) + ' and idstyl||idssfx = '''
                        + %trim(wksku) + '''';
            endif;
            if wssku2 <> *blanks;
              sqlstring = %trim(sqlstring) + ' and idstyl||idssfx = '''
                        + %trim(wssku2) + '''';
            endif;
            if wkpaid <> *blanks;
              chain (wkpaid) idcase00;
              if %found (idcase00);
                sqlstring = %trim(sqlstring) + ' and idcasn = '''
                          + %trim(wkpaid) + '''';
              else;
                sqlstring = %trim(sqlstring) + ' and idpaid = '''
                          + %trim(wkpaid) + '''';
              endif;
            endif;
            //ra01 filter out Status 90 cases
            //ra01 filter out cases with IDSTAT >= '60'
            //sqlstring = %trim(sqlstring) + ' and idstat <> ''90'' ';
RS01        // sqlstring = %trim(sqlstring) + ' and idstat <  ''60'' ';
RS01        sqlstring = %trim(sqlstring) + ' and idstat <= ''60'' ';
            //ra01
            sqlstring = %trim(sqlstring) + ' order by idpaid,idcasn,'
                      + 'idstyl||idssfx,trim(idzone)||trim(idaisl)||'
                      + 'trim(idbay)||trim(idlevl)||trim(idposn)';
            exec sql
              prepare sql1 from :sqlstring;
 
            // declare cursor
            exec sql
              declare csr1 cursor for sql1;
 
            // open cursor
           exec sql
              open csr1;
 
            // read
            exec sql fetch csr1 into
RS01       // :sfpaid, :sfcasn, :sfsku, :sflbcd, :sflkcd;
RS01          :sfpaid, :sfcasn, :sfsku, :sfqty , :sflbcd, :sflkcd;
 
            dow sqlstt = '00000' or sqlstt = '01004';
 
              wktotl1 += 1;
 
              if sfpaid = *blanks;
                sfdata = sfpaid + '         ' + sfcasn + '   '
                       + sfsku + '   ' + sflbcd + '    ' + sflkcd;
                rrnum += 1;
                write gpk061sfl;
                wkcount = *zero;
                rrnum += 1;
RS01         // sfdata = '  Case Count    1';
RS01            sfdata = '  Case Count    1   Cas_Qty:' + %Char(Sfqty);
                *in50 = *on;
                write gpk061sfl;
                *in50 = *off;
              else;
                if prevpaid = *blanks or prevpaid = sfpaid;
                  sfdata = sfpaid + '         ' + sfcasn + '   '
                         + sfsku + '   ' + sflbcd + '    ' + sflkcd;
                  rrnum += 1;
                  write gpk061sfl;
                  wkcount += 1;
                  prevpaid = sfpaid;
                else;
                  svpaid = sfpaid;
                  svcasn = sfcasn;
                  svsku = sfsku;
                  svlbcd = sflbcd;
                  rrnum += 1;
                  sfdata = '  Case Count ' + %editc(wkcount:'Z');
                  *in50 = *on;
                  write gpk061sfl;
                  *in50 = *off;
                  prevpaid = sfpaid;
                  wkcount = 1;
                  sfpaid = svpaid;
                  sfcasn = svcasn;
                  sfsku = svsku;
                  sflbcd = svlbcd;
                  sfdata = sfpaid + '         ' + sfcasn + '   '
                         + sfsku + '   ' + sflbcd + '    ' + sflkcd;
                  rrnum += 1;
                  write gpk061sfl;
                endif;
              endif;
 
              if rrnum = 9997;
                leave;
              endif;
 
              // read next record
              exec sql fetch csr1 into
RS01         // :sfpaid, :sfcasn, :sfsku, :sflbcd, :sflkcd;
RS01            :sfpaid, :sfcasn, :sfsku, :sfqty , :sflbcd, :sflkcd;
 
            enddo;
 
            // close cursor
            exec sql
               close csr1;
 
          endif;
 
          if rrnum = *zero;
            *in32 = *off;
            *in34 = *off;
            *in35 = *off;
            if wklbcd <> *blanks or wksku <> *blanks or wkpaid <> *blanks;
              wstotl1 = *blanks;
              wstotl2 = *blanks;
              errmsg = 'No records to display';
            else;
              wktotl1 = *zero;
              wktotl2 = *zero;
              wstotl1 = *blanks;
              wstotl2 = *blanks;
              errmsg = 'Enter search parameter';
              wssku2 = *blanks;
              wksku2 = *blanks;
              *in62 = *off;
            endif;
          else;
            *in32 = *on;
            *in34 = *on;
            rrnum += 1;
            if wkcount > *zero;
              sfdata = '  Case Count ' + %editc(wkcount:'Z');
              *in50 = *on;
              write gpk061sfl;
              *in50 = *off;
            endif;
          endif;
          lstrrn = rrnum;
 
          if wktotl1 > *zero;
            wstotl1 = 'Case Total : ' + %trim(%editw(wktotl1:'   0 '));
            if wklbcd <> *blanks;
              chain (ldwhse:ldco:lddiv:wklbcd) islocnz3;
              if %found (islocnz3);
                wktotl2 = isunal;
                wstotl2 = 'Alloc Units: ' + %trim(%editw(wktotl2:'   0 '));
              endif;
            endif;
          endif;
 
        endsr;
 
        //‚--------------------------------------------------------------------*
        //‚ Subroutine @bldsfum2 - build header2 subfile
        //‚--------------------------------------------------------------------*
        begsr @bldsfum2;
 
          if wklbcd <> *blanks or wksku <> *blanks or wkpaid <> *blanks;
 
            wkcount = *zero;
            wktotl1 = *zero;
            wktotl2 = *zero;
            prevpaid = *blanks;
 
            // prepare sqlstring
            sqlstring = 'select isstyl||isssfx,islbcd,isunal,'
                      + 'isunlk,isavun from islocn00'
                      + ' where iswhse = ''' + %trim(ldwhse) + ''''
                      + ' and isstyl||isssfx = ''' + %trim(wksku) + ''''
                      + ' order by islbcd';
 
            exec sql
              prepare sql2 from :sqlstring;
 
            // declare cursor
            exec sql
              declare csr2 cursor for sql2;
 
            // open cursor
           exec sql
              open csr2;
 
            // read
            exec sql fetch csr2 into
              :sfsku, :sflbcd, :isunal, :isunlk, :isavun;
 
            dow sqlstt = '00000' or sqlstt = '01004';
 
              sfaloc = isunal;
              sflock = isunlk;
              sfavai = isavun;
              wktotl1 = sfaloc + sflock + sfavai;
              sfdata = '  ' + sfsku + '   ' + sflbcd
                     + '     ' + %editc(wktotl1:'Z')
                     + '     ' + %editc(sflock:'Z')
                     + '     ' + %editc(sfaloc:'Z')
                     + '     ' + %editc(sfavai:'Z');
              rrnum += 1;
              write gpk061sfl;
 
              if rrnum = 9997;
                leave;
              endif;
 
              // read next record
              exec sql fetch csr2 into
                :sfsku, :sflbcd, :isunal, :isunlk, :isavun;
 
            enddo;
 
            // close cursor
            exec sql
               close csr2;
 
          endif;
 
          if rrnum = *zero;
            *in32 = *off;
            *in34 = *off;
            *in35 = *off;
            if wklbcd <> *blanks or wksku <> *blanks or wkpaid <> *blanks;
              errmsg = 'No records to display';
            else;
              wktotl1 = *zero;
              wktotl2 = *zero;
              wstotl1 = *blanks;
              wstotl2 = *blanks;
              errmsg = 'Enter search parameter';
              wssku2 = *blanks;
              wksku2 = *blanks;
              *in62 = *off;
            endif;
          else;
            *in32 = *on;
            *in34 = *on;
            rrnum += 1;
          endif;
          lstrrn = rrnum;
 
        endsr;
 
      /end-free
 

 

 
     A*%%TS  SD  20230906  101914  SETHRX      REL-V7R5M0  5770-WDS
     
     A*%%EC
     A                                      DSPSIZ(24 80 *DS3)
     A                                      CHGINPDFT
     A                                      PRINT
     A                                      CF03
     A                                      CF05
     A                                      CF06
     A                                      CF12
     A          R GPK061SFL                 SFL
     A*%%TS  SD  20191014  111521  MATEOEX     REL-V7R3M0  5770-WDS
     A            SFDATA        78A  O  8  2
     A  50                                  DSPATR(HI)
     A          R GPK061CTL                 SFLCTL(GPK061SFL)
     A*%%TS  SD  20210430  070556  MATEOEX     REL-V7R3M0  5770-WDS
     A                                      SFLSIZ(9999)
     A                                      SFLPAG(0013)
     A                                      CF04
     A                                      OVERLAY
     A                                      RTNCSRLOC(&CSRRCD &CSRFLD &CSRPOS)
     A  35                                  ROLLUP(25 'ROLLUP')
     A  32                                  SFLDSP
     A N30                                  SFLDSPCTL
     A  30                                  SFLCLR
     A  34                                  SFLEND(*MORE)
     A            CSRRRN         5S 0H
     A            CSRPOS         4S 0H
     A            CSRFLD        10A  H
     A            CSRRCD        10A  H
     A            CL             3S 0H
     A            RW             3S 0H
     A            USERID        10A  O  1  2
     A                                  1 31'Product Inquiry'
     A                                      DSPATR(HI)
     A                                  1 63DATE
     A                                      EDTCDE(Y)
     A                                  1 72TIME
     A            PGM           10A  O  2  2
     A            WSWHCODV      31A  O  2 49
     A                                  4  2'Scan Pallet/Case/Location/SKU:'
     A                                      COLOR(BLU)
     A            WSINPUT       20A  B  5  2DSPATR(HI)
     A                                      CHECK(ER)
     A  61                                  DSPATR(RI PC)
     A N61                                  DSPATR(UL)
     A  40        WSSKU2        15A  B  5 28DSPATR(HI)
     A                                      CHECK(ER)
     A  62                                  DSPATR(RI PC)
     A N62                                  DSPATR(UL)
     A**RS01 N70        WSTOTL1       20A  O  4 49COLOR(PNK)
RS01 A N70        WSTOTL1       20A  O  4 40COLOR(PNK)
RS01 A N70                              4 61'Tot_Unts:' COLOR(PNK)
RS01 A** N70        WKTOTL3        9Y 0O   + 1COLOR(PNK) EDTCDE(3)
RS01 A N70        WSTOTL3        9   O   + 1COLOR(PNK)
     A**RS01 N70        WSTOTL2       20A  O  5 49COLOR(PNK)
RS01 A N70        WSTOTL2       20A  O  5 61COLOR(PNK)
     A N70                              7  2'Pallet Id '
     A                                      DSPATR(HI)
     A                                      DSPATR(UL)
     A N70                              7 21'Case Id             '
     A                                      DSPATR(HI)
     A                                      DSPATR(UL)
     A N70                              7 44'SKU             '
     A                                      DSPATR(HI)
     A                                      DSPATR(UL)
     A N70                              7 63'Location  '
     A                                      DSPATR(HI)
     A                                      DSPATR(UL)
     A N70                              6 76'Lock'
     A                                      DSPATR(HI)
     A                                      DSPATR(UL)
     A N70                              7 76'Code'
     A                                      DSPATR(HI)
     A                                      DSPATR(UL)
     A  70                              7  4'SKU             '
     A                                      DSPATR(HI)
     A                                      DSPATR(UL)
     A  70                              7 23'Location  '
     A                                      DSPATR(HI)
     A                                      DSPATR(UL)
     A  70                              7 36'Cur-Inv'
     A                                      DSPATR(HI)
     A                                      DSPATR(UL)
     A  70                              7 46'Lkd-Inv'
     A                                      DSPATR(HI)
     A                                      DSPATR(UL)
     A  70                              7 56'Alc-Inv'
     A                                      DSPATR(HI)
     A                                      DSPATR(UL)
     A  70                              7 66'Avl-Inv'
     A                                      DSPATR(HI)
     A                                      DSPATR(UL)
     A*
     A          R GPK061FTR
     A*%%TS  SD  20191014  141225  MATEOEX     REL-V7R3M0  5770-WDS
     A                                 22  2'F3=Exit  F5=Refresh  F12=Cancel'
     A                                      COLOR(BLU)
     A            ERRMSG        79   O 23  2DSPATR(BL)
     A                                      COLOR(RED)