MAGDRPC6 ;WOIFO/EdM - Routing RPCs ; 05/18/2007 11:23
;;3.0;IMAGING;**11,30,51,54**;03-July-2009;;Build 1424
;; Per VHA Directive 2004-038, this routine should not be modified.
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
Q
;
PURGDONE(OUT,DAYS,LOCATION) ; RPC = MAG DICOM ROUTE PURGE DONE
; Purge Entries from Queue that have been sent successfully
N D0,DE,ID,IM,LIM,PR,RT,STS,TP,TX,X
I '$G(LOCATION) S OUT="-1,No Location Specified" Q
;
S OUT=0
F STS="SENT","NOT FOUND" D
. S PR="" F S PR=$O(^MAGQUEUE(2006.035,"STS",LOCATION,STS,PR)) Q:PR="" D
. . S DE="" F S DE=$O(^MAGQUEUE(2006.035,"STS",LOCATION,STS,PR,DE)) Q:DE="" D
. . . S RT=$P($G(^MAG(2005.2,DE,3)),"^",1) S:'RT RT=31
. . . S:$G(DAYS)'<1 RT=DAYS
. . . S LIM=$H-RT
. . . S D0="" F S D0=$O(^MAGQUEUE(2006.035,"STS",LOCATION,STS,PR,DE,D0)) Q:D0="" D
. . . . Q:$$FMTH^XLFDT($P($G(^MAGQUEUE(2006.035,D0,1)),"^",4)\1)'<LIM
. . . . S X=$G(^MAGQUEUE(2006.035,D0,0)),IM=$P(X,"^",1),TP=$P(X,"^",3),ID=$P(X,"^",6)
. . . . K ^MAGQUEUE(2006.035,"STS",LOCATION,STS,PR,DE,D0)
. . . . K:ID'="" ^MAGQUEUE(2006.035,"ID",ID,D0)
. . . . I IM'="",TP'="" K ^MAGQUEUE(2006.035,"DEST",DE,STS,IM,TP,D0)
. . . . K ^MAGQUEUE(2006.035,D0)
. . . . S OUT=OUT+1
. . . . Q
. . . Q
. . Q
. S DE="" F S DE=$O(^MAGQUEUE(2006.035,"DEST",DE)) Q:DE="" D
. . S IM="" F S IM=$O(^MAGQUEUE(2006.035,"DEST",DE,STS,IM)) Q:IM="" D
. . . S TP="" F S TP=$O(^MAGQUEUE(2006.035,"DEST",DE,STS,IM,TP)) Q:TP="" D
. . . . S D0="" F S D0=$O(^MAGQUEUE(2006.035,"DEST",DE,STS,IM,TP,D0)) Q:D0="" D
. . . . . S PR=$P($G(^MAGQUEUE(2006.035,D0,1)),"^",2)
. . . . . S ID=$P($G(^MAGQUEUE(2006.035,D0,0)),"^",6)
. . . . . K ^MAGQUEUE(2006.035,D0)
. . . . . K:ID'="" ^MAGQUEUE(2006.035,"ID",ID,D0)
. . . . . K ^MAGQUEUE(2006.035,"DEST",DE,STS,IM,TP,D0)
. . . . . K:PR'="" ^MAGQUEUE(2006.035,"STS",LOCATION,STS,PR,DE,D0)
. . . . . S OUT=OUT+1
. . . . . Q
. . . . Q
. . . Q
. . Q
. Q
S D0=0 F S D0=$O(^MAGQUEUE(2006.035,D0)) Q:'D0 D
. S X=$P($G(^MAGQUEUE(2006.035,D0,1)),"^",1) I X'="SENT",X'="NOT FOUND" Q
. S ID=$P($G(^MAGQUEUE(2006.035,D0,0)),"^",6)
. K ^MAGQUEUE(2006.035,D0)
. K:ID'="" ^MAGQUEUE(2006.035,"ID",ID,D0)
. S OUT=OUT+1
. Q
Q
;
REQUEUE(OUT,LOCATION) ; RPC = MAG DICOM ROUTE REQUEUE
; ReQueue Files that Failed during transmission
N D0,DE,FL,IM,PR,TP,WW,X
I '$G(LOCATION) S OUT="-1,No Location Specified" Q
;
S WW="WAITING",OUT=0
F FL="FAILED","SENDING" D
. S PR="" F S PR=$O(^MAGQUEUE(2006.035,"STS",LOCATION,FL,PR)) Q:PR="" D
. . S DE="" F S DE=$O(^MAGQUEUE(2006.035,"STS",LOCATION,FL,PR,DE)) Q:DE="" D
. . . S D0="" F S D0=$O(^MAGQUEUE(2006.035,"STS",LOCATION,FL,PR,DE,D0)) Q:D0="" D
. . . . K ^MAGQUEUE(2006.035,"STS",LOCATION,FL,PR,DE,D0)
. . . . I '$D(^MAGQUEUE(2006.035,D0,0)) K ^MAGQUEUE(2006.035,D0) Q
. . . . S $P(^MAGQUEUE(2006.035,D0,1),"^",1)=WW
. . . . S ^MAGQUEUE(2006.035,"STS",LOCATION,WW,PR,DE,D0)=""
. . . . S X=^MAGQUEUE(2006.035,D0,0),IM=$P(X,"^",1),TP=$P(X,"^",3)
. . . . I IM'="",TP'="" K ^MAGQUEUE(2006.035,"DEST",DE,FL,IM,TP,D0)
. . . . I IM'="",TP'="" S ^MAGQUEUE(2006.035,"DEST",DE,WW,IM,TP,D0)=""
. . . . S OUT=OUT+1
. . . . Q
. . . Q
. . Q
. Q
Q
;
REMOBSO(OUT,UPTO,LOCATION) ; RPC = MAG DICOM ROUTE REMOVE OBSO
; Purge Unprocessed entries requested before a certain date
N D0,DE,ID,IM,N,PRI,RDT,ST,TY
I '$G(LOCATION) S OUT="-1,No Location Specified" Q
;
S OUT=0
S PRI="" F S PRI=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRI)) Q:PRI="" D
. S DE="" F S DE=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRI,DE)) Q:DE="" D
. . S D0="" F S D0=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRI,DE,D0)) Q:D0="" D Q:'D0
. . . S X=$G(^MAGQUEUE(2006.035,D0,0)),IM=$P(X,"^",1),TY=$P(X,"^",3),ID=$P(X,"^",6)
. . . S X=$G(^MAGQUEUE(2006.035,D0,1)),ST=$P(X,"^",1),RDT=$P(X,"^",3)
. . . I RDT'<UPTO S D0=0 Q
. . . I ST'="",IM'="",TY'="" K ^MAGQUEUE(2006.035,"DEST",DE,ST,IM,TY,D0)
. . . K ^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRI,DE,D0)
. . . K:ID'="" ^MAGQUEUE(2006.035,"ID",ID,D0)
. . . K ^MAGQUEUE(2006.035,D0)
. . . S OUT=OUT+1
. . . Q
. . Q
. Q
Q
;
EVALLOG(OUT,TASK,MSG,MAX,LOCATION) ; RPC = MAG DICOM ROUTE EVAL LOG
N L,N,PLACE,ZTSK
;
S PLACE=$$PLACE^MAGDRPC2(LOCATION)
S $P(^MAG(2006.1,PLACE,"LASTROUTE"),"^",1)=DT
;
I '$D(^XTMP("MAGEVAL",+$G(TASK))) S OUT(1)="-1,No task #"_(+$G(TASK)) Q
I $G(MAX)<1 S OUT(1)="-2,MAXIMUM parameter = "_$G(MAX)_" < 1" Q
S (L,MSG)=+$G(MSG),N=1
F S MSG=$O(^XTMP("MAGEVAL",TASK,MSG)) Q:MSG="" D Q:N'<MAX
. S L=MSG,N=N+1,OUT(N)=^XTMP("MAGEVAL",TASK,MSG)
. Q
S OUT(1)=(N-1)_" "_L
Q:N>1
S ZTSK=TASK D STAT^%ZTLOAD
I $G(ZTSK(2))["Inactive" S OUT(1)="-3,"_ZTSK(2) Q
Q
;
XMIT ; Continuation from MAGDRPC5
N FROM,HASH,TO,TTP
S (FROM,TO,OUT(7),OUT(8))=-13
S TTP=TP S:TP="TEXT" TTP="FULL" ; MAGFILEB does not support type="TEXT"
D FILEFIND^MAGDFB(IM,TTP,0,0,.TO,.FROM)
S:FROM["~NO NETWORK LOCATION DEFINED" (FROM,TO)="-1~No routable files found for image "_IM
I TP="TEXT" S TO=$E(TO,1,$L(TO)-4)_".TXT",FROM=$E(FROM,1,$L(FROM)-4)_".TXT"
I (FROM<0)!(TO<0)!(FROM="") D STATUS^MAGDRPC5(X,D0,"SENT",LOCATION) S OUT(1)=2 Q
S HASH=$$DIRHASH^MAGFILEB(TO,+DEST) D:HASH'=""
. I $E(TO,1)="\",$E(HASH,$L(HASH))="\" S HASH=$E(HASH,1,$L(HASH)-1)
. I $E(TO,1)'="\",$E(HASH,$L(HASH))'="\" S HASH=HASH_"\"
. S TO=HASH_TO
. Q
D:DIR'=""
. I $E(TO,1)="\",$E(DIR,$L(DIR))="\" S DIR=$E(DIR,1,$L(DIR)-1)
. I $E(TO,1)'="\",$E(DIR,$L(DIR))'="\" S DIR=DIR_"\"
. S TO=DIR_TO
. Q
S:$E(TO,1)'="\" TO="\"_TO
S OUT(7)=FROM,OUT(8)=TO
S OUT(1)=1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDRPC6 6573 printed Oct 16, 2024@18:02:10 Page 2
MAGDRPC6 ;WOIFO/EdM - Routing RPCs ; 05/18/2007 11:23
+1 ;;3.0;IMAGING;**11,30,51,54**;03-July-2009;;Build 1424
+2 ;; Per VHA Directive 2004-038, this routine should not be modified.
+3 ;; +---------------------------------------------------------------+
+4 ;; | Property of the US Government. |
+5 ;; | No permission to copy or redistribute this software is given. |
+6 ;; | Use of unreleased versions of this software requires the user |
+7 ;; | to execute a written test agreement with the VistA Imaging |
+8 ;; | Development Office of the Department of Veterans Affairs, |
+9 ;; | telephone (301) 734-0100. |
+10 ;; | The Food and Drug Administration classifies this software as |
+11 ;; | a medical device. As such, it may not be changed in any way. |
+12 ;; | Modifications to this software may result in an adulterated |
+13 ;; | medical device under 21CFR820, the use of which is considered |
+14 ;; | to be a violation of US Federal Statutes. |
+15 ;; +---------------------------------------------------------------+
+16 ;;
+17 QUIT
+18 ;
PURGDONE(OUT,DAYS,LOCATION) ; RPC = MAG DICOM ROUTE PURGE DONE
+1 ; Purge Entries from Queue that have been sent successfully
+2 NEW D0,DE,ID,IM,LIM,PR,RT,STS,TP,TX,X
+3 IF '$GET(LOCATION)
SET OUT="-1,No Location Specified"
QUIT
+4 ;
+5 SET OUT=0
+6 FOR STS="SENT","NOT FOUND"
Begin DoDot:1
+7 SET PR=""
FOR
SET PR=$ORDER(^MAGQUEUE(2006.035,"STS",LOCATION,STS,PR))
if PR=""
QUIT
Begin DoDot:2
+8 SET DE=""
FOR
SET DE=$ORDER(^MAGQUEUE(2006.035,"STS",LOCATION,STS,PR,DE))
if DE=""
QUIT
Begin DoDot:3
+9 SET RT=$PIECE($GET(^MAG(2005.2,DE,3)),"^",1)
if 'RT
SET RT=31
+10 if $GET(DAYS)'<1
SET RT=DAYS
+11 SET LIM=$HOROLOG-RT
+12 SET D0=""
FOR
SET D0=$ORDER(^MAGQUEUE(2006.035,"STS",LOCATION,STS,PR,DE,D0))
if D0=""
QUIT
Begin DoDot:4
+13 if $$FMTH^XLFDT($PIECE($GET(^MAGQUEUE(2006.035,D0,1)),"^",4)\1)'<LIM
QUIT
+14 SET X=$GET(^MAGQUEUE(2006.035,D0,0))
SET IM=$PIECE(X,"^",1)
SET TP=$PIECE(X,"^",3)
SET ID=$PIECE(X,"^",6)
+15 KILL ^MAGQUEUE(2006.035,"STS",LOCATION,STS,PR,DE,D0)
+16 if ID'=""
KILL ^MAGQUEUE(2006.035,"ID",ID,D0)
+17 IF IM'=""
IF TP'=""
KILL ^MAGQUEUE(2006.035,"DEST",DE,STS,IM,TP,D0)
+18 KILL ^MAGQUEUE(2006.035,D0)
+19 SET OUT=OUT+1
+20 QUIT
End DoDot:4
+21 QUIT
End DoDot:3
+22 QUIT
End DoDot:2
+23 SET DE=""
FOR
SET DE=$ORDER(^MAGQUEUE(2006.035,"DEST",DE))
if DE=""
QUIT
Begin DoDot:2
+24 SET IM=""
FOR
SET IM=$ORDER(^MAGQUEUE(2006.035,"DEST",DE,STS,IM))
if IM=""
QUIT
Begin DoDot:3
+25 SET TP=""
FOR
SET TP=$ORDER(^MAGQUEUE(2006.035,"DEST",DE,STS,IM,TP))
if TP=""
QUIT
Begin DoDot:4
+26 SET D0=""
FOR
SET D0=$ORDER(^MAGQUEUE(2006.035,"DEST",DE,STS,IM,TP,D0))
if D0=""
QUIT
Begin DoDot:5
+27 SET PR=$PIECE($GET(^MAGQUEUE(2006.035,D0,1)),"^",2)
+28 SET ID=$PIECE($GET(^MAGQUEUE(2006.035,D0,0)),"^",6)
+29 KILL ^MAGQUEUE(2006.035,D0)
+30 if ID'=""
KILL ^MAGQUEUE(2006.035,"ID",ID,D0)
+31 KILL ^MAGQUEUE(2006.035,"DEST",DE,STS,IM,TP,D0)
+32 if PR'=""
KILL ^MAGQUEUE(2006.035,"STS",LOCATION,STS,PR,DE,D0)
+33 SET OUT=OUT+1
+34 QUIT
End DoDot:5
+35 QUIT
End DoDot:4
+36 QUIT
End DoDot:3
+37 QUIT
End DoDot:2
+38 QUIT
End DoDot:1
+39 SET D0=0
FOR
SET D0=$ORDER(^MAGQUEUE(2006.035,D0))
if 'D0
QUIT
Begin DoDot:1
+40 SET X=$PIECE($GET(^MAGQUEUE(2006.035,D0,1)),"^",1)
IF X'="SENT"
IF X'="NOT FOUND"
QUIT
+41 SET ID=$PIECE($GET(^MAGQUEUE(2006.035,D0,0)),"^",6)
+42 KILL ^MAGQUEUE(2006.035,D0)
+43 if ID'=""
KILL ^MAGQUEUE(2006.035,"ID",ID,D0)
+44 SET OUT=OUT+1
+45 QUIT
End DoDot:1
+46 QUIT
+47 ;
REQUEUE(OUT,LOCATION) ; RPC = MAG DICOM ROUTE REQUEUE
+1 ; ReQueue Files that Failed during transmission
+2 NEW D0,DE,FL,IM,PR,TP,WW,X
+3 IF '$GET(LOCATION)
SET OUT="-1,No Location Specified"
QUIT
+4 ;
+5 SET WW="WAITING"
SET OUT=0
+6 FOR FL="FAILED","SENDING"
Begin DoDot:1
+7 SET PR=""
FOR
SET PR=$ORDER(^MAGQUEUE(2006.035,"STS",LOCATION,FL,PR))
if PR=""
QUIT
Begin DoDot:2
+8 SET DE=""
FOR
SET DE=$ORDER(^MAGQUEUE(2006.035,"STS",LOCATION,FL,PR,DE))
if DE=""
QUIT
Begin DoDot:3
+9 SET D0=""
FOR
SET D0=$ORDER(^MAGQUEUE(2006.035,"STS",LOCATION,FL,PR,DE,D0))
if D0=""
QUIT
Begin DoDot:4
+10 KILL ^MAGQUEUE(2006.035,"STS",LOCATION,FL,PR,DE,D0)
+11 IF '$DATA(^MAGQUEUE(2006.035,D0,0))
KILL ^MAGQUEUE(2006.035,D0)
QUIT
+12 SET $PIECE(^MAGQUEUE(2006.035,D0,1),"^",1)=WW
+13 SET ^MAGQUEUE(2006.035,"STS",LOCATION,WW,PR,DE,D0)=""
+14 SET X=^MAGQUEUE(2006.035,D0,0)
SET IM=$PIECE(X,"^",1)
SET TP=$PIECE(X,"^",3)
+15 IF IM'=""
IF TP'=""
KILL ^MAGQUEUE(2006.035,"DEST",DE,FL,IM,TP,D0)
+16 IF IM'=""
IF TP'=""
SET ^MAGQUEUE(2006.035,"DEST",DE,WW,IM,TP,D0)=""
+17 SET OUT=OUT+1
+18 QUIT
End DoDot:4
+19 QUIT
End DoDot:3
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 QUIT
+23 ;
REMOBSO(OUT,UPTO,LOCATION) ; RPC = MAG DICOM ROUTE REMOVE OBSO
+1 ; Purge Unprocessed entries requested before a certain date
+2 NEW D0,DE,ID,IM,N,PRI,RDT,ST,TY
+3 IF '$GET(LOCATION)
SET OUT="-1,No Location Specified"
QUIT
+4 ;
+5 SET OUT=0
+6 SET PRI=""
FOR
SET PRI=$ORDER(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRI))
if PRI=""
QUIT
Begin DoDot:1
+7 SET DE=""
FOR
SET DE=$ORDER(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRI,DE))
if DE=""
QUIT
Begin DoDot:2
+8 SET D0=""
FOR
SET D0=$ORDER(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRI,DE,D0))
if D0=""
QUIT
Begin DoDot:3
+9 SET X=$GET(^MAGQUEUE(2006.035,D0,0))
SET IM=$PIECE(X,"^",1)
SET TY=$PIECE(X,"^",3)
SET ID=$PIECE(X,"^",6)
+10 SET X=$GET(^MAGQUEUE(2006.035,D0,1))
SET ST=$PIECE(X,"^",1)
SET RDT=$PIECE(X,"^",3)
+11 IF RDT'<UPTO
SET D0=0
QUIT
+12 IF ST'=""
IF IM'=""
IF TY'=""
KILL ^MAGQUEUE(2006.035,"DEST",DE,ST,IM,TY,D0)
+13 KILL ^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRI,DE,D0)
+14 if ID'=""
KILL ^MAGQUEUE(2006.035,"ID",ID,D0)
+15 KILL ^MAGQUEUE(2006.035,D0)
+16 SET OUT=OUT+1
+17 QUIT
End DoDot:3
if 'D0
QUIT
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
EVALLOG(OUT,TASK,MSG,MAX,LOCATION) ; RPC = MAG DICOM ROUTE EVAL LOG
+1 NEW L,N,PLACE,ZTSK
+2 ;
+3 SET PLACE=$$PLACE^MAGDRPC2(LOCATION)
+4 SET $PIECE(^MAG(2006.1,PLACE,"LASTROUTE"),"^",1)=DT
+5 ;
+6 IF '$DATA(^XTMP("MAGEVAL",+$GET(TASK)))
SET OUT(1)="-1,No task #"_(+$GET(TASK))
QUIT
+7 IF $GET(MAX)<1
SET OUT(1)="-2,MAXIMUM parameter = "_$GET(MAX)_" < 1"
QUIT
+8 SET (L,MSG)=+$GET(MSG)
SET N=1
+9 FOR
SET MSG=$ORDER(^XTMP("MAGEVAL",TASK,MSG))
if MSG=""
QUIT
Begin DoDot:1
+10 SET L=MSG
SET N=N+1
SET OUT(N)=^XTMP("MAGEVAL",TASK,MSG)
+11 QUIT
End DoDot:1
if N'<MAX
QUIT
+12 SET OUT(1)=(N-1)_" "_L
+13 if N>1
QUIT
+14 SET ZTSK=TASK
DO STAT^%ZTLOAD
+15 IF $GET(ZTSK(2))["Inactive"
SET OUT(1)="-3,"_ZTSK(2)
QUIT
+16 QUIT
+17 ;
XMIT ; Continuation from MAGDRPC5
+1 NEW FROM,HASH,TO,TTP
+2 SET (FROM,TO,OUT(7),OUT(8))=-13
+3 ; MAGFILEB does not support type="TEXT"
SET TTP=TP
if TP="TEXT"
SET TTP="FULL"
+4 DO FILEFIND^MAGDFB(IM,TTP,0,0,.TO,.FROM)
+5 if FROM["~NO NETWORK LOCATION DEFINED"
SET (FROM,TO)="-1~No routable files found for image "_IM
+6 IF TP="TEXT"
SET TO=$EXTRACT(TO,1,$LENGTH(TO)-4)_".TXT"
SET FROM=$EXTRACT(FROM,1,$LENGTH(FROM)-4)_".TXT"
+7 IF (FROM<0)!(TO<0)!(FROM="")
DO STATUS^MAGDRPC5(X,D0,"SENT",LOCATION)
SET OUT(1)=2
QUIT
+8 SET HASH=$$DIRHASH^MAGFILEB(TO,+DEST)
if HASH'=""
Begin DoDot:1
+9 IF $EXTRACT(TO,1)="\"
IF $EXTRACT(HASH,$LENGTH(HASH))="\"
SET HASH=$EXTRACT(HASH,1,$LENGTH(HASH)-1)
+10 IF $EXTRACT(TO,1)'="\"
IF $EXTRACT(HASH,$LENGTH(HASH))'="\"
SET HASH=HASH_"\"
+11 SET TO=HASH_TO
+12 QUIT
End DoDot:1
+13 if DIR'=""
Begin DoDot:1
+14 IF $EXTRACT(TO,1)="\"
IF $EXTRACT(DIR,$LENGTH(DIR))="\"
SET DIR=$EXTRACT(DIR,1,$LENGTH(DIR)-1)
+15 IF $EXTRACT(TO,1)'="\"
IF $EXTRACT(DIR,$LENGTH(DIR))'="\"
SET DIR=DIR_"\"
+16 SET TO=DIR_TO
+17 QUIT
End DoDot:1
+18 if $EXTRACT(TO,1)'="\"
SET TO="\"_TO
+19 SET OUT(7)=FROM
SET OUT(8)=TO
+20 SET OUT(1)=1
+21 QUIT
+22 ;
