Code:
- // Here is an example usage of the procedure:
-
- DCL-S FLD2 VARCHAR(128);
- DCL-S fld1 CHAR(7);
- DCL-S FLD3 PACKED(7:2);
- fld1 = '002632J';
-
- FLD2 = UTL_FMTNUMFORDEC(fld1:7:2:*ON:*OFF);
- FLD3 = %DEC( FLD2 : 7:2);
-
-
- // This is what I put into the Service Program's Copy Book:
-
- /IF NOT DEFINED(Utl_FmtNumForDec)
- /DEFINE Utl_FmtNumForDec
- //===================================================================
- // @Name - Utl_FmtNumForDec
- // @Description - Format a string number for a %DEC function.
-
- // @Usage - Utl_FmtNumForDec( String);
- // @Usage - Utl_FmtNumForDec( String : %Size(DecFld) : %Decpos(DecFld)
- // :*on :*on :*on :PerrorDS);
- // @Usage - Utl_FmtNumForDec( Position :15:0 );
- // @Usage - Utl_FmtNumForDec( wkField :%SIZE(OutField) :ErrorDS)
-
- // @Params - String to be converted (required)
- // Output Precision
- // Ignored when zero
- // Values Between 1 and 63
- // Minimum value is DecimalPlaces+2 (Unless Decimal is zero)
- // Output Decimal places
- // Values Between 0 and 63
- // AssumeDecimal
- // If decimal character not passed in input then the
- // rightmost digits are used to fill the Decimal places.
- // This option will correctly parse the negative out of
- // a packed edit code "X" string.
- // Ignore Negative inputs
- // Digits Only
- // Ignores all non-digits.
- // Pads leading zeros up to Precision.
- // Error DS (When passed Validation is active)
- // Errors out when characters are included in input.
- // Strict Validation active
- // Error: when characters are included in input.
- // Error: when generated string exceeds decimal places
- // Error: when generated string exceeds Precision
-
- // @Returns - On success: Reformatted number usable by function %DEC().
- // On failure: Input String, and Error DS (if passed).
-
- // Notes on negatives.
- // (123) translates to -123
- // 123CR translates to -123
- // -123 translates to -123
- // 123- translates to 123-
- // X'F1D1' translates to 11- (Packed Edit Code 'X' negative)
-
- // Characters Stripped: ,$*+%-.
-
- //===================================================================
- Dcl-Pr Utl_FmtNumForDec Varchar(128) Opdesc;
- String Varchar(128) Const;
- Precision Int(5) Options( *NOPASS ) Const;
- Decimalplaces Int(5) Options( *NOPASS ) Const;
- Assumedecimal Ind Options( *NOPASS ) Const;
- Ignorenegative Ind Options( *NOPASS ) Const;
- Digitsonly Ind Options( *NOPASS ) Const;
- Perrords Char(512) Options(*VARSIZE:*OMIT:*NOPASS);
- Validstrict Ind Options( *NOPASS ) Const;
- End-Pr;
- /ENDIF
-
-
-
-
-
-
- // These are some global definitions required by the two procedures.
-
- // we actually map more PSDS fields, but this is the only one used in Utl_FmtNumForDec
- Dcl-Ds PGMINF psds;
- PgmInfErrorMsg Char(80) Pos(091);
- End-Ds;
-
- Dcl-Ds Apierrords QUALIFIED;
- Bytespass Int(10) INZ(%SIZE(APIERRORDS));
- Bytesavail Int(10) INZ(*ZERO);
- MsgID Char(7) INZ(*BLANKS);
- *N Char(1) INZ(X'00');
- MsgDta Char(256) INZ(*BLANKS);
- End-Ds;
-
- Dcl-Pr CEEDOD;
- PR_ArgNum Int(10) CONST;
- PR_DscTyp Int(10);
- PR_DtaTyp Int(10);
- PR_DscInf1 Int(10);
- PR_DscInf2 Int(10);
- PR_ArgLen Int(10);
- PR_FBCod Char(12) OPTIONS(*OMIT);
- End-Pr;
- //*************************
- //* CEEDOD API Parameters *
- //*************************
- Dcl-ds Ceedod_DS Template Qualified;
- Arg Int(10);
- DscTyp Int(10);
- DtaTyp Int(10);
- Dscinf1 Int(10);
- Dscinf2 Int(10);
- Arglen Int(10);
- Fbcod Likeds(Ceedod_FB_t);
- End-ds;
-
- // To test for success, determine if the first 4 bytes are 0.
- // If the first 4 bytes are 0, then the remainder is 0.
- Dcl-ds Ceedod_FB_t Len(12) Template Qualified;
- Id Uns(10);
- Msgsev Uns(5) Pos(1);
- Msgno Uns(5) Pos(3);
- C_S_C Char(1);
- FacilityId Char(3);
- I_S_Info Char(4);
- End-ds;
-
-
-
-
- Dcl-Proc Utl_FmtNumForDec EXPORT;
- //===================================================================
- //===================================================================
- // @Procedure name: Utl_FmtNumForDec
- //===================================================================
- //===================================================================
- Dcl-Pi Utl_FmtNumForDec Varchar(128) OPDESC;
- String Varchar(128) Const;
- Precision Int(5) Options( *Nopass ) Const;
- Decimalplaces Int(5) Options( *Nopass ) Const;
- pAssumeDecimal Ind Options( *Nopass ) Const;
- pIgnoreNegative Ind Options( *Nopass ) Const;
- pDigitsOnly Ind Options( *Nopass ) Const;
- pErrorDS Char(512) OPTIONS(*VARSIZE:*OMIT:*NOPASS);
- pValidStrict Ind Options( *Nopass ) Const;
- End-Pi;
-
- Dcl-S DscTyp Int(10);
- Dcl-S DtaTyp Int(10);
- Dcl-S DscInf1 Int(10);
- Dcl-S DscInf2 Int(10);
- Dcl-S ArgLen Int(10);
-
-
- // Local fields
- Dcl-S Decperc Int(5) Inz( 0 );
- Dcl-S Decpos Int(5) Inz( 0 );
- Dcl-S FirstChar Char(1) Inz;
- Dcl-S LastDot Int(5) Inz( 0 );
- Dcl-S LastChar Char(1) Inz;
- Dcl-S Validate Ind Inz(*OFF);
- Dcl-S ValidStrict Ind Inz(*OFF);
- Dcl-S AssumeDecimal Ind Inz(*OFF);
- Dcl-S Negative Ind Inz(*OFF);
- Dcl-S IgnoreNegative Ind Inz(*OFF);
- Dcl-S ErrorOnce Ind Inz(*Off);
- Dcl-S DigitsOnly Ind Inz(*Off);
-
- Dcl-S Len1 Int(10) Inz( 0 );
- Dcl-S Idx Int(10) Inz( 0 );
- Dcl-S Retfield Varchar(128);
- Dcl-S ReturnError Varchar(128) INZ;
- Dcl-S Dftreturn Varchar(128) INZ;
- Dcl-S AllZeros Char(128) INZ(*ZEROS);
- Dcl-S AllBlanks Char(128) INZ(*BLANKS);
- Dcl-C NUMBERS CONST('0123456789');
- Dcl-C REMOVECHARS CONST(',$*+-%');
- Dcl-C VALIDCHARS CONST('0123456789,$*+-.%');
- Dcl-S Lerrords LIKE(Apierrords) BASED(Ptrerror);
-
- Validate = *Off;
- ArgLen = 0;
- Ptrerror = *NULL;
- IF %PARMS() >= %Parmnum(Perrords) AND %ADDR(Perrords) <> *NULL;
- Ptrerror = %ADDR(Perrords);
-
- // If parm isn't passed as OMIT then set return Api DS.
- IF Ptrerror <> *NULL;
- Validate = *on;
- ArgLen = 0;
- CEEDOD(%Parmnum(Perrords)
- :DscTyp:DtaTyp:DscInf1:DscInf2:ArgLen:*OMIT);
- ENDIF;
- ENDIF;
- If %Parms() >= %Parmnum( pValidStrict );
- ValidStrict = pValidStrict;
- Endif;
- If ArgLen > 0;
- Tlk_SetApiError(Lerrords :' ' :' ' :ArgLen);
- Endif;
-
- If %Len( String ) = 0;
- Return String;
- Endif;
- If %Parms() >= %Parmnum( Precision );
- Decperc = Precision;
- Endif;
- If %Parms() >= %Parmnum( Decimalplaces );
- Decpos = Decimalplaces;
- Endif;
- If %Parms() >= %Parmnum( pAssumeDecimal );
- AssumeDecimal = pAssumeDecimal;
- Endif;
- If %Parms() >= %Parmnum( pIgnoreNegative );
- IgnoreNegative = pIgnoreNegative;
- Endif;
- If %Parms() >= %Parmnum( pDigitsOnly );
- DigitsOnly = pDigitsOnly;
- Endif;
- // "Digits only" ignores decimal positions.
- If DigitsOnly;
- Decpos = 0;
- Elseif Decpos > 63;
- Decpos = 63;
- Elseif Decpos < 0;
- Decpos = 0;
- Endif;
- If Decperc > 63;
- Decperc = 63;
- Elseif Decperc < 0;
- Decperc = 0;
- Endif;
- // Make sure Decperc is more than whats required for Despos value.
- If Decpos > 0 and Decperc >0 and Decperc < Decpos + 2;
- Decperc = Decpos + 2;
- Endif;
-
- // Remove any inner blanks. "1 2 3 4" becomes "1234"
- Retfield = %Scanrpl( ' ' :'' :String );
- Len1 = %Len( retfield );
- // Check for blanks.
- If Len1 = 0;
- // On blank input return blank output.
- Return String;
- Endif;
-
- // When digits only, just strip anything not a digit.
- If DigitsOnly;
- Exsr BuildDigitsOnly;
- Endif;
-
- // remove every character of these
- Retfield = %Scanrpl( ',' :'' :Retfield );
- Retfield = %Scanrpl( '$' :'' :Retfield );
- Retfield = %Scanrpl( '*' :'' :Retfield );
- Retfield = %Scanrpl( '+' :'' :Retfield );
- Retfield = %Scanrpl( '%' :'' :Retfield );
-
- Len1 = %Len( Retfield );
- // Save first and last character for a negative check.
- FirstChar = %Subst( Retfield :1 :1);
- LastChar = %Subst( Retfield :Len1 :1);
-
- // Accept negative leading/trailing.
- If FirstChar ='-' or LastChar='-';
-
- // Accept negative as (123.00) -> translate to -123.00
- Elseif FirstChar='(' and LastChar =')' and Len1 > 2;
- Clear LastChar;
- FirstChar = '-';
- Retfield = %Subst( Retfield :2 : Len1 -2);
-
- // Accept negative as 123.00CR -> translate to -123.00
- Elseif Len1 > 2 and %Subst( Retfield :Len1-2 :2) ='CR';
- Clear LastChar;
- FirstChar = '-';
- Retfield = %Subst( Retfield :1 : Len1 -2);
-
- // Check for a packed negitive number
- Elseif LastChar >= x'D0' AND LastChar <= x'D9';
- LastChar = '-';
- %Subst(Retfield :Len1 :1)=%BitOr( %Subst( Retfield :Len1 :1) :X'F0');
- Endif;
-
- // Remove all minus signs.
- Retfield = %Scanrpl( '-' :'' :Retfield );
- Len1 = %Len( Retfield );
-
- // Invalid characters in input (like letters)
- If %Check(NUMBERS+'.' :Retfield) > 0;
- If (Validate Or ValidStrict);
- If ArgLen > 0;
- Tlk_SetApiError(Lerrords :'ERR9996'
- :'Invalid character entered for numeric value.'
- :ArgLen);
- Endif;
- Return String;
- Endif;
- // Strip out bad characters.
- For idx = 1 to Len1;
- If %Check(NUMBERS+'.' : %Subst(Retfield :idx :1) ) > 0;
- %Subst(Retfield :idx :1) = ' ';
- Endif;
- Endfor;
- // Strip blanks just entered.
- Retfield = %Scanrpl( ' ' :'' :Retfield );
- Len1 = %Len( retfield );
- Endif;
-
- // Return default formatted output when nonblank input.
- If Len1=0 or Retfield='.';
- Exsr BuildDefault;
- Retfield = Dftreturn;
- Endif;
-
- // The first non-number from the right "Should" be the last Decimal
- LastDot = 0;
- Idx = %CheckR(NUMBERS :Retfield);
- If Idx > 0;
- LastDot = Idx;
- // Strip out any extra decimals.
- If LastDot > 1;
- Retfield = %Scanrpl( '.' :'' :Retfield :1 :LastDot-1);
- // If we removed something we will need to get the position again.
- LastDot = %Scan('.' :Retfield);
- Endif;
- Endif;
- // Get new length
- Len1 = %Len(Retfield);
-
- // We received a string without decimals, and we are allowed
- // to assume the right most digits of the string are intended as decimals
- If Decpos > 0 and LastDot = 0 And AssumeDecimal;
- // not enough decimals, add more zeros to left.
- If Len1 < Decpos;
- Retfield = '0.' + %SUBST(AllZeros:1:Decpos-Len1) + Retfield;
-
- // Have just enough decimals
- Elseif Len1 = Decpos;
- Retfield = '0.' + Retfield;
-
- // More digits that we need for the decimal were passed. Insert a decimal
- Else;
- // Len1 > Decpos;
- Retfield = %Subst(Retfield :1 : Len1-Decpos ) + '.'
- + %Subst(Retfield : Len1-Decpos+1);
- Endif;
- LastDot = %Scan('.' :Retfield);
- Len1 = %Len(Retfield);
- Endif;
-
- // Error. We were passed decimals, however the request was for no decimals.
- If ValidStrict And Decpos =0 And LastDot<>0 and Len1 <>LastDot;
- If ArgLen > 0;
- Tlk_SetApiError(Lerrords :'ERR9996'
- :'Use of decimals not correct or too many numbers entered.'
- :ArgLen);
- Endif;
- Return String;
- Endif;
-
- // Get the first character that is not a zero.
- Idx = %Check('0' :Retfield);
- // Remove extra leading zeros when all we have is zeros. 000 becomes 0
- If Idx =0 and Len1 > 0;
- Exsr BuildDefault;
- Retfield = Dftreturn;
- Len1 = %Len(Retfield);
-
- // Remove all leading zeros prior to decimal. 000.00 becomes 0.00
- Elseif Idx > 0 And %Subst(Retfield:Idx:1) ='.';
- Retfield = '0' + %Subst(Retfield:Idx);
- Len1 = %Len(Retfield);
- LastDot = %Scan('.' :Retfield);
-
- // The zero precedes another number.
- Elseif Idx > 0 And %Subst(Retfield:Idx:1) <>'.';
- Retfield = %Subst(Retfield:Idx);
- Len1 = %Len(Retfield);
- LastDot = %Scan('.' :Retfield);
- Endif;
-
- // No decimals allowed and all we have is decimals.
- If Decpos = 0 and LastDot = 1;
- Exsr BuildDefault;
- Retfield = Dftreturn;
- Len1 = %Len(Retfield);
-
- // Truncate decimals.
- Elseif Decpos = 0 and LastDot > 1;
- Retfield = %Subst( Retfield : 1 : LastDot-1);
- Len1 = %Len(Retfield);
-
- // don't want decimals, don't got decimals.
- Elseif Decpos = 0;
-
- // Want decimals.
- Elseif Decpos > 0;
-
- // Wanted decimals, but we didn't get any. Add zeros.
- If Lastdot = 0;
- Retfield += '.' + %SUBST(AllZeros:1:Decpos);
- Lastdot = Len1+1;
- Len1 = %Len(Retfield);
-
- // Next we need to add addtional decimals zeros to account for requested decimals.
- Elseif (Decpos - (Len1- Lastdot)) > 0;
- // Retfield += %SUBST(AllZeros:1: (Len1- (Lastdot+Decpos)));
- Retfield += %SUBST(AllZeros:1: (Decpos - (Len1- Lastdot)));
- Len1 = %Len(Retfield);
- Endif;
-
- // Error. To many decimals were passed.
- If ValidStrict and Len1 > (Lastdot+ Decpos);
- If ArgLen > 0;
- Tlk_SetApiError(Lerrords :'ERR9996'
- :'Use of decimals not correct or too many numbers entered.'
- :ArgLen);
- Endif;
- Return String;
- Endif;
-
- // To many decimals. Truncate extra decimals.
- If Len1 > (Lastdot+ Decpos);
- Retfield = %Subst( Retfield : 1 : (Lastdot+ Decpos));
- Len1 = %Len(Retfield);
- Endif;
-
- Endif;
- //----------------------------------------
- // Assume at this point that we have accounted for any decimals
- //----------------------------------------
-
- // Now we must add any leading zeros to account for Precision
- If Decperc > 0;
- If Decpos > 0;
- If Decperc > (Len1-1);
- Retfield = %Subst(AllBlanks:1:Decperc-(Len1-1)) +Retfield;
- Len1 = %Len(Retfield);
- Endif;
-
- Else;
- If Decperc > (Len1);
- Retfield = %Subst(AllBlanks:1:Decperc-(Len1)) +Retfield;
- Len1 = %Len(Retfield);
- Endif;
- Endif;
- Endif;
- //----------------------------------------
- //----------------------------------------
- Negative = *off;
- // Check if all we have are zeros, blanks, and a decimal.
- Idx = %Check(' .0' :Retfield);
- // Ignore negative Flag
- // Ingore when when zero output.
- If Idx = 0 or IgnoreNegative;
- // Ignore negative for zeros.
-
- // Number was negative so add back that condition
- Elseif Firstchar = '-';
- Negative = *on;
- // Get last blank.
- Idx = %CheckR(NUMBERS+'.' :Retfield);
- // Insert negative just after leading blanks.
- If Idx > 0 and Idx < Len1;
- Retfield = %Subst(Retfield:1:Idx) +'-' + %Subst(Retfield:Idx+1);
- Len1 = %Len(Retfield);
-
- // Add as leading negative.
- Else;
- Retfield = Firstchar +Retfield;
- Len1 = %Len(Retfield);
- Endif;
-
- // Add Trailing negative.
- Elseif Lastchar = '-';
- Negative = *on;
- Retfield += Lastchar;
- Len1 = %Len(Retfield);
- Endif;
-
- // Check if the generated field length has exceeded the passed Precision.
- IDX = Decperc;
- // Count negative sign
- If Negative;
- IDX += 1;
- Endif;
- // Count decimal sign.
- If Decpos > 0;
- IDX += 1;
- Endif;
- If ValidStrict And Decperc > 0 and IDX < Len1;
- If ArgLen > 0;
- Tlk_SetApiError(Lerrords :'ERR9996'
- :'Use of decimals not correct or too many numbers entered.'
- :ArgLen);
- Endif;
- Return String;
- Endif;
- // Truncate leading digits.
- If Decperc > 0 and IDX < Len1;
- Retfield = %Subst( Retfield : Len1-Idx+1);
- Len1 = %Len(Retfield);
- Endif;
-
- // Set errorDs for no error
- If ArgLen > 0;
- Tlk_SetApiError(Lerrords :' ' :' ' :ArgLen);
- Endif;
-
- Return Retfield;
-
- //-----------------------------------------------------------------------
- // Build with Digits Only
- //-----------------------------------------------------------------------
- Begsr BuildDigitsOnly;
-
- // Strip non-digit characters.
- Idx = %Check(NUMBERS :Retfield );
- If Idx > 0;
- Dow Idx > 0;
- %Subst(Retfield :idx :1) = ' ';
- If Idx+1 > Len1;
- Leave;
- Endif;
- Idx = %Check(NUMBERS+' ' :Retfield : Idx+1);
- Enddo;
- // Strip blanks just entered.
- Retfield = %Scanrpl( ' ' :'' :Retfield );
- Len1 = %Len( retfield );
- Endif;
-
- // No change to output
- IF Decperc = 0;
-
- // Pad ouput with leading zeros up to Precision.
- Elseif Decperc > Len1;
- Retfield = %Subst(AllZeros:1:Decperc-(Len1)) +Retfield;
- // Truncate leading digits down to Precision.
- Elseif Decperc < Len1;
- Retfield = %Subst( Retfield : Len1-Decperc+1);
- Endif;
- Return Retfield;
-
- Endsr;
- //-----------------------------------------------------------------------
- // Build the default return value.
- //-----------------------------------------------------------------------
- Begsr BuildDefault;
-
- If Decpos = 0 and Decperc = 0;
- Dftreturn = '0';
- Elseif Decpos = 0;
- Dftreturn = %Subst(AllBlanks:1:Decperc-1)+'0';
- Elseif Decperc > 0;
- If Decperc > (Decpos + 1);
- Dftreturn = %Subst(AllBlanks:1:Decperc-(Decpos+1)) +'0.'
- + %SUBST(AllZeros:1:Decpos);
- Else;
- Dftreturn = '0.'+ %SUBST(AllZeros:1:Decpos);
- Endif;
- Else;
- Dftreturn = '0.'+ %SUBST(AllZeros:1:Decpos);
- Endif;
-
- Endsr;
- //==================
- Begsr *PSSR;
- If ErrorOnce;
- Return '';
- Endif;
- ErrorOnce = *on;
- If ArgLen > 0;
- Tlk_SetApiError(Lerrords :'ERR9996'
- :'Utl_FmtNumForDec Error: ' +PgmInfErrorMsg
- :ArgLen);
- Endif;
-
- Return String;
- Endsr;
- End-Proc Utl_FmtNumForDec;
-
-
-
- // Note: Tlk_SetApiError was included so the above procedure can be compiled.
- // It is actually part of a larger service program for message processing.
-
-
- // Tlk_SetApiError
- // This procedure will properly load a data structure in
- // the format of a QSYSINC/QRPGLESRC,QUSEC error mesage.
- Dcl-Proc Tlk_SetApiError Export;
- Dcl-Pi Tlk_SetApiError OPDESC;
- ErrorDS Char(32767) OPTIONS(*VARSIZE);
- MsgId Char(7) CONST OPTIONS(*VARSIZE:*NOPASS);
- MsgDta Varchar(32767) CONST OPTIONS(*VARSIZE:*NOPASS);
- SizeErrorDS Uns(10) CONST OPTIONS(*NOPASS);
- End-Pi;
- Dcl-S MaxDtaLen Int(10);
- Dcl-S ApiSize Int(10);
- Dcl-S ErrDSLen LIKE(Ceedod_DS.ArgLen);
- // lErrorDS is 32767 bytes long.
- Dcl-Ds Lerrords Len(32767) BASED(ptr_ErrorDS) QUALIFIED;
- Q LIKEDS(QUSEC);
- MsgData Char(32751);
- End-Ds;
- Dcl-ds lFc Likeds(Ceedod_FB_t) Inz;
- Dcl-ds P1 Likeds(Ceedod_DS) Inz;
- /COPY QSYSINC/QRPGLESRC,QUSEC
- Dcl-Ds APIErr; // Error structure.
- APIErrPrv LIKE(QUSBPRV) INZ(%LEN(APIErr)); // Bytes provided.
- APIErrAva LIKE(QUSBAVL); // Bytes available.
- APIErrMsg LIKE(QUSEI); // Return message ID
- APIErrRes LIKE(QUSERVED); // Reserved area.
- APIErrDta Char(240); // Error message dat
- End-Ds;
-
- CEEDOD(%Parmnum(ErrorDS):P1.DscTyp:P1.DtaTyp:P1.DscInf1:P1.DscInf2:ApiSize:P1.Fbcod);
- If lFc.Id <> 0;
- // error using CEEDOD.
- Clear ApiSize;
- IF %PARMS()>= %Parmnum(SizeErrorDS) AND %ADDR(SizeErrorDS)<>*NULL;
- ApiSize = SizeErrorDS;
- Endif;
- Endif;
-
- // Allow SizeErrorDS parm to override OPDESC value received
- // for ErrorDS. This is only needed when the ErrorDS is being
- // passed through an intermediary procedure that
- // is also checking the Operational Descriptor (OPDESC).
- IF %PARMS()>= %Parmnum(SizeErrorDS) AND ApiSize > SizeErrorDS;
- ApiSize = SizeErrorDS;
- ENDIF;
- // Make sure we can at least load the 16 bytes defined in QUSEC.
- IF ApiSize < %SIZE(QUSEC);
- RETURN;
- ENDIF;
-
- ptr_ErrorDS = %ADDR(ErrorDS);
- lErrorDS.Q.QUSBPRV = ApiSize;
- lErrorDS.Q.QUSBAVL = 0;
- MaxDtaLen = (ApiSize - %SIZE(QUSEC));
- ErrDSLen = 0;
-
- // Return no Available Bytes or Bytes Provided when message data is blank.
- IF %PARMS() < %Parmnum( MsgId ) OR MsgId = *blanks;
- lErrorDS.Q.QUSEI = *BLANKS;
- lErrorDS.Q.QUSBAVL = 0;
-
- Else;
-
- lErrorDS.Q.QUSEI = MsgId;
- lErrorDS.Q.QUSBAVL = %SIZE(QUSEC);
-
- IF %PARMS() >= %Parmnum( MsgDta );
- // retrieve length of message data.
- Monitor;
- ErrDsLen = %LEN(MsgDta);
- on-error;
- ErrDsLen = 0;
- Endmon;
- ENDIF;
- ENDIF;
-
- // Add bytes available for message data.
- lErrorDS.Q.QUSBAVL += ErrDSLen;
-
- IF ErrDSLen > MaxDtaLen;
- ErrDSLen = MaxDtaLen;
- ENDIF;
-
- // Set message data.
- IF ErrDSLen > 0;
- %SUBST(Lerrords.MsgData:1:MaxDtaLen) = %SUBST(MsgDta:1:ErrDSLen);
-
- // Clear available message data.
- ELSEIF MaxDtaLen > 0;
- %SUBST(Lerrords.MsgData:1:MaxDtaLen) = *BLANKS;
- ENDIF;
- RETURN;
- End-Proc Tlk_SetApiError;
-
|
|