JLPAOnline

Random musings of a poor but honest programmer
  • About
  • Events
RSS

Recent Posts

  • Windows Server 2008 R2 DNS Issues
  • WRKSRVPGM – A Service Program Management Command for iSeries
  • WRKILEMOD – An ILE Program Manager for iSeries
  • Simple file layout utility for the iSeries
  • You cannot delete a file or a folder on an NTFS file system volume

Archives

Calendar

May 2012
M T W T F S S
« Feb    
 123456
78910111213
14151617181920
21222324252627
28293031  
Feb01

Windows Server 2008 R2 DNS Issues

by Jeff on February 1st, 2012 at 9:43 am
Posted In: Computers, Computers, Tips, Computers, Windows

Lately, I’ve been having issues with my DNS servers, which are both Windows 2008 R2, resolving certain site names.  I fixed it temporarily by adding a forwarder to my router.  I knew there had to be a way to fix it to still use the root hints and resolve successfully.  After googling the problem, this was the one that solved it.  I’m putting it here in it’s entirety as a reminder.

The original web reference is here.

Thank you Scott Forsyth for this solution.


I recently upgraded my home Windows Server 2008 Domain Controller to R2.  The upgrade process itself wasn’t too much work but was a bit more than ‘next, next, finish’ because the AD schema needed to be updated and the installer required that WSUS be uninstalled first.  But, those weren’t a big deal.

However, after the install, I got the strangest behavior.  Visiting some websites like www.microsoft.com, www.bing.com, www.windowsupdate.com and a number of other Microsoft websites didn’t work.  However, other websites worked perfectly.  In fact,www.google.com still worked.  It’s almost as if Microsoft decided they didn’t want to grow their search engine market share anymore and would start blocking their visitors. :)

What made it even more confusing was that if I viewed the errors in my browser, it timed out and gave a DNS error. However, if I pinged the DNS name, it worked.

(feel free to skip to the bottom for the fix if you don’t want to read the details)

I did some searching and didn’t find an answer (although now that I know what search terms to look for, I see that others have run into this now).  I tried all the basic troubleshooting methods to no avail.

I skimmed some R2 release notes I found and I saw that there were EDns (EDNS0) changes with R2 but it was pretty vague.  EDns is a relatively new DNS protocol extension that is still coming of age.  Later I realized that I was on to something here.

I realized that I would need to fire up Network Monitor to get the story.  After running Network Monitor, an issue was immediately apparent as seen from the following screen shot snippet:

image

First, I wondered why my search for bing.com returned search.ms.com.edgesuite.net.  The answer to that wasn’t hard to find.  Those are the DNS names of the Akamai CDN which Microsoft uses for a lot of their sites.  The real issue there is the “Response – Format error”.

I looked at the request and the results for a while and it seemed straight forward, so I did a network trace on a working server and found that R2 added some extra information.  Notice the bottom line of the following image with the “AdditionalRecord:  of type OPT on class Unknown DNSClass”.  The network trace on the working server didn’t have that.

image

So, I knew at this point that R2 was adding something that the Akamai DNS servers didn’t like.  I did a search for OPT and discovered that OPT is used in EDns.  I found a registry setting called EnableEDNSProbes which disables EDNS when set to 0.  After setting that and restarting the DNS Server service, everything worked perfectly.  I set it back again and it stopped working, so I knew I had narrowed it down.

While searching for information on EDns, I discovered that some DNS servers will attempt to make a EDNS probe, and if it fails then it will try again with a plain query.  That allows it to always work regardless of the support of the other DNS servers.  However, after testing I found that Microsoft DNS doesn’t do that.  EDNS can either be ‘on’ or ‘off’.  Bummer, I thought that was a good idea.

Testing further I discovered that it’s not enabled by default on Windows Server 2008 RTM.  I tried on another R2 server that wasn’t in production yet and confirmed that the issue appeared there too.  So, the issue wasn’t that something changed with EDns, it’s simply that it was enabled in R2 for the first time.

The reason that it failed in the web browser but worked with a ping is because the browser followed a redirect and failed on the redirected address and not the original address.  The ping didn’t follow the redirect so the failure never occurred.

It appears that the same issue occured when Windows Server 2003 was released:http://support.microsoft.com/kb/832223.  I don’t remember that occuring and being a big deal so I suspect that Microsoft must have made changes to the default with later service packs or hot fixes.

Conclusion

It appears that the Internet isn’t fully up to date and ready to use EDns quite yet.  The solution for this is to disable EDns and wait another year or two until Akamai and other DNS servers catch up, or Microsoft releases a hot fix to support the failback option I mentioned above.

Note that this isn’t a problem for most Windows Server 2008 R2 member servers.  It’s only a problem for DNS *servers* that do recursive lookups.  i.e. likely only your domain controller will be affected if that is where your DNS Server role exists.

Fix

To disable EDns, you can do it from the command prompt, or by editing the registry.

From the command prompt, no restart of DNS is required.  If from the registry, make sure to restart the DNS Server service.

Command prompt: 

dnscmd /config /EnableEDNSProbes 0

No restart is needed.  It takes effect immediately.

or Registry: </>

Create a DWORD called EnableEDNSProbes and set to 0 in HKLM\SYSTEM\CurrentControlSet\services\DNS\Parameters

Restart the DNS Server service for it to take effect.

 Comment 
Oct26

WRKSRVPGM – A Service Program Management Command for iSeries

by Jeff on October 26th, 2010 at 1:26 pm
Posted In: Computers, Computers, iSeries

This is the last of my utility posts for the time being. Just like with the other utility programs on this site, use at your own risk. All source can be used for any purpose as long as you site me as the original author.

This has the same purpose for service programs as WRKILEMOD has for multi-module programs.

Without any more discussion, it’s on with the source code.

