midrange.com code scratchpad
Name:
Utl_FmtNumForDec
Scriptlanguage:
Plain Text
Tabwidth:
4
Date:
02/28/2020 06:27:15 pm
IP:
Logged
Description:
Utl_FmtNumForDec is a procedure that I put together for replacing the MOVE op code.

It will allow you to take a character string that contains a packed decimal number and translate it into a string that can be passed to the %DEC BIF.

Code:
  1. // Here is an example usage of the procedure:
  2.  
  3. DCL-S FLD2 VARCHAR(128);
  4. DCL-S fld1 CHAR(7);
  5. DCL-S FLD3 PACKED(7:2);
  6. fld1 = '002632J';
  7.  
  8. FLD2 = UTL_FMTNUMFORDEC(fld1:7:2:*ON:*OFF);
  9. FLD3 = %DEC( FLD2 : 7:2);
  10.  
  11.  
  12. // This is what I put into the Service Program's Copy Book:
  13.  
  14. /IF NOT DEFINED(Utl_FmtNumForDec)
  15. /DEFINE Utl_FmtNumForDec
  16.  //===================================================================
  17.  // @Name        - Utl_FmtNumForDec
  18.  // @Description - Format a string number for a %DEC function.
  19.  
  20.  // @Usage       - Utl_FmtNumForDec( String);
  21.  // @Usage       - Utl_FmtNumForDec( String : %Size(DecFld) : %Decpos(DecFld)
  22.  //                                 :*on :*on :*on :PerrorDS);
  23.  // @Usage       - Utl_FmtNumForDec( Position :15:0 );
  24.  // @Usage       - Utl_FmtNumForDec( wkField :%SIZE(OutField) :ErrorDS)
  25.  
  26.  // @Params      - String to be converted (required)
  27.  //                Output Precision
  28.  //                     Ignored when zero
  29.  //                     Values Between 1 and 63
  30.  //                     Minimum value is DecimalPlaces+2 (Unless Decimal is zero)
  31.  //                Output Decimal places
  32.  //                     Values Between 0 and 63
  33.  //                AssumeDecimal
  34.  //                     If decimal character not passed in input then the
  35.  //                     rightmost digits are used to fill the Decimal places.
  36.  //                     This option will correctly parse the negative out of
  37.  //                     a packed edit code "X" string.
  38.  //                Ignore Negative inputs
  39.  //                Digits Only
  40.  //                     Ignores all non-digits.
  41.  //                     Pads leading zeros up to Precision.
  42.  //                Error DS (When passed Validation is active)
  43.  //                     Errors out when characters are included in input.
  44.  //                Strict Validation active
  45.  //                     Error: when characters are included in input.
  46.  //                     Error: when generated string exceeds decimal places
  47.  //                     Error: when generated string exceeds Precision
  48.  
  49.  // @Returns     - On success: Reformatted number usable by function %DEC().
  50.  //                On failure: Input String, and Error DS (if passed).
  51.  
  52.  // Notes on negatives.
  53.  //     (123) translates to -123
  54.  //     123CR translates to -123
  55.  //     -123  translates to -123
  56.  //     123-  translates to  123-
  57.  //   X'F1D1' translates to  11-  (Packed Edit Code 'X' negative)
  58.  
  59.  // Characters Stripped: ,$*+%-.
  60.  
  61.  //===================================================================
  62.  Dcl-Pr Utl_FmtNumForDec Varchar(128) Opdesc;
  63.    String Varchar(128) Const;
  64.    Precision Int(5) Options( *NOPASS ) Const;
  65.    Decimalplaces Int(5) Options( *NOPASS ) Const;
  66.    Assumedecimal Ind Options( *NOPASS ) Const;
  67.    Ignorenegative Ind Options( *NOPASS ) Const;
  68.    Digitsonly Ind Options( *NOPASS ) Const;
  69.    Perrords Char(512) Options(*VARSIZE:*OMIT:*NOPASS);
  70.    Validstrict Ind Options( *NOPASS ) Const;
  71.  End-Pr;
  72. /ENDIF
  73.  
  74.  
  75.  
  76.  
  77.  
  78.  
  79. // These are some global definitions required by the two procedures.
  80.  
  81. // we actually map more PSDS fields, but this is the only one used in Utl_FmtNumForDec
  82. Dcl-Ds PGMINF psds;
  83.   PgmInfErrorMsg Char(80) Pos(091);
  84. End-Ds;
  85.  
  86. Dcl-Ds Apierrords QUALIFIED;
  87.   Bytespass Int(10) INZ(%SIZE(APIERRORDS));
  88.   Bytesavail Int(10) INZ(*ZERO);
  89.   MsgID Char(7) INZ(*BLANKS);
  90.   *N Char(1) INZ(X'00');
  91.   MsgDta Char(256) INZ(*BLANKS);
  92. End-Ds;
  93.  
  94. Dcl-Pr CEEDOD;
  95.   PR_ArgNum Int(10) CONST;
  96.   PR_DscTyp Int(10);
  97.   PR_DtaTyp Int(10);
  98.   PR_DscInf1 Int(10);
  99.   PR_DscInf2 Int(10);
  100.   PR_ArgLen Int(10);
  101.   PR_FBCod Char(12) OPTIONS(*OMIT);
  102. End-Pr;
  103. //*************************
  104. //* CEEDOD API Parameters *
  105. //*************************
  106. Dcl-ds Ceedod_DS Template Qualified;
  107.   Arg Int(10);
  108.   DscTyp Int(10);
  109.   DtaTyp Int(10);
  110.   Dscinf1 Int(10);
  111.   Dscinf2 Int(10);
  112.   Arglen Int(10);
  113.   Fbcod Likeds(Ceedod_FB_t);
  114. End-ds;
  115.  
  116. // To test for success, determine if the first 4 bytes are 0.
  117. // If the first 4 bytes are 0, then the remainder is 0.
  118. Dcl-ds Ceedod_FB_t Len(12) Template Qualified;
  119.   Id Uns(10);
  120.   Msgsev Uns(5) Pos(1);
  121.   Msgno Uns(5) Pos(3);
  122.   C_S_C Char(1);
  123.   FacilityId Char(3);
  124.   I_S_Info Char(4);
  125. End-ds;
  126.  
  127.  
  128.  
  129.  
  130. Dcl-Proc Utl_FmtNumForDec EXPORT;
  131. //===================================================================
  132. //===================================================================
  133. // @Procedure name: Utl_FmtNumForDec
  134. //===================================================================
  135. //===================================================================
  136. Dcl-Pi Utl_FmtNumForDec Varchar(128) OPDESC;
  137.   String Varchar(128) Const;
  138.   Precision Int(5) Options( *Nopass ) Const;
  139.   Decimalplaces Int(5) Options( *Nopass ) Const;
  140.   pAssumeDecimal Ind Options( *Nopass ) Const;
  141.   pIgnoreNegative Ind Options( *Nopass ) Const;
  142.   pDigitsOnly Ind Options( *Nopass ) Const;
  143.   pErrorDS Char(512) OPTIONS(*VARSIZE:*OMIT:*NOPASS);
  144.   pValidStrict Ind Options( *Nopass ) Const;
  145. End-Pi;
  146.  
  147. Dcl-S DscTyp Int(10);
  148. Dcl-S DtaTyp Int(10);
  149. Dcl-S DscInf1 Int(10);
  150. Dcl-S DscInf2 Int(10);
  151. Dcl-S ArgLen Int(10);
  152.  
  153.  
  154. // Local fields
  155. Dcl-S Decperc Int(5) Inz( 0 );
  156. Dcl-S Decpos Int(5) Inz( 0 );
  157. Dcl-S FirstChar Char(1) Inz;
  158. Dcl-S LastDot Int(5) Inz( 0 );
  159. Dcl-S LastChar Char(1) Inz;
  160. Dcl-S Validate Ind Inz(*OFF);
  161. Dcl-S ValidStrict Ind Inz(*OFF);
  162. Dcl-S AssumeDecimal Ind Inz(*OFF);
  163. Dcl-S Negative Ind Inz(*OFF);
  164. Dcl-S IgnoreNegative Ind Inz(*OFF);
  165. Dcl-S ErrorOnce Ind Inz(*Off);
  166. Dcl-S DigitsOnly Ind Inz(*Off);
  167.  
  168. Dcl-S Len1 Int(10) Inz( 0 );
  169. Dcl-S Idx Int(10) Inz( 0 );
  170. Dcl-S Retfield Varchar(128);
  171. Dcl-S ReturnError Varchar(128) INZ;
  172. Dcl-S Dftreturn Varchar(128) INZ;
  173. Dcl-S AllZeros Char(128) INZ(*ZEROS);
  174. Dcl-S AllBlanks Char(128) INZ(*BLANKS);
  175. Dcl-C NUMBERS CONST('0123456789');
  176. Dcl-C REMOVECHARS CONST(',$*+-%');
  177. Dcl-C VALIDCHARS CONST('0123456789,$*+-.%');
  178. Dcl-S Lerrords LIKE(Apierrords) BASED(Ptrerror);
  179.  
  180. Validate = *Off;
  181. ArgLen = 0;
  182. Ptrerror = *NULL;
  183. IF %PARMS() >= %Parmnum(Perrords) AND %ADDR(Perrords) <> *NULL;
  184.   Ptrerror = %ADDR(Perrords);
  185.  
  186.   // If parm isn't passed as OMIT then set return Api DS.
  187.   IF Ptrerror <> *NULL;
  188.     Validate = *on;
  189.     ArgLen = 0;
  190.     CEEDOD(%Parmnum(Perrords)
  191.       :DscTyp:DtaTyp:DscInf1:DscInf2:ArgLen:*OMIT);
  192.   ENDIF;
  193. ENDIF;
  194. If %Parms() >= %Parmnum( pValidStrict );
  195.   ValidStrict = pValidStrict;
  196. Endif;
  197. If ArgLen > 0;
  198.   Tlk_SetApiError(Lerrords :' ' :' ' :ArgLen);
  199. Endif;
  200.  
  201. If %Len( String ) = 0;
  202.   Return String;
  203. Endif;
  204. If %Parms() >= %Parmnum( Precision );
  205.   Decperc = Precision;
  206. Endif;
  207. If %Parms() >= %Parmnum( Decimalplaces );
  208.   Decpos = Decimalplaces;
  209. Endif;
  210. If %Parms() >= %Parmnum( pAssumeDecimal );
  211.   AssumeDecimal = pAssumeDecimal;
  212. Endif;
  213. If %Parms() >= %Parmnum( pIgnoreNegative );
  214.   IgnoreNegative = pIgnoreNegative;
  215. Endif;
  216. If %Parms() >= %Parmnum( pDigitsOnly );
  217.   DigitsOnly = pDigitsOnly;
  218. Endif;
  219. // "Digits only" ignores decimal positions.
  220. If DigitsOnly;
  221.   Decpos = 0;
  222. Elseif Decpos > 63;
  223.   Decpos = 63;
  224. Elseif Decpos < 0;
  225.   Decpos = 0;
  226. Endif;
  227. If Decperc > 63;
  228.   Decperc = 63;
  229. Elseif Decperc < 0;
  230.   Decperc = 0;
  231. Endif;
  232. // Make sure Decperc is more than whats required for Despos value.
  233. If Decpos > 0 and Decperc >0 and Decperc < Decpos + 2;
  234.   Decperc = Decpos + 2;
  235. Endif;
  236.  
  237. // Remove any inner blanks.   "1 2 3 4" becomes "1234"
  238. Retfield = %Scanrpl( ' ' :'' :String );
  239. Len1 = %Len( retfield );
  240. // Check for blanks.
  241. If Len1 = 0;
  242.   // On blank input return blank output.
  243.   Return String;
  244. Endif;
  245.  
  246. // When digits only, just strip anything not a digit.
  247. If DigitsOnly;
  248.   Exsr BuildDigitsOnly;
  249. Endif;
  250.  
  251. // remove every character of these
  252. Retfield = %Scanrpl( ',' :'' :Retfield );
  253. Retfield = %Scanrpl( '$' :'' :Retfield );
  254. Retfield = %Scanrpl( '*' :'' :Retfield );
  255. Retfield = %Scanrpl( '+' :'' :Retfield );
  256. Retfield = %Scanrpl( '%' :'' :Retfield );
  257.  
  258. Len1 = %Len( Retfield );
  259. // Save first and last character for a negative check.
  260. FirstChar = %Subst( Retfield :1 :1);
  261. LastChar = %Subst( Retfield :Len1 :1);
  262.  
  263. // Accept negative leading/trailing.
  264. If FirstChar ='-' or LastChar='-';
  265.  
  266.   // Accept negative as (123.00)  -> translate to -123.00
  267. Elseif FirstChar='(' and LastChar =')' and Len1 > 2;
  268.   Clear LastChar;
  269.   FirstChar = '-';
  270.   Retfield = %Subst( Retfield :2 : Len1 -2);
  271.  
  272.   // Accept negative as 123.00CR -> translate to -123.00
  273. Elseif Len1 > 2 and %Subst( Retfield :Len1-2 :2) ='CR';
  274.   Clear LastChar;
  275.   FirstChar = '-';
  276.   Retfield = %Subst( Retfield :1 : Len1 -2);
  277.  
  278.   // Check for a packed negitive number
  279. Elseif LastChar >= x'D0' AND LastChar <= x'D9';
  280.   LastChar = '-';
  281.   %Subst(Retfield :Len1 :1)=%BitOr( %Subst( Retfield :Len1 :1) :X'F0');
  282. Endif;
  283.  
  284. // Remove all minus signs.
  285. Retfield = %Scanrpl( '-' :'' :Retfield );
  286. Len1 = %Len( Retfield );
  287.  
  288. // Invalid characters in input (like letters)
  289. If %Check(NUMBERS+'.' :Retfield) > 0;
  290.   If (Validate Or ValidStrict);
  291.     If ArgLen > 0;
  292.       Tlk_SetApiError(Lerrords :'ERR9996'
  293.         :'Invalid character entered for numeric value.'
  294.         :ArgLen);
  295.     Endif;
  296.     Return String;
  297.   Endif;
  298.   // Strip out bad characters.
  299.   For idx = 1 to Len1;
  300.     If %Check(NUMBERS+'.' : %Subst(Retfield :idx :1) ) > 0;
  301.       %Subst(Retfield :idx :1) = ' ';
  302.     Endif;
  303.   Endfor;
  304.   // Strip blanks just entered.
  305.   Retfield = %Scanrpl( ' ' :'' :Retfield );
  306.   Len1 = %Len( retfield );
  307. Endif;
  308.  
  309. // Return default formatted output when nonblank input.
  310. If Len1=0 or Retfield='.';
  311.   Exsr BuildDefault;
  312.   Retfield = Dftreturn;
  313. Endif;
  314.  
  315. // The first non-number from the right "Should" be the last Decimal
  316. LastDot = 0;
  317. Idx = %CheckR(NUMBERS :Retfield);
  318. If Idx > 0;
  319.   LastDot = Idx;
  320.   // Strip out any extra decimals.
  321.   If LastDot > 1;
  322.     Retfield = %Scanrpl( '.' :'' :Retfield :1 :LastDot-1);
  323.     // If we removed something we will need to get the position again.
  324.     LastDot = %Scan('.' :Retfield);
  325.   Endif;
  326. Endif;
  327. // Get new length
  328. Len1 = %Len(Retfield);
  329.  
  330. // We received a string without decimals, and we are allowed
  331. // to assume the right most digits of the string are intended as decimals
  332. If Decpos > 0 and LastDot = 0 And AssumeDecimal;
  333.   // not enough decimals, add more zeros to left.
  334.   If Len1 < Decpos;
  335.     Retfield = '0.' + %SUBST(AllZeros:1:Decpos-Len1) + Retfield;
  336.  
  337.     // Have just enough decimals
  338.   Elseif Len1 = Decpos;
  339.     Retfield = '0.'  + Retfield;
  340.  
  341.     // More digits that we need for the decimal were passed. Insert a decimal
  342.   Else;
  343.     // Len1 > Decpos;
  344.     Retfield = %Subst(Retfield :1 : Len1-Decpos ) + '.'
  345.       + %Subst(Retfield : Len1-Decpos+1);
  346.   Endif;
  347.   LastDot = %Scan('.' :Retfield);
  348.   Len1 = %Len(Retfield);
  349. Endif;
  350.  
  351. // Error. We were passed decimals, however the request was for no decimals.
  352. If ValidStrict And Decpos =0 And LastDot<>0 and Len1 <>LastDot;
  353.   If ArgLen > 0;
  354.     Tlk_SetApiError(Lerrords :'ERR9996'
  355.       :'Use of decimals not correct or too many numbers entered.'
  356.       :ArgLen);
  357.   Endif;
  358.   Return String;
  359. Endif;
  360.  
  361. // Get the first character that is not a zero.
  362. Idx =  %Check('0' :Retfield);
  363. // Remove extra leading zeros when all we have is zeros. 000 becomes 0
  364. If Idx =0 and Len1 > 0;
  365.   Exsr BuildDefault;
  366.   Retfield = Dftreturn;
  367.   Len1 = %Len(Retfield);
  368.  
  369.   // Remove all leading zeros prior to decimal.   000.00 becomes 0.00
  370. Elseif Idx > 0 And %Subst(Retfield:Idx:1) ='.';
  371.   Retfield = '0' + %Subst(Retfield:Idx);
  372.   Len1 = %Len(Retfield);
  373.   LastDot = %Scan('.' :Retfield);
  374.  
  375.   // The zero precedes another number.
  376. Elseif Idx > 0 And %Subst(Retfield:Idx:1) <>'.';
  377.   Retfield = %Subst(Retfield:Idx);
  378.   Len1 = %Len(Retfield);
  379.   LastDot = %Scan('.' :Retfield);
  380. Endif;
  381.  
  382. // No decimals allowed and all we have is decimals.
  383. If Decpos = 0 and LastDot = 1;
  384.   Exsr BuildDefault;
  385.   Retfield = Dftreturn;
  386.   Len1 = %Len(Retfield);
  387.  
  388.   // Truncate decimals.
  389. Elseif Decpos = 0 and LastDot > 1;
  390.   Retfield = %Subst( Retfield : 1 : LastDot-1);
  391.   Len1 = %Len(Retfield);
  392.  
  393.   // don't want decimals, don't got decimals.
  394. Elseif Decpos = 0;
  395.  
  396.   // Want decimals.
  397. Elseif Decpos > 0;
  398.  
  399.   // Wanted decimals, but we didn't get any. Add zeros.
  400.   If Lastdot = 0;
  401.     Retfield += '.' + %SUBST(AllZeros:1:Decpos);
  402.     Lastdot = Len1+1;
  403.     Len1 = %Len(Retfield);
  404.  
  405.     // Next we need to add addtional decimals zeros to account for requested decimals.
  406.   Elseif (Decpos - (Len1- Lastdot)) > 0;
  407.     //    Retfield += %SUBST(AllZeros:1: (Len1- (Lastdot+Decpos)));
  408.     Retfield += %SUBST(AllZeros:1: (Decpos - (Len1- Lastdot)));
  409.     Len1 = %Len(Retfield);
  410.   Endif;
  411.  
  412.   // Error. To many decimals were passed.
  413.   If ValidStrict and Len1 > (Lastdot+ Decpos);
  414.     If ArgLen > 0;
  415.       Tlk_SetApiError(Lerrords :'ERR9996'
  416.         :'Use of decimals not correct or too many numbers entered.'
  417.         :ArgLen);
  418.     Endif;
  419.     Return String;
  420.   Endif;
  421.  
  422.   // To many decimals. Truncate extra decimals.
  423.   If Len1 > (Lastdot+ Decpos);
  424.     Retfield = %Subst( Retfield : 1 : (Lastdot+ Decpos));
  425.     Len1 = %Len(Retfield);
  426.   Endif;
  427.  
  428. Endif;
  429. //----------------------------------------
  430. // Assume at this point that we have accounted for any decimals
  431. //----------------------------------------
  432.  
  433. // Now we must add any leading zeros to account for Precision
  434. If Decperc > 0;
  435.   If Decpos > 0;
  436.     If Decperc > (Len1-1);
  437.       Retfield = %Subst(AllBlanks:1:Decperc-(Len1-1)) +Retfield;
  438.       Len1 = %Len(Retfield);
  439.     Endif;
  440.  
  441.   Else;
  442.     If Decperc > (Len1);
  443.       Retfield = %Subst(AllBlanks:1:Decperc-(Len1)) +Retfield;
  444.       Len1 = %Len(Retfield);
  445.     Endif;
  446.   Endif;
  447. Endif;
  448. //----------------------------------------
  449. //----------------------------------------
  450. Negative = *off;
  451. // Check if all we have are zeros, blanks, and a decimal.
  452. Idx = %Check(' .0' :Retfield);
  453. // Ignore negative Flag
  454. // Ingore when when zero output.
  455. If Idx = 0 or IgnoreNegative;
  456.   // Ignore negative for zeros.
  457.  
  458.   // Number was negative so add back that condition
  459. Elseif Firstchar = '-';
  460.   Negative = *on;
  461.   // Get last blank.
  462.   Idx = %CheckR(NUMBERS+'.' :Retfield);
  463.   // Insert negative just after leading blanks.
  464.   If Idx > 0 and Idx < Len1;
  465.     Retfield = %Subst(Retfield:1:Idx) +'-' + %Subst(Retfield:Idx+1);
  466.     Len1 = %Len(Retfield);
  467.  
  468.     // Add as leading negative.
  469.   Else;
  470.     Retfield = Firstchar +Retfield;
  471.     Len1 = %Len(Retfield);
  472.   Endif;
  473.  
  474.   // Add Trailing negative.
  475. Elseif Lastchar = '-';
  476.   Negative = *on;
  477.   Retfield += Lastchar;
  478.   Len1 = %Len(Retfield);
  479. Endif;
  480.  
  481. // Check if the generated field length has exceeded the passed Precision.
  482. IDX = Decperc;
  483. // Count negative sign
  484. If Negative;
  485.   IDX += 1;
  486. Endif;
  487. // Count decimal sign.
  488. If Decpos > 0;
  489.   IDX += 1;
  490. Endif;
  491. If ValidStrict And Decperc > 0 and IDX < Len1;
  492.   If ArgLen > 0;
  493.     Tlk_SetApiError(Lerrords :'ERR9996'
  494.       :'Use of decimals not correct or too many numbers entered.'
  495.       :ArgLen);
  496.   Endif;
  497.   Return String;
  498. Endif;
  499. // Truncate leading digits.
  500. If Decperc > 0 and IDX < Len1;
  501.   Retfield = %Subst( Retfield : Len1-Idx+1);
  502.   Len1 = %Len(Retfield);
  503. Endif;
  504.  
  505. // Set errorDs for no error
  506. If ArgLen > 0;
  507.   Tlk_SetApiError(Lerrords :' ' :' ' :ArgLen);
  508. Endif;
  509.  
  510. Return Retfield;
  511.  
  512. //-----------------------------------------------------------------------
  513. // Build with Digits Only
  514. //-----------------------------------------------------------------------
  515. Begsr BuildDigitsOnly;
  516.  
  517.   // Strip non-digit characters.
  518.   Idx = %Check(NUMBERS :Retfield );
  519.   If Idx > 0;
  520.     Dow Idx > 0;
  521.       %Subst(Retfield :idx :1) = ' ';
  522.       If Idx+1 > Len1;
  523.         Leave;
  524.       Endif;
  525.       Idx = %Check(NUMBERS+' ' :Retfield : Idx+1);
  526.     Enddo;
  527.     // Strip blanks just entered.
  528.     Retfield = %Scanrpl( ' ' :'' :Retfield );
  529.     Len1 = %Len( retfield );
  530.   Endif;
  531.  
  532.   // No change to output
  533.   IF Decperc = 0;
  534.  
  535.     // Pad ouput with leading zeros up to Precision.
  536.   Elseif Decperc > Len1;
  537.     Retfield = %Subst(AllZeros:1:Decperc-(Len1)) +Retfield;
  538.     // Truncate leading digits down to Precision.
  539.   Elseif Decperc < Len1;
  540.     Retfield = %Subst( Retfield : Len1-Decperc+1);
  541.   Endif;
  542.   Return Retfield;
  543.  
  544. Endsr;
  545. //-----------------------------------------------------------------------
  546. // Build the default return value.
  547. //-----------------------------------------------------------------------
  548. Begsr BuildDefault;
  549.  
  550.   If Decpos = 0 and Decperc = 0;
  551.     Dftreturn = '0';
  552.   Elseif Decpos = 0;
  553.     Dftreturn = %Subst(AllBlanks:1:Decperc-1)+'0';
  554.   Elseif Decperc > 0;
  555.     If Decperc > (Decpos + 1);
  556.       Dftreturn = %Subst(AllBlanks:1:Decperc-(Decpos+1)) +'0.'
  557.       + %SUBST(AllZeros:1:Decpos);
  558.     Else;
  559.       Dftreturn =  '0.'+ %SUBST(AllZeros:1:Decpos);
  560.     Endif;
  561.   Else;
  562.     Dftreturn =  '0.'+ %SUBST(AllZeros:1:Decpos);
  563.   Endif;
  564.  
  565. Endsr;
  566. //==================
  567. Begsr *PSSR;
  568.   If ErrorOnce;
  569.     Return '';
  570.   Endif;
  571.   ErrorOnce = *on;
  572.   If ArgLen > 0;
  573.     Tlk_SetApiError(Lerrords :'ERR9996'
  574.       :'Utl_FmtNumForDec Error: ' +PgmInfErrorMsg
  575.       :ArgLen);
  576.   Endif;
  577.  
  578.   Return String;
  579. Endsr;
  580. End-Proc Utl_FmtNumForDec;
  581.  
  582.  
  583.  
  584. // Note: Tlk_SetApiError was included so the above procedure can be compiled.
  585. // It is actually part of a larger service program for message processing.
  586.  
  587.  
  588. // Tlk_SetApiError  
  589. // This procedure will properly load a data structure in 
  590. //  the format of a QSYSINC/QRPGLESRC,QUSEC error mesage.
  591. Dcl-Proc Tlk_SetApiError Export;
  592. Dcl-Pi Tlk_SetApiError OPDESC;
  593.   ErrorDS Char(32767) OPTIONS(*VARSIZE);
  594.   MsgId Char(7) CONST OPTIONS(*VARSIZE:*NOPASS);
  595.   MsgDta Varchar(32767) CONST OPTIONS(*VARSIZE:*NOPASS);
  596.   SizeErrorDS Uns(10) CONST OPTIONS(*NOPASS);
  597. End-Pi;
  598. Dcl-S MaxDtaLen Int(10);
  599. Dcl-S ApiSize Int(10);
  600. Dcl-S ErrDSLen LIKE(Ceedod_DS.ArgLen);
  601. // lErrorDS is 32767 bytes long.
  602. Dcl-Ds Lerrords Len(32767) BASED(ptr_ErrorDS) QUALIFIED;
  603.   Q LIKEDS(QUSEC);
  604.   MsgData Char(32751);
  605. End-Ds;
  606. Dcl-ds lFc Likeds(Ceedod_FB_t) Inz;
  607. Dcl-ds P1 Likeds(Ceedod_DS) Inz;
  608. /COPY QSYSINC/QRPGLESRC,QUSEC
  609. Dcl-Ds APIErr;                                                           // Error structure.
  610.   APIErrPrv LIKE(QUSBPRV) INZ(%LEN(APIErr));                             // Bytes provided.
  611.   APIErrAva LIKE(QUSBAVL);                                               // Bytes available.
  612.   APIErrMsg LIKE(QUSEI);                                                 // Return message ID
  613.   APIErrRes LIKE(QUSERVED);                                              // Reserved area.
  614.   APIErrDta Char(240);                                                   // Error message dat
  615. End-Ds;
  616.  
  617. CEEDOD(%Parmnum(ErrorDS):P1.DscTyp:P1.DtaTyp:P1.DscInf1:P1.DscInf2:ApiSize:P1.Fbcod);
  618. If lFc.Id <> 0;
  619.   // error using CEEDOD.
  620.   Clear ApiSize;
  621.   IF %PARMS()>= %Parmnum(SizeErrorDS) AND %ADDR(SizeErrorDS)<>*NULL;
  622.     ApiSize = SizeErrorDS;
  623.   Endif;
  624. Endif;
  625.  
  626. // Allow SizeErrorDS parm to override OPDESC value received
  627. // for ErrorDS. This is only needed when the ErrorDS is being
  628. // passed through an intermediary procedure that
  629. // is also checking the Operational Descriptor (OPDESC).
  630. IF %PARMS()>= %Parmnum(SizeErrorDS) AND ApiSize > SizeErrorDS;
  631.   ApiSize = SizeErrorDS;
  632. ENDIF;
  633. // Make sure we can at least load the 16 bytes defined in QUSEC.
  634. IF ApiSize < %SIZE(QUSEC);
  635.   RETURN;
  636. ENDIF;
  637.  
  638. ptr_ErrorDS = %ADDR(ErrorDS);
  639. lErrorDS.Q.QUSBPRV = ApiSize;
  640. lErrorDS.Q.QUSBAVL = 0;
  641. MaxDtaLen = (ApiSize - %SIZE(QUSEC));
  642. ErrDSLen = 0;
  643.  
  644. // Return no Available Bytes or Bytes Provided when message data is blank.
  645. IF %PARMS() < %Parmnum( MsgId ) OR MsgId = *blanks;
  646.   lErrorDS.Q.QUSEI = *BLANKS;
  647.   lErrorDS.Q.QUSBAVL = 0;
  648.  
  649. Else;
  650.  
  651.   lErrorDS.Q.QUSEI = MsgId;
  652.   lErrorDS.Q.QUSBAVL = %SIZE(QUSEC);
  653.  
  654.   IF %PARMS() >= %Parmnum( MsgDta );
  655.     // retrieve length of message data.
  656.     Monitor;
  657.       ErrDsLen = %LEN(MsgDta);
  658.     on-error;
  659.       ErrDsLen = 0;
  660.     Endmon;
  661.   ENDIF;
  662. ENDIF;
  663.  
  664. // Add bytes available for message data.
  665. lErrorDS.Q.QUSBAVL += ErrDSLen;
  666.  
  667. IF ErrDSLen > MaxDtaLen;
  668.   ErrDSLen = MaxDtaLen;
  669. ENDIF;
  670.  
  671. // Set message data.
  672. IF ErrDSLen > 0;
  673.   %SUBST(Lerrords.MsgData:1:MaxDtaLen) = %SUBST(MsgDta:1:ErrDSLen);
  674.  
  675.   // Clear available message data.
  676. ELSEIF MaxDtaLen > 0;
  677.   %SUBST(Lerrords.MsgData:1:MaxDtaLen) = *BLANKS;
  678. ENDIF;
  679. RETURN;
  680. End-Proc Tlk_SetApiError;
  681.  
© 2004-2019 by midrange.com generated in 0.01s valid xhtml & css