code

Name
Astradyne (UK) Ltd
Scriptlanguage
Plain Text
Tabwidth
4
Date
Sun, 12 May 2013 14:04:04 +0000
IP
192.168.0.1

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

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