/copy qrpgsrc,umedheader FMtrgDly o a e disk //-*ENTRY----------------------------- D P_Utrgstk PR extpgm('UTRGSTK') D 9a @PTNO D 1a @DELAY D P_Utrgstk PI D @PTNO 9a D @DELAY 1a D QWVRCSTK PR ExtPgm('QWVRCSTK') D RcvVar 65535a options(*varsize) D RcvVarLen 10i 0 const D Format 8a const D JobId 64a const options(*varsize) D JobIdFmt 8a const D ErrorCode 32767a options(*varsize) D ErrCode ds qualified D BytesProv 10i 0 inz(0) D BytesAvail 10i 0 inz(0) D CSTK0100 ds qualified D based(p_CSTK0100) D BytesRtn 10i 0 D BytesAvail 10i 0 D Total 10i 0 D Offset 10i 0 D Count 10i 0 D ThreadId 8a D Status 1a D Entry ds qualified D based(p_Entry) D Len 10i 0 D StmtDisp 10i 0 D StmtCnt 10i 0 D ProcDisp 10i 0 D ProcLen 10i 0 D RqsLvl 10i 0 D PgmName 10a D PgmLib 10a D MiInst 10i 0 D Module 10a D ModLib 10a D CtlBdy 1a D 3a D ActGrpNo 10u 0 D ActGrp 10a D Name s 4096a based(p_Name) D ProcName s 4096a varying D JIDF0100 ds qualified D JobName 10a inz('*') D JobUser 10a D JobNo 6a D IntId 16a D 2a inz(x'0000') D ThreadInd 10i 0 inz(1) D ThreadId 8a inz(x'0000000000000000') D size s 10i 0 D x s 10i 0 D msg s 50a D wait s 1a /free *inlr = *on; @Delay = 'N'; // ------------------------------------------------ // Reserve memory to receive call stack entries // into. // ------------------------------------------------ size = %size(CSTK0100); p_CSTK0100 = %alloc(size); // ------------------------------------------------ // Call the API. If the memory we've reserved // isn't large enough, reserve more and re-call // the API. // ------------------------------------------------ dou ( CSTK0100.BytesRtn >= CSTK0100.BytesAvail ); QWVRCSTK( CSTK0100 : size : 'CSTK0100' : JIDF0100 : 'JIDF0100' : ErrCode ); if ( size < CSTK0100.BytesAvail ); size = CSTK0100.BytesAvail; p_CSTK0100 = %realloc(p_CSTK0100: size); endif; enddo; // ------------------------------------------------ // Loop through the entries in the call stack // ------------------------------------------------ for x = 1 to CSTK0100.Count; if (x=1); p_Entry = p_CSTK0100 + CSTK0100.Offset; else; p_Entry = p_entry + Entry.Len; endif; if (Entry.ProcDisp>0 and Entry.ProcLen>0); p_Name = p_entry + Entry.ProcDisp; ProcName = %subst(Name:1:Entry.ProcLen); else; ProcName = ''; endif; If Entry.PgmName <> 'UTRGSTK' And Entry.PgmName <> 'DT100' And Entry.PgmName <> 'MPATAU12' And Entry.PgmLib <> 'QSYS'; DlyPat = @Ptno; DlyPgm = Entry.PgmName; If Entry.PgmName = 'DP749' Or Entry.PgmName = 'DP444' Or %Subst(Entry.PgmName:1:5) = 'DP411' Or %Subst(Entry.PgmName:1:5) = 'DP611'; @Delay = 'Y'; EndIf; DlySend = @Delay; Write Rmtrgdly; Leave; EndIf; endfor; // ------------------------------------------------ // All done! Let i5/OS have it's memory back // ------------------------------------------------ dealloc p_CSTK0100; return; /end-free