midrange.com code scratchpad
Name:
getDtaAraVal
Scriptlanguage:
Plain Text
Tabwidth:
4
Date:
04/23/2012 07:25:41 pm
IP:
Logged
Description:
Return the value of any numeric data area. Returned value is 30 length with 9 precision.

Dennis Lovelady
Code:
  1.  
  2.        // Return the value of a a numeric data area.
  3.        // Public domain by Dennis Lovelady 23-Apr-2012
  4.  
  5.  
  6.      D getDtaAraVal    PR            30  9 ExtProc('getDtaAraVal')
  7.       * Return the value of a numeric data area.
  8.      D  dtaara                       10    Const
  9.      D  lib                          10    Const
  10.  
  11.  
  12.      P getDtaAraVal    B
  13.       * Return the value of a numeric data area.
  14.      D getDtaAraVal    PI            30  9
  15.      D  dtaara                       10    Const
  16.      D  lib                          10    Const
  17.  
  18.      D num31           DS
  19.      D  packed31                     31P 0 Inz(*Zero)
  20.  
  21.  
  22.  
  23.      D RtvDataArea     PR                  ExtPgm('QWCRDTAA')
  24.      D  rcvrVar                   65535    Options(*VarSize)
  25.      D  rcvrLen                      10I 0 Const
  26.      D  qualDtaArea                  20    Const
  27.      D  startPos                     10I 0 Const
  28.      D  readLength                   10I 0 Const
  29.      D  errorStruct                        LikeDS(usec_T)
  30.  
  31.      D usec_T          DS                  Qualified based(proto_only)
  32.      D*                                             Error Struct
  33.      D  QUSBPRV                      10I 0
  34.      D*                                             Bytes Provided
  35.      D  QUSBAVL                      10I 0
  36.      D*                                             Bytes Available
  37.      D  QUSEI                         7
  38.      D*                                             Exception Id
  39.      D  reserved                      1
  40.      D*                                             Reserved
  41.      D  QUSED01                    1024
  42.      D  bytesProvided...
  43.      D                                              Like(usec_t.QUSBPRV)
  44.      D                                              Overlay(QUSBPRV)
  45.      D  bytesAvailable...
  46.      D                                              Like(usec_t.QUSBAVL)
  47.      D                                              Overlay(QUSBAVL)
  48.      D  errorID                                     Like(usec_t.QUSEI)
  49.      D                                              Overlay(QUSEI)
  50.      D  errorData                                   Like(usec_t.QUSED01)
  51.      D                                              Overlay(QUSED01)
  52.  
  53.  
  54.      D daReceiver      DS                  Qualified
  55.      D  rcvAvail                     10I 0
  56.      D  rcvReturned                  10I 0
  57.      D  typeReturned                 10
  58.      D  library                      10
  59.      D  valLen                       10I 0
  60.      D  nbrDec                       10I 0
  61.      D  value                        16
  62.  
  63.  
  64.      D myUSEC          DS                  LikeDS(usec_T)
  65.      D physLen         S              3  0
  66.      D divisor         S             10  0
  67.      D rtnVal          S             31  9 Inz(*Zero)
  68.  
  69.       /Free
  70.  
  71.        // Retrieve data area value.  If no eror, and if the value
  72.        // is numeric, then we will move the returned data to the 
  73.        // right-hand sideof our work data structure 'num31,'  which
  74.        // forces proper alignment.
  75.  
  76.        Clear myUSEC ;
  77.        myUSEC.bytesProvided = %Size(myUSEC) ;
  78.        rtvDataArea(daReceiver: %Size(daReceiver)
  79.                  : dtaara + lib
  80.                  : 1
  81.                  : %Size(num31)
  82.                  : myUSEC
  83.                   ) ;
  84.  
  85.        If myUSEC.bytesAvailable = *Zero ;
  86.           If daReceiver.typeReturned = '*DEC' ;
  87.              physLen = (daReceiver.vallen / 2) + 1 ;
  88.              %Subst(num31: %Size(num31)+1 - physLen
  89.                        : physLen) = daReceiver.value ;
  90.  
  91.              // Now to figure out the scale of the value,
  92.              // we take 10 to the power of the indicated
  93.              // number of decimals.  This becomes the
  94.              // divisor to obtain the correct scale.
  95.  
  96.              divisor = 10 ** daReceiver.nbrdec ;
  97.              rtnVal = packed31 / divisor ;
  98.           EndIF ;
  99.        EndIF ;
  100.        Return rtnVal ;
  101.  
  102.       /End-free
  103.  
  104.      P getDtaAraVal    B
  105.      
© 2004-2019 by midrange.com generated in 0.008s valid xhtml & css