source: cprs/branches/tmg-cprs/m_files/TMGSIPHU.m@ 1742

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

replacing soft links with actual files

File size: 30.8 KB
RevLine 
[896]1TMGSIPH ;TMG/kst/SIPHON PROGRAM, FOR TRANSFERRING VISTA INSTANCES ;11/27/09
2 ;;1.0;TMG-LIB;**1**;11/27/09
3 ;
4 ;"TMG SIPHON PROGRAM, FOR TRANSFERRING VISTA INSTANCE
5 ;"UTILITY FUNCTIONS
6 ;"Kevin Toppenberg MD
7 ;"GNU General Public License (GPL) applies
8 ;"11/27/09
9 ;
10 ;"=======================================================================
11 ;" API -- Public Functions.
12 ;"=======================================================================
13 ;"ORDREF(REF) -- return a $ORDER on a reference
14 ;"QLASTSUB(REF) -- Returns the LAST subscript of reference
15 ;"QSUBS(REF,ENDNUM,STARTNUM) -- Return subscripts from START to END ***NOTE ORDER OF PARAMETERS.
16 ;"QSETSUB(REF,POS,VALUE) -- Set the subscript in REF as position POS to be VALUE
17 ;"GETREF0(FILENUM) -- Returns reference to 0 node for file.
18 ;"GETNUMREC(FILENUM) -- Return the highest record number in given file.
19 ;"STOREDATA(ARRAY) -- store data from array into local globals, making backup of overwritten records
20 ;"IENOFARRAY(FILENUM,ARRAY,IENS) --return the IEN record number of the array.
21 ;"APPENDIEN(FILENUM,IENS) --return an IEN number that is +1 from the last one in the file.
22 ;"RLOCARRAY(FILENUM,NEWIEN,ARRAY,NARRAY) --Relocate array (change IEN)
23 ;"STOREDAS(FILENUM,IEN,ARRAY) -- Store data from array into local globals, making backup of
24 ;" overwritten records. AND ALSO translate record number to input-specified IEN
25 ;"GETFLD(FILENUM,LOC,PCE) -Return field number cooresponding to File number, node, and piece.
26 ;"
27 ;"=======================================================================
28 ;" API -- Private Functions.
29 ;"=======================================================================
30 ;"UNNEEDPTR(FILENUM,RPTR,LPTR,INOUT,TALLY) -- satisfy all the places that were wanting a remote record to be downloaded
31 ;"ISDIFF(ARRAY) -- determine if record stored in ARRAY is different from that stored in local ^Global
32 ;"RECSHOW(FILENUM,RPTR,ARRAY) -- Show remote and local data, to allow user to see differences
33 ;"GET01FIELD(FILENUM,ARRAY,RVALUE,LVALUE,IENS) -- Extract .01 field name from data array
34 ;"GETTARGETIEN(FILENUM,ARRAY,TARGETIEN) --determine if a local record should be overwritten with record from server.
35 ;" Ask user directly if not able to automically determine.
36 ;"=======================================================================
37 ;"Dependancies
38 ;"=======================================================================
39 ;"TMGUSRIF
40 ;"=======================================================================
41 ;
42ORDREF(REF)
43 ;"Purpose: to return a $ORDER on a reference
44 ;" e.g. ^TIU(8925,"") --> returns ^TIU(8925,0)
45 ;" ^TIU(8925) --> returns ^TIU(8925.1)
46 ;"NOTE: If there is no further nodes AT THE LEVEL OF THE LAST PARAMETER, then "" is returned.
47 ;" e.g. A("Fruits","Citrus","Orange")
48 ;" A("Fruits","Citrus","Green")
49 ;" A("Fruits","Non-Citrus","Red","Hard")
50 ;" A("Fruits","Non-Citrus","Red","Soft")
51 ;" A("Fruits","Tropic","Yellow")
52 ;" A("Fruits","Tropic","Blue")
53 ;" In this example, $ORDREF(A("Fruits","Non-Citrus","Red","Soft")), would return ""
54 ;" This is difference from $QUERY, which would return A("Fruits","Tropic","Yellow")
55 ;"Input --REF -- reference to a global. Must be in Closed format
56 ;"Results: Returns new reference.
57 NEW RESULT,SUB
58 SET SUB=$ORDER(@REF)
59 IF SUB'="" DO
60 . SET RESULT=REF
61 . DO QSETSUB(.RESULT,$QLENGTH(REF),SUB)
62 ELSE SET RESULT=""
63 QUIT RESULT
64 ;
65 ;
66QLASTSUB(REF) ;
67 ;"Returns the LAST subscript of reference
68 ;"Input: REF -- The reference to work on, e.g. ^TIU(8925,3,0) MUST be in closed form
69 QUIT $QSUBSCRIPT(REF,$QLENGTH(REF))
70 ;
71 ;
72QSUBS(REF,ENDNUM,STARTNUM) ;"***NOTE ORDER OF PARAMETERS. IT IS 'BACKWARDS', so STARTNUM can be optional
73 ;"Purpose: Return subscripts from START to END
74 ;"Input: REF -- The reference to work on, e.g. ^TIU(8925,3,0) MUST be in closed form
75 ;" ENDNUM -- The ending subscript to return.
76 ;" STARTNUM -- The starting subscript to return. OPTIONAL. Default is 0
77 ;"Returns the reference, in closed for.
78 NEW I,RESULT SET RESULT=""
79 SET STARTNUM=+$GET(STARTNUM)
80 SET ENDNUM=+$GET(ENDNUM)
81 IF ENDNUM>$QLENGTH(REF) SET ENDNUM=$QLENGTH(REF)
82 FOR I=STARTNUM:1:ENDNUM DO
83 . NEW ONENODE SET ONENODE=$QSUBSCRIPT(REF,I)
84 . IF (+ONENODE'=ONENODE),(I>0) SET ONENODE=""""_ONENODE_""""
85 . SET RESULT=RESULT_ONENODE
86 . IF I=0 SET RESULT=RESULT_"("
87 . ELSE SET RESULT=RESULT_","
88 SET RESULT=$$CREF^DILF(RESULT)
89 IF (RESULT'["("),($EXTRACT(RESULT,$LENGTH(RESULT))=",") DO
90 . SET RESULT=$EXTRACT(RESULT,1,$LENGTH(RESULT)-1)_")"
91 QUIT RESULT
92 ;
93 ;
94QSETSUB(REF,POS,VALUE) ;
95 ;"Purpose: Set the subscript in REF as position POS to be VALUE
96 ;"Input: REF -- The reference to modify. PASS BY REFERENCE
97 ;" POS -- The position of the subscript to change. POS=1 means first subscript
98 ;" VALUE -- The new subscript number or name
99 ;"Output: REF is modified
100 ;"Results: none
101 IF (POS>$QLENGTH(REF))!(POS<1) QUIT
102 NEW REFA SET REFA=$$QSUBS(REF,POS-1)
103 SET REFA=$$OREF^DILF(REFA)
104 NEW REFB SET REFB=$$QSUBS(REF,999,POS+1)
105 IF REFB="" SET REFB=")"
106 ELSE SET REFB=","_REFB
107 IF (+VALUE'=VALUE),($EXTRACT(VALUE,1)'="""") SET VALUE=""""_VALUE_""""
108 SET REF=REFA_VALUE_REFB
109 QUIT
110 ;
111 ;
112GETREF0(FILENUM)
113 ;"Purpose: Returns reference to 0 node for file.
114 ;"Input: FILENUM -- The fileman number of the file to return info for.
115 ;"Result: RETURNS REF, OR "" if problem.
116 NEW REF SET REF=$GET(^DIC(FILENUM,0,"GL"))
117 IF REF'="" SET REF=REF_"0)"
118 QUIT REF
119 ;
120 ;
121GETNUMREC(FILENUM)
122 ;"Purpose: Return the highest record number in given file.
123 ;"Input: FILENUM -- The fileman number of the file to return info for.
124 ;"Results: returns number, or -1 if problem.
125 ;"write "Here in GETNUMRECS",!
126 NEW RESULT,REF,NODE
127 SET RESULT=-1
128 SET REF=$$GETREF0(FILENUM)
129 IF REF'="" SET RESULT=$PIECE($GET(@REF),"^",4)
130 IF RESULT="" SET RESULT=-1
131 QUIT RESULT
132 ;
133 ;
134STOREDATA(ARRAY)
135 ;"Purpose: To store data from array into local globals, making backup of
136 ;" overwritten records
137 ;"Input: ARRAY -- Pass by REFERENCE. Format
138 ;" ARRAY(1)=ARef_"="
139 ;" ARRAY(2)="="_AValue
140 ;" ARRAY(3)=ARef_"="
141 ;" ARRAY(4)="="_AValue
142 ;" ...
143 ;"Results: none
144 NEW STIME SET STIME=$H
145 NEW TMGI SET TMGI=1
146 NEW TMGCT SET TMGCT=0
147 NEW SHOWPROG SET SHOWPROG=0
148 NEW SHOWREF SET SHOWREF=0
149 NEW REF,VALUE
150 FOR DO QUIT:(TMGI="")
151 . SET REF=$GET(ARRAY(TMGI))
152 . SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1)
153 . IF REF="" SET TMGI="" QUIT
154 . SET TMGI=TMGI+1
155 . SET VALUE=$GET(ARRAY(TMGI))
156 . SET VALUE=$EXTRACT(VALUE,2,10000)
157 . IF $DATA(@REF) DO
158 . . MERGE ^TMG("TMGSIPH","OVERWRITTEN",REF)=@REF
159 . . KILL @REF
160 . SET @REF=VALUE
161 . SET TMGI=$ORDER(ARRAY(TMGI))
162 . SET TMGCT=TMGCT+1
163 . IF (SHOWPROG=0),($$HDIFF^XLFDT($H,STIME,2)>15) DO ;"Turn on progress bar after 15 seconds.
164 . . SET SHOWPROG=1
165 . . SET TMGMIN=$ORDER(ARRAY(0))
166 . . SET TMGMAX=$ORDER(ARRAY(""),-1)
167 . IF (SHOWPROG=1),(TMGCT>500) DO
168 . . IF (SHOWREF=0),($$HDIFF^XLFDT($H,STIME,2)>120) DO ;"Turn on showing referecences after 2 min.
169 . . NEW SREF SET SREF=""
170 . . IF SHOWREF DO
171 . . . SET SREF=REF QUIT:($LENGTH(REF)'>20)
172 . . . SET SREF=$EXTRACT(REF,1,17)_"..."
173 . . DO ProgressBar^TMGUSRIF(TMGI,"Storing Data: "_SREF,TMGMIN,TMGMAX,70,STIME)
174 . . SET TMGCT=0
175 ;
176 QUIT
177 ;
178 ;
179IENOFARRAY(FILENUM,ARRAY,IENS) ;"
180 ;"Purpose: return the IEN record number of the array.
181 ;"Input: FILENUM -- The file number of the data passed in array. MUST MATCH
182 ;" ARRAY -- Pass by REFERENCE. Format
183 ;" ARRAY(1)=ARef_"=" <---- Expected to hold the .01 field.
184 ;" ARRAY(2)="="_AValue
185 ;" ARRAY(3)=ARef_"="
186 ;" ARRAY(4)="="_AValue
187 ;" IENS -- OPTIONAL (needed If FILENUM is a subfile) -- A standard IENS for subfile.
188 ;"Result: IEN if found, or 0 if error.
189 ;" NOTE: Even if FILENUM is a subfile, IEN is a single number, i.e. IEN of subrecord
190 ;" e.g. '3' not '3,23456,'
191 ;"
192 NEW RESULT SET RESULT=0
193 SET FILENUM=+$GET(FILENUM) IF FILENUM'>0 GOTO IOADN
194 ;"NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL"))
195 NEW GREF SET GREF=$$GETGREF^TMGFMUT2(FILENUM,.IENS) ;"IENS not used if not subfile.
196 NEW CGREF SET CGREF=$$CREF^DILF(GREF)
197 IF GREF="" GOTO IOADN
198 NEW GREFLEN SET GREFLEN=$QLENGTH(CGREF)
199 NEW REF SET REF=$GET(ARRAY(1)) IF (REF="") GOTO IOADN
200 SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1) IF (REF="") GOTO IOADN
201 IF $$QSUBS(REF,GREFLEN)'=CGREF GOTO IOADN
202 SET RESULT=$QSUBSCRIPT(REF,GREFLEN+1)
203IOADN QUIT RESULT
204 ;
205 ;
206APPENDIEN(FILENUM,IENS) ;
207 ;"Purpose: to return an IEN number that is +1 from the last one in the file.
208 ;"Return : the new IEN, or 0 if problem
209 NEW RESULT SET RESULT=0
210 ;"NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL")) IF GREF="" GOTO AIEDN
211 NEW GREF SET GREF=$$GETGREF^TMGFMUT2(FILENUM,.IENS) ;"IENS not used if not subfile.
212 NEW CGREF SET CGREF=$$CREF^DILF(GREF)
213 NEW LASTIEN SET LASTIEN="%"
214 FOR SET LASTIEN=$ORDER(@CGREF@(LASTIEN),-1) QUIT:(LASTIEN="")!(+LASTIEN=LASTIEN)
215 SET RESULT=LASTIEN+1
216 IF $GET(IENS)["," DO
217 . SET $PIECE(IENS,",",1)=RESULT
218 . SET RESULT=IENS
219AIEDN QUIT RESULT
220 ;
221 ;
222RLOCARRAY(FILENUM,NEWIEN,ARRAY,NARRAY) ;"Relocate array (change IEN)
223 ;"Purpose: To take array, and change IEN values to NEWIEN
224 ;"NOTE: It is assumed that ALL data in ARRAY represents ONE record (not multiple!)
225 ;" The array MAY contain cross-references data
226 ;"Input: FILENUM -- The file (or subfile) number of the data passed in array. MUST MATCH
227 ;" NEWIEN -- The IEN that the data in ARRAY should be changed to.
228 ;" If FILENUM is a subfile, then NEWIEN should be in standard IENS format (e.g. '7,345,')
229 ;" ARRAY -- Pass by REFERENCE. Format
230 ;" ARRAY(1)=ARef_"="
231 ;" ARRAY(2)="="_AValue
232 ;" ARRAY(3)=ARef_"="
233 ;" ARRAY(4)="="_AValue
234 ;" ...
235 ;" NARRAY -- PASS BY REFERENCE, an OUT PARAMETER. Format same as ARRAY
236 ;" NARRAY(1)=ARef_"="
237 ;" NARRAY(2)="="_AValue
238 ;" ...
239 ;"Results: 1 if OK, -1 if error
240 ;
241 KILL NARRAY
242 NEW RESULT SET RESULT=-1
243 NEW SHOWPROG SET SHOWPROG=0
244 NEW STIME SET STIME=$H
245 SET FILENUM=+$GET(FILENUM) IF FILENUM'>0 GOTO RLAD
246 SET NEWIEN=$GET(NEWIEN) IF +NEWIEN'>0 GOTO RLAD
247 NEW GREF SET GREF=$$GETGREF^TMGFMUT2(FILENUM,NEWIEN)
248 ;"NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL"))
249 NEW CGREF SET CGREF=$$CREF^DILF(GREF)
250 IF GREF="" GOTO SDAD
251 ;"Check to see that the ARRAY data is referenced to same place as FILENUM
252 NEW GREFLEN SET GREFLEN=$QL(CGREF)
253 NEW REF SET REF=$GET(ARRAY(1)) IF (REF="") GOTO RLAD
254 SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1) IF (REF="") GOTO RLAD
255 IF $$QSUBS(REF,GREFLEN)'=CGREF GOTO RLAD
256 NEW VALUE,RECNUM
257 NEW OLDIEN SET OLDIEN=""
258 NEW DONE SET DONE=0
259 NEW TMGCT SET TMGCT=0
260 NEW TMGI SET TMGI=0
261 FOR SET TMGI=$ORDER(ARRAY(TMGI)) QUIT:(TMGI="")!DONE DO
262 . SET REF=$GET(ARRAY(TMGI))
263 . SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1)
264 . SET TMGI=TMGI+1
265 . IF REF="" SET DONE=1 QUIT
266 . SET REC=$QSUBSCRIPT(REF,GREFLEN+1) ;"Get IEN of ARRAY data
267 . IF OLDIEN="",(+REC=REC) SET OLDIEN=REC
268 . IF REC'=+NEWIEN DO
269 . . IF (+REC=REC) DO ;"Change record number in reference
270 . . . SET REF=GREF_+NEWIEN_","_$$QSUBS(REF,99,GREFLEN+2)
271 . . ELSE DO ;"Redirect XREF value.
272 . . . NEW PT2 SET PT2=$QSUBSCRIPT(REF,$QLENGTH(REF))
273 . . . IF PT2'=OLDIEN QUIT ;"Unexpected format of xref
274 . . . DO QSETSUB(.REF,$QLENGTH(REF),+NEWIEN) ;"Change pointer in last position.
275 . SET VALUE=$EXTRACT($GET(ARRAY(TMGI)),2,10000)
276 . SET NARRAY(TMGI-1)=REF_"="
277 . SET NARRAY(TMGI)="="_VALUE
278 . IF (SHOWPROG=0),($$HDIFF^XLFDT($H,STIME,2)>15) DO ;"Turn on progress bar after 15 seconds.
279 . . SET SHOWPROG=1
280 . . SET TMGMIN=$ORDER(ARRAY(0))
281 . . SET TMGMAX=$ORDER(ARRAY(""),-1)
282 . SET TMGCT=TMGCT+1
283 . IF (SHOWPROG=1),(TMGCT>500) DO
284 . . DO ProgressBar^TMGUSRIF(TMGI,"Shifting Data: ",TMGMIN,TMGMAX,70,STIME)
285 . . SET TMGCT=0
286 SET RESULT=1
287RLAD QUIT RESULT
288 ;
289 ;
290STOREDAS(FILENUM,IEN,ARRAY) ;"'STORE DATA AS'
291 ;"Purpose: To store data from array into local globals, making backup of
292 ;" overwritten records. AND ALSO translate record number to input-specified IEN
293 ;"NOTE: It is assumed that ALL data in ARRAY represents ONE record (not multiple!)
294 ;" The array MAY contain cross-references data
295 ;"Input: FILENUM -- The file number of the data passed in array. MUST MATCH
296 ;" IEN -- The IEN that the data in ARRAY should be changed to.
297 ;" If FILENUM is a subfile, then pass a standard IENS string in IEN
298 ;" ARRAY -- Pass by REFERENCE. Format
299 ;" ARRAY(1)=ARef_"="
300 ;" ARRAY(2)="="_AValue
301 ;" ARRAY(3)=ARef_"="
302 ;" ARRAY(4)="="_AValue
303 ;" ...
304 ;"Also -- Makes use of Globally-scoped variable TMGOWSAVE. If =0, overwritten records are NOT saved
305 ;"Results: 1 if OK, -1 if error
306 ;"NOTE: Subfile support not completed yet...
307 NEW RESULT SET RESULT=-1
308 NEW NARRAY
309 NEW SHOWPROG SET SHOWPROG=0
310 NEW SHOWREF SET SHOWREF=0
311 NEW TMGCT SET TMGCT=0
312 NEW STIME SET STIME=$H
313 IF $$IENOFARRAY(FILENUM,.ARRAY,IEN)=+NEWIEN GOTO SDA2
314 IF $$RLOCARRAY(FILENUM,NEWIEN,.ARRAY,.NARRAY)'=1 GOTO SDAD ;"Relocate array (change IEN)
315 KILL ARRAY MERGE ARRAY=NARRAY
316SDA2 NEW TMGI SET TMGI=0
317 NEW DONE SET DONE=0
318 FOR SET TMGI=$ORDER(ARRAY(TMGI)) QUIT:(TMGI="")!DONE DO
319 . SET REF=$GET(ARRAY(TMGI))
320 . SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1)
321 . SET TMGI=TMGI+1
322 . IF REF="" SET DONE=1 QUIT
323 . NEW VALUE SET VALUE=$EXTRACT($GET(ARRAY(TMGI)),2,10000)
324 . ;"write REF,!
325 . IF $DATA(@REF) DO
326 . . IF +$GET(TMGOWSAVE)=0 QUIT
327 . . MERGE ^TMG("TMGSIPH","OVERWRITTEN",REF)=@REF
328 . . KILL @REF
329 . SET @REF=VALUE
330 . IF (SHOWPROG=0),($$HDIFF^XLFDT($H,STIME,2)>15) DO ;"Turn on progress bar after 15 seconds.
331 . . SET SHOWPROG=1
332 . . SET TMGMIN=$ORDER(ARRAY(0))
333 . . SET TMGMAX=$ORDER(ARRAY(""),-1)
334 . SET TMGCT=TMGCT+1
335 . IF (SHOWPROG=1),(TMGCT>500) DO
336 . . IF (SHOWREF=0),($$HDIFF^XLFDT($H,STIME,2)>120) DO ;"Turn on showing referecences after 2 min.
337 . . NEW SREF SET SREF=""
338 . . IF SHOWREF DO
339 . . . SET SREF=REF QUIT:($LENGTH(REF)'>20)
340 . . . SET SREF=$EXTRACT(REF,1,17)_"..."
341 . . DO ProgressBar^TMGUSRIF(TMGI,"Storing Data: "_SREF,TMGMIN,TMGMAX,70,STIME)
342 . . SET TMGCT=0
343 SET RESULT=1
344SDAD QUIT RESULT
345 ;
346 ;
347UNNEEDPTR(FILENUM,RPTR,LPTR,INOUT,TALLY) ;
348 ;"Purpose: To satisfy all the places that were wanting a remote record to be downloaded
349 ;"Input: FILENUM -- the fileman number of file (or subfile) to get from remote server
350 ;" If FILENUM is a subfile, then can be passed as just subfilenumber, OR
351 ;" in format: SubFileNum{ParentFileNum...
352 ;" RPTR -- The IEN of the record that was wanted from the server.
353 ;" If dealing with subfiles, pass in standard IENS format (e.g. '7,2345,')
354 ;" LPTR -- OPTIONAL. This can specify if the desired REMOTE record has been
355 ;" stored at a different IEN locally.
356 ;" If dealing with subfiles, pass in standard IENS format (e.g. '7,2345,')
357 ;" INOUT -- OPTIONAL -- Default is "PTOUT". Should be "PTIN" or "PTOUT"
358 ;" TALLY -- OPTIONAL. PASS BY REFERENCE. An array to keep progress stats. Format:
359 ;" TALLY("UNNEEDED RECORDS")=#
360 ;"NOTE: Gobal ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT") used, with format as below:
361 ;" ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM,RemotePointer,RefToNodeToBeCorrected,INFO)=""
362 ;" INFO=DataPiece^PointedToFile^PointedToReference^IENDepth^[V]
363 ;" As pointers are resolved, the entries will be KILLED from the above global
364 ;"Results: none
365 ;"
366 SET FILENUM=$GET(FILENUM) QUIT:(+FILENUM'>0)
367 IF $$ISSUBFIL^TMGFMUT2(FILENUM),FILENUM'["{" DO
368 . SET FILENUM=$$GETSPFN^TMGFMUT2(FILENUM) ;"convert 123.02 --> '123.02{123'
369 SET RPTR=$GET(RPTR)
370 SET LPTR=$GET(LPTR)
371 SET INOUT=$GET(INOUT) IF INOUT'="PTIN" SET INOUT="PTOUT"
372 IF INOUT="PTIN" GOTO UN2
373 NEW NODE SET NODE=""
374 FOR SET NODE=$ORDER(^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM,RPTR,NODE)) QUIT:(NODE="") DO
375 . NEW INFO SET INFO=""
376 . FOR SET INFO=$ORDER(^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM,RPTR,NODE,INFO)) QUIT:(INFO="") DO
377 . . NEW PCE SET PCE=+INFO
378 . . NEW P2FILE SET P2FILE=$PIECE(INFO,"^",2)
379 . . IF LPTR'=RPTR DO
380 . . . IF $PIECE(INFO,"^",5)="V" SET LPTR=LPTR_";"_$PIECE(INFO,"^",3) ;"VPTR stored as 'IEN;OREF'
381 . . . SET $PIECE(@NODE,"^",PCE)=LPTR
382 . . IF 0=1 DO ;"Build up map array to store history of connections. DON'T USE.....
383 . . . IF P2FILE=2 DO ;"2=PATIENT file.
384 . . . . SET ^TMG("TMGSIPH","MAP IN","F"_2,"F"_FILENUM,LPTR)=""
385 . . . . SET ^TMG("TMGSIPH","MAP IN","XREF",FILENUM)=$NAME(^TMG("TMGSIPH","MAP IN","F"_2,"F"_FILENUM))
386 . . . IF $DATA(^TMG("TMGSIPH","MAP IN","XREF","F"_P2FILE)) DO
387 . . . . NEW REF SET REF=$GET(^TMG("TMGSIPH","MAP IN","XREF","F"_P2FILE))
388 . . . . QUIT:(REF="")!($QLENGTH(REF)>15)
389 . . . . SET @REF@("F"_FILENUM,LPTR)=""
390 . . . . SET ^TMG("TMGSIPH","MAP IN","XREF","F"_FILENUM)=$NAME(@REF@("F"_FILENUM))
391 . . KILL ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM,RPTR,NODE,INFO)
392 . . SET TALLY("UNNEEDED RECORDS")=+$GET(TALLY("UNNEEDED RECORDS"))+1
393UN2 KILL ^TMG("TMGSIPH","NEEDED RECORDS",INOUT,FILENUM,RPTR) ;"TEMP
394 ;
395 QUIT
396 ;
397 ;
398ISDIFF(ARRAY) ;
399 ;"Purpose:to determine if record stored in ARRAY is different from that stored in local ^Global
400 ;"Input: ARRAY -- Pass by REFERENCE. This is actual remote record from server. Format:
401 ;" ARRAY(1)=ARef_"="
402 ;" ARRAY(2)="="_AValue
403 ;" ARRAY(3)=ARef_"="
404 ;" ARRAY(4)="="_AValue
405 ;"Result: 0 -- no difference
406 ;" 1 -- ARRAY has extra information
407 ;" 2 -- ARRAY has conflicting information
408 ;
409 NEW RESULT SET RESULT=0
410 NEW TMGI SET TMGI=0
411 NEW STIME SET STIME=$H
412 NEW SHOWPROG SET SHOWPROG=0
413 NEW TMGMAX,TMGMIN
414 NEW TMGCT SET TMGCT=0
415 NEW REF,VALUE
416 FOR SET TMGI=$ORDER(ARRAY(TMGI)) QUIT:(TMGI="")!(RESULT=2) DO
417 . IF (SHOWPROG=0),($$HDIFF^XLFDT($H,STIME,2)>15) DO ;"Turn on progress bar after 15 seconds.
418 . . SET SHOWPROG=1
419 . . SET TMGMIN=$ORDER(ARRAY(0))
420 . . SET TMGMAX=$ORDER(ARRAY(""),-1)
421 . IF (SHOWPROG=1),(TMGCT>500) DO
422 . . DO ProgressBar^TMGUSRIF(TMGI,"Comparing server data to local ",TMGMIN,TMGMAX,70,STIME)
423 . . SET TMGCT=0
424 . SET REF=$GET(ARRAY(TMGI))
425 . SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1)
426 . SET TMGI=TMGI+1
427 . SET TMGCT=TMGCT+1
428 . IF REF="" SET RESULT=2 QUIT
429 . SET VALUE=$EXTRACT($GET(ARRAY(TMGI)),2,10000)
430 . IF $DATA(@REF)=0 SET RESULT=1 ;"ARRAY has extra info
431 . IF $GET(@REF)=VALUE QUIT
432 . SET RESULT=2 ;"ARRAY conflicts with local value.
433 QUIT RESULT
434 ;
435 ;
436GETFLD(FILENUM,LOC,PCE)
437 ;"Purpose: Return field number cooresponding to File number, node, and piece.
438 ;"Input: FILENUM -- Fileman file number to work with.
439 ;" LOC -- the subscript location
440 ;" PCE -- the piece for the field in question
441 ;"Results: field number^field name, or 0 if not found
442 NEW RESULT SET RESULT=0
443 NEW FOUND SET FOUND=0
444 NEW FLD SET FLD=0
445 FOR SET FLD=$ORDER(^DD(FILENUM,FLD)) QUIT:(+FLD'>0)!(FOUND=1) DO
446 . NEW INFO SET INFO=$PIECE($GET(^DD(FILENUM,FLD,0)),"^",4)
447 . IF $PIECE(INFO,";",1)'=LOC QUIT
448 . IF $PIECE(INFO,";",2)'=PCE QUIT
449 . SET FOUND=1
450 . SET RESULT=FLD_"^"_$PIECE($GET(^DD(FILENUM,FLD,0)),"^",1)
451 QUIT RESULT
452 ;
453 ;
454RECSHOW(FILENUM,RPTR,ARRAY) ;
455 ;"Purpose: to show remote and local data, to allow user to see differences
456 ;"Input: FILENUM -- Fileman file (or subfile) number to work with.
457 ;" RPTR -- The record number (IEN) on the server of the record downloaded.
458 ;" If FILENUM is a subfile, then pass RPTR in standard IENS format (e.g. '4,6787,')
459 ;" ARRAY -- Pass by REFERENCE. This is actual remote record from server.
460 ;" Format as per OVERWRITE
461 ;"
462 WRITE "NOTE: ONLY DIFFERENCE WILL BE SHOWN",!,!
463 WRITE "LEGEND: REFERENCE",!
464 WRITE " L -- Local data value",!
465 WRITE " R -- Remote data value",!!
466 NEW LINECT SET LINECT=6
467 NEW TMGI SET TMGI=0
468 SET IOSL=$GET(IOSL,24)
469 ;"NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL")) QUIT:(GREF="")
470 NEW GREF SET GREF=$$GETGREF^TMGFMUT2(FILENUM,RPTR) QUIT:(GREF="")
471 NEW SL SET SL=$QLENGTH($$CREF^DILF(GREF))
472 NEW REF,VALUE,LVALUE
473 NEW DONE SET DONE=0
474 FOR SET TMGI=$ORDER(ARRAY(TMGI)) QUIT:(TMGI="")!(DONE=1) DO
475 . SET REF=$GET(ARRAY(TMGI))
476 . SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1)
477 . SET TMGI=TMGI+1
478 . IF REF="" SET DONE=1 QUIT
479 . SET VALUE=$EXTRACT($GET(ARRAY(TMGI)),2,10000)
480 . SET LVALUE=$GET(@REF)
481 . IF LVALUE=VALUE QUIT
482 . ;"Later, I will format raw nodes into readable fileman fields and values...
483 . IF $QLENGTH(REF)=(SL+2) DO
484 . . NEW LOC SET LOC=$QSUBSCRIPT(REF,SL+2)
485 . . NEW PCE,FLD
486 . . FOR PCE=1:1:$LENGTH(VALUE,"^") DO
487 . . . NEW V1,LV1,EV1,ELV1,INFO
488 . . . SET (EV1,V1)=$PIECE(VALUE,"^",PCE)
489 . . . SET (ELV1,LV1)=$PIECE(LVALUE,"^",PCE)
490 . . . IF V1=LV1 QUIT
491 . . . SET FLD=$$GETFLD(FILENUM,LOC,PCE)
492 . . . IF +FLD=0 WRITE "?? FIELD",! QUIT
493 . . . IF $DATA(^DD(FILENUM,+FLD,2))#10=1 DO
494 . . . . NEW XFRM SET XFRM=$GET(^DD(FILENUM,+FLD,2))
495 . . . . IF XFRM="" QUIT
496 . . . . NEW Y
497 . . . . SET Y=V1 XECUTE XFRM SET EV1=Y
498 . . . . SET Y=LV1 XECUTE XFRM SET ELV1=Y
499 . . . WRITE "Field -- ",$PIECE(FLD,"^",2)," (",+FLD,"):",!
500 . . . WRITE " L = ",ELV1,!
501 . . . WRITE " R = ",EV1,!
502 . . . SET LINECT=LINECT+3
503 . . . IF LINECT>(IOSL-5) DO
504 . . . . DO PressToCont^TMGUSRIF
505 . . . . SET LINECT=0
506 . ELSE DO
507 . . WRITE REF,!
508 . . WRITE " L = ",$GET(@REF),!
509 . . WRITE " R = ",VALUE,!
510 . . SET LINECT=LINECT+3
511 . . IF LINECT>(IOSL-5) DO
512 . . . DO PressToCont^TMGUSRIF
513 . . . SET LINECT=0
514 ;
515 IF LINECT>0 DO PressToCont^TMGUSRIF
516 QUIT
517 ;
518 ;
519GET01FIELD(FILENUM,ARRAY,RVALUE,LVALUE,IENS) ;
520 ;"Purpose: Extract .01 field name from data array
521 ;"Input: FILENUM -- Fileman file (of subfile) number to work with.
522 ;" ARRAY -- Pass by REFERENCE. This is actual remote record from server.
523 ;" Format as per OVERWRITE
524 ;" RVALUE -- Pass by REFERENCE. An OUT PARAMETER. Filled with .01 field from server
525 ;" LVALUE -- Pass by REFERENCE. An OUT PARAMETER Filled with .01 field from local database
526 ;" IENS -- OPTIONAL. Only needed if FILENUM is a subfile.
527 ;"Results: none
528 ;"Output: RVALUE and LVALUE are filled with the INTERNAL values of the .01 field, or "" if null
529 ;"
530 SET (RVALUE,LVALUE)=""
531 ;"NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL")) QUIT:(GREF="")
532 NEW GREF SET GREF=$$GETGREF^TMGFMUT2(FILENUM,.IENS) QUIT:(GREF="")
533 NEW SL SET SL=$QLENGTH($$CREF^DILF(GREF))
534 NEW REF,RNODE,LNODE
535 NEW DONE SET DONE=0
536 NEW TMGI SET TMGI=0
537 FOR SET TMGI=$ORDER(ARRAY(TMGI)) QUIT:(TMGI="")!(DONE=1) DO
538 . SET REF=$GET(ARRAY(TMGI))
539 . SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1)
540 . SET TMGI=TMGI+1
541 . IF REF="" SET DONE=1 QUIT
542 . SET RNODE=$EXTRACT($GET(ARRAY(TMGI)),2,10000)
543 . SET LNODE=$GET(@REF)
544 . ;"Later, I will format raw nodes into readable fileman fields and values...
545 . IF $QLENGTH(REF)=(SL+2) DO
546 . . NEW LOC SET LOC=$QSUBSCRIPT(REF,SL+2)
547 . . IF LOC'=0 QUIT
548 . . SET RVALUE=$PIECE(RNODE,"^",1)
549 . . SET LVALUE=$PIECE(LNODE,"^",1)
550 . . SET DONE=1
551 ;
552 QUIT
553 ;
554 ;
555GETTARGETIEN(FILENUM,ARRAY,TARGETIEN) ;
556 ;"Purpose: To determine if a local record should be overwritten with record from server.
557 ;" Ask user directly if not able to automically determine.
558 ;"Input: FILENUM -- Fileman file (or subfile) number to work with.
559 ;" ARRAY -- Pass by REFERENCE. This is actual remote record from server. Format:
560 ;" ARRAY(1)=ARef_"="
561 ;" ARRAY(2)="="_AValue
562 ;" ARRAY(3)=ARef_"="
563 ;" ARRAY(4)="="_AValue
564 ;" NOTE: IEN of array doesn't match input TARGETIEN, then IEN of array will be changed to it.
565 ;" TARGETIEN -- Required. PASS BY REFERENCE. an IN & OUT PARAMETER.
566 ;" If FILENUM is a subfile, then pass TARGETIEN in standard IENS format.
567 ;" INPUT: The initially planned location for storing the array
568 ;" OUTPUT: This is the pointer of where the record should be stored locally
569 ;"Result: "OVERWRITE" = OVERWRITE record currently stored at TARGETIEN
570 ;" "ABORT" = User abort or error occurred.
571 ;" "USELOCAL" = Dump server data, and just use record already at TARGETIEN
572 ;"TARGETIEN pointer may be changed to new target record location.
573 NEW Y,NARRAY,%
574 NEW R01VALUE,L01VALUE
575 NEW RESULT SET RESULT="OVERWRITE" ;"default to overwriting
576 SET TARGETIEN=$GET(TARGETIEN)
577 IF +TARGETIEN'>0 DO GOTO OVWDN
578 . SET RESULT="ABORT"
579 SET FILENUM=+$GET(FILENUM)
580 NEW RPTR SET RPTR=+$$IENOFARRAY(FILENUM,.ARRAY,TARGETIEN)
581 IF TARGETIEN["," DO ;"i.e. is an IENS
582 . NEW TEMP SET TEMP=TARGETIEN
583 . SET $PIECE(TEMP,",",1)=RPTR
584 . SET RPTR=TEMP ;"convert RPTR into an IENS
585 IF +RPTR'>0 DO GOTO OVWDN
586 . SET RESULT="ABORT"
587 IF $GET(^TMG("TMGSIPH",".01 VALUE",FILENUM,RPTR))="" DO
588 . DO GET01FIELD(FILENUM,.ARRAY,.R01VALUE,,RPTR) ;"Extract .01 field name from data array, before relocated
589 . SET ^TMG("TMGSIPH",".01 VALUE",FILENUM,RPTR)=R01VALUE ;"Needed elsewhere for faster processing of future records.
590 IF TARGETIEN'=RPTR DO GOTO:(RESULT="ABORT") OVWDN
591 . NEW TEMP SET TEMP=$$RLOCARRAY(FILENUM,TARGETIEN,.ARRAY,.NARRAY) ;"Relocate array (change IEN)
592 . IF TEMP=-1 SET RESULT="ABORT" QUIT
593 . KILL ARRAY
594 . MERGE ARRAY=NARRAY
595 NEW DIFF SET DIFF=$$ISDIFF(.ARRAY) ;" 0=no diff, 1=ARRAY has extra info, 2=ARRAY has conflicting info
596 IF DIFF=0 SET RESULT="USELOCAL" GOTO OVWDN
597 IF DIFF=1 SET RESULT="OVERWRITE" GOTO OVWDN
598 ;
599 DO GET01FIELD(FILENUM,.ARRAY,.R01VALUE,.L01VALUE,RPTR) ;
600 IF R01VALUE'=L01VALUE DO GOTO OVWDN ;"If .01 values are different, so move TARGETIEN to new location
601 . SET TARGETIEN=$$APPENDIEN(FILENUM,RPTR) ;"RPTR not used unless dealing with subfile.
602 . SET RESULT=$SELECT((TARGETIEN>0):"OVERWRITE",1:"ABORT")
603 ;
604 IF $GET(^DD(FILENUM,.01,0))["DINUM" SET RESULT="OVERWRITE" GOTO OVWDN ;"translation of pointer not allowed
605 NEW MENU,USRSLCT
606 SET USRSLCT=$GET(^TMG("TMGSIPH","CONFLICT HANDL",FILENUM))
607 IF USRSLCT'="" GOTO OW3
608 ;
609OW2 WRITE #
610 NEW FNAME SET FNAME=$$FILENAME^TMGFMUT2(FILENUM)
611 KILL MENU
612 set MENU(0)="<<!!CONFLICT FOUND!!>> OVERWRITE LOCAL DATA IN FILE ["_FNAME_"] ?"
613 set MENU(1)="VIEW local and remote raw data"_$char(9)_"View"
614 set MENU(2)="OVERWRITE local data."_$char(9)_"Overwrite1"
615 set MENU(3)="Store record in NEW location."_$char(9)_"ChangeIEN"
616 set MENU(4)="Use LOCAL data, not remote data from server."_$char(9)_"UseLocal"
617 set MENU(5)="FIND a local record to use instead."_$char(9)_"FindLocal"
618 set MENU(6)="Abort"_$char(9)_"Abort"
619 ;
620 WRITE "File = ",FNAME,"; Record .01 field = "_R01VALUE,!
621 SET USRSLCT=$$Menu^TMGUSRIF(.MENU,"")
622 IF USRSLCT="^" SET USRSLCT="Abort"
623 IF USRSLCT=0 set USRSLCT=""
624 IF USRSLCT="FindLocal" DO GOTO:(+Y>0) OVWDN
625 . NEW X,DIC
626 . IF $$ISSUBFIL^TMGFMUT2(FILENUM) DO
627 . . SET DIC=$$GETGREF^TMGFMUT2(FILENUM,TARGETIEN)
628 . ELSE SET DIC=FILENUM
629 . SET DIC(0)="MAEQ"
630 . DO ^DIC WRITE !
631 . IF +Y'>0 QUIT
632 . SET RESULT="OVERWRITE"
633 . SET $PIECE(TARGETIEN,",",1)=+Y
634 IF USRSLCT="Abort" SET RESULT="ABORT" GOTO OVWDN
635 IF USRSLCT="View" DO RECSHOW(FILENUM,RPTR,.ARRAY) GOTO OW2
636 SET %=2
637 WRITE "ALWAYS do this for file ["_FNAME_"]"
638 DO YN^DICN WRITE !
639 IF %=-1 SET RESULT="ABORT" GOTO OVWDN
640 IF %=2 SET ^TMG("TMGSIPH","CONFLICT HANDL",FILENUM)=""
641 ELSE SET ^TMG("TMGSIPH","CONFLICT HANDL",FILENUM)=USRSLCT
642OW3 IF USRSLCT="Overwrite1" DO GOTO OVWDN
643 . SET RESULT="OVERWRITE"
644 IF USRSLCT="ChangeIEN" DO GOTO OVWDN
645 . SET TARGETIEN=$$APPENDIEN(FILENUM,RPTR) ;"RPTR not used unless dealing with subfile.
646 . SET RESULT=$SELECT((TARGETIEN>0):"OVERWRITE",1:"ABORT")
647 IF USRSLCT="UseLocal" DO GOTO OVWDN
648 . SET RESULT="USELOCAL"
649 GOTO OW2
650 ;
651OVWDN QUIT RESULT
652 ;
Note: See TracBrowser for help on using the repository browser.