Embedded SQL in RPG ILE
I want to write a program that will retrieve any field(s)from any file on the iSeries. The only part I haven't figured out is how to code the fetch statement to populate variables that aren't known until execution time
Software/Hardware used:
Software/Hardware used:
ASKED:
August 19, 2008 11:15 PM
UPDATED:
November 5, 2008 11:31 AM
Answer Wiki:
First, your program will need to determine which file (and fields) the user wants. You may need to query the system file SYSCOLUMNS to help with this.
Then you will need to dynamically write the SQL statement into a variable in the program, use that variable in a PREPARE statement, and use that to DECLARE your cursor. you then OPEN, FETCH and process, and CLOSE the cursor as usual.
To see all answers submitted to the Answer Wiki: View Answer History.
User Ten2008 originally posted this in the answer section (I removed it from there to make the answer section more straight forward, but didn’t want to completely erase someone else’s comments):
Can you please elaborate your question and give the sample code to enable me answer you…thanks
Hi, Jeff.
I have written such a ‘program’. It’s actually 16 programs. SQL is stored in two files.
The actual execution of such SQL is simple. Since the SQL statement is stored in a string, use :
* ------------------------- * Prepare the SQL statement * ------------------------- C/EXEC SQL C+ PREPARE P1 FROM :SQLstring C/END-EXEC * Check for error : C If SQLCODE < *Zero C Eval p_MsgID = 'SQL' C + %Subst(%EditC(%Abs( C SQLCOD):'X'):6:4) C Eval p_MsgDta = SQLERM C ExSr SendMsgPrv C Eval p_RtnCode = '*SQLERR' C ExSr EndProgram C EndIf * ------------------------------------------------- * Get the SQL information about the selected fields * ------------------------------------------------- C Eval SQLN = SQL_NUM C Eval SQLDABC = SQLN * %Len(SQLVAR) + 16 C/EXEC SQL C+ DESCRIBE P1 INTO :SQLDA C/END-EXEC * -------------------------- * Load the pointer addresses * -------------------------- C Eval P2 = *Zero C Eval P3 = *Zero C For P1 = 1 to SQLD C Eval SQLVAR = SQL_VAR (P1) * Store the offset into the data receiver : C Eval aSelOffSet (P1) = P3 C Eval SQLDATA = pRec + aSelOffSet (P1) C Eval SQLIND = pInd + P2 C Eval SQL_VAR (P1) = SQLVAR C Eval P2 = P2 + 4 C Eval P3 = P3 + aSelBytes (P1) C EndFor * --------------------------- * Declare and open the cursor * --------------------------- C/EXEC SQL C+ DECLARE C2 CURSOR FOR P1 C/END-EXEC C/EXEC SQL C+ OPEN C2 C/END-EXEC * Check for error : C If SQLCODE < *Zero C Eval p_MsgID = 'SQL' C + %Subst(%EditC(%Abs( C SQLCOD):'X'):6:4) C Eval p_MsgDta = SQLERM C ExSr SendMsgPrv C Eval p_RtnCode = '*SQLERR' C ExSr EndProgram C EndIf * -------------------------------------------- * Read and process the data from the SQL query * -------------------------------------------- C DoU SQLCOD = 100 C/EXEC SQL C+ FETCH C2 USING DESCRIPTOR :SQLDA C/END-EXEC * End of data : C If SQLCOD = 100 C Leave C EndIf * Move data into receiver : C For P1 = 1 to SQLD C Eval SQLVAR = SQL_VAR (P1) C EndFor * Move data from receiver into output line : C Eval DataFound = *On C ExSr LoadRec C Except PrtDtl * (Page overflow code goes here) C EndDoThe LOADREC subroutine uses the field definitions in SQL_VAR to convert packed and binary fields for display, and to apply edit codes and conversions.
Note that the P1 in the embedded SQL statements is NOT the P1 in the RPG code!
I have to say that the number of support objects needed to create this application is large. I have a big library of procedures to edit and convert data, to parse strings, handle messaging and so on. You’re very likely going to have a bumpy ride; but on the whole, if you have a lot of time on your hands, it’s an interesting exercise.
One tip: SQL does NOT like DB/400 logical files. You can get unexpected results if the SQL engine decides to use such a logical file instead of an SQL view. Even if you specify the physical file name ONLY in the SQL string, the engine may decide to use a logical, and then crash.
So, do this (copied from an internal socument):
To force SQL not to use Logical files, we need to add an option record to a file called QAQQINI.
This file must exist in QUSRSYS. If it does not, then it must be copied from QSYS using CRTDUPOBJ. Please note – if the file does not exist in QUSRSYS, it must be created in QUSRSYS from QSYS using ONLY CRTDUPOBJ. You cannot copy this file any other way.
The command would be:
CRTDUPOBJ QAQQINI QSYS *FILE QUSRSYS DATA(*YES)
The record to be added is best added using SQL itself, like this:
INSERT INTO QUSRSYS/QAQQINI
VALUES(‘IGNORE_DERIVED_INDEX’,'*YES’,NULL)
Or, if it already exists, but its value is *DEFAULT or *NO :
UPDATE QUSRSYS/QAQQINI
SET QQVAL=’*YES’
WHERE QQPARM=’IGNORE_DERIVED_INDEX’
Good luck!
Sloopy
Sloopy,
Thanks for your response. It has been very helpful. The one area that I don’t have a good understanding of is how to retreive the data that the SQLDA references after the fetch. I have been unable to find any documentaion on this. Can you point me to a good resource?
Thanks
Jeff
Sorry, Jeff – here is the resource:
You can track back to the table of contents – there is plenty more to read!
In the code fragment I posted, the SQL record from the FETCH is stored here:
* ------------------------------------------------------------------------ * SQL data receiver and indicator areas * ------------------------------------------------------------------------ D pRec S * D Receiver S 65535 D pInd S * D IndicArea DS D aIndic 4B 0 Dim(300) D SQLstring S 12000 * ------------------------------------------------------------------------ * Constants * ------------------------------------------------------------------------ D SQL_NUM C 300SQL_NUM sets the maximum number of columns that can be fetched.
The code after the DESCRIBE statement loops SQLD (i.e. number of columns) times to set the offset value for the data receiver and and indicator arrays in the SQL reserved structure SQLVAR. This structure is copied back to the relevant array element in SQL_VAR.
I have already got the offsets from another program, but you can get that information on the fly, because the DESCRIBE statement has filled in everything you need in SQL_VAR – one element per column. The only things it had not got were the pointers to your data receiver and null indicator structures (Receiver and IndicArea).
Now you have an array, SQL_VAR, containing elements describing the columns, and with values that point to the parts of Receiver and IndicArea where SQL will store the incoming data and the null indicator flags on every FETCH.
After each FETCH, if there is data, it is in Receiver. If a column fetched a null value, the corresponding null indicator is *ON in IndicArea.
Your LoadRec routine will loop SQLD times and copy out the data from Receiver (from the offset position, for the length in bytes from SQL_VAR element) into a ‘proper’ field from which you can work. Note that SQL returns data in the same form as it is stored in your database – so if it’s binary, or float, or packed, you will probably need to convert it.
btw, anything in the code beginning “aSel” is from a field in a file containing the list of fields from the SELECT statement for a ‘stored’ SQL command. This list is produced in another program, but you can get the information from the entries in the SQL_VAR array after the DESCRIBE. This is all explained in the IBM document in the link at the top of this message.
If you start off simple (certainly simpler than my code!), you will soon get the hang of it.
Sloopy
I have been sidetracked on other projects and just now getting back to writing this program. I am running into the following error right after the open statement. “Address in the SQLDA or descriptor area not valid” SQLData value is SPP:*NULL. When I put the program in debug I noticed that this is the value of pRec when I am setting the pointer addresses. I’m not even sure this is the area I need to be concerned about.
Sorry again – there is so much to do with this SQL stuff that, unless I post whole programs, it’s difficult to be sure I have included everything you need to know….
pRec is the pointer to the RECEIVER variable, and pInd to the null indicator variable:
C *InzSr BegSr * ======================================================================== * Initialise on every entry to program * ------------------------------------------------------------------------ * Get the receiver addresses : C Eval pRec = %Addr(Receiver) C Eval pInd = %Addr(IndicArea) * Include the SQL Descriptor Area : C/EXEC SQL C+ INCLUDE SQLDA C/END-EXEC(etcetera)
Sloopy
Success!
Thanks Sloopy
I’ve been able to get my program to build the SQL statement and to retreive the data. I utilize the SQLDA to determine the data fields and the data type that is retrieved. I’m having trouble finding any documentation that will help me with converting binary data that is retrieved. I was hoping that by just taking the data I sub-stringed out into a character field and moving it into a binary defined field that the program would convert the data. It looks like I am just getting the bottom bit of each byte (I think, if that makes sense). Any help would be appreciated.
Well, I’ve got a set of procedures to do the conversions; but it’s a lot of code – 1,700 lines may be too much to include here, but we will try it.
H NoMain H Copyright ('NSRI London Office 2007') H Option ( *NoDebugIO : *SrcStmt ) H ExprOpts ( *ResDecPos ) H BndDir ('TBNDSRVPGM') * System : Programmers' Workbench * Version : 3.0 * Unit : ILE Procedures * Author : J L Blenkinsop * Date : July 2007 * Description : Return edited field value * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *CMD: CRTRPGMOD *CRT* DBGVIEW(*ALL) *CRT: DBGVIEW(*NONE) OPTIMIZE(*FULL) *END: * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * NOTES * * This procedure returns a value length and a value in a single structure. * * It receives field information from the QUSLFLD API, and a variable-length * string containing the actual value in the field. * * RtnSQLedit Converts SQL field information to normal (DDS) form. * * Receives : * * Type 4B 0 SQL data type * Length 4B 0 SQL data length * * The length value is a tricky field. * * EditFld Returns structure containing edited length and value. * * Receives : * * Value In *VarSize Value of data item * Length 10I 0 Value length in bytes * Type 1A Data type (A, P, S, B, L, T, Z) * Digits 10I 0 Number of digits * Decimals 10I 0 Number of decimal positions * Edit code 1A Field edit code * Date format 4A Date and Time format * New length 10I 0 New length in bytes (leftmost, character) * New digits 10I 0 New number of digits * New decimals 10I 0 New number of decimal positions * * Errors are signalled by a negative number returned in the * length part of the structure, and a text explanation in * the string part. For example, -1 and 'Invalid data type'. * * EditNum Returns string edited according to IBM edit code rules. * * Receives : * * Value In 31S 0 Numeric value adjusted to 0 decimals * Decimals 2S 0 Number of decimal positions * Edit code 1A IBM edit code * Option 1A Cheque protect, left-adjust, etc. * New decimals 10I 0 New number of decimal positions * New digits 10I 0 New number of digits * * * * * * * * * * * * * * * * * * * * * * * * * * * THE FOLLOWING PROCEDURE IS INTERNAL ONLY. * * * IT IS NOT EXPORTED FROM THIS MODULE. * * * * * * * * * * * * * * * * * * * * * * * * * * * HideHex Hides undisplayable hex values in a character string. * * Receives : * * String 2048A Fixed-length string * Length 10I 0 Data length in bytes * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * D*Dstart * ======================================================================== * Prototype parameters * ======================================================================== * --------------------------------------------- * Internal procedures exported from this module * --------------------------------------------- * Return DDS field attributes from SQL values D RtnSQLedit PR 14 <-DDS attributes D p_RE_Type 4B 0 Const SQL data type D p_RE_Bytes 4B 0 Const SQL length * Return edited field value D EditFld PR 2052 <-Length & data D p_EF_Value 2048 Varying Const Data D p_EF_Bytes 10I 0 Const Length in bytes D p_EF_Type 1 Const Data type D p_EF_Digits 10I 0 Const Options(*NoPass) No. of digits D p_EF_DecPos 10I 0 Const Options(*NoPass) No. of decimals D p_EF_EdtCde 1 Const Options(*NoPass) Edit code D p_EF_DatFmt 4 Const Options(*NoPass) Date/Time format D p_EF_NewLen 10I 0 Const Options(*NoPass) New no. of digits D p_EF_NewDig 10I 0 Const Options(*NoPass) New no. of digits D p_EF_NewDec 10I 0 Const Options(*NoPass) New no. of decimals * Return edited numeric value D EditNum PR 45 D p_EN_Value 31S 0 Const D p_EN_DecPos 2S 0 Const D p_EN_EdtCde 1 Const D p_EN_Cheque 1 Const Options(*NoPass) D p_EN_NewDec 10I 0 Const Options(*NoPass) D p_EN_NewDig 10I 0 Const Options(*NoPass) * Hide undisplayable characters in a string D HideHex PR 2048 <-Edited string D p_HH_Value 2048 Const Data D p_HH_Length 10I 0 Const Length in bytes * ----------------------------------------------- * External procedures referenced from this module * ----------------------------------------------- * Return a date in the format requested D GetDate PR 30 D p_Stamp Z Const D p_Format 1 Const Options(*NoPass) * Return a time in the format requested D GetTime PR 8 D p_Stamp Z Const D p_Format 1 Const Options(*NoPass) * ======================================================================== * Global variables and constants * ======================================================================== * ------------------------------------------------------------------------ * For Return SQL Edit procedure * ------------------------------------------------------------------------ D wkSQLLEN DS D wkPadB 1 4B 0 Inz(*Zero) D wkLenB 2 3B 0 D wkPrec 1 2B 0 D wkScl01 3 3 D wkSQLSCALE DS D wkScale 1 2B 0 Inz(*Zero) D wkScl02 2 2 D sSQLedit DS D seType 1 D seBytes 10U 0 D sePrecision 10U 0 D seDecimals 10U 0 D seNull 1 * ------------------------------------------------------------------------ * For Edit Field procedure * ------------------------------------------------------------------------ D BinNums DS D b_04 1 4B 0 D b_02 3 4B 0 D Unsigned DS D uns 1 8 D u_20 1 8U 0 D u_10 5 8U 0 D u_05 7 8U 0 D u_03 8 8U 0 D Integer DS D int 1 8 D i_20 1 8I 0 D i_10 5 8I 0 D i_05 7 8I 0 D i_03 8 8I 0 D PackNums DS D p_30 16 D p_30num 1 16P 0 D ZoneNums DS D z_31 31 D z_31num 1 31S 0 D ZoneDec1 S 31S 1 D ZoneDec2 S 31S 2 D ZoneDec3 S 31S 3 D ZoneDec4 S 31S 4 D ZoneDec5 S 31S 5 D ZoneDec6 S 31S 6 D ZoneDec7 S 31S 7 D ZoneDec8 S 31S 8 D ZoneDec9 S 31S 9 D Float4 DS 4 D Float4num 1 4F D Float8 DS 8 D Float8num 1 8F D Float4out S 14 D Float8out S 23 D RawDate DS 8 D RD_CCYMD 8 D RD_CYMD 7 OverLay(RD_CCYMD:2) D RD_YMD 6 OverLay(RD_CCYMD:3) D RD_CCYM 6 OverLay(RD_CCYMD:1) D RD_YM 4 OverLay(RD_CCYMD:3) D RD_CC 2 OverLay(RD_CCYMD:1) D RD_YY 2 OverLay(RD_CCYMD:3) D RD_MM 2 OverLay(RD_CCYMD:5) D RD_DD 2 OverLay(RD_CCYMD:7) D RD_NUM 8S 0 OverLay(RD_CCYMD:1) D RawTime DS 6 D RT_HMS 6 D RT_HM 4 OverLay(RT_HMS:1) D RT_HH 2 OverLay(RT_HMS:1) D RT_MM 2 OverLay(RT_HMS:3) D RT_SS 2 OverLay(RT_HMS:5) D RT_NUM 6S 0 OverLay(RT_HMS:1) D StampVal DS 26 D DateVal 10 D 1 Inz('-') D TimeVal 8 D 1 Inz('.') D Msecs 6 Inz('000000') * ------------------------------------------------------------------------ * Miscellaneous fields * ------------------------------------------------------------------------ D p_Digits S 10I 0 D p_DecPos S 10I 0 D p_EdtCde S 1 D p_DatFmt S 4 D p_NewLen S 10I 0 D p_NewDig S 10I 0 D p_NewDec S 10I 0 D Block S 1 Inz(' ') D DisplayVal S 2048 D WrkVal S 100 D cVarLen DS 2 D VarLen 5U 0 D P1 S 10U 0 D P2 S 10U 0 D FromDate DS D f_01 2 D f_02 2 D f_03 2 D f_04 2 D f_01a 2 2 D ToDate DS D t_Date 1 8S 0 D t_CY 1 4S 0 D t_CC 1 2 D t_YY 3 4 D t_MM 5 6 D t_DD 7 8 D t_Time 3 8S 0 D t_CC_n 1 2S 0 D t_YY_n 3 4S 0 D t_MM_n 5 6S 0 D t_DD_n 7 8S 0 * ------------------------------------------------------------------------ * Data return structure * ------------------------------------------------------------------------ D RtnData DS D RtnLen 10I 0 D RtnVal 2048 * ------------------------------------------------------------------------ * Working date and time * ------------------------------------------------------------------------ D DS D WorkStampISO Z Inz(*Sys) D WorkISODate D Overlay( WorkStampISO ) D WorkISOTime T Overlay( WorkStampISO : 12 ) * ------------------------------------------------------------------------ * For Edit number procedure * ------------------------------------------------------------------------ * ----------------------------------------------------------------------- * Editing structures and parameters * ----------------------------------------------------------------------- D wkLADJ S 45 Left-adjusted result D wkCURR S 2 Currency symbol D wkSEPS S 1 Decimal separator D wkCURS S 1 Currency symbol D wkEdtCde S 1 Edit code D p_EN_Result DS Output D aOut 1 Dim(45) D wkValue DS Input D z_VALU 31S 0 D sInput DS Incoming value D aIn 1 62 Dim(62) D wkIINT 1 31 D z_IINT 1 31S 0 D wkIDEC 32 62 D z_IDEC 32 62S31 D sEdit DS Editing array D aEdit 1 77 Dim(77) D wkVAL 13 43 D wkINT 13 43S 0 D POINT 44 44 D wkDEC 45 75S31 D I01 13 13 D I02 14 16 D I03 17 19 D I04 20 22 D I05 23 25 D I06 26 28 D I07 29 31 D I08 32 34 D I09 35 37 D I10 38 40 D I11 41 43 D DEC 45 75 D sCommas DS Comma editing D 2 D C01 1 D C01c 1 D C02 3 D C02c 1 D C03 3 D C03c 1 D C04 3 D C04c 1 D C05 3 D C05c 1 D C06 3 D C06c 1 D C07 3 D C07c 1 D C08 3 D C08c 1 D C09 3 D C09c 1 D C10 3 D C10c 1 D C11 3 D FirstTime S N Inz(*On) First time * ----------------------------------------------------------------------- * Parameters to retrieve system values * ----------------------------------------------------------------------- D p_RVAL DS D B#NUMR 10I 0 D B#SVTO 10I 0 D C#SVNM 10 D C#SVTP 1 D C#SVST 1 D C#SVLN 10I 0 D C#SVDA 4 D p_RLEN DS D B#RLEN 10I 0 Inz(28) D p_RNUM DS D B#RNUM 10I 0 Inz(1) D p_ERRS DS D B#ERRB 10I 0 Inz(32) D B#ERRA 10I 0 Inz(0) D C#ERRI 7 D C#ERRD 16 * ----------------------------------------------------------------------- * Constants * ----------------------------------------------------------------------- D VALEDT C Const('1234ABCDJKLMNOPQXZ') * ======================================================================== * ======================================================================== * =============================================== * Procedure specifications =============================================== * =============================================== * ======================================================================== * ======================================================================== * ======================================================================== * Return DDS field attributes from SQL values * ======================================================================== P RtnSQLedit B Export D RtnSQLedit PI 14 D p_RE_Type 4B 0 Const SQL data type D p_RE_Bytes 4B 0 Const SQL length D DS D wkBin4 1 4B 0 Inz(*Zero) D wkBin2 3 4B 0 C Monitor C Eval wkBin2 = p_RE_Bytes C If %Rem(p_RE_Type:2) = 1 C Eval seNull = *On C Else C Eval seNull = *Off C EndIf C Select * Character (variable length) : C When p_RE_Type = 448 or C p_RE_Type = 449 or C p_RE_Type = 456 or C p_RE_Type = 457 C Eval seType = 'V' C Eval seBytes = wkBin4 + 2 C Eval sePrecision = *Zero C Eval seDecimals = *Zero * Character (fixed length) : C When p_RE_Type = 452 or C p_RE_Type = 453 C Eval seType = 'A' C Eval seBytes = wkBin4 C Eval sePrecision = *Zero C Eval seDecimals = *Zero * Packed numeric : C When p_RE_Type = 484 or C p_RE_Type = 485 C Eval wkLenB = p_RE_Bytes C Eval wkScl02 = wkScl01 C Eval seType = 'P' C Eval seBytes = %Int(wkPrec / 2) + 1 C Eval sePrecision = wkPrec C Eval seDecimals = wkScale * Zoned numeric : C When p_RE_Type = 488 or C p_RE_Type = 489 C Eval wkLenB = p_RE_Bytes C Eval wkScl02 = wkScl01 C Eval seType = 'S' C Eval seBytes = wkPrec C Eval sePrecision = wkPrec C Eval seDecimals = wkScale * Integer : C When p_RE_Type = 492 or C p_RE_Type = 493 or C p_RE_Type = 496 or C p_RE_Type = 497 or C p_RE_Type = 500 or C p_RE_Type = 501 C Eval seType = 'B' C Eval wkLenB = p_RE_Bytes C Eval wkScl02 = wkScl01 C Select C When wkPrec <> *Zero C Eval sePrecision = wkPrec C Eval seDecimals = wkScale C Eval seBytes = wkPrec C When p_RE_Bytes = 2 C Eval sePrecision = 5 C Eval seDecimals = *Zero C Eval seBytes = p_RE_Bytes C When p_RE_Bytes = 4 C Eval sePrecision = 10 C Eval seDecimals = *Zero C Eval seBytes = p_RE_Bytes C When p_RE_Bytes = 8 C Eval sePrecision = 20 C Eval seDecimals = *Zero C Eval seBytes = p_RE_Bytes C EndSl * Date : C When p_RE_Type = 384 or C p_RE_Type = 385 C Eval seType = 'L' C Eval seBytes = 10 C Eval sePrecision = *Zero C Eval seDecimals = *Zero * Time : C When p_RE_Type = 388 or C p_RE_Type = 389 C Eval seType = 'T' C Eval seBytes = 8 C Eval sePrecision = *Zero C Eval seDecimals = *Zero * Timestamp : C When p_RE_Type = 392 or C p_RE_Type = 393 C Eval seType = 'Z' C Eval seBytes = 26 C Eval sePrecision = *Zero C Eval seDecimals = *Zero * Floating point : C When p_RE_Type = 480 or C p_RE_Type = 481 C Eval seType = 'F' C Eval seBytes = p_RE_Bytes C Eval sePrecision = *Zero C Eval seDecimals = *Zero C Other C Eval seType = '*' C Eval seBytes = wkBin4 C Eval sePrecision = *Zero C Eval seDecimals = *Zero C EndSl C On-Error C Eval seType = '*' C Eval seBytes = wkBin4 C Eval sePrecision = *Zero C Eval seDecimals = *Zero C EndMon C Return sSQLedit P RtnSQLedit E * ======================================================================== * Return edited field value * ======================================================================== P EditFld B Export D EditFld PI 2052 <-Length & data D p_EF_Value 2048 Varying Const Data D p_EF_Bytes 10I 0 Const Length in bytes D p_EF_Type 1 Const Data type D p_EF_Digits 10I 0 Const Options(*NoPass) No. of digits D p_EF_DecPos 10I 0 Const Options(*NoPass) No. of decimals D p_EF_EdtCde 1 Const Options(*NoPass) Edit code D p_EF_DatFmt 4 Const Options(*NoPass) Date/Time format D p_EF_NewLen 10I 0 Const Options(*NoPass) New no. of digits D p_EF_NewDig 10I 0 Const Options(*NoPass) New no. of digits D p_EF_NewDec 10I 0 Const Options(*NoPass) New no. of decimals D wkEF_Digits S 10I 0 Inz(*Zero) D wkEF_DecPos S 10I 0 Inz(*Zero) D wkEF_EdtCde S 1 Inz(*Blank) D wkEF_DatFmt S 4 Inz(*Blank) D wkEF_NewLen S 10I 0 Inz(*Zero) D wkEF_NewDig S 10I 0 Inz(*Zero) D wkEF_NewDec S 10I 0 Inz(*Zero) D wkDatFrom S 1 Inz(*Blank) D wkDatTo S 1 Inz(*Blank) * -------------- * Procedure code * -------------- C Monitor * Invalid field type : C If %Scan(p_EF_Type:'AVFPSBLTZ') = *Zero C Eval RtnVal = 'Invalid field type' C Eval RtnLen = -1 C Return RtnData C EndIf * Set new length and edit code internal parameters : C If %Parms > 5 C Eval p_EdtCde = p_EF_EdtCde C Else C Eval p_EdtCde = *Blank C EndIf C If %Parms > 7 C Eval p_NewLen = p_EF_NewLen C Else C Eval p_NewLen = *Zero C EndIf * If data type is fixed character, just move the data : C Select C When p_EF_Type = 'A' and C p_NewLen > *Zero and C p_EdtCde = 'R' C Eval P1 = (p_EF_Bytes - p_NewLen) + 1 C Eval RtnVal = %Subst(p_EF_Value C : P1 C : p_NewLen) C Eval RtnLen = p_NewLen C Eval RtnVal = HideHex(RtnVal:RtnLen) C Return RtnData C When p_EF_Type = 'A' and C p_NewLen > *Zero C Eval RtnVal = %Subst(p_EF_Value C : 1 C : p_NewLen) C Eval RtnLen = p_NewLen C Eval RtnVal = HideHex(RtnVal:RtnLen) C Return RtnData C When p_EF_Type = 'A' C Eval RtnVal = p_EF_Value C Eval RtnLen = p_EF_Bytes C Eval RtnVal = HideHex(RtnVal:RtnLen) C Return RtnData C EndSl * If data type is variable character, move the data more carefully : C If p_EF_Type = 'V' C Eval cVarLen = %Subst(p_EF_Value:1:2) C If VarLen <= p_NewLen C Eval p_NewLen = VarLen C EndIf C EndIf C Select C When p_EF_Type = 'V' and C p_NewLen > *Zero and C p_EdtCde = 'R' C Eval P1 = (VarLen - p_NewLen) + 1 C Eval RtnVal = %Subst(p_EF_Value C : P1 + 2 C : p_NewLen) C Eval RtnLen = p_NewLen C Eval RtnVal = HideHex(RtnVal:RtnLen) C Return RtnData C When p_EF_Type = 'V' and C p_NewLen > *Zero C Eval RtnVal = %Subst(p_EF_Value C : 3 C : p_NewLen) C Eval RtnLen = p_NewLen C Eval RtnVal = HideHex(RtnVal:RtnLen) C Return RtnData C When p_EF_Type = 'V' C Eval RtnVal = %Subst(p_EF_Value C : 3 C : VarLen ) C Eval RtnLen = VarLen C Eval RtnVal = HideHex(RtnVal:RtnLen) C Return RtnData C EndSl * If data type is float, move and edit the data : C If p_EF_Type = 'F' and C p_EF_Bytes = 4 C MoveL p_EF_Value Float4 C Eval Float4Out = %EditFlt(Float4Num) C Eval RtnVal = Float4Out C Eval RtnLen = 14 C Return RtnData C EndIf C If p_EF_Type = 'F' and C p_EF_Bytes = 8 C MoveL p_EF_Value Float8 C Eval Float8Out = %EditFlt(Float8Num) C Eval RtnVal = Float8Out C Eval RtnLen = 23 C Return RtnData C EndIf * ----------------------------------- * Set defaults for missing parameters * ----------------------------------- C If %Parms < 10 C Eval p_NewDec = *Zero C Else C Eval p_NewDec = p_EF_NewDec C EndIf C If %Parms < 9 C Eval p_NewDig = *Zero C Else C Eval p_NewDig = p_EF_NewDig C EndIf C If %Parms < 8 C Eval p_NewLen = *Zero C Else C Eval p_NewLen = p_EF_NewLen C EndIf C If %Parms < 7 C Eval p_DatFmt = '*EUR' C Else C Eval p_DatFmt = p_EF_DatFmt C EndIf C If %Parms < 6 C Eval p_EdtCde = 'X' C Else C Eval p_EdtCde = p_EF_EdtCde C EndIf C If %Parms < 5 C Eval p_DecPos = *Zero C Else C Eval p_DecPos = p_EF_DecPos C EndIf C If %Parms < 4 C Eval p_Digits = p_EF_Bytes C Else C Eval p_Digits = p_EF_Digits C EndIf * ------------------------------------------------------------------- * Numeric editing converts to zoned, which is then edited to a string * ------------------------------------------------------------------- * If data type is binary, treat as Unsigned Integer if length is in range, else error : C If p_EF_Type = 'B' C If p_EF_Bytes < 9 C Eval u_20 = *Zero C Eval %Subst(Uns:9-p_EF_Bytes:p_EF_Bytes) = C %Subst(p_EF_Value:1:p_EF_Bytes) C Eval z_31num = u_20 C Select C When p_EF_Bytes < 2 C Eval RtnLen = 3 C When p_EF_Bytes < 4 C Eval RtnLen = 5 C When p_EF_Bytes < 8 C Eval RtnLen = 10 C Other C Eval RtnLen = 20 C EndSl C Else C Eval RtnVal = 'Invalid length for Binary' C Eval RtnLen = -3 C Return RtnData C EndIf C EndIf * Packed data type - convert to zoned : C If p_EF_Type = 'P' C Eval p_30num = *Zero C Eval %Subst(p_30:17-p_EF_Bytes:p_EF_Bytes) = C %Subst(p_EF_Value:1:p_EF_Bytes) C Eval z_31num = p_30num C Eval RtnLen = (p_EF_Bytes * 2) -1 C EndIf * Zoned data type : C If p_EF_Type = 'S' C Eval z_31num = *Zero C Eval %Subst(z_31:32-p_EF_Bytes:p_EF_Bytes) = C %Subst(p_EF_Value:1:p_EF_Bytes) C Eval RtnLen = p_EF_Bytes C EndIf * ----------------------------------------------- * Edit the numeric value when it is a date format * ----------------------------------------------- C Eval wkDatFrom = %Subst(p_DatFmt:1:1) C Eval wkDatTo = %Subst(p_DatFmt:2:1) C If wkDatTo = *Blank C Eval wkDatTo = wkDatFrom C EndIf C If wkDatFrom <> *Blank and C p_DecPos = *Zero and C (p_EF_Type = 'P' or C p_EF_Type = 'S' or C p_EF_Type = 'B<OK.
I tried to include 1,700 lines of code, but it did not work….
Jeff (and anyone else), if you would like a set of procedures to do all the conversions you require, please email me at:
john.blenkinsop@ne.nykline.com
I will send you text files containing the code.
Regards,
Sloopy