Changeset 894 for cprs/branches/tmg-cprs/m_files/TMGRPC1C.m
- Timestamp:
- Jul 25, 2010, 2:51:23 PM (15 years ago)
- File:
-
- 1 edited
-
cprs/branches/tmg-cprs/m_files/TMGRPC1C.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
cprs/branches/tmg-cprs/m_files/TMGRPC1C.m
r796 r894 1 QUIT 1 TMGRPC1C ;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 ; 37 GETDEFNL() 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 ; 56 GDFNDN QUIT RESULT 57 ; 58 ; 59 ENSUREDIV(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 ; 71 GETLOCFPATH(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 ; 107 GETDROPPATH(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) 119 GDPDN quit Result 120 121 122 DOWNLOAD(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 157 UPLOAD(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 197 UpDone set RESULT=resultMsg 198 quit 199 200 201 DOWNDROP(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 256 DnDBxDone 257 set RESULT=resultMsg 258 quit 259 260 261 UPLDDROP(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 315 UpDBxDone 316 set RESULT=resultMsg 317 quit 318 319 320 ENCODE(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 367 EncodeDone 368 quit 369 370 371 HEXCODER(INPUT) 372 ;"Purpose: to encode the input string. Currently using simple hex encoding/ 373 quit $$STRB2H^TMGSTUTL(.INPUT,0,1) 374 375 376 B64CODER(INPUT) 377 ;"Purpose: to encode the input string via UUENCODE (actually Base64) 378 quit $$ENCODE^RGUTUU(.INPUT) 379 380 B64DECODER(INPUT) 381 ;"Purpose: to encode the input string via UUENCODE (actually Base64) 382 quit $$DECODE^RGUTUU(.INPUT) 383 384 385 DECODE(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 430 DecodeDone 431 quit 432 ; 433 ; 434 DELIMAGE(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 ; 502 DIDN QUIT 503 ; 504 UNRETRACT(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 539 URDN QUIT
Note:
See TracChangeset
for help on using the changeset viewer.