RPG Source-SY0040R

      /Title SY0040R - Work with Service Program Modules.
     H Optimize(*None) Option(*SrcStmt: *NoDebugIO)
     H CopyRight('Copyright 2010. Jeffrey Lanham Programming Arts, Inc. All Rig-
     Hhts Reserved.')
      //*************************************************************************
      //  Module: SY0040R                                                       *
      //  Purpose: This module gets module information for Service Program      *
      //           objects.  Will eventually turn this into a service program   *
      //           management system.                                           *
      //*************************************************************************
      //  Written by: Jeffrey Lanham                                            *
      //*************************************************************************

     FSY0040FM  CF   E             Workstn Sfile(SY0040S1: Recno1)
     F                                     Sfile(SY0040S5: Recno5)
     F                                     Infds(SY0040DS)
     FSY0040P   O    E             Printer UsrOpn

      /Eject
      //*************************************************************************
      // Constants.
     D CmdCol          C                   7
     D CmdRow          C                   21

      //*************************************************************************
      // Work fields.
     D Bin04           S              8B 0                                      Scrap 4.0 Binary
     D Cancelled       S               N                                        Function Cancelled?
     D CommandLine     S          32702                                         Command Line
     D CommandLength   S             15  5                                      Command Length
     D ErrorMessage    S             80                                         Error Message Parm.
     D No_Selection    S               N                                        No Selection Made
     D NotExist        S               N                                        Doesn't Exist?
     D OverFlow        S               N                                        OverFlow Indicator
     D Recno1          S                   Like(SFLCT1)                         Subfile Record No.
     D Recno5          S                   Like(SFLCT5)                         Subfile Record No.
     D Sav_Cur_Page    S                   Like(SFLCT1)
     D Tick            C                   X'7D'                                '

      //*************************************************************************
      // Entry Parameter Procedure definition.
     D SY0040R         PR
      // This is also a parameter for QBNLPGMI API (List ILE Program Information).
     D  Bi_ILEPgmName                20

     D SY0040R         PI
     D  Bi_ILEPgmName                20

      //*************************************************************************
      // File information data structure.
     D SY0040DS        DS                                                       Infds Data Structure
     D  Cur_RRN              376    377B 0                                      Current Sfile RRN
     D  Cur_Page             378    379B 0                                      RRN Current Page

      //*************************************************************************
      // Program status data structure.
     D                SDS                                                       System Data Struct.
     D ErrorData              91    170                                         Error data

      //*************************************************************************
      // Definitions for user space information.
     D Gn_Pointer      S               *                                        Generic Header Ptr

      //*************************************************************************
      // Generic user space header.
     D Gn_Header       DS                  Based(Gn_Pointer)
     D   Gn_UserArea                 64                                         User Area
     D   Gn_HdrSize                   8B 0                                      Generic Header Size
     D   Gn_RlsLevel                  4                                         Release and Level
     D   Gn_Format                    8                                         Format Name
     D   Gn_APIUsed                  10                                         API Used
     D   Gn_CreateSt                 13                                         TimeStamp Created
     D   Gn_InfoStat                  1                                         Information Status
     D   Gn_SizeUsed                  8B 0                                      Space Size Used
     D   Gn_InputOff                  8B 0                                      Input Section Offset
     D   Gn_InputSize                 8B 0                                      Input Section Size
     D   Gn_HeadrOff                  8B 0                                      Header Offset
     D   Gn_HeadrSize                 8B 0                                      Header Size
     D   Gn_ListOff                   8B 0                                      Offset to List
     D   Gn_ListSize                  8B 0                                      List Size
     D   Gn_Entries                   8B 0                                      Number of Entries
     D   Gn_EntrySize                 8B 0                                      Entry Size

      //*************************************************************************
      // List Pointers.
     D Pt_SPGL0100     S               *
     D Pt_SPGL0200     S               *

      //*************************************************************************
      // List module information section.
     D Ls_SPGL0100     DS                  Based(Pt_SPGL0100)
     D   Md_Program                  10                                         Program Name
     D   Md_Library                  10                                         Library Name
     D   Md_Module                   10                                         Module Name
     D   Md_ModuleLib                10                                         Module Library
     D   Md_SrcFile                  10                                         Source File Name
     D   Md_SrcLib                   10                                         Source Library Name
     D   Md_SrcMember                10                                         Source Member Name
     D   Md_ModuleAtt                10                                         Module Attribute
     D   Md_ModuleCrt                13                                         Creation Time Stamp
     D   Md_SrcUpdate                13                                         Last Update TimeStmp
     D   Md_SortTable                10                                         Sort Table
     D   Md_SortLib                  10                                         Sort Library
     D   Md_LangId                   10                                         Language Identifier
     D   Md_OptLevel                  8B 0                                      Optimization Level
     D   Md_MaxOpt                    8B 0                                      Max Optimization Lvl
     D   Md_ModCrtRls                 6                                         Release Created On
     D   Md_ModCrtFor                 6                                         Module Created For
     D   Md_Reserved                 20                                         Reserved
     D   Md_UsrMod                    1                                         User Modified
     D   Md_LicPgm                   13                                         Licensed Program
     D   Md_PTFNumber                 5                                         PTF Number
     D   Md_APARId                    6                                         APAR Id
     D   Md_Reserv2                   1                                         Reserved again
     D   Md_ModCCSID                  8B 0                                      Module CCSID
     D   Md_ObjCtrLvl                 8                                         Object Control Level
     D   Md_Reserv3                 100                                         One more time
     D   Md_SqlStmt                   8B 0                                      No SQL Statements
     D   Md_RelDbase                 18                                         Relational Database
     D   Md_CommitCtr                10                                         Commitment Control
     D   Md_AlwCpyDta                10                                         Allow Copy of Data
     D   Md_CloseSql                 10                                         Close SQL Cursors
     D   Md_NameConv                 10                                         Naming Convention
     D   Md_DateFmt                  10                                         Date Format
     D   Md_DateSep                   1                                         Date Seperator
     D   Md_TimeFmt                  10                                         Time Format
     D   Md_TimeSep                   1                                         Time Seperator
     D   Md_DelayPrep                10                                         Delay PREPARE
     D   Md_AllowBlck                10                                         Allow Blocking
     D   Md_DftColl                  10                                         Default Collection
     D   Md_SQLPkg                   10                                         SQL Package Name
     D   Md_SQLPLib                  10                                         SQL Package Library
     D   Md_DynUser                  10                                         Dynamic User Profile
     D   Md_SQLSTbl                  10                                         SQL Sort Table
     D   Md_SQLSLib                  10                                         SQL Sort Library
     D   Md_SQLLang                  10                                         SQL Language Id
     D   Md_ConnMth                  10                                         Connection Method

      //*************************************************************************
      // Service program information data structure.
     D Ls_SPGL0200     DS                  Based(Pt_SPGL0200)
     D  Sp_Program                   10                                         Program Name
     D  Sp_Library                   10                                         Program Library
     D  Sp_Service_Program...                                                   Service Program
     D                               10
     D  Sp_Service_Library...                                                   Service Library
     D                               10
     D  Sp_Service_Signature...
     D                               16                                         Signature

      //*************************************************************************
      // Retrieve Program Information Return Variable.
     D Si_SPGI0100     DS
     D  Si_BytesAva                   8B 0                                      Bytes Available
     D  Si_BytesRet                   8B 0                                      Bytes Returned
     D  Si_Program_Name...
     D                               10                                         Program Name
     D  Si_Program_Library...
     D                               10                                         Program Library
     D  Si_Program_Owner...
     D                               10                                         Program Owner
     D  Si_Program_Attribute...
     D                               10                                         Program Attribute
     D  Si_Create_Date_Time...
     D                               13                                         Create Date/Time
     D  Si_Export_Source_File...
     D                               10                                         Export Source File
     D  Si_Export_Source_File_Library...
     D                               10                                         Export Source Lib
     D  Si_Export_Source_Member...
     D                               10                                         Export Source Member
     D  Si_Activation_Group_Attr...
     D                               30                                         Activation Group Atr
     D  Si_Current_Signature...
     D                               16                                         Current Export Sig.
     D  Si_User_Profile...
     D                                1                                         User Profile
     D  Si_Observable_Information_Compressed...
     D                                1                                         Observable Compress
     D  Si_Run_Time_Information_Compressed...
     D                                1                                         Run Time Compressed
     D  Si_Program_CCSID...
     D                                8B 0                                      Program CCSID
     D  Si_Number_of_Modules...
     D                                8B 0                                      Number of Modules
     D  Si_Number_of_Service_Programs...
     D                                8B 0                                      Number of Serv Pgms
     D  Si_Number_of_Copyrights...
     D                                8B 0                                      Number of Copyrights
     D  Si_Desciption...
     D                               50                                         Program Description
     D  Si_Shared_Activation_Group...
     D                                1                                         Shared Act. Group?
     D  Si_Allow_Update...
     D                                1                                         Allow Update?
     D  Si_Number_of_Unresolved_References...
     D                                8B 0                                      # of Unresolved Refs
     D  Si_Use_Adopted_Auth...
     D                                1                                         Use Adopted Auth.
     D  Si_Allow_Bound_Service_Library_Update...
     D                                1                                         Allow Service Update
     D  Si_Profiling_Data...
     D                               10                                         Profiling Data
     D  Si_Reserved1                 82                                         IBM Reserved
     D  Si_Program_State...
     D                                1                                         Program State
     D  Si_Program_Domain...
     D                                1                                         Program Domain
     D  Si_Associated_Space_Size...
     D                                8B 0                                      Associated Size
     D  Si_Static_Storage...
     D                                8B 0                                      Static Storage
     D  Si_Program_Size...
     D                                8B 0                                      Program Size
     D  Si_Release_Created...
     D                                6                                         Release Created On
     D  Si_Earliest_Run_Release...
     D                                6                                         Earliest Run Rls.
     D  Si_Release_Created_For...
     D                                6                                         Release Created For
     D  Si_ReInit_Static_Storage...
     D                                1                                         Allow Reinit.
     D  Si_Conversion_Required...
     D                                1                                         Conversion Required?
     D  Si_All_Creation_Data...
     D                                1                                         All Creation Data
     D  Si_Reserved2                 91                                         IBM Reserved
     D  Si_Paging_Pool...
     D                                1                                         Paging Pool
     D  Si_Paging_Amount...
     D                                1                                         Paging Amount

      //*************************************************************************
      // API Error code parameter for those that need it.
     D DS_ErrorCode    DS
     D   ER_BytesPrv                  8B 0 Inz(256)                             Bytes Provided
     D   ER_BytesAva                  8B 0                                      Bytes Available
     D   ER_ExcId                     7                                         Exception Id
     D   ER_Reserved                  1                                         Reserved
     D   ER_Data                    256                                         Exception Data

      //*************************************************************************
      // API Dummy Error Code.
     D DS_DummyError   DS
     D   DE_BytesPrv                  8B 0 Inz(0)                               Bytes Provided

      //*************************************************************************
      // Retrieve Object description return data.
     D DS_OBJD0200     DS
     D  OB_BytesRet                   8B 0                                      Bytes Returned
     D  OB_BytesAva                   8B 0                                      Bytes Available
     D  OB_Object                    10                                         Object Name
     D  OB_Library                   10                                         Object Library
     D  OB_Type                      10                                         Object Type
     D  OB_Return_Library...
     D                               10                                         Return Library
     D  OB_ASP                        8B 0                                      Aux Storage Pool
     D  OB_Owner                     10                                         Object Owner
     D  OB_Domain                     2                                         Object Domain
     D  OB_Create_Date_Time...
     D                               13                                         Create Date/Time
     D  OB_Change_Date_Time...
     D                               13                                         Change Date/Time
     D  OB_Extended_Attribute...
     D                               10                                         Extended Attribute
     D  OB_Text                      50                                         Text Description
     D  OB_SourceFile                10                                         Source File
     D  OB_SourceLib                 10                                         Source Library
     D  OB_SourceMbr                 10                                         Source Member

      //*************************************************************************
      // Retrieve Request Message return data.
     D DS_RTVQ0100     DS
     D  RM_BytesRet                   8B 0                                      Bytes Returned
     D  RM_BytesAva                   8B 0                                      Bytes Available
     D  RM_MsgKey                     4                                         Message Key
     D  RM_Reserved                  20                                         IBM Reserved
     D  RM_LengthRet                  8B 0                                      Length Returned
     D  RM_LengthAva                  8B 0                                      Length Available
     D  RM_Text                   32000                                         Message Data

      // Retrieve Program Message return data.
     D DS_RCVM0100     DS
     D  RC_BytesRet                   8B 0                                      Bytes Returned
     D  RC_BytesAva                   8B 0                                      Bytes Available
     D  RC_MsgSev                     8B 0                                      Message Severity
     D  RC_MsgId                      7                                         Message Identifier
     D  RC_MsgType                    2                                         Message Type
     D  RC_MsgKey                     4                                         Message Key
     D  RC_Reserved                   7                                         Reserved
     D  RC_CCSIDStat                  8B 0                                      CCSID Conv Status
     D  RC_CCSIDRepl                  8B 0                                      CCSID Replace Data
     D  RC_ReplRet                    8B 0                                      Replace Data Return
     D  RC_ReplAva                    8B 0                                      Replace Data Avail
     D  RC_Text                   32000                                         Message Data

      //*************************************************************************
      // Process commands control block.
     D DS_CPOP0100     DS
     D   CP_Type                      8B 0 Inz(3)                               Type of Processing
     D   CP_DBCS                      1    Inz('0')                             DBCS Data Handling
     D   CP_PromptAct                 1                                         Prompter Action
     D   CP_CmdSyntax                 1    Inz('0')                             Command String Syntx
     D   CP_MsgKey                    4    Inz(*Blanks)                         Message Retrieve Key
     D   CP_Reserved                  9    Inz(X'000000000000000000')           IBM Reserved

      //*************************************************************************
      // QUSROBJD - Retrieve object description.
     D POB_Length      S              8B 0 Inz(%Size(DS_OBJD0200))
     D POB_Format      S              8    Inz('OBJD0200')
     D POB_QLObject    S             20                                         Qualified Object
     D POB_ObjectType  S             10    Inz('*MODULE')                       Object Type

      //*************************************************************************
      // Parameters for QUSCRTUS API (Create User Space) for Modules
     D Md_SpaceName    S             20    Inz('ILEPGM    QTEMP')               Qualified Space Name
     D Md_ExtAttr      S             10    Inz('WRKILEPGM')                     Extended Attribute
     D Md_InitSize     S              8B 0 Inz(%Size(Ls_SPGL0100))
     D Md_InitValue    S              1    Inz(X'00')
     D Md_PubAuth      S             10    Inz('*ALL')                          Public Authority
     D Md_Text         S             50    Inz('User Space for WRKILEPGM')      User Space Text
     D Md_Replace      S             10    Inz('*YES')                          Replace Object

      //*************************************************************************
      // Parameters for QUSCRTUS API (Create User Space) for Service Programs
     D Sp_SpaceName    S             20    Inz('SRVPGM    QTEMP')               Qualified Space Name
     D Sp_ExtAttr      S             10    Inz('WRKILEPGM')                     Extended Attribute
     D Sp_InitSize     S              8B 0 Inz(%Size(Ls_SPGL0200))
     D Sp_InitValue    S              1    Inz(X'00')
     D Sp_PubAuth      S             10    Inz('*ALL')                          Public Authority
     D Sp_Text         S             50    Inz('User Space for WRKILEPGM')      User Space Text
     D Sp_Replace      S             10    Inz('*YES')                          Replace Object

      //*************************************************************************
      // Parameters for QBNLSPGM API (List ILE Program Information).
     D Bi_Format       S             10                                         API Format to Return

      //*************************************************************************
      // Parameters for QBNRSPGM API (Retrieve Program Information).
     D Si_Data_Length  S              4B 0 Inz(%Size(Si_SPGI0100))              Data Length

      //*************************************************************************
      // QMHRMVPM - Remove program messages API.
     D PRM_CallQ       S             10    Inz('*')                             Call Message Queue
     D PRM_CallStack   S              8B 0 Inz(1)                               Call Stack Counter
     D PRM_MsgKey      S              4                                         Message Key
     D PRM_MsgToRemove...
     D                 S             10    Inz('*ALL')                          Messages To Remove

      //*************************************************************************
      // QMHRSNDPM - Send program messages API.
     D PSM_MsgID       S              8    Inz('CPF9897')                       Message Identifier
     D PSM_QLMsgFile   S             20    Inz('QCPFMSG   *LIBL')               Qualified Msg File
     D PSM_Length      S              8B 0 Inz(%Size(ErrorMessage))             Message Length
     D PSM_MsgType     S             10    Inz('*INFO')                         Message Type
     D PSM_CallQ       S             10    Inz('*')                             Call Message Queue
     D PSM_CallStack   S              8B 0 Inz(1)                               Call Stack Counter
     D PSM_MsgKey      S              4                                         Message Key

      //*************************************************************************
      // QMHRSNDPM - Send program messages API parameters for request messages.
     D RSM_MsgID       S              8    Inz('       ')                       Message Identifier
     D RSM_QLMsgFile   S             20    Inz('               ')               Qualified Msg File
     D RSM_Length      S              8B 0 Inz(%Size(CommandLine))              Message Length
     D RSM_MsgType     S             10    Inz('*RQS')                          Message Type
     D RSM_CallQ       S             10    Inz('*')                             Call Message Queue
     D RSM_CallStack   S              8B 0 Inz(0)                               Call Stack Counter
     D RSM_MsgKey      S              4                                         Message Key

      /Eject
      //*************************************************************************
      // Procedure definitions.
      //*************************************************************************
      // Create User Space.
     D QUsCrtUs        PR                  ExtPgm('QUSCRTUS')
     D   SpaceName                   20                                         Qualified Space Name
     D   ExtAttr                     10                                         Extended Attribute
     D   InitSize                     8B 0                                      Initial Size
     D   InitValue                    1                                         Initial Value
     D   PubAuth                     10                                         Public Authority
     D   Text                        50                                         User Space Text
     D   Replace                     10                                         Replace Object
     D   ErrorCode                         Like(DS_ErrorCode)                   Error Code

      //*************************************************************************
      // Delete User Space.
     D QUsDltUs        PR                  ExtPgm('QUSDLTUS')
     D   SpaceName                   20                                         Qualified Space Name
     D   ErrorCode                         Like(DS_ErrorCode)                   Return Error Code

      //*************************************************************************
      // Retrieve Pointer to User Space.
     D QUsPtrUs        PR                  ExtPgm('QUSPTRUS')
     D   SpaceName                   20                                         Qualified Space Name
     D   RetPointer                    *                                        Return Pointer
     D   ErrorCode                         Like(DS_ErrorCode)                   Return Error Code

      //*************************************************************************
      // Retrieve ILE Program Information.
     D QBnlSPgm        PR                  ExtPgm('QBNLSPGM')
     D   SpaceName                   20                                         Qualified Space Name
     D   FormatName                   8                                         Format Name
     D   ILEProgram                  20                                         Qualified Pgm Name
     D   ErrorCode                         Like(DS_ErrorCode)                   Error Code

      //*************************************************************************
      // Send program message API.
     D Send_PgmMessage...
     D                 PR                  ExtPgm('QMHSNDPM')                   Send Pgm Message
     D                                7                                         Message Id
     D                               20                                         Qualified Msg File
     D                            32767    Options(*VarSize)                    Message Data
     D                                8B 0                                      Length of Msg Data
     D                               10                                         Message Type
     D                            32767    Options(*VarSize)                    Call Message Queue
     D                                8B 0                                      Call Stack Counter
     D                                4                                         Message Key
     D                            32767    Options(*VarSize)                    Error Code

      //*************************************************************************
      // Receive request message API.
     D Receive_RqsMessage...
     D                 PR                  ExtPgm('QMHRTVRQ')                   Receive Pgm Message
     D                            32767    Options(*VarSize)                    Message Data
     D                                8B 0 Const                                Length of Msg Data
     D                                8    Const                                Format Name
     D                               10    Const                                Message Type
     D                                4    Const                                Message Key
     D                            32767    Options(*VarSize)                    Error Code

      //*************************************************************************
      // Receive program message API.
     D Receive_PgmMessage...
     D                 PR                  ExtPgm('QMHRCVPM')                   Receive Pgm Message
     D                            32767    Options(*VarSize)                    Message Data
     D                                8B 0 Const                                Length of Msg Data
     D                                8    Const                                Format Name
     D                            32767    Options(*VarSize) Const              Call Stack Entry
     D                                8B 0 Const                                Call Stack Counter
     D                               10    Const                                Message Type
     D                                4    Const                                Message Key
     D                                8B 0 Const                                Wait Time
     D                               10    Const                                Message Action
     D                            32767    Options(*VarSize)                    Error Code

      //*************************************************************************
      // Remove program message API.
     D Remove_PgmMessage...
     D                 PR                  ExtPgm('QMHRMVPM')                   Remove Messages
     D                            32767    Options(*VarSize)                    Call Message Queue
     D                                8B 0                                      Call Stack Counter
     D                                4                                         Message Key
     D                               10                                         Messages to Remove
     D                            32767    Options(*VarSize)                    Error Code

      //*************************************************************************
      // Retrieve Program Information (QBNRSPGM)
     D QBnrSPgm        PR                  ExtPgm('QBNRSPGM')
     D                            32767    Options(*VarSize)                    Returned Data
     D                                4B 0                                      Receiver Var Length
     D                                8                                         Format Name
     D                               20                                         Qualified Program
     D                            32767    Options(*VarSize)                    Error Code

      //*************************************************************************
      // Commands for each module attribute.
     D C               S              5U 0                                      Lookup Array Index
     D ModAtt          S             10    Dim(10) CtData PerRcd(1)             Module Attribute
     D ModCmd          S             10    Dim(%Elem(ModAtt)) CtData PerRcd(1)  Module Create Cmds
     D BndCmd          S             10    Dim(%Elem(ModAtt)) CtData PerRcd(1)  Bound Pgm Commands

      //*************************************************************************
      // Clear Message Procedure.
     D Clear_Message   PR

      //*************************************************************************
      // Send Message Procedure.
     D Send_Message    PR
     D   Message                  32767    Options(*VarSize)

      //*************************************************************************
      // Display Service program procedure.
     D Disp_Service_Program...
     D                 PR              N

      //*************************************************************************
      // Print list procedure.
     D Print_List      PR

      //*************************************************************************
      // Retrieve Object Description API.
     D QUsrObjD        PR                  ExtPgm('QUSROBJD')                   Retrieve Object Desc
     D                            32767    Options(*VarSize)                    Return Data
     D                                8B 0                                      Length of Receiver
     D                                8                                         Format Name
     D                               20                                         Qualified Obj Name
     D                               10                                         Object Type
     D                            32767    Options(*VarSize)                    Error Code

      //*************************************************************************
      // QCMDEXEC API.
     D QCmdExec        PR                  ExtPgm('QCMDEXC')
     D   CommandLine              32702    Options(*VarSize)
     D   CommandLength...
     D                               15  5

      // QCMDCHK API.
     D QCmdCheck       PR                  ExtPgm('QCMDCHK')
     D   CommandLine              32702    Options(*VarSize)
     D   CommandLength...
     D                               15  5

      //*************************************************************************
      // QCAPCMD API.
     D QCapCommand     PR                  ExtPgm('QCAPCMD')
     D                            32702    Options(*VarSize) Const              Command Line Passed
     D                                8B 0 Const                                Command Line Length
     D                            32702A   Options(*VarSize) Const              Options Block
     D                                8B 0 Const                                Options Block Length
     D                                8    Const                                Options Block Format
     D                            32702A   Options(*VarSize)                    Changed Command Str
     D                                8B 0 Const                                Ret Cmd Available
     D                                8B 0                                      Length Returned
     D                            32702A   Options(*VarSize: *Omit)             Error Return Code
      //*************************************************************************
      // Build a binding directory.
     D Build_Directory...
     D                 PR              N

      //*************************************************************************
      // Convert to Hex.
     D CvtToHex        PR                  OpDesc
     D   InString                 16383    Const Options(*VarSize)
     D   HexString                32766    Options(*VarSize)
      //*************************************************************************
      // Add an entry to the command line history buffer.
     D Add_Command_Line...
     D                 PR                  OpDesc
     D  CommandLine               32702    Options(*VarSize)

      //*************************************************************************
      // Retrieve the next entry in the history buffer.
     D Retrieve_Command_Line...
     D                 PR                  Like(CommandLine)

      //*************************************************************************
      // Attach command line to command.
     D Attach_Options...
     D                 PR         32702    OpDesc
     D                            32702    Options(*VarSize)                    Command Line
     D                            32702    Options(*VarSize)                    Options to Attach

      /Eject
      /Free
       //*************************************************************************
       //* Create the user spaces in QTEMP.
       PGMQ = '*';
       Clear ER_ExcId;

       //*************************************************************************
       // Create user space for module display.
       QUsCrtUs(Md_SpaceName: Md_ExtAttr:
           Md_InitSize: Md_InitValue: Md_PubAuth:
           Md_Text: Md_Replace: DS_ErrorCode);
       If Not (ER_ExcId = *Blanks);
         Exsr Exception_Err;
         Return;
       Endif;                                                                 //Not (ER_ExcId...

       //*************************************************************************
       // Create the user space for service program display.
       QUsCrtUs(Sp_SpaceName: Sp_ExtAttr:
           Sp_InitSize: Sp_InitValue: Sp_PubAuth:
           Sp_Text: Sp_Replace: DS_ErrorCode);
       If Not (ER_ExcId = *Blanks);
         Exsr Exception_Err;
         Return;
       Endif;                                                                 //Not (ER_ExcId...

       *IN88 = *Off;                                                          //Display Dft Keys

       Dow Not *INLR;

         //*************************************************************************
         // Call the Retrieve Program Information API.
         Clear ER_ExcId;
         Bi_Format = 'SPGI0100';
         QBnrSPgm(Si_SPGI0100: Si_Data_Length:
             Bi_Format: Bi_ILEPgmName: DS_ErrorCode);
         If Not (ER_ExcId = *Blanks);
           Exsr Exception_Err;
           QUsDltUs(Md_SpaceName: DS_ErrorCode);
           QUsDltUs(Sp_SpaceName: DS_ErrorCode);
           Return;
         Endif;                                                               //Not (ER_ExcId...

         //*************************************************************************
         // Call the Get ILE Program Information API for modules information.
         Clear ER_ExcId;
         Bi_Format = 'SPGL0100';
         QBnlSPgm(Md_SpaceName: Bi_Format:
             Bi_ILEPgmName: DS_ErrorCode);
         If Not (ER_ExcId = *Blanks);
           Exsr Exception_Err;
           QUsDltUs(Md_SpaceName: DS_ErrorCode);
           QUsDltUs(Sp_SpaceName: DS_ErrorCode);
           Return;
         Endif;                                                               //Not (ER_ExcId...

         //*************************************************************************
         // Call the Get ILE Program Information API for service program information.
         Clear ER_ExcId;
         Bi_Format = 'SPGL0200';
         QBnlSPgm(Sp_SpaceName: Bi_Format:
             Bi_ILEPgmName: DS_ErrorCode);
         If Not (ER_ExcId = *Blanks);
           Exsr Exception_Err;
           QUsDltUs(Md_SpaceName: DS_ErrorCode);
           QUsDltUs(Sp_SpaceName: DS_ErrorCode);
           Return;
         Endif;                                                               //Not (ER_ExcId...

         //*************************************************************************
         // Load the top of screen data.
         SAPROGRAM = Si_Program_Name;
         SAPGMLIB = Si_Program_Library;
         CvtToHex(Si_Current_Signature: SASIGNAT);

         //*************************************************************************
         // Retrieve the pointer to the user space for module information.
         Clear ER_ExcId;
         QUsPtrUs(Md_SpaceName: Gn_Pointer:
             DS_ErrorCode);
         If Not (ER_ExcId = *Blanks);
           Exsr Exception_Err;
           QUsDltUs(Md_SpaceName: DS_ErrorCode);
           QUsDltUs(Sp_SpaceName: DS_ErrorCode);
           Return;
         Endif;                                                               //Not (ER_ExcId...

         //*************************************************************************
         // Now we can load the subfile for module information.
         *IN66 = *On;
         Write SY0040C1;
         *IN66 = *Off;
         Pt_SPGL0100 = Gn_Pointer + Gn_ListOff;
         NotExist = *Off;
         For Recno1 = 1 to Gn_Entries;
           If Recno1 <= *Zeros;
             Leave;
           Endif;                                                             //Recno1<=*Zeros
           *IN67 = *On;
           Clear SAOPTION;
           SAMODULE = Md_Module;
           SALIBRARY = Md_ModuleLib;
           SASOURCE = Md_SrcFile;
           SASRCLIB = Md_SrcLib;
           SAMEMBER = Md_SrcMember;
           SAMODATTR = Md_ModuleAtt;
           // If the create date is not blanks, convert the date and time.
           If Not (Md_ModuleCrt = *Blanks);
              SACREATEDT = %Char(%Date(%Subst(Md_ModuleCrt: 1: 7):
                              *CYMD0): *MDY/);
              SACREATETM = %Char(%Time(%Subst(Md_ModuleCrt: 8: 6):
                              *HMS0): *HMS:);
           Endif;                                                             //Not (Md_Module...
           // If the source update date is not blanks, convert the date and time.
           If Not (Md_SrcUpdate = *Blanks);
              SASRCCHGDT = %Char(%Date(%Subst(Md_SrcUpdate: 1: 7):
                              *CYMD0): *MDY/);
              SASRCCHGTM = %Char(%Time(%Subst(Md_SrcUpdate: 8: 6):
                              *HMS0): *HMS:);
           Endif;                                                             //Not (Md_SrcUpdate...
           // Clear the exception Id.
           Clear Er_ExcId;
           POB_QLObject = SAMODULE + SALIBRARY;
           POB_ObjectType = '*MODULE';
           QUsrObjD(DS_OBJD0200: POB_Length: POB_Format:
               POB_QLObject: POB_ObjectType: DS_ErrorCode);
           If Not (Er_ExcId = *Blanks);
             NotExist = *On;
             SAMODTEXT = '* Not Available';
           Else;
             SAMODTEXT = OB_Text;
           Endif;                                                             //Not (Er_ExcId...
           Write SY0040S1;
           Pt_SPGL0100 = Pt_SPGL0100 + Gn_EntrySize;
         EndFor;                                                              //Do Gn_Entries

         //*************************************************************************
         // Retrieve the pointer to the user space for service program information.
         Clear ER_ExcId;
         QUsPtrUs(Sp_SpaceName: Gn_Pointer:
             DS_ErrorCode);
         If Not (ER_ExcId = *Blanks);
           Exsr Exception_Err;
           QUsDltUs(Md_SpaceName: DS_ErrorCode);
           QUsDltUs(Sp_SpaceName: DS_ErrorCode);
           Return;
         Endif;                                                               //Not (ER_ExcId...

         // Now we can load the subfile for module information.
         *IN68 = *On;
         Write SY0040C5;
         *IN68 = *Off;
         Pt_SPGL0200 = Gn_Pointer + Gn_ListOff;

         NotExist = *Off;
         For Recno5 = 1 to Gn_Entries;
           If Recno5 <= *Zeros;
             Leave;
           Endif;                                                             //Recno5<=*Zeros
           *IN69 = *On;
           SESRVPGM = Sp_Service_Program;
           SESRVLIB = Sp_Service_Library;
           Clear Er_ExcId;
           POB_ObjectType = '*SRVPGM';
           POB_QLObject = Sp_Service_Program +
               Sp_Service_Library;
           QUsrObjD(DS_OBJD0200: POB_Length: POB_Format:
               POB_QLObject: POB_ObjectType: DS_ErrorCode);
           If Not (Er_ExcId = *Blanks);
             NotExist = *On;
             SETEXT = '* Not Available';
           Else;
             SETEXT = OB_Text;
           Endif;                                                             //Not (Er_ExcId...
           SESHTEXT = SETEXT;
           Write SY0040S5;
           Pt_SPGL0200 = Pt_SPGL0200 + Gn_EntrySize;
         EndFor;                                                               //Do Gn_Entries

         //*************************************************************************
         // Clear the subfile message queue.
         Clear_Message();
         ErrorMessage = *Blanks;
         Send_Message(ErrorMessage);
         SFLCT1 = 1;

         //*************************************************************************
         // Read and process the screen.
         Dow Not *INLR;
           Write MSGSFC1;
           Write SY0040B1;
           If Not *IN67;
             Write SY004002;
           Endif;                                                             //Not *IN67
           Write SY0040C1;
           Read SY0040B1;
           Read SY0040C1;
           Sav_Cur_Page = Cur_Page;
           *IN99 = *Off;
           Clear_Message();
           Clear ErrorMessage;
           If Not (Sav_Cur_Page = 0);
             SFLCT1 = Sav_Cur_Page;
           Endif;                                                             //Not(Cur_Page...
           // Set the cursor location.
           CSRROW = RTNROW;
           CSRCOL = RTNCOL;

           //*************************************************************************
           // Handle Function Keys.
           Select;

             //*************************************************************************
             // Exit program.
           When *IN03;                                                        //F3=Exit
             QUsDltUs(Md_SpaceName: DS_ErrorCode);
             QUsDltUs(Sp_SpaceName: DS_ErrorCode);
             *INLR = *On;
             Leave;

             //*************************************************************************
             // Refresh list.
           When *IN05;                                                        //F5=Refresh
             Clear SACMDLINE;
             Leave;

             //*************************************************************************
             // Add a module to program.
           When *IN06;                                                        //F6=Add Module
             ErrorMessage = 'Function not currently -
                 supported';
             Send_Message(ErrorMessage);
             Iter;

             //*************************************************************************
             // Retrieve a previous command line.
           When *IN09;                                                        //F9=Retrieve
             CSRROW = CmdRow;
             CSRCOL = CmdCol;
             *IN99 = *On;
             SACMDLINE = Retrieve_Command_Line;
             Iter;

             //*************************************************************************
             // Cancel from main screen.
           When *IN12;                                                        //F12=Cancel
             QUsDltUs(Md_SpaceName: DS_ErrorCode);
             QUsDltUs(Sp_SpaceName: DS_ErrorCode);
             *INLR = *On;
             Leave;

             //*************************************************************************
             // Build a binding directory from current module list.
           When *IN13;                                                        //F13=Build Directory
             If Si_Activation_Group_Attr = '*DFTACTGRP';
               ErrorMessage = 'Cannot build binding direct-
                   ory for a DFTACTGRP program.';
               Send_Message(ErrorMessage);
               Iter;
             Endif;                                                           //Si_Activation...
             Cancelled = Build_Directory;
             If Cancelled;
               ErrorMessage = ErrorData;
               Send_Message(ErrorMessage);
               Iter;
             Else;
               ErrorMessage = 'Binding directory built for -
                   program ' + %Trimr(SAPGMLIB) + '/' +
                   %Trimr(SAPROGRAM) + '.';
               Send_Message(ErrorMessage);
               Iter;
             Endif;                                                           //Cancelled

             //*************************************************************************
             // Display program information.
           When *IN14;
             CommandLine = 'DSPSRVPGM SRVPGM(' +
                 %Trimr(SAPGMLIB) + '/' + %Trimr(SAPROGRAM) +
                 ')';
             CommandLength = %Size(CommandLine);
             Callp(E) QCmdExec(CommandLine: CommandLength);
             Iter;

             //*************************************************************************
             // Rebuild all modules in the list.
           When *IN18;                                                        //F18=Rebuild All Mods
             If Si_Activation_Group_Attr = '*DFTACTGRP';
               ErrorMessage = 'Cannot rebuild a default act-
                   ivation group program.  Use option 15.';
               Send_Message(ErrorMessage);
               Iter;
             Endif;                                                           //Si_Activation...
             CommandLength = %Size(CommandLine);
             Recno1 = 1;
             // Read through the entire subfile.
             Chain Recno1 SY0040S1;
             Dow %Found;
               // Find the appropriate command for the create.
               C = 1;
               C = %Lookup(SAMODATTR: ModAtt);
               If Not (C = 0);
      /If Defined(Target_Release)
                 CommandLine = %Trimr(ModCmd(C)) +
                     ' MODULE(' +
                     %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                     ') SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                     %Trimr(SASOURCE) + ') SRCMBR(' +
                     %Trimr(SAMEMBER) + ') ' + 'TGTRLS(' +
                     Si_Release_Created_For + ')';
      /Else
                 CommandLine = %Trimr(ModCmd(C)) +
                     ' MODULE(' +
                     %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                     ') SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                     %Trimr(SASOURCE) + ') SRCMBR(' +
                     %Trimr(SAMEMBER) + ')';
      /Endif
               Else;
                 ErrorMessage = 'Module attribute ' +
                     %Trimr(SAMODATTR) +
                     ' for member ' + %Trimr(SAMEMBER) +
                     ' is not supported.';
                 Send_Message(ErrorMessage);
               Endif;                                                         //%Equal
               // Submit it to batch.
               ErrorMessage = 'The compile of ' +
                   %Trimr(SAMODULE) + ' has been submitted to batch';
               Send_Message(ErrorMessage);
               CommandLine = 'SBMJOB CMD(' +
                   %Trimr(CommandLine) + ') JOB(' +
                   %Trimr(SAMEMBER) + ')';
               QCmdExec(CommandLine: CommandLength);
               Recno1 = Recno1 + 1;
               Chain Recno1 SY0040S1;
             Enddo;                                                           //%Found
             Iter;

             //*************************************************************************
             //* Rebuild program.
           When *IN19;                                                        //F19=Rebuild Program
             If Si_Activation_Group_Attr =
                   '*DFTACTGRP';
               ErrorMessage = 'Cannot rebuild a default -
                   activation group service program.  Use -
                   option 15.';
               Send_Message(ErrorMessage);
               Iter;
             Endif;                                                           //Si_Activation...
             If NotExist;
               ErrorMessage = 'Cannot rebuild.  One or more-
                   modules are missing.';
               Send_Message(ErrorMessage);
               Iter;
             Else;
               CommandLength = %Size(CommandLine);
               CommandLine = '?CRTSRVPGM ?*SRVPGM(' +
                   %Trimr(SAPGMLIB) + '/' + %Trimr(SAPROGRAM) +
                   ') MODULE(';
               // Build the module list.
               Recno1 = 1;
               Chain Recno1 SY0040S1;
               Dow %Found;
                 CommandLine = %Trimr(CommandLine) + ' ' +
                     %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE);
                 Recno1 = Recno1 + 1;
                 Chain Recno1 SY0040S1;
               Enddo;                                                         //%Found
               // Build the service program list.
               CommandLine = %Trimr(CommandLine) +
                   ') BNDSRVPGM(';
               Recno5 = 1;
               Chain Recno5 SY0040S5;
               Dow %Found;
                 CommandLine = %Trimr(CommandLine) + ' ' +
                     %Trimr(SESRVLIB) + '/' + %Trimr(SESRVPGM);
                 Recno5 = Recno5 + 1;
                 Chain Recno5 SY0040S5;
               Enddo;                                                         //%Found
               // Tack on the compile release.
      /If Defined(Target_Release)
               CommandLine = %Trimr(CommandLine) +
                   ') TGTRLS(' +
                   Si_Release_Created_For + ')';
      /Else
               CommandLine = %Trimr(CommandLine) +
                   ')';
      /Endif

               // Attach any command lines entered.
               If Not (SACMDLINE = *Blanks);
                 CommandLine = Attach_Options(CommandLine:
                     SACMDLINE);
               Endif;                                                         //Not (SACMDLINE...

               // Display the command prior to submitting.
               Clear_Message();
               Callp(E) QCmdCheck(CommandLine: CommandLength);
               If %Error;
                 Iter;
               Endif;                                                         //%Error
               ErrorMessage = 'The create of program ' +
                   %Trimr(SAPROGRAM) + ' has been submitted to batch';
               Send_Message(ErrorMessage);
               CommandLine = 'SBMJOB CMD(' +
                   %Trimr(CommandLine) + ') JOB(' +
                   %Trimr(SAPROGRAM) + ')';
               QCmdExec(CommandLine: CommandLength);
               Iter;
             Endif;                                                           //NotExist

             //*************************************************************************
             // Display service programs.
           When *IN20;                                                        //F20=Display Service
             *INLR = Disp_Service_Program;                                    //    Programs
             If *INLR;
               QUsDltUs(Md_SpaceName: DS_ErrorCode);
               QUsDltUs(Sp_SpaceName: DS_ErrorCode);
               Leave;
             Endif;                                                           //*INLR
             Iter;

             //*************************************************************************
             // Print all modules and service programs.
           When *IN21;                                                        //F21=Print List
             Print_List();
             ErrorMessage = 'The list has been printed';
             Send_Message(ErrorMessage);
             Iter;

             //*************************************************************************
             // Display next function key list.
           When *IN24;                                                        //F24=More Keys
             *IN88 = Not *IN88;
             Iter;

             //*************************************************************************
             // Pageup
           When *IN25;                                                        //PageUp
             ErrorMessage =
                 'You have reached the top of the list.';
             Send_Message(ErrorMessage);
             Iter;

             //*************************************************************************
             // Pagedown
           When *IN26;                                                        //PageDown
             ErrorMessage =
                 'You have reached the bottom of the list.';
             Send_Message(ErrorMessage);
             Iter;

           Endsl;

           Readc SY0040S1;

           //*************************************************************************
           // Edit check options.
           No_Selection = *On;
           Dow Not %Eof;
             *IN30 = *Off;                                                    //Reverse Image

             Select;

             When SAOPTION = *Blanks;
               *IN50 = *Off;                                                  //SFLNXTCHG

               //*************************************************************************
               // Edit source member.
             When SAOPTION = '2 ' or SAOPTION = '02' or
                   SAOPTION = ' 2';
               *IN50 = *On;                                                   //SFLNXTCHG
               No_Selection = *Off;
               *IN99 = *Off;

               //*************************************************************************
               // Display source member.
             When SAOPTION = '5 ' or SAOPTION = '05' or
                   SAOPTION = ' 5';
               *IN50 = *On;                                                   //SFLNXTCHG
               No_Selection = *Off;
               *IN99 = *Off;

               //*************************************************************************
               // Display module details.
             When SAOPTION = '8 ' or SAOPTION = '08' or
                   SAOPTION = ' 8';
               *IN50 = *On;                                                   //SFLNXTCHG
               No_Selection = *Off;
               *IN99 = *Off;

               //*************************************************************************
               // Rebuild module.
             When SAOPTION = '15';
               *IN50 = *On;                                                   //SFLNXTCHG
               No_Selection = *Off;
               *IN99 = *Off;

               //*************************************************************************
               // Update program with current module.
             When SAOPTION = '16';
               *IN50 = *On;                                                   //SFLNXTCHG
               No_Selection = *Off;
               *IN99 = *Off;

               //*************************************************************************
               // Otherwise, an error.
             Other;
               *IN30 = *On;                                                   //Reverse Image
               ErrorMessage =
                   'Specified option number is not allowed.';
               Send_Message(ErrorMessage);
               *IN50 = *On;                                                   //SFLNXTCHG
               No_Selection = *Off;
               *IN99 = *Off;
               SFLCT1 = RECNO1;
             Endsl;
             Update SY0040S1;

             Readc SY0040S1;
           Enddo;                                                             //Not %Eof

           //*************************************************************************
           // Handle if a command line entered and no selection made.
           If No_Selection and Not (SACMDLINE = *Blanks);
             CommandLine = SACMDLINE;
             CommandLength = %Size(CommandLine);
             // Either edit check the command line or, if prompted, prompt.
             If *IN04;                                                        //If prompted
               CP_PromptAct = '1';
               Callp(E) QCapCommand(CommandLine: CommandLength:
                   DS_CPOP0100: %Size(DS_CPOP0100): 'CPOP0100':
                   CommandLine: CommandLength: Bin04:
                   DS_DummyError);
             Else;
               Callp(E) QCmdCheck(CommandLine: CommandLength);
             Endif;                                                           //*IN04
             If %Error;
               Add_Command_Line(CommandLine);                                 //If error, retain.
               *IN99 = *On;                                                   //Position to Line
               CSRROW = CmdRow;
               CSRCOL = CmdCol;
               Iter;
             Endif;                                                           //%Error
             Add_Command_Line(CommandLine);                                   //Save command
             *IN99 = *On;                                                     //Position to Line
             CSRROW = CmdRow;
             CSRCOL = CmdCol;
             // Then run it.
             Callp(E) QCmdExec(CommandLine: CommandLength);
             If %Error;
               Iter;
             Endif;                                                           //%Error
             Clear SACMDLINE;
             Iter;
           Endif;                                                             //No_Selection...

           //*************************************************************************
           // If not selection made and F4=Prompt hasn't been pressed, assume exit.
           If No_Selection and Not *IN04;
             *INLR = *On;
             QUsDltUs(Md_SpaceName: DS_ErrorCode);
             QUsDltUs(Sp_SpaceName: DS_ErrorCode);
             Leave;
           Endif;                                                             //No_Selection...

           //*************************************************************************
           // If no selection was made and prompting was pressed,
           // display error message.
           If No_Selection and *IN04;
             ErrorMessage =
                 'Prompting is not allowed at this time.';
             Send_Message(ErrorMessage);
             Iter;
           Endif;                                                             //No_Selection...

           If Not (ErrorMessage = *Blanks);
             Iter;
           Endif;                                                             //Not (ErrorMessage...

           //*************************************************************************
           // Handle options.
           Readc SY0040S1;
           Dow Not %Eof;

             Select;

               //*************************************************************************
               // Edit module source with SEU.
             When SAOPTION = '2 ' or SAOPTION = '02' or
                   SAOPTION = ' 2';
               SFLCT1 = RECNO1;
               CommandLength = %Size(CommandLine);
               If *IN04;                                                      //F4=Prompt
                 CommandLine = '?STRSEU ?*SRCFILE(' +
                     %Trimr(SASRCLIB) + '/' + %Trimr(SASOURCE) +
                     ') ?*SRCMBR(' + %Trimr(SAMEMBER) +
                     ') ?*TYPE(' + %Trimr(SAMODATTR) +
                     ') ?*OPTION(2)';
               Else;
                 CommandLine = 'STRSEU SRCFILE(' +
                     %Trimr(SASRCLIB) + '/' + %Trimr(SASOURCE) +
                     ') SRCMBR(' + %Trimr(SAMEMBER) +
                     ') TYPE(' + %Trimr(SAMODATTR) + ') OPTION(2)';
               Endif;                                                         //*IN04

               // Attach any command lines entered.
               If Not (SACMDLINE = *Blanks);
                 CommandLine = Attach_Options(CommandLine:
                     SACMDLINE);
               Endif;                                                         //Not (SACMDLINE...

               Callp(E) QCmdCheck(CommandLine: CommandLength);
               If %Error;
                 *IN50 = *On;                                                 //SFLNXTCHG
                 Update SY0040S1;
                 Leave;
               Endif;                                                         //%Error
               Callp(E) QCmdExec(CommandLine: CommandLength);
               If %Error;
                 *IN50 = *On;                                                 //SFLNXTCHG
                 Update SY0040S1;
                 Leave;
               Endif;                                                         //%Error
               Clear SAOPTION;
               Update SY0040S1;

               //*************************************************************************
               // Display module source with SEU.
             When SAOPTION = '5 ' or SAOPTION = '05' or
                   SAOPTION = ' 5';
               SFLCT1 = RECNO1;
               CommandLength = %Size(CommandLine);
               If *IN04;                                                      //F4=Prompt
                 CommandLine = '?STRSEU ?*SRCFILE(' +
                     %Trimr(SASRCLIB) + '/' + %Trimr(SASOURCE) +
                     ') ?*SRCMBR(' + %Trimr(SAMEMBER) +
                     ') ?*TYPE(' + %Trimr(SAMODATTR) +
                     ') ?*OPTION(5)';
               Else;
                 CommandLine = 'STRSEU SRCFILE(' +
                     %Trimr(SASRCLIB) + '/' + %Trimr(SASOURCE) +
                     ') SRCMBR(' + %Trimr(SAMEMBER) +
                     ') TYPE(' + %Trimr(SAMODATTR) + ') OPTION(5)';
               Endif;                                                         //*IN04

               // Attach any command lines entered.
               If Not (SACMDLINE = *Blanks);
                 CommandLine = Attach_Options(CommandLine:
                     SACMDLINE);
               Endif;                                                         //Not (SACMDLINE...

               Callp(E) QCmdCheck(CommandLine: CommandLength);
               If %Error;
                 *IN50 = *On;                                                 //SFLNXTCHG
                 Update SY0040S1;
                 Leave;
               Endif;                                                         //%Error
               Callp(E) QCmdExec(CommandLine: CommandLength);
               If %Error;
                 *IN50 = *On;                                                 //SFLNXTCHG
                 Update SY0040S1;
                 Leave;
               Endif;                                                         //%Error
               Clear SAOPTION;
               Update SY0040S1;

               //*************************************************************************
               // Display module information.
             When SAOPTION = '8 ' or SAOPTION = '08' or
                   SAOPTION = ' 8';
               SFLCT1 = RECNO1;
               If *IN04;                                                      //Prompted?
                 CommandLine = '?DSPMOD ?*MODULE(' +
                     %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                     ')';
               Else;                                                          //Not Prompted
                 CommandLine = 'DSPMOD MODULE(' +
                     %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                     ')';
               Endif;                                                         //*IN04

               // Attach any command lines entered.
               If Not (SACMDLINE = *Blanks);
                 CommandLine = Attach_Options(CommandLine:
                     SACMDLINE);
               Endif;                                                         //Not (SACMDLINE...

               CommandLength = %Size(CommandLine);
               Callp(E) QCmdCheck(CommandLine: CommandLength);
               If %Error;
                 *IN50 = *On;                                                 //SFLNXTCHG
                 Update SY0040S1;
                 Leave;
               Endif;                                                         //%Error
               Callp(E) QCmdExec(CommandLine: CommandLength);
               If %Error;
                 *IN50 = *On;                                                 //SFLNXTCHG
                 Update SY0040S1;
                 Leave;
               Endif;                                                         //%Error
               Clear SAOPTION;
               Update SY0040S1;

               //*************************************************************************
               // Rebuild module.
             When SAOPTION = '15';
               SFLCT1 = RECNO1;
               CommandLength = %Size(CommandLine);
               // If prompted
               If *IN04;                                                      //F4=Prompt
                 If Not (Si_Activation_Group_Attr =
                       '*DFTACTGRP');
                   // Find the appropriate command for the create.
                   C = 1;
                   C = %Lookup(SAMODATTR: ModAtt);
                   If Not (C = 0);
      /If Defined(Target_Release)
                     CommandLine = '?' + %Trimr(ModCmd(C)) +
                         ' ?*MODULE(' +
                         %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                         ') ?*SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                         %Trimr(SASOURCE) + ') ?*SRCMBR(' +
                         %Trimr(SAMEMBER) + ') ' + 'TGTRLS(' +
                         Si_Release_Created_For + ')';
      /Else
                     CommandLine = '?' + %Trimr(ModCmd(C)) +
                         ' ?*MODULE(' +
                         %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                         ') ?*SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                         %Trimr(SASOURCE) + ') ?*SRCMBR(' +
                         %Trimr(SAMEMBER) + ')';
      /Endif
                   Else;
                     ErrorMessage = 'Module attribute ' +
                         %Trimr(SAMODATTR) +
                         ' for member ' + %Trimr(SAMEMBER) +
                         ' is not supported.';
                     Send_Message(ErrorMessage);
                   Endif;                                                     //%Equal
                 Else;
                   // Find the appropriate command for the create.
                   C = 1;
                   C = %Lookup(SAMODATTR: ModAtt);
                   If Not (C = 0);
      /If Defined(Target_Release)
                     CommandLine = '?' + %Trimr(BndCmd(C)) +
                         ' ?*PGM(' +
                         %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                         ') ?*SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                         %Trimr(SASOURCE) + ') ?*SRCMBR(' +
                         %Trimr(SAMEMBER) + ') ' + 'TGTRLS(' +
                         Si_Release_Created_For + ')';
      /Else
                     CommandLine = '?' + %Trimr(BndCmd(C)) +
                         ' ?*PGM(' +
                         %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                         ') ?*SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                         %Trimr(SASOURCE) + ') ?*SRCMBR(' +
                         %Trimr(SAMEMBER) + ')';
      /Endif
                   Else;
                     ErrorMessage = 'Module attribute ' +
                         %Trimr(SAMODATTR) +
                         ' for member ' + %Trimr(SAMEMBER) +
                         ' is not supported.';
                     Send_Message(ErrorMessage);
                   Endif;                                                     //%Equal
                 Endif;                                                       //Not (Si_Activa...

                 // Attach any command lines entered.
                 If Not (SACMDLINE = *Blanks);
                   CommandLine = Attach_Options(CommandLine:
                       SACMDLINE);
                 Endif;                                                       //Not (SACMDLINE...

                 // Edit check the command line.
                 Callp(E) QCmdCheck(CommandLine: CommandLength);
                 If %Error;
                   *IN50 = *On;                                               //SFLNXTCHG
                   Update SY0040S1;
                   Leave;
                 Endif;                                                       //%Error
                 // Submit the compile to batch.
                 ErrorMessage = 'The compile of ' +
                     %Trimr(SAMEMBER) + ' has been submitted to batch';
                 Send_Message(ErrorMessage);
                 CommandLine = 'SBMJOB CMD(' +
                     %Trimr(CommandLine) + ') JOB(' +
                     %Trimr(SAMEMBER) + ')';
                 QCmdExec(CommandLine: CommandLength);
               Else;
                 // If unprompted
                 If Not (Si_Activation_Group_Attr =
                       '*DFTACTGRP');
                   // Find the appropriate command for the create.
                   C = 1;
                   C = %Lookup(SAMODATTR: ModAtt);
                   If Not (C = 0);
      /If Defined(Target_Release)
                     CommandLine = %Trimr(ModCmd(C)) +
                         ' MODULE(' +
                         %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                         ') SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                         %Trimr(SASOURCE) + ') SRCMBR(' +
                         %Trimr(SAMEMBER) + ') ' + 'TGTRLS(' +
                         Si_Release_Created_For + ')';
      /Else
                     CommandLine = %Trimr(ModCmd(C)) +
                         ' MODULE(' +
                         %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                         ') SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                         %Trimr(SASOURCE) + ') SRCMBR(' +
                         %Trimr(SAMEMBER) + ')';
      /Endif
                   Else;
                     ErrorMessage = 'Module attribute ' +
                         %Trimr(SAMODATTR) +
                         ' for member ' + %Trimr(SAMEMBER) +
                         ' is not supported.';
                     Send_Message(ErrorMessage);
                   Endif;                                                     //%Equal
                 Else;
                   // Find the appropriate command for the create.
                   C = 1;
                   C = %Lookup(SAMODATTR: ModAtt);
                   If Not (C = 0);
      /If Defined(Target_Release)
                     CommandLine = %Trimr(BndCmd(C)) + ' PGM(' +
                         %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                         ') SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                         %Trimr(SASOURCE) + ') SRCMBR(' +
                         %Trimr(SAMEMBER) + ') ' + 'TGTRLS(' +
                         Si_Release_Created_For + ')';
      /Else
                     CommandLine = %Trimr(BndCmd(C)) + ' PGM(' +
                         %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                         ') SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                         %Trimr(SASOURCE) + ') SRCMBR(' +
                         %Trimr(SAMEMBER) + ')';
      /Endif
                   Else;
                     ErrorMessage = 'Module attribute ' +
                         %Trimr(SAMODATTR) +
                         ' for member ' + %Trimr(SAMEMBER) +
                         ' is not supported.';
                     Send_Message(ErrorMessage);
                   Endif;                                                     //%Equal
                 Endif;                                                       //Not (Si_Activa...

                 // Attach any command lines entered.
                 If Not (SACMDLINE = *Blanks);
                   CommandLine = Attach_Options(CommandLine:
                       SACMDLINE);
                 Endif;                                                       //Not (SACMDLINE...

                 // Edit check the command line.
                 Callp(E) QCmdCheck(CommandLine: CommandLength);
                 If %Error;
                   *IN50 = *On;                                               //SFLNXTCHG
                   Update SY0040S1;
                   Leave;
                 Endif;                                                       //%Error

                 // Submit the compile to batch.
                 ErrorMessage = 'The compile of ' +
                     %Trimr(SAMEMBER) + ' has been submitted to batch';
                 Send_Message(ErrorMessage);
                 CommandLine = 'SBMJOB CMD(' +
                     %Trimr(CommandLine) +
                     ') JOB(' + %Trimr(SAMEMBER) + ')';
                 Callp(E) QCmdExec(CommandLine: CommandLength);
                 If %Error;
                   *IN50 = *On;                                               //SFLNXTCHG
                   Update SY0040S1;
                   Leave;
                 Endif;                                                       //%Error
               Endif;                                                         //*IN04
               Clear SAOPTION;
               Update SY0040S1;

               //*************************************************************************
               // Update Program with Module.
             When SAOPTION = '16';
               SFLCT1 = RECNO1;
               CommandLength = %Size(CommandLine);
               If Si_Allow_Update = 'Y';
                 // If prompted.
                 If *IN04;                                                    //F4=Prompt
                   CommandLine = '?UPDSRVPGM ?*SRVPGM(' +
                       %Trimr(SAPGMLIB) + '/' + %Trimr(SAPROGRAM)
                       + ') ?*MODULE(' + %Trimr(SALIBRARY) +
                       '/' + %Trimr(SAMODULE) + ')';
                 Else;
                   // Non-Prompted.
                   CommandLine = 'UPDSRVPGM SRVPGM(' +
                       %Trimr(SAPGMLIB) + '/' + %Trimr(SAPROGRAM)
                       + ') MODULE(' + %Trimr(SALIBRARY) +
                       '/' + %Trimr(SAMODULE) + ')';
                 Endif;                                                       //*IN04

                 // Attach any command lines entered.
                 If Not (SACMDLINE = *Blanks);
                   CommandLine = Attach_Options(CommandLine:
                       SACMDLINE);
                 Endif;                                                       //Not (SACMDLINE...

                 // Edit check command line.
                 Callp(E) QCmdCheck(CommandLine: CommandLength);
                 If %Error;
                   *IN50 = *On;                                               //SFLNXTCHG
                   Update SY0040S1;
                   Leave;
                 Endif;                                                       //%Error

                 // Submit the job to batch.
                 ErrorMessage = 'The update of ' +
                     %Trimr(SAPROGRAM) + ' has been submitted to batch';
                 Send_Message(ErrorMessage);
                 CommandLine = 'SBMJOB CMD(' +
                     %Trimr(CommandLine) +
                     ') JOB(' + %Trimr(SAMEMBER) + ')';
                 Callp(E) QCmdExec(CommandLine: CommandLength);
                 If %Error;
                   *IN50 = *On;                                               //SFLNXTCHG
                   Update SY0040S1;
                   Leave;
                 Endif;                                                       //%Error
               Else;
                 // Not updateable error message.
                 ErrorMessage = 'This program does not -
                     allow module updates.';
                 Send_Message(ErrorMessage);
                 *IN50 = *On;
                 Update SY0040S1;
                 Leave;
               Endif;                                                         //Si_Activation...
               Clear SAOPTION;
               Update SY0040S1;

             Endsl;
             SFLCT1 = Recno1;

             Readc SY0040S1;
           Enddo;                                                             //Not %Eof

           //*************************************************************************
           If Not %Error;
             Clear SACMDLINE;
             If ErrorMessage = *Blanks;
               ErrorMessage = *Blanks;
               Send_Message(ErrorMessage);
             Endif;                                                           //ErrorMessage...
           Endif;                                                             //Not %Error

         Enddo;                                                               //Not *INLR

       Enddo;                                                                 //Not *INLR
      /Eject
       //*************************************************************************
       // Exception_Err - Subroutine to pass error up and quit.                  *
       //*************************************************************************
       Begsr Exception_Err;
         PSM_MsgId = ER_ExcId;
         PSM_Length = %Size(ER_Data);
         PSM_MsgType = '*ESCAPE';
         PSM_CallStack = 3;
         Send_Message(ER_Data);
         *INLR = *On;
       Endsr;                                                                 //Exception_Err

      /Eject
      /End-Free
       //*************************************************************************
       // Send_Message - Send message to program message queue.                  *
       //*************************************************************************
     P Send_Message    B

     D Send_Message    PI
     D   ErrorMessage             32767    Options(*VarSize)

      /Free
       Send_PgmMessage(PSM_MsgID: PSM_QLMsgFile:
           ErrorMessage: PSM_Length: PSM_MsgType:
           PSM_CallQ: PSM_CallStack: PSM_MsgKey:
           DS_ErrorCode);

      /End-Free
     P Send_Message    E
      /Eject
      //*************************************************************************
      // Clear_Message - Clear all messages from program message queue.         *
      //*************************************************************************
     P Clear_Message   B

     D Clear_Message   PI

      /Free
       Remove_PgmMessage(PRM_CallQ: PRM_CallStack:
           PRM_MsgKey: PRM_MsgToRemove: DS_ErrorCode);

      /End-Free
     P Clear_Message   E

      /Eject
      //*************************************************************************
      // Print_List - Print the list to the printer.                            *
      //*************************************************************************
     P Print_List      B

     D Print_List      PI

     D CommandLine     S            256
     D CommandLength   S             15P 5

      /Free
       CommandLine = 'OVRPRTF FILE(SY0040P) -
           USRDTA(' + %Trimr(SAPROGRAM) + ')';
       CommandLength = %Size(CommandLine);
       QCmdExec(CommandLine: CommandLength);
       Open SY0040P;
       // Print module information.
       Recno1 = 1;
       Write SY0040H;
       Write SY0040H1;
       Chain Recno1 SY0040S1;
       Dow %Found;
         If OverFlow;
           Write SY0040H;
           Write SY0040H1;
           Overflow = *Off;
         Endif;                                                               //OverFlow
         Write(E) SY0040D;
         If %Error;                                                           //If End of File
           OverFlow = *On;                                                    //turn OverFlow On.
         Endif;                                                               //%Error
         Recno1 = Recno1 + 1;
         Chain Recno1 SY0040S1;
       Enddo;                                                                 //%Found

       // Print service program information.
       Recno5 = 1;
       If Not OverFlow;
         Write SY0040H2;
       Endif;                                                                 //Not *IN90
       Chain Recno5 SY0040S5;
       Dow %Found;
         If OverFlow;
           Write SY0040H;
           Write SY0040H2;
           OverFlow = *Off;
         Endif;                                                               //OverFlow
         Write(E) SY0040D2;
         If %Error;
           OverFlow = *On;
         Endif;                                                               //%Error
         Recno5 = Recno5 + 1;
         Chain Recno5 SY0040S5;
       Enddo;                                                                 //%Found
       Close SY0040P;
       CommandLine = 'DLTOVR FILE(SY0040P)';
       CommandLength = %Size(CommandLine);
       QCmdExec(CommandLine: CommandLength);

      /End-Free
     P Print_List      E

      /Eject
      //*************************************************************************
      // Build_Directory - Build a binding directory.                           *
      //*************************************************************************
     P Build_Directory...
     P                 B

     D Build_Directory...
     D                 PI              N

      // First see if the binding directory is there.
      /Free
       POB_QLObject = SAPROGRAM + SAPGMLIB;
       Clear Er_ExcId;
       POB_ObjectType = '*BNDDIR';
       QUsrObjD(DS_OBJD0200: POB_Length: POB_Format:
           POB_QLObject: POB_ObjectType: DS_ErrorCode);
       If Er_ExcId = *Blanks;
         SBOBJECT = SAPROGRAM;
         SBLIBRARY = SAPGMLIB;
         SBOBJTYPE = '*BNDDIR';
         SBCONFIRM = 'N';
         Exfmt SY004004;
         If *IN12 or SBCONFIRM = 'N';
           Return *On;
         Endif;                                                               //*IN12
         CommandLine = 'DLTBNDDIR BNDDIR(' +
             %Trimr(SAPGMLIB) + '/' + %Trimr(SAPROGRAM) +
             ')';
         CommandLength = %Size(CommandLine);
         Callp(E) QCmdExec(CommandLine: CommandLength);
         If %Error;
           Return *On;
         Endif;                                                               //%Error
       Endif;                                                                 //Not (Er_ExcId...

       // Now, create the binding directory.
       CommandLine = 'CRTBNDDIR BNDDIR(' +
           %Trimr(SAPGMLIB) + '/' + %Trimr(SAPROGRAM) +
           ') TEXT(' + Tick + 'Binding directory for-
           program ' + %Trimr(SAPROGRAM) + '.' + Tick +
           ')';
       CommandLength = %Size(CommandLine);
       Callp(E) QCmdExec(CommandLine: CommandLength);
       If %Error;
         Return *On;
       Endif;                                                                 //%Error

       // Now add all of the binding directory entries.
       Recno1 = 1;
       Chain Recno1 SY0040S1;
       Dow %Found;
         CommandLine = 'ADDBNDDIRE BNDDIR(' +
             %Trimr(SAPGMLIB) + '/' + %Trimr(SAPROGRAM) +
             ') OBJ((' + %Trimr(SALIBRARY) + '/' +
             %Trimr(SAMODULE) + ' *MODULE))';
         CommandLength = %Size(CommandLine);
         Callp(E) QCmdExec(CommandLine: CommandLength);
         If %Error;
           Return *On;
         Endif;
         Recno1 = Recno1 + 1;
         Chain Recno1 SY0040S1;
       Enddo;                                                                 //%Found
       Return *Off;

      /End-Free
     P Build_Directory...
     P                 E

      /Eject
      //*************************************************************************
      // Disp_Service_Program - Display all service programs.                   *
      //*************************************************************************
     P Disp_Service_Program...
     P                 B

     D Disp_Service_Program...
     D                 PI              N

      // Work fields.
     D Exit_Proc       S               N
     D No_Selection    S               N

      // Display screen and process options and function keys.
      /Free
       Exit_Proc = *Off;
       SFLCT5 = 1;
       Dow Not Exit_Proc;
         Write MSGSFC1;
         Write SY0040B5;
         If Not *IN69;
           Write SY004006;
         Endif;                                                               //Not *IN67
         Exfmt SY0040C5;
         Clear_Message();
         Clear ErrorMessage;
         SFLCT5 = Cur_Page;

         //*************************************************************************
         // Handle function keys.
         Select;
           //*************************************************************************
         When *IN03;                                                          //F3=Exit
           Exit_Proc = *On;
           Return Exit_Proc;

           //*************************************************************************
         When *IN12;                                                          //F12=Cancel
           Exit_Proc = *Off;
           Return Exit_Proc;

           //*************************************************************************
         When *IN25;                                                          //PageUp
           ErrorMessage =
               'You have reached the top of the list.';
           Send_Message(ErrorMessage);
           Iter;

           //*************************************************************************
         When *IN26;                                                          //PageDown
           ErrorMessage =
               'You have reached the bottom of the list.';
           Send_Message(ErrorMessage);
           Iter;

         Endsl;

         Readc SY0040S5;
         If %Eof and Not *IN04;
           Return *Off;
         Endif;                                                               //%Eof

         //*************************************************************************
         // Edit check options.
         No_Selection = *On;
         Clear SFLCT5;
         Dow Not %Eof;
           *IN30 = *Off;                                                      //Reverse Image

           //*************************************************************************
           Select;

             //*************************************************************************
           When SEOPTION = *Blanks;
             *IN51 = *Off;

             //*************************************************************************
           When SEOPTION = '5';
             *IN51 = *On;
             No_Selection = *Off;
             If SFLCT5 = *Zeros;
               SFLCT5 = RECNO5;
             Endif;                                                           //SFLCT5 = *Zeros

             //*************************************************************************
           Other;
             *IN30 = *On;                                                     //Reverse Image
             ErrorMessage =
                 'Specified option number is not allowed.';
             Send_Message(ErrorMessage);
             *IN51 = *On;
             No_Selection = *Off;
             If SFLCT5 = *Zeros;
               SFLCT5 = RECNO5;
             Endif;                                                           //SFLCT1 = *Zeros
           Endsl;
           Update SY0040S5;

           Readc SY0040S5;
         Enddo;                                                               //Not %Eof

         //*************************************************************************
         If No_Selection and Not *IN04;
           Return *Off;
         Endif;                                                               //No_Selection...

         //*************************************************************************
         If No_Selection and *IN04;
           If SFLCT5 = *Zeros;
             If Cur_Page = *Zeros;
               SFLCT5 = 1;
             Else;
               SFLCT5 = Cur_Page;
             Endif;                                                           //Cur_Page = 0
           Endif;                                                             //SFLCT5 = *Zeros
           ErrorMessage =
               'Prompting is not allowed at this time.';
           Send_Message(ErrorMessage);
           Iter;
         Endif;                                                               //Not_Selection...

         If Not (ErrorMessage = *Blanks);
           Iter;
         Endif;                                                               //Not (ErrorMessage...

         //*************************************************************************
         // Handle options.
         Readc SY0040S5;
         Dow Not %Eof;

           Select;

             //*************************************************************************
             // Display service program detail.
           When SEOPTION = '5';
             CommandLength = %Size(CommandLine);
             If *IN04;                                                        //F4=Prompt
               CommandLine = '?DSPSRVPGM ?*SRVPGM(' +
                   %Trimr(SESRVLIB) + '/' + %Trimr(SESRVPGM) +
                   ')';
               Callp(E) QCmdExec(CommandLine: CommandLength);
               If %Error;
                 *IN51 = *On;
                 Update SY0040S5;
                 Leave;
               Endif;                                                         //%Error
             Else;
               CommandLine = 'DSPSRVPGM SRVPGM(' +
                   %Trimr(SESRVLIB) + '/' + %Trimr(SESRVPGM) +
                   ')';
               Callp(E) QCmdExec(CommandLine: CommandLength);
               If %Error;
                 *IN51 = *On;
                 Update SY0040S5;
                 Leave;
               Endif;                                                         //%Error
             Endif;                                                           //*IN04
             Clear SEOPTION;
             Update SY0040S5;
           Endsl;

           SFLCT5 = Recno5;

           Readc SY0040S5;
         Enddo;                                                               //Not %Eof

         //*************************************************************************
         If ErrorMessage = *Blanks and Not %Error;
           ErrorMessage = *Blanks;
           Send_Message(ErrorMessage);
         Endif;                                                               //ErrorMessage...

         //*************************************************************************
         // If a selection was made, redisplay screen.
         If Not No_Selection;
           Iter;
         Endif;                                                               //No_Select = *Off

         Return Exit_Proc;
       Enddo;                                                                 //Not (Exit_Proc ...

      /End-Free
     P Disp_Service_Program...
     P                 E

      /Eject
      //*************************************************************************
      // CvtToHex - Convert from Character to Hex.                              *
      //            Taken from the IBM ILE RPG Programmer's Guide.              *
      //*************************************************************************
     P CvtToHex        B

     D  CvtToHex       PI                  OpDesc
     D   InString                 16383    Const Options(*VarSize)
     D   HexString                32766    Options(*VarSize)

      // Procedure prototype for CEEDOD (Retrieve operational descriptors)
     D CEEDOD          PR
     D  ParmNum                      10I 0 Const
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               12A   Options(*Omit)

      // Parameters for CEEDOD
     D DescType        S             10I 0
     D DataType        S             10I 0
     D DescInfo1       S             10I 0
     D DescInfo2       S             10I 0
     D InLen           S             10I 0
     D HexLen          S             10I 0
     D X1              S              5P 0
     D X2              S              5P 0

      // Work fields, etc.
     D HexDigits       C                   Const('0123456789ABCDEF')
     D IntDS           DS
     D   IntNum                       5I 0 Inz(0)
     D   IntChar                      1    Overlay(IntNum:2)
     D HexDS           DS
     D   HexC1                        1
     D   HexC2                        1
     D InChar          S              1
     D Pos             S              5P 0
     D HexPos          S              5P 0

      // Call CEEDOD to get the types and legnths of the input parameters.
      /Free
       CEEDOD(1: DescType: DataType: DescInfo1:
           DescInfo2: InLen: *Omit);
       CEEDOD(2: DescType: DataType: DescInfo1:
           DescInfo2: HexLen: *Omit);

       // Determine the length to handle.
       If InLen > HexLen/2;
         InLen = HexLen/2;
       Endif;                                                                 //InLen>HexLen/2

       // For each character in the input string, convert to a two character
       // hex byte.
       HexPos = 1;
      /End-Free
     C                   Do        InLen         Pos
      /Free
         InChar = %Subst(InString: Pos: 1);
         Exsr GetHex;
         %Subst(HexString: HexPos: 2) = HexDS;
         HexPos = HexPos + 2;
       Enddo;                                                                 //Do InLen

       // Ok, we're done.  Return
       Return;

       //*************************************************************************
       // GetHex - Convert InChar to HexDS.
       //*************************************************************************
       Begsr GetHex;
         IntChar = InChar;
      /End-Free
     C     IntNum        Div       16            X1
     C                   Mvr                     X2
      /Free
         HexC1 = %Subst(HexDigits: X1+1: 1);
         HexC2 = %Subst(HexDigits: X2+1: 1);
       Endsr;                                                                 //GetHex

      /End-Free
     PCvtToHex         E
      /Eject
      //*************************************************************************
      // Add_Command_Line - Add a command line to the history array.            *
      //*************************************************************************
     P Add_Command_Line...
     P                 B

     D Add_Command_Line...
     D                 PI                  OpDesc
     D   CommandLine              32702    Options(*VarSize)

      // Procedure prototype for CEEDOD (Retrieve operational descriptors)
     D CEEDOD          PR
     D  ParmNum                      10I 0 Const
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               12A   Options(*Omit)

      // Parameters for CEEDOD
     D DescType        S             10I 0
     D DataType        S             10I 0
     D DescInfo1       S             10I 0
     D DescInfo2       S             10I 0
     D InLen           S             10I 0                                      Command Length

      // Work fields
     D CommandLength   S              5U 0                                      Command Length

      // Call CEEDOD to get the types and legnths of the input parameters.
      /Free
       CEEDOD(1: DescType: DataType: DescInfo1:
           DescInfo2: InLen: *Omit);

       // Check for the ? in position 1.
       If %Subst(CommandLine:1:1) = '?';
         CommandLength = %Len(%Trimr(%Subst(
             CommandLine:2)));
         CommandLine = %Subst(CommandLine:2:
             CommandLength);
       Endif;                                                                 //%Subst(Command...

       // Send the message to the call stack message queue.
       RSM_Length = %Len(%Trimr(CommandLine));
       Send_PgmMessage(RSM_MsgID: RSM_QLMsgFile:
           CommandLine: RSM_Length: RSM_MsgType:
           RSM_CallQ: RSM_CallStack: RSM_MsgKey:
           DS_ErrorCode);

       // Now pop the message back off.
       Callp(E) Receive_PgmMessage(DS_RCVM0100:
           %Len(DS_RCVM0100): 'RCVM0100':
           '*EXT': 0: '*RQS': RSM_MsgKey:
           0: '*OLD': DS_ErrorCode);

      /End-Free
     P Add_Command_Line...
     P                 E
      /Eject
      //*************************************************************************
      // Retrieve_Command_Line - Retrieve previous command.                     *
      //*************************************************************************
     P Retrieve_Command_Line...
     P                 B

     D Retrieve_Command_Line...
     D                 PI                  Like(CommandLine)

     D Current_Msg     S              4    Static                               Current Message
     D Hex_00          C                   X'00000000'

      /Free
       If Current_Msg = *Blanks or
             SACMDLINE = *Blanks;
         Current_Msg = Hex_00;
       Endif;                                                                 //Current_Msg...

       Clear DS_RTVQ0100;
       Callp(E) Receive_RqsMessage(DS_RTVQ0100:
           %Len(DS_RTVQ0100): 'RTVQ0100':
           '*PRV': Current_Msg: DS_ErrorCode);
       If RM_BytesAva = 0;
         Current_Msg = Hex_00;
         Callp(E) Receive_RqsMessage(DS_RTVQ0100:
             %Len(DS_RTVQ0100): 'RTVQ0100':
             '*PRV': Current_Msg: DS_ErrorCode);
         If RM_BytesAva = 0;
           Return *Blanks;
         Else;
           Current_Msg = RM_MsgKey;
           Return RM_Text;
         Endif;                                                               //RM_BytesAva...
       Else;
         Current_Msg = RM_MsgKey;
         Return RM_Text;
       Endif;                                                                 //RM_BytesAva...

      /End-Free
     P Retrieve_Command_Line...
     P                 E
      /Eject
      //*************************************************************************
      // Attach_Options - Attach options to end of command line for prompted    *
      //                  options.                                              *
      //*************************************************************************
     P Attach_Options...
     P                 B

     D Attach_Options...
     D                 PI         32702    OpDesc
     D  CommandLine               32702    Options(*VarSize)
     D  Options                   32702    Options(*VarSize)

      // Procedure prototype for CEEDOD (Retrieve operational descriptors)
     D CEEDOD          PR
     D  ParmNum                      10I 0 Const
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               12A   Options(*Omit)

      // Parameters for CEEDOD
     D DescType        S             10I 0
     D DataType        S             10I 0
     D DescInfo1       S             10I 0
     D DescInfo2       S             10I 0
     D InLen1          S             10I 0                                      Command Length
     D InLen2          S             10I 0                                      Command Length

      // Call CEEDOD to get the types and legnths of the input parameters.
      /Free
       CEEDOD(1: DescType: DataType: DescInfo1:
           DescInfo2: InLen1: *Omit);
       CEEDOD(2: DescType: DataType: DescInfo1:
           DescInfo2: InLen2: *Omit);

       Return %Trimr(%Subst(CommandLine: 1: InLen1)) + ' '
           + %Trim(%Subst(Options: 1: InLen2));

      /End-Free
     P Attach_Options...
     P                 E
      /Eject
** CtData ModAtt
RPGLE
CLLE
CBLLE
CLE
** CtData ModCmd
CRTRPGMOD
CRTCLMOD
CRTCBLMOD
CRTCMOD
** CtData BndCmd
CRTBNDRPG
CRTBNDCL
CRTBNDCBL
CRTBNDC

Display File Source-SY0040FM

     A*%%TS  SD  20010430  153157  LANHAMJ     REL-V4R4M0  5769-PW1
     A*%%EC
     A                                      DSPSIZ(24 80 *DS3)
     A                                      PRINT
     A          R SY0040S1                  SFL
     A*%%TS  SD  20010430  153157  LANHAMJ     REL-V4R4M0  5769-PW1
     A  50                                  SFLNXTCHG
     A            SAMODATTR     10A  H
     A            SACREATETM    10A  H
     A            SASRCCHGDT    10A  H
     A            SASRCCHGTM    10A  H
     A            SAMODTEXT     50A  H
     A            SAOPTION       2A  B 12  2
     A  30                                  DSPATR(RI)
     A            SAMODULE      10A  O 12  7
     A            SALIBRARY     10A  O 12 19
     A            SASOURCE      10A  O 12 31
     A            SASRCLIB      10A  O 12 43
     A            SAMEMBER      10A  O 12 55
     A            SACREATEDT    10A  O 12 67
     A          R SY0040C1                  SFLCTL(SY0040S1)
     A*%%TS  SD  20010430  153157  LANHAMJ     REL-V4R4M0  5769-PW1
     A                                      CA03(03 'Exit')
     A                                      CA12(12 'Cancel')
     A                                      PAGEUP(25 'Page Up')
     A                                      PAGEDOWN(26 'Page Down')
     A                                      CA13(13 'Build Binding Directory')
     A                                      CA18(18 'Recreate All')
     A                                      CA19(19 'Recreate Program')
     A                                      CA21(21 'Print List')
     A                                      CF04(04 'Prompt')
     A                                      CA05(05 'Refresh')
     A                                      CF09(09 'Retrieve')
     A                                      CA24(24 'More Keys')
     A                                      CA20(20 'Service Programs')
     A                                      CA06(06 'Add Module')
     A                                      CA14(14 'Display Program')
     A                                      RTNCSRLOC(*WINDOW &RTNROW &RTNCOL)
     A  99                                  CSRLOC(CSRROW     CSRCOL)
     A                                      OVERLAY
     A  67                                  SFLDSP
     A N66                                  SFLDSPCTL
     A  66                                  SFLCLR
     A N55                                  SFLEND(*MORE)
     A                                      SFLSIZ(0008)
     A                                      SFLPAG(0007)
     A            CSRROW         3S 0H
     A            CSRCOL         3S 0H
     A            RTNCOL         3S 0H
     A            RTNROW         3S 0H
     A            SFLCT1         4S 0H      SFLRCDNBR(CURSOR)
     A                                  1 28'Work with Service Modules'
     A                                      DSPATR(HI)
     A                                  1 72SYSNAME
     A                                  3  2'Service Program . :'
     A            SAPROGRAM     10A  O  3 22
     A                                  3 34'Signature . :'
     A            SASIGNAT      32A  O  3 48
     A                                  4  4'Library . . . . :'
     A            SAPGMLIB      10A  O  4 24
     A                                  6  2'Type options, press Enter.'
     A                                      COLOR(BLU)
     A                                  7  4'2=Edit Source'
     A                                      COLOR(BLU)
     A                                  7 24'5=Display Source'
     A                                      COLOR(BLU)
     A                                  7 54'8=Display Details'
     A                                      COLOR(BLU)
     A                                  8  4'15=Rebuild Module'
     A                                      COLOR(BLU)
     A                                  8 24'16=Update Module in Program'
     A                                      COLOR(BLU)
     A                                 10  7'Module'
     A                                      DSPATR(HI)
     A                                 10 19'Library'
     A                                      DSPATR(HI)
     A                                 10 31'Source'
     A                                      DSPATR(HI)
     A                                 10 43'Source'
     A                                      DSPATR(HI)
     A                                 10 55'Member'
     A                                      DSPATR(HI)
     A                                 10 69'Create'
     A                                      DSPATR(HI)
     A                                 11  2'Opt'
     A                                      DSPATR(HI)
     A                                 11  7'Name'
     A                                      DSPATR(HI)
     A                                 11 19'Name'
     A                                      DSPATR(HI)
     A                                 11 31'File'
     A                                      DSPATR(HI)
     A                                 11 43'Library'
     A                                      DSPATR(HI)
     A                                 11 55'Name'
     A                                      DSPATR(HI)
     A                                 11 70'Date'
     A                                      DSPATR(HI)
     A          R SY0040B1
     A*%%TS  SD  19990105  165113  ICILANHAM   REL-V4R2M0  5769-PW1
     A                                      OVERLAY
     A                                 20  2'Parameters or command'
     A                                 21  2'===>'
     A            SACMDLINE     73A  B 21  7CHECK(LC)
     A N88                             22  2'F3=Exit'
     A                                      COLOR(BLU)
     A                                 22  2'F14=Display Program'
     A                                      COLOR(BLU)
     A N88                             22 16'F4=Prompt'
     A                                      COLOR(BLU)
     A  88                             22 24'F18=Rebuild All Modules'
     A                                      COLOR(BLU)
     A N88                             22 29'F5=Refresh'
     A                                      COLOR(BLU)
     A  88                             22 50'F19=Rebuild Program'
     A                                      COLOR(BLU)
     A N88                             22 51'F6=Add Module'
     A                                      COLOR(BLU)
     A  88                             23  2'F21=Print List'
     A                                      COLOR(BLU)
     A N88                             23  2'F9=Retrieve'
     A                                      COLOR(BLU)
     A N88                             23 16'F12=Cancel'
     A                                      COLOR(BLU)
     A  88                             23 24'F20=Service Programs'
     A                                      COLOR(BLU)
     A N88                             23 29'F13=Build Directory'
     A                                      COLOR(BLU)
     A  88                             23 50'F24=More Keys'
     A                                      COLOR(BLU)
     A N88                             23 51'F24=More Keys'
     A                                      COLOR(BLU)
     A          R SY004002
     A*%%TS  SD  19990105  163907  ICILANHAM   REL-V4R2M0  5769-PW1
     A                                      OVERLAY
     A                                 12  3'(No records to display.)'
     A          R SY004004
     A*%%TS  SD  19970428  162220  JLANHAM     REL-V3R7M0  5716-PW1
     A                                      CA12(12 'Cancel')
     A                                  1 23'Confirm Rebuild of Binding Directo-
     A                                      ry'
     A                                      DSPATR(HI)
     A                                  1 72SYSNAME
     A                                  3  2'The following object already exist-
     A                                      s for the rebuild operation:'
     A                                      COLOR(BLU)
     A                                  5  4'Object which exists . . . . . . . -
     A                                      . :'
     A            SBOBJECT      10A  O  5 42
     A                                  6  6'Library . . . . . . . . . . . . . -
     A                                      :'
     A            SBLIBRARY     10A  O  6 44
     A                                  7  4'Object type . . . . . . . . . . . -
     A                                      . :'
     A            SBOBJTYPE     10A  O  7 42
     A                                  9  2'Type choice, press Enter.'
     A                                      COLOR(BLU)
     A                                 10  2'Press F12=Cancel to return and not-
     A                                       perform rebuild operation.'
     A                                      COLOR(BLU)
     A                                 12  4'Delete existing object . . . . . .-
     A                                       .'
     A            SBCONFIRM      1A  B 12 42
     A                                 12 46'Y=Yes, N=No'
     A                                 23  2'F12=Cancel'
     A                                      COLOR(BLU)
     A          R SY0040S5                  SFL
     A*%%TS  SD  19980616  134138  JLANHAM     REL-V3R7M0  5716-PW1
     A  51                                  SFLNXTCHG
     A            SETEXT        50A  H
     A            SEOPTION       1A  B 11  3
     A  30                                  DSPATR(RI)
     A            SESRVPGM      10A  O 11  7
     A            SESRVLIB      10A  O 11 19
     A            SESHTEXT      49A  O 11 31
     A          R SY0040C5                  SFLCTL(SY0040S5)
     A*%%TS  SD  19980616  134138  JLANHAM     REL-V3R7M0  5716-PW1
     A                                      SFLSIZ(0011)
     A                                      SFLPAG(0010)
     A                                      CA03(03 'Exit')
     A                                      CA12(12 'Cancel')
     A                                      PAGEUP(25 'Page Up')
     A                                      PAGEDOWN(26 'Page Down')
     A                                      CF09(09 'Command Line')
     A                                      CF04(04 'Prompt')
     A                                      OVERLAY
     A  69                                  SFLDSP
     A N68                                  SFLDSPCTL
     A  68                                  SFLCLR
     A N55                                  SFLEND(*MORE)
     A            SFLCT5         4S 0H      SFLRCDNBR(CURSOR)
     A                                  1 30'Work with ILE Program'
     A                                      DSPATR(HI)
     A                                  1 72SYSNAME
     A                                  3  2'Program . . . . . :'
     A            SAPROGRAM     10A  O  3 22
     A                                  4  4'Library . . . . :'
     A            SAPGMLIB      10A  O  4 24
     A                                  6  2'Type options, press Enter.'
     A                                      COLOR(BLU)
     A                                  7  4'5=Service Program Information'
     A                                      COLOR(BLU)
     A                                  9  7'Service'
     A                                      COLOR(WHT)
     A                                  9 19'Library'
     A                                      DSPATR(HI)
     A                                 10  2'Opt'
     A                                      COLOR(WHT)
     A                                 10  7'Program'
     A                                      COLOR(WHT)
     A                                 10 19'Name'
     A                                      DSPATR(HI)
     A                                 10 31'Text'
     A                                      COLOR(WHT)
     A          R SY0040B5
     A*%%TS  SD  19990105  165113  ICILANHAM   REL-V4R2M0  5769-PW1
     A                                      OVERLAY
     A                                 22  2'F3=Exit'
     A                                      COLOR(BLU)
     A                                 22 12'F4=Prompt'
     A                                      COLOR(BLU)
     A                                 22 24'F12=Cancel'
     A                                      COLOR(BLU)
     A          R SY004006
     A*%%TS  SD  19980616  085131  JLANHAM     REL-V3R7M0  5716-PW1
     A                                      OVERLAY
     A                                  9  3'(No records to display.)'
     A          R MSGSFS1                   SFL
     A                                      SFLMSGRCD(24)
     A            MSGKEY                    SFLMSGKEY
     A            PGMQ                      SFLPGMQ
     A          R MSGSFC1                   SFLCTL(MSGSFS1)
     A*%%TS  SD  19970421  160823  JLANHAM     REL-V3R7M0  5716-PW1
     A                                      SFLDSP
     A                                      SFLDSPCTL
     A                                      SFLINZ
     A N80                                  SFLEND
     A                                      SFLSIZ(0002)
     A                                      SFLPAG(0001)
     A            PGMQ                      SFLPGMQ(10)

Printer File Source-SY0040P

     A*%%***********************************************************************
     A*%%TS  RD  19981229  145522  ICILANHAM   REL-V4R2M0  5769-PW1
     A*%%FI+10660100000000000000000000000000000000000000000000000000
     A*%%FI       0000000000000000000000000000000000000000000000000
     A*%%***********************************************************************
     A          R SY0040H
     A*%%***********************************************************************
     A*%%RI 00000
     A*%%FS 001
     A*%%***********************************************************************
     A                                      SKIPB(002)
     A                                      SPACEA(001)
     A                                     1
     A                                      DATE
     A                                      EDTCDE(Y)
     A                                    +3
     A                                      TIME
     A                                    54
     A                                      'Work with Service Modules'
     A                                   123
     A                                      'Page:'
     A                                    +1
     A                                      PAGNBR
     A                                      EDTCDE(Z)
     A                                     1
     A                                      'Service Program . . . . :'
     A                                      SPACEB(002)
     A            SAPROGRAM     10A  O    +1
     A                                    +7
     A                                      'Signature . . . . :'
     A            SASIGNAT      32A  O    +1
     A                                     3
     A                                      'Library . . . . . . . :'
     A                                      SPACEB(001)
     A            SAPGMLIB      10A  O    +1
     A*%%***********************************************************************
     A*%%SS
     A*%%CL 002
     A*%%CL 001
     A*%%CL 001
     A*%%***********************************************************************
     A          R SY0040H1
     A*%%***********************************************************************
     A*%%RI 00000
     A*%%***********************************************************************
     A                                      SPACEB(001)
     A                                    23
     A                                      'Source'
     A                                    34
     A                                      'Source'
     A                                   +18
     A                                      '----- Change ------'
     A                                     1
     A                                      'Module'
     A                                      SPACEB(001)
     A                                    +5
     A                                      'Library'
     A                                    +4
     A                                      'File'
     A                                    +7
     A                                      'Library'
     A                                    +4
     A                                      'Member'
     A                                    +9
     A                                      'Date'
     A                                    +7
     A                                      'Time'
     A                                    +4
     A                                      'Text'
     A*%%***********************************************************************
     A*%%SS
     A*%%CL 001
     A*%%***********************************************************************
     A          R SY0040D
     A*%%***********************************************************************
     A*%%RI 00000
     A*%%***********************************************************************
     A                                      SPACEB(001)
     A            SAMODULE      10A  O     1
     A            SALIBRARY     10A  O    +1
     A            SASOURCE      10A  O    +1
     A            SASRCLIB      10A  O    +1
     A            SAMEMBER      10A  O    +1
     A            SACREATEDT    10A  O    +1
     A            SACREATETM    10A  O    +1
     A            SAMODTEXT     50A  O    +2
     A*%%***********************************************************************
     A*%%SS
     A*%%***********************************************************************
     A          R SY0040H2
     A*%%***********************************************************************
     A*%%RI 00000
     A*%%***********************************************************************
     A                                      SPACEB(001)
     A                                     1
     A                                      'Service'
     A                                      SPACEB(001)
     A                                     1
     A                                      'Program'
     A                                      SPACEB(001)
     A                                    +4
     A                                      'Library'
     A                                    +5
     A                                      'Signature'
     A                                    +8
     A                                      'Text'
     A*%%***********************************************************************
     A*%%SS
     A*%%CL 001
     A*%%CL 001
     A*%%***********************************************************************
     A          R SY0040D2
     A*%%***********************************************************************
     A*%%RI 00000
     A*%%***********************************************************************
     A                                      SPACEB(001)
     A            SESRVPGM      10A  O     1
     A            SESRVLIB      10A  O    +1
     A            SESIGNAT      16A  O    +2
     A            SETEXT        50A  O    +1
     A*%%***********************************************************************
     A*%%SS
     A*%%CP+999CRTPRTF
     A*%%CP+    FILE(JLANHAM/SY0040P)
     A*%%CP+    DEVTYPE(*SCS)
     A*%%CP     PAGESIZE(*N       132      *N     )
     A*%%***********************************************************************

Command Source-WRKSRVPGM

             CMD        PROMPT('Work with Service Modules')
             PARM       KWD(PGM) TYPE(QLPGMNAME) MIN(1) +
                          PROMPT('Service Program')
 QLPGMNAME:  QUAL       TYPE(*NAME) LEN(10) MIN(1) CHOICE('Name')
             QUAL       TYPE(*NAME) LEN(10) DFT(*LIBL) +
                          SPCVAL((*LIBL)) CHOICE('Name, *LIBL') +
                          PROMPT('Library')
└ Tags: iSeries, Programming
 Comment 
Oct26

WRKILEMOD – An ILE Program Manager for iSeries

by Jeff on October 26th, 2010 at 1:00 pm
Posted In: Computers, Computers, iSeries

I love ILE/RPG. Binding and running multiple code bases as one program has been available on most other platforms for a long time and I’m glad we, as iSeries programmers, finally have it as well.

It just makes it a little difficult to manage multi-module programs. This program was my attempt to alleviate that. Just like with the other utility programs on this site, use at your own risk. All source can be used for any purpose as long as you site me as the original author. Anyway, without further ado, the WRKILEMOD command.

The RPG Source – SY0030R

      /Title SY0030R - Work with ILE Program Modules.
     H Optimize(*None) Option(*SrcStmt: *NoDebugIO)
     H CopyRight('Copyright 2010. Jeffrey Lanham Programming Arts, Inc. All Rig-
     Hhts Reserved.')
      //*************************************************************************
      //  Module: SY0030R                                                       *
      //  Purpose: This module gets module information for ILE Program          *
      //           objects.  Will eventually turn this into a bound program     *
      //           management system.                                           *
      //*************************************************************************
      //  Written by: Jeffrey Lanham                                            *
      //*************************************************************************

     FSY0030FM  CF   E             Workstn Sfile(SY0030S1: Recno1)
     F                                     Sfile(SY0030S5: Recno5)
     F                                     Infds(SY0030DS)
     FSY0030P   O    E             Printer UsrOpn

      /Eject
      //*************************************************************************
      // Constants.
     D CmdCol          C                   7
     D CmdRow          C                   21

      //*************************************************************************
      // Work fields.
     D Bin04           S              8B 0                                      Scrap 4.0 Binary
     D Cancelled       S               N                                        Function Cancelled?
     D CommandLine     S          32702                                         Command Line
     D CommandLength   S             15  5                                      Command Length
     D ErrorMessage    S             80                                         Error Message Parm.
     D No_Selection    S               N                                        No Selection Made
     D NotExist        S               N                                        Doesn't Exist?
     D OverFlow        S               N                                        OverFlow Indicator
     D Recno1          S                   Like(SFLCT1)                         Subfile Record No.
     D Recno5          S                   Like(SFLCT5)                         Subfile Record No.
     D Sav_Cur_Page    S                   Like(SFLCT1)
     D Tick            C                   X'7D'                                '

      //*************************************************************************
      // Entry Procedure definition.
     D SY0030R         PR
      // This is also a parameter for QBNLPGMI API (List ILE Program Information).
     D  Bi_ILEPgmName                20

     D SY0030R         PI
     D  Bi_ILEPgmName                20

      //*************************************************************************
      // File information data structure.
     D SY0030DS        DS                                                       Infds Data Structure
     D  Cur_RRN              376    377B 0                                      Current Sfile RRN
     D  Cur_Page             378    379B 0                                      RRN Current Page

      //*************************************************************************
      // Program status data structure.
     D                SDS                                                       System Data Struct.
     D ErrorData              91    170                                         Error data

      //*************************************************************************
      // Definitions for user space information.
     D Gn_Pointer      S               *                                        Generic Header Ptr

      //*************************************************************************
      // Generic user space header.
     D Gn_Header       DS                  Based(Gn_Pointer)
     D   Gn_UserArea                 64                                         User Area
     D   Gn_HdrSize                   8B 0                                      Generic Header Size
     D   Gn_RlsLevel                  4                                         Release and Level
     D   Gn_Format                    8                                         Format Name
     D   Gn_APIUsed                  10                                         API Used
     D   Gn_CreateSt                 13                                         TimeStamp Created
     D   Gn_InfoStat                  1                                         Information Status
     D   Gn_SizeUsed                  8B 0                                      Space Size Used
     D   Gn_InputOff                  8B 0                                      Input Section Offset
     D   Gn_InputSize                 8B 0                                      Input Section Size
     D   Gn_HeadrOff                  8B 0                                      Header Offset
     D   Gn_HeadrSize                 8B 0                                      Header Size
     D   Gn_ListOff                   8B 0                                      Offset to List
     D   Gn_ListSize                  8B 0                                      List Size
     D   Gn_Entries                   8B 0                                      Number of Entries
     D   Gn_EntrySize                 8B 0                                      Entry Size

      //*************************************************************************
      // List Pointers.
     D Pt_PGML0100     S               *
     D Pt_PGML0200     S               *

      //*************************************************************************
      // List module information section.
     D Ls_PGML0100     DS                  Based(Pt_PGML0100)
     D   Md_Program                  10                                         Program Name
     D   Md_Library                  10                                         Library Name
     D   Md_Module                   10                                         Module Name
     D   Md_ModuleLib                10                                         Module Library
     D   Md_SrcFile                  10                                         Source File Name
     D   Md_SrcLib                   10                                         Source Library Name
     D   Md_SrcMember                10                                         Source Member Name
     D   Md_ModuleAtt                10                                         Module Attribute
     D   Md_ModuleCrt                13                                         Creation Time Stamp
     D   Md_SrcUpdate                13                                         Last Update TimeStmp
     D   Md_SortTable                10                                         Sort Table
     D   Md_SortLib                  10                                         Sort Library
     D   Md_LangId                   10                                         Language Identifier
     D   Md_OptLevel                  8B 0                                      Optimization Level
     D   Md_MaxOpt                    8B 0                                      Max Optimization Lvl
     D   Md_ModCrtRls                 6                                         Release Created On
     D   Md_ModCrtFor                 6                                         Module Created For
     D   Md_Reserved                 20                                         Reserved
     D   Md_UsrMod                    1                                         User Modified
     D   Md_LicPgm                   13                                         Licensed Program
     D   Md_PTFNumber                 5                                         PTF Number
     D   Md_APARId                    6                                         APAR Id
     D   Md_Reserv2                   1                                         Reserved again
     D   Md_ModCCSID                  8B 0                                      Module CCSID
     D   Md_ObjCtrLvl                 8                                         Object Control Level
     D   Md_Reserv3                 100                                         One more time
     D   Md_SqlStmt                   8B 0                                      No SQL Statements
     D   Md_RelDbase                 18                                         Relational Database
     D   Md_CommitCtr                10                                         Commitment Control
     D   Md_AlwCpyDta                10                                         Allow Copy of Data
     D   Md_CloseSql                 10                                         Close SQL Cursors
     D   Md_NameConv                 10                                         Naming Convention
     D   Md_DateFmt                  10                                         Date Format
     D   Md_DateSep                   1                                         Date Seperator
     D   Md_TimeFmt                  10                                         Time Format
     D   Md_TimeSep                   1                                         Time Seperator
     D   Md_DelayPrep                10                                         Delay PREPARE
     D   Md_AllowBlck                10                                         Allow Blocking

      //*************************************************************************
      // Service program information data structure.
     D Ls_PGML0200     DS                  Based(Pt_PGML0200)
     D  Sp_Program                   10                                         Program Name
     D  Sp_Library                   10                                         Program Library
     D  Sp_Service_Program...                                                   Service Program
     D                               10
     D  Sp_Service_Library...                                                   Service Library
     D                               10
     D  Sp_Service_Signature...
     D                               16                                         Signature

      //*************************************************************************
      // Retrieve Program Information Return Variable.
     D PI_PGMI0100     DS
     D  Pi_BytesAva                   8B 0                                      Bytes Available
     D  Pi_BytesRet                   8B 0                                      Bytes Returned
     D  Pi_Program_Name...
     D                               10                                         Program Name
     D  Pi_Program_Library...
     D                               10                                         Program Library
     D  Pi_Program_Owner...
     D                               10                                         Program Owner
     D  Pi_Program_Attribute...
     D                               10                                         Program Attribute
     D  Pi_Create_Date_Time...
     D                               13                                         Create Date/Time
     D  Pi_Source_File...
     D                               10                                         Source File Name
     D  Pi_Source_File_Library...
     D                               10                                         Source File Library
     D  Pi_Source_Member...
     D                               10                                         Source Member
     D  Pi_Source_Updated_Date_Time...
     D                               13                                         Source Update Date
     D  Pi_Observable_Info...
     D                                1                                         Observable Info
     D  Pi_Profile_Option...
     D                                1                                         User Profile Option
     D  Pi_Use_Adopt_Authority...
     D                                1                                         Use Adopt Authority
     D  Pi_Log_Commands...
     D                                1                                         Log Commands?
     D  Pi_Allow_Rtv_CL_Source...
     D                                1                                         Allow CL Retrieve
     D  Pi_Fix_Decimal_Data...
     D                                1                                         Fix DDE
     D  Pi_Desciption...
     D                               50                                         Program Description
     D  Pi_Type                       1                                         Type of Program
     D  Pi_Reserved1                 59                                         IBM Reserved
     D  Pi_Minimum_Parameters...
     D                                8B 0                                      Minimum Parameters
     D  Pi_Maximum_Parameters...
     D                                8B 0                                      Maximum Parameters
     D  Pi_Program_Size...
     D                                8B 0                                      Program Size
     D  Pi_Associated_Space_Size...
     D                                8B 0                                      Associated Size
     D  Pi_Static_Storage...
     D                                8B 0                                      Static Storage
     D  Pi_Automatic_Storage...
     D                                8B 0                                      Automatic Storage
     D  Pi_MI_Instructions...
     D                                8B 0                                      No. of MI Inst.
     D  Pi_MI_ODT_Entries...
     D                                8B 0                                      No. of MI ODT Ent.
     D  Pi_Program_State...
     D                                1                                         Program State
     D  Pi_Compiler_Identification...
     D                               14                                         Compiler I.D.
     D  Pi_Earliest_Run_Release...
     D                                6                                         Earliest Run Rls.
     D  Pi_Sort_Table_Name...
     D                               10                                         Sort Seq Table Name
     D  Pi_Sort_Table_Library...
     D                               10                                         Sort Seq Table Lib
     D  Pi_Language_Identifier...
     D                               10                                         Language I.D.
     D  Pi_Program_Domain...
     D                                1                                         Program Domain
     D  Pi_Conversion_Required...
     D                                1                                         Conversion Required?
     D  Pi_Reserved2                 20                                         IBM Reserved
     D  Pi_Optimization...
     D                                1                                         Optimization
     D  Pi_Paging_Pool...
     D                                1                                         Paging Pool
     D  Pi_Update_PASA...
     D                                1                                         Update PASA
     D  Pi_Clear_PASA...
     D                                1                                         Clear PASA
     D  Pi_Paging_Amount...
     D                                1                                         Paging Amount
     D  Pi_Reserved3                 18                                         IBM Reserved
     D  Pi_PEP_Module_Name...
     D                               10                                         PEP Module
     D  Pi_PEP_Module_Library...
     D                               10                                         PEP Module Lib
     D  Pi_Activation_Group_Attr...
     D                               30                                         Act Group Attr.
     D  Pi_Observable_Info_Compressed...
     D                                1                                         Observable Compress?
     D  Pi_Run_Time_Compressed...
     D                                1                                         Run Time Compressed?
     D  Pi_Release_Created...
     D                                6                                         Release Created On
     D  Pi_Shared_Activation_Group...
     D                                1                                         Shared Act. Group?
     D  Pi_Allow_Update...
     D                                1                                         Allow Update?
     D  Pi_Program_CCSID...
     D                                8B 0                                      Program CCSID
     D  Pi_Number_of_Modules...
     D                                8B 0                                      Number of Modules
     D  Pi_Number_of_Service_Programs...
     D                                8B 0                                      Number of Serv Pgms
     D  Pi_Number_of_Copyrights...
     D                                8B 0                                      Number of Copyrights
     D  Pi_Number_of_Unresolved_References...
     D                                8B 0                                      # of Unresolved Refs
     D  Pi_Release_Created_For...
     D                                6                                         Release Created For
     D  Pi_ReInit_Static_Storage...
     D                                1                                         Allow Reinit.
     D  Pi_All_Creation_Data...
     D                                1                                         All Creation Data
     D  Pi_Allow_Bound_Service_Pgm_Update...
     D                                1                                         Allow Service Update
     D  Pi_Profiling_Data...
     D                               10                                         Profiling Data
     D  Pi_Reserved4                 89                                         IBM Reserved

      //*************************************************************************
      // API Error code parameter for those that need it.
     D DS_ErrorCode    DS
     D   ER_BytesPrv                  8B 0 Inz(256)                             Bytes Provided
     D   ER_BytesAva                  8B 0                                      Bytes Available
     D   ER_ExcId                     7                                         Exception Id
     D   ER_Reserved                  1                                         Reserved
     D   ER_Data                    256                                         Exception Data

      //*************************************************************************
      // API Dummy Error Code.
     D DS_DummyError   DS
     D   DE_BytesPrv                  8B 0 Inz(0)                               Bytes Provided

      //*************************************************************************
      // Retrieve Object description return data.
     D DS_OBJD0200     DS
     D  OB_BytesRet                   8B 0                                      Bytes Returned
     D  OB_BytesAva                   8B 0                                      Bytes Available
     D  OB_Object                    10                                         Object Name
     D  OB_Library                   10                                         Object Library
     D  OB_Type                      10                                         Object Type
     D  OB_Return_Library...
     D                               10                                         Return Library
     D  OB_ASP                        8B 0                                      Aux Storage Pool
     D  OB_Owner                     10                                         Object Owner
     D  OB_Domain                     2                                         Object Domain
     D  OB_Create_Date_Time...
     D                               13                                         Create Date/Time
     D  OB_Change_Date_Time...
     D                               13                                         Change Date/Time
     D  OB_Extended_Attribute...
     D                               10                                         Extended Attribute
     D  OB_Text                      50                                         Text Description
     D  OB_SourceFile                10                                         Source File
     D  OB_SourceLib                 10                                         Source Library
     D  OB_SourceMbr                 10                                         Source Member

      //*************************************************************************
      // Retrieve Program Request Message return data.
     D DS_RTVQ0100     DS
     D  RM_BytesRet                   8B 0                                      Bytes Returned
     D  RM_BytesAva                   8B 0                                      Bytes Available
     D  RM_MsgKey                     4                                         Message Key
     D  RM_Reserved                  20                                         IBM Reserved
     D  RM_LengthRet                  8B 0                                      Length Returned
     D  RM_LengthAva                  8B 0                                      Length Available
     D  RM_Text                   32000                                         Message Data

      //*************************************************************************
      // Retrieve Program Message return data.
     D DS_RCVM0100     DS
     D  RC_BytesRet                   8B 0                                      Bytes Returned
     D  RC_BytesAva                   8B 0                                      Bytes Available
     D  RC_MsgSev                     8B 0                                      Message Severity
     D  RC_MsgId                      7                                         Message Identifier
     D  RC_MsgType                    2                                         Message Type
     D  RC_MsgKey                     4                                         Message Key
     D  RC_Reserved                   7                                         Reserved
     D  RC_CCSIDStat                  8B 0                                      CCSID Conv Status
     D  RC_CCSIDRepl                  8B 0                                      CCSID Replace Data
     D  RC_ReplRet                    8B 0                                      Replace Data Return
     D  RC_ReplAva                    8B 0                                      Replace Data Avail
     D  RC_Text                   32000                                         Message Data

      //*************************************************************************
      // Process commands control block.
     D DS_CPOP0100     DS
     D   CP_Type                      8B 0 Inz(3)                               Type of Processing
     D   CP_DBCS                      1    Inz('0')                             DBCS Data Handling
     D   CP_PromptAct                 1                                         Prompter Action
     D   CP_CmdSyntax                 1    Inz('0')                             Command String Syntx
     D   CP_MsgKey                    4    Inz(*Blanks)                         Message Retrieve Key
     D   CP_Reserved                  9    Inz(X'000000000000000000')           IBM Reserved

      //*************************************************************************
      // QUSROBJD - Retrieve object description.
     D POB_Length      S              8B 0 Inz(%Size(DS_OBJD0200))
     D POB_Format      S              8    Inz('OBJD0200')
     D POB_QLObject    S             20                                         Qualified Object
     D POB_ObjectType  S             10    Inz('*MODULE')                       Object Type

      //*************************************************************************
      // Parameters for QUSCRTUS API (Create User Space) for Modules
     D Md_SpaceName    S             20    Inz('ILEPGM    QTEMP')               Qualified Space Name
     D Md_ExtAttr      S             10    Inz('WRKILEPGM')                     Extended Attribute
     D Md_InitSize     S              8B 0 Inz(%Size(Ls_PGML0100))
     D Md_InitValue    S              1    Inz(X'00')
     D Md_PubAuth      S             10    Inz('*ALL')                          Public Authority
     D Md_Text         S             50    Inz('User Space for WRKILEPGM')      User Space Text
     D Md_Replace      S             10    Inz('*YES')                          Replace Object

      //*************************************************************************
      // Parameters for QUSCRTUS API (Create User Space) for Service Programs
     D Sp_SpaceName    S             20    Inz('SRVPGM    QTEMP')               Qualified Space Name
     D Sp_ExtAttr      S             10    Inz('WRKILEPGM')                     Extended Attribute
     D Sp_InitSize     S              8B 0 Inz(%Size(Ls_PGML0200))
     D Sp_InitValue    S              1    Inz(X'00')
     D Sp_PubAuth      S             10    Inz('*ALL')                          Public Authority
     D Sp_Text         S             50    Inz('User Space for WRKILEPGM')      User Space Text
     D Sp_Replace      S             10    Inz('*YES')                          Replace Object

      //*************************************************************************
      // Parameters for QBNLPGMI API (List ILE Program Information).
     D Bi_Format       S             10                                         API Format to Return

      //*************************************************************************
      // Parameters for QCLRPGMI API (Retrieve Program Information).
     D Pi_Data_Length  S              4B 0 Inz(%Size(Pi_PGMI0100))              Data Length

      //*************************************************************************
      // QMHRMVPM - Remove program messages API.
     D PRM_CallQ       S             10    Inz('*')                             Call Message Queue
     D PRM_CallStack   S              8B 0 Inz(1)                               Call Stack Counter
     D PRM_MsgKey      S              4                                         Message Key
     D PRM_MsgToRemove...
     D                 S             10    Inz('*ALL')                          Messages To Remove

      //*************************************************************************
      // QMHRSNDPM - Send program messages API parameters.
     D PSM_MsgID       S              7    Inz('CPF9897')                       Message Identifier
     D PSM_QLMsgFile   S             20    Inz('QCPFMSG   *LIBL')               Qualified Msg File
     D PSM_Length      S              8B 0 Inz(%Size(ErrorMessage))             Message Length
     D PSM_MsgType     S             10    Inz('*INFO')                         Message Type
     D PSM_CallQ       S             10    Inz('*')                             Call Message Queue
     D PSM_CallStack   S              8B 0 Inz(1)                               Call Stack Counter
     D PSM_MsgKey      S              4                                         Message Key

      //*************************************************************************
      // QMHRSNDPM - Send program messages API parameters for request messages.
     D RSM_MsgID       S              8    Inz('       ')                       Message Identifier
     D RSM_QLMsgFile   S             20    Inz('               ')               Qualified Msg File
     D RSM_Length      S              8B 0 Inz(%Size(CommandLine))              Message Length
     D RSM_MsgType     S             10    Inz('*RQS')                          Message Type
     D RSM_CallQ       S             10    Inz('*EXT')                          Call Message Queue
     D RSM_CallStack   S              8B 0 Inz(0)                               Call Stack Counter
     D RSM_MsgKey      S              4                                         Message Key

      //*************************************************************************
      // Commands for each module attribute.
     D C               S              5U 0                                      Lookup Array Index
     D ModAtt          S             10    Dim(10) CtData PerRcd(1)             Module Attribute
     D ModCmd          S             10    Dim(%Elem(ModAtt)) CtData PerRcd(1)  Module Create Cmds
     D BndCmd          S             10    Dim(%Elem(ModAtt)) CtData PerRcd(1)  Bound Pgm Commands

      /Eject
      //*************************************************************************
      // Procedure definitions.
      //*************************************************************************
      // Create User Space.
     D QUsCrtUs        PR                  ExtPgm('QUSCRTUS')
     D                               20                                         Qualified Space Name
     D                               10                                         Extended Attribute
     D                                8B 0                                      Initial Size
     D                                1                                         Initial Value
     D                               10                                         Public Authority
     D                               50                                         User Space Text
     D                               10                                         Replace Object
     D   ErrorCode                         Like(DS_ErrorCode)                   Error Code

      //*************************************************************************
      // Delete User Space.
     D QUsDltUs        PR                  ExtPgm('QUSDLTUS')
     D                               20                                         Qualified Space Name
     D  ErrorCode                          Like(DS_ErrorCode)                   Return Error Code

      //*************************************************************************
      // Retrieve Pointer to User Space.
     D QUsPtrUs        PR                  ExtPgm('QUSPTRUS')
     D                               20                                         Qualified Space Name
     D                                 *                                        Return Pointer
     D  ErrorCode                          Like(DS_ErrorCode)                   Return Error Code

      //*************************************************************************
      // Retrieve ILE Program Information.
     D QBnlPgmI        PR                  ExtPgm('QBNLPGMI')
     D                               20                                         Qualified Space Name
     D                                8                                         Format Name
     D                               20                                         Qualified Pgm Name
     D  ErrorCode                          Like(DS_ErrorCode)                   Error Code

      //*************************************************************************
      // Send program message API.
     D Send_PgmMessage...
     D                 PR                  ExtPgm('QMHSNDPM')                   Send Pgm Message
     D                                7    Const                                Message Id
     D                               20    Const                                Qualified Msg File
     D                            32767    Options(*VarSize)                    Message Data
     D                                8B 0 Const                                Length of Msg Data
     D                               10    Const                                Message Type
     D                            32767    Options(*VarSize) Const              Call Message Queue
     D                                8B 0 Const                                Call Stack Counter
     D                                4                                         Message Key
     D                            32767    Options(*VarSize)                    Error Code

      //*************************************************************************
      // Receive request message API.
     D Receive_RqsMessage...
     D                 PR                  ExtPgm('QMHRTVRQ')                   Receive Rqs Message
     D                            32767    Options(*VarSize)                    Message Data
     D                                8B 0 Const                                Length of Msg Data
     D                                8    Const                                Format Name
     D                               10    Const                                Message Type
     D                                4    Const                                Message Key
     D                            32767    Options(*VarSize)                    Error Code

      //*************************************************************************
      // Receive program message API.
     D Receive_PgmMessage...
     D                 PR                  ExtPgm('QMHRCVPM')                   Receive Pgm Message
     D                            32767    Options(*VarSize)                    Message Data
     D                                8B 0 Const                                Length of Msg Data
     D                                8    Const                                Format Name
     D                            32767    Options(*VarSize) Const              Call Stack Entry
     D                                8B 0 Const                                Call Stack Counter
     D                               10    Const                                Message Type
     D                                4    Const                                Message Key
     D                                8B 0 Const                                Wait Time
     D                               10    Const                                Message Action
     D                            32767    Options(*VarSize)                    Error Code

      //*************************************************************************
      // Remove program message API.
     D Remove_PgmMessage...
     D                 PR                  ExtPgm('QMHRMVPM')                   Remove Messages
     D                            32767    Options(*VarSize)                    Call Message Queue
     D                                8B 0                                      Call Stack Counter
     D                                4                                         Message Key
     D                               10                                         Messages to Remove
     D                            32767    Options(*VarSize)                    Error Code

      //*************************************************************************
      // Retrieve Program Information (QCLRPGMI)
     D QClrPgmI        PR                  ExtPgm('QCLRPGMI')
     D                            32767    Options(*VarSize)                    Returned Data
     D                                4B 0                                      Receiver Var Length
     D                                8                                         Format Name
     D                               20                                         Qualified Program
     D                            32767    Options(*VarSize)                    Error Code

      //*************************************************************************
      // QCMDEXEC API.
     D QCmdExec        PR                  ExtPgm('QCMDEXC')
     D   CommandLine              32702    Options(*VarSize)
     D   CommandLength...
     D                               15  5

      //*************************************************************************
      // QCAPCMD API.
     D QCapCommand     PR                  ExtPgm('QCAPCMD')
     D                            32702    Options(*VarSize) Const              Command Line Passed
     D                                8B 0 Const                                Command Line Length
     D                            32702A   Options(*VarSize) Const              Options Block
     D                                8B 0 Const                                Options Block Length
     D                                8    Const                                Options Block Format
     D                            32702A   Options(*VarSize)                    Changed Command Str
     D                                8B 0 Const                                Ret Cmd Available
     D                                8B 0                                      Length Returned
     D                            32702A   Options(*VarSize: *Omit)             Error Return Code

      // QCMDCHK API.
     D QCmdCheck       PR                  ExtPgm('QCMDCHK')
     D                            32702    Options(*VarSize)                    Command Line
     D                               15  5                                      Command Length

      //*************************************************************************
      // Retrieve Object Description API.
     D QUsrObjD        PR                  ExtPgm('QUSROBJD')                   Retrieve Object Desc
     D                            32767    Options(*VarSize)                    Return Data
     D                                8B 0                                      Length of Receiver
     D                                8                                         Format Name
     D                               20                                         Qualified Obj Name
     D                               10                                         Object Type
     D                            32767    Options(*VarSize)                    Error Code

      //*************************************************************************
      // Clear Message Procedure.
     D Clear_Message   PR

      //*************************************************************************
      // Send Message Procedure.
     D Send_Message    PR
     D   Message                  32767    Options(*VarSize)

      //*************************************************************************
      // Display Service program procedure.
     D Disp_Service_Program...
     D                 PR              N

      //*************************************************************************
      // Print list procedure.
     D Print_List      PR

      //*************************************************************************
      // Build a binding directory.
     D Build_Directory...
     D                 PR              N

      //*************************************************************************
      // Add an entry to the command line history buffer.
     D Add_Command_Line...
     D                 PR                  OpDesc
     D  CommandLine               32702    Options(*VarSize)

      //*************************************************************************
      // Retrieve the next entry in the history buffer.
     D Retrieve_Command_Line...
     D                 PR                  Like(CommandLine)

      //*************************************************************************
      // Attach command line to command.
     D Attach_Options...
     D                 PR         32702    OpDesc
     D                            32702    Options(*VarSize)                    Command Line
     D                            32702    Options(*VarSize)                    Options to Attach

      /Eject
      /Free
       //*************************************************************************
       //* Create the user spaces in QTEMP.
       PGMQ = '*';
       Clear ER_ExcId;

       //*************************************************************************
       // Create user space for module display.
       QUsCrtUs(Md_SpaceName: Md_ExtAttr:
           Md_InitSize: Md_InitValue: Md_PubAuth:
           Md_Text: Md_Replace: DS_ErrorCode);
       If Not (ER_ExcId = *Blanks);
         Exsr Exception_Err;
         Return;
       Endif;                                                                 //Not (ER_ExcId...

       //*************************************************************************
       // Create the user space for service program display.
       QUsCrtUs(Sp_SpaceName: Sp_ExtAttr:
           Sp_InitSize: Sp_InitValue: Sp_PubAuth:
           Sp_Text: Sp_Replace: DS_ErrorCode);
       If Not (ER_ExcId = *Blanks);
         Exsr Exception_Err;
         Return;
       Endif;                                                                 //Not (ER_ExcId...

       //*************************************************************************
       // Get initial information and display first screen.
       *IN88 = *Off;                                                          //Display Dft Keys

       Dow Not *INLR;

         //*************************************************************************
         // Call the Retrieve Program Information API.
         Clear ER_ExcId;
         Bi_Format = 'PGMI0100';
         QClrPgmI(Pi_PGMI0100: Pi_Data_Length:
             Bi_Format: Bi_ILEPgmName: DS_ErrorCode);
         If Not (ER_ExcId = *Blanks);
           Exsr Exception_Err;
           QUsDltUs(Md_SpaceName: DS_ErrorCode);
           QUsDltUs(Sp_SpaceName: DS_ErrorCode);
           Return;
         Endif;                                                               //Not (ER_ExcId...

         //*************************************************************************
         // Call the Get ILE Program Information API for modules information.
         Clear ER_ExcId;
         Bi_Format = 'PGML0100';
         QBnlPgmi(Md_SpaceName: Bi_Format:
             Bi_ILEPgmName: DS_ErrorCode);
         If Not (ER_ExcId = *Blanks);
           Exsr Exception_Err;
           QUsDltUs(Md_SpaceName: DS_ErrorCode);
           QUsDltUs(Sp_SpaceName: DS_ErrorCode);
           Return;
         Endif;                                                               //Not (ER_ExcId...

         //*************************************************************************
         // Call the Get ILE Program Information API for service program information.
         Clear ER_ExcId;
         Bi_Format = 'PGML0200';
         QBnlPgmi(Sp_SpaceName: Bi_Format:
             Bi_ILEPgmName: DS_ErrorCode);
         If Not (ER_ExcId = *Blanks);
           Exsr Exception_Err;
           QUsDltUs(Md_SpaceName: DS_ErrorCode);
           QUsDltUs(Sp_SpaceName: DS_ErrorCode);
           Return;
         Endif;                                                               //Not (ER_ExcId...

         //*************************************************************************
         // Retrieve the pointer to the user space for module information.
         Clear ER_ExcId;
         QUsPtrUs(Md_SpaceName: Gn_Pointer:
             DS_ErrorCode);
         If Not (ER_ExcId = *Blanks);
           Exsr Exception_Err;
           QUsDltUs(Md_SpaceName: DS_ErrorCode);
           QUsDltUs(Sp_SpaceName: DS_ErrorCode);
           Return;
         Endif;                                                               //Not (ER_ExcId...

         // Now we can load the subfile for module information.
         *IN66 = *On;
         Write SY0030C1;
         *IN66 = *Off;
         Pt_PGML0100 = Gn_Pointer + Gn_ListOff;
         SAPROGRAM = Md_Program;
         SAPGMLIB = Md_Library;

         NotExist = *Off;
         For Recno1 = 1 to Gn_Entries;
           If Recno1 <= *Zeros;
             Leave;
           Endif;                                                             //Recno1<=*Zeros
           *IN67 = *On;
           Clear SAOPTION;
           SAMODULE = Md_Module;
           SALIBRARY = Md_ModuleLib;
           SASOURCE = Md_SrcFile;
           SASRCLIB = Md_SrcLib;
           SAMEMBER = Md_SrcMember;
           SAMODATTR = Md_ModuleAtt;
           // If the create date is not blanks, convert the date and time.
           If Not (Md_ModuleCrt = *Blanks);
              SACREATEDT = %Char(%Date(%Subst(Md_ModuleCrt: 1: 7):
                              *CYMD0): *MDY/);
              SACREATETM = %Char(%Time(%Subst(Md_ModuleCrt: 8: 6):
                              *HMS0): *HMS:);
           Endif;                                                             //Not (Md_Module...
           // If the source update date is not blanks, convert the date and time.
           If Not (Md_SrcUpdate = *Blanks);
              SASRCCHGDT = %Char(%Date(%Subst(Md_SrcUpdate: 1: 7):
                              *CYMD0): *MDY/);
              SASRCCHGTM = %Char(%Time(%Subst(Md_SrcUpdate: 8: 6):
                              *HMS0): *HMS:);
           Endif;                                                             //Not (Md_SrcUpdate...
           // Get the object description if available.
           Clear Er_ExcId;
           POB_QLObject = SAMODULE + SALIBRARY;
           POB_ObjectType = '*MODULE';
           QUsrObjD(DS_OBJD0200: POB_Length: POB_Format:
               POB_QLObject: POB_ObjectType: DS_ErrorCode);
           If Not (Er_ExcId = *Blanks);
             NotExist = *On;
             SAMODTEXT = '* Not Available';
           Else;
             SAMODTEXT = OB_Text;
           Endif;                                                             //Not (Er_ExcId...
           Write SY0030S1;
           Pt_PGML0100 = Pt_PGML0100 + Gn_EntrySize;
         EndFor;                                                              //Do Gn_Entries

         //*************************************************************************
         // Retrieve the pointer to the user space for service program information.
         Clear ER_ExcId;
         QUsPtrUs(Sp_SpaceName: Gn_Pointer:
             DS_ErrorCode);
         If Not (ER_ExcId = *Blanks);
           Exsr Exception_Err;
           QUsDltUs(Md_SpaceName: DS_ErrorCode);
           QUsDltUs(Sp_SpaceName: DS_ErrorCode);
           Return;
         Endif;                                                               //Not (ER_ExcId...

         //*************************************************************************
         // Now we can load the subfile for module information.
         *IN68 = *On;
         Write SY0030C5;
         *IN68 = *Off;
         Pt_PGML0200 = Gn_Pointer + Gn_ListOff;

         NotExist = *Off;
         For Recno5 = 1 to Gn_Entries;
           If Recno5 <= *Zeros;
             Leave;
           Endif;                                                             //Recno5<=*Zeros
           *IN69 = *On;
           SESRVPGM = Sp_Service_Program;
           SESRVLIB = Sp_Service_Library;
           Clear Er_ExcId;
           POB_ObjectType = '*SRVPGM';
           POB_QLObject = Sp_Service_Program +
               Sp_Service_Library;
           QUsrObjD(DS_OBJD0200: POB_Length: POB_Format:
               POB_QLObject: POB_ObjectType: DS_ErrorCode);
           If Not (Er_ExcId = *Blanks);
             NotExist = *On;
             SETEXT = '* Not Available';
           Else;
             SETEXT = OB_Text;
           Endif;                                                             //Not (Er_ExcId...
           SESHTEXT = SETEXT;
           Write SY0030S5;
           Pt_PGML0200 = Pt_PGML0200 + Gn_EntrySize;
         EndFor;                                                              //Do Gn_Entries

         //*************************************************************************
         // Clear the subfile message queue.
         Clear_Message();
         ErrorMessage = *Blanks;
         Send_Message(ErrorMessage);
         SFLCT1 = 1;

         //*************************************************************************
         // Read and process the screen.
         Dow Not *INLR;
           Write MSGSFC1;
           Write SY0030B1;
           If Not *IN67;
             Write SY003002;
           Endif;                                                             //Not *IN67
           Write SY0030C1;
           Read SY0030B1;
           Read SY0030C1;
           Sav_Cur_Page = Cur_Page;
           *IN99 = *Off;
           Clear_Message();
           Clear ErrorMessage;
           If Not (Sav_Cur_Page = 0);
             SFLCT1 = Sav_Cur_Page;
           Endif;                                                             //Not(Cur_Page...
           // Set the cursor location.
           CSRROW = RTNROW;
           CSRCOL = RTNCOL;

           //*************************************************************************
           // Handle Function Keys.
           Select;

             //*************************************************************************
             // Exit program.
           When *IN03;                                                        //F3=Exit
             QUsDltUs(Md_SpaceName: DS_ErrorCode);
             QUsDltUs(Sp_SpaceName: DS_ErrorCode);
             *INLR = *On;
             Leave;

             //*************************************************************************
             // Refresh list.
           When *IN05;                                                        //F5=Refresh
             Clear SACMDLINE;
             Leave;

             //*************************************************************************
             // Add a module to program.
           When *IN06;                                                        //F6=Add Module
             ErrorMessage = 'Function not currently supported.';
             Send_Message(ErrorMessage);
             Iter;

             //*************************************************************************
             // Retrieve a previous command line.
           When *IN09;                                                        //F9=Retrieve
             CSRROW = CmdRow;
             CSRCOL = CmdCol;
             *IN99 = *On;
             SACMDLINE = Retrieve_Command_Line;
             Iter;

             //*************************************************************************
             // Cancel from main screen.
           When *IN12;                                                        //F12=Cancel
             QUsDltUs(Md_SpaceName: DS_ErrorCode);
             QUsDltUs(Sp_SpaceName: DS_ErrorCode);
             *INLR = *On;
             Leave;

             //*************************************************************************
             // Build a binding directory from current module list.
           When *IN13;                                                        //F13=Build Directory
             If Pi_Activation_Group_Attr = '*DFTACTGRP';
               ErrorMessage = 'Cannot build binding directory ' +
                   'for a DFTACTGRP program.';
               Send_Message(ErrorMessage);
               Iter;
             Endif;                                                           //Pi_Activation...
             Cancelled = Build_Directory;
             If Cancelled;
               ErrorMessage = ErrorData;
               Send_Message(ErrorMessage);
               Iter;
             Else;
               ErrorMessage = 'Binding directory built for ' +
                   'program ' + %Trimr(SAPGMLIB) + '/' +
                   %Trimr(SAPROGRAM) + '.';
               Send_Message(ErrorMessage);
               Iter;
             Endif;                                                           //Cancelled

             //*************************************************************************
             // Display program information.
           When *IN14;
             CommandLine = 'DSPPGM PGM(' +
                 %Trimr(SAPGMLIB) + '/' + %Trimr(SAPROGRAM) +
                 ')';
             CommandLength = %Size(CommandLine);
             Callp(E) QCmdExec(CommandLine: CommandLength);
             Iter;

             //*************************************************************************
             // Rebuild all modules in the list.
           When *IN18;                                                        //F18=Rebuild All Mods
             If Pi_Activation_Group_Attr = '*DFTACTGRP';
               ErrorMessage = 'Cannot rebuild a default act' +
                   'ivation group program.  Use option 15.';
               Send_Message(ErrorMessage);
               Iter;
             Endif;                                                           //Pi_Activation...
             CommandLength = %Size(CommandLine);
             Recno1 = 1;
             // Read through the entire subfile.
             Chain Recno1 SY0030S1;
             Dow %Found;
               // Find the appropriate command for the create.
               C = 1;
               C = %Lookup(SAMODATTR: ModAtt);
               If Not (C = 0);
      /If Defined(Target_Release)
                 CommandLine = %Trimr(ModCmd(C)) +
                     ' MODULE(' +
                     %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                     ') SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                     %Trimr(SASOURCE) + ') SRCMBR(' +
                     %Trimr(SAMEMBER) + ') ' + 'TGTRLS(' +
                     Pi_Release_Created_For + ')';
      /Else
                 CommandLine = %Trimr(ModCmd(C)) +
                     ' MODULE(' +
                     %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                     ') SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                     %Trimr(SASOURCE) + ') SRCMBR(' +
                     %Trimr(SAMEMBER) + ')';
      /Endif
               Else;
                 ErrorMessage = 'Module attribute ' +
                     %Trimr(SAMODATTR) +
                     ' for member ' + %Trimr(SAMEMBER) +
                     ' is not supported.';
                 Send_Message(ErrorMessage);
               Endif;                                                         //%Equal
               // Submit it to batch.
               ErrorMessage = 'The compile of ' +
                   %Trimr(SAMODULE) + ' has been submitted to batch.';
               Send_Message(ErrorMessage);
               CommandLine = 'SBMJOB CMD(' +
                   %Trimr(CommandLine) + ') JOB(' +
                   %Trimr(SAMEMBER) + ')';
               QCmdExec(CommandLine: CommandLength);
               Recno1 = Recno1 + 1;
               Chain Recno1 SY0030S1;
             Enddo;                                                           //%Found
             Iter;

             //*************************************************************************
             //* Rebuild program.
           When *IN19;                                                        //F19=Rebuild Program
             If Pi_Activation_Group_Attr =
                   '*DFTACTGRP';
               ErrorMessage = 'Cannot rebuild a default ' +
                   'activation group program.  Use option 15.';
               Send_Message(ErrorMessage);
               Iter;
             Endif;                                                           //Pi_Activation...
             If NotExist;
               ErrorMessage = 'Cannot rebuild.  One or more modules are ' +
                                'missing.';
               Send_Message(ErrorMessage);
               Iter;
             Else;
               CommandLength = %Size(CommandLine);
               CommandLine = '?CRTPGM ?*PGM(' +
                   %Trimr(SAPGMLIB) + '/' + %Trimr(SAPROGRAM) +
                   ') MODULE(';
               // Build the module list.
               Recno1 = 1;
               Chain Recno1 SY0030S1;
               Dow %Found;
                 CommandLine = %Trimr(CommandLine) + ' ' +
                     %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE);
                 Recno1 = Recno1 + 1;
                 Chain Recno1 SY0030S1;
               Enddo;                                                         //%Found
               // Build the service program list.
               CommandLine = %Trimr(CommandLine) +
                   ') BNDSRVPGM(';
               Recno5 = 1;
               Chain Recno5 SY0030S5;
               Dow %Found;
                 CommandLine = %Trimr(CommandLine) + ' ' +
                     %Trimr(SESRVLIB) + '/' + %Trimr(SESRVPGM);
                 Recno5 = Recno5 + 1;
                 Chain Recno5 SY0030S5;
               Enddo;                                                         //%Found
               // Tack on the compile release.
      /If Defined(Target_Release)
               CommandLine = %Trimr(CommandLine) +
                   ') TGTRLS(' +
                   Pi_Release_Created_For + ')';
      /Else
               CommandLine = %Trimr(CommandLine) +
                   ')';
      /Endif

               // Attach any command lines entered.
               If Not (SACMDLINE = *Blanks);
                 CommandLine = Attach_Options(CommandLine:
                     SACMDLINE);
               Endif;                                                         //Not (SACMDLINE...

               // Display the command prior to submitting.
               Clear_Message();
               Callp(E) QCmdCheck(CommandLine: CommandLength);
               If %Error;
                 Iter;
               Endif;                                                         //%Error
               ErrorMessage = 'The create of program ' +
                   %Trimr(SAPROGRAM) + ' has been submitted to batch.';
               Send_Message(ErrorMessage);
               CommandLine = 'SBMJOB CMD(' +
                   %Trimr(CommandLine) + ') JOB(' +
                   %Trimr(SAPROGRAM) + ')';
               QCmdExec(CommandLine: CommandLength);
               Iter;
             Endif;                                                           //NotExist

             //*************************************************************************
             // Display service programs.
           When *IN20;                                                        //F20=Display Service
             *INLR = Disp_Service_Program;                                    //    Programs
             If *INLR;
               //                  Callp     Rmv_Command_Line
               QUsDltUs(Md_SpaceName: DS_ErrorCode);
               QUsDltUs(Sp_SpaceName: DS_ErrorCode);
               Leave;
             Endif;                                                           //*INLR
             Iter;

             //*************************************************************************
             // Print all modules and service programs.
           When *IN21;                                                        //F21=Print List
             Print_List();
             ErrorMessage = 'The list has been printed.';
             Send_Message(ErrorMessage);
             Iter;

             //*************************************************************************
             // Display next function key list.
           When *IN24;                                                        //F24=More Keys
             *IN88 = Not *IN88;
             Iter;

             //*************************************************************************
             // Pageup
           When *IN25;                                                        //PageUp
             ErrorMessage =
                 'You have reached the top of the list.';
             Send_Message(ErrorMessage);
             Iter;

             //*************************************************************************
             // Pagedown
           When *IN26;                                                        //PageDown
             ErrorMessage =
                 'You have reached the bottom of the list.';
             Send_Message(ErrorMessage);
             Iter;

           Endsl;

           Readc SY0030S1;

           //*************************************************************************
           // Edit check options.
           No_Selection = *On;
           Dow Not %Eof;
             *IN30 = *Off;                                                    //Reverse Image

             Select;

             When SAOPTION = *Blanks;
               *IN50 = *Off;                                                  //SFLNXTCHG

               //*************************************************************************
               // Edit source member.
             When SAOPTION = '2 ' or SAOPTION = '02' or
                   SAOPTION = ' 2';
               *IN50 = *On;                                                   //SFLNXTCHG
               No_Selection = *Off;
               *IN99 = *Off;

               //*************************************************************************
               // Display source member.
             When SAOPTION = '5 ' or SAOPTION = '05' or
                   SAOPTION = ' 5';
               *IN50 = *On;                                                   //SFLNXTCHG
               No_Selection = *Off;
               *IN99 = *Off;

               //*************************************************************************
               // Display module details.
             When SAOPTION = '8 ' or SAOPTION = '08' or
                   SAOPTION = ' 8';
               *IN50 = *On;                                                   //SFLNXTCHG
               No_Selection = *Off;
               *IN99 = *Off;

               //*************************************************************************
               // Rebuild module.
             When SAOPTION = '15';
               *IN50 = *On;                                                   //SFLNXTCHG
               No_Selection = *Off;
               *IN99 = *Off;

               //*************************************************************************
               // Update program with current module.
             When SAOPTION = '16';
               *IN50 = *On;                                                   //SFLNXTCHG
               No_Selection = *Off;
               *IN99 = *Off;

             Other;
               *IN30 = *On;                                                   //Reverse Image
               ErrorMessage =
                   'Specified option number is not allowed.';
               Send_Message(ErrorMessage);
               *IN50 = *On;                                                   //SFLNXTCHG
               No_Selection = *Off;
               *IN99 = *Off;
               SFLCT1 = RECNO1;
             Endsl;
             Update SY0030S1;

             Readc SY0030S1;
           Enddo;                                                             //Not %Eof

           //*************************************************************************
           // Handle if a command line entered and no selection made.
           If No_Selection and Not (SACMDLINE = *Blanks);
             CommandLine = SACMDLINE;
             // Either edit check the command line or, if prompted, prompt.
             CommandLength = %Size(CommandLine);
             If *IN04;                                                        //If prompted
               CP_PromptAct = '1';
               Callp(E) QCapCommand(CommandLine: CommandLength:
                   DS_CPOP0100: %Size(DS_CPOP0100): 'CPOP0100':
                   CommandLine: CommandLength: Bin04:
                   DS_DummyError);
             Else;
               Callp(E) QCmdCheck(CommandLine: CommandLength);
             Endif;                                                           //*IN04
             If %Error;
               Add_Command_Line(CommandLine);                                 //If error, retain.
               *IN99 = *On;                                                   //Position to Line
               CSRROW = CmdRow;
               CSRCOL = CmdCol;
               Iter;
             Endif;                                                           //%Error
             Add_Command_Line(CommandLine);                                   //Save command
             *IN99 = *On;                                                     //Position to Line
             CSRROW = CmdRow;
             CSRCOL = CmdCol;
             // Then run it.
             Callp(E) QCmdExec(CommandLine: CommandLength);
             If %Error;
               Iter;
             Endif;                                                           //%Error
             Clear SACMDLINE;
             Iter;
           Endif;                                                             //No_Selection...

           //*************************************************************************
           // If no selection made and F4=Prompt hasn't been pressed, assume exit.
           If No_Selection and Not *IN04;
             *INLR = *On;
             //                  Callp     Rmv_Command_Line
             QUsDltUs(Md_SpaceName: DS_ErrorCode);
             QUsDltUs(Sp_SpaceName: DS_ErrorCode);
             Leave;
           Endif;                                                             //No_Selection...

           //*************************************************************************
           // If no selection was made and prompting was pressed,
           // display error message.
           If No_Selection and *IN04;
             ErrorMessage =
                 'Prompting is not allowed at this time.';
             Send_Message(ErrorMessage);
             Iter;
           Endif;                                                             //No_Selection...

           If Not (ErrorMessage = *Blanks);
             Iter;
           Endif;                                                             //Not (ErrorMessage...

           //*************************************************************************
           // Handle options.
           //                  Clear                   Cur_Retrieve                   Reset Pos in H
           Readc SY0030S1;
           Dow Not %Eof;

             Select;

               //*************************************************************************
               // Edit module source with SEU.
             When SAOPTION = '2 ' or SAOPTION = '02' or
                   SAOPTION = ' 2';
               SFLCT1 = RECNO1;
               CommandLength = %Size(CommandLine);
               If *IN04;                                                      //F4=Prompt
                 CommandLine = '?STRSEU ?*SRCFILE(' +
                     %Trimr(SASRCLIB) + '/' + %Trimr(SASOURCE) +
                     ') ?*SRCMBR(' + %Trimr(SAMEMBER) +
                     ') ?*TYPE(' + %Trimr(SAMODATTR) +
                     ') ?*OPTION(2)';
               Else;
                 CommandLine = 'STRSEU SRCFILE(' +
                     %Trimr(SASRCLIB) + '/' + %Trimr(SASOURCE) +
                     ') SRCMBR(' + %Trimr(SAMEMBER) +
                     ') TYPE(' + %Trimr(SAMODATTR) + ') OPTION(2)';
               Endif;                                                         //*IN04

               // Attach any command lines entered.
               If Not (SACMDLINE = *Blanks);
                 CommandLine = Attach_Options(CommandLine:
                     SACMDLINE);
               Endif;                                                         //Not (SACMDLINE...

               Callp(E) QCmdCheck(CommandLine: CommandLength);
               If %Error;
                 *IN50 = *On;                                                 //SFLNXTCHG
                 Update SY0030S1;
                 Leave;
               Endif;                                                         //%Error
               Callp(E) QCmdExec(CommandLine: CommandLength);
               If %Error;
                 *IN50 = *On;                                                 //SFLNXTCHG
                 Update SY0030S1;
                 Leave;
               Endif;                                                         //%Error
               Clear SAOPTION;
               Update SY0030S1;

               //*************************************************************************
               // Display module source with SEU.
             When SAOPTION = '5 ' or SAOPTION = '05' or
                   SAOPTION = ' 5';
               SFLCT1 = RECNO1;
               CommandLength = %Size(CommandLine);
               If *IN04;                                                      //F4=Prompt
                 CommandLine = '?STRSEU ?*SRCFILE(' +
                     %Trimr(SASRCLIB) + '/' + %Trimr(SASOURCE) +
                     ') ?*SRCMBR(' + %Trimr(SAMEMBER) +
                     ') ?*TYPE(' + %Trimr(SAMODATTR) +
                     ') ?*OPTION(5)';
               Else;
                 CommandLine = 'STRSEU SRCFILE(' +
                     %Trimr(SASRCLIB) + '/' + %Trimr(SASOURCE) +
                     ') SRCMBR(' + %Trimr(SAMEMBER) +
                     ') TYPE(' + %Trimr(SAMODATTR) + ') OPTION(5)';
               Endif;                                                         //*IN04

               // Attach any command lines entered.
               If Not (SACMDLINE = *Blanks);
                 CommandLine = Attach_Options(CommandLine:
                     SACMDLINE);
               Endif;                                                         //Not (SACMDLINE...

               Callp(E) QCmdCheck(CommandLine: CommandLength);
               If %Error;
                 *IN50 = *On;                                                 //SFLNXTCHG
                 Update SY0030S1;
                 Leave;
               Endif;                                                         //%Error
               Callp(E) QCmdExec(CommandLine: CommandLength);
               If %Error;
                 *IN50 = *On;                                                 //SFLNXTCHG
                 Update SY0030S1;
                 Leave;
               Endif;                                                         //%Error
               Clear SAOPTION;
               Update SY0030S1;

               //*************************************************************************
               // Display module information.
             When SAOPTION = '8 ' or SAOPTION = '08' or
                   SAOPTION = ' 8';
               SFLCT1 = RECNO1;
               If *IN04;                                                      //Prompted?
                 CommandLine = '?DSPMOD ?*MODULE(' +
                     %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                     ')';
               Else;                                                          //Not Prompted
                 CommandLine = 'DSPMOD MODULE(' +
                     %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                     ')';
               Endif;                                                         //*IN04

               // Attach any command lines entered.
               If Not (SACMDLINE = *Blanks);
                 CommandLine = Attach_Options(CommandLine:
                     SACMDLINE);
               Endif;                                                         //Not (SACMDLINE...

               CommandLength = %Size(CommandLine);
               Callp(E) QCmdCheck(CommandLine: CommandLength);
               If %Error;
                 *IN50 = *On;                                                 //SFLNXTCHG
                 Update SY0030S1;
                 Leave;
               Endif;                                                         //%Error
               Callp(E) QCmdExec(CommandLine: CommandLength);
               If %Error;
                 *IN50 = *On;                                                 //SFLNXTCHG
                 Update SY0030S1;
                 Leave;
               Endif;                                                         //%Error
               Clear SAOPTION;
               Update SY0030S1;

               //*************************************************************************
               // Rebuild module.
             When SAOPTION = '15';
               SFLCT1 = RECNO1;
               CommandLength = %Size(CommandLine);
               // If prompted
               If *IN04;                                                      //F4=Prompt
                 If Not (Pi_Activation_Group_Attr =
                       '*DFTACTGRP');
                   // Find the appropriate command for the create.
                   C = 1;
                   C = %Lookup(SAMODATTR: ModAtt);
                   If Not (C = 0);
      /If Defined(Target_Release)
                     CommandLine = '?' + %Trimr(ModCmd(C)) +
                         ' ?*MODULE(' +
                         %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                         ') ?*SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                         %Trimr(SASOURCE) + ') ?*SRCMBR(' +
                         %Trimr(SAMEMBER) + ') ' + 'TGTRLS(' +
                         Pi_Release_Created_For + ')';
      /Else
                     CommandLine = '?' + %Trimr(ModCmd(C)) +
                         ' ?*MODULE(' +
                         %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                         ') ?*SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                         %Trimr(SASOURCE) + ') ?*SRCMBR(' +
                         %Trimr(SAMEMBER) + ')';
      /Endif
                   Else;
                     ErrorMessage = 'Module attribute ' +
                         %Trimr(SAMODATTR) +
                         ' for member ' + %Trimr(SAMEMBER) +
                         ' is not supported.';
                     Send_Message(ErrorMessage);
                   Endif;                                                     //%Equal
                 Else;
                   // Find the appropriate command for the create.
                   C = 1;
                   C = %Lookup(SAMODATTR: ModAtt);
                   If Not (C = 0);
      /If Defined(Target_Release)
                     CommandLine = '?' + %Trimr(BndCmd(C)) +
                         ' ?*PGM(' +
                         %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                         ') ?*SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                         %Trimr(SASOURCE) + ') ?*SRCMBR(' +
                         %Trimr(SAMEMBER) + ') ' + 'TGTRLS(' +
                         Pi_Release_Created_For + ')';
      /Else
                     CommandLine = '?' + %Trimr(BndCmd(C)) +
                         ' ?*PGM(' +
                         %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                         ') ?*SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                         %Trimr(SASOURCE) + ') ?*SRCMBR(' +
                         %Trimr(SAMEMBER) + ')';
      /Endif
                   Else;
                     ErrorMessage = 'Module attribute ' +
                         %Trimr(SAMODATTR) +
                         ' for member ' + %Trimr(SAMEMBER) +
                         ' is not supported.';
                     Send_Message(ErrorMessage);
                   Endif;                                                     //%Equal
                 Endif;                                                       //Not (Pi_Activa...

                 // Attach any command lines entered.
                 If Not (SACMDLINE = *Blanks);
                   CommandLine = Attach_Options(CommandLine:
                       SACMDLINE);
                 Endif;                                                       //Not (SACMDLINE...

                 // Edit check the command line.
                 Callp(E) QCmdCheck(CommandLine: CommandLength);
                 If %Error;
                   *IN50 = *On;                                               //SFLNXTCHG
                   Update SY0030S1;
                   Leave;
                 Endif;                                                       //%Error
                 // Submit the compile to batch.
                 ErrorMessage = 'The compile of ' +
                     %Trimr(SAMEMBER) + ' has been submitted to batch.';
                 Send_Message(ErrorMessage);
                 CommandLine = 'SBMJOB CMD(' +
                     %Trimr(CommandLine) + ') JOB(' +
                     %Trimr(SAMEMBER) + ')';
                 QCmdExec(CommandLine: CommandLength);
               Else;
                 // If unprompted
                 If Not (Pi_Activation_Group_Attr =
                       '*DFTACTGRP');
                   // Find the appropriate command for the create.
                   C = 1;
                   C = %Lookup(SAMODATTR: ModAtt);
                   If Not (C = 0);
      /If Defined(Target_Release)
                     CommandLine = %Trimr(ModCmd(C)) +
                         ' MODULE(' +
                         %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                         ') SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                         %Trimr(SASOURCE) + ') SRCMBR(' +
                         %Trimr(SAMEMBER) + ') ' + 'TGTRLS(' +
                         Pi_Release_Created_For + ')';
      /Else
                     CommandLine = %Trimr(ModCmd(C)) +
                         ' MODULE(' +
                         %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                         ') SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                         %Trimr(SASOURCE) + ') SRCMBR(' +
                         %Trimr(SAMEMBER) + ')';
      /Endif
                   Else;
                     ErrorMessage = 'Module attribute ' +
                         %Trimr(SAMODATTR) +
                         ' for member ' + %Trimr(SAMEMBER) +
                         ' is not supported.';
                     Send_Message(ErrorMessage);
                   Endif;                                                     //%Equal
                 Else;
                   // Find the appropriate command for the create.
                   C = 1;
                   C = %Lookup(SAMODATTR: ModAtt);
                   If Not (C = 0);
      /If Defined(Target_Release)
                     CommandLine = %Trimr(BndCmd(C)) + ' PGM(' +
                         %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                         ') SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                         %Trimr(SASOURCE) + ') SRCMBR(' +
                         %Trimr(SAMEMBER) + ') ' + 'TGTRLS(' +
                         Pi_Release_Created_For + ')';
      /Else
                     CommandLine = %Trimr(BndCmd(C)) + ' PGM(' +
                         %Trimr(SALIBRARY) + '/' + %Trimr(SAMODULE) +
                         ') SRCFILE(' + %Trimr(SASRCLIB) + '/' +
                         %Trimr(SASOURCE) + ') SRCMBR(' +
                         %Trimr(SAMEMBER) + ')';
      /Endif
                   Else;
                     ErrorMessage = 'Module attribute ' +
                         %Trimr(SAMODATTR) +
                         ' for member ' + %Trimr(SAMEMBER) +
                         ' is not supported.';
                     Send_Message(ErrorMessage);
                   Endif;                                                     //%Equal
                 Endif;                                                       //Not (Pi_Activa...

                 // Attach any command lines entered.
                 If Not (SACMDLINE = *Blanks);
                   CommandLine = Attach_Options(CommandLine:
                       SACMDLINE);
                 Endif;                                                       //Not (SACMDLINE...

                 // Edit check the command line.
                 Callp(E) QCmdCheck(CommandLine: CommandLength);
                 If %Error;
                   *IN50 = *On;                                               //SFLNXTCHG
                   Update SY0030S1;
                   Leave;
                 Endif;                                                       //%Error

                 // Submit the compile to batch.
                 ErrorMessage = 'The compile of ' +
                     %Trimr(SAMEMBER) + ' has been submitted to batch.';
                 Send_Message(ErrorMessage);
                 CommandLine = 'SBMJOB CMD(' +
                     %Trimr(CommandLine) +
                     ') JOB(' + %Trimr(SAMEMBER) + ')';
                 Callp(E) QCmdExec(CommandLine: CommandLength);
                 If %Error;
                   *IN50 = *On;                                               //SFLNXTCHG
                   Update SY0030S1;
                   Leave;
                 Endif;                                                       //%Error
               Endif;                                                         //*IN04
               Clear SAOPTION;
               Update SY0030S1;

               //*************************************************************************
               // Update Program with Module.
             When SAOPTION = '16';
               SFLCT1 = RECNO1;
               CommandLength = %Size(CommandLine);
               If Pi_Allow_Update = 'Y';
                 // If prompted.
                 If *IN04;                                                    //F4=Prompt
                   CommandLine = '?UPDPGM ?*PGM(' +
                       %Trimr(SAPGMLIB) + '/' + %Trimr(SAPROGRAM)
                       + ') ?*MODULE(' + %Trimr(SALIBRARY) +
                       '/' + %Trimr(SAMODULE) + ')';
                 Else;
                   // Non-Prompted.
                   CommandLine = 'UPDPGM PGM(' +
                       %Trimr(SAPGMLIB) + '/' + %Trimr(SAPROGRAM)
                       + ') MODULE(' + %Trimr(SALIBRARY) +
                       '/' + %Trimr(SAMODULE) + ')';
                 Endif;                                                       //*IN04

                 // Attach any command lines entered.
                 If Not (SACMDLINE = *Blanks);
                   CommandLine = Attach_Options(CommandLine:
                       SACMDLINE);
                 Endif;                                                       //Not (SACMDLINE...

                 // Edit check command line.
                 Callp(E) QCmdCheck(CommandLine: CommandLength);
                 If %Error;
                   *IN50 = *On;                                               //SFLNXTCHG
                   Update SY0030S1;
                   Leave;
                 Endif;                                                       //%Error

                 // Submit the job to batch.
                 ErrorMessage = 'The update of ' +
                     %Trimr(SAPROGRAM) + ' has been submitted to batch.';
                 Send_Message(ErrorMessage);
                 CommandLine = 'SBMJOB CMD(' +
                     %Trimr(CommandLine) +
                     ') JOB(' + %Trimr(SAMEMBER) + ')';
                 Callp(E) QCmdExec(CommandLine: CommandLength);
                 If %Error;
                   *IN50 = *On;                                               //SFLNXTCHG
                   Update SY0030S1;
                   Leave;
                 Endif;                                                       //%Error
               Else;
                 // Not updateable error message.
                 ErrorMessage = 'This program does not ' +
                     'allow module updates.';
                 Send_Message(ErrorMessage);
                 *IN50 = *On;
                 Update SY0030S1;
                 Leave;
               Endif;                                                         //Pi_Activation...
               Clear SAOPTION;
               Update SY0030S1;

             Endsl;

             Readc SY0030S1;
           Enddo;                                                             //Not %Eof

           //*************************************************************************
           If Not %Error;
             Clear SACMDLINE;
             If ErrorMessage = *Blanks;
               ErrorMessage = *Blanks;
               Send_Message(ErrorMessage);
             Endif;                                                           //ErrorMessage...
           Endif;                                                             //Not %Error

         Enddo;                                                               //Not *INLR

       Enddo;                                                                 //Not *INLR
      /Eject
       //*************************************************************************
       // Exception_Err - Subroutine to pass error up and quit.                  *
       //*************************************************************************
       Begsr Exception_Err;
         PSM_MsgId = ER_ExcId;
         PSM_Length = %Size(ER_Data);
         PSM_MsgType = '*ESCAPE';
         PSM_CallStack = 3;
         Send_Message(ER_Data);
         *INLR = *On;
       Endsr;                                                                 //Exception_Err

      /Eject
       //*************************************************************************
       // Send_Message - Send message to program message queue.                  *
       //*************************************************************************
      /End-Free
     P Send_Message    B

     D Send_Message    PI
     D   ErrorMessage             32767    Options(*VarSize)

      /Free
       Send_PgmMessage(PSM_MsgID: PSM_QLMsgFile:
           ErrorMessage: PSM_Length: PSM_MsgType:
           PSM_CallQ: PSM_CallStack: PSM_MsgKey:
           DS_ErrorCode);

      /End-Free
     P Send_Message    E
      /Eject
      //*************************************************************************
      // Clear_Message - Clear all messages from program message queue.         *
      //*************************************************************************
     P Clear_Message   B

     D Clear_Message   PI

      /Free
       Remove_PgmMessage(PRM_CallQ: PRM_CallStack:
           PRM_MsgKey: PRM_MsgToRemove: DS_ErrorCode);

      /End-Free
     P Clear_Message   E

     C/Eject
      //*************************************************************************
      // Print_List - Print the list to the printer.                            *
      //*************************************************************************
     P Print_List      B

     D Print_List      PI

     D CommandLine     S            256
     D CommandLength   S             15P 5

      /Free
       CommandLine = 'OVRPRTF FILE(SY0030P) -
           USRDTA(' + %Trimr(SAPROGRAM) + ')';
       CommandLength = %Size(CommandLine);
       QCmdExec(CommandLine: CommandLength);
       Open SY0030P;
       // Print module information.
       Recno1 = 1;
       Write SY0030H;
       Write SY0030H1;
       Chain Recno1 SY0030S1;
       Dow %Found;
         If OverFlow;
           Write SY0030H;
           Write SY0030H1;
           Overflow = *Off;
         Endif;                                                               //OverFlow
         Write(E) SY0030D;
         If %Error;                                                           //If End of File
           OverFlow = *On;                                                    //turn OverFlow On.
         Endif;                                                               //%Error
         Recno1 = Recno1 + 1;
         Chain Recno1 SY0030S1;
       Enddo;                                                                 //%Found

       // Print service program information.
       Recno5 = 1;
       If Not OverFlow;
         Write SY0030H2;
       Endif;                                                                 //Not *IN90
       Chain Recno5 SY0030S5;
       Dow %Found;
         If OverFlow;
           Write SY0030H;
           Write SY0030H2;
           OverFlow = *Off;
         Endif;                                                               //OverFlow
         Write(E) SY0030D2;
         If %Error;
           OverFlow = *On;
         Endif;                                                               //%Error
         Recno5 = Recno5 + 1;
         Chain Recno5 SY0030S5;
       Enddo;                                                                 //%Found
       Close SY0030P;
       CommandLine = 'DLTOVR FILE(SY0030P)';
       CommandLength = %Size(CommandLine);
       QCmdExec(CommandLine: CommandLength);

      /End-Free
     P Print_List      E

     C/Eject
      //*************************************************************************
      // Build_Directory - Build a binding directory.                           *
      //*************************************************************************
     P Build_Directory...
     P                 B

     D Build_Directory...
     D                 PI              N

      // First see if the binding directory is there.
      /Free
       POB_QLObject = SAPROGRAM + SAPGMLIB;
       Clear Er_ExcId;
       POB_ObjectType = '*BNDDIR';
       QUsrObjD(DS_OBJD0200: POB_Length: POB_Format:
           POB_QLObject: POB_ObjectType: DS_ErrorCode);
       If Er_ExcId = *Blanks;
         SBOBJECT = SAPROGRAM;
         SBLIBRARY = SAPGMLIB;
         SBOBJTYPE = '*BNDDIR';
         SBCONFIRM = 'N';
         Exfmt SY003004;
         If *IN12 or SBCONFIRM = 'N';
           Return *On;
         Endif;                                                               //*IN12
         CommandLine = 'DLTBNDDIR BNDDIR(' +
             %Trimr(SAPGMLIB) + '/' + %Trimr(SAPROGRAM) +
             ')';
         CommandLength = %Size(CommandLine);
         Callp(E) QCmdExec(CommandLine: CommandLength);
         If %Error;
           Return *On;
         Endif;                                                               //%Error
       Endif;                                                                 //Not (Er_ExcId...

       // Now, create the binding directory.
       CommandLine = 'CRTBNDDIR BNDDIR(' +
           %Trimr(SAPGMLIB) + '/' + %Trimr(SAPROGRAM) +
           ') TEXT(' + Tick + 'Binding directory for-
           program ' + %Trimr(SAPROGRAM) + '.' + Tick +
           ')';
       CommandLength = %Size(CommandLine);
       Callp(E) QCmdExec(CommandLine: CommandLength);
       If %Error;
         Return *On;
       Endif;                                                                 //%Error

       // Now add all of the binding directory entries.
       Recno1 = 1;
       Chain Recno1 SY0030S1;
       Dow %Found;
         CommandLine = 'ADDBNDDIRE BNDDIR(' +
             %Trimr(SAPGMLIB) + '/' + %Trimr(SAPROGRAM) +
             ') OBJ((' + %Trimr(SALIBRARY) + '/' +
             %Trimr(SAMODULE) + ' *MODULE))';
         CommandLength = %Size(CommandLine);
         Callp(E) QCmdExec(CommandLine: CommandLength);
         If %Error;
           Return *On;
         Endif;
         Recno1 = Recno1 + 1;
         Chain Recno1 SY0030S1;
       Enddo;                                                                 //%Found
       Return *Off;

      /End-Free
     P Build_Directory...
     P                 E

     C/Eject
      //*************************************************************************
      // Disp_Service_Program - Display all service programs.                   *
      //*************************************************************************
     P Disp_Service_Program...
     P                 B

     D Disp_Service_Program...
     D                 PI              N

      // Work fields.
     D Exit_Proc       S               N
     D No_Selection    S               N

      // Display screen and process options and function keys.
      /Free
       Exit_Proc = *Off;
       SFLCT5 = 1;
       Dow Not Exit_Proc;
         Write MSGSFC1;
         Write SY0030B5;
         If Not *IN69;
           Write SY003006;
         Endif;                                                               //Not *IN67
         Exfmt SY0030C5;
         Clear_Message();
         Clear ErrorMessage;
         SFLCT5 = Cur_Page;

         // Handle function keys.
         Select;
         When *IN03;                                                          //F3=Exit
           Exit_Proc = *On;
           Return Exit_Proc;

         When *IN12;                                                          //F12=Cancel
           Exit_Proc = *Off;
           Return Exit_Proc;

         When *IN25;                                                          //PageUp
           ErrorMessage =
               'You have reached the top of the list.';
           Send_Message(ErrorMessage);
           Iter;

         When *IN26;                                                          //PageDown
           ErrorMessage =
               'You have reached the bottom of the list.';
           Send_Message(ErrorMessage);
           Iter;

         Endsl;

         Readc SY0030S5;
         If %Eof and Not *IN04;
           Return *Off;
         Endif;                                                               //%Eof

         // Edit check options.
         No_Selection = *On;
         Clear SFLCT5;
         Dow Not %Eof;
           *IN30 = *Off;                                                      //Reverse Image

           Select;

           When SEOPTION = *Blanks;
             *IN51 = *Off;

           When SEOPTION = '5';
             *IN51 = *On;
             No_Selection = *Off;
             If SFLCT5 = *Zeros;
               SFLCT5 = RECNO5;
             Endif;                                                           //SFLCT5 = *Zeros

           Other;
             *IN30 = *On;                                                     //Reverse Image
             ErrorMessage =
                 'Specified option number is not allowed.';
             Send_Message(ErrorMessage);
             *IN51 = *On;
             No_Selection = *Off;
             If SFLCT5 = *Zeros;
               SFLCT5 = RECNO5;
             Endif;                                                           //SFLCT1 = *Zeros
           Endsl;
           Update SY0030S5;

           Readc SY0030S5;
         Enddo;                                                               //Not %Eof

         If No_Selection and Not *IN04;
           Return *Off;
         Endif;                                                               //No_Selection...

         If No_Selection and *IN04;
           If SFLCT5 = *Zeros;
             If Cur_Page = *Zeros;
               SFLCT5 = 1;
             Else;
               SFLCT5 = Cur_Page;
             Endif;                                                           //Cur_Page = 0
           Endif;                                                             //SFLCT5 = *Zeros
           ErrorMessage =
               'Prompting is not allowed at this time.';
           Send_Message(ErrorMessage);
           Iter;
         Endif;                                                               //Not_Selection...

         If Not (ErrorMessage = *Blanks);
           Iter;
         Endif;                                                               //Not (ErrorMessage...

         // Handle options.
         Readc SY0030S5;
         Dow Not %Eof;

           Select;

             // Display service program detail.
           When SEOPTION = '5';
             CommandLength = %Size(CommandLine);
             If *IN04;                                                        //F4=Prompt
               CommandLine = '?DSPSRVPGM ?*SRVPGM(' +
                   %Trimr(SESRVLIB) + '/' + %Trimr(SESRVPGM) +
                   ')';
               Callp(E) QCmdExec(CommandLine: CommandLength);
               If %Error;
                 *IN51 = *On;
                 Update SY0030S5;
                 Leave;
               Endif;                                                         //%Error
             Else;
               CommandLine = 'DSPSRVPGM SRVPGM(' +
                   %Trimr(SESRVLIB) + '/' + %Trimr(SESRVPGM) +
                   ')';
               Callp(E) QCmdExec(CommandLine: CommandLength);
               If %Error;
                 *IN51 = *On;
                 Update SY0030S5;
                 Leave;
               Endif;                                                         //%Error
             Endif;                                                           //*IN04
             Clear SEOPTION;
             Update SY0030S5;
           Endsl;

           SFLCT5 = Recno5;

           Readc SY0030S5;
         Enddo;                                                               //Not %Eof

         If ErrorMessage = *Blanks and Not %Error;
           ErrorMessage = *Blanks;
           Send_Message(ErrorMessage);
         Endif;                                                               //ErrorMessage...

         // If a selection was made, redisplay screen.
         If Not No_Selection;
           Iter;
         Endif;                                                               //No_Select = *Off

         Return Exit_Proc;
       Enddo;                                                                 //Not (Exit_Proc ...

      /End-Free
     P Disp_Service_Program...
     P                 E
      /Eject
      //*************************************************************************
      // Add_Command_Line - Add a command line to the history array.            *
      //*************************************************************************
     P Add_Command_Line...
     P                 B

     D Add_Command_Line...
     D                 PI                  OpDesc
     D   CommandLine              32702    Options(*VarSize)

      // Procedure prototype for CEEDOD (Retrieve operational descriptors)
     D CEEDOD          PR
     D  ParmNum                      10I 0 Const
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               12A   Options(*Omit)

      // Parameters for CEEDOD
     D DescType        S             10I 0
     D DataType        S             10I 0
     D DescInfo1       S             10I 0
     D DescInfo2       S             10I 0
     D InLen           S             10I 0                                      Command Length

      // Work fields
     D CommandLength   S              5U 0                                      Command Length

      // Call CEEDOD to get the types and legnths of the input parameters.
      /Free
       CEEDOD(1: DescType: DataType: DescInfo1:
           DescInfo2: InLen: *Omit);

       // Check for the ? in position 1.
       If %Subst(CommandLine:1:1) = '?';
         CommandLength = %Len(%Trimr(%Subst(
             CommandLine:2)));
         CommandLine = %Subst(CommandLine:2:
             CommandLength);
       Endif;                                                                 //%Subst(Command...

       // Send the message to the call stack message queue.
       RSM_Length = %Len(%Trimr(CommandLine));
       Send_PgmMessage(RSM_MsgID: RSM_QLMsgFile:
           CommandLine: RSM_Length: RSM_MsgType:
           RSM_CallQ: RSM_CallStack: RSM_MsgKey:
           DS_ErrorCode);

       // Now pop the message back off.
       Callp(E) Receive_PgmMessage(DS_RCVM0100:
           %Len(DS_RCVM0100): 'RCVM0100':
           '*EXT': 0: '*RQS': RSM_MsgKey:
           0: '*OLD': DS_ErrorCode);

      /End-Free
     P Add_Command_Line...
     P                 E
      /Eject
      //*************************************************************************
      // Retrieve_Command_Line - Retrieve previous command.                     *
      //*************************************************************************
     P Retrieve_Command_Line...
     P                 B

     D Retrieve_Command_Line...
     D                 PI                  Like(CommandLine)

     D Current_Msg     S              4    Static                               Current Message
     D Hex_00          C                   X'00000000'

      /Free
       If Current_Msg = *Blanks or
             SACMDLINE = *Blanks;
         Current_Msg = Hex_00;
       Endif;                                                                 //Current_Msg...

       Clear DS_RTVQ0100;
       Callp(E) Receive_RqsMessage(DS_RTVQ0100:
           %Len(DS_RTVQ0100): 'RTVQ0100':
           '*PRV': Current_Msg: DS_ErrorCode);
       If RM_BytesAva = 0;
         Current_Msg = Hex_00;
         Callp(E) Receive_RqsMessage(DS_RTVQ0100:
             %Len(DS_RTVQ0100): 'RTVQ0100':
             '*PRV': Current_Msg: DS_ErrorCode);
         If RM_BytesAva = 0;
           Return *Blanks;
         Else;
           Current_Msg = RM_MsgKey;
           Return RM_Text;
         Endif;                                                               //RM_BytesAva...
       Else;
         Current_Msg = RM_MsgKey;
         Return RM_Text;
       Endif;                                                                 //RM_BytesAva...

      /End-Free
     P Retrieve_Command_Line...
     P                 E
      /Eject
      //*************************************************************************
      // Attach_Options - Attach options to end of command line for prompted    *
      //                  options.                                              *
      //*************************************************************************
     P Attach_Options...
     P                 B

     D Attach_Options...
     D                 PI         32702    OpDesc
     D  CommandLine               32702    Options(*VarSize)
     D  Options                   32702    Options(*VarSize)

      // Procedure prototype for CEEDOD (Retrieve operational descriptors)
     D CEEDOD          PR
     D  ParmNum                      10I 0 Const
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               12A   Options(*Omit)

      // Parameters for CEEDOD
     D DescType        S             10I 0
     D DataType        S             10I 0
     D DescInfo1       S             10I 0
     D DescInfo2       S             10I 0
     D InLen1          S             10I 0                                      Command Length
     D InLen2          S             10I 0                                      Command Length

      // Call CEEDOD to get the types and legnths of the input parameters.
      /Free
       CEEDOD(1: DescType: DataType: DescInfo1:
           DescInfo2: InLen1: *Omit);
       CEEDOD(2: DescType: DataType: DescInfo1:
           DescInfo2: InLen2: *Omit);

       Return %Trimr(%Subst(CommandLine: 1: InLen1)) + ' '
           + %Trim(%Subst(Options: 1: InLen2));

      /End-Free
     P Attach_Options...
     P                 E
      /Eject

** CtData ModAtt
RPGLE
CLLE
CBLLE
CLE
** CtData ModCmd
CRTRPGMOD
CRTCLMOD
CRTCBLMOD
CRTCMOD
** CtData BndCmd
CRTBNDRPG
CRTBNDCL
CRTBNDCBL
CRTBNDC

The DDS for the Screen – SY0030FM

     A*%%TS  SD  20010430  153003  LANHAMJ     REL-V4R4M0  5769-PW1
     A*%%EC
     A                                      DSPSIZ(24 80 *DS3)
     A                                      PRINT
     A                                      HELP
     A          R SY0030S1                  SFL
     A*%%TS  SD  20010430  153003  LANHAMJ     REL-V4R4M0  5769-PW1
     A  50                                  SFLNXTCHG
     A            SAMODATTR     10A  H
     A            SACREATETM    10A  H
     A            SASRCCHGDT    10A  H
     A            SASRCCHGTM    10A  H
     A            SAMODTEXT     50A  H
     A            SAOPTION       2A  B 12  2
     A  30                                  DSPATR(RI)
     A            SAMODULE      10A  O 12  7
     A            SALIBRARY     10A  O 12 19
     A            SASOURCE      10A  O 12 31
     A            SASRCLIB      10A  O 12 43
     A            SAMEMBER      10A  O 12 55
     A            SACREATEDT    10A  O 12 67
     A          R SY0030C1                  SFLCTL(SY0030S1)
     A*%%TS  SD  20010430  153003  LANHAMJ     REL-V4R4M0  5769-PW1
     A                                      CA03(03 'Exit')
     A                                      CA12(12 'Cancel')
     A                                      PAGEUP(25 'Page Up')
     A                                      PAGEDOWN(26 'Page Down')
     A                                      CA13(13 'Build Binding Directory')
     A                                      CA18(18 'Recreate All')
     A                                      CA19(19 'Recreate Program')
     A                                      CA21(21 'Print List')
     A                                      CF04(04 'Prompt')
     A                                      CA05(05 'Refresh')
     A                                      CF09(09 'Retrieve')
     A                                      CA24(24 'More Keys')
     A                                      CA20(20 'Service Programs')
     A                                      CA06(06 'Add Module')
     A                                      CA14(14 'Display Program')
     A                                      RTNCSRLOC(*WINDOW &RTNROW &RTNCOL)
     A  99                                  CSRLOC(CSRROW     CSRCOL)
     A                                      OVERLAY
     A  67                                  SFLDSP
     A N66                                  SFLDSPCTL
     A  66                                  SFLCLR
     A N55                                  SFLEND(*MORE)
     A                                      SFLSIZ(0008)
     A                                      SFLPAG(0007)
     A            CSRROW         3S 0H
     A            CSRCOL         3S 0H
     A            RTNCOL         3S 0H
     A            RTNROW         3S 0H
     A            SFLCT1         4S 0H      SFLRCDNBR(CURSOR)
     A                                  1 26'Work with ILE Program Modules'
     A                                      DSPATR(HI)
     A                                  1 72SYSNAME
     A                                  3  2'Program . . . . . :'
     A            SAPROGRAM     10A  O  3 22
     A                                  4  4'Library . . . . :'
     A            SAPGMLIB      10A  O  4 24
     A                                  6  2'Type options, press Enter.'
     A                                      COLOR(BLU)
     A                                  7  4'2=Edit Source'
     A                                      COLOR(BLU)
     A                                  7 24'5=Display Source'
     A                                      COLOR(BLU)
     A                                  7 54'8=Display Details'
     A                                      COLOR(BLU)
     A                                  8  4'15=Rebuild Module'
     A                                      COLOR(BLU)
     A                                  8 24'16=Update Module in Program'
     A                                      COLOR(BLU)
     A                                 10  7'Module'
     A                                      DSPATR(HI)
     A                                 10 19'Library'
     A                                      DSPATR(HI)
     A                                 10 31'Source'
     A                                      DSPATR(HI)
     A                                 10 43'Source'
     A                                      DSPATR(HI)
     A                                 10 55'Member'
     A                                      DSPATR(HI)
     A                                 10 69'Create'
     A                                      DSPATR(HI)
     A                                 11  2'Opt'
     A                                      DSPATR(HI)
     A                                 11  7'Name'
     A                                      DSPATR(HI)
     A                                 11 19'Name'
     A                                      DSPATR(HI)
     A                                 11 31'File'
     A                                      DSPATR(HI)
     A                                 11 43'Library'
     A                                      DSPATR(HI)
     A                                 11 55'Name'
     A                                      DSPATR(HI)
     A                                 11 70'Date'
     A                                      DSPATR(HI)
     A          R SY0030B1
     A*%%TS  SD  19981231  123304  ICILANHAM   REL-V4R2M0  5769-PW1
     A                                      OVERLAY
     A                                 20  2'Parameters or command'
     A                                 21  2'===>'
     A            SACMDLINE     73A  B 21  7
     A                                      CHECK(LC)
     A N88                             22  2'F3=Exit'
     A                                      COLOR(BLU)
     A                                 22  2'F14=Display Program'
     A                                      COLOR(BLU)
     A N88                             22 20'F4=Prompt'
     A                                      COLOR(BLU)
     A  88                             22 24'F18=Rebuild All Modules'
     A                                      COLOR(BLU)
     A N88                             22 34'F5=Refresh'
     A                                      COLOR(BLU)
     A  88                             22 50'F19=Rebuild Program'
     A                                      COLOR(BLU)
     A N88                             22 56'F6=Add Module'
     A                                      COLOR(BLU)
     A  88                             23  2'F21=Print List'
     A                                      COLOR(BLU)
     A N88                             23  2'F9=Retrieve'
     A                                      COLOR(BLU)
     A N88                             23 20'F12=Cancel'
     A                                      COLOR(BLU)
     A  88                             23 24'F20=Service Programs'
     A                                      COLOR(BLU)
     A N88                             23 34'F13=Build Directory'
     A                                      COLOR(BLU)
     A  88                             23 50'F24=More Keys'
     A                                      COLOR(BLU)
     A N88                             23 56'F24=More Keys'
     A                                      COLOR(BLU)
     A          R SY003002
     A*%%TS  SD  19990105  164357  ICILANHAM   REL-V4R2M0  5769-PW1
     A                                      OVERLAY
     A                                 12  3'(No records to display.)'
     A          R SY003004
     A*%%TS  SD  19970428  162220  JLANHAM     REL-V3R7M0  5716-PW1
     A                                      CA12(12 'Cancel')
     A                                  1 23'Confirm Rebuild of Binding Directo-
     A                                      ry'
     A                                      DSPATR(HI)
     A                                  1 72SYSNAME
     A                                  3  2'The following object already exist-
     A                                      s for the rebuild operation:'
     A                                      COLOR(BLU)
     A                                  5  4'Object which exists . . . . . . . -
     A                                      . :'
     A            SBOBJECT      10A  O  5 42
     A                                  6  6'Library . . . . . . . . . . . . . -
     A                                      :'
     A            SBLIBRARY     10A  O  6 44
     A                                  7  4'Object type . . . . . . . . . . . -
     A                                      . :'
     A            SBOBJTYPE     10A  O  7 42
     A                                  9  2'Type choice, press Enter.'
     A                                      COLOR(BLU)
     A                                 10  2'Press F12=Cancel to return and not-
     A                                       perform rebuild operation.'
     A                                      COLOR(BLU)
     A                                 12  4'Delete existing object . . . . . .-
     A                                       .'
     A            SBCONFIRM      1A  B 12 42
     A                                 12 46'Y=Yes, N=No'
     A                                 23  2'F12=Cancel'
     A                                      COLOR(BLU)
     A          R SY0030S5                  SFL
     A*%%TS  SD  19980616  134138  JLANHAM     REL-V3R7M0  5716-PW1
     A  51                                  SFLNXTCHG
     A            SETEXT        50A  H
     A            SEOPTION       1A  B 11  3
     A  30                                  DSPATR(RI)
     A            SESRVPGM      10A  O 11  7
     A            SESRVLIB      10A  O 11 19
     A            SESHTEXT      49A  O 11 31
     A          R SY0030C5                  SFLCTL(SY0030S5)
     A*%%TS  SD  19981230  094821  ICILANHAM   REL-V4R2M0  5769-PW1
     A                                      CA03(03 'Exit')
     A                                      CA12(12 'Cancel')
     A                                      PAGEUP(25 'Page Up')
     A                                      PAGEDOWN(26 'Page Down')
     A                                      CF04(04 'Prompt')
     A                                      OVERLAY
     A  69                                  SFLDSP
     A N68                                  SFLDSPCTL
     A  68                                  SFLCLR
     A N55                                  SFLEND(*MORE)
     A                                      SFLSIZ(0011)
     A                                      SFLPAG(0010)
     A            SFLCT5         4S 0H      SFLRCDNBR(CURSOR)
     A                                  1 30'Work with ILE Program'
     A                                      DSPATR(HI)
     A                                  1 72SYSNAME
     A                                  3  2'Program . . . . . :'
     A            SAPROGRAM     10A  O  3 22
     A                                  4  4'Library . . . . :'
     A            SAPGMLIB      10A  O  4 24
     A                                  6  2'Type options, press Enter.'
     A                                      COLOR(BLU)
     A                                  7  4'5=Service Program Information'
     A                                      COLOR(BLU)
     A                                  9  7'Service'
     A                                      COLOR(WHT)
     A                                  9 19'Library'
     A                                      DSPATR(HI)
     A                                 10  2'Opt'
     A                                      COLOR(WHT)
     A                                 10  7'Program'
     A                                      COLOR(WHT)
     A                                 10 19'Name'
     A                                      DSPATR(HI)
     A                                 10 31'Text'
     A                                      COLOR(WHT)
     A          R SY0030B5
     A*%%TS  SD  19981230  094821  ICILANHAM   REL-V4R2M0  5769-PW1
     A                                      OVERLAY
     A                                 22  2'F3=Exit'
     A                                      COLOR(BLU)
     A                                 22 12'F4=Prompt'
     A                                      COLOR(BLU)
     A                                 22 24'F12=Cancel'
     A                                      COLOR(BLU)
     A          R SY003006
     A*%%TS  SD  19980616  085131  JLANHAM     REL-V3R7M0  5716-PW1
     A                                      OVERLAY
     A                                  9  3'(No records to display.)'
     A          R MSGSFS1                   SFL
     A                                      SFLMSGRCD(24)
     A            MSGKEY                    SFLMSGKEY
     A            PGMQ                      SFLPGMQ
     A          R MSGSFC1                   SFLCTL(MSGSFS1)
     A*%%TS  SD  19970421  160823  JLANHAM     REL-V3R7M0  5716-PW1
     A                                      SFLDSP
     A                                      SFLDSPCTL
     A                                      SFLINZ
     A N80                                  SFLEND
     A                                      SFLSIZ(0002)
     A                                      SFLPAG(0001)
     A            PGMQ                      SFLPGMQ(10)

The Printer File Source – SY0030P

     A*%%***********************************************************************
     A*%%TS  RD  20090709  101133  LANHAMJ     REL-V5R3M0  5722-WDS
     A*%%FI+10660100000000000000000000000000000000000000000000000000
     A*%%FI       0000000000000000000000000000000000000000000000000
     A*%%***********************************************************************
     A          R SY0030H
     A*%%***********************************************************************
     A*%%RI 00000
     A*%%FS 001
     A*%%***********************************************************************
     A                                      SKIPB(002)
     A                                      SPACEA(001)
     A                                     1
     A                                      DATE
     A                                      EDTCDE(Y)
     A                                    +3
     A                                      TIME
     A                                   +38
     A                                      'Work with ILE Modules'
     A                                   123
     A                                      'Page:'
     A                                    +1
     A                                      PAGNBR
     A                                      EDTCDE(Z)
     A                                     1
     A                                      'Program . . . . . . . . :'
     A                                      SPACEB(002)
     A            SAPROGRAM     10A  O    +1
     A                                     3
     A                                      'Library . . . . . . . :'
     A                                      SPACEB(001)
     A            SAPGMLIB      10A  O    +1
     A*%%***********************************************************************
     A*%%SS
     A*%%CL 002
     A*%%CL 001
     A*%%CL 001
     A*%%***********************************************************************
     A          R SY0030H1
     A*%%***********************************************************************
     A*%%RI 00000
     A*%%***********************************************************************
     A                                      SPACEB(001)
     A                                    23
     A                                      'Source'
     A                                    34
     A                                      'Source'
     A                                   +18
     A                                      '----- Change ------'
     A                                     1
     A                                      'Module'
     A                                      SPACEB(001)
     A                                    +5
     A                                      'Library'
     A                                    +4
     A                                      'File'
     A                                    +7
     A                                      'Library'
     A                                    +4
     A                                      'Member'
     A                                    +9
     A                                      'Date'
     A                                    +7
     A                                      'Time'
     A                                    +4
     A                                      'Text'
     A*%%***********************************************************************
     A*%%SS
     A*%%CL 001
     A*%%***********************************************************************
     A          R SY0030D
     A*%%***********************************************************************
     A*%%RI 00000
     A*%%***********************************************************************
     A                                      SPACEB(001)
     A            SAMODULE      10A  O     1
     A            SALIBRARY     10A  O    +1
     A            SASOURCE      10A  O    +1
     A            SASRCLIB      10A  O    +1
     A            SAMEMBER      10A  O    +1
     A            SACREATEDT    10A  O    +1
     A            SACREATETM    10A  O    +1
     A            SAMODTEXT     50A  O    +2
     A*%%***********************************************************************
     A*%%SS
     A*%%***********************************************************************
     A          R SY0030H2
     A*%%***********************************************************************
     A*%%RI 00000
     A*%%***********************************************************************
     A                                      SPACEB(001)
     A                                     1
     A                                      'Service'
     A                                      SPACEB(001)
     A                                     1
     A                                      'Program'
     A                                      SPACEB(001)
     A                                    +4
     A                                      'Library'
     A                                    +5
     A                                      'Signature'
     A                                    +8
     A                                      'Text'
     A*%%***********************************************************************
     A*%%SS
     A*%%CL 001
     A*%%CL 001
     A*%%***********************************************************************
     A          R SY0030D2
     A*%%***********************************************************************
     A*%%RI 00000
     A*%%***********************************************************************
     A                                      SPACEB(001)
     A            SESRVPGM      10A  O     1
     A            SESRVLIB      10A  O    +1
     A            SESIGNAT      16A  O    +2
     A            SETEXT        50A  O    +1
     A*%%***********************************************************************
     A*%%SS
     A*%%CP+999CRTPRTF
     A*%%CP+    FILE(LANHAMJ/SY0030P)
     A*%%CP+    DEVTYPE(*SCS)
     A*%%CP     PAGESIZE(*N 198)
     A*%%***********************************************************************

The Command Source-WRKILEMOD

             CMD        PROMPT('Work with ILE Program Modules')
             PARM       KWD(PGM) TYPE(QLPGMNAME) MIN(1) +
                          PROMPT('Program')
 QLPGMNAME:  QUAL       TYPE(*NAME) LEN(10) MIN(1) CHOICE('Name')
             QUAL       TYPE(*NAME) LEN(10) DFT(*LIBL) +
                          SPCVAL((*LIBL)) CHOICE('Name, *LIBL') +
                          PROMPT('Library')
└ Tags: iSeries, Programming
 Comment 
Oct26

Simple file layout utility for the iSeries

by Jeff on October 26th, 2010 at 11:33 am
Posted In: Computers, iSeries

This is a simple file layout utility for the iSeries (AS/400, Series i).  Just like with the other utility programs on this site, use at your own risk. All source can be used for any purpose as long as you site me as the original author.

To build, create the print file from the source, create a module from the cl and the rpg, bind them together as SY0010C. Create the command to run the resultant program and you’re done. Just make sure it’s in your library list so it can find the print file.

The result is a nicely formatted file layout showing from, to, length, packed length, and other information about the file. A little easier to use than a DSPFFD. So without further ado, the LAYOUT command.

The C/L Source-SY0010C


/**************************************************************************/
/*   Module: SY0010C                                                      */
/*  Purpose: This module prints a file layout from the combined output of */
/*           DSPFFD and DSPFD *ACCPTH.                                    */
/**************************************************************************/
/*  Written by: Jeffrey Lanham                                            */
/**************************************************************************/

             PGM        PARM(&QUALFILE &SORT)

             DCL        VAR(&QUALFILE) TYPE(*CHAR) LEN(20)
             DCL        VAR(&SORT) TYPE(*CHAR) LEN(4)
             DCL        VAR(&LAYFILE) TYPE(*CHAR) LEN(10)
             DCL        VAR(&LAYLIB) TYPE(*CHAR) LEN(10)
             DCL        VAR(&MSGDATA) TYPE(*CHAR) LEN(80)
             DCL        VAR(&MSGLEN) TYPE(*DEC) LEN(5 0)
             DCL        VAR(&MSGID) TYPE(*CHAR) LEN(7)
             DCL        VAR(&MSGFILE) TYPE(*CHAR) LEN(10)
             DCL        VAR(&MSGLIB) TYPE(*CHAR) LEN(10)

             CHGVAR     VAR(&LAYFILE) VALUE(%SST(&QUALFILE 1 10))
             CHGVAR     VAR(&LAYLIB) VALUE(%SST(&QUALFILE 11 10))

             CHKOBJ     OBJ(&LAYLIB/&LAYFILE) OBJTYPE(*FILE)
             MONMSG     MSGID(CPF0000) EXEC(DO)
               RCVMSG     MSGQ(*PGMQ) MSGDTA(&MSGDATA) +
                            MSGDTALEN(&MSGLEN) MSGID(&MSGID) +
                            MSGF(&MSGFILE) MSGFLIB(&MSGLIB)
               SNDPGMMSG  MSGID(&MSGID) MSGF(&MSGLIB/&MSGFILE) +
                            MSGDTA(&MSGDATA) TOPGMQ(*PRV)
               RETURN
             ENDDO

             SNDPGMMSG  MSGID(CPF9897) MSGF(QCPFMSG) +
                          MSGDTA('Retrieving file field +
                          descriptions.') TOPGMQ(*EXT) MSGTYPE(*STATUS)
             DSPFFD     FILE(&LAYLIB/&LAYFILE) OUTPUT(*OUTFILE) +
                          OUTFILE(QTEMP/QADSPFFD)
             SNDPGMMSG  MSGID(CPF9897) MSGF(QCPFMSG) MSGDTA('Getting +
                          access path information.') TOPGMQ(*EXT) +
                          MSGTYPE(*STATUS)
             DSPFD      FILE(&LAYLIB/&LAYFILE) TYPE(*ACCPTH) +
                          OUTPUT(*OUTFILE) OUTFILE(QTEMP/QAFDACCP)

             OVRDBF     FILE(QADSPFFD) TOFILE(QTEMP/QADSPFFD) +
                          SHARE(*YES)

             OVRDBF     FILE(QAFDACCP) TOFILE(QTEMP/QAFDACCP)

             IF         COND(&SORT = '*YES') THEN(do)
               SNDPGMMSG  MSGID(CPF9897) MSGF(QCPFMSG) MSGDTA('Sorting +
                            by file name.') TOPGMQ(*EXT) MSGTYPE(*STATUS)
               OPNQRYF    FILE((QTEMP/QADSPFFD)) KEYFLD((WHFLDE)) +
                            ALWCPYDTA(*OPTIMIZE)
             ENDDO

             OVRPRTF    FILE(SY0010P) USRDTA(&LAYFILE)
             SNDPGMMSG  MSGID(CPF9897) MSGF(QCPFMSG) +
                          MSGDTA('Printing list.') TOPGMQ(*EXT) +
                          MSGTYPE(*STATUS)
             CALLPRC    PRC(SY0010R) PARM(&LAYFILE &LAYLIB &SORT)

             IF         COND(&SORT = '*YES') THEN(CLOF OPNID(QADSPFFD))

             DLTOVR     FILE(QADSPFFD QAFDACCP SY0010P)

             DLTF       FILE(QTEMP/QADSPFFD)
             DLTF       FILE(QTEMP/QAFDACCP)

             ENDPGM

The RPG Source-SY0010R

      /Title SY0010R - Print File Layout.
     H Optimize(*None) Option(*SrcStmt: *NoDebugIO)
     H CopyRight('Copyright 2010. Jeffrey Lanham Programming Arts, Inc. All Rig-
     Hhts Reserved.')
      **************************************************************************
      *   Module: SY0010R                                                      *
      *  Purpose: This module prints a file layout from the combined output of *
      *           DSPFFD and DSPFD *ACCPTH.                                    *
      **************************************************************************
      *  Written by: Jeffrey Lanham                                            *
      **************************************************************************

     FQADSPFFD  IF   E             DISK
     FQAFDACCP  IF   E             DISK
     FSY0010P   O    E             PRINTER

      // Entry parameter list.
     D SY0010R         PR
     D  File_Name                          Like(WHFILE)                         File Name
     D  Lib_Name                           Like(WHLIB)                          Library Name
     D  Sort                          4                                         Sort Option

     D SY0010R         PI
     D  File_Name                          Like(WHFILE)                         File Name
     D  Lib_Name                           Like(WHLIB)                          Library Name
     D  Sort                          4                                         Sort Option

      // Work fields.
     D Key_Field       S                   dim(100) like(WHFLDE)                Key field array.
     D Key_Number      S                   dim(100) like(APKEYN)                Key position.
     D OverFlow        S               N                                        OverFlow?
     D Z               S              5U 0                                      Counter for arrays.

     D Center_Field    PR         32766A   OpDesc                               Return Centered Fld
     D                            32766A   Options(*VarSize)                    Field to Center

     D Is_It_Key       PR                  Like(Z)

      // System status data structure.
     D                SDS
     D UserName              254    263                                         User Name

      /Eject
      /Free
        // Print sort header if option is '*YES'.
          If Sort = '*YES';
              *IN30 = *On;
          EndIf;

        // Initial read to get the library name.
          Read QWHDRFFD;

        // Concatenate the file and field names together.
          If Lib_Name = '*LIBL' and Not %EOf;
              Lib_Name = WHLIB;
          EndIf;

        // Load fields and Center for print purposes.
          FileName = %Trim(Lib_Name) + '/' + File_Name;
          FileName = Center_Field(FileName);
          UserName = Center_Field(UserName);

        // First, load the key field and key positions into the array.
          Z = 1;
          Read QWHFDACP;

          Dow Not %eof and Z<= %Elem(Key_Field);
              Key_Field(Z) = APKEYF;
              Key_Number(Z) = APKEYN;
              Z = Z + 1;
              Read QWHFDACP;
          EndDo;

        // Force the header to print.
          *IN60 = (APUNIQ = 'Y');
          OverFlow = *On;

        // Now that we've done that, we can go ahead and read through the file
        // field description file and print the layout.
          Dow Not %Eof(QADSPFFD);
              Z = Is_It_Key;
              StartPos = WHIBO;
              EndPos = (StartPos + WHFLDB) - 1;

              *IN50 = *Off;
              If WHFLDD > 0;
                  *IN50 = *On;
              EndIf;

              If OverFlow;
                  Write SY0010H;
                  Write Sy0010H1;
                  OverFlow = *Off;
              EndIf;

              Write(E) SY0010D;

              If %Error;
                  OverFlow = *On;
              EndIf;

              Read QWHDRFFD;

          EndDo;

        // Now, print the key list.
          If Not (Key_Field(1) = *Blanks);
              If OverFlow;
                  Write SY0010H;
                  OverFlow = *Off;
              EndIf;

              Write(E) SY0010H2;

              If %Error;
                  OverFlow = *On;
              EndIf;

              Z = 1;

              Dow Z < %Elem(Key_Field) and Not (Key_Field(Z) = *Blanks);
                  If OverFlow;
                      Write SY0010H;
                      Write SY0010H2;
                      OverFlow = *Off;
                  EndIf;

                  APKEYF = Key_Field(Z);
                  APKEYN = Key_Number(Z);

                  Write(E) SY0010D2;
                  If %Error;
                      OverFlow = *On;
                  EndIf;

                  Z = Z + 1;
              EndDo;

          EndIf;

          *INLR = *On;

      /End-Free

      /Eject
      **************************************************************************
      * Is_It_Key - This determines if a key field and, if it is, it will      *
      *             assign the key field number.                               *
      **************************************************************************
     P Is_It_Key       B

     D Is_It_Key       PI                  Like(Z)

     D Counter         S                   Like(Z)

      /Free
        Counter = 1;
        APKEYN = *Zeros;

        Dow Counter <= %Elem(Key_Field) and Not (Key_Field(Counter) = *Blanks);

            If Key_Field(Counter) = WHFLDE;
                APKEYN = Key_Number(Counter);
                Leave;
            EndIf;

            Counter = Counter + 1;
        EndDo;

        Return Counter;

      /End-Free

     P Is_It_Key       E

      /Eject
      **************************************************************************
      * Center_Field - Center field procedure.  Takes input string and returns *
      *                it centered.                                            *
      **************************************************************************
     P Center_Field    B

     D Center_Field    PI         32766A   OpDesc
     D   Input_String             32766A   Options(*VarSize)

      * Procedure prototype for CEEDOD (Retrieve operational descriptors)
     D CEEDOD          PR
     D  ParmNum                      10I 0 Const
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               12A   Options(*Omit)

      * Parameters for CEEDOD
     D DescType        S             10I 0
     D DataType        S             10I 0
     D DescInfo1       S             10I 0
     D DescInfo2       S             10I 0
     D InLen           S             10I 0                                      Passed Length.

      * Work fields.
     D Work_String     S          32766A                                        Fixed String for Wrk
     D Temp_String     S          32766A   Varying
     D Where           S              5U 0                                      Where to start

      /Free
       // Call CEEDOD to get the types and legnths of the input parameters.
          Callp CEEDOD(1: DescType: DataType: DescInfo1: DescInfo2:
                       InLen: *Omit);

          %Len(Temp_String) = InLen;
          Temp_String = %Subst(Input_String: 1: InLen);
          Where = %CheckR(' ': Temp_String);

          Select;
       // If error, just load the return field.
          When Where = 0 or Where = 1;
              Work_String = Temp_String;
       // Otherwise, center it.
          Other;
              Where = ((%Len(Temp_String) - Where) / 2) + 1;
              %Subst(Work_String: Where: InLen) = Temp_String;
          EndSl;

          Return Work_String;

      /End-Free

     P Center_Field    E
      /Eject

The DDS Source for the Printer File-SY0010P

     A*%%***********************************************************************
     A*%%TS  RD  20000602  093242  LANHAMJ     REL-V4R2M0  5769-PW1
     A*%%FI+10660100000000000000000000000000000000000000000000000000
     A*%%FI       0000000000000000000000000000000000000000000000000
     A*%%***********************************************************************
     A          R SY0010H
     A*%%***********************************************************************
     A*%%RI 00000
     A*%%FS 001
     A*%%***********************************************************************
     A                                      SKIPB(002)
     A                                      SPACEA(001)
     A                                     1
     A                                      DATE
     A                                      EDTCDE(Y)
     A                                    57
     A                                      'File Layout Utility'
     A                                   129
     A                                      PAGNBR
     A                                      EDTCDE(Z)
     A                                     1
     A                                      TIME
     A                                      SPACEB(001)
     A  30                               +12
     A                                      'Sorted by Field Name'
     A            FILENAME      21A  O   +15
     A            USERNAME      10A  O   123
     A*%%***********************************************************************
     A*%%SS
     A*%%CL 001
     A*%%CL 001
     A*%%***********************************************************************
     A          R SY0010H1
     A*%%***********************************************************************
     A*%%RI 00000
     A*%%***********************************************************************
     A                                      SPACEB(001)
     A                                     1
     A                                      'Format Name:'
     A            WHNAME    R        O    +1
     A                                      REFFLD(QWHDRFFD/WHNAME *LIBL/QADSPF-
     A                                      FD)
     A                                    +5
     A                                      'Level Identifier:'
     A            WHSEQ     R        O    +1
     A                                      REFFLD(QWHDRFFD/WHSEQ *LIBL/QADSPFF-
     A                                      D)
     A                                    63
     A                                      'Format Text:'
     A            WHTEXT    R        O    76
     A                                      REFFLD(QWHDRFFD/WHTEXT *LIBL/QADSPF-
     A                                      FD)
     A                                    29
     A                                      'Number of Fields:'
     A                                      SPACEB(001)
     A            WHFLDN    R        O    47
     A                                      REFFLD(QWHDRFFD/WHFLDN *LIBL/QADSPF-
     A                                      FD)
     A                                      EDTCDE(Z)
     A                                    +9
     A                                      'Format Length:'
     A            WHRLEN    R        O    +1
     A                                      REFFLD(QWHDRFFD/WHRLEN *LIBL/QADSPF-
     A                                      FD)
     A                                      EDTCDE(Z)
     A                                    +5
     A                                      'Physical File:'
     A            APBOF     R        O    +1
     A                                      REFFLD(QWHFDACP/APBOF *LIBL/QAFDACC-
     A                                      P)
     A  60                                +4
     A                                      'Unique'
     A                                    14
     A                                      'Key'
     A                                      SPACEB(002)
     A                                    20
     A                                      'Field'
     A                                    28
     A                                      'Starting'
     A                                    41
     A                                      'Ending'
     A                                    51
     A                                      'Field'
     A                                     1
     A                                      'Field Name'
     A                                      SPACEB(001)
     A                                    14
     A                                      'Pos'
     A                                    20
     A                                      'Type'
     A                                    28
     A                                      'Position'
     A                                    40
     A                                      'Position'
     A                                    51
     A                                      'Length'
     A                                    61
     A                                      'Digits'
     A                                    +2
     A                                      'Decimals'
     A                                    +4
     A                                      'Field Text'
     A*%%***********************************************************************
     A*%%SS
     A*%%CL 001
     A*%%CL 002
     A*%%CL 001
     A*%%***********************************************************************
     A          R SY0010D
     A*%%***********************************************************************
     A*%%RI 00000
     A*%%***********************************************************************
     A                                      SPACEB(001)
     A            WHFLDE    R        O     1
     A                                      REFFLD(QWHDRFFD/WHFLDE *LIBL/QADSPF-
     A                                      FD)
     A            APKEYN    R        O    +3
     A                                      REFFLD(QWHFDACP/APKEYN *LIBL/QAFDAC-
     A                                      CP)
     A                                      EDTCDE(Z)
     A            WHFLDT    R        O    +4
     A                                      REFFLD(QWHDRFFD/WHFLDT *LIBL/QADSPF-
     A                                      FD)
     A            STARTPOS       5S 0O    +7
     A                                      EDTCDE(Z)
     A            ENDPOS         5S 0O    +8
     A                                      EDTCDE(Z)
     A            WHFLDB    R        O    +4
     A                                      REFFLD(QWHDRFFD/WHFLDB *LIBL/QADSPF-
     A                                      FD)
     A                                      EDTCDE(Z)
     A            WHFLDD    R        O    +7
     A                                      REFFLD(QWHDRFFD/WHFLDD *LIBL/QADSPF-
     A                                      FD)
     A                                      EDTCDE(Z)
     A  50        WHFLDP    R        O    +7
     A                                      REFFLD(QWHDRFFD/WHFLDP *LIBL/QADSPF-
     A                                      FD)
     A                                      EDTCDE(3)
     A            WHFTXT    R        O    +6
     A                                      REFFLD(QWHDRFFD/WHFTXT *LIBL/QADSPF-
     A                                      FD)
     A*%%***********************************************************************
     A*%%SS
     A*%%***********************************************************************
     A          R SY0010H2
     A*%%***********************************************************************
     A*%%RI 00000
     A*%%FS 001
     A*%%***********************************************************************
     A                                      SPACEB(002)
     A                                     1
     A                                      'Key Field'
     A                                    +6
     A                                      'Key Position'
     A*%%***********************************************************************
     A*%%SS
     A*%%***********************************************************************
     A          R SY0010D2
     A*%%***********************************************************************
     A*%%RI 00000
     A*%%***********************************************************************
     A                                      SPACEB(001)
     A            APKEYF    R        O     1
     A                                      REFFLD(QWHFDACP/APKEYF *LIBL/QAFDAC-
     A                                      CP)
     A            APKEYN    R        O    +9
     A                                      REFFLD(QWHFDACP/APKEYN *LIBL/QAFDAC-
     A                                      CP)
     A                                      EDTCDE(Z)
     A*%%***********************************************************************
     A*%%SS
     A*%%CP+999CRTPRTF
     A*%%CP+    FILE(*CURLIB/SY0010P)
     A*%%CP+    DEVTYPE(*SCS)
     A*%%CP     PAGESIZE(*N       132      *N     )
     A*%%***********************************************************************

And finally the Command Source-LAYOUT

             CMD        PROMPT('Layout a File')
             PARM       KWD(FILE) TYPE(QLFILENAME) MIN(1) +
                          CHOICE('File Name') PROMPT('File Name')
             PARM       KWD(SORT) TYPE(*CHAR) LEN(4) RSTD(*YES) +
                          DFT(*NO) VALUES(*YES *NO) MIN(0) +
                          PROMPT('Sort by Field Name')
 QLFILENAME: QUAL       TYPE(*NAME) LEN(10) MIN(1)
             QUAL       TYPE(*NAME) LEN(10) DFT(*LIBL) +
                          SPCVAL((*LIBL)) MIN(0) CHOICE('*LIBL, +
                          Library Name') PROMPT('Library')

The reason I’m throwing this up in the wild is because I want to be able to find my source and I have other people who would like it.  If it’s of value to you, then by all means use it.

If any one has any suggestions for changes or modifications, please let me know.

 Comment 
Dec10

You cannot delete a file or a folder on an NTFS file system volume

by Jeff on December 10th, 2009 at 12:33 pm
Posted In: Computers, Computers, Tips, Computers, Windows

INTRODUCTION

This article describes why you may not be able to delete a file or a folder on a…

This article describes why you may not be able to delete a file or a folder on an NTFS file system volume and how to address the different causes to resolve this issue.

MORE INFORMATION

Note Internally, NTFS treats folders as a special type of file. Therefore, the w…

Note Internally, NTFS treats folders as a special type of file. Therefore, the word “file” in this article indicates either a file or folder.

Cause 1: The file uses an ACL

You may not be able to delete a file if the file uses an Access Control List (ACL). To resolve this issue, change the permissions on the file. You may have to take ownership of the files to be able to change the permissions.

Administrators have the implicit ability to take ownership of any file even if they have not been explicitly granted any permission to the file. File owners have the implicit ability to modify file permissions even if they are not explicitly granted any permissions to the file. Therefore, you may have to take ownership of a file, give yourself permissions to delete the file, and then delete the file.

You cannot use certain security tools to display or to modify permissions because the file has a non-canonical ACL

To work around this issue, use another tool (for example, a later build of Cacls.exe).

The Access Control Entries (ACEs) in an ACL have a certain preferred sequence depending on their type. For example, ACEs that deny access typically come before ACEs that grant access. However, nothing prevents a program from writing an ACL that has ACEs in any arbitrary sequence. In some earlier versions of Windows, issues occurred when Microsoft Windows tried to read these “non-canonical” ACLs. Sometimes, you cannot modify these ACLs correctly by using the Microsoft Windows Explorer graphical security editor. This issue has been corrected in later versions of Windows. If you are experiencing this issue, use the most recent version of Cacls.exe. Even if you cannot display or edit an ACL in place, you can write a new ACL that lets you to gain access to the file.

Cause 2: The file is being used

You may not be able to delete a file if the file is being used. To resolve this issue, determine the process that has the open handle, and then close that process.

Depending on how the file is opened (for example, it is open for exclusive access instead of shared access), you may not be able to delete a file that is in use. You can use a variety of tools to help you determine the processes that have open handles to files whenever you want. For more information about tools to help the processes that have open handles to files, click the following article numbers to view the articles in the Microsoft Knowledge Base:

242131 (http://support.microsoft.com/kb/242131/ ) How to display a list of processes that have files open

172710 (http://support.microsoft.com/kb/172710/ ) How to use the OH tool on the Windows NT 4.0 Resource Kit

The symptoms of this issue may vary. You may be able to use the Delete command to delete a file, but the file is not actually deleted until the process that has the file open releases the file. Additionally, you may not be able to access the Security dialog box for a file that is pending deletion. To resolve this issue, determine the process that has the open handle, and then close that process.

Back to the top

Cause 3: File system corruption is preventing access to the file

You may not be able to delete the file if the file system is corrupted. To resolve this issue, run the Chkdsk utility on the disk volume to correct any errors.

Bad sectors on the disk, other faulty hardware, or software bugs can corrupt the file system and put files in a problematic state. Typical operations may fail in a variety of ways. When the file system detects corruption, it logs an event to the event log and you typically receive a message that prompts you to run Chkdsk. Depending on the nature of the corruption, Chkdsk may or may not be able to recover file data; however, Chkdsk returns the file system to an internally consistent state. For additional information about using the Chkdsk utility, click the following article numbers to view the articles in the Microsoft Knowledge Base:

176646 (http://support.microsoft.com/kb/176646/ ) Error message: The file or directory is corrupt…

187941 (http://support.microsoft.com/kb/187941/ ) An explanation of CHKDSK and the New /C and /I switches

Cause 4: Files exist in paths that are deeper than MAX_PATH characters

You may not be able to open, edit, or delete a file if there are issues with the file path.

Resolution 1: Use an auto-generated 8.3 name to access the file

To resolve this issue, you may want to use the auto-generated 8.3 name to access the file. This resolution may be the easiest resolution if the path is deep because the folder names are too long. If the 8.3 path is also too long or if 8.3 names have been disabled on the volume, go to Resolution 2. For additional information about disabling 8.3 file names on NTFS volumes, click the following article number to view the article in the Microsoft Knowledge Base:

121007 (http://support.microsoft.com/kb/121007/ ) How to disable the 8.3 name creation on NTFS partitions

Resolution 2: Rename or move a deep folder

Rename the folder so that the target files that are deeper than the MAX_PATH no longer exist. If you do this, start at the root folder (or any other convenient place), and then rename folders so that they have shorter names. If this step does not resolve this issue (for example, if a file is more than 128 folders deep), go to Resolution 4.

Resolution 3: Map a drive to a folder in the structure of the path

Map a drive to a folder inside the structure of the path of the target file or folder. This method shortens the virtual path.

For example, suppose you have a path that is structured as follows:

\\ServerName\SubfolderName1\SubfolderName2\SubfolderName3\SubfolderName4\…

In this path, the total character count is over 255 characters. To short the length of this path, to 73 characters, map a drive to SubfolderName4.

Resolution 4: Use a network share that is as deep as the folder

If Resolution 1, 2, and 3 are not convenient or do not resolve the issue, create a network share that is as deep in the folder tree as you can, and then rename the folders by accessing the share.

Resolution 5: Use a tool that can traverse deep paths

Many Windows programs expect the maximum path length to be shorter than 255 characters. Therefore, these programs only allocate enough internal storage to handle these typical paths. NTFS does not have this limit and it can hold much longer paths.

You may experience this issue if you create a share at some point in your folder structure that is already fairly deep, and then create a deep structure below that points by using the share. Some tools that operate locally on the folder tree may not be able to traverse the whole tree starting from the root. You may have to use these tools in a special way so that they can traverse the share. (The CreateFile API documentation describes a method to traverse the whole tree in this situation.)

Typically, you can manage files by using the software that creates them. If you have a program that can create files that are deeper than MAX_PATH, you can typically use that same program to delete or manage the files. You can typically delete files that are created on a share by using the same share.

Cause 5: The file name includes a reserved name in the Win32 name space

If the file name includes a reserved name (for example, “lpt1″) in the Win32 name space, you may not be able to delete the file. To resolve this issue, use a non-Win32 program to rename the file. You can use a POSIX tool or any other tool that uses the appropriate internal syntax to use the file.

Additionally, you may be able to use some built-in commands to bypass the typical Win32 reserved name checks if you use a particular syntax to specify the path of the file. For example, if you use the Del command in Windows XP, you can delete a file named “lpt1″ if you specify the full path of the file by using the following special syntax:

del \\?\c:\path_to_file\lpt1

For more information about deleting files with reserved names under Windows NT and Windows 2000, click the following article number to view the article in the Microsoft Knowledge Base:

120716 (http://support.microsoft.com/kb/120716/ ) How to remove files with reserved names in Windows

For more information about deleting files with reserved names under Windows XP, click the following article number to view the article in the Microsoft Knowledge Base:

315226 (http://support.microsoft.com/kb/315226/ ) How to remove files with reserved names in Windows XP

If you open a handle to a file by using the typical Win32 CreateFile mechanism, certain file names are reserved for old-style DOS devices. For backward compatibility, these file names are not permitted and they cannot be created by using typical Win32 file calls. However, this issue is not a limitation of NTFS.

You may be able to use a Win32 program to bypass the typical name checks that are performed when a file is created (or deleted) by using the same technique that you use to traverse folders that are deeper than MAX_PATH. Additionally, some POSIX tools are not subject to these name checks.

Cause 6: The file name includes an invalid name in the Win32 name space

You may not be able to delete a file if the file name includes an invalid name (for example, the file name has a trailing space or a trailing period or the file name is made up of a space only). To resolve this issue, use a tool that uses the appropriate internal syntax to delete the file. You can use the “\\?\” syntax with some tools to operate on these files, for example:

del “\\?\c:\path_to_file_that contains a trailing space.txt “

The cause of this issue is similar to Cause 4. However, if you use typical Win32 syntax to open a file that has trailing spaces or trailing periods in its name, the trailing spaces or periods are stripped before the actual file is opened. Therefore, if you have two files in the same folder named “AFile.txt” and “AFile.txt ” (note the space after the file name), if you try to open the second file by using standard Win32 calls, you open the first file instead. Similarly, if you have a file whose name is just ” ” (a space character) and you try to open it by using standard Win32 calls, you open the file’s parent folder instead. In this situation, if you try to change security settings on these files, you either may not be able to do this or you may unexpectedly change the settings on different files. If this behavior occurs, you may think that you have permission to a file that actually has a restrictive ACL.

Combinations of causes

Sometimes, you may experience combinations of these causes, which can make the procedure to delete a file more complex. For example, if you log on as the computer’s administrator, you may experience a combination of Cause 1 (you do not have permissions to delete a file) and Cause 5 (the file name contains a trailing character that causes file access to be redirected to a different or nonexistent file) and you may not be able to delete the file. If you try to resolve Cause 1 by taking ownership of the file and adding permissions, you still may not be able to delete the file because the ACL editor in the user interface cannot access the appropriate file because of Cause 6.

In this situation, you can use the Subinacl utility with the /onlyfile switch (this utility is included in the Resource Kit) to change ownership and permissions on a file that is otherwise inaccessible, for example:

subinacl /onlyfile “\\?\c:\path_to_problem_file” /setowner=domain\administrator /grant=domain\administrator=F

Note This command is a single command line it has been wrapped for readability.

This sample command line modifies the C:\path_to_problem_file file that contains a trailing space so that the domain\administrator account is the owner of the file and this account has full control over the file. You can now delete this file by using the Del command with the same “\\?\” syntax.

└ Tags: Computer, Tips, Windows
 Comment 
  • Page 1 of 3
  • 1
  • 2
  • 3
  • »

Categories

  • Computers
  • History
  • iSeries
  • Reviews
  • Tips
  • Uncategorized
  • Windows

Tags

ArcServe Computer History iSeries Linux NetFlix Programming Reviews Tips Windows

Control Panel

  • Register
  • Recover password

©2009-2012 JLPAOnline | Powered by WordPress with Easel | Subscribe: RSS | Back to Top ↑