midrange.com code scratchpad
Name:
Modifed JCRSBSDR to show all subsystems, not just active ones.
Scriptlanguage:
Plain Text
Tabwidth:
4
Date:
02/11/2020 06:36:21 pm
IP:
Logged
Description:
Modifed JCRSBSDR to show all subsystems, not just active ones.
Code:
  1.        //---------------------------------------------------------
  2.        ctl-opt copyright('This program is free software, you can redistribute +
  3.        it and/or modify it under the terms of the GNU General Public License +
  4.        as published by the Free Software Foundation. See GNU General Public +
  5.        License for detail.    Craig Rutledge      < www.jcrcmds.com > ');
  6.        //---------------------------------------------------------
  7.        // JCRSBSDR - List subsystem pools and routing ids
  8.        //---------------------------------------------------------
  9.        /define ControlStatements
  10.        /define Constants
  11.        /define ApiErrDS
  12.        /define f_DisplayLastSplf
  13.        /define f_Quscrtus
  14.        /define f_GetDayName
  15.        /define Qwcrneta
  16.        /define Quslobj
  17.        /COPY JCRCMDS,JCRCMDSCPY
  18.  
  19.        dcl-f JCRSBSDP printer oflind(IsOverFlow) usropn;
  20.  
  21.        dcl-s SBSArry char(20) dim(250);
  22.        dcl-s a21 char(21);
  23.        dcl-s PrtPools char(75);
  24.        dcl-s PrtRouting char(30);
  25.        dcl-s QualSbsName char(20);
  26.        dcl-s RoutingExtract char(3);
  27.        dcl-s SystemName char(8);
  28.        dcl-s RoutingArry int(10) dim(50) ascend;
  29.        dcl-s scDow char(9);
  30.        dcl-s yy uns(5);
  31.        dcl-s zz uns(10);
  32.  
  33.        // List Active Subsystems
  34.        dcl-pr Qwclasbs extpgm('QWCLASBS');
  35.         *n char(20);  // Space Name and Lib
  36.         *n char(8) const;  // Api Format
  37.         *n like(ApiErrDS);
  38.        end-pr;
  39.  
  40.        dcl-ds QwclasbsDS qualified based(QwclasbsPtr);
  41.         QualSbsName char(20) pos(1);
  42.        end-ds;
  43.  
  44.        // Retrieve Subsystem Information
  45.        dcl-pr Qwdrsbsd extpgm('QWDRSBSD');
  46.         *n char(500);  // Receiver
  47.         *n int(10) const;  // Length
  48.         *n char(8) const;  // Api Format
  49.         *n char(20);  // Subsystem Name
  50.         *n like(ApiErrDS);
  51.        end-pr;
  52.  
  53.        dcl-ds QwdrsbsdDS len(500) qualified;
  54.         NumberOfPools int(10) pos(77);
  55.        end-ds;
  56.  
  57.        dcl-ds PoolExtractDS qualified based(PoolExtractPtr);
  58.         PoolNumber int(10);
  59.         PoolName char(10);
  60.        end-ds;
  61.  
  62.        // List Subsystem Entries
  63.        dcl-pr Qwdlsbse extpgm('QWDLSBSE');
  64.         *n char(20);  // User Space and Lib
  65.         *n char(8) const;  // Api Format
  66.         *n char(20);  // Qualified Sbs Name
  67.         *n like(ApiErrDS);
  68.        end-pr;
  69.  
  70.        // routing entries
  71.        dcl-ds QwdlsbseDS qualified based(QwdlsbsePtr);
  72.         RoutingEntry int(10) pos(49);
  73.        end-ds;
  74.  
  75.        // load print string
  76.        dcl-ds PoolPrintDS len(15) qualified;
  77.         PoolNumber char(2) pos(1);
  78.         PoolName char(11) pos(4);
  79.        end-ds;
  80.  
  81.        //---------------------------------------------------------
  82.        open JCRSBSDP;
  83.        scDow = f_GetDayName();
  84.  
  85.        // retrieve Network attributes to get sys name
  86.        callp QWCRNETA(
  87.              QwcrnetaDS:
  88.              %size(QwcrnetaDS):
  89.              1:
  90.              'SYSNAME':
  91.              ApiErrDS);
  92.  
  93.        NetWorkInfoPtr = %addr(QwcrnetaDS) + QwcrnetaDS.TableOffset;
  94.        SystemName = NetworkInfoDS.LocalSysName;
  95.        write PrtHead;
  96.        IsOverFlow = *off;
  97.  
  98.        //load active subsystem names to user space then to array
  99.        ApiHeadPtr = f_QUSCRTUS(UserSpaceName);
  100.        //callp QWCLASBS(UserSpaceName: 'SBSL0100': ApiErrDS);
  101.        callp QUSLOBJ(
  102.           UserSpaceName:
  103.           'OBJL0100':
  104.           '*ALL      *ALL':
  105.           '*SBSD':
  106.           ApiErrDS);
  107.        //QwclasbsPtr = ApiHeadPtr + ApiHead.OffSetToList;
  108.        QuslobjPtr = ApiHeadPtr + ApiHead.OffSetToList;
  109.  
  110.  1b    for ForCount = 1 to ApiHead.ListEntryCount;
  111.           //SBSArry(ForCount) = QwclasbsDS.QualSbsName;
  112.           SBSArry(ForCount) = QuslobjDS.ObjNam + QuslobjDS.ObjLib;
  113.           //QwclasbsPtr += ApiHead.ListEntrySize;
  114.           QuslobjPtr += ApiHead.ListEntrySize;
  115.  1e    endfor;
  116.  
  117.        sorta %subarr(SBSArry: 1: ApiHead.ListEntryCount);
  118.  
  119.        //---------------------------------------------------------
  120.        // Spin though subsystems and load pools and routing entries
  121.        //---------------------------------------------------------
  122.        yy = ApiHead.ListEntryCount;
  123.  1b    for ForCount = 1 to yy;
  124.           QualSbsName = SBSArry(ForCount);
  125.  
  126.           // Get POOL id number and names.   Load up to 5 entries
  127.           callp QWDRSBSD(
  128.                 QwdrsbsdDS:
  129.                 %len(QwdrsbsdDS):
  130.                 'SBSI0100':
  131.                 QualSbsName:
  132.                 ApiErrDS);
  133.  
  134.           PoolExtractPtr = %addr(QwdrsbsdDS) + 80;
  135.           PrtPools = *blanks;
  136.           aa = 1;
  137.  
  138.  2b       for zz = 1 to QwdrsbsdDS.NumberOfPools;
  139.  3b          if zz > 5;
  140.  2v             leave;
  141.  3e          endif;
  142.  
  143.              evalr PoolPrintDS.PoolNumber =
  144.              %editc(PoolExtractDS.PoolNumber:'4');
  145.              PoolPrintDS.PoolName = PoolExtractDS.PoolName;
  146.              %subst(PrtPools: aa) = PoolPrintDS;
  147.              aa += 15;
  148.              PoolExtractPtr += 28;
  149.  2e       endfor;
  150.  
  151.           // load routing entries for this subsystem into user space
  152.           callp QWDLSBSE(UserSpaceName: 'SBSE0100': QualSbsName: ApiErrDS);
  153.  
  154.           //---------------------------------------------------------
  155.           // Same routing pool entry ID could be in many
  156.           // routing entries. Only want to show one.
  157.           // Use array to lookup and see if entry is used yet.
  158.           //---------------------------------------------------------
  159.           aa = 0;
  160.           RoutingArry(*) = 0;
  161.           PrtRouting = *all'-    ';
  162.           QwdlsbsePtr = ApiHeadPtr + ApiHead.OffSetToList;
  163.  
  164.  2b       for ForCount2 = 1 to ApiHead.ListEntryCount;
  165.  3b          if aa = 0
  166.                 or %lookup(QwdlsbseDS.RoutingEntry: RoutingArry: 1: aa) = 0;
  167.                 aa += 1;
  168.                 RoutingArry(aa) = QwdlsbseDS.RoutingEntry;
  169.  3e          endif;
  170.              QwdlsbsePtr += ApiHead.ListEntrySize;
  171.  2e       endfor;
  172.  
  173.           // Sort array and load it into print string
  174.  2b       if aa > 1;
  175.              sorta %subarr(RoutingArry: 1: aa);
  176.  2e       endif;
  177.  
  178.           // Spin through array, loading print string
  179.           cc = 1;
  180.  2b       for bb = 1 to aa;
  181.              evalr RoutingExtract = %editc(RoutingArry(bb):'4');
  182.              %subst(PrtRouting: cc: 3) = RoutingExtract;
  183.              cc += 3;
  184.  2e       endfor;
  185.  
  186.           a21 = %subst(QualSbsName: 1: 10)+' '+%subst(QualSbsName: 11);
  187.           write PrtDetail;
  188.  1e    endfor;
  189.  
  190.        close JCRSBSDP;
  191.        f_DisplayLastSplf('JCRSBSDR': '*');
  192.        *inlr = *on;
  193.        return; 
© 2004-2019 by midrange.com generated in 0.007s valid xhtml & css