146 lines
3.3 KiB
Plaintext
146 lines
3.3 KiB
Plaintext
COMPILE SUBROUTINE Export_TSV(TableName,FieldNames,KeyList,DosTable,AutoFlag)
|
|
|
|
|
|
* 9/22/2006 John C. Henry - J.C. Henry & Co., Inc. - Initial Coding
|
|
|
|
DECLARE SUBROUTINE RList, Msg, ErrMsg, Yield, Send_Info
|
|
DECLARE FUNCTION Msg, obj_Part, Environment_Services
|
|
|
|
$Insert LOGICAL
|
|
$INSERT MSG_EQUATES
|
|
$INSERT DICT_EQUATES
|
|
|
|
EQU CRLF$ TO \0D0A\
|
|
EQU CR$ TO \0D\
|
|
EQU TAB$ TO \09\
|
|
|
|
If Assigned(AutoFlag) else AutoFlag = False$
|
|
If AutoFlag EQ True$ else AutoFlag = False$
|
|
|
|
DosTableName = DosTable[1,'.']
|
|
|
|
DosTable = DosTableName:'.tsv'
|
|
IF DosTable[2,1] NE ':' THEN
|
|
* DosTable = 'C:\OIReports\':DosTable
|
|
DosTable = Environment_Services('GetReportsRootPath') : '\':DosTable
|
|
END
|
|
|
|
OPEN TableName TO TableVar ELSE
|
|
ErrorMsg = 'Unable to open ':TableName:' table in Export_TSV routine'
|
|
If Not(AutoFlag) then ErrMsg(ErrorMsg)
|
|
RETURN
|
|
END
|
|
|
|
OPEN 'DICT.':TableName TO @DICT ELSE
|
|
ErrorMsg = 'Unable to open DICT.':TableName:' table in Export_TSV routine.'
|
|
If Not(AutoFlag) then ErrMsg(ErrorMsg)
|
|
RETURN
|
|
END
|
|
|
|
DataOut = ''
|
|
|
|
OSOPEN DosTable TO DOSFile THEN
|
|
OSWrite DataOut ON DosTable ;* Clear file it was already there
|
|
END ELSE
|
|
OSWrite DataOut ON DosTable ;* Create the file if it wasn't
|
|
OSOPEN DosTable TO DOSFile ELSE
|
|
ErrorMsg = "Unable to open ":QUOTE(DosTable):" in Export_TSV routine."
|
|
RETURN
|
|
END
|
|
END
|
|
|
|
READ Fields FROM @DICT,'%FIELDS%' ELSE
|
|
ErrorMsg = 'Unable to read %FIELDS% from DICT.':TableName:' in Export_TSV routine.'
|
|
RETURN
|
|
END
|
|
|
|
FilePointer = 0
|
|
|
|
Def = ''
|
|
Def<MTEXT$> = 'Exporting ':TableName:' Data...'
|
|
Def<MTYPE$> = 'U'
|
|
|
|
If Not(AutoFlag) then MsgUp = Msg(@WINDOW,Def)
|
|
|
|
HeaderOut = ''
|
|
|
|
FOR I = 1 TO COUNT(FieldNames,@VM) + (FieldNames NE '')
|
|
FieldName = FieldNames<1,I>
|
|
READV FieldHeader FROM @DICT,FieldName,DICT_DISPLAY$ THEN
|
|
HeaderOut := QUOTE(FieldHeader):TAB$
|
|
END
|
|
NEXT I
|
|
|
|
HeaderOut[-1,1] = ''
|
|
HeaderOut := CRLF$
|
|
|
|
OSBWrite HeaderOut ON DOSFile AT FilePointer
|
|
FilePointer += LEN(HeaderOut)
|
|
|
|
DataOut = ''
|
|
FOR I = 1 TO COUNT(KeyList,@VM) + (KeyList NE '')
|
|
@ID = KeyList<1,I>
|
|
READ @RECORD FROM TableVar,@ID THEN
|
|
|
|
FOR N = 1 TO COUNT(FieldNames,@VM) + (FieldNames NE '')
|
|
FieldName = FieldNames<1,N>
|
|
LOCATE FieldName IN Fields<FIELDS_NAME$> USING @VM SETTING Pos THEN
|
|
FType = Fields<FIELDS_TYPE$,Pos>
|
|
FNo = Fields<FIELDS_FIELD_NO$,Pos>
|
|
FMV = Fields<FIELDS_MVFLAG$,Pos>
|
|
FPart = Fields<FIELDS_PART$,Pos>
|
|
FJust = Fields<FIELDS_JUST$,Pos>
|
|
FConv = Fields<FIELDS_CONV$,Pos>
|
|
|
|
|
|
IF FNo[1,1] = 0 THEN
|
|
* @ID field
|
|
DataVal = FIELD(@ID,'*',FPart,1)
|
|
END ELSE
|
|
IF FType = 'F' THEN DataVal = @RECORD<FNo>
|
|
IF FType = 'S' THEN
|
|
DataVal = Calculate(FieldName)
|
|
END
|
|
END
|
|
IF FConv NE '' THEN DataVal = OCONV(DataVal,FConv)
|
|
|
|
DataOut := QUOTE(DataVal):TAB$
|
|
|
|
END
|
|
|
|
|
|
NEXT N
|
|
|
|
DataOut[-1,1] = ''
|
|
DataOut := CRLF$
|
|
|
|
IF LEN(DataOut) > 32000 THEN
|
|
OSBWrite DataOut ON DOSFile AT FilePointer
|
|
FilePointer += LEN(DataOut)
|
|
DataOut = ''
|
|
END
|
|
END
|
|
YIELD()
|
|
|
|
NEXT I
|
|
|
|
OSBWrite DataOut ON DOSFile AT FilePointer
|
|
|
|
If Not(AutoFlag) then Msg(@WINDOW,MsgUp)
|
|
|
|
|
|
Def = ''
|
|
Def<MTEXT$> = 'File ':DosTable:' written.'
|
|
Def<MTYPE$> = 'TA3'
|
|
|
|
If Not(AutoFlag) then MsgUp = Msg(@WINDOW,Def)
|
|
|
|
OSClose DOSFile
|
|
|
|
RETURN
|
|
|
|
|
|
|
|
|
|
|