Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

TMGDBAPI.m~@ 796

Last change on this file since 796 was 796, checked in by Kevin Toppenberg, 14 years ago
Initial upload
File size: 56.4 KB

Line
1	TMGDBAPI ;TMG/kst/Database API library ;03/25/06
2	;;1.0;TMG-LIB;1;07/12/05
3
4	;"TMG DATABASE API FUNCTIONS
5	;"Kevin Toppenberg MD
6	;"GNU General Public License (GPL) applies
7	;"7-12-2005
8
9	;"=======================================================================
10	;" API -- Public Functions.
11	;"=======================================================================
12	;"$$GetNumField^TMGDBAPI(FileNumber,FieldName) ;Convert Field Name to Field Number
13	;"$$GetFileNum^TMGDBAPI(FileName) ;Convert File Name to File Number
14	;"$$SetFileFldNums^TMGDBAPI(File,Field,FileNumber,FieldNumber) ;do both functions above at once.
15	;"$$GetFName^TMGDBAPI(FileNumber) ;Convert File Number to File Name
16	;"$$GetFldName^TMGDBAPI(File,FieldNumber) ;Convert Field Number to Field Name
17	;"$$GetFldList^TMGDBAPI(File,pArray) ;Get list of all fields for a file.
18	;"FieldExists^TMGDBAPI(FileNumber,Field)
19	;"SetFieldInfo^TMGDBAPI(File,Field,Array)
20	;"GetFieldInfo^TMGDBAPI(FileNumber,Field,VarOutP)
21	;"GetSubFileNumber^TMGDBAPI(FileNumber,Field)
22	;"$$IsSubFile^TMGDBAPI(File)
23	;"GetSubFInfo^TMGDBAPI(SubFileNum,Array)
24	;"GetRecMatch^TMGDBAPI(Data,RecNumIEN)
25	;"CompRec^TMGDBAPI(FileNumber,dbRec,TestRec)
26	;"UploadData^TMGDBAPI(DaDIta,RecNumIEN)
27	;"ValueLookup^TMGDBAPI(Params)
28	;"FileUtility^TMGDBAPI(Params)
29	;"AddRec^TMGDBAPI(Data)
30	;"OverwriteRec^TMGDBAPI(RecNum,Data)
31	;"SetupFileNum^TMGDBAPI(Data)
32	;"RecFind^TMGDBAPI(Params)
33	;"FieldCompare^TMGDBAPI(TestField,dbField,Type)
34	;"$$dbWrite^TMGDBAPI(FDA,Overwrite,TMGIDE,Flags,ErrArray)
35	;"$$DelIEN^TMGDBAPI(File,RecNumIEN,ErrArray)
36	;"$$WriteWP^TMGDBAPI(File,RecNumIEN,Field,Array)
37	;"$$ReadWP^TMGDBAPI(File,IENS,Field,Array)
38	;"$$ShowIfError^TMGDBAPI(TMGMsg,PriorErrorFund)
39	;"$$GetValidInput^TMGDBAPI(File,Field) -- Get a valid input for field in file, asking user
40	;"$$AskFIENS^TMGDBAPI() -- pick a (sub)file number, then pick a record from that file.
41	;"$$AskIENS^TMGDBAPI(FileNum) -- return IENS for File (or subfile) number
42	;"GetRef^TMGDBAPI(file,IENS,field) -- to return the global reference for a given record
43	;"GetPtrsOUT^TMGDBAPI(FileNum,Info) -- get a list of pointers out from the file.
44	;"$$TrimFDA^TMGDBAPI(FDA,Quiet) -- Trim FDA of any data already present in the database
45
46	;"=======================================================================
47	;"PRIVATE API FUNCTIONS
48	;"=======================================================================
49	;"ConvertFDA(FDA,MarkerArray)
50	;"ConvertIENS(IENS,MarkerArray)
51	;"SetupFDA(Data,FDA,IENS,SrchType,MarkNum,MsgArray,Minimal,RecNum)
52	;"HackWrite(GlobalP,FileNumber,IENS,FieldNum,Data)
53	;"HandleHacksArray(MsgArray)
54	;"GetRefArray(FileNum,array)
55
56	;"=======================================================================
57	;"DEPENDENCIES
58	;"TMGDEBUG
59	;"TMGUSRIF
60	;"TMGSTUTL
61	;"=======================================================================
62
63	;"=======================================================================
64
65	;"FORMAT OF DATA ARRAY
66
67	;" cNull="(none)"
68	;" cRecNum="RECNUM"
69	;" cOutput="OUTVAR"
70	;" cGlobal="GLOBAL"
71	;" cEntries="Entries"
72	;" cFlags="FLAGS"
73	;" cParentIENS="ParentIENS"
74
75	;"The Data array will be filed with data. (An example)
76	;" Data(0,"FILE")="1234.1" <-- "NEW PERSON" Note conversion
77	;" Data(0,"FILE",cGlobal)="^DIC(200)" <-- note, NOT "^DIC(200,"
78	;" Data(0,cRecNum)=2 <-- only if user-specified.
79	;" Data(0,cEntries)=1
80	;" Data(1,".01")="MyData1"
81	;" Data(1,".01","MATCHVALUE")="MyData1"
82	;" Data(1,".01",cFlags)=any flags given (only present if user specified)
83	;" Data(1,".02")="Bill"
84	;" Data(1,".02","MATCHVALUE")="John"
85	;" Data(1,".03")="MyData3"
86	;" Data(1,".03",cFlags)=any flags given (only present if user specified)
87	;" Data(1,".04")="MyData4"
88	;" Data(1,".06")="MyData5" <-- note "NAME" was converted to ".06"
89	;" Data(1,".07",0,cEntries)=2 <-- "ITEM" converted to ".07"
90	;" Data(1,".07",0,cParentIENS)=",10033,"
91	;" Data(1,".07",1,".01")="SubEntry1"
92	;" Data(1,".07",1,".02")="SE1"
93	;" Data(1,".07",1,".03")="'Some Info'"
94	;" Data(1,".07",2,".01")="SubEntry2"
95	;" Data(1,".07",2,".02")="SE2"
96	;" Data(1,".07",2,".04",0,cEntries)=1 ;"TEXT converted to .04
97	;" Data(1,".07",2,".04",0,cParentIENS)=",3,10033,"
98	;" Data(1,".07",2,".04",1,".01")="JD"
99	;" Data(1,".07",2,".04",1,".02")="DOE,JOHN"
100
101	;"=======================================================================
102	;"=======================================================================
103
104	GetNumField(FileNumber,FieldName)
105	;"PUBLIC FUNCTION
106	;"Purpose: Given file and the name of a field, this will return the field NUMBER
107	;"Input: FileNumber. Number of file, i.e. "4.11"
108	;" FieldName: the name of a field, i.e. "NAME" spelling must exactly match
109	;"Output: Returns field number, i.e. ".01" or 0 if not found
110
111	new cOKToCont set cOKToCont=1
112	new cAbort set cAbort=0
113	if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
114
115	new result
116	if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetNumField^TMGDBAPI")
117
118	set result=$$FLDNUM^DILFD(FileNumber,FieldName)
119
120	if result'=0 goto GNMFDone
121
122	;"--------------------------
123	;"The below is a manual method
124
125	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Having difficulty finding field name (? due to security ?). Doing Manual Check.")
126
127	new FoundField
128	new Index
129	new result set result=cAbort
130	set U=$get(U,"^") ;"Setup up U if doesn't yet exist
131
132	if $$VFILE^DILFD(FileNumber)=0 do goto GNMFDone
133	. do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, #"_FileNumber_", doesn't exist.")
134
135	set Index=""
136	GNmLoop set Index=$order(^DD(FileNumber,Index))
137	if Index="" goto GNMFDone
138	if $data(^DD(FileNumber,Index,0))=0 goto GNMFDone
139	set FoundField=$piece(^DD(FileNumber,Index,0),"^",1)
140	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Comparing fields: '",FoundField,"' vs. '",FieldName,"'")
141	if FieldName=FoundField do goto GNMFDone
142	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Match!")
143	. set result=Index
144	goto GNmLoop
145
146	GNMFDone
147	if result=cAbort do
148	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Unable to convert '",FieldName,"' in file '",FileNumber,"' to a field number. Check for Field name typo")
149	if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetNumField^TMGDBAPI")
150
151	quit result
152
153	SetFileFldNums(File,Field,FileNumber,FieldNumber)
154	;"Purpose: To provide a generic shell to ensure that File and Field numbers are in place
155	;"Input: File -- File number or name
156	;" Field -- field number or name
157	;" FileNumber -- PASS BY REFERENCE -- an out parameter
158	;" FieldNum -- PASS BY REFERENCE -- an out parameter
159	;"Results: cOKToCont(1) if ok, otherwise cAbort(0) if error
160	;"Output -- FileNumber and FieldNumber are filled in.
161
162	new cOKToCont set cOKToCont=1
163	new cAbort set cAbort=0
164	if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
165
166	new result set result=cOKToCont
167	if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SetFileFldNums^TMGDBAPI")
168
169	set FileNumber=+$get(File)
170	if FileNumber=0 set FileNumber=$$GetFileNum(.File)
171	if FileNumber=0 do goto SFFNDone
172	. set result=cAbort
173	. do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert file '"_$get(File)_", to a number.")
174
175	set FieldNumber=$get(Field)
176	if FieldNumber=0 set FieldNumber=$$GetNumField(FileNumber,.Field)
177	if FieldNumber=0 do goto SFFNDone
178	. set result=cAbort
179	. do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert field '"_$get(Field)_", to a number.")
180
181	SFFNDone
182	if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SetFileFldNums^TMGDBAPI")
183	quit result
184
185
186	FieldExists(FileNumber,Field)
187	;"PUBLIC FUNCTION
188	;"Purpose: To ensure that a field exists -- even if hidden by security measures
189	;"Input: FileNumber: File to check
190	;" Field: the field number (or name) to check
191	;"Result: 1 if field exists, 0 if doesn't, 2 if exists but is hidden to user
192
193	new result,FieldNumber
194	if +Field=0 set FieldNumber=$$GetNumField(FileNumber,Field)
195	else set FieldNumber=Field
196
197	set result=$$VFIELD^DILFD(FileNumber,FieldNumber)
198	if result=1 goto FExsDone
199
200	;"Try a low-level data dictionary eval to see if really does exist, but is hidden
201	if $data(^DD(FileNumber,FieldNumber,0))'=0 set result=2
202
203	FExsDone
204	quit result
205
206
207
208	GetSubFileNumber(FileNumber,Field)
209	;"PUBLIC FUNCTION
210	;"Purpose: If FieldNumber is a 'multiple' field, then this function should return 'subfile'
211	;" number of the sub file.
212	;"Input:FileNumber-- the file number (or sub file number) that field exists in
213	;" Field-- the field number (or name) in file to lookup
214	;"Result: Returns sub file number, or 0 if not found or invalid
215
216	new cOKToCont set cOKToCont=1
217	new cAbort set cAbort=0
218	if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
219
220	new Info
221	new result set result=cAbort
222	new Output
223
224	if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetSubFileNumber^TMGDBAPI")
225
226	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNumber=",FileNumber)
227	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Field=",Field)
228
229	;"First, verify file (or subfile) exists
230	if $$VFILE^DILFD(FileNumber)=0 do goto GSFDone ;"abort
231	. do ShowError^TMGDEBUG(.PriorErrorFound,"File number '"_FileNumber_"' is not valid.")
232
233	;"Next, ensure Field exists in file
234	if $$FieldExists(FileNumber,Field)=0 do goto GSFDone ;"abort
235	. do ShowError^TMGDEBUG(.PriorErrorFound,"Field number '"_Field_"' is not valid.")
236
237	;"Next, ensure field is a multiple and get field info.
238	do GetFieldInfo(FileNumber,Field,"Output")
239	if $data(Output("MULTIPLE-VALUED"))=0 do goto GSFDone ;"abort
240	. do ShowError^TMGDEBUG(.PriorErrorFound,"Field '"_Field_"' in File '"_FileNumber_"' is not a subfile.")
241
242	;"Now actually get subfile number
243	if $data(Output("SPECIFIER"))=0 do goto GSFDone ;"abort
244	. do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to find 'Specifier' (subfile number)")
245	set result=+Output("SPECIFIER")
246
247	;"Now actually get subfile number
248	;"set Info=$get(^DD(FileNumber,Field,0),0)
249	;"if Info=0 do goto GSFDone
250	;". do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to get information from data dictionary.")
251	;"set result=+$piece(Info,"^",2)
252
253	GSFDone
254	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"SubFile number is: ",result)
255	if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetSubFileNumber^TMGDBAPI")
256	quit result
257
258
259	IsSubFile(File)
260	;"Purpose: to return if file is actually a subfile
261	;"Input: File -- File name or number
262	;"Results: Parent file number^Field in Parent File
263	;" or 0 if not a subfile.
264
265	new result
266	if +File'=File set File=$$GetFileNum(File)
267	set result=+$get(^DD(File,0,"UP"))
268	if result'>0 goto ISFDone
269
270	;"Now find which field this sub file is in its parent
271	new fldInParent set fldInParent=0
272	new field set field=0
273	new done set done=0
274	for set field=$order(^DD(result,field)) quit:(+field'>0)!(done=1) do
275	. new fldInfo set fldInfo=$piece($get(^DD(result,field,0)),"^",2)
276	. if +fldInfo=File set fldInParent=field set done=1
277	if fldInParent>0 set result=result_"^"_fldInParent
278	ISFDone
279	quit result
280
281
282	GetSubFInfo(SubFileNum,Array)
283	;"PUBLIC FUNCTION
284	;"Purpose: To take a subfile NUMBER, and return information about it.
285	;"Input: SubFileNum-- the sub file number
286	;" Array -- PASS BY REFERENCE. An array to receive results.
287	;" any preexisting data is deleted.
288	;"Output Array is formated as follows:
289	;" Array("SUBFILE","NUMBER")=file number of this sub file.
290	;" Array("SUBFILE","NAME")=file name of this sub file.
291	;" Array("PARENT","NUMBER")=parent file number
292	;" Array("PARENT","NAME")=parent file name
293	;" Array("PARENT","GL")=global reference of parent, in open format<-- only valid if parent isn't also a subfile
294	;" Array("FIELD IN PARENT","NUMBER")=field number of subfile in parent
295	;" Array("FIELD IN PARENT","NAME")=filed name of subfile in parent
296	;" Array("FIELD IN PARENT","LOC")=node and piece where subfile is stored
297	;" Array("FIELD IN PARENT","CODE")=code giving subfile's attributes.
298	;"Result: 1 if found info, or 0 if not found or invalid
299
300	new result set result=0
301	if '$get(SubFileNum) goto GSPDone
302	kill Array
303	set Array("SUBFILE","NUMBER")=SubFileNum
304	set Array("SUBFILE","NAME")=$piece($get(^DD(SubFileNum,0)),"^",1)
305	new parent
306	set parent=+$get(^DD(SubFileNum,0,"UP"))
307	if parent=0 goto GSPDone
308	set Array("PARENT","NUMBER")=parent
309	set Array("PARENT","NAME")=$order(^DD(parent,0,"NM",""))
310	set Array("PARENT","GL")=$get(^DIC(parent,0,"GL"))
311	new i set i=$order(^DD(parent,""))
312	for do quit:(i="")!(result=1) ;"scan all fields for a match
313	. quit:(i="")
314	. new node,num
315	. set node=$get(^DD(parent,i,0))
316	. if +$piece(node,"^",2)=SubFileNum do quit
317	. . set Array("FIELD IN PARENT","NUMBER")=i
318	. . set Array("FIELD IN PARENT","NAME")=$piece(node,"^",1)
319	. . set Array("FIELD IN PARENT","LOC")=$piece(node,"^",4)
320	. . set Array("FIELD IN PARENT","CODE")=$piece(node,"^",2)
321	. . set result=1
322	. set i=$order(^DD(parent,i))
323
324	GSPDone
325	quit result
326
327
328
329	GetFieldInfo(FileNumber,Field,VarOutP,InfoS)
330	;"PUBLIC FUNCTION
331	;"Purpose: To get Field info,
332	;"Input: FileNumber: File or subfile number
333	;" Field: Field name or number
334	;" VarOutP -- the NAME of the variable to put result into.
335	;" InfoS -- [OPTIONAL] -- additional attributes of field info to be looked up
336	;" (as allowed by FIELD^DID). Multiple items should be
337	;" separated by a semicolon (';')
338	;" e.g. "TITLE;LABEL;POINTER"
339	;"Output: Data is put into VarOutP (any thing in VarOutP is erased first
340	;" i.e. @VarOutP@("MULTIPLE-VALUED")=X
341	;" i.e. @VarOutP@("SPECIFIER")=Y
342	;" i.e. @VarOutP@("TYPE")=Z
343	;" i.e. @VarOutP@("StoreLoc")="0;1" <-- not from fileman output (i.e. extra info)
344	;" (if additional attributes were specified, they will also be in array)
345	;"Result: none
346
347	kill @VarOutP ;"erase any old information
348
349	if +Field=0 set Field=$$GetNumField(FileNumber,Field)
350	set @VarOutP@("StoreLoc")=$piece($get(^DD(FileNumber,Field,0)),"^",4)
351
352	new Attribs set Attribs="MULTIPLE-VALUED;SPECIFIER;TYPE"
353	if $data(InfoS) set Attribs=Attribs_";"_InfoS
354	;"Next, check if field is a multiple and get field info.
355	do FIELD^DID(FileNumber,Field,,Attribs,VarOutP,"TMGMsg")
356	if $data(TMGMsg) do
357	. if $data(TMGMsg("DIERR"))'=0 do quit
358	. . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound)
359
360	GFIDone
361	quit
362
363
364
365	HackWrite(GlobalP,FileNumber,IENS,FieldNum,Data)
366	;"PUBLIC FUNCTION
367	;"Purpse: To force data into a field -- using low level 'hack' method
368	;"Input: GlobalP -- the NAME of the global to put this into, i.e. "^VA(200,"
369	;" FileNumber- the file number
370	;" IENS -- the standard API IENS
371	;" FieldNum the field to put this into
372	;" Data -- the value to put in
373	;"Note: This can be used to put a value of "@" into a field
374	;"Result: 1 if ok to continue, 0=abort
375	;"!!!NOTICE: This is a very low level means of accessing the database.
376	;" The built in data verifiers, indexers etc etc will not be made aware of
377	;" changes made to the database through this method. USE ONLY WITH CAUTION.
378
379	new cOKToCont set cOKToCont=1
380	new cAbort set cAbort=0
381	if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
382
383	new result set result=cAbort
384
385	if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"HackWrite^TMGDBAPI")
386
387	if '$data(GlobalP) goto HWDone
388	if '$data(FileNumber) goto HWDone
389	if '$data(IENS) goto HWDone
390	if '$data(FieldNum) goto HWDone
391	if '$data(Data) goto HWDone
392
393	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"GlobalP: ",GlobalP)
394	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"File:",FileNumber)
395	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IENS:",IENS)
396	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum:",FieldNum)
397	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Data:",Data)
398
399	new DDInfo
400	new FieldInfo
401	new Index,Part
402	new OldData
403	new RecNum
404
405	;"Get info from data dictionary r.e. where actual fields are stored in files.
406	set DDInfo=$get(^DD(FileNumber,FieldNum,0))
407	if '$data(DDInfo) goto HWDone
408	set FieldInfo=$piece(DDInfo,"^",4)
409	if '$data(FieldInfo),(FieldInfo="") goto HWDone
410	set Index=$piece(FieldInfo,";",1)
411	set Part=$piece(FieldInfo,";",2)
412
413	;"Convert global form of ^VA(200, into ^VA(200)
414	new Len
415	set Len=$length(GlobalP)
416	if $extract(GlobalP,Len)="," do
417	. set $extract(GlobalP,Len)=")"
418
419	set RecNum=$piece(IENS,",",1)
420	if $piece(IENS,",",2)'="" do goto HWDone
421	. do ShowError^TMGDEBUG(.PriorErrorFound,"Hack writing to subfiles not supported")
422	if $data(@GlobalP@(RecNum,Index))=0 goto HWDone
423	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"I think the correct data place is: ",GlobalP,"(",RecNum,",",Index,") at piece: ",Part)
424	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"That line is now: ",@GlobalP@(RecNum,Index))
425	set OldData=$piece(@GlobalP@(RecNum,Index),"^",Part)
426	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"And that data item is now: '",OldData,"'")
427	if Data'=OldData do
428	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Performing hack write")
429	. set $piece(@GlobalP@(RecNum,Index),"^",Part)=Data
430	. ;"Give Message
431	. new Text
432	. set Text(0)="<!> Caution"
433	. set Text(1)="Yikes!"
434	. set Text(2)=" "
435	. set Text(3)="We just bypassed all safety measures, "
436	. set Text(4)="and wrote directly to the database."
437	. set Text(5)="Make sure you know what you are doing!!"
438	. set Text(6)=" "
439	. set Text(7)="File: "_FileNumber
440	. set Text(8)="Field: "_FieldNum
441	. set Text(9)="Prior value: '"_OldData_"'"
442	. set Text(10)="New value: '"_Data_"'"
443	. set Text(11)=" "
444	. set Text(12)="(This was caused by using Flags='H' in"
445	. set Text(13)="the XML script.)"
446	. do PopupArray^TMGUSRIF(5,45,.Text)
447	else do
448	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No need for hackwrite... the data is already what we want.")
449
450	HWDone
451	if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"HackWrite^TMGDBAPI")
452	quit
453
454
455	HandleHacksArray(MsgArray)
456	;"PUBLIC FUNCTION
457	;"Purpose: To cycle through an array of hackwrites and process each one.
458	;"Input: HacksArray. Best if passed by reference
459	;" Expected format of array:
460	;" MsgArray(cHack,0,cEntries)=Number of Entries
461	;" MsgArray(cHack,n) = Global;FileNumber;IENS;FieldNum;Data
462	;" MsgArray(cHack,n,cFlags)=User specified Flags for field.
463	;"Output: database is changed
464	;"Result: 1 if ok to continue, 0=abort
465	;"!!!NOTICE: This is a very low level means of accessing the database.
466	;" The built in data verifiers, indexers etc etc will not be made aware of
467	;" changes made to the database through this method. USE ONLY WITH CAUTION.
468
469	new cOKToCont set cOKToCont=1
470	new cAbort set cAbort=0
471	if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
472	new cHack set cHack="H"
473	new cEntries set cEntries="Entries"
474
475	if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"HandleHacksArray^TMGDBAPI")
476
477	new result set result=cOKToCont
478	new index set index=1
479	new GlobalP,FileNum,IENS,FieldNum,Data
480	new s
481
482	for index=1:1:$get(MsgArray(cHack,0,cEntries)) do quit:(s="")!(result=cAbort)
483	. set s=$get(MsgArray(cHack,index)) if s="" quit
484	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Processing: ",s)
485	. set GlobalP=$piece(s,";",1)
486	. set FileNum=$piece(s,";",2)
487	. set IENS=$piece(s,";",3)
488	. set FieldNum=$piece(s,";",4)
489	. set Data=$piece(s,";",5)
490	. set result=$$HackWrite(GlobalP,FileNum,IENS,FieldNum,Data)
491
492	if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"HandleHacksArray^TMGDBAPI")
493	quit result
494
495
496	GetRecMatch(Data,RecNumIEN)
497	;"PUBLIC FUNCTION
498	;"Purpose: Take Data array from DoUpload, and search in database
499	;" for a prior matching record
500	;"Input: Data - Data array will contain all the information that is to be uploaded
501	;" Fields that should be specifically matched will have "MATCHTHIS" fields.
502	;" A field may have a "MATCHTHIS" node meaning that the value
503	;" specified should be searched for.
504	;" Or, rarely, one may want to specifically search for a different
505	;" search value. This is stored in a "MATCHVALUE" node. This
506	;" node is ignored if "MATCHTHIS" node is present.
507	;" The .01 field always is used for searching. If not present, then
508	;" a "MATCHTHIS" node is assumed.
509	;" Example array:
510	;" Data(0,"FILE")="1234.1" <-- "NEW PERSON" Note conversion
511	;" Data(1,".01")="BILL"
512	;" Data(1,".01","MATCHVALUE")="JOHN" <-- optional search value
513	;" Data(1,".01","MATCHTHIS")=1
514	;" Data(1,".02")="Sue"
515	;" Data(1,".03")="MyData3"
516	;" Data(1,".03",cFlags)=any flags given (only present if user specified)
517	;" RecNumIEN -- MUST PASS BY REFERENCE. An OUT parameter to receive results
518	;"Output: Returns answer in RecNumIEN (record number in file) if found, or 0 otherwise
519	;"Result: 1=OKToContinue, 0=Abort
520	;"Note:
521	;" * Data in Multiple fields are NOT used for matching.
522	;" * I am not going to support matching for subrecords (i.e. SubEntry stuff above)
523	;" * If data passed is a subset of a larger data group (i.e. when this function
524	;" is called recursively to handle a subfile), then an entry will be placed
525	;" in the Data(0,cParentIENS) that will specify the RecNumIEN of the parent record
526	;" holding this subfile.
527
528	new cOKToCont set cOKToCont=1
529	new cAbort set cAbort=0
530	if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
531	new cParentIENS set cParentIENS="ParentIENS"
532
533	new FileNumber,FieldNum
534	set RecNumIEN=0
535	new IENS,Fields,Flags
536	new MatchValue set MatchValue=""
537	new FieldMatch set FieldMatch=""
538	new ScreenCode
539	new Matches,NumMatches
540	new TMGMsg
541	new result set result=cOKToCont
542	new index
543	new SlimData ;"Will hold just those fields that should be matched against
544	new OneMatch
545
546	set IENS=$get(Data(0,cParentIENS))
547	if IENS'="" if $extract(IENS,1)'="," do
548	. set IENS=","_IENS
549
550	set Fields="@"
551	;"Setup specifier to tell which fields to return info on
552	new done set done=0
553	set index=0
554	for set index=$order(Data(index)) quit:(index="")!done do
555	. set FieldNum=""
556	. for set FieldNum=$order(Data(index,FieldNum)) quit:(+FieldNum=0) do
557	. . if $get(Data(index,FieldNum,"MATCHTHIS"))=1 do
558	. . . set FieldMatch=$get(Data(index,FieldNum))
559	. . else set FieldMatch=$get(Data(index,FieldNum,"MATCHVALUE"))
560	. . if FieldNum=".01" do
561	. . . if FieldMatch="" set FieldMatch=$get(Data(index,.01))
562	. . . set MatchValue=FieldMatch
563	. . if FieldMatch'="" do
564	. . . set Fields=Fields_";"_FieldNum
565	. . . set SlimData(FieldNum)=FieldMatch
566	. . . set FieldMatch=""
567	. set done=1 ;"Force handling only 1 entry (i.e. #1), then quit after first cycle.
568
569	set FileNumber=$get(Data(0,"FILE"))
570	set ScreenCode=""
571	set Flags=""
572
573	;"======================================================
574	;"Call FIND^DIC
575	;"======================================================
576	;"Params:
577	;"FILE,IENS,FIELDS,FLAGS,VALUE,NUMBER,INDEXES,SCREEN,IDENTIFIER,TARGET_ROOT,MSG_ROOTS
578	do FIND^DIC(FileNumber,$get(IENS),Fields,Flags,MatchValue,"*",,ScreenCode,,"Matches","TMGMsg")
579	if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::FIND^DIC")
580	;"======================================================
581	;"======================================================
582
583	if $data(TMGMsg) do
584	. if $data(TMGMsg("DIERR"))'=0 do quit
585	. . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound)
586	. . set result=cAbort
587	if result=cAbort goto GRMQuit
588
589	if $data(Matches("DILIST"))=0 goto GRMQuit ;"keep RecNumIEN default of 0
590	set NumMatches=$piece(Matches("DILIST",0),"^",1)
591	if NumMatches=0 goto GRMQuit ;"keep RecNumIEN default of 0
592
593	for index=1:1:NumMatches do quit:RecNumIEN'=0 ;"Note: FIRST match returned.
594	. kill OneMatch
595	. merge OneMatch=Matches("DILIST","ID",index)
596	. if $$CompRec(FileNumber,.OneMatch,.SlimData) set RecNumIEN=Matches("DILIST",2,index)
597
598	GRMQuit
599	quit result
600
601
602	CompRec(FileNumber,dbRec,TestRec)
603	;"PUBLIC FUNCTION
604	;"Purpose: To compare data from the database against a test match
605	;"Input: FileNumber: the file data is from
606	;" dbRec, an array of data from the database in the following format
607	;" dbRec(.01)="JOHNS,BILL"
608	;" dbRec(.02)="MALE"
609	;" dbRec(.03)="01/20/1957"
610	;" dbRec(.07)="(123) 555-1212"
611	;" TestRec, an array of data to test for match with, in same format
612	;" as above. Note: there may well be less entries in this array
613	;" than in the dbRec
614	;" TestRec(.01)="JOHNS,BILL"
615	;" TestRec(.03)="01/20/1957"
616	;"Output: 1 if all values in TestRec=dbRec. 0=conflict
617	;" Note: values in dbRec that don't have a corresponding entry in TestRec
618	;" are ignored.
619
620	new cOKToCont set cOKToCont=1
621	new cAbort set cAbort=0
622	if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
623
624	new result set result=cOKToCont
625	new index set index=""
626	new FieldType,TMGFDA,TMGMsg
627	new dbIDT,testIDT ;" IDT = internal form of date/time
628
629	if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"CompRec^TMGDBAPI")
630
631	if TMGDEBUG do
632	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is records to be compared")
633	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"dbRec:")
634	. do ArrayDump^TMGDEBUG("dbRec") ;"zwr dbRec(*)
635	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TestRec:")
636	. do ArrayDump^TMGDEBUG("TestRec") ;"zwr TestRec(*)
637
638	CRLoop
639	set index=$order(TestRec(index))
640	if index="" goto CRDone
641	if $data(dbRec(index))=0 goto CRLoop
642	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Comparing field ",index)
643	kill TMGFDA,TMGMsg
644	do FIELD^DID(FileNumber,index,,"TYPE","TMGFDA","TMGMsg")
645	if $get(TMGFDA("TYPE"))="DATE/TIME" do goto CRDone:'result
646	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Doing special date comparison")
647	. set X=TestRec(index)
648	. do ^%DT ;"convert date/time into internal format
649	. set testIDT=Y
650	. set X=dbRec(index)
651	. do ^%DT ;"convert date/time into internal format
652	. set dbIDT=Y
653	. if testIDT'=dbIDT do
654	. . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Dates not equal: ",TestRec(index)," vs, ",dbRec(index))
655	. . set result=cAbort
656	else if TestRec(index)'=dbRec(index) do goto CRDone ;"Note: simple '=' compare
657	. set result=cAbort
658	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Fields are equal")
659	goto CRLoop
660	CRDone
661	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Leaving CompRec. Result=",result," (0 if conflict)")
662
663	if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"CompRec^TMGDBAPI")
664	quit result
665
666
667	UploadData(Data,RecNumIEN)
668	;"PUBLIC FUNCTION
669	;"Purpose: Do actual upload of Data, given in specific format
670	;"Note: This function may be called recursively by subfiles
671	;"Input: Data -- data in format show at TOP OF THIS FILE
672	;" Note: If this function is being passed recursively, then the data
673	;" passed is probably just a subpart that corresponds to the subfile
674	;" RecNumIEN -- OPTIONAL pameter. May be used to specify the
675	;" record to force data into. If passed by reference, then
676	;" record number (IEN) where data was placed is passed back.
677	;" Use of this parameter only makes sense when filing the highest
678	;" level file. (When filing subfiles recursively, then the parent
679	;" record number is stored in (0,cParentIENS)=",10033," e.g.)
680	;"Output: Information will be put into global database, based on
681	;" entries in Data.
682	;" Record number (IEN) of record will be put into RecNumIEN (or 0 if error)
683	;"Result: Returns success 1=OK to continue. 0=Abort
684
685	new cOKToCont set cOKToCont=1
686	new cAbort set cAbort=0
687	if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
688	new cEntries set cEntries="Entries"
689
690	if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"UploadData^TMGDBAPI")
691
692	new result set result=cOKToCont
693	new NumEntries
694	new index
695
696	set RecNumIEN=$get(RecNumIEN,0) ;"See if user-specified IEN was given.
697
698	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNumIEN=",RecNumIEN)
699
700	if RecNumIEN'=0 do goto UDDone:(result=cAbort)
701	. new Params,MyOutVar
702	. set Params("FILE")=$get(Data(0,"FILE"))
703	. set Params(cRecNum)=RecNumIEN
704	. set Params(cField)=".01"
705	. set Params(cOutput)="MyOutVar"
706	. set result=$$ValueLookup(.Params) ;"result=0 (cAbort) if unsuccessful lookup
707	. if result=cAbort do
708	. . if $data(PriorErrorFound)=0 new PriorErrorFound
709	. . new s set s="Unable to overwrite data into record#"_RecNumIEN_" because that record does not already exist.\n"
710	. . set s=s_"Will try to put data into a new record, which may not be record#"_RecNumIEN
711	. . do ShowError^TMGDEBUG(.PriorErrorFound,s)
712	. . set result=cOKToCont
713	. . set PriorErrorFound=0 ;"clear errors and continue program.
714	. . set RecNumIEN=0
715
716	set NumEntries=$get(Data(0,cEntries))
717	for index=1:1:NumEntries do quit:(result=cAbort)
718	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Starting loop to process all uploadData entries. Entry=",index)
719	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNumIEN=",RecNumIEN)
720	. new tData ;"Create a tData array that has only 1 entry in it.
721	. merge tData(0)=Data(0)
722	. set tData(0,cEntries)=1
723	. merge tData(1)=Data(index)
724	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"This is entry to process")
725	. if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("tData")
726	. if RecNumIEN=0 set result=$$GetRecMatch(.tData,.RecNumIEN) ;"if no prior record, returns 0
727	. if result=cAbort quit ;//kt added 1/6/05
728	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Using RecNumIEN=",RecNumIEN)
729	. ;
730	. if RecNumIEN=0 do quit:(result=cAbort)
731	. . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"calling AddRec")
732	. . new AddRecNum
733	. . set AddRecNum=$$AddRec(.tData)
734	. . if AddRecNum=0 do quit
735	. . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error adding a record.")
736	. . . set result=cAbort
737	. else do quit:(result=cAbort)
738	. . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"calling Overwriterec")
739	. . set result=$$OverwriteRec(RecNumIEN,.tData)
740	. . set RecNumIEN=0 ;"We won't to file any more into that record num, force search next cycle.
741	. . if result=cAbort do quit
742	. . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error modifying an existing record.")
743
744	UDDone
745	;"if (result'=cAbort) set result=(RecNumIEN>0)
746	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Result = ",result)
747	if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"UploadData^TMGDBAPI")
748	quit result
749
750
751
752	ValueLookup(Params)
753	;"PUBLIC FUNCTION
754	;"Purpose: To look for a value of a given value in a given record in given file.
755	;"Input: Params -- an array loaded with expected parameters. I.e.:
756	;" Params("FILE")="NEW PERSON" in our example
757	;" Params(cRecNum)="1" in example
758	;" Params(cField)=".01" in our example (could be Name of field)
759	;" Params(cOutput)="MyVar"
760	;"Output: MyVar is loaded with data, i.e.:
761	;" MyVar("FILE")=200
762	;" MyVar(cGlobal)="^VA(200)"
763	;" MyVar(cGlobal,cOpen)="^VA(200,"
764	;" MyVar(cRecNum)=1
765	;" MyVar(cField)=.01
766	;" MyVar(cValue)=xxx <-- the looked-up value
767	;"Returns: If should continue execution: 1=OK to continue. 0=unsuccessful lookup
768	;"Note: I am getting values by directly looking into database, rather than use
769	;" the usual lookup commands. I am doing this so that there will be no
770	;" 'hidden' data, based on security etc.
771	;" **I need to check, but this probably means that the data returned will be
772	;" in INTERNAL FILEMAN FORMAT (i.e. time values are encoded etc.)
773
774	new cOKToCont set cOKToCont=1
775	new cAbort set cAbort=0
776	if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
777	new cField set cField="FIELD" ;"Field"
778	new cNull set cNull="(none)"
779	new cRecNum set cRecNum="RECNUM" ;"RecNum
780	new cOutput set cOutput="OUTVAR" ;"OutVar"
781	new cGlobal set cGlobal="GLOBAL"
782	new cValueLookup set cValueLookup="LOOKUPFIELDVALUE" ;"LookupFieldValue"
783	new cOpen set cOpen="OPEN"
784
785
786	if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ValueLookup^TMGDBAPI")
787	new result set result=cAbort
788
789	new Data
790	new DDInfo
791	new FieldInfo
792	new Index,Part
793
794	new Field set Field=$get(Params(cField),cNull)
795	new RecNum set RecNum=$get(Params(cRecNum),cNull)
796	new OutVarP set OutVarP=$get(Params(cOutput),cNull)
797	if (RecNum=cNull),(OutVarP=cNull) goto DVLUDone
798	kill @OutVarP ;"--ensure old variables in output variable are removed.
799
800	set Data(0,"FILE")=$get(Params("FILE"))
801	set result=$$SetupFileNum(.Data)
802	if result=cAbort goto DVLUDone
803	new FileNum set FileNum=$get(Data(0,"FILE"),cNull)
804	new GlobalP set GlobalP=$get(Data(0,"FILE",cGlobal),cNull)
805	if (FileNum=cNull),(GlobalP=cNull) goto DVLUDone
806	new FieldNum set FieldNum=$$GetNumField(FileNum,Field)
807	if FieldNum=0 goto DVLUDone
808
809	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"GlobalP: ",GlobalP)
810	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"File: ",FileNum)
811	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Rec#: ",RecNum)
812	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum: ",FieldNum)
813
814	;"Get info from data dictionary r.e. where actual fields are stored in files.
815	set DDInfo=$get(^DD(FileNum,FieldNum,0))
816	if $data(DDInfo)=0 goto HWDone
817	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"DDInfo='",DDInfo,"', $data(DDInfo)=",$data(DDinfo))
818	set FieldInfo=$piece(DDInfo,"^",4)
819	if '$data(FieldInfo),(FieldInfo="") goto DVLUDone
820	set Index=$piece(FieldInfo,";",1)
821	set Part=$piece(FieldInfo,";",2)
822
823	if $data(@GlobalP@(RecNum,Index))=0 goto DVLUDone
824	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"I think the correct data place is: ",GlobalP,"(",RecNum,",",Index,") at piece: ",Part)
825	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"That line is now: ",@GlobalP@(RecNum,Index))
826	set Data=$piece(@GlobalP@(RecNum,Index),"^",Part)
827	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"And our value is: ",Data)
828
829	kill @OutVarP
830	set @OutVarP@("FILE")=FileNum
831	set @OutVarP@(cRecNum)=RecNum
832	set @OutVarP@(cField)=FieldNum
833	set @OutVarP@(cValue)=Data
834	set @OutVarP@(cGlobal)=GlobalP
835	set @OutVarP@(cGlobal,cOpen)=$get(Data(0,"FILE",cGlobal,cOpen))
836
837	set result=cOKToCont
838
839	DVLUDone
840	if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ValueLookup^TMGDBAPI")
841	quit result
842
843
844	FileUtility(Params)
845	;"PUBLIC FUNCTION
846	;"Purpose: To provide file access/manipulation utilities to script user
847	;"syntax:
848	;" <FileUtility File="NEW PERSON" Fn="xxx" RecNum="1" Field=".01" OutVar"MyOutVar" Value="xx" >
849	;"Input: Params -- an array loaded with expected parameters. I.e.:
850	;" Params("FILE")="NEW PERSON" for example
851	;" File: The name of the file to act upon.
852	;" File may have subnodes (i.e. "NEW PERSON\|ALIAS\|TITLE")
853	;" BUT, any deletion or set values will only work on top level (i.e. "NEW PERSON")
854	;" Params(cFn)="info" or "delete", or "set" [OPTIONAL]
855	;" Fn="delete" If Field is not specified:
856	;" Will cause record RecNum to be deleted.
857	;" MyOutVar("DELETED")=RecNum of deleted record, or
858	;" 0 if not found.
859	;" If Field IS specified:
860	;" Will delete the value in field, in record RecNum
861	;" Note: delete is intended only for the highest-level records
862	;" (i.e. not subfiels, or multiple fields)
863	;" Note: delete method uses ^DIK to delete the record
864	;" Fn="info" Will just fill in info below.
865	;" If Fn not specified, this is default
866	;" Fn="set" Will put Value into Field, in RecNum, in File (all required)
867	;" Params(cRecNum)="1" for example
868	;" RecNum: [OPTIONAL] Specifies which record to act on. If not
869	;" specified, then just file info is returned.
870	;" Params(cField)=".01" for example (could be Name of field)
871	;" Field: [OPTIONAL] Specifies which field to act on.
872	;" Params(cOutput)="MyVar"
873	;" OutVar: Needed to get information back from function (but still Optional)
874	;" Gives name of variable to put info into.
875	;"Output: MyVar is loaded with data, i.e.
876	;" i.e. MyOutVar("FILE")=Filenumber
877	;" MyOutVar("FILE","FILE")=SubFilenumber <-- only if subnodes input in File name (e.g."ALIAS")
878	;" MyOutVar("FILE","FILE","FILE")=SubSubFilenumber <-- only if subnodes input in File name (e.g."TITLE")
879	;" MyOutVar("GLOBAL")="^VA(200)"
880	;" MyOutVar("GLOBAL, OPEN")="^VA(200,"
881	;" MyOutVar("RECNUM")=record number
882	;" MyOutVar("FIELD")=Filenumber
883	;" MyOutVar("VALUE")=xxxx <=== value of field (PRIOR TO deletion, if deleted)
884	;" MyOutVar("NEXTREC")=record number after RecNum, or "" if none
885	;" MyOutVar("PREVREC")=record number before RecNum, or "" if none
886	;" MyOutVar("FN")=the function executed
887	;" MyOutVar("NUMRECS")=Number of records in file PRIOR to any deletions
888	;" MyOutVar("FIRSTREC")=Rec number of first record in file
889	;" MyOutVar("LASTREC")=Rec number of last record in file
890	;"Returns: If should continue execution: 1=OK to continue. 0=abort
891	;"Note: I am getting values by directly looking into database, rather than use
892	;" the usual lookup commands. I am doing this so that there will be no
893	;" 'hidden' data, based on security etc.
894
895	if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
896	new cOKToCont set cOKToCont=1
897	new cAbort set cAbort=0
898	new cField set cField="FIELD" ;"Field"
899	new cNull set cNull="(none)"
900	new cRecNum set cRecNum="RECNUM" ;"RecNum
901	new cRecord set cRecord="RECORD" ;"Record"
902	new cOutput set cOutput="OUTVAR" ;"OutVar"
903	new cGlobal set cGlobal="GLOBAL"
904	new cValueLookup set cValueLookup="LOOKUPFIELDVALUE" ;"LookupFieldValue"
905	new cOpen set cOpen="OPEN"
906	new cInfo set cInfo="INFO" ;"Info
907	if $data(cNodeDiv)#10=0 new cNodeDiv set cNodeDiv="\|"
908	new cDelete set cDelete="DELETE" ;"Delete
909	new cNextRec set cNextRec="NEXTREC"
910	new cPrev set cPrev="PREV"
911	new cNumRecs set cNumRecs="NUMRECS"
912	new cFirstRec set cFirstRec="FIRSTREC"
913	new cLastRec set cLastRec="LASTREC"
914
915	if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"DoFileUtility^TMGDBAPI")
916	new result set result=cAbort
917
918	new Data
919	new DDInfo
920	new FieldInfo
921	new Index,Part
922	new DummyOut
923
924	new OutVarP set OutVarP=$get(Params(cOutput),cNull)
925	;"if (OutVarP=cNull) goto DFUTDone
926	if (OutVarP=cNull) do
927	. set OutVarP="DummyOut"
928
929	kill @OutVarP ;"--ensure old variables in output variable are removed.
930	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Output variable=",OutVarP)
931
932	new RecNum set RecNum=$get(Params(cRecNum))
933	set @OutVarP@(cRecNum)=RecNum
934	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNum=",RecNum)
935
936	new Fn set Fn=$get(Params(cFn),cInfo)
937	set Fn=$$UP^XLFSTR(Fn)
938	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Action Fn=",Fn)
939
940	new Value set Value=$get(Params(cValue))
941	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Value=",Value)
942
943	new FileN set FileN=$get(Params("FILE"))
944
945	new SpliceArray
946	if FileN[cNodeDiv do ;"Parse 'NEW PERSON\|ALIAS\|TITLE' into 'NEW PERSON', 'ALIAS', 'TITLE'
947	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Multiple nodes found for file name. Processing...")
948	. do CleaveToArray^TMGSTUTL(FileN,cNodeDiv,.SpliceArray)
949	. set FileN=$get(SpliceArray(1))
950	set Data(0,"FILE")=FileN
951	set result=$$SetupFileNum(.Data) if result=cAbort goto DFUTDone
952	new FileNum set FileNum=$get(Data(0,"FILE"),cNull)
953	set @OutVarP@("FILE")=FileNum
954	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNum=",FileNum)
955
956	new index set index=2
957	new GlobalP set GlobalP=$name(@OutVarP@("FILE"))
958	if $data(SpliceArray(index)) do
959	. for index=index:1 do quit:index=""
960	. . set FileN=SpliceArray(index)
961	. . set FileNum=$$GetSubFileNumber(FileNum,FileN)
962	. . if +FileNum'=0 set @GlobalP@("FILE")=FileNum
963	. . set GlobalP=$name(@GlobalP@("FILE"))
964	. . set index=$order(SpliceArray(index))
965
966	new GlobalP set GlobalP=$get(Data(0,"FILE",cGlobal),cNull)
967	if (FileNum=cNull),(GlobalP=cNull) goto DFUTDone
968	set @OutVarP@(cGlobal)=GlobalP
969	set @OutVarP@(cGlobal,cOpen)=$get(Data(0,"FILE",cGlobal,cOpen))
970
971	;"If we've gotten this far, will consider the function a success
972	set result=cOKToCont
973	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Setting fn result to success")
974
975	new FieldN set FieldN=$get(Params(cField))
976	new FieldNum
977	if (+FieldN=0)&(FieldN'="") do
978	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldN=",FieldN)
979	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNum=",FileNum)
980	. set FieldNum=$$GetNumField(FileNum,FieldN)
981	else do
982	. if FieldN
983	. set FieldNum=FieldN
984	set @OutVarP@(cField)=FieldNum
985	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum=",FieldNum)
986
987	if $data(@GlobalP@(0))=0 goto DFUTDone
988	new NumRecs set NumRecs=$piece(@GlobalP@(0),"^",4)
989	new LastRec set LastRec=$piece(@GlobalP@(0),"^",3)
990	set @OutVarP@(cNumRecs)=NumRecs
991	set @OutVarP@(cLastRec)=LastRec
992	new RecI set RecI=LastRec
993	new PrevRec
994	for do quit:(RecI="")!(RecI=0) ;"Scan backwards to find first record
995	. set PrevRec=$order(@GlobalP@(RecI),-1)
996	. ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"PrevRec=",PrevRec," RecI=",RecI)
997	. if (PrevRec="")!(PrevRec=0) do
998	. . set @OutVarP@(cFirstRec)=RecI
999	. set RecI=PrevRec
1000
1001	if FieldNum="" do goto DFUTDone
1002	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No field name specified")
1003	. if (Fn=cDelete)&(RecNum'="") do
1004	. . set DIK=$get(Data(0,"FILE",cGlobal,cOpen))
1005	. . set DA=RecNum
1006	. . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Deleting one record (number: ",RecNum,") from File number",FileNum)
1007	. . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Notice: deleting record does not clear any pointers to deleted records")
1008	. . do ^DIK
1009
1010	;"Get info from data dictionary r.e. where actual fields are stored in files.
1011	set DDInfo=$get(^DD(FileNum,FieldNum,0))
1012	if '$data(DDInfo) goto HWDone
1013	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"DDInfo=",DDInfo)
1014	set FieldInfo=$piece(DDInfo,"^",4)
1015	if '$data(FieldInfo),(FieldInfo="") goto DFUTDone
1016	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldInfo=",FieldInfo)
1017	set Index=$piece(FieldInfo,";",1)
1018	set Part=$piece(FieldInfo,";",2)
1019
1020	if RecNum="" goto DFUTDone
1021	if $data(@GlobalP@(RecNum,Index))=0 goto DFUTDone
1022
1023	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"I think the correct data place is: ",GlobalP,"(",RecNum,",",Index,") at piece: ",Part)
1024	new Temp set Temp=@GlobalP@(RecNum,Index)
1025	set @OutVarP@(cValue)=$piece(Temp,"^",Part)
1026	kill Temp
1027	set @OutVarP@(cNextRec)=$order(@GlobalP@(RecNum))
1028	set @OutVarP@(cPrev)=$order(@GlobalP@(RecNum),-1)
1029
1030	if Fn=cDelete do
1031	. set $piece(@GlobalP@(RecNum,Index),"^",Part)=""
1032
1033	if Fn=cSet do
1034	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Performing a hack write. CAUTION!")
1035	. set $piece(@GlobalP@(RecNum,Index),"^",Part)=Value
1036
1037	set result=cOKToCont
1038
1039	DFUTDone
1040	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Fn result=",result)
1041	if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"DoFileUtility^TMGDBAPI")
1042	quit result
1043
1044
1045
1046	AddRec(Data)
1047	;"Purpose: Use info from data array to create a MINIMAL new record in database
1048	;" This record will have only it's .01 field, and any multiple
1049	;" subfiles will have only their .01 fields also.
1050	;"Input: Data - Data array should be in format output from GetRInfo
1051	;"Output: data base will be modified by adding record
1052	;"Assumption: That a matching record does not already exist in database
1053	;"Returns: RecNum of added record, or 0 if error (0=abort)
1054
1055	;"NOTE!!! -- As I review this code, does it really return record number added???
1056
1057	if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
1058	new cOKToCont set cOKToCont=1
1059	new cAbort set cAbort=0
1060	new cParentIENS set cParentIENS="ParentIENS"
1061
1062
1063	new tmgFDA,TMGFDA ;"Fileman Data Array
1064	new IENS ;"Internal Entry Number String
1065	new RecNum ;"Internal number entry array
1066	new Flags
1067	new TMGMsg
1068	new FileNum
1069	new result set result=cAbort
1070	new FDAIndex
1071	new MarkerArray
1072	new MsgArray
1073
1074	if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"AddRec^TMGDBAPI")
1075
1076	set IENS=$get(Data(0,cParentIENS))
1077
1078	new MarkNum set MarkNum=0
1079	set result=$$SetupFDA(.Data,.tmgFDA,IENS,"+",.MarkNum,.MsgArray)
1080	if result=cAbort goto SkRDone
1081	set FileNum=$get(Data(0,"FILE"),0)
1082	if FileNum=0 set result=cAbort goto SkRDone
1083
1084	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master MsgArray")
1085	if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("MsgArray")
1086
1087	if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master tmgFDA")
1088	if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("tmgFDA") ;"zwr tmgFDA(*)
1089
1090	set FDAIndex=FileNum
1091	for do quit:(FDAIndex="")!(result=cAbort)
1092	. kill TMGFDA
1093	. merge TMGFDA(FDAIndex)=tmgFDA(FDAIndex)
1094	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Starting cycle with "_FDAIndex_" part.")
1095	. ;
1096	. set Flags="E" ;"E=External format values
1097	. ;
1098	. set result=$$ConvertFDA(.TMGFDA,.MarkerArray)
1099	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"AFTER CONVERSION, Here is the FDA to pass to UPDATE^DIE")
1100	. if TMGDEBUG do ArrayDump^TMGDEBUG("TMGFDA") ;"zwr TMGFDA(*)
1101	. ;
1102	. ;"======================================================
1103	. ;"Call UPDATE^DIE
1104	. ;"======================================================
1105	. if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"TMGDBAPI::UPDATE^DIE")
1106	. if $data(TMGFDA)'=0 do
1107	. . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Flags=",Flags)
1108	. . new $etrap set $etrap="do ErrTrp^TMGDBAPI"
1109	. . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Remember, UPDATE^DIE adds new entries in files or subfiles.")
1110	. . set ^TMP("TMG",$J,"ErrorTrap")=result
1111	. . set ^TMP("TMG",$J,"Caller")="UPDATE^DIE"
1112	. . do UPDATE^DIE(Flags,"TMGFDA","RecNum","TMGMsg")
1113	. . set result=^TMP("TMG",$J,"ErrorTrap")
1114	. . kill ^TMP("TMG",$J,"ErrorTrap")
1115	. . kill ^TMP("TMG",$J,"Caller")
1116	. if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::UPDATE^DIE")
1117	. ;"======================================================
1118	. ;"======================================================
1119	. ;
1120	. if $data(RecNum) do
1121	. . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is RecNum array after update/filing")
1122	. . if TMGDEBUG do ArrayDump^TMGDEBUG("RecNum") ;"zwr RecNum(*)
1123	. . merge MarkerArray=RecNum
1124	. . if result=cAbort do
1125	. . . new index
1126	. . . set index=$order(RecNum(""))
1127	. . . set result=$get(RecNum(index))
1128	. . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Output Record#=",result)
1129	. else do
1130	. . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After update/filing, RecNum array is empty!")
1131	. ;
1132	. if $data(TMGMsg("DIERR")) do quit
1133	. . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound)
1134	. . if $data(RecNum(1)) do
1135	. . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Trying to ignore error")
1136	. . . set PriorErrorFound=0
1137	. . else do
1138	. . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Unable to ignore error")
1139	. . . set result=cAbort
1140	. do
1141	. . new tI set tI=FDAIndex
1142	. . set FDAIndex=$order(tmgFDA(FDAIndex))
1143	. . kill tmgFDA(tI)
1144
1145	if result=cAbort do goto SkRDone
1146	. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Error encountered, dropping out.")
1147
1148	set result=$$HandleHacksArray(.MsgArray)
1149
1150	if result=cAbort goto SkRDone
1151
1152	SkRDone
1153	if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"AddRec^TMGDBAPI")
1154	quit result
1155
1156
1157
1158	;"=========================================================
1159	;" Error trap routine
1160	;"=========================================================
1161	ErrTrp
1162	new cAbort set cAbort=0
1163	set $etrap="",$ecode=""
1164	new Caller
1165	set Caller=$get(^TMP("TMG",$J,"Caller"),"?")
1166	do ShowError^TMGDEBUG(.PriorErrorFound,"Error trapped. Caller was: ",Caller)
1167	if $data(TMGMsg) do ShowDIERR^TMGDEBUG(TMGMsg)
1168	set ^TMP("TMG",$J,"ErrorTrap")=cAbort
1169	quit
1170	;"=========================================================
1171	;" End of Error trap routine
1172	;"=========================================================
1173
1174	;"========================================================
1175	;"The following routines were moved to shorten module length
1176
1177	ConvertFDA(FDA,MarkerArray)
1178	goto ConvertFDA+1^TMGDBAP2
1179
1180	ConvertIENS(IENS,MarkerArray)
1181	goto ConvertIENS+1^TMGDBAP2
1182
1183	SetupFDA(Data,FDA,parentIENS,SrchType,MarkNum,MsgArray,Minimal,RecNum)
1184	goto SetupFDA+1^TMGDBAP2
1185
1186	OverwriteRec(RecNum,Data)
1187	goto OverwriteRec+1^TMGDBAP2
1188
1189	GetFileNum(FileName)
1190	goto GetFileNum+1^TMGDBAP2
1191
1192	GetFName(FileNumber)
1193	goto GetFName+1^TMGDBAP2
1194
1195	GetFldName(File,FieldNumber)
1196	goto GetFldName+1^TMGDBAP2
1197
1198	GetFldList(File,pArray)
1199	goto GetFldList+1^TMGDBAP2
1200
1201	SetupFileNum(Data)
1202	goto SetupFileNum+1^TMGDBAP2
1203
1204	RecFind(Params)
1205	goto RecFind+1^TMGDBAP2
1206
1207	FieldCompare(TestField,dbField,Type)
1208	goto FieldCompare+1^TMGDBAP2
1209
1210	EnsureWrite(File,Field,IENS,Value,Flags,MsgArray)
1211	goto EnsureWrite+1^TMGDBAP2
1212
1213	dbWrite(FDA,Overwrite,TMGIEN,Flags,ErrArray)
1214	goto dbWrite+1^TMGDBAP2
1215
1216	DelIEN(File,RecNumIEN,ErrArray)
1217	goto DelIEN+1^TMGDBAP2
1218
1219	WriteWP(File,RecNumIEN,Field,TMGArray)
1220	goto WriteWP+1^TMGDBAP2
1221
1222	ReadWP(File,IENS,Field,Array)
1223	goto ReadWP+1^TMGDBAP2
1224
1225	ShowIfError(TMGMsg,PriorErrorFound)
1226	goto ShowIfError+1^TMGDBAP2
1227
1228	DataImport(Info,ProgressFN)
1229	goto DataImport+1^TMGDBAP2
1230
1231	Set1(File,IEN,Field,Value,Flag)
1232	goto Set1+1^TMGDBAP2
1233
1234	GetValidInput(File,Field)
1235	goto GetValidInput+1^TMGDBAP2
1236
1237	AskFIENS()
1238	goto AskFIENS+1^TMGDBAP2
1239
1240	ASKSCRN
1241	goto ASKSCRN+1^TMGDBAP2
1242
1243	AskIENS(FileNum,IENS)
1244	goto AskIENS+1^TMGDBAP2
1245
1246	GetRefArray(FileNum,array)
1247	goto GetRefArray+1^TMGDBAP2
1248
1249	FIENS2Root(FIENS)
1250	goto FIENS2Root+1^TMGDBAP2
1251
1252	GetRef(file,IENS,field)
1253	goto GetRef+1^TMGDBAP2
1254
1255	TrimFDA(FDA,Quiet)
1256	goto TrimFDA+1^TMGDBAP2
1257
1258	GetPtrsOUT(File,Info)
1259	goto GetPtrsOUT+1^TMGDBAP2
1260

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format