source: cprs/branches/tmg-cprs/m_files/TMGDBAP2.m@ 1797

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

Initial upload
File size: 64.3 KB
RevLine 
[796]1TMGDBAP2 ;TMG/kst/Database API library 2 ;03/25/06; 5/2/10
2 ;;1.0;TMG-LIB;**1**;07/12/05
3
4
5 ;"This module holds moved functions from TMGDBAPI (moved due to size constraints)
6
7ConvertFDA(FDA,MarkerArray)
8 ;"Purpose: To convert all the IENS's in a FDA via ConvertIENS
9 ;"Input: FDA -- An FDA that need conversion. MUST PASS BY REFERENCE
10 ;" Expected FDA is as follows. I.e., expecting that
11 ;" there will only be ONE filenumber (the 19.01) part:
12 ;" FDA(*)
13 ;" }~19.01
14 ;" }~?+4,?+2,
15 ;" | }~.01 = DIUSER
16 ;" | }~2 = FM2
17 ;" | }~3 = 1
18 ;" |
19 ;" }~?+5,?+2,
20 ;" | }~.01 = XMMGR
21 ;" | }~2 = X2
22 ;" | }~3 = 1
23 ;" |
24 ;" }~?+6,?+2,
25 ;" }~.01 = DIEDIT
26 ;" }~2 = Edit
27 ;" }~3 = 2
28 ;" MarkerArray -- see documentation in ConvertIENS
29 ;"Output: FDA is changed
30 ;"Result: 1=OKToContinue, 0=Abort
31
32
33 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
34 new cOKToCont set cOKToCont=1
35 new cAbort set cAbort=0
36 new cParentIENS set cParentIENS="ParentIENS"
37 new cRef set cRef="Ref"
38
39
40 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ConvertFDA^TMGDBAPI")
41
42 new result set result=1
43 if $data(FDA)=0 set result=0 goto CvFDAQ
44 new FileNum
45 new Index
46 new IENS,OldIENS
47
48 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the FDA to convert")
49 ;"if TMGDEBUG do ArrayDump^TMGDEBUG("FDA")
50 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the MarkerArray")
51 ;"if TMGDEBUG do ArrayDump^TMGDEBUG("MarkerArray")
52
53 set FileNum=$order(FDA(""))
54 if +FileNum=0 set result=0 goto CvFDAQ
55 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Looking at filenumber ",FileNum)
56 set IENS=$order(FDA(FileNum,""))
57 for do quit:(IENS="")
58 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IENS=",IENS)
59 . if IENS="" do quit
60 . . set result=0
61 . set OldIENS=IENS
62 . if $$ConvertIENS(.IENS,.MarkerArray)=0 do quit
63 . . set IENS=""
64 . . set result=0
65 . if IENS'=OldIENS do
66 . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Converted to IENS=",IENS)
67 . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Convert FDA(FileNumber,"""_OldIENS_""") to FDA(Filenumber,"""_IENS_""")")
68 . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"$data(FDA(FileNum,OLDIENS))=",$data(FDA(FileNum,OldIENS)))
69 . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is FDA so far")
70 . . ;"if TMGDEBUG do ArrayDump^TMGDEBUG("FDA")
71 . . merge FDA(FileNum,IENS)=FDA(FileNum,OldIENS)
72 . . set IENS=$order(FDA(FileNum,OldIENS))
73 . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"killing FDA(FileNumber,"_OldIENS_")")
74 . . kill FDA(FileNum,OldIENS)
75 . else do
76 . . set IENS=$order(FDA(FileNum,OldIENS))
77 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Resulting FDA so far")
78 . ;"if TMGDEBUG do ArrayDump^TMGDEBUG("FDA")
79 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"-----------------------")
80 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"End of cycle. IENS=",IENS)
81 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"-----------------------")
82
83 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After conversion, here is the FDA.")
84 ;"if TMGDEBUG do ArrayDump^TMGDEBUG("FDA")
85
86CvFDAQ
87 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"ConvertFDA^TMGDBAPI")
88 quit result
89
90
91ConvertIENS(IENS,MarkerArray)
92 ;"Purpose: to convert an IENS such as "?+4,?+2," into "?+4,12345,", given
93 ;" the MarkerArray that corelates "2" to #"12345"
94 ;"Input: IENS -- the IENS string to convert. MUST PASS BY REFERENCE
95 ;" MarkerArray -- a composite array composed of results returned
96 ;" by database server, like below. SHOULD PASS BY REFERENCE
97 ;" MarkerArray(*)
98 ;" }~2 = 10033
99 ;" }~0 = +
100 ;" }~4 = 12345
101 ;" }~0 = +
102 ;"Output: IENS will be changed
103 ;"Result: 1=OkToContinue, 0=Abort
104
105 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
106 new cOKToCont set cOKToCont=1
107 new cAbort set cAbort=0
108 new cParentIENS set cParentIENS="ParentIENS"
109
110 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ConvertIENS^TMGDBAPI")
111
112 new result set result=1
113 new S set S=""
114
115 if $data(IENS)#10=0 set result=0 goto CvIENSQ
116 if $data(MarkerArray)=0 set result=0 goto CvIENSQ
117
118 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Initial IENS=",IENS)
119
120 new I set I=1
121 for do quit:(I=-1)
122 . new Part,RecMarker
123 . set Part=$piece(IENS,",",I)
124 . ;";"if $get(TMGDEBUG)>0 do DebugWrite^TMGDEBUG(.DBIndent,"Part="_Part_" --> ",0)
125 . if Part="" set I=-1 quit
126 . set RecMarker=+$translate(Part,"?+","")
127 . ;"if $get(TMGDEBUG)>0 do DebugWrite^TMGDEBUG(.DBIndent,"RecMarker="_RecMarker_" --> ",0)
128 . new tS set tS=$get(MarkerArray(RecMarker),Part)
129 . ;"if $get(TMGDEBUG)>0 do DebugWrite^TMGDEBUG(.DBIndent,"tS="_tS,1)
130 . set S=S_tS_","
131 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"S so far=",S)
132 . set I=I+1
133
134 set IENS=S
135
136CvIENSQ
137 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"ConvertIENS^TMGDBAPI")
138 quit result
139
140
141SetupFDA(Data,FDA,parentIENS,SrchType,MarkNum,MsgArray,Minimal,RecNum)
142 ;"Purpose: to transfer from Data format to FDA format
143 ;"Input: Data - Data array should be in format output from GetRInfo
144 ;" FDA -- SHOULD BE PASSED BY REFERENCE (to receive results)
145 ;" parentIENS -- initial IENS.. the IENS of any PARENT record, or "" if no parent record
146 ;" SrchType -- should be "?", "+", or "?+"
147 ;" MarkNum -- -- SHOULD BE PASSED BY REFERENCE. A variable to ensure
148 ;" "?X" search term always has unique number. On first call, should=0
149 ;" MsgArray -- SHOULD BE PASSED BY REFERENCE. An array that can accept
150 ;" messages back from function.
151 ;" -- One such type of message is a list of needed hackwrites.
152 ;" Format as follows:
153 ;" MsgArray(cHack,0,Entries)=2
154 ;" MsgArray(cHack,1)="^VA(;200;?+1;.01;SomeData"
155 ;" MsgArray(cHack,1,cFlags)="H"
156 ;" MsgArray(cHack,2)="^VA(;200;?+1;.02;SomeMoreData"
157 ;" MsgArray(cHack,2,cFlags)="H"
158 ;" i.e. MsgArray(cHack,0,Entries)=Number of Entries
159 ;" MsgArray(cHack,n) = Global;FileNumber;IENS;FieldNum;Data
160 ;" MsgArray(n,cFlags)=User specified Flags for field.
161 ;" -- MsgArray(cRef,SubFileNumber)=Reference to Part of Data that created this.
162 ;" MsgArray(*)
163 ;" }~cRef
164 ;" }~1234.21 = "Data(6,".07")
165 ;" }~1234.2101 = "Data(6,".07",2,".04")
166 ;" Minimal -- OPTIONAL. 1=fill only .01 fields and subfile .01 fields
167 ;" RecNum -- OPTIONAL. If FDA is to be setup such that data is put into
168 ;" a specified record number, put that number here.
169 ;" !!! Note: I believe this is used erroneously here. A record number
170 ;" is not specified in the FDA. For calls to UPDATE^DIE to a specific
171 ;" record number, the FDA should have an IENS that is like "+1,", and then
172 ;" put the desired record number into the IEN_ROOT, like TMGIEN(1)=1234
173 ;" with the "1" matching the "1" in TMGIEN(1)
174 ;"Output: FDA is changed if passed by reference.
175 ;"Returns: If should continue execution: 1=OK to continue. 0=abort.
176
177 ;"Note: input Data array will be formated like this:
178 ;" Data(0,cFile)="1234.1" <-- "NEW PERSON" Note conversion
179 ;" Data(0,cFile,cGlobal)="^DIC(200)" <-- note, NOT "^DIC(200,"
180 ;" Data(0,cRecNum)=2 <-- only if user-specified.
181 ;" Data(0,cEntries)=1
182 ;" Data(1,".01")="MyData1"
183 ;" Data(1,".01",cMatchValue)="MyData1"
184 ;" Data(1,".02")="Bill"
185 ;" Data(1,".02",cMatchValue)="John"
186 ;" Data(1,".03")="MyData3"
187 ;" Data(1,".04")="MyData4"
188 ;" Data(1,".06")="MyData5" <-- note "NAME" was converted to ".06"
189 ;" Data(1,".07",0,cEntries)=2 <-- "ITEM" converted to ".07"
190 ;" Data(1,".07",1,".01")="SubEntry1"
191 ;" Data(1,".07",1,".02")="SE1"
192 ;" Data(1,".07",1,".03")="'Some Info'"
193 ;" Data(1,".07",2,".01")="SubEntry2"
194 ;" Data(1,".07",2,".02")="SE2"
195 ;" Data(1,".07",2,".04",0,cEntries)=1 ;"TEXT converted to .04
196 ;" Data(1,".07",2,".04",1,".01")="JD"
197 ;" Data(1,".07",2,".04",1,".02")="DOE,JOHN"
198 ;" ADDENDUM
199 ;" Data(1,".01",cFlags)=any flags specified for given field.
200 ;" only present if user specified.
201
202 ;"Resulting FDA will look like this.
203 ;" i.e. FDA(1234,"?+1,10024,",.01)="MyData1"
204 ;" i.e. FDA(1234,"?+1,10024,",.02)="Bill"
205 ;" i.e. FDA(1234,"?+1,10024,",.03)="MyData3"
206 ;" i.e. FDA(1234,"?+1,10024,",.04)="MyData4"
207 ;" i.e. FDA(1234,"?+1,10024,",.06)="MyData5"
208 ;" i.e. FDA(1234.21,"?+2,?+1,10024,",.01)="SubEntry1"
209 ;" i.e. FDA(1234.21,"?+2,?+1,10024,",.02)="SE1"
210 ;" i.e. FDA(1234.21,"?+2,?+1,10024,",.03)="'Some Info'"
211 ;" i.e. FDA(1234.21,"?+3,?+1,10024,",.01)="SubEntry2"
212 ;" i.e. FDA(1234.21,"?+3,?+1,10024,",.02)="SE2"
213 ;" i.e. FDA(1234.21,"?+3,?+1,10024,",.03)="'Some Info'"
214 ;" i.e. FDA(1234.2101,"?+4,?+3,?+1,10024,",.01)="JD"
215 ;" i.e. FDA(1234.2101,"?+4,?+3,?+1,10024,",.02)="DOE,JOHN"
216 ;"(OR... reformat of above)
217 ;" FDA(*)
218 ;" }~1234
219 ;" }~?+1,10024
220 ;" }~.01 = MyData1
221 ;" }~.02 = Bill
222 ;" }~.03 = MyData3
223 ;" }~.04 = MyData4
224 ;" }~.06 = MyData5
225 ;" }~1234.21
226 ;" }~?+2,?+1,10024
227 ;" }~.01 = SubEntry1
228 ;" }~.02 = SE1
229 ;" }~.03 = 'Some Info'
230 ;" }~?+3,?+1,10024
231 ;" }~.01 = SubEntry2
232 ;" }~.02 = SE2
233 ;" }~.03 = 'Some Info'
234 ;" }~1234.2101
235 ;" }~?+4,?+3,?+1,10024
236 ;" }~.01 = JD
237 ;" }~.02 = DOE,JOHN
238
239 ;"MsgArray will hold the following
240 ;" MsgArray(*)
241 ;" }~"H"
242 ;" }~"Ref"
243 ;" }~1234.21 = "Data(6,".07")
244 ;" }~1234.2101 = "Data(6,".07",2,".04")
245
246 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
247 new cOKToCont set cOKToCont=1
248 new cAbort set cAbort=0
249 new cFile set cFile="FILE" ;"File"
250 new cHack set cHack="H"
251 new cFlags set cFlags="FLAGS" ;"Flags"
252 new cEntries set cEntries="Entries"
253 new cNoOverwrite set cNoOverwrite="N"
254
255 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SetupFDA^TMGDBAPI")
256
257 new result set result=cOKToCont
258 new index
259 new FieldNum
260 new FileNumber
261 new SubMarkNum set SubMarkNum=0
262 new IENS set IENS=""
263 if $get(RecNum)="" kill RecNum
264
265 set FileNumber=$get(Data(0,cFile))
266 if +FileNumber=0 goto SFDAQ
267 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNumber=",FileNumber)
268 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"parentIENS=",parentIENS)
269 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"SrchType=",SrchType)
270 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNum=",$get(RecNum))
271 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the Data array to work with:")
272 ;"if TMGDEBUG do ArrayDump^TMGDEBUG("Data")
273
274 set index=$order(Data(0))
275 ;"Cycle through all entries (i.e. 1, 2, 3)
276 for do quit:(index="")!(result=cAbort)
277 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"index=",index)
278 . set FieldNum=$order(Data(index,""))
279 . ;"Cycle through all fields (i.e. .01, .02, ,1223)
280 . for do quit:(FieldNum="")!(result=cAbort)
281 . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum=",FieldNum)
282 . . new NextFieldNum set NextFieldNum=$order(Data(index,FieldNum))
283 . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"NextFieldNum=",NextFieldNum)
284 . . if ($get(Data(index,FieldNum,cFlags))[cNoOverwrite)&(SrchType["?") do quit
285 . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"m0")
286 . . . set FieldNum=NextFieldNum
287 . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"NoOverwrite flag found, ignoring current field.")
288 . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"m1")
289 . . if (FieldNum=.01)!(IENS="") do
290 . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"m2")
291 . . . if $data(RecNum)#10=0 do
292 . . . . set MarkNum=+$get(MarkNum)+1
293 . . . . set IENS=SrchType_MarkNum_","_$get(parentIENS)
294 . . . else do
295 . . . . set IENS=$get(RecNum)_","_$get(parentIENS)
296 . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IENS=",IENS)
297 . . if $get(Data(index,FieldNum,cFlags))[cHack do ;"HACK PROCESSING
298 . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Hack Processing")
299 . . . ;"Load hacks into a message array for later processing
300 . . . new NumHacks set NumHacks=$get(MsgArray(cHack,0,cEntries))+1
301 . . . new Entry set Entry=Data(index,FieldNum)
302 . . . if $get(Data(index,FieldNum,cFlags))[cEncrypt do
303 . . . . set Entry=$$EN^XUSHSH(Entry) ;"encrypt data
304 . . . new Global set Global=$get(Data(0,cFile,cGlobal))
305 . . . if Global="" do quit
306 . . . . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to local global name for file")
307 . . . . set result=cAbort
308 . . . set MsgArray(cHack,NumHacks)=Global_";"_FileNumber_";"_IENS_";"_FieldNum_";"_Entry
309 . . . set MsgArray(cHack,NumHacks,cFlags)=Data(index,FieldNum,cFlags)
310 . . else if $data(Data(index,FieldNum,0,cEntries)) do ;"SUB-FILE PROCESSING
311 . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Sub-file processing")
312 . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Addition of subfile entries encountered.")
313 . . . new tempData merge tempData=Data(index,FieldNum)
314 . . . new SubFileNum set SubFileNum=$get(Data(index,FieldNum,0,cFile),0)
315 . . . set MsgArray(cRef,SubFileNum)=$name(Data(index,FieldNum))
316 . . . ;"call self recursively to handle subfile.
317 . . . new SubMarkNum set SubMarkNum=MarkNum
318 . . . set result=$$SetupFDA(.tempData,.FDA,IENS,SrchType,.SubMarkNum,.MsgArray,.Minimal)
319 . . . if SubMarkNum>MarkNum set MarkNum=SubMarkNum
320 . . else do ;"THE-USUAL-CASE PROCESSING
321 . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Processing usual case")
322 . . . if (FieldNum=.01)!($get(Minimal)'=1) do
323 . . . . new ts set ts="Setting: FDA("_FileNumber_","""_IENS_""","_FieldNum_")="_$get(Data(index,FieldNum))
324 . . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"ts=",ts)
325 . . . . set FDA(FileNumber,IENS,FieldNum)=$get(Data(index,FieldNum))
326 . . . if $data(Data(index,FieldNum,"WP")) do
327 . . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Detected word-processor field")
328 . . . . merge FDA(FileNumber,IENS,FieldNum,"WP")=Data(index,FieldNum,"WP")
329 . . . . ;"if $get(TMGDEBUG)>0 do
330 . . . . ;". new ts set ts="Setting: FDA("_FileNumber_","""_IENS_""","_FieldNum_")="
331 . . . . ;". ;"NOTE: the "TMGFDA" MUST!! match the FDA name passed to UPDATE^DIE, FILE^DIE
332 . . . . ;". set ts=ts_$name(TMGFDA(FileNumber,IENS,FieldNum,"WP"))
333 . . . . ;". do DebugMsg^TMGDEBUG(.DBIndent,ts)
334 . . . . ;"NOTE: the "TMGFDA" MUST!! match the FDA name passed to UPDATE^DIE, FILE^DIE
335 . . . . set FDA(FileNumber,IENS,FieldNum)=$name(TMGFDA(FileNumber,IENS,FieldNum,"WP"))
336 . . set FieldNum=NextFieldNum
337 . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"End of field loop")
338 . set index=$order(Data(index))
339 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"End of index loop")
340
341SFDAQ
342 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is resulting FDA")
343 ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("FDA") ;"zwr FDA(*)
344
345 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SetupFDA^TMGDBAPI")
346 quit result
347
348
349
350OverwriteRec(RecNum,Data)
351 ;"Purpose: To stuff data from data array into record specified by RecNum.
352 ;" This function will not directly put any data into subfiles, but will
353 ;" call UploadData to handle this.
354 ;"Input: RecNum -- the record number (as returned by GetRecMatch) to put data into
355 ;" Data - Should be in format output from GetRInfo
356 ;"Output: database will be modified by changing record
357 ;"Returns: If should continue execution: 1=OK to continue. 0=abort.
358
359 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
360 if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1
361 if $data(cAbort)#10=0 new cAbort set cAbort=0
362 new cParentIENS set cParentIENS="ParentIENS"
363
364 new result set result=cOKToCont
365 new Flags
366 new FileNumber,FieldNum,SubFileNum
367 new FieldFlags
368 new tmgFDA,TMGFDA,TMGMsg
369 new index
370 new IENS set IENS=$get(Data(0,cParentIENS))
371 new FDAIndex
372 new MarkerArray
373 new MsgArray
374
375 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"OverwriteRec^TMGDBAPI")
376 if $get(RecNum)=0 set result=cAbort goto OWQuit
377
378 set FileNumber=Data(0,cFile)
379 set Flags="KE" ;"E=External format values; K=Func locks file during use.
380
381 set IENS=$get(Data(0,cParentIENS))
382
383 new MarkNum set MarkNum=0
384 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNum=",RecNum)
385
386 ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Data")
387
388 set result=$$SetupFDA(.Data,.tmgFDA,IENS,"?",.MarkNum,.MsgArray,0,RecNum)
389 if result=cAbort goto OWQuit
390 set FileNum=$get(Data(0,cFile),0) if FileNum=0 set result=cAbort goto OWQuit
391
392 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master MsgArray")
393 ;"if TMGDEBUG do ArrayDump^TMGDEBUG("MsgArray")
394
395 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master tmgFDA")
396 ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("tmgFDA") ;"zwr tmgFDA(*)
397
398 if $data(tmgFDA)=0 do goto OWPast ;"This can happen with single records with NoOverwrite flag
399 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No data to file with fileman, so skipping.")
400
401 set FDAIndex=FileNum
402 kill TMGFDA
403 merge TMGFDA(FDAIndex)=tmgFDA(FDAIndex)
404 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Processing "_FDAIndex_" part of tmgFDA")
405 ;
406 set Flags="E" ;"E=External format values
407 ;
408 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the TMGFDA to pass to FILE^DIE")
409 ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGFDA") ;"zwr TMGFDA(*)
410 ;
411 ;"======================================================
412 ;"Call FILE^DIE
413 ;"======================================================
414 if $data(TMGFDA)=0 set result=cAbort quit
415 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"TMGDBAPI::FILE^DIE")
416 do
417 . new $etrap set $etrap="do ErrTrp^TMGDBAPI"
418 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Remember, FILE^DIE is for working with records that already exist.")
419 . set ^TMP("TMG",$J,"ErrorTrap")=result
420 . set ^TMP("TMG",$J,"Caller")="FILE^DIE"
421 . do FILE^DIE(Flags,"TMGFDA","TMGMsg")
422 . set result=^TMP("TMG",$J,"ErrorTrap")
423 . kill ^TMP("TMG",$J,"ErrorTrap")
424 . kill ^TMP("TMG",$J,"Caller")
425 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::FILE^DIE")
426 ;"======================================================
427 ;"======================================================
428 ;"
429 if $data(TMGMsg("DIERR")) do goto OWQuit
430 . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound)
431 . set result=cAbort
432
433 if result=cAbort goto OWQuit
434
435 kill tmgFDA(FDAIndex)
436 set FDAIndex="" ;"I don't want to loop through rest of tmgFDA, will handle below.
437
438OWPast
439 set result=$$HandleHacksArray^TMGDBAPI(.MsgArray)
440 if result=cAbort do ShowError^TMGDEBUG(.PriorErrorFound,"Error in writing record") goto OWQuit
441
442 ;"Now we handle possible subfile entries. Info regarding these is in MsgArray
443 if $data(MsgArray(cRef))'=0 do
444 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Handling subfile entries.")
445 . set SubFileNum=$order(MsgArray(cRef,""))
446 . for do quit:(+SubFileNum=0)!(result=cAbort)
447 . . if +SubFileNum=0 quit
448 . . new SubData,DataP
449 . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"SubFileNum="_SubFileNum)
450 . . set DataP=MsgArray(cRef,SubFileNum)
451 . . merge SubData=@DataP
452 . . set SubData(0,cParentIENS)=RecNum_","_IENS
453 . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Sub IENS="_RecNum_","_IENS)
454 . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"DataP="_DataP)
455 . . set result=$$UploadData^TMGDBAPI(.SubData)
456 . . set SubFileNum=$order(MsgArray(cRef,SubFileNum))
457
458OWQuit
459 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"OverwriteRec^TMGDBAPI")
460 quit result
461
462
463GetFileNum(FileName)
464 ;"Purpose: Convert a file name into a file number
465 ;"Input: The name of a file
466 ;"Result: The filenumber, or 0 if not found.
467
468 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetFileNum^TMGDBAPI")
469 new result set result=0
470
471 if $get(FileName)="" goto GtFlNumDone
472
473 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"File Name='"_FileName_"'")
474
475 if FileName=" " do goto GtFlNumDone
476 . do ShowError^TMGDEBUG(.PriorErrorFound,"No file specifier (either name or number) given!")
477 . set result=0
478
479 set DIC=1 ;"File 1=Global file reference (the file listing info for all files)
480 set DIC(0)="M"
481 set X=FileName ;"i.e. "AGENCY"
482 do ^DIC ;"lookup filename Result comes back in Y ... i.e. "4.11^AGENCY"
483 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"lookup for filename '"_FileName_"' ==> "_Y)
484 set result=$piece(Y,"^",1)
485 if result=-1 set result=0
486
487GtFlNumDone
488 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetFileNum^TMGDBAPI")
489 quit result
490
491
492GetFName(FileNumber)
493 ;"Purpose: Convert a file number into a file name
494 ;"Input: The number of a file
495 ;"Result: The file name, or "" if not found.
496
497 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetFileName^TMGDBAPI")
498 new result set result=""
499
500 if $get(FileNumber)=0 goto GtFlNumDone
501
502 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"File Number='"_FileNumber_"'")
503
504 set result=$get(^DIC(FileNumber,0))
505 if (result="")&(FileNumber[".") do
506 . set result=$get(^DD(FileNumber,0))
507 set result=$piece(result,"^",1)
508
509GtFNmDone
510 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetFileName^TMGDBAPI")
511 quit result
512
513
514GetFldName(File,FieldNumber)
515 ;"Purpose: Convert a field number into a field name
516 ;"Input: File -- name or number of file
517 ;" FieldNumber -- the number of the field to convert
518 ;"Result: The field name, or "" if not found.
519
520 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetFldName^TMGDBAPI")
521 new result set result=""
522 new array
523 do GetFieldInfo^TMGDBAPI(.File,.FieldNumber,"array","LABEL")
524 set result=$get(array("LABEL"))
525
526GFldNmDone
527 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetFldName^TMGDBAPI")
528 quit result
529
530
531GetFldList(File,pArray)
532 ;"Purpose: Get list of all fields for a file.
533 ;"Input: File -- File name or number to look query. May be a sub file number
534 ;" pArray -- pointer to (i.e. name of) array to put data into
535 ;" Any preexisting data in pArray will be killed.
536 ;"Output: Array will be fille with info like this:
537 ;" example: Array(.01)=""<--- shows that field .01 exists
538 ;" Array(1)="" <--- shows that field 1 exists
539 ;" Array(2)="" <--- shows that field 2 exists
540 ;"Results: 1=OK to continue. 0=error
541
542 new result set result=1
543 new FileNumber,FileName
544 if ($get(File)="")!($get(pArray)="") set result=0 goto GFdLDone
545 kill @pArray
546
547 if +File=File do
548 . set FileNumber=File
549 . set FileName=$$GetFName(File)
550 else do
551 . set FileName=File
552 . set FileNumber=$$GetFileNum(File)
553 if FileNumber'>0 do goto GFdLDone
554 . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, "_File_", doesn't exist.")
555 . set result=0
556
557 new index set index=$order(^DD(FileNumber,0))
558 if +index>0 for do quit:(+index'>0)
559 . set @pArray@(index)=""
560 . set index=$order(^DD(FileNumber,index))
561
562GFdLDone
563 quit result
564
565
566SetupFileNum(Data)
567 ;"Purpose: To Ensure that Data(0,cFile) contains valid file number
568 ;"Input: Data-- should be passed by reference, Array setup by GetRInfo
569 ;" Specifically, Data(0,cFile) should have file name OR number
570 ;"Output: Data is changed:
571 ;" Data(0,cFile)=FileNumber
572 ;" Data(0,cFile,cGlobal)=Global reference name ;i.e. "^VA(200)"
573 ;" Data(0,cFile,cGlobal,cOpen)=Open Global reference name ;i.e. "^VA(200,"
574 ;"Returns: If should continue execution: 1=OK to continue. 0=abort.
575
576 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
577 new cOKToCont set cOKToCont=1
578 new cAbort set cAbort=0
579 new cFile set cFile="FILE" ;"File"
580 new cGlobal set cGlobal="GLOBAL"
581 new cOpen set cOpen="OPEN"
582
583 new result set result=cOKToCont
584 new FileNumber,FileName,File
585
586 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SetupFileNum^TMGDBAPI")
587
588 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is Data passed to SetupFileNum")
589 ;"if TMGDEBUG do ArrayDump^TMGDEBUG("Data") ;"zwr Data(*)
590
591 set File=$get(Data(0,cFile)," ")
592 if +File'=0 do goto CKFileNum
593 . set FileNumber=File
594 set FileName=File
595 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"File Name='"_FileName_"'")
596
597 if FileName=" " do goto SFNDone
598 . do ShowError^TMGDEBUG(.PriorErrorFound,"No file specifier (either name or number) given!")
599 . set result=cAbort ;"0=Abort
600
601 ;"Note: I could replace this code with GetFileNum(FileName)
602 ;"----------------
603 set DIC=1 ;"File 1=Global file reference (the file listing info for all files)
604 set DIC(0)="M"
605 set X=FileName ;"i.e. "AGENCY"
606 do ^DIC ;"lookup filename Result comes back in Y ... i.e. "4.11^AGENCY"
607 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"lookup for filename '"_FileName_"' ==> "_Y)
608 set FileNumber=$piece(Y,"^",1)
609 ;"----------------
610
611CKFileNum
612 set Data(0,cFile)=FileNumber
613 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Uploading to File number: "_FileNumber)
614 ;"if $data(FileName) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"('",FileName,"' file)")
615 if FileNumber=-1 do goto SFNDone
616 . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to locate file specified as #"_FileNumber_" or '"_FileName_"'.")
617 . set result=cAbort ;"0=Abort
618 if $$VFILE^DILFD(FileNumber)=0 do goto SFNDone
619 . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, #"_FileNumber_", doesn't exist.")
620 . set result=cAbort ;"0=Abort
621
622 set Global=$get(^DIC(FileNumber,0,"GL"),"INVALID") ;"^DIC is file 1/FILE
623 set Data(0,cFile,cGlobal,cOpen)=Global
624 ;"Convert global form of ^VA(200, into ^VA(200)
625 new Len
626 set Len=$length(Global)
627 if $extract(Global,Len)="," do
628 . set $extract(Global,Len)=")"
629 if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"The global file to access is: "_Global)
630 set Data(0,cFile,cGlobal)=Global
631
632SFNDone
633 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SetupFileNum^TMGDBAPI")
634
635 quit result
636
637
638
639RecFind(Params)
640 ;"Purpose: To look through a file and find matching record
641 ;"Input -- Params(cFile)=File name or number
642 ;" Params(FieldNumber)=LookupValue
643 ;" Params(FieldNumber)=LookupValue
644 ;"
645 ;" e.g. Params(0,cFile)="PERSON CLASS"
646 ;" Params(.01)="Physicians (M.D. and D.O.)"
647 ;" Params(1)="Physician/Osteopath"
648 ;" Params(2)="Family Practice"
649 ;"
650 ;"Note: Does not support searching based on subfile data.
651 ;"Output -- (via results)
652 ;"Result -- Returns record number file, OR 0 if not found
653
654 if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"RecFind^TMGDBAPI")
655
656 if $data(cFile)=0 new cFile set cFile="FILE"
657 if $data(cEntries)=0 new cEntries set cEntries="Entries"
658 if $data(cMatchValue)=0 new cMatchValue set cMatchValue="MATCHVALUE"
659 new result set result=0
660 new Data
661 new RecNum
662 new FieldNum
663
664 set Data(0,cFile)=$get(Params(0,cFile))
665 if Data(0,cFile)="" goto RFDone
666 if $$SetupFileNum(.Data)=0 goto RFDone
667 set Data(0,cEntries)=1
668
669 set FieldNum=$order(Params(0))
670 for do quit:(+FieldNum=0)
671 . if +FieldNum=0 quit
672 . set Data(1,FieldNum,cMatchValue)=$get(Params(FieldNum))
673 . set FieldNum=$order(Params(FieldNum))
674
675 if $$GetRecMatch^TMGDBAPI(.Data,.RecNum)=0 goto RFDone
676 set result=RecNum
677
678RFDone
679 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"RecFind^TMGDBAPI")
680 quit result
681
682
683
684FieldCompare(TestField,dbField,Type)
685 ;"PURPOSE: To compare two fields and return a comparison code
686 ;"INPUT: TestField -- User input to be tested (in "external format"). **Don't pass by Ref**
687 ;" dbField -- data from database to be tested. **Don't pass by Ref
688 ;" Type -- (Optional) The type of data being compared:
689 ;" "NORMAL" or "" -- Simple comparison carried out (i.e. 'if A=B')
690 ;" "DATE" -- the two values are date/time values
691 ;" "SSNUM"-- the two values are social security numbers
692 ;" "SEX" -- the two values are Sex descriptors.
693 ;" "NUMBER" -- the two values are numbers
694 ;"Results:
695 ;" return value = cConflict (0) if entries conflict
696 ;" i.e. TestField="John" vs dbField="Bill"
697 ;" return value = cFullMatch (1) if entries completely match
698 ;" ie. TestField="John" vs dbField="John"
699 ;" or TestField="" vs. dbField=""
700 ;" return value = cExtraInfo (2) if entries have no conflict, but TestField has extra info.
701 ;" i.e. TestField="John" vs. dbField=""
702 ;" return value = cdbExtraInfo (3) if entries have no conflict, but dbField has extra info.
703 ;" i.e. TestField="" vs. dbField="12345"
704
705 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"FieldCompare^TMGDBAPI")
706
707 if $data(cConflict)#10=0 new cConflict set cConflict=0
708 if $data(cFullMatch)#10=0 new cFullMatch set cFullMatch=1
709 if $data(cExtraInfo)#10=0 new cExtraInfo set cExtraInfo=2
710 if $data(cdbExtraInfo)#10=0 new cdbExtraInfo set cdbExtraInfo=3
711
712 set TestField=$get(TestField)
713 set dbField=$get(dbField)
714 set Type=$get(Type)
715
716 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TestField=",TestField)
717 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"dbField=",dbField)
718 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Type=",Type)
719
720 new result set result=cConflict
721
722 if Type="DATE" do
723 . set TestField=$$IDATE^TIULC(TestField)
724 . set dbField=$$IDATE^TIULC(dbField)
725 else if Type="SSNUM" do
726 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Processing SSNUM's")
727 . set TestField=$translate(TestField," /-","") ;"Clean delimiters
728 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TestField now=",TestField)
729 . if TestField["P" set TestField="P"
730 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TestField now=",TestField)
731 . if dbField["P" set dbField="P"
732 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"dbField now=",dbField)
733 else if Type="SEX" do
734 . if (TestField="m")!(TestField="M") set TestField="MALE"
735 . if (TestField="f")!(TestField="F") set TestField="FEMALE"
736
737 if TestField'="" do
738 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"$data(dbField)=",$data(dbField))
739 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"$get(dbField)='' =",($get(dbField)=""))
740 . if ($data(dbField)#10=0)!($get(dbField)="") set result=cExtraInfo
741 . else do
742 . . if Type="NUMBER" do
743 . . . if +TestField=+dbField set result=cFullMatch
744 . . else do
745 . . . if TestField=dbField set result=cFullMatch
746 else do ;"i.e. test case when TestField=""
747 . if $get(dbfield)="" set result=cFullMatch
748 . else set result=cdbExtraInfo
749
750 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"result=",result)
751 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"FieldCompare^TMGDBAPI")
752
753 quit result
754
755
756EnsureWrite(File,Field,IENS,Value,Flags,MsgArray)
757 ;"Purpose: To provide code to that will ensure that data is written to
758 ;" the database, but it will not add duplicate records if the value
759 ;" is already there. So a FIND is done first, and added if not found.
760 ;" Note: This is primarly targeted at adding entries in a subfile.
761 ;"Input: File -- File name or number
762 ;" Field -- Field name or number
763 ;" IENS -- standard IENS string describing IEN in File, or IEN path to subfile
764 ;" Value -- The value to be filed
765 ;" Flags -- Flags to be passed
766 ;" MsgArray -- PASS BY REFERENCE. Messages to pass back out.
767 ;"Results : 1=Writen OK, 0=Already present so not written, -1=error
768
769 new result set result=-1
770
771
772 quit result
773
774
775
776dbWrite(FDA,Overwrite,TMGIEN,Flags,ErrArray)
777 ;"Purpose: To provide a unified interface for writing a FDA to the database
778 ;"Input: FDA -- PASS BY REFERENCE. A standard FDA structure. (won't be changed)
779 ;" Overwrite -- specifies if records already exist in database
780 ;" if = 1, then FILE^DIE used to write into pre-existing records
781 ;" if = 0, then UPDATE^DIE used to write new records
782 ;" TMGIEN (OPTIONAL)-- an array to receive back records added (only applies if
783 ;" Overwrite=0)
784 ;" It can also be used to pass info to UPDATE^DIE recarding requested record numbers
785 ;" Flags (OPTIONAL) -- Flags to pass to UPDATE^DIE or FILE^DIE.
786 ;" default is "E". If "E" is not wanted, then pass a " "
787 ;" ErrArray (OPTIONAL) -- an OUT parameter to receive fileman "DIERR" results, if any
788 ;"Results --1 if OK, or 0 if error
789
790 merge ^TMG("TMP","EDDIE","FDA")=FDA ;"TEMP!!
791
792 set Overwrite=$get(Overwrite,0)
793 new TMGFDA merge TMGFDA=FDA
794 new TMGMsg
795 new TMGFlags set TMGFlags=$get(Flags,"E") ;"E=External values
796 if TMGFlags=" " set TMGFlags=""
797 if (Overwrite=1)&($get(Flags)'="") set TMGFlags=TMGFlags_"K" ;"K means filer does file locking.
798
799 new result set result=1 ;"Default to success
800 if $data(TMGFDA)=0 set result=-1 goto DBWDone
801
802 set ^TMP("TMG",$J,"ErrorTrap")=result
803 ;"======================================================
804 ;"======================================================
805 if Overwrite=1 do ;"i.e. FILE^DIE used to write into pre-existing records
806 . new $etrap set $etrap="do ErrTrp^TMGDBAPI"
807 . set ^TMP("TMG",$J,"Caller")="FILE^DIE"
808 . do FILE^DIE(TMGFlags,"TMGFDA","TMGMsg")
809 else if Overwrite=0 do ;"i.e. UPDATE^DIE used to write new records
810 . new $etrap set $etrap="do ErrTrp^TMGDBAPI"
811 . set ^TMP("TMG",$J,"Caller")="UPDATE^DIE"
812 . do UPDATE^DIE(TMGFlags,"TMGFDA","TMGIEN","TMGMsg")
813 ;"======================================================
814 ;"======================================================
815 set result=^TMP("TMG",$J,"ErrorTrap")
816 kill ^TMP("TMG",$J,"ErrorTrap")
817 kill ^TMP("TMG",$J,"Caller")
818
819 if $data(TMGMsg("DIERR")) do
820 . ;"TMGDEBUG=-1 --> extra quiet mode
821 . if $get(TMGDEBUG)>-1 do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound)
822 . set result=0
823 . merge ErrArray("DIERR")=TMGMsg("DIERR")
824
825DBWDone
826 quit result
827
828
829DelIEN(File,RecNumIEN,ErrArray)
830 ;"Purpose: To delete record# RecNumIEN from file FILE
831 ;"Input: File -- File name or number to delete from
832 ;" RecNumIEN -- the IEN to delete
833 ;" ErrArray --OPTIONAL, PASS BY REFERENCE.
834 ;" an OUT parameter to receive fileman "DIERR" results, if any
835 ;"Output: will cause deletion from database
836 ;"Results -- if error occured
837 ;" cOKToCont (i.e. 1) if no error
838 ;" cAbort (i.e. 0) if error
839
840 new TMGFDA,result
841 set result=0
842
843 if $get(File)="" goto DIENDone
844 if +$get(RecNumIEN)'>0 goto DIENDone
845 if +File'>0 set File=$$GetFileNum(File)
846
847 set TMGFDA(File,+RecNumIEN_",",.01)="@"
848 set result=$$dbWrite(.TMGFDA,1,,,.ErrArray)
849
850DIENDone
851 quit result
852
853
854WriteWP(File,RecNumIEN,Field,TMGArray)
855 ;"Purpose: To provide a shell around WP^DIE with error trap, error reporting
856 ;"Note: This does not support subfiles or multiples. Does not support appending
857 ;"Input: File: a number or name
858 ;" RecNumIEN: The record number, in File, to use
859 ;" Field: a name or number
860 ;" TMGArray: The array that contains WP data. Must be in Fileman acceptible format.
861 ;"Results -- if error occured
862 ;" cOKToCont (i.e. 1) if no error
863 ;" cAbort (i.e. 0) if error
864
865 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
866 if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1
867 if $data(cAbort)#10=0 new cAbort set cAbort=0
868
869 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"WriteWP^TMGDBAPI")
870
871 new IENS
872 new TMGMsg
873 new FileNumber,FieldNumber
874 new result set result=cAbort
875 new TMGFlags set TMGFlags="K"
876
877 set FileNumber=+$get(File)
878 if FileNumber=0 set FileNumber=$$GetFileNum(.File)
879 if FileNumber=0 do goto WWPDone
880 . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert file '"_$get(File)_", to a number.")
881
882 set FieldNumber=$get(Field)
883 if FieldNumber=0 set FieldNumber=$$GetNumField^TMGDBAPI(.Field)
884 if FieldNumber=0 do goto WWPDone
885 . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert field '"_$get(Field)_", to a number.")
886
887 if +$get(RecNumIEN)=0 do goto WWPDone
888 . do ShowError^TMGDEBUG(.PriorErrorFound,"No numeric record number supplied.")
889
890 set IENS=RecNumIEN_","
891
892 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNumber=",FileNumber)
893 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IENS='",IENS,"'")
894 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNumber=",FieldNumber)
895 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Flags=",TMGFlags)
896 ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGArray")
897
898 do
899 . ;"======================================================
900 . ;"Call WP^DIE
901 . ;"======================================================
902 . ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"TMGDBAPI::WP^DIE")
903 . new $etrap set $etrap="do ErrTrp^TMGDBAPI"
904 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Remember, WP^DIE files WP data.")
905 . set ^TMP("TMG",$J,"ErrorTrap")=result
906 . set ^TMP("TMG",$J,"Caller")="WP^DIE"
907 . do WP^DIE(FileNumber,IENS,FieldNumber,TMGFlags,"TMGArray","TMGMsg")
908 . set result=^TMP("TMG",$J,"ErrorTrap")
909 . kill ^TMP("TMG",$J,"ErrorTrap")
910 . kill ^TMP("TMG",$J,"Caller")
911 . ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::WP^DIE")
912 . ;"======================================================
913 . ;"======================================================
914
915 if $data(TMGMsg("DIERR"))'=0 do goto WWPDone
916 . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound)
917 . set result=cAbort
918
919 set result=cOKToCont
920
921 ;"zbreak WWPDone
922
923WWPDone
924 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"WriteWP^TMGDBAPI")
925 quit result
926
927
928ReadWP(File,IENS,Field,Array)
929 ;"Purpose: To provide a shell for reading a WP with error trap, error reporting
930 ;"Input: File: a number or name
931 ;" IENS: a standard IENS (i.e. "IEN,parent-IEN,grandparent-IEN,ggparent-IEN," etc.
932 ;" Note: can just pass a single IEN (without a terminal ",")
933 ;" Field: a name or number
934 ;" Array: The array to receive WP data. PASS BY REFERENCE
935 ;" returned In Fileman acceptible format.
936 ;" Array will be deleted before refilling
937 ;"Results -- if error occured
938 ;" cOKToCont (i.e. 1) if no error
939 ;" cAbort (i.e. 0) if error
940
941 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
942 if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1
943 if $data(cAbort)#10=0 new cAbort set cAbort=0
944
945 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ReadWP^TMGDBAPI")
946
947 new FileNumber,FieldNumber
948 new TMGWP,temp
949 new result set result=cOKToCont
950
951 if $get(IENS)="" do goto RWPDone
952 . do ShowError^TMGDEBUG(.PriorErrorFound,"Valid IENS not supplied.")
953 if $extract(IENS,$length(IENS))'="," set IENS=IENS_","
954
955 if $$SetFileFldNums^TMGDBAPI(.File,.Field,.FileNumber,.FieldNumber)=cAbort goto RWPDone
956
957 set temp=$$GET1^DIQ(FileNumber,IENS,FieldNumber,"","TMGWP","TMGMsg")
958
959 if $data(TMGMsg) do
960 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here are TMGMsg entries")
961 . ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGMsg")
962 . if $data(TMGMsg("DIERR"))'=0 do quit
963 . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound)
964 . . set result=cAbort
965 if result=cAbort goto RWPDone
966
967 kill Array
968 merge Array=TMGWP
969
970RWPDone
971 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"ReadWP^TMGDBAPI")
972 quit result
973
974ShowIfError(TMGMsg,PriorErrorFound)
975 ;"Purpose: to show DIERR if preesnt in pTMGMsg
976 ;"Input: pTMGMsg -- PASS BY REFERENCE, holds message route, as set up by Fileman
977 ;" PriorErrroFound -- OPTIONAL, a variable holding if a prior error has been found
978 ;"Output: 1 if ERROR found, 0 otherwise
979
980 new result set result=0
981 if $data(TMGMsg("DIERR"))'=0 do
982 . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound)
983 . set result=1
984 quit result
985
986
987DataImport(Info,ProgressFN)
988 ;"Purpose: to provide a generic loading utility.
989 ;" Note: this is more specific than code found in DDMP.m
990 ;"Assumptions: that all data for one record is found on one line, with a given
991 ;" number of columns for each field.
992 ;"Input: Info, an array with relevent info. PASS BY REFERENCE
993 ;" Format as follows:
994 ;" Info("HFS DIR")=<directory name in HFS to load from>
995 ;" Info("HFS FILE")=<file name in HFS to load from>
996 ;" Info("DEST FILE")=<file name or number>
997 ;" Info(x)=field# (or "IEN" if data should be used to determine record number
998 ;" Info(x,"START")=starting column
999 ;" Info(x,"END")=ending column
1000 ;" ProgressFN: optional. If not "", then this will be XECUTED after each line
1001 ;"Result: 1 if OK to continue, 0 if error
1002
1003 ;"Note: input Data array will be formated like this:
1004 ;" Data(0,cFile)="1234.1" <-- "NEW PERSON" Note conversion
1005 ;" Data(0,cFile,cGlobal)="^DIC(200)" <-- note, NOT "^DIC(200,"
1006 ;" Data(0,cRecNum)=2 <-- only if user-specified.
1007 ;" Data(0,cEntries)=1
1008 ;" Data(1,".01")="MyData1"
1009 ;" Data(1,".01",cMatchValue)="MyData1"
1010 ;" Data(1,".02")="Bill"
1011 ;" Data(1,".02",cMatchValue)="John"
1012 ;" Data(1,".03")="MyData3"
1013 ;" Data(1,".04")="MyData4"
1014 ;" Data(1,".06")="MyData5" <-- note "NAME" was converted to ".06"
1015 ;" Data(1,".07",0,cEntries)=2 <-- "ITEM" converted to ".07"
1016 ;" Data(1,".07",1,".01")="SubEntry1"
1017 ;" Data(1,".07",1,".02")="SE1"
1018 ;" Data(1,".07",1,".03")="'Some Info'"
1019 ;" Data(1,".07",2,".01")="SubEntry2"
1020 ;" Data(1,".07",2,".02")="SE2"
1021 ;" Data(1,".07",2,".04",0,cEntries)=1 ;"TEXT converted to .04
1022 ;" Data(1,".07",2,".04",1,".01")="JD"
1023 ;" Data(1,".07",2,".04",1,".02")="DOE,JOHN"
1024 ;" ADDENDUM
1025 ;" Data(1,".01",cFlags)=any flags specified for given field.
1026 ;" only present if user specified.
1027
1028 new cFile set cFile="FILE"
1029 new cRecNum set cRecNum="RECNUM"
1030 new result set result=1
1031
1032 new GRef set GRef=$name(^TMP("TMG","DATAIMPORT",$J))
1033 new GRef1 set GRef1=$name(@GRef@(1)) ;"I have to use this to load file
1034 kill @GRef
1035
1036 new result
1037 new dir set dir=$get(Info("HFS DIR"))
1038 new HFSfile set HFSfile=$get(Info("HFS FILE"))
1039 set result=$$FTG^%ZISH(dir,HFSfile,GRef1,4)
1040 if result=0 goto DIDone
1041 new file set file=$get(Info("DEST FILE"))
1042 if +file=0 set file=$$GetFileNum(file)
1043
1044 new index
1045 set index=$order(@GRef@(""))
1046 for do quit:(+index=0)!(result=0)
1047 . new RecData,FDA
1048 . set RecData(0,cFile)=file
1049 . new line set line=$get(@GRef@(index))
1050 . new fields set fields=$order(Info(""))
1051 . new IEN set IEN=""
1052 . for do quit:(+fields=0)!(result=0)
1053 . . new fieldNum set fieldNum=$get(Info(fields)) ;"could be number or 'IEN'
1054 . . new oneField
1055 . . set oneField=$extract(line,$get(Info(fields,"START")),$get(Info(fields,"END")))
1056 . . set oneField=$$Trim^TMGSTUTL(oneField)
1057 . . if fieldNum="IEN" do
1058 . . . set RecData(0,cRecNum)=fieldNum
1059 . . . set IEN=fieldNum
1060 . . else do
1061 . . . set RecData(1,fieldNum)=oneField
1062 . . set fields=$order(Info(fields))
1063 . new MarkNum set MarkNum=0
1064 . new MsgArray
1065 . set result=$$SetupFDA(.RecData,.FDA,,"+",.MarkNum,.MsgArray,IEN)
1066 . if result=0 quit
1067 . set result=$$dbWrite(.FDA,0,," ")
1068 . if result=0 quit
1069 . if $get(ProgressFN)'="" do
1070 . . new $etrap set $etrap="w ""??Progress function -- error trapped??"",!"
1071 . . xecute ProgressFN
1072 . set index=$order(@GRef@(index))
1073
1074DIDone
1075 kill @GRef
1076 quit result
1077
1078
1079Set1(File,IEN,Field,Value,Flag)
1080 ;"Purpose: to be the reverse of GET1^DIQ (i.e. a setter instead of a getter)
1081 ;" It will set the value for 1 field in 1 record in 1 file.
1082 ;" Note: only to be used in existing files.
1083 ;"Input: File -- the Filename or number
1084 ;" IEN -- the record number to set into
1085 ;" Field -- the field name or number
1086 ;" Value -- the value to set it to (WP not currently supported)
1087 ;" Flag -- OPTIONAL. Combinations of below:
1088 ;" 'I' -- values are in internal format
1089 ;" 'E' -- values are in external format (this is the DEFAULT)
1090 ;"Results: 1 if OKtoCont, 0 if error
1091
1092 new FileNumber,FieldNumber
1093 new result set result=0 ;"default to error
1094
1095 ;"new tempDebug set tempDebug=$get(TMGDEBUG)
1096 ;"set TMGDEBUG=-1 ;"Extra quiet mode
1097
1098 if $$SetFileFldNums^TMGDBAPI(.File,.Field,.FileNumber,.FieldNumber)=0 goto S1Done
1099 if (+FileNumber=0)!(+FieldNumber=0) goto S1Done
1100 if ($get(Value)="")!(+IEN=0) goto S1Done
1101
1102 new result set result=1 ;"default to success.
1103
1104 new TMGFDA,FMFlag,TMGMSG
1105 set FMFlag="E"
1106 if $get(Flag)["I" set FMFlag=""
1107 set FMFlag=FMFlag_"K"
1108 set TMGFDA(FileNumber,IEN_",",FieldNumber)=Value
1109 do FILE^DIE(FMFlag,"TMGFDA","TMGMSG")
1110 if $data(TMGMSG("DIERR"))'=0 do goto S1Done
1111 . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound)
1112
1113S1Done
1114 ;"set TMGDEBUG=tempDebug
1115 quit result
1116
1117
1118GetValidInput(File,Field)
1119 ;"Purpose: Gets a valid input for field in file, asking user from console
1120 ;"Input: File: File number or name of file to use
1121 ;" Field: Field number or name in file.
1122 ;"Results: returns valid input, or ""
1123
1124 new FileNum,FldNum
1125 new DIR,X,Y
1126 set Y=""
1127
1128 set FileNum=+$get(File)
1129 if FileNum=0 set FileNum=$$GetFileNum^TMGDBAPI(.File)
1130 if FileNum=0 goto GVIDone
1131
1132 set FldNum=$get(Field)
1133 if FldNum=0 set FldNum=$$GetNumField^TMGDBAPI(FileNum,.Field)
1134 if FldNum=0 goto GVIDone
1135
1136 set DIR(0)=FileNum_","_FldNum
1137 do ^DIR write !
1138GVIDone
1139 quit Y
1140
1141
1142AskFIENS()
1143 ;"Purpose: Ask user to pick a file number, then pick a record
1144 ;" from that file. This supports selection of subfiles.
1145 ;"Input: none
1146 ;"Results: format-- File^IENS, or ^ if abort
1147 new result set result="^"
1148
1149 new DIR,X,Y
1150 set DIR(0)="F"
1151 set DIR("A")="Select FILE (or SUBFILE)"
1152 set DIR("?")="Answer with FILE NUMBER or NAME, or SUBFILE NUMBER"
1153 set DIR("PRE")="D ASKSCRN^TMGDBAPI"
1154 do ^DIR
1155 set Y=+Y
1156 if Y>0 set result=Y_"^"_$$AskIENS(Y)
1157
1158 quit result
1159
1160ASKSCRN
1161 ;"Purpose: an Input transform for AskFIENS
1162 ;"Input: (global) X -- the user's response in ^DIR
1163 ;" (global) DTOUT -- this will be defined if the read timed out.
1164 ;"Output: If X is changed, it will be as if user entered in new X
1165 ;" If X is killed, it will be as if user entered an illegal value.
1166
1167 if $data(DTOUT) quit
1168 if +X=X do
1169 . if $data(^DD(X,0))=0 kill X quit
1170 . if $data(^DIC(X,0)) write " ",$piece(^DIC(X,0),"^",1)," " quit
1171 . ;"Here we deal with subfiles
1172 . new temp,i,filenum
1173 . set filenum=X
1174 . set X=""
1175 . for i=100:-1:0 do quit:(filenum=0)
1176 . . set temp(i)=filenum
1177 . . set X=X_filenum_","
1178 . . set filenum=+$get(^DD(filenum,0,"UP"))
1179 . new indent set indent=5
1180 . new indentS set $piece(indentS," ",75)=" "
1181 . write !
1182 . set i=""
1183 . for set i=$order(temp(i)) quit:(i="") do
1184 . . set filenum=+$get(temp(i)) quit:(filenum=0)
1185 . . write $extract(indentS,1,indent)
1186 . . if $data(^DIC(filenum,0)) do
1187 . . . write $piece(^DIC(filenum,0),"^",1)," (FILE #",filenum,")",!
1188 . . else write "+--SUBFILE# ",filenum,!
1189 . . set indent=indent+3
1190 else do ;"check validity of FILE NAME
1191 . if X="" quit
1192 . new filenum
1193 . set filenum=$order(^DIC("B",X,""))
1194 . if +filenum>0 set X=+filenum_"," quit
1195 . set filenum=$$GetFileNum(X)
1196 . if +filenum>0 set X=+filenum_"," quit
1197 . new DIC,Y
1198 . set DIC=1 set DIC(0)="EQM"
1199 . do ^DIC w !
1200 . if +Y>0 set X=+Y quit
1201 . set X=0
1202
1203 if $get(X)="" set X=0
1204 quit
1205
1206
1207AskIENS(FileNum,IENS)
1208 ;"Purpose: To ask user to select a record in File indicated by FileNum.
1209 ;" If FileNum is a subfile number, then the user will be asked
1210 ;" for records to drill down to desired record, and return values
1211 ;" as an IENS.
1212 ;"Input: FileNum: A file number or subfile number
1213 ;" IENS: OPTIONAL. Allows for supplying a partial IENS supplying a
1214 ;" partial path. E.g. if a full IENS to FileNum
1215 ;" would be '2,3,4455,' and if the IENS supplied is
1216 ;" '3,4455,' then only the missing IEN (in this case 2)
1217 ;" would be asked.
1218 ;"Results: Returns IENS. format: IEN in file,IEN in parentfile,IEN in grandparentfile, ... ,
1219 ;" Note: IENS will contain '?' if there is a problem,
1220 ;" or "" if FileNum is invalid
1221 new array
1222 do GetRefArray(FileNum,.array)
1223 new resultIENS set resultIENS=""
1224 set IENS=$get(IENS)
1225
1226 new DANum set DANum=1
1227 new TMGDA,numIENS
1228 set numIENS=$length(IENS,",")
1229 new i,abort set i="",abort=0
1230 for set i=$order(array(i),-1) quit:(i="")!abort do
1231 . new DIC,X,Y,DA
1232 . new tempIEN set tempIEN=+$piece(IENS,",",numIENS-DANum)
1233 . if tempIEN'>0 do
1234 . . set DIC=$get(array(i,"GL")),DIC(0)="AEQM"
1235 . . if DIC'="" write !,"Select entry in file# ",array(i,"FILE NUM")
1236 . . do ^DIC write !
1237 . else set Y=tempIEN
1238 . if +Y'>0 set resultIENS="?,"_resultIENS,abort=1 quit
1239 . set TMGDA(DANum)=+Y,DANum=DANum+1
1240 . set resultIENS=+Y_","_resultIENS
1241
1242 write "#: ",resultIENS,!
1243 quit resultIENS
1244
1245
1246GetRefArray(FileNum,array)
1247 ;"Purpose: To return an array containing global references that can
1248 ;" be passed to ^DIC, for given file or subfile number
1249 ;"Input: FileNum: A file number or subfile number
1250 ;" array: PASS BY REFERENCE. See format below
1251 ;"Results: none, but array is filled with result. Format (example):
1252 ;" array(1,"FILE NUM")=2.011 <--- sub sub file
1253 ;" array(1,"GL")="^DPT(TMGDA(1),""DE"",TMGDA(2),""1"","
1254 ;" array(2,"FILE NUM")=2.001 <---- sub file
1255 ;" array(2,"GL")="^DPT(TMGDA(1),""DE"","
1256 ;" array(3,"FILE NUM")=2 <---- parent file
1257 ;" array(3,"GL")="^DPT("
1258 ;"Note: To use the references stored in "GL", then the IEN for
1259 ;" each step should be stored in TMGDA(x)
1260
1261 new i
1262 for i=1:1 quit:(+$get(FileNum)=0) do
1263 . set array(i,"FILE NUM")=FileNum
1264 . if $data(^DD(FileNum,0,"UP")) do
1265 . . new parentFlNum,field
1266 . . set parentFlNum=+$get(^DD(FileNum,0,"UP"))
1267 . . if parentFlNum=0 quit ;"really should be an abort
1268 . . set field=$order(^DD(parentFlNum,"SB",FileNum,""))
1269 . . if field="" quit ;"really should be an abort
1270 . . new node set node=$piece($piece($get(^DD(parentFlNum,field,0)),"^",4),";",1)
1271 . . set array(i,"NODE IN PARENT")=node
1272 . else do
1273 . . set array(i,"GL")=$get(^DIC(FileNum,0,"GL"))
1274 . set FileNum=+$get(^DD(FileNum,0,"UP"))
1275
1276 set i="" set i=$order(array(i),-1)
1277 set array(i,"ref")=$get(array(i,"GL"))_"TMGDA(1),"
1278 new DANum set DANum=2
1279 for set i=$order(array(i),-1) quit:(i="") do
1280 . new ref
1281 . set ref=$get(array(i+1,"ref"))_""""_$get(array(i,"NODE IN PARENT"))_""","
1282 . kill array(i+1,"ref"),array(i,"NODE IN PARENT")
1283 . set array(i,"GL")=ref
1284 . set array(i,"ref")=ref_"TMGDA("_DANum_"),"
1285 . set DANum=DANum+1
1286 kill array(1,"ref")
1287 quit
1288
1289FIENS2Root(FIENS)
1290 ;"Purpose: to convert a Files^IENS string into a root reference
1291 ;"Input: FIENS: format: FileNumber^StandardIENS
1292 ;"Output: A global root in open format
1293 quit
1294
1295
1296GetRef(file,IENS,field)
1297 ;"Purpose: to return the global reference for a given record
1298 ;"Input: file -- File or subfile number
1299 ;" IENS -- an IEN, or an IENS for record
1300 ;" field -- OPTIONAL.
1301 ;"Results: if field is NOT supplied, or
1302 ;" OPEN global ref
1303 ;" if field IS supplied
1304 ;" CLOSED global ref@piece
1305 ;" e.g. ^TMG(22706.9,3,2,IEN,0)@1 <-- note 'IEN' placeholder
1306
1307 ;"Note: This function really needs to be fleshed out some more...
1308 ;"Note: this only will work for normal files, or subfiles ONE (1) level deep...
1309
1310 new ref set ref=""
1311 new parentFile set parentFile=$$IsSubFile^TMGDBAPI(file)
1312 if parentFile=0 goto GRF1 ;"handle non-subfiles separately.
1313
1314 set fieldInParent=$piece(parentFile,"^",2)
1315 set ref=$get(^DIC(+parentFile,0,"GL"))
1316 new IENinParent set IENinParent=$piece(IENS,",",2)
1317 set ref=ref_IENinParent_","
1318 new storeLoc set storeLoc=$piece($get(^DD(+parentFile,fieldInParent,0)),"^",4)
1319 ;"Note: works only with storeLoc in Node;Piece format... not all fields follow this...
1320 set ref=ref_+storeLoc_","
1321 new IENinSubRec set IENinSubRec=$piece(IENS,",",1)
1322 if IENinSubRec="" set IENinSubRec="IEN"
1323 set ref=ref_IENinSubRec_","
1324
1325 if $get(field)="" goto GRF2 ;"done
1326 set storeLoc=$piece($get(^DD(file,field,0)),"^",4)
1327 set ref=ref_+storeLoc_")@"_$piece(storeLoc,";",2)
1328 goto GRF2
1329
1330GRF1
1331 set ref=$get(^DIC(file,0,"GL"))
1332 set ref=ref_+IENS_","
1333 if $get(field)="" goto GRF2 ;"done
1334 new storeLoc set storeLoc=$piece($get(^DD(file,field,0)),"^",4)
1335 set ref=ref_+storeLoc_")@"_$piece(storeLoc,";",2)
1336 ;"Note: works only with storeLoc in Node;Piece format... not all fields follow this...
1337GRF2
1338 quit ref
1339
1340TrimFDA(FDA,Quiet)
1341 ;"Purpose: To take an FDA, and compare it to data already present in the
1342 ;" record specified by the FDA. If any values already in the record
1343 ;" match those in the FDA, then those entries will be removed from the
1344 ;" FDA array.
1345 ;"Input: FDA -- PASS BY REFERENCE. A standard Fileman FDA.
1346 ;" Quiet -- OPTIONAL. If 1, then error messages will be supressed
1347 ;" (These would be messages generated on READING existing
1348 ;" data, not writing new data.)
1349 ;" default value=1
1350 ;"Output: Values from FDA may be removed.
1351 ;"Results: final IENS (i.e. '+1,3,' --> '5,3,' if prev value found)
1352 ;"Note: match will be made base on INTERNAL, or EXTERNAL forms
1353 ;"Note: Fields should be specified by numbers, NOT NAMES.
1354
1355 new tempIENS set tempIENS=""
1356 if $data(FDA)'>0 goto TFDDone
1357 new TMGDATA,TMGMSG
1358 new file,IENS
1359 set file=$order(FDA(""))
1360 set IENS=$order(FDA(file,""))
1361 set tempIENS=IENS
1362 set Quiet=$get(Quiet,1)
1363
1364 new fieldsS set fieldsS=""
1365 new field set field=""
1366 for set field=$order(FDA(file,IENS,field)) quit:(field="") do
1367 . set fieldsS=fieldsS_field_";"
1368
1369 new parentFile set parentFile=$$IsSubFile^TMGDBAPI(file)
1370 if parentFile=0 goto TFD0 ;"handle non-subfiles separately.
1371
1372 ;"e.g. FDA(22706.9001,"+1,3",.01)=1
1373 ;" FDA(22706.9001,"+1,3",.02)=2
1374 ;"Note: The .01 field is used to find a matching subrecord, which is then
1375 ;" check for preexisting data. If multiple matches for .01 are found,
1376 ;" then the process is aborted, and the FDA will NOT BE TRIMMED.
1377
1378 set $piece(tempIENS,",",1)="" ;"leave first piece blank in IENS
1379 new value set value=$get(FDA(file,IENS,.01))
1380
1381 ;"new i for i=1:1:$length(fieldsS,",") do ;"append 'E' to each field number
1382 ;". new field set field=$piece(fieldsS,";",i)
1383 ;". set field=field_"E"
1384 ;". set $piece(fieldsS,";",i)=field
1385 ;"
1386 ;"new TMGFIND
1387 ;"
1388 ;"I can't get this part to work... so will work around
1389 ;"do FIND^DIC(file,tempIENS,fieldsS,"BMU",value,"*",,,,"TMGFIND","TMGMSG")
1390 ;"do ShowIfDIERR^TMGDEBUG(.TMGMSG)
1391 ;"if +$get(TMGFIND(0))'=1 goto TFDDone ;"abort
1392 ;"merge TMGDATA(file,IENS)=TMGDATA("ID",1)
1393 ;"goto TFD1
1394
1395 new ref set ref=$$GetRef(file,tempIENS,.01) ;"returns ref with 'IEN' built in...
1396 new ref2 set ref2=$$CREF^DILF($piece(ref,"IEN",1))
1397 new ref3 set ref3=$piece(ref,"@",1)
1398 new p set p=$piece(ref,"@",2)
1399 new found set found=0
1400 new IEN set IEN=0
1401 for set IEN=$order(@ref2@(IEN)) quit:(+IEN'>0)!(found>0) do
1402 . new valueFound set valueFound=$piece($get(@ref3),"^",p)
1403 . if valueFound=value set found=IEN
1404 if found=0 set tempIENS=IENS goto TFDDone
1405 set tempIENS=found_tempIENS
1406TFD0
1407 do GETS^DIQ(file,tempIENS,fieldsS,"EI","TMGDATA","TMGMSG")
1408 if 'Quiet do ShowIfDIERR^TMGDEBUG(.TMGMSG)
1409
1410TFD1
1411 for set field=$order(FDA(file,IENS,field)) quit:(field="") do
1412 . new found set found=0
1413 . new FDAvalue set FDAvalue=$get(FDA(file,IENS,field))
1414 . if $get(TMGDATA(file,tempIENS,field,"I"))=FDAvalue set found=1
1415 . if $get(TMGDATA(file,tempIENS,field,"E"))=FDAvalue set found=1
1416 . if (FDAvalue="@")&($data(TMGDATA(file,tempIENS,field))=0) set found=1
1417 . if found=1 kill FDA(file,IENS,field)
1418 goto TFDDone
1419TFDDone
1420 quit tempIENS
1421
1422
1423
1424GetPtrsOUT(File,Info)
1425 ;"Purpose: to get a list of pointers out from the file.
1426 ;"Input: File -- File Name or Number of file to investigate
1427 ;" Info -- PASS BY REFERENCE. An OUT PARAMETER. Format:
1428 ;" Info(Field#)=PointedToFileNum
1429 ;" Info(Field#,"GL")=an open global ref to pointed-to file
1430 ;"results: none
1431
1432 if $get(File)="" goto GPODone
1433 if +File'=File set File=$$GetFileNum(File)
1434 new field set field=0
1435 new done set done=0
1436 for set field=$order(^DD(File,field)) quit:(+field'>0)!(done=1) do
1437 . new array
1438 . do FIELD^DID(File,field,"N","POINTER","array")
1439 . if $get(array("POINTER"))="" quit
1440 . if array("POINTER")[";" quit
1441 . set Info(field,"GL")=array("POINTER")
1442 . new temp set temp=$piece($get(^DD(File,field,0)),"^",2)
1443 . set temp=+$piece(temp,"P",2)
1444 . set Info(field)=temp
1445 . if $data(array) write field," " zwr array
1446GPODone
1447 quit
1448
Note: See TracBrowser for help on using the repository browser.