MAGDRPC5 ;WOIFO/EdM,DAC - Routing RPCs ; 26 Oct 2017 3:12PM
;;3.0;IMAGING;**11,30,51,85,54,190**;;Build 2
;; 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
;
START(OUT,LOCATION,RULES) ; RPC = MAG DICOM ROUTE EVAL START
N I,LOC,X,ZTDESC,ZTDTH,ZTRTN,ZTSAVE
;
D XTINIT
;
I '$G(LOCATION) S OUT="-1,No Location Specified" Q
I '$O(RULES("")) S OUT="-2,No Routing Rules Specified" Q
;
S LOC=$$GET1^DIQ(4,LOCATION,.01)
L +^MAGDICOM(2006.563,1,"EVAL",LOCATION):0 E D Q
. S OUT="-3,A Rule Evaluator is Already Running for "_LOC
. Q
;
S ^MAGDICOM(2006.563,1,"EVAL")=1
S ZTRTN="EVAL^MAGBRTE4"
S ZTDESC="Evaluate Routing Rules for Origin="_LOC
S ZTDTH=$H
S ZTSAVE("LOCATION")=LOCATION
S I="" F S I=$O(RULES(I)) Q:I="" S:+I=I ZTSAVE("RULES("_I_")")=RULES(I)
D ^%ZTLOAD,HOME^%ZIS
L -^MAGDICOM(2006.563,1,"EVAL",LOCATION)
I '$D(ZTSK) S OUT="-4,TaskMan did not Accept Request" Q
S OUT="0,TaskMan task#="_ZTSK
Q
;
STOP(OUT) ; RPC = MAG DICOM ROUTE EVAL STOP
S ^MAGDICOM(2006.563,1,"EVAL")=0,OUT=1
Q
;
XMIT(OUT,LOCATION,DEST,PRIOR,MECH,DESTS) ; RPC = MAG DICOM ROUTE NEXT FILE
N D0,DIR,DL,IM,M,NOW,OK,PLACE,TP,VP,X
;
S PLACE=$$PLACE^MAGDRPC2(LOCATION)
S $P(^MAG(2006.1,PLACE,"LASTROUTE"),"^",1)=DT
;
K OUT S OUT(1)=0,OK=0
S:'$G(MECH) MECH=1 I MECH'=1,MECH'=2 S MECH=1
I '$G(LOCATION) S OUT(1)="-1,No Location Specified" Q
S VP(1)=";MAG(2005.2,"
S VP(2)=";MAG(2006.587,"
S:$G(DEST) DEST=+DEST_VP(MECH)
S M="" F S M=$O(DESTS(M)) Q:M="" D
. S X=DESTS(M) Q:X'["^" Q:$P(X,"^",1)'=MECH Q:'$P(X,"^",2)
. S DL($P(X,"^",2)_VP(MECH))=""
. Q
I $O(DL(""))="" S OUT(1)="-2,No Valid Destinations Specified" Q
S:'$G(DEST) (PRIOR,DEST)=""
I $G(PRIOR) D
. I DEST S X=0 F D Q:X
. . N NXT
. . I $P($G(^MAG(2005.2,+DEST,0)),"^",6) S X=1 Q
. . S NOW=$$NOW^XLFDT()*1E6
. . S X=$P($G(^MAG(2005.2,+DEST,3)),"^",6)*1E6
. . I NOW-X>1500 D ONOFLINE(.X,+DEST,1) Q
. . S X=0,NXT=0
. . F S DEST=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR,DEST)) Q:DEST="" D Q:NXT
. . . S:$D(DL(DEST)) NXT=1
. . . Q
. . S:'DEST X=1
. . Q
. I 'DEST S (PRIOR,DEST)="" Q
. F D Q:OK
. . S D0=+$G(D0)
. . S D0=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR,DEST,D0))
. . I 'D0 S OK=1 Q
. . S M=$P($G(^MAGQUEUE(2006.035,D0,0)),"^",4) I M'=1,M'=2 S M=1
. . I M=MECH S OK=1 Q
. . S (PRIOR,DEST)=""
. . Q
. Q
I OK D:$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR))
. ;
. ; Ignore higher priority items for destinations that are not accessible
. ;
. N A,D,P,T,X
. S P=PRIOR F S P=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",P)) Q:'P D Q:'PRIOR
. . S D="" F S D=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",P,D)) Q:D="" D Q:'PRIOR
. . . ; Interrupt only if we're transmitting there
. . . Q:'$D(DL(D))
. . . ;
. . . D:'$P(^MAG(2005.2,+D,0),"^",6)
. . . . S NOW=$$NOW^XLFDT()*1E6
. . . . S X=$P($G(^MAG(2005.2,+D,3)),"^",6)*1E6 Q:NOW-X<1500
. . . . D ONOFLINE(.X,+D,1)
. . . . Q
. . . S:$P(^MAG(2005.2,+D,0),"^",6) PRIOR=0
. . . Q
. . Q
. Q
I '$G(PRIOR) F D Q:OK Q:'PRIOR
. S PRIOR=" " F S PRIOR=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR),-1) Q:'PRIOR D Q:OK
. . S DEST="" F S DEST=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR,DEST)) Q:DEST="" D:$D(DL(DEST)) Q:OK
. . . D:'$P(^MAG(2005.2,+DEST,0),"^",6)
. . . . S NOW=$$NOW^XLFDT()*1E6
. . . . S X=$P($G(^MAG(2005.2,+DEST,3)),"^",6)*1E6 Q:NOW-X<1500
. . . . D ONOFLINE(.X,+DEST,1)
. . . . Q
. . . Q:'$P(^MAG(2005.2,+DEST,0),"^",6)
. . . S D0="" F S D0=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR,DEST,D0)) Q:D0="" D Q:OK
. . . . S M=$P($G(^MAGQUEUE(2006.035,D0,0)),"^",4) I M'=1,M'=2 S M=1
. . . . I M=MECH S OK=1 Q
. . . . Q
. . . Q
. . Q
. Q
Q:'PRIOR
Q:'OK
I 'D0 S OUT(1)=0 Q ; All files transmitted
;
S X=^MAGQUEUE(2006.035,D0,0),IM=$P(X,"^",1),TP=$P(X,"^",3)
I 'IM D STATUS(X,D0,"SENT",LOCATION) S OUT(1)=2 Q
S OUT(2)=+DEST,OUT(3)=PRIOR,OUT(4)=MECH,OUT(9)=D0
S X=$G(^MAG(2005.2,+DEST,2)),OUT(5)=$P(X,"^",1),OUT(6)=$P(X,"^",2)
D STATUS(X,D0,"SENDING",LOCATION)
S OUT(10)=$P(^MAG(2005.2,+DEST,0),"^",2)
S DIR=$P($G(^MAG(2005.2,+DEST,4)),"^",2)
S OUT(11)=$G(^MAG(2005.2,+DEST,3))
S OUT(12)=IM
S OUT(13)=$P($G(^MAGQUEUE(2006.035,D0,1)),"^",3)
S OUT(14)=$P($G(^MAG(2005.2,+DEST,1)),"^",7) S:OUT(14)="" OUT(14)="NONE"
D XMIT^MAGDRPC6 ; Routine grew over 10,000 characters
I MECH=2 S OUT(2)=OUT(2)_"^"_$P($G(^MAG(2006.587,+DEST,0)),"^",1)
Q
;
PURGE(OUT,LOCATION,DEST,MAX,DONE) ; RPC = MAG DICOM ROUTE GET PURGE
N D0,D1,FILE,FMFILE,I,LIMIT,MORE,NOW,RETAIN,STAMP,STATUS,X
;
S NOW=$$NOW^XLFDT()
K OUT S OUT(1)=1
S:$D(^MAG(2005.2,DEST,0)) $P(^MAG(2005.2,DEST,3),"^",4)=DT
S X=^MAG(2005.2,DEST,3)
S RETAIN=$P(X,"^",1) S:RETAIN="" RETAIN=32 S:RETAIN<0 RETAIN=0
S LIMIT=$H-RETAIN
;
S X=$G(DONE(1)),MORE="" S:$E(X,1)="^" MORE=$P(X,"^",4,6)
;
S I="" F S I=$O(DONE(I)) Q:I="" D
. N D41,D61
. S X=$G(DONE(I))
. S D0=$P(X,"^",2),D41=$P(X,"^",3)
. S STAMP=$P(X,"^",4)
. Q:'D0 Q:'D41
. ; Just in case the image is being deleted as this purge is taking place
. F FMFILE=2005,2005.1 D
. . K ^MAG(FMFILE,"ROUTE",DEST,STAMP,D0,D41)
. . S D61=$P($G(^MAG(FMFILE,D0,4,D41,0)),"^",7)
. . K ^MAG(FMFILE,D0,4,"LOC",DEST,D41)
. . K ^MAG(FMFILE,D0,4,D41,0)
. . S:D61 $P(^MAG(FMFILE,D0,6,D61,0),"^",5)=NOW
. . Q
. S MORE=""
. Q
;
S LIMIT=$$HTFM^XLFDT(LIMIT,1)
;
S MAX=$G(MAX) S:MAX<1 MAX=100
F FMFILE=2005,2005.1 D Q:OUT(1)'<MAX
. S STAMP="" F S STAMP=$O(^MAG(FMFILE,"ROUTE",DEST,STAMP)) Q:STAMP="" Q:STAMP'<LIMIT D Q:OUT(1)'<MAX
. . S D0="" F S D0=$O(^MAG(FMFILE,"ROUTE",DEST,STAMP,D0)) Q:D0="" D Q:OUT(1)'<MAX
. . . S D1="" F S D1=$O(^MAG(FMFILE,"ROUTE",DEST,STAMP,D0,D1)) Q:D1="" D Q:OUT(1)'<MAX
. . . . I MORE'="",FMFILE_"^"_D0_"^"_D1'=MORE Q
. . . . S MORE=""
. . . . S FILE=$P($G(^MAG(FMFILE,D0,4,D1,0)),"^",4),STATUS=0
. . . . S:FILE="" FILE=$P($G(^MAG(2005.1,D0,4,D1,0)),"^",4)
. . . . I FILE="" D Q
. . . . . K ^MAG(FMFILE,"ROUTE",DEST,STAMP,D0,D1)
. . . . . K ^MAG(FMFILE,D0,4,"LOC",DEST,D1)
. . . . . K ^MAG(FMFILE,D0,4,D1,0)
. . . . . Q
. . . . S OUT(1)=OUT(1)+1,OUT(OUT(1))=FMFILE_"^"_D0_"^"_D1_"^"_STAMP_"^"_FILE
. . . . Q
. . . Q
. . Q
. Q
Q
;
STATUS(OUT,D0,STATUS,LOCATION) ; RPC = MAG DICOM ROUTE STATUS
; D0 ------- Internal Entry Number of Send Queue Entry
; STATUS --- New Status
N DEST ;---- Internal Entry Number of destination
N IMAGE ;--- Internal Entry Number of image
N OLD ;----- Old Status Value
N ORIGIN ;-- Origin of image
N PRIOR ;--- Priority
N TYPE ;---- File Type (Big, Text, DICOM, etc)
N X0,X1 ;--- Queue data
;
I '$G(D0) S OUT="-1,Invalid queue identifier: """_$G(D0)_"""." Q
;
S X0=$G(^MAGQUEUE(2006.035,D0,0))
S X1=$G(^MAGQUEUE(2006.035,D0,1))
S OUT=0
;
S DEST=$P(X0,"^",2) Q:DEST=""
S PRIOR=$P(X1,"^",2) Q:PRIOR=""
S ORIGIN=$P(X0,"^",5)
S:'ORIGIN ORIGIN=$G(LOCATION) Q:'ORIGIN
S OLD=$P(X1,"^",1),IMAGE=$P(X0,"^",1),TYPE=$P(X0,"^",3)
;
K:OLD'="" ^MAGQUEUE(2006.035,"DEST",DEST,OLD,IMAGE,TYPE,D0)
K:OLD'="" ^MAGQUEUE(2006.035,"STS",ORIGIN,OLD,PRIOR,DEST,D0)
Q:STATUS=""
S $P(^MAGQUEUE(2006.035,D0,0),"^",5)=ORIGIN
S $P(^MAGQUEUE(2006.035,D0,1),"^",1)=STATUS
S ^MAGQUEUE(2006.035,"DEST",DEST,STATUS,IMAGE,TYPE,D0)=""
S ^MAGQUEUE(2006.035,"STS",ORIGIN,STATUS,PRIOR,DEST,D0)=""
S OUT=1
Q
;
LISTDEST(OUT,LOCATION) ; RPC = MAG DICOM ROUTE LIST DESTI
N D0,F,I,X,ROU,OPER
; Return list of possible routing destinations
K OUT
S I=1,D0=0 F S D0=$O(^MAG(2005.2,D0)) Q:'D0 D
. S X=$G(^MAG(2005.2,D0,0)) Q:'$P(X,"^",9)
. S X=$G(^MAG(2005.2,D0,0)),ROU=$P(X,U,9),OPER=$P(X,U,6)
. ; P190 DAC - include router entries; filter if inactive
. Q:'ROU!(OPER'=1)
. L +^MAGQUEUE("ROUTE",LOCATION,D0):0 S F='$T
. L:'F -^MAGQUEUE("ROUTE",LOCATION,D0)
. S I=I+1,OUT(I)=D0_"^"_F_"^"_$P(X,"^",1,2)
. Q
S OUT(1)=I-1
Q
LOCK(OUT,D0,LOCATION,PLUSMIN) ; RPC = MAG DICOM ROUTE LOCK TRANSMIT
S OUT=0
I $G(PLUSMIN) L +^MAGQUEUE("ROUTE",LOCATION,D0):0 S OUT=$T Q
L -^MAGQUEUE("ROUTE",LOCATION,D0) S OUT=2
Q
;
ONOFLINE(OUT,DEST,STATUS) ; RPC = MAG DICOM NETWORK STATUS
N NET
I '$G(DEST) S OUT="-1,No Network Location Specified" Q
S STATUS=''$G(STATUS)
S NET=$P($G(^MAG(2005.2,DEST,0)),"^",2)
K ^MAG(2005.2,"C",NET,0,DEST)
K ^MAG(2005.2,"C",NET,1,DEST)
S ^MAG(2005.2,"C",NET,STATUS,DEST)=""
S $P(^MAG(2005.2,DEST,0),"^",6)=STATUS
S $P(^MAG(2005.2,DEST,3),"^",6)=$S(STATUS:"",1:$$NOW^XLFDT())
S OUT=1
Q
;
XTINIT N NODE
D DT^DICRW
F NODE="MAGEVAL","MAGEVALSTUDY" D
. S X=$G(^XTMP(NODE,0))
. S $P(X,"^",2)=DT
. S $P(X,"^",3)="Routing Rule Evaluator Log - Can be purged at any time"
. S ^XTMP(NODE,0)=X
. Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDRPC5 9806 printed Dec 13, 2024@02:01:24 Page 2
MAGDRPC5 ;WOIFO/EdM,DAC - Routing RPCs ; 26 Oct 2017 3:12PM
+1 ;;3.0;IMAGING;**11,30,51,85,54,190**;;Build 2
+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 ;
START(OUT,LOCATION,RULES) ; RPC = MAG DICOM ROUTE EVAL START
+1 NEW I,LOC,X,ZTDESC,ZTDTH,ZTRTN,ZTSAVE
+2 ;
+3 DO XTINIT
+4 ;
+5 IF '$GET(LOCATION)
SET OUT="-1,No Location Specified"
QUIT
+6 IF '$ORDER(RULES(""))
SET OUT="-2,No Routing Rules Specified"
QUIT
+7 ;
+8 SET LOC=$$GET1^DIQ(4,LOCATION,.01)
+9 LOCK +^MAGDICOM(2006.563,1,"EVAL",LOCATION):0
IF '$TEST
Begin DoDot:1
+10 SET OUT="-3,A Rule Evaluator is Already Running for "_LOC
+11 QUIT
End DoDot:1
QUIT
+12 ;
+13 SET ^MAGDICOM(2006.563,1,"EVAL")=1
+14 SET ZTRTN="EVAL^MAGBRTE4"
+15 SET ZTDESC="Evaluate Routing Rules for Origin="_LOC
+16 SET ZTDTH=$HOROLOG
+17 SET ZTSAVE("LOCATION")=LOCATION
+18 SET I=""
FOR
SET I=$ORDER(RULES(I))
if I=""
QUIT
if +I=I
SET ZTSAVE("RULES("_I_")")=RULES(I)
+19 DO ^%ZTLOAD
DO HOME^%ZIS
+20 LOCK -^MAGDICOM(2006.563,1,"EVAL",LOCATION)
+21 IF '$DATA(ZTSK)
SET OUT="-4,TaskMan did not Accept Request"
QUIT
+22 SET OUT="0,TaskMan task#="_ZTSK
+23 QUIT
+24 ;
STOP(OUT) ; RPC = MAG DICOM ROUTE EVAL STOP
+1 SET ^MAGDICOM(2006.563,1,"EVAL")=0
SET OUT=1
+2 QUIT
+3 ;
XMIT(OUT,LOCATION,DEST,PRIOR,MECH,DESTS) ; RPC = MAG DICOM ROUTE NEXT FILE
+1 NEW D0,DIR,DL,IM,M,NOW,OK,PLACE,TP,VP,X
+2 ;
+3 SET PLACE=$$PLACE^MAGDRPC2(LOCATION)
+4 SET $PIECE(^MAG(2006.1,PLACE,"LASTROUTE"),"^",1)=DT
+5 ;
+6 KILL OUT
SET OUT(1)=0
SET OK=0
+7 if '$GET(MECH)
SET MECH=1
IF MECH'=1
IF MECH'=2
SET MECH=1
+8 IF '$GET(LOCATION)
SET OUT(1)="-1,No Location Specified"
QUIT
+9 SET VP(1)=";MAG(2005.2,"
+10 SET VP(2)=";MAG(2006.587,"
+11 if $GET(DEST)
SET DEST=+DEST_VP(MECH)
+12 SET M=""
FOR
SET M=$ORDER(DESTS(M))
if M=""
QUIT
Begin DoDot:1
+13 SET X=DESTS(M)
if X'["^"
QUIT
if $PIECE(X,"^",1)'=MECH
QUIT
if '$PIECE(X,"^",2)
QUIT
+14 SET DL($PIECE(X,"^",2)_VP(MECH))=""
+15 QUIT
End DoDot:1
+16 IF $ORDER(DL(""))=""
SET OUT(1)="-2,No Valid Destinations Specified"
QUIT
+17 if '$GET(DEST)
SET (PRIOR,DEST)=""
+18 IF $GET(PRIOR)
Begin DoDot:1
+19 IF DEST
SET X=0
FOR
Begin DoDot:2
+20 NEW NXT
+21 IF $PIECE($GET(^MAG(2005.2,+DEST,0)),"^",6)
SET X=1
QUIT
+22 SET NOW=$$NOW^XLFDT()*1E6
+23 SET X=$PIECE($GET(^MAG(2005.2,+DEST,3)),"^",6)*1E6
+24 IF NOW-X>1500
DO ONOFLINE(.X,+DEST,1)
QUIT
+25 SET X=0
SET NXT=0
+26 FOR
SET DEST=$ORDER(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR,DEST))
if DEST=""
QUIT
Begin DoDot:3
+27 if $DATA(DL(DEST))
SET NXT=1
+28 QUIT
End DoDot:3
if NXT
QUIT
+29 if 'DEST
SET X=1
+30 QUIT
End DoDot:2
if X
QUIT
+31 IF 'DEST
SET (PRIOR,DEST)=""
QUIT
+32 FOR
Begin DoDot:2
+33 SET D0=+$GET(D0)
+34 SET D0=$ORDER(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR,DEST,D0))
+35 IF 'D0
SET OK=1
QUIT
+36 SET M=$PIECE($GET(^MAGQUEUE(2006.035,D0,0)),"^",4)
IF M'=1
IF M'=2
SET M=1
+37 IF M=MECH
SET OK=1
QUIT
+38 SET (PRIOR,DEST)=""
+39 QUIT
End DoDot:2
if OK
QUIT
+40 QUIT
End DoDot:1
+41 IF OK
if $ORDER(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR))
Begin DoDot:1
+42 ;
+43 ; Ignore higher priority items for destinations that are not accessible
+44 ;
+45 NEW A,D,P,T,X
+46 SET P=PRIOR
FOR
SET P=$ORDER(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",P))
if 'P
QUIT
Begin DoDot:2
+47 SET D=""
FOR
SET D=$ORDER(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",P,D))
if D=""
QUIT
Begin DoDot:3
+48 ; Interrupt only if we're transmitting there
+49 if '$DATA(DL(D))
QUIT
+50 ;
+51 if '$PIECE(^MAG(2005.2,+D,0),"^",6)
Begin DoDot:4
+52 SET NOW=$$NOW^XLFDT()*1E6
+53 SET X=$PIECE($GET(^MAG(2005.2,+D,3)),"^",6)*1E6
if NOW-X<1500
QUIT
+54 DO ONOFLINE(.X,+D,1)
+55 QUIT
End DoDot:4
+56 if $PIECE(^MAG(2005.2,+D,0),"^",6)
SET PRIOR=0
+57 QUIT
End DoDot:3
if 'PRIOR
QUIT
+58 QUIT
End DoDot:2
if 'PRIOR
QUIT
+59 QUIT
End DoDot:1
+60 IF '$GET(PRIOR)
FOR
Begin DoDot:1
+61 SET PRIOR=" "
FOR
SET PRIOR=$ORDER(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR),-1)
if 'PRIOR
QUIT
Begin DoDot:2
+62 SET DEST=""
FOR
SET DEST=$ORDER(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR,DEST))
if DEST=""
QUIT
if $DATA(DL(DEST))
Begin DoDot:3
+63 if '$PIECE(^MAG(2005.2,+DEST,0),"^",6)
Begin DoDot:4
+64 SET NOW=$$NOW^XLFDT()*1E6
+65 SET X=$PIECE($GET(^MAG(2005.2,+DEST,3)),"^",6)*1E6
if NOW-X<1500
QUIT
+66 DO ONOFLINE(.X,+DEST,1)
+67 QUIT
End DoDot:4
+68 if '$PIECE(^MAG(2005.2,+DEST,0),"^",6)
QUIT
+69 SET D0=""
FOR
SET D0=$ORDER(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR,DEST,D0))
if D0=""
QUIT
Begin DoDot:4
+70 SET M=$PIECE($GET(^MAGQUEUE(2006.035,D0,0)),"^",4)
IF M'=1
IF M'=2
SET M=1
+71 IF M=MECH
SET OK=1
QUIT
+72 QUIT
End DoDot:4
if OK
QUIT
+73 QUIT
End DoDot:3
if OK
QUIT
+74 QUIT
End DoDot:2
if OK
QUIT
+75 QUIT
End DoDot:1
if OK
QUIT
if 'PRIOR
QUIT
+76 if 'PRIOR
QUIT
+77 if 'OK
QUIT
+78 ; All files transmitted
IF 'D0
SET OUT(1)=0
QUIT
+79 ;
+80 SET X=^MAGQUEUE(2006.035,D0,0)
SET IM=$PIECE(X,"^",1)
SET TP=$PIECE(X,"^",3)
+81 IF 'IM
DO STATUS(X,D0,"SENT",LOCATION)
SET OUT(1)=2
QUIT
+82 SET OUT(2)=+DEST
SET OUT(3)=PRIOR
SET OUT(4)=MECH
SET OUT(9)=D0
+83 SET X=$GET(^MAG(2005.2,+DEST,2))
SET OUT(5)=$PIECE(X,"^",1)
SET OUT(6)=$PIECE(X,"^",2)
+84 DO STATUS(X,D0,"SENDING",LOCATION)
+85 SET OUT(10)=$PIECE(^MAG(2005.2,+DEST,0),"^",2)
+86 SET DIR=$PIECE($GET(^MAG(2005.2,+DEST,4)),"^",2)
+87 SET OUT(11)=$GET(^MAG(2005.2,+DEST,3))
+88 SET OUT(12)=IM
+89 SET OUT(13)=$PIECE($GET(^MAGQUEUE(2006.035,D0,1)),"^",3)
+90 SET OUT(14)=$PIECE($GET(^MAG(2005.2,+DEST,1)),"^",7)
if OUT(14)=""
SET OUT(14)="NONE"
+91 ; Routine grew over 10,000 characters
DO XMIT^MAGDRPC6
+92 IF MECH=2
SET OUT(2)=OUT(2)_"^"_$PIECE($GET(^MAG(2006.587,+DEST,0)),"^",1)
+93 QUIT
+94 ;
PURGE(OUT,LOCATION,DEST,MAX,DONE) ; RPC = MAG DICOM ROUTE GET PURGE
+1 NEW D0,D1,FILE,FMFILE,I,LIMIT,MORE,NOW,RETAIN,STAMP,STATUS,X
+2 ;
+3 SET NOW=$$NOW^XLFDT()
+4 KILL OUT
SET OUT(1)=1
+5 if $DATA(^MAG(2005.2,DEST,0))
SET $PIECE(^MAG(2005.2,DEST,3),"^",4)=DT
+6 SET X=^MAG(2005.2,DEST,3)
+7 SET RETAIN=$PIECE(X,"^",1)
if RETAIN=""
SET RETAIN=32
if RETAIN<0
SET RETAIN=0
+8 SET LIMIT=$HOROLOG-RETAIN
+9 ;
+10 SET X=$GET(DONE(1))
SET MORE=""
if $EXTRACT(X,1)="^"
SET MORE=$PIECE(X,"^",4,6)
+11 ;
+12 SET I=""
FOR
SET I=$ORDER(DONE(I))
if I=""
QUIT
Begin DoDot:1
+13 NEW D41,D61
+14 SET X=$GET(DONE(I))
+15 SET D0=$PIECE(X,"^",2)
SET D41=$PIECE(X,"^",3)
+16 SET STAMP=$PIECE(X,"^",4)
+17 if 'D0
QUIT
if 'D41
QUIT
+18 ; Just in case the image is being deleted as this purge is taking place
+19 FOR FMFILE=2005,2005.1
Begin DoDot:2
+20 KILL ^MAG(FMFILE,"ROUTE",DEST,STAMP,D0,D41)
+21 SET D61=$PIECE($GET(^MAG(FMFILE,D0,4,D41,0)),"^",7)
+22 KILL ^MAG(FMFILE,D0,4,"LOC",DEST,D41)
+23 KILL ^MAG(FMFILE,D0,4,D41,0)
+24 if D61
SET $PIECE(^MAG(FMFILE,D0,6,D61,0),"^",5)=NOW
+25 QUIT
End DoDot:2
+26 SET MORE=""
+27 QUIT
End DoDot:1
+28 ;
+29 SET LIMIT=$$HTFM^XLFDT(LIMIT,1)
+30 ;
+31 SET MAX=$GET(MAX)
if MAX<1
SET MAX=100
+32 FOR FMFILE=2005,2005.1
Begin DoDot:1
+33 SET STAMP=""
FOR
SET STAMP=$ORDER(^MAG(FMFILE,"ROUTE",DEST,STAMP))
if STAMP=""
QUIT
if STAMP'<LIMIT
QUIT
Begin DoDot:2
+34 SET D0=""
FOR
SET D0=$ORDER(^MAG(FMFILE,"ROUTE",DEST,STAMP,D0))
if D0=""
QUIT
Begin DoDot:3
+35 SET D1=""
FOR
SET D1=$ORDER(^MAG(FMFILE,"ROUTE",DEST,STAMP,D0,D1))
if D1=""
QUIT
Begin DoDot:4
+36 IF MORE'=""
IF FMFILE_"^"_D0_"^"_D1'=MORE
QUIT
+37 SET MORE=""
+38 SET FILE=$PIECE($GET(^MAG(FMFILE,D0,4,D1,0)),"^",4)
SET STATUS=0
+39 if FILE=""
SET FILE=$PIECE($GET(^MAG(2005.1,D0,4,D1,0)),"^",4)
+40 IF FILE=""
Begin DoDot:5
+41 KILL ^MAG(FMFILE,"ROUTE",DEST,STAMP,D0,D1)
+42 KILL ^MAG(FMFILE,D0,4,"LOC",DEST,D1)
+43 KILL ^MAG(FMFILE,D0,4,D1,0)
+44 QUIT
End DoDot:5
QUIT
+45 SET OUT(1)=OUT(1)+1
SET OUT(OUT(1))=FMFILE_"^"_D0_"^"_D1_"^"_STAMP_"^"_FILE
+46 QUIT
End DoDot:4
if OUT(1)'<MAX
QUIT
+47 QUIT
End DoDot:3
if OUT(1)'<MAX
QUIT
+48 QUIT
End DoDot:2
if OUT(1)'<MAX
QUIT
+49 QUIT
End DoDot:1
if OUT(1)'<MAX
QUIT
+50 QUIT
+51 ;
STATUS(OUT,D0,STATUS,LOCATION) ; RPC = MAG DICOM ROUTE STATUS
+1 ; D0 ------- Internal Entry Number of Send Queue Entry
+2 ; STATUS --- New Status
+3 ;---- Internal Entry Number of destination
NEW DEST
+4 ;--- Internal Entry Number of image
NEW IMAGE
+5 ;----- Old Status Value
NEW OLD
+6 ;-- Origin of image
NEW ORIGIN
+7 ;--- Priority
NEW PRIOR
+8 ;---- File Type (Big, Text, DICOM, etc)
NEW TYPE
+9 ;--- Queue data
NEW X0,X1
+10 ;
+11 IF '$GET(D0)
SET OUT="-1,Invalid queue identifier: """_$GET(D0)_"""."
QUIT
+12 ;
+13 SET X0=$GET(^MAGQUEUE(2006.035,D0,0))
+14 SET X1=$GET(^MAGQUEUE(2006.035,D0,1))
+15 SET OUT=0
+16 ;
+17 SET DEST=$PIECE(X0,"^",2)
if DEST=""
QUIT
+18 SET PRIOR=$PIECE(X1,"^",2)
if PRIOR=""
QUIT
+19 SET ORIGIN=$PIECE(X0,"^",5)
+20 if 'ORIGIN
SET ORIGIN=$GET(LOCATION)
if 'ORIGIN
QUIT
+21 SET OLD=$PIECE(X1,"^",1)
SET IMAGE=$PIECE(X0,"^",1)
SET TYPE=$PIECE(X0,"^",3)
+22 ;
+23 if OLD'=""
KILL ^MAGQUEUE(2006.035,"DEST",DEST,OLD,IMAGE,TYPE,D0)
+24 if OLD'=""
KILL ^MAGQUEUE(2006.035,"STS",ORIGIN,OLD,PRIOR,DEST,D0)
+25 if STATUS=""
QUIT
+26 SET $PIECE(^MAGQUEUE(2006.035,D0,0),"^",5)=ORIGIN
+27 SET $PIECE(^MAGQUEUE(2006.035,D0,1),"^",1)=STATUS
+28 SET ^MAGQUEUE(2006.035,"DEST",DEST,STATUS,IMAGE,TYPE,D0)=""
+29 SET ^MAGQUEUE(2006.035,"STS",ORIGIN,STATUS,PRIOR,DEST,D0)=""
+30 SET OUT=1
+31 QUIT
+32 ;
LISTDEST(OUT,LOCATION) ; RPC = MAG DICOM ROUTE LIST DESTI
+1 NEW D0,F,I,X,ROU,OPER
+2 ; Return list of possible routing destinations
+3 KILL OUT
+4 SET I=1
SET D0=0
FOR
SET D0=$ORDER(^MAG(2005.2,D0))
if 'D0
QUIT
Begin DoDot:1
+5 SET X=$GET(^MAG(2005.2,D0,0))
if '$PIECE(X,"^",9)
QUIT
+6 SET X=$GET(^MAG(2005.2,D0,0))
SET ROU=$PIECE(X,U,9)
SET OPER=$PIECE(X,U,6)
+7 ; P190 DAC - include router entries; filter if inactive
+8 if 'ROU!(OPER'=1)
QUIT
+9 LOCK +^MAGQUEUE("ROUTE",LOCATION,D0):0
SET F='$TEST
+10 if 'F
LOCK -^MAGQUEUE("ROUTE",LOCATION,D0)
+11 SET I=I+1
SET OUT(I)=D0_"^"_F_"^"_$PIECE(X,"^",1,2)
+12 QUIT
End DoDot:1
+13 SET OUT(1)=I-1
+14 QUIT
LOCK(OUT,D0,LOCATION,PLUSMIN) ; RPC = MAG DICOM ROUTE LOCK TRANSMIT
+1 SET OUT=0
+2 IF $GET(PLUSMIN)
LOCK +^MAGQUEUE("ROUTE",LOCATION,D0):0
SET OUT=$TEST
QUIT
+3 LOCK -^MAGQUEUE("ROUTE",LOCATION,D0)
SET OUT=2
+4 QUIT
+5 ;
ONOFLINE(OUT,DEST,STATUS) ; RPC = MAG DICOM NETWORK STATUS
+1 NEW NET
+2 IF '$GET(DEST)
SET OUT="-1,No Network Location Specified"
QUIT
+3 SET STATUS=''$GET(STATUS)
+4 SET NET=$PIECE($GET(^MAG(2005.2,DEST,0)),"^",2)
+5 KILL ^MAG(2005.2,"C",NET,0,DEST)
+6 KILL ^MAG(2005.2,"C",NET,1,DEST)
+7 SET ^MAG(2005.2,"C",NET,STATUS,DEST)=""
+8 SET $PIECE(^MAG(2005.2,DEST,0),"^",6)=STATUS
+9 SET $PIECE(^MAG(2005.2,DEST,3),"^",6)=$SELECT(STATUS:"",1:$$NOW^XLFDT())
+10 SET OUT=1
+11 QUIT
+12 ;
XTINIT NEW NODE
+1 DO DT^DICRW
+2 FOR NODE="MAGEVAL","MAGEVALSTUDY"
Begin DoDot:1
+3 SET X=$GET(^XTMP(NODE,0))
+4 SET $PIECE(X,"^",2)=DT
+5 SET $PIECE(X,"^",3)="Routing Rule Evaluator Log - Can be purged at any time"
+6 SET ^XTMP(NODE,0)=X
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
