source: cprs/branches/tmg-cprs/m_files/TMGDBAPI.m@ 1035

Last change on this file since 1035 was 796, checked in by Kevin Toppenberg, 14 years ago

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