code

Name
Astradyne (UK) Ltd
Scriptlanguage
Plain Text
Tabwidth
4
Date
Mon, 21 May 2007 20:18:52 +0100
IP
192.168.0.33

A sub-procedure that can be used to retrieve system values into an ILE program.

  1. *****************
  2. *** COPY BOOK ***
  3. *****************
  4.     D* Common API Error Structure
  5.  
  6.     D/IF    NOT DEFINED(API_ERROR)
  7.     D/DEFINE API_ERROR
  8.  
  9.     D ApiError        DS
  10.     D  ApiBytes                    10I 0 Inz(%Size(ApiError))
  11.     D  ApiBytesOut                10I 0
  12.     D  ApiErrID                    7A
  13.     D  ApiReserved                  1A
  14.     D  ApiErInDta                256A
  15.  
  16.     D/ENDIF
  17.  
  18.     D RtvSysVal      pr          2080a  Varying
  19.     D  iSysval                      10a  Const
  20.  
  21.     D QwcRsvAL        pr                  ExtPgm('QWCRSVAL')
  22.     D  valRcvVar                          Like(RcvVariable)
  23.     D  valRcvVarLen                10i 0 Const
  24.     D  valNoSysVals                10i 0 Const
  25.     D  valSysValName                10a  Const
  26.     D  valErrCode                        Like(ApiError)
  27.  
  28.     D RcvVariable    ds
  29.     D  rcvNbrSysVals                10i 0
  30.     D  rcvOffSysVals                10i 0
  31.     D  rcvSysValTbl                      Like(SysValInfTbl)
  32.  
  33.     D SysValInfTbl    ds
  34.     D  tblSysVal                    10a
  35.     D  tblDtaTyp                    1a
  36.     D  tblInfSts                    1a
  37.     D  tblDtaLen                    10i 0
  38.     D  tblDtaVal                  2080a
  39.  
  40.     D  tblChar001                    1a  Overlay(tblDtaVal : 1)
  41.     D  tblChar002                    2a  Overlay(tblDtaVal : 1)
  42.     D  tblChar003                    3a  Overlay(tblDtaVal : 1)
  43.     D  tblChar004                    4a  Overlay(tblDtaVal : 1)
  44.     D  tblChar005                    5a  Overlay(tblDtaVal : 1)
  45.     D  tblChar006                    6a  Overlay(tblDtaVal : 1)
  46.     D  tblChar007                    7a  Overlay(tblDtaVal : 1)
  47.     D  tblChar008                    8a  Overlay(tblDtaVal : 1)
  48.     D  tblChar009                    9a  Overlay(tblDtaVal : 1)
  49.     D  tblChar010                  10a  Overlay(tblDtaVal : 1)
  50.     D  tblChar013                  13a  Overlay(tblDtaVal : 1)
  51.     D  tblChar020                  20a  Overlay(tblDtaVal : 1)
  52.     D  tblChar030                  30a  Overlay(tblDtaVal : 1)
  53.     D  tblChar050                  50a  Overlay(tblDtaVal : 1)
  54.     D  tblChar080                  80a  Overlay(tblDtaVal : 1)
  55.     D  tblChar150                  150a  Overlay(tblDtaVal : 1)
  56.     D  tblChar160                  160a  Overlay(tblDtaVal : 1)
  57.     D  tblChar250                  250a  Overlay(tblDtaVal : 1)
  58.     D  tblChar315                  315a  Overlay(tblDtaVal : 1)
  59.     D  tblChar500                  500a  Overlay(tblDtaVal : 1)
  60.  
  61.     D  tblBin004                    10i 0 Overlay(tblDtaVal : 1)
  62.  
  63.     D* Figurative constants...
  64.     D Binary          c                  Const('B')
  65.     D Char            c                  Const('C')
  66.     D Locked          c                  Const('L')
  67.  
  68. *****************
  69. *** PROCEDURE ***
  70. *****************
  71.  
  72.     P RtvSysVal      b                  Export
  73.  
  74.     D* Procedure interface
  75.     D RtvSysVal      pi          2080a  Varying
  76.     D  iSysVal                      10a  Const
  77.  
  78.     D Wk010a          s            10a
  79.     D wSysVal        s            10a
  80.     D Pos            s              5p 0
  81.     D Len            s              5p 0
  82.  
  83.     C* Procedure calculation specifications
  84.  
  85.     C*  Call the API...
  86.     C                  Reset                  ApiError
  87.  
  88.     C                  Eval      wSysVal = CvtCase(iSysVal : 10 : '*UPPER')
  89.  
  90.     C                  CallP    QwcRsvAL(RcvVariable      :
  91.     C                                      %Len(RcvVariable) :
  92.     C                                      1                :
  93.     C                                      wSysVal          :
  94.     C                                      ApiError          )
  95.  
  96.     C*  If any errors generated then return an error flag...
  97.     C                  If        ApiBytesOut <> 0
  98.     C                  Return    '*ERROR: ' + ApiErrID
  99.  
  100.     C*  ...otherwise return the appropriate value...
  101.     C                  Else
  102.  
  103.     C                  Eval      Pos = rcvOffSysVals - 8 + 1
  104.     C                  Eval      Len = %Len(SysValInfTbl) - Pos + 1
  105.     C                  Eval      SysValInfTbl = %Subst(RcvSysValTbl :
  106.     C                                              Pos : Len)
  107.     C                  Select
  108.     C                  When      tblDtaTyp = Binary
  109.     C                  Movel    tblBin004    wk010a
  110.     C                  Return    Wk010a
  111.     C                  When      tblDtaTyp = Char And tblDtaLen = 0001
  112.     C                  Return    tblChar001
  113.     C                  When      tblDtaTyp = Char And tblDtaLen = 0002
  114.     C                  Return    tblChar002
  115.     C                  When      tblDtaTyp = Char And tblDtaLen = 0003
  116.     C                  Return    tblChar003
  117.     C                  When      tblDtaTyp = Char And tblDtaLen = 0004
  118.     C                  Return    tblChar004
  119.     C                  When      tblDtaTyp = Char And tblDtaLen = 0005
  120.     C                  Return    tblChar005
  121.     C                  When      tblDtaTyp = Char And tblDtaLen = 0006
  122.     C                  Return    tblChar006
  123.     C                  When      tblDtaTyp = Char And tblDtaLen = 0007
  124.     C                  Return    tblChar007
  125.     C                  When      tblDtaTyp = Char And tblDtaLen = 0008
  126.     C                  Return    tblChar008
  127.     C                  When      tblDtaTyp = Char And tblDtaLen = 0009
  128.     C                  Return    tblChar009
  129.     C                  When      tblDtaTyp = Char And tblDtaLen = 0010
  130.     C                  Return    tblChar010
  131.     C                  When      tblDtaTyp = Char And tblDtaLen = 0013
  132.     C                  Return    tblChar013
  133.     C                  When      tblDtaTyp = Char And tblDtaLen = 0020
  134.     C                  Return    tblChar020
  135.     C                  When      tblDtaTyp = Char And tblDtaLen = 0030
  136.     C                  Return    tblChar030
  137.     C                  When      tblDtaTyp = Char And tblDtaLen = 0050
  138.     C                  Return    tblChar050
  139.     C                  When      tblDtaTyp = Char And tblDtaLen = 0080
  140.     C                  Return    tblChar080
  141.     C                  When      tblDtaTyp = Char And tblDtaLen = 0150
  142.     C                  Return    tblChar150
  143.     C                  When      tblDtaTyp = Char And tblDtaLen = 0160
  144.     C                  Return    tblChar160
  145.     C                  When      tblDtaTyp = Char And tblDtaLen = 0250
  146.     C                  Return    tblChar250
  147.     C                  When      tblDtaTyp = Char And tblDtaLen = 0315
  148.     C                  Return    tblChar315
  149.     C                  When      tblDtaTyp = Char And tblDtaLen = 0500
  150.     C                  Return    tblChar500
  151.     C                  When      tblDtaTyp = Char And tblDtaLen = 2080
  152.     C                  Return    tblDtaVal
  153.     C                  Other
  154.     C                  Return    '*ERROR: Locked'
  155.     C                  EndSl
  156.  
  157.     C                  EndIf
  158.  
  159.     P RtvSysVal      e