midrange.com code scratchpad
Name:
Reclaim Activation Group Override ELIGIBLE
Scriptlanguage:
Plain Text
Tabwidth:
4
Date:
01/26/2016 10:54:28 pm
IP:
Logged
Description:
Command and processing program that allows for certain activation groups to be ingored when someone calls
RCLACTGRP ACTGRP(*ELIGIBLE)
Code:
  1. COMMAND:RCLACTGRP
  2. /*============================================================================*/
  3. /* PROGRAM NAME...: RCLACTGRP                                                 */
  4. /* AUTHOR.........: Chris Hiebert                                             */
  5. /* DATE...........: 01/26/2016                                                */
  6. /* PCR #..........: STDCODE                                                   */
  7. /* FUNCTION/DESC..: Reclaim Activation Group Override ELIGIBLE                */
  8. /*                                                                            */
  9. /* This command is higher in the Library list than QSYS.                      */
  10. /* When *ELIGIBLE is passed we will skip our activation groups.               */
  11. /* When an Activation Group is passed, the program triggers QSYS/RCLACTGRP    */
  12. /*                                                                            */
  13. /*----------------------------------------------------------------------------*/
  14. /*   MODIFICATIONS:                                                           */
  15. /*----------------------------------------------------------------------------*/
  16. /* MOD#  PCR#    PGMR   DATE   DESCRIPTION                                    */
  17. /* /M01               MM/DD/YY CHANGES...                                     */
  18. /*============================================================================*/
  19.  
  20. /*      CRTCMD                                                                */
  21. /*PARMS CMD(WFIQSYS/RCLACTGRP) PGM(WFIQSYS/RCL00ARG) SRCFILE(WFIQSYS/QCMDSRC) */
  22. /*PARMS SRCMBR(RCLACTGRP) THDSAFE(*YES)                                       */
  23. /*PARMS TEXT('Reclaim Activation Group Override ELIGIBLE')                    */
  24. /*PARMS MODE(*ALL) ALLOW(*ALL) ALWLMTUSR(*NO) MAXPOS(*NOMAX)                  */
  25. /*PARMS PMTFILE(*LIBL/QCPFPMT) MSGF(*LIBL/QCPFMSG) HLPPNLGRP(*LIBL/QHWVCMD)   */
  26. /*PARMS HLPID(RCLACTGRP) CURLIB(*NOCHG) PRDLIB(*NOCHG)                        */
  27.  
  28.              CMD        PROMPT('Reclaim Activation Group')
  29.              PARM       KWD(ACTGRP) TYPE(*NAME) LEN(10) +
  30.                           SPCVAL((*ELIGIBLE *ELIGIBLE)) MIN(1) +
  31.                           EXPR(*YES) CHOICE(*PGM) +
  32.                           CHOICEPGM(QSYS/QLERCLAG) INLPMTLEN(10) +
  33.                           PROMPT(TXT6856)
  34.              PARM       KWD(OPTION) TYPE(*CHAR) LEN(1) RSTD(*YES) +
  35.                           DFT(*NORMAL) SPCVAL((*NORMAL N) (*ABNORMAL +
  36.                           A)) EXPR(*YES) CHOICE('*NORMAL, +
  37.                           *ABNORMAL') PROMPT(TXT3212) 
  38.  
  39.  
  40. RPGLE: RCL00ARG
  41.        //========================================================================*
  42.        // PROGRAM NAME...: RCL00ARG
  43.        // AUTHOR.........: Chris Hiebert
  44.        // DATE...........: 01/26/2016
  45.        // PCR #..........: STDCODE
  46.        // FUNCTION/DESC..: Reclaim Activation Group Override ELIGIBLE
  47.        //------------------------------------------------------------------------
  48.        //    MODIFICATIONS:
  49.        //------------------------------------------------------------------------
  50.        // MOD#  PCR#    PGMR   DATE   DESCRIPTION
  51.        // /M01               MM/DD/YY CHANGES...
  52.        //========================================================================*
  53.        Ctl-Opt OPENOPT(*NOINZOFL) OPTION(*NODEBUGIO:*SRCSTMT);
  54.        Ctl-Opt DFTACTGRP(*NO) ACTGRP(*NEW) MAIN(RCL00ARG);
  55.  
  56.        Dcl-s ErrorMsgkey Char(4);
  57.        Dcl-s Whitelist Char(20) CTDATA Dim(7);
  58.  
  59.        Dcl-Ds PGMINF psds;
  60.          ProcStatus *STATUS;
  61.          ProcRoutin *ROUTINE;
  62.          ProcName *PROC;
  63.          ParmCount *PARMS;
  64.          PrmCnt *PARMS;
  65.          MsgErrId Char(7) Pos(40);
  66.          PgmInfErrorMsg Char(80) Pos(091);
  67.          ProgName Char(10) Pos(334);
  68.          Pgmnam Char(10) Pos(334);
  69.          JobName Char(10) Pos(244);
  70.          JobNam Char(10) Pos(244);
  71.          UserName Char(10) Pos(254);
  72.          JobUsr Char(10) Pos(254);
  73.          JobNbr Zoned(6) Pos(264);
  74.          JobDate Zoned(6) Pos(270);
  75.          JobDat Zoned(6) Pos(270);
  76.          ProgDate Zoned(6) Pos(276);
  77.          PgmDat Zoned(6) Pos(276);
  78.          ProgTime Zoned(6) Pos(282);
  79.          PgmTim Zoned(6) Pos(282);
  80.        End-Ds;
  81.  
  82.  
  83.        Dcl-pr QWVCCDLA EXTPGM('QSYS/QWVCCDLA');
  84.          P_ACTGRP Char(10);
  85.          P_OPTION Char(1);
  86.        End-pr;
  87.  
  88.        Dcl-Proc RCL00ARG;
  89.        Dcl-pi RCL00ARG Extpgm;
  90.          P_ACTGRP Char(10);
  91.          P_Option Char(1);
  92.        End-pi;
  93.  
  94.        Dcl-Ds P_Errords QUALIFIED;
  95.          Bytespass Int(10) INZ(%SIZE(P_Errords));
  96.          Bytesavail Int(10) INZ(*ZERO);
  97.          MsgID Char(7) INZ(*BLANKS);
  98.          *N Char(1) INZ(X'00');
  99.          MsgDta Char(256) INZ(*BLANKS);
  100.        End-Ds;
  101.        Dcl-Pr QWVOLAGP EXTPGM('QWVOLAGP');
  102.          Receiver Char(1) CONST OPTIONS(*VARSIZE);
  103.          Receiverlen Int(10) CONST;
  104.          ListInfo Char(80);
  105.          RequestCount Int(10) CONST;
  106.          Dataformat Char(8) CONST;
  107.          QualJob Char(26) CONST;
  108.          InternalJobId Char(16) CONST;
  109.          Apierror LIKEDS(P_Errords);
  110.        End-Pr;
  111.        // Get List Entries (QGYGTLE) API
  112.        Dcl-pr QGYGTLE Extpgm('QGYGTLE');
  113.          Receiver Char(1) CONST OPTIONS(*VARSIZE);
  114.          Receiverlen Int(10) CONST;
  115.          Handle Char(4) CONST;
  116.          ListInfo Char(80);
  117.          RequestCount Int(10) CONST;
  118.          StartRecord Int(10) CONST;
  119.          Apierror LIKEDS(P_Errords);
  120.        End-pr;
  121.        // Close List (QGYCLST) API
  122.        Dcl-pr QGYCLST Extpgm('QGYCLST');
  123.          Handle Char(4) CONST;
  124.          Apierror LIKEDS(P_Errords);
  125.        End-pr;
  126.  
  127.        Dcl-s InternalJobId Char(16) Inz;
  128.        Dcl-DS QualJobName Qualified Len(26);
  129.          Job Char(10);
  130.          User Char(10);
  131.          Nbr Char(6);
  132.        End-ds;
  133.        Dcl-s Basesize Int(10);
  134.        Dcl-s BaseCount Int(10);
  135.        Dcl-s StartRecord Int(10);
  136.        Dcl-s Listhandle Char(4);
  137.  
  138.        //****************************************************************
  139.        //Type Definition for the List Information Format
  140.        //****************************************************************
  141.        Dcl-Ds QWVOLI00 Len(80);     // Qwv Olagp ListInfo
  142.          TotalRecords Bindec(9);         // Total Records
  143.          RecordsReturned Bindec(9);         // Records Retd
  144.          Handle Char(4);           // Request Handle
  145.          RecordLength Bindec(9);         // Record Length
  146.          InfoComplete Char(1);           // Info Complete
  147.          DateTime Char(13);          // Date Time
  148.          ListStatus Char(1);           // List Status
  149.          QWVRSV101 Char(1);         // Reserved1
  150.          InfoLength Bindec(9);         // Info Length
  151.          FirstRecord Bindec(9);         // First Record
  152.          QWVRSV200 Char(40);        // Reserved2
  153.        End-Ds;
  154.  
  155.        Dcl-s RAGA0100_P Pointer;
  156.  
  157.        // Qwv Olagp Raga0100
  158.        Dcl-Ds QWVR010000 Based(RAGA0100_P);
  159.          AgpName Char(10);              // AGP Name
  160.          QWVRSV102 Char(6);             // reserved1
  161.          AGPNumber Int(10);             // AGP Number
  162.          NumOfActivations Int(10);      // Num of Activations
  163.          NumOfheaps Int(10);            // Num of Heaps
  164.          StaticSize Int(10);            // Static Size
  165.          HeapSize Int(10);              // Heap Size
  166.          RootPgmNam Char(10);           // Root PGM Name
  167.          RootPgmLib Char(10);           // Root PGM Lib
  168.          RootPgmType Char(1);           // Root PGM Type
  169.          State Char(1);                 // State
  170.          Shared Char(1);                // Shared
  171.          Inuse Char(1);                 // In use
  172.          QWVERVED00 Char(4);            // Reserved
  173.          AgpNumberLong Int(20);         // AGP Number Long
  174.          QWVRSV202 Char(8);             // Reserved2
  175.        End-Ds;
  176.  
  177.        Dcl-s Base_P Pointer;
  178.        Dcl-ds BaseData Likeds(QWVR010000) Based(Base_P);
  179.        Dcl-S Idx Int(10);
  180.        Dcl-S Wkactgrp Char(10);
  181.  
  182.        Dcl-s Whitelist_p Pointer Inz(%Addr(Whitelist));
  183.        Dcl-DS WhiteList_D Dim(6) Based(Whitelist_p) Qualified;
  184.          Actgrp Char(10);
  185.          Pgm Char(10);
  186.        End-ds;
  187.  
  188.        If P_ACTGRP = '*ELIGIBLE';
  189.          Exsr Process;
  190.        Else;
  191.          Monitor;
  192.            Callp QWVCCDLA( P_ACTGRP : P_Option );
  193.          On-error;
  194.        //      CPF1653     Activation group &1 not found.
  195.        //      CPF1654     Activation group &1 cannot be deleted.
  196.        //      CPF180C     Function &1 not allowed.
  197.        //      CPF1892     Function &1 not allowed.
  198.            If MsgErrId = 'CPF1653' OR MsgErrId = 'CPF1654';
  199.              Internal_RaiseError(MsgErrId:P_ACTGRP);
  200.            Elseif MsgErrId = 'CPF180C' OR MsgErrId = 'CPF1892';
  201.              Internal_RaiseError(MsgErrId:'RCLACTGRP');
  202.            Endif;
  203.            Internal_RaiseError();
  204.          Endmon;
  205.        Endif;
  206.  
  207.  
  208.        Dealloc(n) Base_P;
  209.        RAGA0100_P = *Null;
  210.        Return;
  211.  
  212.        //-----------------------------------------------------------------------
  213.        // Load subfile
  214.        //-----------------------------------------------------------------------
  215.        Begsr Process;
  216.  
  217.          QualJobName ='*';
  218.          BaseCount = 100;
  219.          BaseSize = %Size( QWVR010000 ) * BaseCount;
  220.          Base_P = %Alloc( BaseSize );
  221.  
  222.          Qwvolagp(BaseData : BaseSize : QWVOLI00 : BaseCount :
  223.            'RAGA0100' :QualJobName : InternalJobId : P_Errords );
  224.  
  225.          // Trap for errors
  226.          If P_Errords.BytesAvail > 0;
  227.            Internal_RaiseError(P_Errords.MsgId:P_Errords.MsgDta);
  228.          Endif;
  229.          Listhandle = Handle;
  230.  
  231.          If ListStatus <> '2' Or InfoComplete <> 'C';
  232.            Internal_RaiseError('':'List not complete');
  233.          Endif;
  234.  
  235.          Exsr ProcessReturned;
  236.  
  237.          If TotalRecords <= RecordsReturned;
  238.            QGYCLST(Listhandle : P_Errords );
  239.            Leavesr;
  240.          Endif;
  241.  
  242.          StartRecord = FirstRecord;
  243.          Dow TotalRecords > (RecordsReturned + FirstRecord -1);
  244.            StartRecord += RecordsReturned;
  245.  
  246.            QGYGTLE( BaseData : BaseSize : Listhandle : QWVOLI00 : BaseCount :
  247.              StartRecord : P_Errords );
  248.  
  249.            Exsr ProcessReturned;
  250.  
  251.          Enddo;
  252.  
  253.          QGYCLST(Listhandle : P_Errords );
  254.  
  255.        Endsr;
  256.        Begsr ProcessReturned;
  257.          For idx = 1 to RecordsReturned;
  258.            RAGA0100_P = Base_P +%Size( QWVR010000 ) * (Idx -1 );
  259.        //    dsply QWVAGPN01;
  260.  
  261.          // Only process user state. and Not in use.
  262.            If State = '0' And Inuse ='0' And Shared ='0' And
  263.                AgpName <> '*DFTACTGRP' And
  264.                AgpName <> '*UNNAMED' And
  265.                RootPgmLib <> 'QSYS' And
  266.                RootPgmLib <> 'TAATOOL' And
  267.                %Lookup( AgpName : WhiteList_D(*).Actgrp :
  268.                  1 : %Elem(WhiteList_D) ) = 0;
  269.  
  270.              Wkactgrp = AgpName;
  271.              Monitor;
  272.                Callp QWVCCDLA( Wkactgrp : P_Option );
  273.              On-error;
  274.            //      CPF1653     Activation group &1 not found.
  275.            //      CPF1654     Activation group &1 cannot be deleted.
  276.            //      CPF180C     Function &1 not allowed.
  277.            //      CPF1892     Function &1 not allowed.
  278.                If MsgErrId = 'CPF1653' OR MsgErrId = 'CPF1654';
  279.                  Internal_RaiseError(MsgErrId:P_ACTGRP);
  280.                Elseif MsgErrId = 'CPF180C' OR MsgErrId = 'CPF1892';
  281.                  Internal_RaiseError(MsgErrId:'RCLACTGRP');
  282.                Endif;
  283.                Internal_RaiseError();
  284.              Endmon;
  285.            Endif;
  286.  
  287.          Endfor;
  288.        Endsr;
  289.        End-Proc;
  290.  
  291.  
  292.        Dcl-Proc Internal_RaiseError;
  293.        // RaiseError Always sends the message to the program caller.
  294.        Dcl-Pi Internal_RaiseError;
  295.          ErrorMsgid Char(7) Const Options(*Nopass);
  296.          ErrorMsg Varchar(32768) Const Options(*Varsize:*Nopass);
  297.        End-pi;
  298.        //*  SEND Program Message
  299.        Dcl-Pr QMHSNDPM ExtPgm('QMHSNDPM');
  300.          szMsgID Char(7) Const;
  301.          szMsgFile Char(20) Const;
  302.          szMsgData Char(6000) Const  Options(*varsize);
  303.          nMsgDataLen Int(10) Const;
  304.  
  305.          //*  Message Type may be one of the following:
  306.          //*  *COMP    - Completion
  307.          //*  *DIAG    - Diagnostic
  308.          //*  *ESCAPE  - Escape
  309.          //*  *INFO    - Informational
  310.          //*  *INQ     - Inquiry. (only when ToPgmQ(*EXT) is specified.
  311.          //*  *NOTIFY  - Notify
  312.          //*  *RQS     - Request
  313.          //*  *STATUS  - Status
  314.          szMsgType Char(10) Const;
  315.          //*  Call Stack Entry may be one of the following:
  316.          //*  *        - *SAME
  317.          //*  *EXT     - The external message queue
  318.          //*  *CTLBDY  - Control Boundary
  319.          szCallStkEntry
  320.          Char(10) Const;
  321.          nRelativeCallStkEntry
  322.          Int(10) Const;
  323.          SZRTNMSGKEY Char(4) Const;
  324.          api_error Like( QUSEC_Err );
  325.        End-Pr;
  326.  
  327.        Dcl-pr CEE4FCB;
  328.          ctlbdy_inv Int(10) Options(*Omit);
  329.          ctlbdy_type Int(10) Options(*Omit);
  330.          fc Char(12) Options(*Omit);
  331.        End-pr;
  332.        Dcl-s ControlBoundry Int(10);
  333.  
  334.        Dcl-Ds QUSEC_Err Inz;
  335.          us_DSLen Int(10) Inz(%size(qusec_Err));
  336.          us_nRtnLen Int(10) Inz(0);
  337.          us_CpfMsgID Char(7);
  338.          us_apiResv1t Char(1);
  339.        End-Ds;
  340.        Dcl-s Msgid Char(7);
  341.        Dcl-s MsgLevel Int(10);
  342.  
  343.  
  344.        // Get control boundry
  345.        CALLP CEE4FCB( ControlBoundry : *Omit : *Omit );
  346.        MsgLevel = ControlBoundry + 1;
  347.  
  348.        Msgid = 'CPF9897';
  349.  
  350.        // Resend last error
  351.        If %Parms() < %Parmnum( ErrorMsg );
  352.          CALLP QMHSNDPM(Msgid : 'QCPFMSG   *LIBL     ' :
  353.            PgmInfErrorMsg : %Len(PgmInfErrorMsg) : '*ESCAPE' :
  354.            '*' : MsgLevel : ErrorMsgkey : QUSEC_Err);
  355.          Return;
  356.        Endif;
  357.  
  358.        If %Parms() >= %Parmnum( ErrorMsgid ) And ErrorMsgid <> *Blanks;
  359.          Msgid = ErrorMsgid;
  360.        Endif;
  361.  
  362.        // Send escape message to control boundry
  363.        CALLP QMHSNDPM(Msgid :  'QCPFMSG   *LIBL     ' :
  364.            ErrorMsg : %Len(ErrorMsg) : '*ESCAPE' :
  365.            '*' : MsgLevel : ErrorMsgkey : QUSEC_Err);
  366.  
  367.        End-Proc Internal_RaiseError;
  368.  
  369.  
  370. ** WHITELIST
  371. DATEUTL   DATEUTL
  372. UTILITIES ERRORSP
  373. RIM00AAG  RIM00ASP
  374. RIMMAINTAGRIM30ZRG
  375. ISTOOLKIT TLKUTLSP
  376. PAYSTUBS  PRP40ERG
  377. TAAPGNF   TAAPGNFR 
  378.  
© 2004-2019 by midrange.com generated in 0.007s valid xhtml & css