source: cprs/branches/tmg-cprs/m_files/TMGRPC1C.m@ 1407

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

interval update
File size: 27.7 KB
Line 
1TMGRPC1C ;TMG/kst-RPC Functions ;07/09/10
2 ;;1.0;TMG-LIB;**1**;07/09/10
3
4 ;"TMG RPC FUNCTIONS especially related to imaging.
5
6 ;"Kevin Toppenberg MD
7 ;"GNU General Public License (GPL) applies
8 ;"7/09/10
9
10 ;"=======================================================================
11 ;" RPC -- Public Functions.
12 ;"=======================================================================
13 ;"GETDEFNL() -- return the default Network Location (file 2005.2) entry
14 ;"GETLOCFPATH(FPATH,LOCIEN) -- get local (absolute) path for storing on host file system
15 ;"GETDROPPATH(LOCIEN,DropBox) -- return path to local dropbox.
16 ;"DOWNLOAD(GREF,FPATH,FNAMEW $$,LOCIEN)
17 ;"UPLOAD(RESULT,FPATH,FNAME,LOCIEN,ARRAY)
18 ;"DOWNDROP(RESULT,FPATH,FNAME,LOCIEN) -- Download drop box file
19 ;"UPLDDROP(RESULT,FPATH,FNAME,LOCIEN) -- Upload Dropbox File
20 ;"DELIMAGE(RESULT,IMGIEN,MODE,REASON) -- Delete or Retract Image
21 ;"UNRETRACT(RESULT,TMGIEN) -- reverse retraction process from DELIMAGE above.
22 ;"=======================================================================
23 ;"PRIVATE API FUNCTIONS
24 ;"=======================================================================
25 ;"ENCODE(GRef,incSubscr,encodeFn)
26 ;"DECODE(GRef,incSubscr,decodeFn)
27 ;"$$HEXCODER(INPUT) ;encode the input string. Currently using simple hex encoding/
28 ;"$$B64CODER(INPUT) ;encode the input string via UUENCODE (actually Base64)
29 ;"$$B64DECODER(INPUT) ;encode the input string via UUDECODE (actually Base64)
30 ;"ENSUREDIV(FPATH,LOCIEN) ;Ensure that the path ends with an appropriate node divider.
31
32 ;"=======================================================================
33 ;"Dependancies:
34 ;" DIK, TMGDEBUG
35 ;"=======================================================================
36 ;
37GETDEFNL()
38 ;"Purpose: to return the default Network Location (file 2005.2) entry
39 ;"Input: None
40 ;"Results: Returns IEN in file 2005.2, or 1 if some problem.
41 ;
42 NEW RESULT SET RESULT=1 ;"Default
43 ;
44 ;"First get default INSTITUTION, stored in KERNEL SYSTEM PARAMETERS file.
45 NEW INSTPTR SET INSTPTR=+$PIECE($GET(^XTV(8989.3,1,"XUS")),"^",17) ;"Ptr to file $4 (Institution)
46 IF INSTPTR'>0 GOTO GDFNDN
47 ;
48 ;"Now get IMAGING SITE PARAMETERS for Institution Name
49 NEW IMGSPPTR SET IMGSPPTR=+$ORDER(^MAG(2006.1,"B",INSTPTR,0))
50 IF IMGSPPTR'>0 GOTO GDFNDN
51 ;
52 ;"Now get NETWORK LOCATION stored in IMAGING SITE PARAMETERS record
53 NEW LOCPTR SET LOCPTR=+$PIECE($GET(^MAG(2006.1,IMGSPPTR,0)),"^",3)
54 IF LOCPTR>0 SET RESULT=LOCPTR
55 ;
56GDFNDN QUIT RESULT
57 ;
58 ;
59ENSUREDIV(FPATH,LOCIEN) ;
60 ;"Purpose: Ensure that the path ends with an appropriate node divider.
61 set FPATH=$GET(FPATH,"/")
62 set LOCIEN=+$GET(LOCIEN) if LOCIEN'>0 set LOCIEN=$$GETDEFNL()
63
64 ;"default is "/" NOTE: CUSTOM FIELD
65 new NodeDiv set NodeDiv=$piece($get(^MAG(2005.2,LOCIEN,22701),"/"),"^",1)
66
67 new EndChar set EndChar=$extract(FPATH,$length(FPATH))
68 if EndChar'=NodeDiv set FPATH=FPATH_NodeDiv
69 quit FPATH
70 ;
71GETLOCFPATH(FPATH,LOCIEN) ;
72 ;"Purpose: to get local (absolute) path for storing on host file system
73 ;"Input: FPATH -- the file path up to, but not including, the filename
74 ;" Use '/' to NOT specify any subdirectory
75 ;" [optional] default is '/'
76 ;" LOCIEN-- [optional] -- the IEN from file 2005.2 (network location) to download from
77 ;" NOTE: DEPRECIATED. Should pass "" to allow code to lookup default
78 ;" values stored in KERNEL SYSTEM PARAMETERS etc.
79 ;" Note: For security reasons, all path requests will be considered relative to a root path.
80 ;" e.g. if user asks for /download/SomeFile.jpg, this function will retrieve:
81 ;" /var/local/Dir1/Dir2/download/SomeFile.jpg
82 ;" This root path is found in custom field 22701 in file 2005.2
83 ;"Returns: A path, that can be passed to KERNEL calls for HFS calls.
84 ;" NOTE: Result WILL end with a node divider
85 ;
86 set FPATH=$GET(FPATH,"/")
87 set LOCIEN=+$GET(LOCIEN) if LOCIEN'>0 set LOCIEN=$$GETDEFNL()
88
89 ;"NOTE: CUSTOM FIELD
90 new PathRoot set PathRoot=$piece($get(^MAG(2005.2,LOCIEN,22700)),"^",1)
91
92 ;"default is "/" NOTE: CUSTOM FIELD
93 new NodeDiv set NodeDiv=$piece($get(^MAG(2005.2,LOCIEN,22701),"/"),"^",1)
94
95 new EndRoot set EndRoot=$extract(PathRoot,$length(PathRoot))
96 new StartPath set StartPath=$extract(FPATH,1)
97
98 if (EndRoot=NodeDiv)&(StartPath=NodeDiv) do
99 . set FPATH=$extract(FPATH,2,1024)
100 else if (EndRoot'=NodeDiv)&(StartPath'=NodeDiv) do
101 . set PathRoot=PathRoot_NodeDiv
102
103 set FPATH=$$ENSUREDIV(PathRoot_FPATH,LOCIEN)
104 quit FPATH
105 ;
106 ;
107GETDROPPATH(LOCIEN,DropBox) ;
108 ;"Purpose: return path to local dropbox.
109 ;"Input: LOCIEN -- the IEN from file 2005.2 (network location)
110 ;" DropBox -- PASS BY REFERENCE. AN OUT PARAMETER.
111 ;"Results: 1 if OK, -1 if error
112 set LOCIEN=+$GET(LOCIEN)
113 if LOCIEN'>0 set LOCIEN=$$GETDEFNL()
114 new Result set Result=1
115 set DropBox=$piece($get(^MAG(2005.2,LOCIEN,22702)),"^",1)
116 if DropBox="" do goto GDPDN
117 . set Result=-1
118 set DropBox=$$ENSUREDIV(DropBox,LOCIEN)
119GDPDN quit Result
120
121
122DOWNLOAD(GREF,FPATH,FNAME,LOCIEN)
123 ;"SCOPE: Public
124 ;"Purpose: To provide an entry point for a RPC call from a client. The client
125 ;" will ask for a given file, and it will be passed back in the form
126 ;" of an array (in BASE64 ascii encoding)
127 ;"Input: GREF -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE)
128 ;" FPATH -- the file path up to, but not including, the filename
129 ;" Use '/' to NOT specify any subdirectory
130 ;" [optional] default is '/'
131 ;" FNAME -- the name of the file to pass back
132 ;" LOCIEN-- [optional] -- the IEN from file 2005.2 (network location) to download from
133 ;" NOTE: DEPRECIATED. Should pass "" to allow code to lookup default
134 ;" values stored in KERNEL SYSTEM PARAMETERS etc.
135 ;" Note: For security reasons, all path requests will be considered relative to a root path.
136 ;" e.g. if user asks for /download/SomeFile.jpg, this function will retrieve:
137 ;" /var/local/Dir1/Dir2/download/SomeFile.jpg
138 ;" This root path is found in custom field 22701 in file 2005.2
139 ;"Output: results are passed out in @GREF
140 ;" @GREF@(0)=success; 1=success, 0=failure
141 ;" @GREF@(1..xxx) = actual data
142
143 set FNAME=$get(FNAME)
144 set LOCIEN=+$GET(LOCIEN)
145 if LOCIEN'>0 set LOCIEN=$$GETDEFNL()
146 set FPATH=$$GETLOCFPATH($GET(FPATH),LOCIEN) ;
147
148 set GREF="^TMP(""DOWNLOAD^TMGRPC1"","_$J_")"
149 kill @GREF
150 set @GREF@(0)=$$BFTG^TMGBINF(.FPATH,.FNAME,$name(@GREF@(1)),3)
151
152 do ENCODE($name(@GREF@(1)),3)
153
154 quit
155
156
157UPLOAD(RESULT,FPATH,FNAME,LOCIEN,ARRAY)
158 ;"SCOPE: Public
159 ;"RPC That calls this: TMG UPLOAD FILE
160 ;"Purpose: To provide an entry point for a RPC call from a client. The client
161 ;" will provide a file for upload (in BASE64 ascii encoding)
162 ;"Input: GREF -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE)
163 ;" FPATH -- the file path up to, but not including, the filename
164 ;" Use '/' to NOT specify any subdirectory
165 ;" [optional] default is '/'
166 ;" FNAME -- the name of the file to pass back
167 ;" LOCIEN-- [optional] -- the IEN from file 2005.2 (network location) to upload to
168 ;" NOTE: DEPRECIATED. Should pass "" to allow code to lookup default
169 ;" Note: For security reasons, all path requests will be considered relative to a root path.
170 ;" e.g. if user asks for /download/SomeFile.jpg, this function will retrieve:
171 ;" /var/local/Dir1/Dir2/download/SomeFile.jpg
172 ;" This root path is found in custom field 22701 in file 2005.2
173 ;" ARRAY -- the array that will hold the file, in BASE64 ascii encoding
174 ;"Output: results are passed out in RESULT: 1^SuccessMessage or 0^FailureMessage
175
176 new result
177 new resultMsg set resultMsg="1^Successful Upload"
178
179 set ^TMP("UPLOAD^TMGRPC1",$J,"FPATH")=$GET(FPATH)
180 set ^TMP("UPLOAD^TMGRPC1",$J,"FNAME")=$GET(FNAME)
181 set ^TMP("UPLOAD^TMGRPC1",$J,"LOCIEN")=$GET(LOCIEN)
182
183 if $data(ARRAY)=0 set resultMsg="0^No data received to upload" goto UpDone
184 set FNAME=$get(FNAME)
185 if FNAME="" do goto UpDone
186 . set resultMsg="0^No file name received"
187
188 set LOCIEN=+$GET(LOCIEN) if LOCIEN'>0 set LOCIEN=$$GETDEFNL()
189
190 set FPATH=$$GETLOCFPATH($GET(FPATH),LOCIEN) ;
191
192 do DECODE("ARRAY(0)",1)
193
194 if $$GTBF^TMGBINF("ARRAY(0)",1,FPATH,FNAME)=0 do
195 . set resultMsg="0^Error while saving file"
196
197UpDone set RESULT=resultMsg
198 quit
199
200
201DOWNDROP(RESULT,FPATH,FNAME,LOCIEN) ;"i.e. Download drop box file
202 ;"SCOPE: Public
203 ;"RPC That calls this: TMG DOWNLOAD FILE DROPBOX
204 ;"Purpose: To provide an entry point for a RPC call from a client. The client
205 ;" will request for the file to be placed into in a 'dropbox' file
206 ;" location that both the client and server can access. File may be
207 ;" moved from there to its final destination by the client.
208 ;" This method alloows file-hiding ability on the server side.
209 ;"Input: RESULT -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE)
210 ;" FPATH -- the file path up to, but not including, the filename. This
211 ;" is the path that the file is stored at (relative to a root path,
212 ;" see comments below). It is NOT the path of the dropbox.
213 ;" Use '/' to NOT specify any subdirectory
214 ;" [optional] default is '/'
215 ;" FNAME -- the name of the file to be uploaded. Note: This is also the
216 ;" name of the file to be put into the dropbox. It is the
217 ;" responsibility of the client to ensure that there is not already
218 ;" a similarly named file in the dropbox before requesting a file
219 ;" be put there. It is the responsibility of the client to delete
220 ;" the file from the drop box.
221 ;" LOCIEN-- [optional] -- the IEN from file 2005.2 (network location) to download from
222 ;" NOTE: DEPRECIATED. Should pass "" to allow code to lookup default
223 ;" Note: For security reasons, all path requests will be considered relative to a root path.
224 ;" e.g. if user asks for /download/SomeFile.jpg, this function will retrieve:
225 ;" /var/local/Dir1/Dir2/download/SomeFile.jpg
226 ;" This root path is found in custom field 22701 in file 2005.2
227 ;" Also: dropbox location is obtained from custom field 22702 in file 2005.2
228 ;"NOTE RE DROPBOX:
229 ;" This system is designed for a system where by the server and the client have a
230 ;" shared filesystem, but the directory paths will be different. For example:
231 ;" Linux server has dropbox at: /mnt/WinServer/dropbox/
232 ;" Windows Client has access to dropbox at: V:\Dropbox\
233
234 ;"Output: results are 1^Success^FileSize (in bytes), or 0^Error Message
235
236 new DropBox,moveResult,SrcNamePath
237
238 new resultMsg set resultMsg="1^Successful Download"
239
240 set FNAME=$get(FNAME) if FNAME="" do goto DnDBxDone
241 . set resultMsg="0^No file name received"
242
243 set FPATH=$$GETLOCFPATH(.FPATH,.LOCIEN) ;
244
245 if $$GETDROPPATH(.LOCIEN,.DropBox)=-1 do goto DnDBxDone
246 . set resultMsg="0^Dropbox location not configured in file 2005.2, IEN "_LOCIEN_", field 22702"
247
248 set SrcNamePath=FPATH_FNAME
249
250 set moveResult=$$Copy^TMGKERNL(SrcNamePath,DropBox)
251 if moveResult>0 do
252 . set resultMsg="0^Move failed, returning OS error code: "_moveResult
253 else do
254 . set resultMsg=resultMsg_"^"_$$FileSize^TMGKERNL(SrcNamePath)
255
256DnDBxDone
257 set RESULT=resultMsg
258 quit
259
260
261UPLDDROP(RESULT,FPATH,FNAME,LOCIEN) ;"i.e. Upload Dropbox File
262 ;"SCOPE: Public
263 ;"RPC That calls this: TMG UPLOAD FILE DROPBOX
264 ;"Purpose: To provide an entry point for a RPC call from a client. The client
265 ;" will put the file in a 'dropbox' file location that both the client
266 ;" and server can access. File will be moved from there to its final
267 ;" destination. This will provide file-hiding ability on the server side.
268 ;"Input: RESULT -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE)
269 ;" FPATH -- the file path up to, but not including, the filename. This
270 ;" is the path to store the file at. (relative to a root path,
271 ;" see comments below). It is NOT the path of the dropbox.
272 ;" Use '/' to NOT specify any subdirectory
273 ;" [optional] default is '/'
274 ;" FNAME -- the name of the file to be uploaded. Note: This is also the
275 ;" name of the file to be pulled from the dropbox. It is the
276 ;" responsibility of the client to ensure that there is not already
277 ;" a similarly named file in the dropbox before depositing a file there.
278 ;" The server will remove the file from the dropbox, unless there is
279 ;" an error with the host OS (which will be returned as an error message)
280 ;" LOCIEN-- [optional] -- the IEN from file 2005.2 (network location) to upload to
281 ;" NOTE: DEPRECIATED. Should pass "" to allow code to lookup default
282 ;" Note: For security reasons, all path requests will be considered relative to a root path.
283 ;" e.g. if user asks for /download/SomeFile.jpg, this function will retrieve:
284 ;" /var/local/Dir1/Dir2/download/SomeFile.jpg
285 ;" This root path is found in custom field 22700 in file 2005.2
286 ;" Also: dropbox location is obtained from custom field 22702 in file 2005.2
287 ;"NOTE RE DROPBOX:
288 ;" This system is designed for a system where by the server and the client have a
289 ;" shared filesystem, but the directory paths will be different. For example:
290 ;" Linux server has dropbox at: /mnt/WinServer/dropbox/
291 ;" Windows Client has access to dropbox at: V:\Dropbox\
292
293 ;"Output: results are passed out in RESULT:
294 ;" 1^SuccessMessage or 0^FailureMessage
295
296 new SrcNamePath,DestNamePath,moveResult
297 new resultMsg set resultMsg="1^Successful Upload"
298
299 set FNAME=$get(FNAME)
300 if FNAME="" set resultMsg="0^No file name received" goto UpDBxDone
301
302 new DropBox
303 if $$GETDROPPATH(.LOCIEN,.DropBox)=-1 do goto UpDBxDone
304 . set resultMsg="0^Dropbox location not configured in file 2005.2, IEN "_LOCIEN_", field 22702"
305
306 set FPATH=$$GETLOCFPATH($GET(FPATH),LOCIEN) ;
307
308 set SrcNamePath=DropBox_FNAME
309 set DestNamePath=FPATH_FNAME
310
311 set moveResult=$$Move^TMGKERNL(SrcNamePath,DestNamePath)
312 if moveResult>0 do
313 . set resultMsg="0^Move failed, returning OS error code: "_moveResult
314
315UpDBxDone
316 set RESULT=resultMsg
317 quit
318
319
320ENCODE(GRef,incSubscr,encodeFn)
321 ;"Purpose: ENCODE a BINARY GLOBAL.
322 ;"Input:
323 ;" GRef-- Global reference of the SOURCE binary global array, in fully resolved
324 ;" (closed root) format.
325 ;" Note:
326 ;" At least one subscript must be numeric. This will be the incrementing
327 ;" subscript (i.e. the subscript that $$BIN2WP^TMGBINWP will increment
328 ;" to store each new global node). This subscript need not be the final
329 ;" subscript. For example, to load into a WORD PROCESSING field, the
330 ;" incrementing node is the second-to-last subscript; the final subscript
331 ;" is always zero.
332 ;" REQUIRED
333 ;" incSubscr-- (required) Identifies the incrementing subscript level, for the source global
334 ;" For example, if you pass ^TMP(115,1,1,0) as the global_ref parameter and
335 ;" pass 3 as the inc_subscr parameter, $$BIN2GBL will increment the third
336 ;" subscript, such as ^TMP(115,1,x), but will WRITE notes at the full global
337 ;" reference, such as ^TMP(115,1,x,0).
338 ;" REQUIRED
339 ;" encodeFn- (OPTIONAL) the name of a function that will encode a line of data.
340 ;" e.g. "CODER^ZZZCODER" or "LOCALCODER". The function should
341 ;" take one input variable (the line of raw binary data), and return a converted
342 ;" line. e.g.
343 ;" CODER(INPUT)
344 ;" ... ;"convert INPUT to RESULT
345 ;" QUIT RESULT
346 ;" default value is B64CODER^TMGRPC1
347 ;"
348 ;"Output: @GRef is converted to encoded data
349 ;"Result: None
350
351 if $get(GRef)="" goto EncodeDone
352 if $get(incSubscr)="" goto EncodeDone
353
354 set encodeFn=$get(encodeFn,"B64CODER")
355
356 new encoder
357 set encoder="set temp=$$"_encodeFn_"(.temp)"
358
359 for do quit:(GRef="")
360 . new temp
361 . set temp=$get(@GRef)
362 . if temp="" set GRef="" quit
363 . xecute encoder ;"i.e. set temp=$$encoderFn(.temp)
364 . set @GRef=temp
365 . set GRef=$$NEXTNODE^TMGBINF(GRef,incSubscr,1,1)
366
367EncodeDone
368 quit
369
370
371HEXCODER(INPUT)
372 ;"Purpose: to encode the input string. Currently using simple hex encoding/
373 quit $$STRB2H^TMGSTUTL(.INPUT,0,1)
374
375
376B64CODER(INPUT)
377 ;"Purpose: to encode the input string via UUENCODE (actually Base64)
378 quit $$ENCODE^RGUTUU(.INPUT)
379
380B64DECODER(INPUT)
381 ;"Purpose: to encode the input string via UUENCODE (actually Base64)
382 quit $$DECODE^RGUTUU(.INPUT)
383
384
385DECODE(GRef,incSubscr,decodeFn)
386 ;"Purpose: ENCODE a BINARY GLOBAL.
387 ;"Input:
388 ;" GRef-- Global reference of the SOURCE binary global array, in fully resolved
389 ;" (closed root) format.
390 ;" Note:
391 ;" At least one subscript must be numeric. This will be the incrementing
392 ;" subscript (i.e. the subscript that $$BIN2WP^TMGBINWP will increment
393 ;" to store each new global node). This subscript need not be the final
394 ;" subscript. For example, to load into a WORD PROCESSING field, the
395 ;" incrementing node is the second-to-last subscript; the final subscript
396 ;" is always zero.
397 ;" REQUIRED
398 ;" incSubscr-- (required) Identifies the incrementing subscript level, for the source global
399 ;" For example, if you pass ^TMP(115,1,1,0) as the global_ref parameter and
400 ;" pass 3 as the inc_subscr parameter, $$BIN2GBL will increment the third
401 ;" subscript, such as ^TMP(115,1,x), but will WRITE notes at the full global
402 ;" reference, such as ^TMP(115,1,x,0).
403 ;" REQUIRED
404 ;" decodeFn- (OPTIONAL) the name of a function that will decode a line of data.
405 ;" e.g. "DECODER^ZZZCODER" or "DECODER". The function should take
406 ;" one input variable (the line of encoded data), and return a decoded line. e.g.
407 ;" DECODER(INPUT)
408 ;" ... ;"convert INPUT to RESULT
409 ;" QUIT RESULT
410 ;" default value is B64DECODER^TMGRPC1
411 ;"
412 ;"Output: @GRef is converted to decoded data
413 ;"Result: None
414
415 if $get(GRef)="" goto DecodeDone
416 if $get(incSubscr)="" goto DecodeDone
417 set decodeFn=$get(decodeFn,"B64DECODER")
418
419 new decoder
420 set decoder="set temp=$$"_decodeFn_"(.temp)"
421
422 for do quit:(GRef="")
423 . new temp
424 . set temp=$get(@GRef)
425 . if temp="" set GRef="" quit
426 . xecute decoder ;"i.e. set temp=$$decoderFn(.temp)
427 . set @GRef=temp
428 . set GRef=$$NEXTNODE^TMGBINF(GRef,incSubscr,1,1)
429
430DecodeDone
431 quit
432 ;
433 ;
434DELIMAGE(RESULT,TMGIEN,TMGMODE,TMGREASON) ;
435 ;"Purpose: Provide functionality for deleting or retacting an image from CPRS
436 ;"NOTE: MAGG IMAGE DELETE is not used because it does things like archive
437 ;" the images before deletion. I don't have this system fully integrated
438 ;" In the future, that could possibly be used.
439 ;"NOTE: This function DOES NOT CHECK PERMISSIONS for deleting the images.
440 ;" It is assumed that that has been doine PRIOR to calling this function.
441 ;"NOTE: It mode is to retract (see below), then the image will not be
442 ;" actually be deleted. It will just be marked as retracted and
443 ;" set so that it doesn't appear in CPRS.
444 ;" --But if mode is to delete, then the record in the IMAGE file
445 ;" will be deleted AND ALSO the actual image (with no backup.) This
446 ;" mode is for deletion before signing, and the image has not been
447 ;" formally entered into the record.
448 ;"Input: RESULT -- an OUT Parameter. (See results below)
449 ;" TMGIEN -- the IEN in the IMAGE file (2005) to remove
450 ;" TMGMODE -- 0 for NONE <-- just exit and do nothing
451 ;" 1 for DELETE <-- delete record and image file
452 ;" 2 for RETRACT <-- mark record as retracted, don't delete iamge file.
453 ;" TMGREASON -- String (10-60 chars) giving reason for deletion.
454 ;" This is only used for mode RETRACT.
455 ;"Output: RESULT="1^Success" or "-1^Some Failure Message" <-- set up as SINGLE VALUE type in RPC BROKER
456 ;
457 SET RESULT="1^Success" ;"Default to success
458 SET TMGIEN=$GET(TMGIEN,0)
459 IF +TMGIEN'>0 DO GOTO DIDN
460 . SET RESULT="-1^Invalid IEN: "_TMGIEN
461 SET TMGIEN=+TMGIEN
462 SET TMGMODE=+$GET(TMGMODE)
463 IF TMGMODE=0 DO GOTO DIDN
464 . SET RESULT="1^Delete not done because mode=0"
465 SET TMGREASON=$GET(TMGREASON,"(Not Specified)")
466 NEW TMGPTR SET TMGPTR=+$PIECE($GET(^MAG(2005,TMGIEN,2)),"^",8) ;"2;8 ==> Field 18 = PARENT DATA FILE IMAGE POINTER
467 IF TMGPTR'>0 DO GOTO DIDN
468 . SET RESULT="-1^FILE 2005, IEN "_TMGIEN_", Field 18 does not point to valid record in file 8925.91"
469 NEW TMGTIUPTR SET TMGTIUPTR=+$PIECE($GET(^TIU(8925.91,TMGPTR,0)),"^",1) ;"0;1 ==> Field .01 = DOCUMENT (ptr to 8925)
470 IF TMGMODE=1 DO GOTO:(+RESULT'>0) DIDN ;"Delete mode
471 . NEW FNAME SET FNAME=$PIECE($GET(^MAG(2005,TMGIEN,0)),"^",2)
472 . NEW TMGPATH SET TMGPATH=$$GETLOCFPATH()
473 . NEW TMGARRAY,DELRSLT
474 . SET TMGARRAY(FNAME)=""
475 . SET DELRSLT=$$DEL^%ZISH(TMGPATH,"TMGARRAY")
476 . IF DELRSLT=0 DO QUIT
477 . . SET RESULT="-1^Unable to delete file: "_TMGPATH_FNAME
478 . KILL TMGARRAY
479 . NEW FNAME2 SET FNAME2=FNAME
480 . SET $PIECE(FNAME2,",",$LENGTH(FNAME2,"."))="ABS"
481 . SET TMGARRAY(FNAME2)=""
482 . SET DELRSLT=$$DEL^%ZISH(TMGPATH,"TMGARRAY") ;"Ingnore results. Thumbnail not always present
483 . NEW DIK SET DIK="^MAG(2005,"
484 . NEW DA SET DA=TMGIEN
485 . DO ^DIK ;"Kill Record in 2005
486 ELSE IF TMGMODE=2 DO GOTO:(+RESULT'>0) DIDN ;"Retract mode
487 . NEW TMGFDA,TMGMSG,TMGIENS
488 . SET TMGIENS=TMGIEN_","
489 . SET TMGFDA(2005,TMGIENS,30)="`"_+DUZ
490 . SET TMGFDA(2005,TMGIENS,30.1)="NOW"
491 . SET TMGFDA(2005,TMGIENS,30.2)=TMGREASON
492 . SET TMGFDA(2005,TMGIENS,18)="@"
493 . ;"NOTE: Fld 17 already holds IEN of linked 8925 document
494 . DO FILE^DIE("EKT","TMGFDA","TMGMSG")
495 . IF $DATA(TMGMSG("DIERR")) DO
496 . . SET RESULT="-1^"_$$GetErrStr^TMGDEBUG(.TMGMSG)
497 DO ;"Do this for both DELETE and RETRACT modes.
498 . NEW DIK SET DIK="^TIU(8925.91,"
499 . NEW DA SET DA=TMGPTR
500 . DO ^DIK ;"Kill record in 8925.91
501 ;
502DIDN QUIT
503 ;
504UNRETRACT(RESULT,TMGIEN) ;
505 ;"Purpose: to reverse retraction process from DELIMAGE above.
506 ;"Input: RESULT -- an OUT Parameter. (See results below)
507 ;" TMGIEN -- the IEN in the IMAGE file (2005) to remove
508 ;"Output: RESULT="1^Success" or "-1^Some Failure Message" <-- set up as SINGLE VALUE type in RPC BROKER
509 SET TMGIEN=$GET(TMGIEN)
510 IF +TMGIEN'>0 DO GOTO URDN
511 . SET RESULT="-1^Invalid IEN supplied: "_TMGIEN
512 SET TMGIEN=+TMGIEN
513 NEW TIUPTR SET TIUPTR=+$PIECE($GET(^MAG(2005,TMGIEN,2)),"^",7)
514 IF TIUPTR'>0 DO GOTO URDN
515 . SET RESULT="-1^Record 2005 doesn't hold link to TIU DOCUMENT in field 17"
516 NEW TMGFDA,TMGFDA,TMGIENS
517 ;"-- Recreate TIU EXTERNAL DATA LINK record
518 KILL TMGFDA
519 SET TMGIENS="+1,"
520 SET TMGFDA(8925.91,TMGIENS,.01)=TIUPTR
521 SET TMGFDA(8925.91,TMGIENS,.02)=TMGIEN
522 DO UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG")
523 IF $DATA(TMGMSG("DIERR")) DO GOTO URDN
524 . SET RESULT="-1^"_$$GetErrStr^TMGDEBUG(.TMGMSG)
525 NEW TIUIMGPTR SET TIUIMGPTR=+$GET(TMGIEN(1))
526 IF TIUIMGPTR'>0 DO GOTO URDN
527 . SET RESULT="-1^Unable to locate recreated TIU EXTERNAL DATA LINK record"
528 ;"-- remove DELETED info from IMAGE record --
529 NEW TMGFDA,TMGFDA,TMGIENS
530 SET TMGIENS=TMGIEN_","
531 SET TMGFDA(2005,TMGIENS,30)="@"
532 SET TMGFDA(2005,TMGIENS,30.1)="@"
533 SET TMGFDA(2005,TMGIENS,30.2)="@"
534 SET TMGFDA(2005,TMGIENS,18)=TIUIMGPTR
535 DO FILE^DIE("EKT","TMGFDA","TMGMSG")
536 IF $DATA(TMGMSG("DIERR")) DO GOTO URDN
537 . SET RESULT="-1^"_$$GetErrStr^TMGDEBUG(.TMGMSG)
538
539URDN QUIT
Note: See TracBrowser for help on using the repository browser.