*===================================================================== * * CRTCTSQLR: Create Cross-Tab SQL * * Create a cross tab SQL query based on user specifed rows (GROUP BY) * and columns (pivot). Resulting query can be directed to the * display, a QM Query, a source member, a view or a CL variable. * * * * 01/15/03 Michael Sansoterra * * * Compile Notes: Use PDM option 14 * No special modules are required * -OR- * CRTSQLRPGI OBJ(OBJLIB/CRTCTSQLR) SRCFILE(SRCLIB/QRPGLESRC) * *===================================================================== H Dftactgrp(*No) Actgrp(*Caller) * FCrossTab o a f 91 disk ExtFile(tmpSrcFile) F ExtMbr(tmpSrcMbr) UsrOpn * * MISC NOTES: * * CRTQMQRY -- If replace not specified and QMQ exists, CRTQMQRY itself * will prompt for replace (C G)? * * BASE SQL must be used in *SYS format unless compiler opt changed * * RTVCTSQL -- SQL limited to 5000 characters * * ORDER BY -- Not allowed in BASE SQL * * Max Columns to use can be adjusted in program * * FOR VIEWS -- Make sure column name is unique (not req for SELECT) * * QUALIFIERS are to be avoided (ambiguous column names * can't exist because the SELECT DISTINCT won't know which one * to retrieve.) If you have a column heading making use of a * non-unique file name, use an ALIAS for the column heading column * rather than a table qualifier. * * Column heading value will be truncated at 60 characters * * Actual column name alias in SQL statement will be truncated at 30 * characters -- therefore pivoting on columns with large values * isn't recommended. * * Data type of column heading will be assumed based on type given * for column values!!!! * * Bad characters in heading are replaced with an _ * * UNION not allowed in SUBSELECT until V5R2 * * Except for VIEW output, SOURCE will always exist in QTEMP #CRTCTSQL * * If *QMQRY output is selected, the CT SQL statement will be created * but not validated (could still have errors!) * * Nested Query requires V4R4 FREE FORM RPG REQUIRES V5R1!!!!!!!! * Big Integer requires V4R5 * * SQLDA-DB2 UDB for iSeries SQL Programming with Host Languages * Appendix C of SQL Reference * D parmColHdg s 60 D parmMaxCols s 5p 0 D parmRowHdgs ds D NoRowHdgs 5i 0 D RowHdg 60 Dim(16) D parmValues ds D NoValues 5i 0 D ValueOffset 5i 0 Dim(%Elem(dsValueStruc)) D ValueStruc Like(dsValueStruc) D Dim(%Elem(dsValueStruc)) D parmBaseSQL s 5000 Varying D parmOutput s 10 D parmView ds 20 D ViewName 10 D ViewLib 10 D parmRplView s 4 D parmQMQry ds 20 D QMQryName 10 D QMQryLib 10 D parmRplQMQry s 4 D parmSrcFile ds 20 D SrcFile 10 D SrcLib 10 D parmSrcMbr s 10 D parmRplSrcMbr s 4 D parmOrderBy s 4 D parmRtnSQL s 5000 Varying D parmFixedHdgs ds D NoFixedHdgs 5i 0 D HdgOffset 5i 0 Dim(%Elem(dsFixedHdgs)) D HdgStruc Like(dsFixedHdgs) D Dim(%Elem(dsFixedHdgs)) *===================================================================== * Data Structure for Columns to use as values *===================================================================== D dsValueStruc ds Occurs(16) Based(ptrValueStruc) D NoElem 5i 0 D Value 60 D ColFunction 10 D ValuesToUse 10 D CastToType 10 D CastPrec 5i 0 D CastScale 5i 0 * D ptrValueStruc s * *===================================================================== * Data Structure for Values/Names to use as Fixed Column Headings *===================================================================== D dsFixedHdgs ds Occurs(50) Based(ptrFixedHdgs) D NoElem2 5i 0 D FixColValue 30 Varying D FixColName 30 Varying * D ptrFixedHdgs s * *===================================================================== * Array for holding DISTINCT values *===================================================================== D arrDistValues s Dim(%Elem(dsFixedHdgs)) D Like(ColumnData) D arrDistValuesF s Dim(%Elem(dsFixedHdgs)) D Like(ColumnDataFmt) D arrDistColHdg s 30 Dim(%Elem(dsFixedHdgs)) D dvIdx s 5i 0 D NoDistValues s 5i 0 *===================================================================== * Variables for SQL Statement Construction *===================================================================== D SelectDistinct s 5120 Varying * D PrimarySelect s 8192 Varying D GroupBy s 1024 Varying D OrderBy s 256 Varying D CaseStmt s 256 Varying D CTSQL s 16384 Varying D SQLImmed s 16500 Varying *===================================================================== * Dynamic Columns *===================================================================== D ColumnData s 62 D ColumnDataFmt s + 3 Like(columnData) D ColumnNull s 5i 0 * D wrkDataType s Like(tabType) D wrkNull s 1 * * SQL_NUM is used be the SQL Precompiler to define how many * columns to allocate for the SQL Descriptor Area (SQLDA) * D SQL_NUM c Const(1) * D dsSQLLen ds D SQLNumPrec 1 D SQLNumScale 1 D SQLNumAttr 1 2b 0 * D dsBinCvt ds D Byte1 1 Inz(x'00') D Byte2 1 D BinResult 1 2b 0 *===================================================================== * Type conversion tables - Lookup RPG/SQL data funcs for columns *===================================================================== D tabType s 3s 0 Dim(11) Ctdata Ascend D tabColType s 16 Dim(11) Alt(tabType) D RPGType s 1 D SQLColType s 15 *===================================================================== * Query Manager Query Variables *===================================================================== D tmpQMQry s 10 Varying Inz('#CRTCTSQL') D tmpQMQryLib s 10 Varying Inz('QTEMP') D tmpSrcMbr s 10 Varying Inz('CROSSTAB') D tmpSrcFile s 21 Varying Inz('QTEMP/#CRTCTSQL') *===================================================================== * Misc Variables *===================================================================== D RowIdx s 5i 0 D CaseIdx s 5i 0 D WrkIdx s 5i 0 D ColCount s 5i 0 D wrkAlpha s 1 D SQLLine s 79 D WriteSrc s 1 inz('N') D OpenCursor s 1 inz('N') * * List of replaceable (i.e. invalid alias) characters goes here! * D Replaceable s 44 inz( D ' <>,./?:;''"ª³{}\|~`!%›&*()-+=[]^- D  º„”“‡ò‚¡ðŠ¢') D ReplaceChar s like(Replaceable) inz(*all'_') *===================================================================== * Prototype/variables for converting a numeric field to alpha *===================================================================== D CvtNumToAlpha PR 35 Varying D RawData 31 D DataType 1 D ActualSize 3 0 D Precision 3 0 D Scale 3 0 * D Result s 35 Varying D DataType s 1 D ActualSize s 3 0 D Precision s 3 0 D Scale s 3 0 * D RawData ds 31 D Float4 1 4f D Float8 1 8f D Bin2 1 2b 0 D Bin4 1 4b 0 D Bin8 20i 0 Overlay(float8) *===================================================================== * Prototype for replacing one single quote with two *===================================================================== D ReplaceQt PR 120 Varying D pText 60 Const *===================================================================== * Prototype for wrapping unformatted data to a specified length *===================================================================== D WrapText PR 8192 D UnfText 8192 Varying Const Options(*VarSize) D LineLen 5 0 Const D LineBreak 10 Varying Const Options(*NoPass) *===================================================================== * Prototype for writing SQL lines to a source file *===================================================================== D WriteSource PR D SourceText 8192 Varying Const Options(*VarSize) D LineLen 5 0 Const D IndentSpaces 3 0 Const *===================================================================== * Prototype/variables for executing a command *===================================================================== D QCMDEXC PR ExtPgm('QCMDEXC') D pCommand Like(Command) Const Options(*Varsize) D pCommandLen Like(CommandLen) Const * D Command s 4096 D CommandLen s 15 5 *===================================================================== * Prototype/variables for sending a program message *===================================================================== D QMHSNDPM PR ExtPgm('QMHSNDPM') D pMsgId Like(MsgID) Const D pMsgFile Like(MsgFile) Const D pMsgDta Like(MsgDta) Const D pMsgDtaLen Like(MsgDtaLen) Const D pMsgType Like(MsgType) Const D pMsgStack Like(MsgStack) Const D pMsgStack# Like(MsgStack#) Const D pMsgKey Like(MsgKey) D pMsgError Like(dsErrCode) * D MsgId s 7a D MsgFile s 20a Inz('QCPFMSG *LIBL') D MsgDta s 256 D MsgType s 10a D MsgStack s 10a Inz('*') D MsgKey s 4a D MsgDtalen s 10i 0 D MsgStack# s 10i 0 *===================================================================== * Prototype for sending an error message from the SQL processor *===================================================================== D SQLErrorMsg PR *===================================================================== * Prototype for sending a run-time CPF error *===================================================================== D RunTimeMsg PR *===================================================================== * Error Code Data Structure for API Calls *===================================================================== DdsErrCode ds D BytesProvided 10i 0 Inz(%size(MsgData)) D BytesAvail 10i 0 D ExceptionID 7 D Reserved 1 D MsgData 128 *===================================================================== * Program Status Data Structure *===================================================================== D StatusDS sds D stPgm *proc D stStatus *status D stPrvStatus 16 20s 0 D stStatement 21 28s 0 D stRoutine *routine D stParms *parms D stMsgID 40 46 D stMsgData 91 170 D stJobName 244 253 D stUser 254 263 D stJobNo 264 269 D stCurUser 358 367 *===================================================================== * Set SQL Pre-Compiler Options *===================================================================== C/Exec Sql C+ SET OPTION COMMIT=*NONE, DATFMT=*ISO, TIMFMT=*HMS, NAMING=*SYS C/End-Exec * * Define SQL Descriptor Area * C/Exec Sql C+ INCLUDE SQLDA C/End-Exec * C *Entry Plist C Parm parmColHdg C Parm parmMaxCols C Parm parmRowHdgs C Parm parmValues C Parm parmBaseSQL C Parm parmOutput C Parm parmView C Parm parmRplView C Parm parmQMQry C Parm parmRplQMQry C Parm parmSrcFile C Parm parmSrcMbr C Parm parmRplSrcMbr C Parm parmOrderBy C Parm parmRtnSQL C Parm parmFixedHdgs C/Free // Point Multiple Occurence DS to corresponding PARMs If NoValues>*zero; ptrValueStruc=%addr(parmValues)+ValueOffset(NoValues); EndIf; If NoFixedHdgs>*zero; ptrFixedHdgs =%addr(parmFixedHdgs)+HdgOffset(NoFixedHdgs); EndIf; // Prepare work file for display or source output If parmOutput='*' Or parmOutput='*SRC'; If parmOutput='*SRC'; tmpSrcFile=%TrimR(SrcLib)+'/'+%TrimR(SrcFile); tmpSrcMbr=%TrimR(parmSrcMbr); // Attempt to clear/add requested source member If parmRplSrcMbr='*YES'; Command='RMVM '+ tmpSrcFile + ' MBR(' + tmpSrcMbr+')'; CallP(e) QCMDEXC(Command:%Len(Command)); EndIf; Command='ADDPFM '+ tmpSrcFile+ ' MBR(' + tmpSrcMbr+')'; CallP(e) QCMDEXC(Command:%Len(Command)); If %Error; CallP RunTimeMsg(); EndIf; Else; // Create Dummy Work File CallP(e) QCMDEXC('DLTF '+tmpSrcFile:100); CallP(e) QCMDEXC('CRTSRCPF '+tmpSrcFile+ ' RCDLEN(91) MBR('+tmpSrcMbr+')':100); If %Error; CallP RunTimeMsg(); EndIf; EndIf; Open(e) CrossTab; If %Error; CallP RunTimeMsg(); EndIf; WriteSrc='Y'; EndIf; ExSr BuildDistinct; ExSr BuildSQLStmt; // Close source file If WriteSrc='Y'; Close CrossTab; EndIf; // Create Query manager to display/hold results If parmOutput='*' Or parmOutput='*QMQRY'; If parmOutput='*QMQRY'; tmpQmQryLib=%Trim(QMQryLib); tmpQmQry=%Trim(QMQryName); EndIf; If parmOutput='*' or parmRplQMQry='*YES'; // Delete prior QM Query, if this is a temp Command='DLTQMQRY QMQRY('+tmpQmQryLib+'/'+tmpQMQry + ')'; CallP(e) QCMDEXC(Command:%Len(Command)); EndIf; // Create QM Query from Source Member Command='CRTQMQRY QMQRY('+tmpQmQryLib+'/'+tmpQMQry + ') ' + 'SRCFILE('+tmpSrcFile+') '+ 'SRCMBR('+tmpSrcMbr+') ' + 'TEXT(''Cross Tab SQL'')'; CallP(e) QCMDEXC(Command:%Len(Command)); If %Error; CallP RunTimeMsg(); EndIf; If parmOutput='*'; // Display QM Query Command='STRQMQRY QMQRY('+tmpQmQryLib+'/'+tmpQMQry + ')'; CallP(e) QCMDEXC(Command:%Len(Command)); If %Error; CallP RunTimeMsg(); EndIf; EndIf; ElseIf parmOutput='*VIEW'; // Create View If parmRplView='*YES'; SQLImmed='DROP VIEW '+%Trim(ViewLib)+'/'+ %Trim(ViewName); ExSr SQLExecImmed; EndIf; SQLImmed='CREATE VIEW '+%Trim(ViewLib)+'/'+ %Trim(ViewName)+' AS ('+ CTSQL + ')'; ExSr SQLExecImmed; ElseIf parmOutput='*RTNVAR'; // Return SQL Statement as a variable parmRtnSQL=CTSQL; // Send Message if CTSQL>%SIZE of return parm If %Len(CTSQL)>%Size(parmRtnSQL)-2; Eval StMsgData='Maximum SQL Statement Length of ' + %Char(%Size(parmRtnSQL)-2) + ' has been exceeded.'; CallP RunTimeMsg(); EndIf; EndIf; *InLr=*on; Return; //================================================================ // Build List of Distinct Values //================================================================ BegSr BuildDistinct; MsgID='CPF9897'; MsgDta='Building list of DISTINCT values from base SQL statement'; MsgDtaLen=%Len(%Trim(MsgDta)); MsgType='*STATUS'; MsgStack='*EXT'; CallP(e) QMHSNDPM(MsgId: MsgFile: MsgDta: MsgDtaLen: MsgType: MsgStack: MsgStack#: MsgKey: dsErrCode); MsgStack='*'; // Build SELECT DISTINCT statement to retrieve unique key values SelectDistinct='SELECT DISTINCT ' + %Trim(parmColHdg) + ' FROM (' + parmBaseSQL + ') AS TEMP ORDER BY 1'; // Define size & Max columns for SQLDA sqlDAbc=%size(sqlDA); sqlN=SQL_Num; ExSr SQLPrepareStmt; If sqlStt<>'00000'; CallP SQLErrorMsg(); EndIf; // Get Attribute Information for Column #1 sqlVar=SQL_VAR(1); // Convert SQL data type to RPG data type wrkAlpha='N'; If %rem(sqlType:2)=*zero; wrkDataType=sqlType; Else; wrkDataType=sqlType-1; EndIf; // Convert SQL func to an RPG func/SQL Variable func If Not %TLookup(wrkDataType:tabType:tabColType); MsgID='CPF9897'; MsgDta='Cannot Process SQL Data Type for Column:'+parmColHdg; MsgDtaLen=%Len(%Trim(MsgDta)); MsgType='*DIAG'; MsgStack#=1; CallP(e) QMHSNDPM(MsgId: MsgFile: MsgDta: MsgDtaLen: MsgType: MsgStack: MsgStack#: MsgKey: dsErrCode); EndIf; RPGType=%Subst(tabColType:1:1); // // Load Values based on Fixed Column Headings specified on cmd line // Otherwise, load DISTINCT values from BASE SQL Statement // If NoFixedHdgs>*zero; wrkIdx=*zero; For dvIdx=NoFixedHdgs DownTo 1 By 1; wrkIdx=wrkIdx+1; %Occur(dsFixedHdgs)=wrkIdx; arrDistValues(dvIdx)=FixColValue; arrDistColHdg(dvIdx)=FixColName; If FixColValue='*NULL'; arrDistValuesF(dvIdx)=' IS NULL'; ElseIf RPGType='A' or RPGType='V'; arrDistValuesF(dvIdx)='='''+%trim(FixColValue)+''''; Else; arrDistValuesF(dvIdx)='='+%trim(FixColValue); EndIf; NoDistValues=NoFixedHdgs; EndFor; Else; ExSr LoadDistValues; EndIf; EndSr; //================================================================= // Retrieve Distinct Values from Base SQL Statement //================================================================= BegSr LoadDistValues; ExSr SQLDeclareCrsr; If SqlStt='00000'; ExSr SQLOpenCursor; EndIf; DoW SqlStt='00000' And dvIdx%Size(ColumnData)-2; SQLLen=%Size(ColumnData)-2; EndIf; If wrkNull='N'; Select; // Fixed Length Alpha (CHAR, DATE, TIME, TIMESTAMP) When RPGType='A'; wrkAlpha='Y'; ColumnData=ReplaceQt(%Subst(ColumnData:1:SQLLen)); // Convert VARCHAR to CHAR When RPGType='V'; wrkAlpha='Y'; If SQLLen>*zero; ColumnData=ReplaceQt(%Subst(ColumnData:3:SQLLen)); Else; ColumnData=*blanks; EndIf; // Convert Float/Binary to Alpha Representation When RPGType='F' or RPGType='B'; ActualSize=SQLLen; ColumnData=CvtNumToAlpha(ColumnData: RPGType: ActualSize: Precision: Scale); // Convert Zoned/Packed to Alpha Representation When RPGType='S' or RPGType='P'; SQLNumAttr=SQLLen; Byte2=SQLNumPrec; Precision=BinResult; Byte2=SQLNumScale; Scale=BinResult; ColumnData=CvtNumToAlpha(ColumnData: RPGType: ActualSize: Precision: Scale); Other; EndSl; If wrkAlpha='Y'; ColumnDataFmt='='''+%Trim(ColumnData)+''''; Else; ColumnDataFmt='='+ColumnData; EndIf; Else; ColumnDataFmt=' IS NULL'; ColumnData='NULL'; EndIf; dvIdx=dvIdx+1; arrDistValues(dvIdx)=ColumnData; arrDistValuesF(dvIdx)=ColumnDataFmt; arrDistColHdg(dvIdx)=ColumnData; NoDistValues=dvIdx; EndIf; EndDo; If sqlStt<>'00000' And sqlStt<>'02000'; CallP SQLErrorMsg(); ElseIf dvIdx=*zero; // ERROR!!!! No Data MsgID='CPF9897'; MsgDta='Error. No data to retrieve...'; MsgDtaLen=%Len(%Trim(MsgDta)); MsgType='*ESCAPE'; MsgStack#=1; CallP(e) QMHSNDPM(MsgId: MsgFile: MsgDta: MsgDtaLen: MsgType: MsgStack: MsgStack#: MsgKey: dsErrCode); EndIf; ExSr SQLCloseCursor; EndSr; //================================================================= // Build SQL Statements //================================================================= BegSr BuildSQLStmt; // Build Base Cross Tab SELECT statement & GROUP BY // based on given row headings PrimarySelect='SELECT '; GroupBy='GROUP BY '; OrderBy='ORDER BY '; ColCount=*zero; For RowIdx=NoRowHdgs DownTo 1 By 1; ColCount=ColCount+1; If ColCount>1; PrimarySelect=PrimarySelect+', '; GroupBy=GroupBy+', '; OrderBy=OrderBy+', '; EndIf; If WriteSrc='Y'; RowHdg(ColCount)=%XLate(' ':x'FF':%Trim(RowHdg(ColCount))); EndIf; PrimarySelect=PrimarySelect + %Trim(RowHdg(ColCount)); GroupBy=GroupBy + %Trim(RowHdg(ColCount)); OrderBy=OrderBy + %Char(ColCount); EndFor; PrimarySelect=PrimarySelect+', '; If WriteSrc='Y'; // Wrap text to 79 characters, indenting 0 CallP WriteSource(PrimarySelect:79:0); CallP WriteSource('/* Values */':79:0); EndIf; // Loop through distinct values list ColCount=*zero; For dvIdx=1 To NoDistValues; // Create CASE statement for each VALUE requested For CaseIdx=NoValues DownTo 1 by 1; %Occur(dsValueStruc)=CaseIdx; ColCount=ColCount+1; If WriteSrc='Y'; // Replace any spaces in distinct values with // High Value X'FF' so it doesn't get wrapped arrDistValuesF(dvIdx)=%XLate(' ':x'FF': %TrimR(arrDistValuesF(dvIdx))); EndIf; // Build Case Statement for Distinct Value CaseStmt='CASE WHEN ' + %Trim(parmColHdg) + ' ' + %Trim(arrDistValuesF(dvIdx)) + ' THEN ' + %Trim(Value) + ' END'; // Wrap Case in Specified Column Function If ValuesToUse='DISTINCT'; CaseStmt=%Trim(ColFunction) + '(DISTINCT ' + CaseStmt + ')'; Else; CaseStmt=%Trim(ColFunction) + '(' + CaseStmt + ')'; EndIf; // Cast to Specified data type, if requested If CastToType<>*Blanks; CaseStmt=%Trim(CastToType)+'('+CaseStmt; If (CastToType='ZONED' Or CastToType='DECIMAL') And CastPrec>*Zero; CaseStmt=CaseStmt+','+%Char(CastPrec)+ ','+%Char(CastScale); EndIf; CaseStmt=CaseStmt+')'; EndIf; // Append Column Heading to Column replacing bad chars with _ If arrDistColHdg(dvIdx)=*Blanks; arrDistColHdg(dvIdx)=%Trim(ColFunction)+'_'+ arrDistValues(dvIdx); Else; arrDistColHdg(dvIdx)=%Trim(ColFunction)+'_'+ arrDistColHdg(dvIdx); EndIf; CaseStmt=CaseStmt+' AS '+ %XLate(Replaceable:ReplaceChar: %Trim(arrDistColHdg(dvIdx))); // # Columns = No Distinct Values * No Column Values If ColCount<(NoDistValues * NoValues); CaseStmt=CaseStmt+', '; EndIf; If WriteSrc='Y'; // Wrap text to 70 characters, indenting 9 CallP WriteSource(CaseStmt:70:9); EndIf; // Append Aggregate/Case to Select Statement PrimarySelect=PrimarySelect+CaseStmt; EndFor; EndFor; If WriteSrc='Y'; // Wrap text to 79 characters, indenting 0 CallP WriteSource('/* Base SQL */':79:0); parmBaseSQL=%XLate(' ':x'FF':parmBaseSQL); CallP WriteSource('FROM ('+parmBaseSQL+') AS TBL ':79:0); parmBaseSQL=%XLate(x'FF':' ':parmBaseSQL); CallP WriteSource('/* Group By */':79:0); CallP WriteSource(GroupBy:79:0); If parmOrderBy='*YES'; CallP WriteSource('/* Order By */':79:0); CallP WriteSource(OrderBy:79:0); EndIf; EndIf; // Assemble Final Cross Tab SQL CTSQL=PrimarySelect + ' FROM (' + parmBaseSQL + ') AS TBL ' + GroupBy; If parmOrderBy='*YES'; CTSQL=CTSQL+' '+OrderBy; EndIf; EndSr; //================================================================= // Trap Run-time errors //================================================================= BegSr *PSSR; MsgID='CPF9897'; MsgDta=stMsgData; MsgDtaLen=%Len(%Trim(MsgDta)); MsgType='*ESCAPE'; MsgStack#=1; Close *All; If OpenCursor='Y'; ExSr SQLCloseCursor; EndIf; *InLr=*On; CallP(e) QMHSNDPM(MsgId: MsgFile: MsgDta: MsgDtaLen: MsgType: MsgStack: MsgStack#: MsgKey: dsErrCode); Return; EndSr; /End-Free *================================================================ * Embedded SQL Statements *================================================================ C SQLPrepareStmtBegSr C/Exec Sql C+ PREPARE uniquevalues INTO :SQLDA C+ USING NAMES C+ FROM :SelectDistinct C/End-Exec C EndSr C SQLDeclareCrsrBegSr * * Use prepared statement as a cursor * C/Exec Sql C+ DECLARE UniqueValuesCursor CURSOR FOR UniqueValues C/End-Exec C EndSr C SQLOpenCursor BegSr C/Exec Sql C+ OPEN UniqueValuesCursor C/End-Exec C If SqlStt='00000' C Eval OpenCursor='Y' C EndIf C EndSr C SQLFetchData BegSr C/Exec Sql C+ FETCH UniqueValuesCursor INTO DESCRIPTOR :SQLDA C/End-Exec C EndSr C SQLCloseCursorBegSr C/Exec Sql C+ CLOSE UniqueValuesCursor C/End-Exec C EndSr C SQLExecImmed BegSr C/Exec Sql C+ EXECUTE IMMEDIATE :SQLImmed C/End-Exec C EndSr *================================================================ * Output Specs for Source Member *================================================================ OCrossTab EADD SourceSQL O 6 '000000' O 12 '000000' O SQLLine 91 *================================================================ * Procedure: Convert Numeric to Alpha *================================================================ PCvtNumToAlpha b * D CvtNumToAlpha pi 35 Varying D RawData 31 D DataType 1 D ActualSize 3 0 D Precision 3 0 D Scale 3 0 * D dsSupported ds D Float4 1 4f D Float8 1 8f D Bin2 1 2b 0 D Bin4 1 4b 0 D Bin8 20i 0 overlay(Float8) * * Default Edit Code * D EditCode s 1 inz('P') * D returnData s 35 Varying * * Variables for constructing edit mask / return data * D SrcPrecision s 10i 0 D SrcScale s 10i 0 D EditMask s 256 D EditMaskLen s 10i 0 D Receiver s 256 D ReceiverLen s 10i 0 D ZeroBalFC s 1 D FFCurrencyInd s 1 D VariableClass s 10 * * Prototype for calls to QECCVTEC / QECEDT APIs * D QECCVTEC pr ExtPgm('QECCVTEC') D pEditMask Like(EditMask) D pEditMaskLen Like(EditMaskLen) D pReceiverLen Like(ReceiverLen) D pZeroBalFC Like(ZeroBalFC) D pEditCode Like(EditCode) Const D pFFCurrencyIn Like(FFCurrencyInd) Const D pSrcPrecision Like(SrcPrecision) Const D pSrcScale Like(SrcScale) Const D pErrStruc Like(dsErrCode) * D QECEDT pr ExtPgm('QECEDT') D pReceiver Like(Receiver) D pReceiverLen Like(ReceiverLen) Const D pRawData Like(RawData) Const D pVariableCls Like(VariableClass) Const D pSrcPrecision Like(SrcPrecision) Const D pEditMask Like(EditMask) Const D pEditMaskLen Like(EditMaskLen) Const D pZeroBalFC Like(ZeroBalFC) Const D pErrStruc Like(dsErrCode) * C/Free dsSupported=RawData; // If possible, convert supported data types (Float, integer) Select; // Float When DataType='F'; If ActualSize=4; ReturnData=%char(Float4); Else; ReturnData=%char(Float8); EndIf; // Integer When DataType='B'; Select; When ActualSize=2; ReturnData=%Trim(%editc(Bin2:'P')); When ActualSize=4; ReturnData=%Trim(%editc(Bin4:'P')); When ActualSize=8; ReturnData=%Trim(%editc(Bin8:'P')); EndSl; // Zoned/Packed When DataType='S' Or DataType='P'; // Setup variables for Edit Mask / Edit Code API calls If DataType='S'; VariableClass='*ZONED'; Else; VariableClass='*PACKED'; EndIf; SrcPrecision=Precision; SrcScale=Scale; // Convert Edit Code to Edit Mask // NOTE: The first four parms are OUTPUTs from QECCVTEC // for use with QECEDT. The rest of the parms are inputs. CallP(e) QECCVTEC(EditMask:EditMaskLen: ReceiverLen:ZeroBalFC: EditCode:FFCurrencyInd: SrcPrecision:SrcScale: dsErrCode); // Format Numeric Data with Edit Mask (QECEDT API) // NOTE: The first four parms are OUTPUTs from QECCVTEC // for use with QECEDT. The rest of the parms are inputs. CallP(e) QECEDT(Receiver:ReceiverLen: RawData:VariableClass: SrcPrecision: EditMask:EditMaskLen: ZeroBalFC:dsErrCode); ReturnData=%Trim(%Subst(Receiver:1:ReceiverLen)); Other; MsgID='CPF9897'; MsgDta='Unsupported Data Type:'+DataType; MsgDtaLen=%Len(%Trim(MsgDta)); MsgType='*ESCAPE'; MsgStack#=1; CallP(e) QMHSNDPM(MsgId: MsgFile: MsgDta: MsgDtaLen: MsgType: MsgStack: MsgStack#: MsgKey: dsErrCode); EndSl; Return ReturnData; /End-Free P cvtNumToAlpha e *===================================================================== * Procedure: Replace Single Quote (') with Two Quotes ('') *===================================================================== P ReplaceQt B * D ReplaceQt PI 120 Varying D pText 60 Const * D WrkText S 120 Varying D Start S 3 0 D pos S 3 0 * C/Free WrkText=pText; Start=1; Pos=%Scan('''':WrkText); Dow Pos<>*Zero; WrkText=%Subst(WrkText:1:Pos)+''''+ %Subst(WrkText:Pos+1); Start=Pos+2; Pos=%Scan('''':WrkText:Start); EndDo; WrkText=%TrimR(WrkText); Return WrkText; /End-Free P ReplaceQt E *================================================================ * Procedure: Wrap Text to Specified Length *================================================================ P WrapText b * D WrapText PI 8192 D UnfText 8192 Varying Const Options(*VarSize) D LineLen 5 0 Const D LineBreak 10 Varying Const Options(*NoPass) * Work Fields D WrkText s + 1 Like(UnfText) D LineText s 8192 D WordText s Like(UnfText) D FmtText s 8192 D WordLen s 5 0 * Word/Line counters D Line s 5 0 D Word s 5 0 * * C/Free WrkText=UnfText+' '; If LineLen<=*Zero Or LineLen>%Size(UnfText); Return'INVALID LEN*'; EndIf; Dow %Len(WrkText)>*Zero; // Find Boundary of word WordLen=%scan(' ':WrkText)-1; If WordLen>*zero; // Test if Word length is greater than the wrap length If WordLen>LineLen ; WordText=%Subst(WrkText:1:LineLen); WrkText=%Subst(WrkText:LineLen+1); Else; WordText=%Subst(WrkText:1:WordLen); WrkText=%TrimL(%Subst(WrkText:WordLen+1)); EndIf; // Test if break was requested If %Parms=3; If WordText=LineBreak; WordText=' '; ExSr BuildLine; EndIf; EndIf; // If Length of Current Line + Length of the current word // > than formatted line length, make a new line If %Len(%TrimR(LineText)) + %Len(WordText)+1>LineLen; ExSr BuildLine; EndIf; // Append Word to current Line // NOTE: Word will be blank if a line break specified If WordText>*Blanks; Word=Word+1; If Word=1; LineText=WordText; Else; LineText=%TrimR(LineText)+' '+WordText; EndIf; EndIf; EndIf; EndDo; // Build Remaining Line If LineText>*blanks; ExSr BuildLine; EndIf; Return FmtText; // Build Single Line according to the requested format width BegSr BuildLine; Word=*Zero; If Line=*Zero; FmtText=%Subst(LineText:1:LineLen); Else; FmtText=%Subst(FmtText:1:LineLen*Line) + %Subst(LineText:1:LineLen); EndIf; Line=Line+1; LineText=*Blank; EndSr; /End-Free P WrapText E *================================================================ * Procedure: Write Text to Source File *================================================================ P WriteSource B D WriteSource PI D SourceText 8192 Varying Const Options(*VarSize) D LineLen 5 0 Const D IndentSpaces 3 0 Const D Spacing s 999 D ResultTextLen s 5 0 D SQLSource s 8192 D idx s 5 0 D NoSQLLines s 5 0 C/Free If LineLen<=*Zero Or LineLen>%Size(SourceText); Return; EndIf; // Wrap Text to desired width SQLSource=WrapText(SourceText:LineLen); // Determine no of lines returned ResultTextLen=%Len(%TrimR(SQLSource)); NoSQLLines=ResultTextLen/LineLen; If %Rem(ResultTextLen:LineLen)>*Zero; NoSQLLines=NoSQLLines+1; EndIf; // Remove NULLs from Source Text SQLSource=%XLate(x'FF':' ':SQLSource); // Write Wrapped Lines to Source File For Idx=1 To NoSQLLines By 1; SQLLine=%Subst(SQLSource:(Idx-1)*LineLen+1:LineLen); If IndentSpaces>*Zero; SQLLine=%Subst(Spacing:1:IndentSpaces) + SQLLine; EndIf; Except SourceSQL; EndFor; Return; /End-Free P WriteSource E *================================================================ * Procedure: Send Error Message from SQL Processor *================================================================ P SQLErrorMsg B D SQLErrorMsg PI C/Free // SQL Error Message MsgID='SQL' + %Subst(%EditW(%Abs(SQLCOD):'0 '):7); MsgFile='QSQLMSG *LIBL'; MsgDta=SQLERM; MsgDtaLen=SQLERL; MsgType='*ESCAPE'; MsgStack#=2; // 2 levels - program / calling program CallP(e) QMHSNDPM(MsgId: MsgFile: MsgDta: MsgDtaLen: MsgType: MsgStack: MsgStack#: MsgKey: dsErrCode); /End-Free P SQLErrorMsg E *================================================================ * Procedure: Send Run-time error message *================================================================ P RunTimeMsg B D RunTimeMsg PI C/Free // SQL Error Message MsgID='CPF9897'; MsgFile='QCPFMSG *LIBL'; MsgDta=stMsgID+' '+stMsgData; MsgDtaLen=%Size(stMsgData); MsgType='*ESCAPE'; MsgStack#=2; CallP(e) QMHSNDPM(MsgId: MsgFile: MsgDta: MsgDtaLen: MsgType: MsgStack: MsgStack#: MsgKey: dsErrCode); /End-Free P RunTimeMsg E * ** SQLDA Supported SQL Data Types 384ADATE 8 Fixed-Length string representation of a date 388ATIME 6 " time 392ATIMESTAMP 26 " timestamp 448VVARCHAR VY CHAR Varying length character string 452ACHAR CHAR Fixed Length Character String 480FFLOAT 4/8 FLO Floating Point (4 for single, 8 for dbl) 484PDECIMAL Packed Decimal (Precision byte 1, scale in byte 2) 488SNUMERIC Zoned Decimal " 492BBIGINT 8 INT Big Integer 496BINTEGER 4 INT Integer 500BSMALLINT 2 INT Small Integer