midrange.com code scratchpad
Name:
Reclaim Activation Group Override ELIGIBLE
Scriptlanguage:
Plain Text
Tabwidth:
4
Date:
01/27/2016 08:12:11 pm
IP:
Logged
Description:
Command and processing program that allows for certain activation groups to be ignored when someone calls
RCLACTGRP ACTGRP(*ELIGIBLE)

This method uses the QIBM_QCA_CHG_COMMAND exit point to change the command name.
Code:
  1. ADDEXITPGM EXITPNT(QIBM_QCA_CHG_COMMAND) FORMAT(CHGC0100) 
  2.     PGMNBR(*LOW) PGM(WFIQSYS/RCL00ACL) 
  3.     TEXT('Exit program for RCLACTGRP') 
  4.     PGMDTA(*JOB 20 'RCLACTGRP QSYS')  
  5.  
  6. CLLE: RCL00ACL
  7. /*============================================================================*/
  8. /* PROGRAM NAME...: RCL00ACL                                                  */
  9. /* AUTHOR.........: Chris Hiebert                                             */
  10. /* DATE...........: 01/23/2016                                                */
  11. /* PCR #..........: STDCODE                                                   */
  12. /* FUNCTION/DESC..: RCLACTGRP QIBM_QCA_CHG_COMMAND Exit point                 */
  13. /*                                                                            */
  14. /*----------------------------------------------------------------------------*/
  15. /*   MODIFICATIONS:                                                           */
  16. /*----------------------------------------------------------------------------*/
  17. /* MOD#  PCR#    PGMR   DATE   DESCRIPTION                                    */
  18. /* /M01               MM/DD/YY CHANGES...                                     */
  19. /*============================================================================*/
  20.              PGM        PARM(&ECAC0100 &NEWCMD &NEWLEN)
  21.  
  22.              DCL        VAR(&ECAC0100) TYPE(*CHAR) LEN(32767)
  23. /* ECAC0100 Definition from QSYSINC/QRPGLESRC(ECACHCMD) */
  24.              DCL        VAR(&ECAEPN) TYPE(*CHAR) LEN(20) STG(*DEFINED) +
  25.                           DEFVAR(&ECAC0100 1)
  26.              DCL        VAR(&ECAEPFN) TYPE(*CHAR) LEN(8) STG(*DEFINED) +
  27.                           DEFVAR(&ECAC0100 21)
  28.              DCL        VAR(&ECACMDN) TYPE(*CHAR) LEN(10) STG(*DEFINED) +
  29.                           DEFVAR(&ECAC0100 29)
  30.              DCL        VAR(&ECALIBN) TYPE(*CHAR) LEN(10) STG(*DEFINED) +
  31.                           DEFVAR(&ECAC0100 39)
  32.              DCL        VAR(&ECACA) TYPE(*CHAR) LEN(1) STG(*DEFINED) +
  33.                           DEFVAR(&ECAC0100 49)
  34.              DCL        VAR(&ECAPCMD) TYPE(*CHAR) LEN(1) STG(*DEFINED) +
  35.                           DEFVAR(&ECAC0100 50)
  36.              DCL        VAR(&ECAERVED) TYPE(*CHAR) LEN(2) STG(*DEFINED) +
  37.                           DEFVAR(&ECAC0100 51)
  38.              DCL        VAR(&ECACMDSO) TYPE(*INT) STG(*DEFINED) +
  39.                           DEFVAR(&ECAC0100 53)
  40.              DCL        VAR(&ECACMDSL) TYPE(*INT) STG(*DEFINED) +
  41.                           DEFVAR(&ECAC0100 57)
  42.              DCL        VAR(&ECAPCCO) TYPE(*INT) STG(*DEFINED) +
  43.                           DEFVAR(&ECAC0100 61)
  44.              DCL        VAR(&ECANOPC) TYPE(*INT) STG(*DEFINED) +
  45.                           DEFVAR(&ECAC0100 65)
  46. /*DCL VAR(&ECACMDS) TYPE(*CHAR) LEN(256) STG(*DEFINED) DEFVAR(&ECAC0100 69)*/
  47. /*DCL VAR(&ECAPCMDC) TYPE(*CHAR) LEN(1) STG(*DEFINED) DEFVAR(&ECAC0100 70) */
  48.  
  49.              DCL        VAR(&ECACMDS) TYPE(*CHAR) LEN(2000)
  50.              DCL        VAR(&NEWCMD) TYPE(*CHAR) LEN(2000)
  51.              DCL        VAR(&NEWLEN) TYPE(*INT)
  52.              DCL        VAR(&POS) TYPE(*INT)
  53.              DCL        VAR(&LEN) TYPE(*INT)
  54.              DCL        VAR(&CMDOFFSET) TYPE(*INT)
  55.  
  56. /* Error handling variables                                           */
  57.              DCL        &MsgID       *CHAR    7
  58.              DCL        &MsgFile     *CHAR   10
  59.              DCL        &MsgFLib     *CHAR   10
  60.              DCL        &MsgData     *CHAR  512
  61.  
  62.              MONMSG     CPF0000    EXEC(GOTO ERROR)
  63.  
  64.              IF         COND(&ECACA *EQ '0') THEN(GOTO ENDPGM)
  65.  
  66.              CHGVAR     VAR(&CMDOFFSET) VALUE(&ECACMDSO +1)
  67.              CHGVAR     VAR(&ECACMDS) VALUE(%SST(&ECAC0100 &CMDOFFSET +
  68.                           &ECACMDSL))
  69.  
  70.              IF         COND(%SCAN('ELIGIBLE' &ECACMDS 1) *EQ 0) THEN(GOTO +
  71.                           ENDPGM)
  72.  
  73.              CHGVAR     VAR(&POS) VALUE(%SCAN('RCLACTGRP' &ECACMDS))
  74.              IF         COND(&POS *EQ 0) THEN(GOTO ENDPGM)
  75.              CHGVAR     VAR(&POS) VALUE(&POS + 9)
  76.              CHGVAR     VAR(&LEN) VALUE(&ECACMDSL - &POS +1)
  77.  
  78.              CHGVAR     VAR(&NEWCMD) VALUE('RCLACTGRPE' || %SST(&ECACMDS +
  79.                           &POS &LEN))
  80.              CHGVAR     VAR(&NEWLEN) VALUE(&LEN + 10)
  81.  
  82.  
  83.  ENDPGM:     RETURN     /* Normal end of Program */
  84.  
  85. /* Error handling */
  86.  ERROR:      RCVMSG     MSGTYPE(*LAST) MSGDTA(&MsgData) MSGID(&MsgID) +
  87.                           MSGF(&MsgFile) SNDMSGFLIB(&MsgFLib)
  88.              MONMSG     CPF0000 EXEC(RETURN)
  89.              SNDPGMMSG  MSGID(&MsgID) MSGF(&MSGFLIB/&MsgFile) +
  90.                           MSGDTA(&MsgData) MSGTYPE(*ESCAPE)
  91.              MONMSG     CPF0000 EXEC(RETURN)
  92.  
  93.              ENDPGM 
  94.  
  95.  
  96.  
  97. /*============================================================================*/
  98. /* PROGRAM NAME...: RCLACTGRPE                                                */
  99. /* AUTHOR.........: Chris Hiebert                                             */
  100. /* DATE...........: 01/26/2016                                                */
  101. /* PCR #..........: STDCODE                                                   */
  102. /* FUNCTION/DESC..: Reclaim Activation Group Override ELIGIBLE                */
  103. /*                                                                            */
  104. /* This command is higher in the Library list than QSYS.                      */
  105. /* When *ELIGIBLE is passed we will skip our activation groups.               */
  106. /* When an Activation Group is passed, the program triggers QSYS/RCLACTGRP    */
  107. /*                                                                            */
  108. /*----------------------------------------------------------------------------*/
  109. /*   MODIFICATIONS:                                                           */
  110. /*----------------------------------------------------------------------------*/
  111. /* MOD#  PCR#    PGMR   DATE   DESCRIPTION                                    */
  112. /* /M01               MM/DD/YY CHANGES...                                     */
  113. /*============================================================================*/
  114. /*      CRTCMD                                                                */
  115. /*PARMS CMD(WFIQSYS/RCLACTGRPE) PGM(WFIQSYS/RCL00ARG) SRCFILE(WFIQSYS/QCMDSRC)*/
  116. /*PARMS SRCMBR(RCLACTGRPE) THDSAFE(*NO)                                       */
  117. /*PARMS TEXT('Reclaim Activation Group Override ELIGIBLE')                    */
  118. /*PARMS MODE(*ALL) ALLOW(*ALL) ALWLMTUSR(*NO) MAXPOS(*NOMAX)                  */
  119. /*PARMS PMTFILE(*LIBL/QCPFPMT) MSGF(*LIBL/QCPFMSG) HLPPNLGRP(*LIBL/QHWVCMD)   */
  120. /*PARMS HLPID(RCLACTGRP) CURLIB(*NOCHG) PRDLIB(*NOCHG)                        */
  121.  
  122.              CMD        PROMPT('Reclaim Activation Group')
  123.              PARM       KWD(ACTGRP) TYPE(*NAME) LEN(10) +
  124.                           SPCVAL((*ELIGIBLE *ELIGIBLE)) MIN(1) +
  125.                           EXPR(*YES) CHOICE(*PGM) +
  126.                           CHOICEPGM(QSYS/QLERCLAG) INLPMTLEN(10) +
  127.                           PROMPT(TXT6856)
  128.              PARM       KWD(OPTION) TYPE(*CHAR) LEN(1) RSTD(*YES) +
  129.                           DFT(*NORMAL) SPCVAL((*NORMAL N) (*ABNORMAL +
  130.                           A)) EXPR(*YES) CHOICE('*NORMAL, +
  131.                           *ABNORMAL') PROMPT(TXT3212) 
  132.  
  133.  
  134. RPGLE: RCL01ARG
  135.  
  136.        //========================================================================*
  137.        // PROGRAM NAME...: RCL00ARG
  138.        // AUTHOR.........: Chris Hiebert
  139.        // DATE...........: 01/26/2016
  140.        // PCR #..........: STDCODE
  141.        // FUNCTION/DESC..: Reclaim Activation Group Override ELIGIBLE
  142.        //------------------------------------------------------------------------
  143.        //    MODIFICATIONS:
  144.        //------------------------------------------------------------------------
  145.        // MOD#  PCR#    PGMR   DATE   DESCRIPTION
  146.        // /M01               MM/DD/YY CHANGES...
  147.        //========================================================================*
  148.        Ctl-Opt OPTION(*NODEBUGIO:*SRCSTMT);
  149.        Ctl-Opt DFTACTGRP(*NO) ACTGRP(*NEW) MAIN(RCL00ARG);
  150.  
  151.        Dcl-s ErrorMsgkey Char(4);
  152.        Dcl-s Whitelist Char(20) CTDATA Dim(7);
  153.  
  154.        Dcl-Ds Pgminf psds;
  155.          Procstatus *STATUS;
  156.          Procroutin *ROUTINE;
  157.          Procname *PROC;
  158.          Parmcount *PARMS;
  159.          Prmcnt *PARMS;
  160.          Msgerrid Char(7) Pos(40);
  161.          PgminferrormsG Char(80) Pos(091);
  162.          Progname Char(10) Pos(334);
  163.          Pgmnam Char(10) Pos(334);
  164.          Jobname Char(10) Pos(244);
  165.          Jobnam Char(10) Pos(244);
  166.          Username Char(10) Pos(254);
  167.          Jobusr Char(10) Pos(254);
  168.          Jobnbr Zoned(6) Pos(264);
  169.          Jobdate Zoned(6) Pos(270);
  170.          Jobdat Zoned(6) Pos(270);
  171.          Progdate Zoned(6) Pos(276);
  172.          Pgmdat Zoned(6) Pos(276);
  173.          Progtime Zoned(6) Pos(282);
  174.          Pgmtim Zoned(6) Pos(282);
  175.        End-Ds;
  176.  
  177.        Dcl-Proc RCL00ARG;
  178.        Dcl-pi RCL00ARG Extpgm;
  179.          P_ACTGRP Char(10);
  180.          P_Option Char(1);
  181.        End-pi;
  182.  
  183.        Dcl-Ds P_Errords QUALIFIED;
  184.          Bytespass Int(10) INZ(%SIZE(P_Errords));
  185.          Bytesavail Int(10) INZ(*ZERO);
  186.          MsgID Char(7) INZ(*BLANKS);
  187.          *N Char(1) INZ(X'00');
  188.          MsgDta Char(256) INZ(*BLANKS);
  189.        End-Ds;
  190.        Dcl-Pr QWVOLAGP EXTPGM('QWVOLAGP');
  191.          Receiver Char(1) CONST OPTIONS(*VARSIZE);
  192.          Receiverlen Int(10) CONST;
  193.          ListInfo Char(80);
  194.          RequestCount Int(10) CONST;
  195.          Dataformat Char(8) CONST;
  196.          QualJob Char(26) CONST;
  197.          InternalJobId Char(16) CONST;
  198.          Apierror LIKEDS(P_Errords);
  199.        End-Pr;
  200.        // Get List Entries (QGYGTLE) API
  201.        Dcl-pr QGYGTLE Extpgm('QGYGTLE');
  202.          Receiver Char(1) CONST OPTIONS(*VARSIZE);
  203.          Receiverlen Int(10) CONST;
  204.          Handle Char(4) CONST;
  205.          ListInfo Char(80);
  206.          RequestCount Int(10) CONST;
  207.          StartRecord Int(10) CONST;
  208.          Apierror LIKEDS(P_Errords);
  209.        End-pr;
  210.        // Close List (QGYCLST) API
  211.        Dcl-pr QGYCLST Extpgm('QGYCLST');
  212.          Handle Char(4) CONST;
  213.          Apierror LIKEDS(P_Errords);
  214.        End-pr;
  215.  
  216.        Dcl-s InternalJobId Char(16) Inz;
  217.        Dcl-DS QualJobName Qualified Len(26);
  218.          Job Char(10);
  219.          User Char(10);
  220.          Nbr Char(6);
  221.        End-ds;
  222.        Dcl-s Basesize Int(10);
  223.        Dcl-s BaseCount Int(10);
  224.        Dcl-s StartRecord Int(10);
  225.        Dcl-s Listhandle Char(4);
  226.  
  227.  
  228.        //****************************************************************
  229.        //Type Definition for the List Information Format
  230.        //****************************************************************
  231.        Dcl-Ds QWVOLI00 Len(80);     // Qwv Olagp ListInfo
  232.          TotalRecords Bindec(9);         // Total Records
  233.          RecordsReturned Bindec(9);         // Records Retd
  234.          Handle Char(4);           // Request Handle
  235.          RecordLength Bindec(9);         // Record Length
  236.          InfoComplete Char(1);           // Info Complete
  237.          DateTime Char(13);          // Date Time
  238.          ListStatus Char(1);           // List Status
  239.          QWVRSV101 Char(1);         // Reserved1
  240.          InfoLength Bindec(9);         // Info Length
  241.          FirstRecord Bindec(9);         // First Record
  242.          QWVRSV200 Char(40);        // Reserved2
  243.        End-Ds;
  244.  
  245.  
  246.        Dcl-s RAGA0100_P Pointer;
  247.  
  248.        // Qwv Olagp Raga0100
  249.        Dcl-Ds QWVR010000 Based(RAGA0100_P);
  250.          AgpName Char(10);              // AGP Name
  251.          QWVRSV102 Char(6);             // reserved1
  252.          AGPNumber Int(10);             // AGP Number
  253.          NumOfActivations Int(10);      // Num of Activations
  254.          NumOfheaps Int(10);            // Num of Heaps
  255.          StaticSize Int(10);            // Static Size
  256.          HeapSize Int(10);              // Heap Size
  257.          RootPgmNam Char(10);           // Root PGM Name
  258.          RootPgmLib Char(10);           // Root PGM Lib
  259.          RootPgmType Char(1);           // Root PGM Type
  260.          State Char(1);                 // State
  261.          Shared Char(1);                // Shared
  262.          Inuse Char(1);                 // In use
  263.          QWVERVED00 Char(4);            // Reserved
  264.          AgpNumberLong Int(20);         // AGP Number Long
  265.          QWVRSV202 Char(8);             // Reserved2
  266.        End-Ds;
  267.  
  268.        Dcl-s Base_P Pointer;
  269.        Dcl-ds BaseData Likeds(QWVR010000) Based(Base_P);
  270.        //----------------------------------------------------------------------
  271.        // Stand Alone Fields - TOP
  272.        //----------------------------------------------------------------------
  273.        Dcl-S Idx Int(10);
  274.        Dcl-S Wkactgrp Char(10);
  275.  
  276.        Dcl-s Whitelist_p Pointer Inz(%Addr(Whitelist));
  277.        Dcl-DS WhiteList_D Dim(6) Based(Whitelist_p) Qualified;
  278.          Actgrp Char(10);
  279.          Pgm Char(10);
  280.        End-ds;
  281.  
  282.  
  283.        Dcl-Pr QCAPCMD Extpgm('QCAPCMD');
  284.          Command Char(32768) Options(*Varsize) Const;
  285.          Length Int(10) Const;
  286.          OptionsControl Like(Qcap0100);
  287.          OptionsLength Int(10) Const;
  288.          OptionsFormat Char(8) Const;
  289.          ChangedCommand Char(32768) Options(*VARSIZE);
  290.          InChangedCommandLen Int(10) Const;
  291.          ChangedCommandLen Int(10);
  292.          Apierror LIKEDS(P_Errords);
  293.        End-Pr;
  294.  
  295.        Dcl-Ds Qcap0100 Qualified;    // Qca PCMD CPOP0100
  296.          Qcacmdpt Int(10);           // Command Process Type
  297.          Qcabcsdh Char(1);           // DBCS Data Handling
  298.          Qcapa Char(1);              // Prompter Action
  299.          Qcacmdss Char(1);           // Command String Syntax
  300.          Qcamk Char(4) Inz;          // Message Key
  301.          Qcasidcs Int(10) Inz(0);    // CCSID Command String
  302.          Qcaerved Char(5) inz(x'0000000000');     // Reserved
  303.        End-Ds;
  304.  
  305.        Dcl-s Rclactgrpcmd Varchar(256);
  306.        Dcl-s Newcmd Char(256);
  307.        Dcl-s Newcmdlen Int(10);
  308.  
  309.        //----------------------------------------------------------------------
  310.        // Stand Alone Fields - BOTTOM
  311.        //----------------------------------------------------------------------
  312.        // CALL RCL00ARG PARM('*ELIGIBLE' 'N')
  313.        // RCLACTGRP ACTGRP(*ELIGIBLE)
  314.  
  315.        If P_ACTGRP = '*ELIGIBLE';
  316.          Exsr Process;
  317.        Else;
  318.          Monitor;
  319.            Clear P_Errords;
  320.            P_Errords.Bytespass = %Size(P_Errords);
  321.            Clear Qcap0100;
  322.            Qcap0100.Qcabcsdh ='0';
  323.            Qcap0100.Qcapa = '0';
  324.            Qcap0100.Qcacmdss = '0';
  325.            Qcap0100.Qcaerved = *ALLx'00';
  326.            // 51 'QSYS/RCLACTGRP ACTGRP(XXXXXXXXXX) OPTION(XXXXXXXXX)';
  327.            RclactgrpCmd = 'QSYS/RCLACTGRP ACTGRP('+ P_ACTGRP +') OPTION(';
  328.            If P_Option ='A';
  329.              RclactgrpCmd += '*ABNORMAL)';
  330.            Else;
  331.              RclactgrpCmd += '*NORMAL)';
  332.            Endif;
  333.            Callp QCAPCMD( RclactgrpCmd : %Len(RclactgrpCmd) :
  334.                Qcap0100 : %Size(Qcap0100) :
  335.                'CPOP0100' : NewCmd : %Size(NewCmd) : NewCmdLen :
  336.                P_Errords );
  337.          On-error;
  338.        //      CPF1653     Activation group &1 not found.
  339.        //      CPF1654     Activation group &1 cannot be deleted.
  340.        //      CPF180C     Function &1 not allowed.
  341.        //      CPF1892     Function &1 not allowed.
  342.            If MsgErrId = 'CPF1653' OR MsgErrId = 'CPF1654';
  343.              Internal_RaiseError(MsgErrId:P_ACTGRP);
  344.            Elseif MsgErrId = 'CPF180C' OR MsgErrId = 'CPF1892';
  345.              Internal_RaiseError(MsgErrId:'RCLACTGRP');
  346.            Endif;
  347.            Internal_RaiseError();
  348.          Endmon;
  349.          If P_Errords.Bytesavail > 0;
  350.            Internal_RaiseError(P_Errords.Msgid:P_Errords.Msgdta);
  351.          Endif;
  352.  
  353.        Endif;
  354.  
  355.  
  356.        Dealloc(n) Base_P;
  357.        RAGA0100_P = *Null;
  358.        Return;
  359.  
  360.        //-----------------------------------------------------------------------
  361.        // Load subfile
  362.        //-----------------------------------------------------------------------
  363.        Begsr Process;
  364.  
  365.          QualJobName ='*';
  366.          BaseCount = 100;
  367.          BaseSize = %Size( QWVR010000 ) * BaseCount;
  368.          Base_P = %Alloc( BaseSize );
  369.  
  370.          Qwvolagp(BaseData : BaseSize : QWVOLI00 : BaseCount :
  371.            'RAGA0100' :QualJobName : InternalJobId : P_Errords );
  372.  
  373.          // Trap for errors
  374.          If P_Errords.BytesAvail > 0;
  375.            Internal_RaiseError(P_Errords.MsgId:P_Errords.MsgDta);
  376.          Endif;
  377.          Listhandle = Handle;
  378.  
  379.          If Not (ListStatus = '2' Or InfoComplete = 'C' );
  380.            Internal_RaiseError('':'List not complete');
  381.          Endif;
  382.  
  383.          Exsr ProcessReturned;
  384.  
  385.          If TotalRecords <= RecordsReturned;
  386.            QGYCLST(Listhandle : P_Errords );
  387.            Leavesr;
  388.          Endif;
  389.  
  390.          StartRecord = FirstRecord;
  391.          Dow TotalRecords > (RecordsReturned + FirstRecord -1);
  392.            StartRecord += RecordsReturned;
  393.  
  394.            QGYGTLE( BaseData : BaseSize : Listhandle : QWVOLI00 : BaseCount :
  395.              StartRecord : P_Errords );
  396.  
  397.            Exsr ProcessReturned;
  398.  
  399.          Enddo;
  400.  
  401.          QGYCLST(Listhandle : P_Errords );
  402.  
  403.        Endsr;
  404.        Begsr ProcessReturned;
  405.          For idx = 1 to RecordsReturned;
  406.            RAGA0100_P = Base_P +%Size( QWVR010000 ) * (Idx -1 );
  407.        //    dsply QWVAGPN01;
  408.  
  409.          // Only process user state. and Not in use.
  410.            If State = '0' And Inuse ='0' And Shared ='0' And
  411.                AgpName <> '*DFTACTGRP' And
  412.                AgpName <> '*UNNAMED' And
  413.                RootPgmLib <> 'QSYS' And
  414.                RootPgmLib <> 'TAATOOL' And
  415.                %Lookup( AgpName : WhiteList_D(*).Actgrp :
  416.                  1 : %Elem(WhiteList_D) ) = 0;
  417.  
  418.              Wkactgrp = AgpName;
  419.              Monitor;
  420.                Clear P_Errords;
  421.                P_Errords.Bytespass = %Size(P_Errords);
  422.                Clear Qcap0100;
  423.                Qcap0100.Qcabcsdh ='0';
  424.                Qcap0100.Qcapa = '0';
  425.                Qcap0100.Qcacmdss = '0';
  426.                Qcap0100.Qcaerved = *ALLx'00';
  427.                RclactgrpCmd = 'QSYS/RCLACTGRP ACTGRP('+ Wkactgrp +') OPTION(';
  428.                If P_Option ='A';
  429.                  RclactgrpCmd += '*ABNORMAL)';
  430.                Else;
  431.                  RclactgrpCmd += '*NORMAL)';
  432.                Endif;
  433.                Callp QCAPCMD( RclactgrpCmd : %Len(RclactgrpCmd) :
  434.                    Qcap0100 : %Size(Qcap0100) :
  435.                    'CPOP0100' : NewCmd : %Size(NewCmd) : NewCmdLen :
  436.                    P_Errords );
  437.              On-error;
  438.            //      CPF1653     Activation group &1 not found.
  439.            //      CPF1654     Activation group &1 cannot be deleted.
  440.            //      CPF180C     Function &1 not allowed.
  441.            //      CPF1892     Function &1 not allowed.
  442.                If MsgErrId = 'CPF1653' OR MsgErrId = 'CPF1654';
  443.                  Internal_RaiseError(MsgErrId:P_ACTGRP);
  444.                Elseif MsgErrId = 'CPF180C' OR MsgErrId = 'CPF1892';
  445.                  Internal_RaiseError(MsgErrId:'RCLACTGRP');
  446.                Endif;
  447.                Internal_RaiseError();
  448.              Endmon;
  449.              If P_Errords.Bytesavail > 0;
  450.                Internal_RaiseError(P_Errords.Msgid:P_Errords.Msgdta);
  451.              Endif;
  452.  
  453.            Endif;
  454.  
  455.          Endfor;
  456.        Endsr;
  457.        End-Proc;
  458.  
  459.  
  460.        Dcl-Proc Internal_RaiseError;
  461.        // RIM00BI_RaiseError Always sends the message to the procedure prior to the caller.
  462.        Dcl-Pi Internal_RaiseError;
  463.          ErrorMsgid Char(7) Const Options(*Nopass);
  464.          ErrorMsg Varchar(32768) Const Options(*Varsize:*Nopass);
  465.        End-pi;
  466.        //*  SEND Program Message
  467.        Dcl-Pr QMHSNDPM ExtPgm('QMHSNDPM');
  468.          szMsgID Char(7) Const;
  469.          szMsgFile Char(20) Const;
  470.          szMsgData Char(6000) Const  Options(*varsize);
  471.          nMsgDataLen Int(10) Const;
  472.  
  473.          //*  Message Type may be one of the following:
  474.          //*  *COMP    - Completion
  475.          //*  *DIAG    - Diagnostic
  476.          //*  *ESCAPE  - Escape
  477.          //*  *INFO    - Informational
  478.          //*  *INQ     - Inquiry. (only when ToPgmQ(*EXT) is specified.
  479.          //*  *NOTIFY  - Notify
  480.          //*  *RQS     - Request
  481.          //*  *STATUS  - Status
  482.          szMsgType Char(10) Const;
  483.          //*  Call Stack Entry may be one of the following:
  484.          //*  *        - *SAME
  485.          //*  *EXT     - The external message queue
  486.          //*  *CTLBDY  - Control Boundary
  487.          szCallStkEntry
  488.          Char(10) Const;
  489.          nRelativeCallStkEntry
  490.          Int(10) Const;
  491.          SZRTNMSGKEY Char(4) Const;
  492.          api_error Like( QUSEC_Err );
  493.        End-Pr;
  494.  
  495.        Dcl-pr CEE4FCB;
  496.          ctlbdy_inv Int(10) Options(*Omit);
  497.          ctlbdy_type Int(10) Options(*Omit);
  498.          fc Char(12) Options(*Omit);
  499.        End-pr;
  500.        Dcl-s ControlBoundry Int(10);
  501.  
  502.        Dcl-Ds QUSEC_Err Inz;
  503.          us_DSLen Int(10) Inz(%size(qusec_Err));
  504.          us_nRtnLen Int(10) Inz(0);
  505.          us_CpfMsgID Char(7);
  506.          us_apiResv1t Char(1);
  507.        End-Ds;
  508.        Dcl-s Msgid Char(7);
  509.        Dcl-s MsgLevel Int(10);
  510.  
  511.  
  512.        // Get control boundry
  513.        CALLP CEE4FCB( ControlBoundry : *Omit : *Omit );
  514.        MsgLevel = ControlBoundry + 1;
  515.  
  516.        Msgid = 'CPF9897';
  517.  
  518.        // Resend last error
  519.        If %Parms() < %Parmnum( ErrorMsg );
  520.          CALLP QMHSNDPM(Msgid : 'QCPFMSG   *LIBL     ' :
  521.            PgmInfErrorMsg : %Len(PgmInfErrorMsg) : '*ESCAPE' :
  522.            '*' : MsgLevel : ErrorMsgkey : QUSEC_Err);
  523.          Return;
  524.        Endif;
  525.  
  526.        If %Parms() >= %Parmnum( ErrorMsgid ) And ErrorMsgid <> *Blanks;
  527.          Msgid = ErrorMsgid;
  528.        Endif;
  529.  
  530.        // Send escape message to control boundry
  531.        CALLP QMHSNDPM(Msgid :  'QCPFMSG   *LIBL     ' :
  532.            ErrorMsg : %Len(ErrorMsg) : '*ESCAPE' :
  533.            '*' : MsgLevel : ErrorMsgkey : QUSEC_Err);
  534.  
  535.        End-Proc Internal_RaiseError;
  536.  
  537.        Dcl-Proc Internal_Error Export;
  538.        // This procedure allows an Escape message to be send to the
  539.        // Program/Procedure that called the Service Program Procedure.
  540.        // The Error message must include all information for debugging,
  541.        // because the message does not get sent with any information about
  542.        // where it was triggered.
  543.        Dcl-Pi Internal_Error;
  544.          ErrorMsgid Char(7) Const Options(*Nopass);
  545.          ErrorMsg Varchar(32768) Const Options(*Varsize:*Nopass);
  546.          OutOfServiceProgram Ind Const Options(*Nopass);
  547.        End-pi;
  548.        Dcl-pr CEE4FCB;
  549.          ctlbdy_inv Int(10) Options(*Omit);
  550.          ctlbdy_type Int(10) Options(*Omit);
  551.          fc Char(12) Options(*Omit);
  552.        End-pr;
  553.        Dcl-s ControlBoundry Int(10);
  554.  
  555.        //*  SEND Program Message
  556.        Dcl-Pr QMHSNDPM ExtPgm('QMHSNDPM');
  557.          szMsgID Char(7) Const;
  558.          szMsgFile Char(20) Const;
  559.          szMsgData Char(6000) Const  Options(*varsize);
  560.          nMsgDataLen Int(10) Const;
  561.  
  562.          //*  Message Type may be one of the following:
  563.          //*  *COMP    - Completion
  564.          //*  *DIAG    - Diagnostic
  565.          //*  *ESCAPE  - Escape
  566.          //*  *INFO    - Informational
  567.          //*  *INQ     - Inquiry. (only when ToPgmQ(*EXT) is specified.
  568.          //*  *NOTIFY  - Notify
  569.          //*  *RQS     - Request
  570.          //*  *STATUS  - Status
  571.          szMsgType Char(10) Const;
  572.          //*  Call Stack Entry may be one of the following:
  573.          //*  *        - *SAME
  574.          //*  *EXT     - The external message queue
  575.          //*  *CTLBDY  - Control Boundary
  576.          szCallStkEntry
  577.          Char(10) Const;
  578.          nRelativeCallStkEntry
  579.          Int(10) Const;
  580.          SZRTNMSGKEY Char(4) Const;
  581.          api_error Like( QUSEC_Err );
  582.        End-Pr;
  583.  
  584.        Dcl-Ds QUSEC_Err Inz;
  585.          us_DSLen Int(10) Inz(%size(qusec_Err));
  586.          us_nRtnLen Int(10) Inz(0);
  587.          us_CpfMsgID Char(7);
  588.          us_apiResv1t Char(1);
  589.        End-Ds;
  590.        Dcl-s Msgid Char(7);
  591.        Dcl-s MsgLevel Int(10);
  592.  
  593.        // Get control boundry
  594.        CALLP CEE4FCB( ControlBoundry : *Omit : *Omit );
  595.  
  596.        // Error triggered from an Entry Procedure are always directed back to the
  597.        // external calling program/procedure.
  598.        If ControlBoundry = 1;
  599.          MsgLevel = ControlBoundry + 1;
  600.  
  601.        // You can request that the error Always be sent to the external
  602.        //  calling program/procedure.
  603.        // This will SKIP All Error handling inside the service program.
  604.        // This will NOT REFERENCE where the error originated from.
  605.        // If you use this you MUST provide the message text that explains the error fully.
  606.        Elseif %Parms()>=%Parmnum( OutOfServiceProgram ) And OutOfServiceProgram;
  607.          MsgLevel = ControlBoundry + 1;
  608.  
  609.        // The Resend last error feature always bypasses the caller's call level.
  610.        Elseif %Parms() < %Parmnum( ErrorMsg );
  611.          MsgLevel = 2;
  612.  
  613.        // Otherwise the error is directed back to the subprocedure that triggered it.
  614.        Else;
  615.          MsgLevel = 1;
  616.        Endif;
  617.  
  618.        Msgid = 'CPF9897';
  619.  
  620.        // Resend last error
  621.        If %Parms() < %Parmnum( ErrorMsg );
  622.          CALLP QMHSNDPM(Msgid : 'QCPFMSG   *LIBL     ' :
  623.            PgmInfErrorMsg : %Len(PgmInfErrorMsg) : '*ESCAPE' :
  624.            '*' : MsgLevel : ErrorMsgkey : QUSEC_Err);
  625.          Return;
  626.        Endif;
  627.  
  628.        If %Parms() >= %Parmnum( ErrorMsgid ) And ErrorMsgid <> *Blanks;
  629.          Msgid = ErrorMsgid;
  630.        Endif;
  631.  
  632.        // Send escape message to control boundry
  633.        CALLP QMHSNDPM(Msgid : 'QCPFMSG   *LIBL     ' :
  634.            ErrorMsg : %Len(ErrorMsg) : '*ESCAPE' :
  635.            '*' : MsgLevel : ErrorMsgkey : QUSEC_Err);
  636.  
  637.        End-proc Internal_Error;
  638.  
  639. ** WHITELIST
  640. DATEUTL   DATEUTL
  641. UTILITIES ERRORSP
  642. RIM00AAG  RIM00ASP
  643. RIMMAINTAGRIM30ZRG
  644. ISTOOLKIT TLKUTLSP
  645. PAYSTUBS  PRP40ERG
  646. TAAPGNF   TAAPGNFR 
© 2004-2019 by midrange.com generated in 0.008s valid xhtml & css