Embedded SQL in RPG ILE

125 pts.
Tags:
Embedded SQL
IBM iSeries
RPG
RPGLE
RPGSQL
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

Answer Wiki

Thanks. We'll let you know when a new response is added.

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.

Discuss This Question: 10  Replies

 
There was an error processing your information. Please try again later.
Thanks. We'll let you know when a new response is added.
Send me notifications when members answer or reply to this question.

REGISTER or login:

Forgot Password?
By submitting you agree to receive email from TechTarget and its partners. If you reside outside of the United States, you consent to having your personal data transferred to and processed in the United States. Privacy
  • BigKat
    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
    8,220 pointsBadges:
    report
  • Sloopy
    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                   EndDo                         
    
    The 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
    2,195 pointsBadges:
    report
  • Jeffm
    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
    125 pointsBadges:
    report
  • Sloopy
    Sorry, Jeff - here is the resource:
    http://publib.boulder.ibm.com/iseries/v5r1/ic2924/index.htm?info/sqlp/rbafymst260.htm
    
    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                   300                                  
    
    SQL_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
    2,195 pointsBadges:
    report
  • Jeffm
    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.
    125 pointsBadges:
    report
  • Sloopy
    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
    2,195 pointsBadges:
    report
  • Jeffm
    Success! Thanks Sloopy
    125 pointsBadges:
    report
  • Jeffm
    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.
    125 pointsBadges:
    report
  • Sloopy
    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<				
    2,195 pointsBadges:
    report
  • Sloopy
    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
    2,195 pointsBadges:
    report

Forgot Password

No problem! Submit your e-mail address below. We'll send you an e-mail containing your password.

Your password has been sent to:

To follow this tag...

There was an error processing your information. Please try again later.

REGISTER or login:

Forgot Password?
By submitting you agree to receive email from TechTarget and its partners. If you reside outside of the United States, you consent to having your personal data transferred to and processed in the United States. Privacy

Thanks! We'll email you when relevant content is added and updated.

Following