midrange.com code scratchpad
Name:
UTRGDLY
Scriptlanguage:
Plain Text
Tabwidth:
4
Date:
08/02/2018 03:55:11 pm
IP:
Logged
Description:
Program that reads the call stack to delay a trigger action.
Code:
  1.       /copy qrpgsrc,umedheader
  2.      FMtrgDly   o  a e             disk
  3.  
  4.       //-*ENTRY-----------------------------
  5.      D P_Utrgstk       PR                  extpgm('UTRGSTK')
  6.      D                                9a                                        @PTNO
  7.      D                                1a                                        @DELAY
  8.      D P_Utrgstk       PI
  9.      D @PTNO                          9a
  10.      D @DELAY                         1a
  11.  
  12.      D QWVRCSTK        PR                  ExtPgm('QWVRCSTK')
  13.      D   RcvVar                   65535a   options(*varsize)
  14.      D   RcvVarLen                   10i 0 const
  15.      D   Format                       8a   const
  16.      D   JobId                       64a   const options(*varsize)
  17.      D   JobIdFmt                     8a   const
  18.      D   ErrorCode                32767a   options(*varsize)
  19.  
  20.      D ErrCode         ds                  qualified
  21.      D   BytesProv                   10i 0 inz(0)
  22.      D   BytesAvail                  10i 0 inz(0)
  23.  
  24.      D CSTK0100        ds                  qualified
  25.      D                                     based(p_CSTK0100)
  26.      D   BytesRtn                    10i 0
  27.      D   BytesAvail                  10i 0
  28.      D   Total                       10i 0
  29.      D   Offset                      10i 0
  30.      D   Count                       10i 0
  31.      D   ThreadId                     8a
  32.      D   Status                       1a
  33.  
  34.      D Entry           ds                  qualified
  35.      D                                     based(p_Entry)
  36.      D   Len                         10i 0
  37.      D   StmtDisp                    10i 0
  38.      D   StmtCnt                     10i 0
  39.      D   ProcDisp                    10i 0
  40.      D   ProcLen                     10i 0
  41.      D   RqsLvl                      10i 0
  42.      D   PgmName                     10a
  43.      D   PgmLib                      10a
  44.      D   MiInst                      10i 0
  45.      D   Module                      10a
  46.      D   ModLib                      10a
  47.      D   CtlBdy                       1a
  48.      D                                3a
  49.      D   ActGrpNo                    10u 0
  50.      D   ActGrp                      10a
  51.  
  52.      D Name            s           4096a   based(p_Name)
  53.      D ProcName        s           4096a   varying
  54.  
  55.      D JIDF0100        ds                  qualified
  56.      D   JobName                     10a   inz('*')
  57.      D   JobUser                     10a
  58.      D   JobNo                        6a
  59.      D   IntId                       16a
  60.      D                                2a   inz(x'0000')
  61.      D   ThreadInd                   10i 0 inz(1)
  62.      D   ThreadId                     8a   inz(x'0000000000000000')
  63.  
  64.      D size            s             10i 0
  65.      D x               s             10i 0
  66.      D msg             s             50a
  67.      D wait            s              1a
  68.       /free
  69.           *inlr = *on;
  70.           @Delay = 'N';
  71.  
  72.           // ------------------------------------------------
  73.           //   Reserve memory to receive call stack entries
  74.           //   into.
  75.           // ------------------------------------------------
  76.  
  77.           size = %size(CSTK0100);
  78.           p_CSTK0100 = %alloc(size);
  79.  
  80.           // ------------------------------------------------
  81.           //   Call the API.  If the memory we've reserved
  82.           //   isn't large enough, reserve more and re-call
  83.           //   the API.
  84.           // ------------------------------------------------
  85.  
  86.           dou ( CSTK0100.BytesRtn >= CSTK0100.BytesAvail );
  87.  
  88.               QWVRCSTK( CSTK0100
  89.                       : size
  90.                       : 'CSTK0100'
  91.                       : JIDF0100
  92.                       : 'JIDF0100'
  93.                       : ErrCode );
  94.  
  95.               if ( size < CSTK0100.BytesAvail );
  96.                   size = CSTK0100.BytesAvail;
  97.                   p_CSTK0100 = %realloc(p_CSTK0100: size);
  98.               endif;
  99.  
  100.            enddo;
  101.  
  102.           // ------------------------------------------------
  103.           //   Loop through the entries in the call stack
  104.           // ------------------------------------------------
  105.  
  106.           for x = 1 to CSTK0100.Count;
  107.  
  108.               if (x=1);
  109.                  p_Entry = p_CSTK0100 + CSTK0100.Offset;
  110.               else;
  111.                  p_Entry = p_entry + Entry.Len;
  112.               endif;
  113.  
  114.               if (Entry.ProcDisp>0 and Entry.ProcLen>0);
  115.                  p_Name = p_entry + Entry.ProcDisp;
  116.                  ProcName = %subst(Name:1:Entry.ProcLen);
  117.               else;
  118.                  ProcName = '';
  119.               endif;
  120.  
  121.               If Entry.PgmName <> 'UTRGSTK'
  122.                  And Entry.PgmName <> 'DT100'
  123.                  And Entry.PgmName <> 'MPATAU12'
  124.                  And Entry.PgmLib <> 'QSYS';
  125.                 DlyPat = @Ptno;
  126.                 DlyPgm = Entry.PgmName;
  127.                 If Entry.PgmName = 'DP749'
  128.                    Or Entry.PgmName = 'DP444'
  129.                    Or %Subst(Entry.PgmName:1:5) = 'DP411'
  130.                    Or %Subst(Entry.PgmName:1:5) = 'DP611';
  131.                   @Delay = 'Y';
  132.                 EndIf;
  133.                 DlySend = @Delay;
  134.                 Write Rmtrgdly;
  135.                 Leave;
  136.               EndIf;
  137.  
  138.           endfor;
  139.  
  140.           // ------------------------------------------------
  141.           //   All done! Let i5/OS have it's memory back
  142.           // ------------------------------------------------
  143.           dealloc p_CSTK0100;
  144.           return;
  145.       /end-free 
© 2004-2019 by midrange.com generated in 0.005s valid xhtml & css