MAGBRTUT ;WOIFO/EdM - Routing Utilities ; 10/30/2008 09:20
;;3.0;IMAGING;**9,11,30,51,50,85,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
;
SEND(IMAGE,LOC,PRI,MECH,FROM,ID) ; Enter image into Routing Queue
; IMAGE ;---- Internal Entry Number in Image FIle
; LOC ;------ Internal Entry Number in either Network Location file
; or SCU_List file
; PRI ;------ Priority
; MECHanism = 1: Send using MS-DOS-Copy
; = 2: Send using DICOM_Send
; FROM ;----- Location from which request originates
; ID ;------- Transaction ID
N D0 ;------- Internal Entry number
N FLAG ;----- List of file-types to transmit
N I ;-------- Scratch and loop counter
N ORIGIN ;--- Location from which image is being sent (IEN in Institution file)
N QQ ;------- List of queue-entries created
;
S QQ="",MECH=$G(MECH) S:'MECH MECH=1
I '$D(^MAG(2005,+$G(IMAGE))) Q:$Q QQ Q
I MECH=1,'$D(^MAG(2005.2,+$G(LOC))) Q:$Q QQ Q
I MECH=2,'$D(^MAG(2006.587,+$G(LOC))) Q:$Q QQ Q
I MECH'=1,MECH'=2 Q:$Q QQ Q
S:MECH=1 LOC=(+LOC)_";MAG(2005.2,"
S:MECH=2 LOC=(+LOC)_";MAG(2006.587,"
;
S ORIGIN=$G(FROM) D:'ORIGIN
. S ORIGIN=$P($G(^MAG(2005,IMAGE,100)),"^",3)
. S:'ORIGIN ORIGIN=$G(DUZ(2))
. S:'ORIGIN ORIGIN=$$KSP^XUPARAM("INST")
. Q
;
S PRI=$G(PRI,500),ID=$G(ID)
S FLAG=$G(^MAG(2005.2,+LOC,1)) S:MECH=2 FLAG="^^^^5"
;
I MECH=2 D Q:$Q QQ Q
. ; Stopgap until "native DICOM" storage is supported
. N APPNAM
. S APPNAM=$P($G(^MAG(2006.587,+LOC,0)),"^",1)
. D QUEUE^MAGDRPC3(.QQ,IMAGE,APPNAM,ORIGIN,"","6: Copy to HIPAA Compliant Storage",,PRI)
. Q
;
F I=1:1:5 D:$P(FLAG,"^",I)
. N D0,T,X
. S T=$P("ABSTRACT FULL BIG TEXT DICOM"," ",I)
. ;
. S D0=$O(^MAGQUEUE(2006.035,"DEST",LOC,"WAITING",IMAGE,T,"")) I D0 D Q
. . N O,P,T,X0,X1
. . S X0=$G(^MAGQUEUE(2006.035,D0,0)),O=$P(X0,"^",5),T=$P(X0,"^",6)
. . S X1=$G(^MAGQUEUE(2006.035,D0,1)),P=$P(X1,"^",2)
. . ; Don't send multiple copies, but do increase priority if needed
. . Q:PRI'>P
. . S $P(X0,"^",5)=ORIGIN,^MAGQUEUE(2006.035,D0,0)=X0
. . I T'=ID,ID'="" D
. . . S $P(X0,"^",6)=ID
. . . S ^MAGQUEUE(2006.035,D0,0)=X0
. . . K:O'="" ^MAGQUEUE(2006.035,"ID",T,D0)
. . . S ^MAGQUEUE(2006.035,"ID",ID,D0)=""
. . . Q
. . S $P(X1,"^",2)=PRI,^MAGQUEUE(2006.035,D0,1)=X1
. . K:O ^MAGQUEUE(2006.035,"STS",O,"WAITING",P,LOC,D0)
. . S ^MAGQUEUE(2006.035,"STS",ORIGIN,"WAITING",PRI,LOC,D0)=""
. . Q
. ;
. L +^MAGQUEUE(2006.035,0):1E9 ; Background job MUST wait
. S D0=$O(^MAGQUEUE(2006.035," "),-1)+1
. S X=$G(^MAGQUEUE(2006.035,0))
. S $P(X,"^",1,2)="SEND QUEUE^2006.035"
. S $P(X,"^",3)=D0
. S $P(X,"^",4)=$P(X,"^",4)+1
. S ^MAGQUEUE(2006.035,0)=X
. S X=IMAGE_"^"_LOC_"^"_T_"^"_MECH_"^"_ORIGIN_"^"_ID
. S:ID'="" ^MAGQUEUE(2006.035,"ID",ID,D0)=""
. S ^MAGQUEUE(2006.035,D0,0)=X
. S ^MAGQUEUE(2006.035,D0,1)="WAITING^"_PRI_"^"_$$NOW^XLFDT()
. S ^MAGQUEUE(2006.035,"STS",ORIGIN,"WAITING",PRI,LOC,D0)=""
. S ^MAGQUEUE(2006.035,"DEST",LOC,"WAITING",IMAGE,T,D0)=""
. L -^MAGQUEUE(2006.035,0)
. S QQ=QQ_D0_"^"
. Q
Q:$Q QQ Q
;
DCMLIST(OUT,LOCATION) N D0,LO,LST,N,NM,X
S LOCATION=+$G(LOCATION)
S D0=0 F S D0=$O(^MAG(2006.587,D0)) Q:'D0 D
. S X=$G(^MAG(2006.587,D0,0))
. S NM=$P(X,"^",1),LO=$P(X,"^",7) Q:NM=""
. I LOCATION,LO,LO'=LOCATION Q
. S LST(NM,LO)=D0
. Q
S N=1,NM="" F S NM=$O(LST(NM)) Q:NM="" D
. S LO="",X=0 F S LO=$O(LST(NM,LO)) Q:LO="" S X=X+1,D0=LST(NM,LO)
. I X=1 S N=N+1,OUT(N)=NM_"^"_D0 Q
. S LO="" F S LO=$O(LST(NM,LO)) Q:LO="" S N=N+1,OUT(N)=NM_" ("_LO_")^"_LST(NM,LO)
. Q
S OUT(1)=N-1
Q
;
EVALPU(OUT,UNTIL) ; RPC = MAG DICOM ROUTE EVAL PURGE
N D0,MORE,N,P1,P4,P5,P6,P7,P8,TIME
S TIME=$$STAMP($H)+55,N=0,MORE=0
L +^MAGQUEUE(2006.03,0):1E9 ; Background process must wait
S D0="" F S D0=$O(^MAGQUEUE(2006.03,"B","EVAL",D0)) Q:D0="" D Q:MORE
. S X=$G(^MAGQUEUE(2006.03,D0,0))
. S P4=$P(X,"^",4),P6=$P(X,"^",6)
. S:P6 P4=-1
. Q:P4>UNTIL
. I $$STAMP($H)>TIME S MORE=1 Q
. S N=N+1,P1=$P(X,"^",1),P5=$P(X,"^",5),P7=$P(X,"^",7),P8=$P(X,"^",8)
. I P1'="" K ^MAGQUEUE(2006.03,"B",P1,D0)
. I P5'="" K ^MAGQUEUE(2006.03,"C",P5,D0)
. I P7'="",P8'="" K ^MAGQUEUE(2006.03,"JD",P7,P8,D0)
. I P7'="" K ^MAGQUEUE(2006.03,"JX",P7,D0)
. K ^MAGQUEUE(2006.03,D0)
. Q
S X=$G(^MAGQUEUE(2006.03,0))
S P1=$P(X,"^",4)-N S:P1<1 P1=0 S $P(X,"^",4)=P1
S $P(X,"^",1,2)="IMAGE BACKGROUND QUEUE^2006.03"
S ^MAGQUEUE(2006.03,0)=X
L -^MAGQUEUE(2006.03,0)
S OUT=N_"^"_MORE
Q
;
STAMP(H) Q H*86400+$P(H,",",2)
;
RENAME(OUT,OLD,NEW,KEY) ; RPC = MAG DICOM XMIT RENAME GATEWAY
N D0,ID,LOC,SVC,N,X
I $G(OLD)="" S OUT="-1,No previous Gateway name specified" Q
I $G(NEW)="" S OUT="-2,No new Gateway name specified" Q
S:'$G(KEY) KEY=5
I KEY'=5,KEY'=6 S OUT="-3,Invalid key specified ("_KEY_")" Q
;
S (N,D0)=0 F S D0=$O(^MAG(2006.587,D0)) Q:'D0 D
. S X=$G(^MAG(2006.587,D0,0)),ID=$P(X,"^",KEY) Q:ID'=OLD
. S N=N+1
. S $P(X,"^",KEY)=NEW
. Q:KEY'=5
. S LOC=$P(X,"^",7),SVC=$P(X,"^",1)
. I LOC'="",SVC'="" K ^MAG(2006.587,"C",SVC,OLD,LOC,D0)
. I LOC'="" K ^MAG(2006.587,"D",OLD,LOC,D0)
. I LOC'="",SVC'="" S ^MAG(2006.587,"C",SVC,NEW,LOC,D0)=""
. I LOC'="" S ^MAG(2006.587,"D",NEW,LOC,D0)=""
. Q
S OUT=N_" entr"_$S(N=1:"y",1:"ies")_" renamed"
Q
;
REMOVE(OUT,OLD,KEY) ; RPC = MAG DICOM XMIT REMOVE GATEWAY
N D0,ID,LOC,SVC,N,T,X
I $G(OLD)="" S OUT="-1,No Gateway name specified" Q
S:'$G(KEY) KEY=5
I KEY'=5,KEY'=6 S OUT="-3,Invalid key specified ("_KEY_")" Q
;
L +^MAG(2006.587,0):1E9 ; Background process MUST wait
S (N,D0)=0 F S D0=$O(^MAG(2006.587,D0)) Q:'D0 D
. S X=$G(^MAG(2006.587,D0,0)),ID=$P(X,"^",KEY) Q:ID'=OLD
. S N=N+1
. S LOC=$P(X,"^",7),SVC=$P(X,"^",1)
. I LOC'="",SVC'="" K ^MAG(2006.587,"C",SVC,OLD,LOC,D0)
. I LOC'="" K ^MAG(2006.587,"D",OLD,LOC,D0)
. I SVC'="" K ^MAG(2006.587,"B",SVC,D0)
. K ^MAG(2006.587,D0)
. Q
S X=$G(^MAG(2006.587,0))
S $P(X,"^",1,2)="DICOM TRANSMIT DESTINATION^2006.587"
S $P(X,"^",3)=$O(^MAG(2006.587," "),-1)
S T=$P(X,"^",4)-N S:T<1 T="" S $P(X,"^",4)=T
S ^MAG(2006.587,0)=X
L -^MAG(2006.587,0)
S OUT=N_" entr"_$S(N=1:"y",1:"ies")_" removed"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGBRTUT 7193 printed Sep 23, 2025@19:35:44 Page 2
MAGBRTUT ;WOIFO/EdM - Routing Utilities ; 10/30/2008 09:20
+1 ;;3.0;IMAGING;**9,11,30,51,50,85,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 ;
SEND(IMAGE,LOC,PRI,MECH,FROM,ID) ; Enter image into Routing Queue
+1 ; IMAGE ;---- Internal Entry Number in Image FIle
+2 ; LOC ;------ Internal Entry Number in either Network Location file
+3 ; or SCU_List file
+4 ; PRI ;------ Priority
+5 ; MECHanism = 1: Send using MS-DOS-Copy
+6 ; = 2: Send using DICOM_Send
+7 ; FROM ;----- Location from which request originates
+8 ; ID ;------- Transaction ID
+9 ;------- Internal Entry number
NEW D0
+10 ;----- List of file-types to transmit
NEW FLAG
+11 ;-------- Scratch and loop counter
NEW I
+12 ;--- Location from which image is being sent (IEN in Institution file)
NEW ORIGIN
+13 ;------- List of queue-entries created
NEW QQ
+14 ;
+15 SET QQ=""
SET MECH=$GET(MECH)
if 'MECH
SET MECH=1
+16 IF '$DATA(^MAG(2005,+$GET(IMAGE)))
if $QUIT
QUIT QQ
QUIT
+17 IF MECH=1
IF '$DATA(^MAG(2005.2,+$GET(LOC)))
if $QUIT
QUIT QQ
QUIT
+18 IF MECH=2
IF '$DATA(^MAG(2006.587,+$GET(LOC)))
if $QUIT
QUIT QQ
QUIT
+19 IF MECH'=1
IF MECH'=2
if $QUIT
QUIT QQ
QUIT
+20 if MECH=1
SET LOC=(+LOC)_";MAG(2005.2,"
+21 if MECH=2
SET LOC=(+LOC)_";MAG(2006.587,"
+22 ;
+23 SET ORIGIN=$GET(FROM)
if 'ORIGIN
Begin DoDot:1
+24 SET ORIGIN=$PIECE($GET(^MAG(2005,IMAGE,100)),"^",3)
+25 if 'ORIGIN
SET ORIGIN=$GET(DUZ(2))
+26 if 'ORIGIN
SET ORIGIN=$$KSP^XUPARAM("INST")
+27 QUIT
End DoDot:1
+28 ;
+29 SET PRI=$GET(PRI,500)
SET ID=$GET(ID)
+30 SET FLAG=$GET(^MAG(2005.2,+LOC,1))
if MECH=2
SET FLAG="^^^^5"
+31 ;
+32 IF MECH=2
Begin DoDot:1
+33 ; Stopgap until "native DICOM" storage is supported
+34 NEW APPNAM
+35 SET APPNAM=$PIECE($GET(^MAG(2006.587,+LOC,0)),"^",1)
+36 DO QUEUE^MAGDRPC3(.QQ,IMAGE,APPNAM,ORIGIN,"","6: Copy to HIPAA Compliant Storage",,PRI)
+37 QUIT
End DoDot:1
if $QUIT
QUIT QQ
QUIT
+38 ;
+39 FOR I=1:1:5
if $PIECE(FLAG,"^",I)
Begin DoDot:1
+40 NEW D0,T,X
+41 SET T=$PIECE("ABSTRACT FULL BIG TEXT DICOM"," ",I)
+42 ;
+43 SET D0=$ORDER(^MAGQUEUE(2006.035,"DEST",LOC,"WAITING",IMAGE,T,""))
IF D0
Begin DoDot:2
+44 NEW O,P,T,X0,X1
+45 SET X0=$GET(^MAGQUEUE(2006.035,D0,0))
SET O=$PIECE(X0,"^",5)
SET T=$PIECE(X0,"^",6)
+46 SET X1=$GET(^MAGQUEUE(2006.035,D0,1))
SET P=$PIECE(X1,"^",2)
+47 ; Don't send multiple copies, but do increase priority if needed
+48 if PRI'>P
QUIT
+49 SET $PIECE(X0,"^",5)=ORIGIN
SET ^MAGQUEUE(2006.035,D0,0)=X0
+50 IF T'=ID
IF ID'=""
Begin DoDot:3
+51 SET $PIECE(X0,"^",6)=ID
+52 SET ^MAGQUEUE(2006.035,D0,0)=X0
+53 if O'=""
KILL ^MAGQUEUE(2006.035,"ID",T,D0)
+54 SET ^MAGQUEUE(2006.035,"ID",ID,D0)=""
+55 QUIT
End DoDot:3
+56 SET $PIECE(X1,"^",2)=PRI
SET ^MAGQUEUE(2006.035,D0,1)=X1
+57 if O
KILL ^MAGQUEUE(2006.035,"STS",O,"WAITING",P,LOC,D0)
+58 SET ^MAGQUEUE(2006.035,"STS",ORIGIN,"WAITING",PRI,LOC,D0)=""
+59 QUIT
End DoDot:2
QUIT
+60 ;
+61 ; Background job MUST wait
LOCK +^MAGQUEUE(2006.035,0):1E9
+62 SET D0=$ORDER(^MAGQUEUE(2006.035," "),-1)+1
+63 SET X=$GET(^MAGQUEUE(2006.035,0))
+64 SET $PIECE(X,"^",1,2)="SEND QUEUE^2006.035"
+65 SET $PIECE(X,"^",3)=D0
+66 SET $PIECE(X,"^",4)=$PIECE(X,"^",4)+1
+67 SET ^MAGQUEUE(2006.035,0)=X
+68 SET X=IMAGE_"^"_LOC_"^"_T_"^"_MECH_"^"_ORIGIN_"^"_ID
+69 if ID'=""
SET ^MAGQUEUE(2006.035,"ID",ID,D0)=""
+70 SET ^MAGQUEUE(2006.035,D0,0)=X
+71 SET ^MAGQUEUE(2006.035,D0,1)="WAITING^"_PRI_"^"_$$NOW^XLFDT()
+72 SET ^MAGQUEUE(2006.035,"STS",ORIGIN,"WAITING",PRI,LOC,D0)=""
+73 SET ^MAGQUEUE(2006.035,"DEST",LOC,"WAITING",IMAGE,T,D0)=""
+74 LOCK -^MAGQUEUE(2006.035,0)
+75 SET QQ=QQ_D0_"^"
+76 QUIT
End DoDot:1
+77 if $QUIT
QUIT QQ
QUIT
+78 ;
DCMLIST(OUT,LOCATION) NEW D0,LO,LST,N,NM,X
+1 SET LOCATION=+$GET(LOCATION)
+2 SET D0=0
FOR
SET D0=$ORDER(^MAG(2006.587,D0))
if 'D0
QUIT
Begin DoDot:1
+3 SET X=$GET(^MAG(2006.587,D0,0))
+4 SET NM=$PIECE(X,"^",1)
SET LO=$PIECE(X,"^",7)
if NM=""
QUIT
+5 IF LOCATION
IF LO
IF LO'=LOCATION
QUIT
+6 SET LST(NM,LO)=D0
+7 QUIT
End DoDot:1
+8 SET N=1
SET NM=""
FOR
SET NM=$ORDER(LST(NM))
if NM=""
QUIT
Begin DoDot:1
+9 SET LO=""
SET X=0
FOR
SET LO=$ORDER(LST(NM,LO))
if LO=""
QUIT
SET X=X+1
SET D0=LST(NM,LO)
+10 IF X=1
SET N=N+1
SET OUT(N)=NM_"^"_D0
QUIT
+11 SET LO=""
FOR
SET LO=$ORDER(LST(NM,LO))
if LO=""
QUIT
SET N=N+1
SET OUT(N)=NM_" ("_LO_")^"_LST(NM,LO)
+12 QUIT
End DoDot:1
+13 SET OUT(1)=N-1
+14 QUIT
+15 ;
EVALPU(OUT,UNTIL) ; RPC = MAG DICOM ROUTE EVAL PURGE
+1 NEW D0,MORE,N,P1,P4,P5,P6,P7,P8,TIME
+2 SET TIME=$$STAMP($HOROLOG)+55
SET N=0
SET MORE=0
+3 ; Background process must wait
LOCK +^MAGQUEUE(2006.03,0):1E9
+4 SET D0=""
FOR
SET D0=$ORDER(^MAGQUEUE(2006.03,"B","EVAL",D0))
if D0=""
QUIT
Begin DoDot:1
+5 SET X=$GET(^MAGQUEUE(2006.03,D0,0))
+6 SET P4=$PIECE(X,"^",4)
SET P6=$PIECE(X,"^",6)
+7 if P6
SET P4=-1
+8 if P4>UNTIL
QUIT
+9 IF $$STAMP($HOROLOG)>TIME
SET MORE=1
QUIT
+10 SET N=N+1
SET P1=$PIECE(X,"^",1)
SET P5=$PIECE(X,"^",5)
SET P7=$PIECE(X,"^",7)
SET P8=$PIECE(X,"^",8)
+11 IF P1'=""
KILL ^MAGQUEUE(2006.03,"B",P1,D0)
+12 IF P5'=""
KILL ^MAGQUEUE(2006.03,"C",P5,D0)
+13 IF P7'=""
IF P8'=""
KILL ^MAGQUEUE(2006.03,"JD",P7,P8,D0)
+14 IF P7'=""
KILL ^MAGQUEUE(2006.03,"JX",P7,D0)
+15 KILL ^MAGQUEUE(2006.03,D0)
+16 QUIT
End DoDot:1
if MORE
QUIT
+17 SET X=$GET(^MAGQUEUE(2006.03,0))
+18 SET P1=$PIECE(X,"^",4)-N
if P1<1
SET P1=0
SET $PIECE(X,"^",4)=P1
+19 SET $PIECE(X,"^",1,2)="IMAGE BACKGROUND QUEUE^2006.03"
+20 SET ^MAGQUEUE(2006.03,0)=X
+21 LOCK -^MAGQUEUE(2006.03,0)
+22 SET OUT=N_"^"_MORE
+23 QUIT
+24 ;
STAMP(H) QUIT H*86400+$PIECE(H,",",2)
+1 ;
RENAME(OUT,OLD,NEW,KEY) ; RPC = MAG DICOM XMIT RENAME GATEWAY
+1 NEW D0,ID,LOC,SVC,N,X
+2 IF $GET(OLD)=""
SET OUT="-1,No previous Gateway name specified"
QUIT
+3 IF $GET(NEW)=""
SET OUT="-2,No new Gateway name specified"
QUIT
+4 if '$GET(KEY)
SET KEY=5
+5 IF KEY'=5
IF KEY'=6
SET OUT="-3,Invalid key specified ("_KEY_")"
QUIT
+6 ;
+7 SET (N,D0)=0
FOR
SET D0=$ORDER(^MAG(2006.587,D0))
if 'D0
QUIT
Begin DoDot:1
+8 SET X=$GET(^MAG(2006.587,D0,0))
SET ID=$PIECE(X,"^",KEY)
if ID'=OLD
QUIT
+9 SET N=N+1
+10 SET $PIECE(X,"^",KEY)=NEW
+11 if KEY'=5
QUIT
+12 SET LOC=$PIECE(X,"^",7)
SET SVC=$PIECE(X,"^",1)
+13 IF LOC'=""
IF SVC'=""
KILL ^MAG(2006.587,"C",SVC,OLD,LOC,D0)
+14 IF LOC'=""
KILL ^MAG(2006.587,"D",OLD,LOC,D0)
+15 IF LOC'=""
IF SVC'=""
SET ^MAG(2006.587,"C",SVC,NEW,LOC,D0)=""
+16 IF LOC'=""
SET ^MAG(2006.587,"D",NEW,LOC,D0)=""
+17 QUIT
End DoDot:1
+18 SET OUT=N_" entr"_$SELECT(N=1:"y",1:"ies")_" renamed"
+19 QUIT
+20 ;
REMOVE(OUT,OLD,KEY) ; RPC = MAG DICOM XMIT REMOVE GATEWAY
+1 NEW D0,ID,LOC,SVC,N,T,X
+2 IF $GET(OLD)=""
SET OUT="-1,No Gateway name specified"
QUIT
+3 if '$GET(KEY)
SET KEY=5
+4 IF KEY'=5
IF KEY'=6
SET OUT="-3,Invalid key specified ("_KEY_")"
QUIT
+5 ;
+6 ; Background process MUST wait
LOCK +^MAG(2006.587,0):1E9
+7 SET (N,D0)=0
FOR
SET D0=$ORDER(^MAG(2006.587,D0))
if 'D0
QUIT
Begin DoDot:1
+8 SET X=$GET(^MAG(2006.587,D0,0))
SET ID=$PIECE(X,"^",KEY)
if ID'=OLD
QUIT
+9 SET N=N+1
+10 SET LOC=$PIECE(X,"^",7)
SET SVC=$PIECE(X,"^",1)
+11 IF LOC'=""
IF SVC'=""
KILL ^MAG(2006.587,"C",SVC,OLD,LOC,D0)
+12 IF LOC'=""
KILL ^MAG(2006.587,"D",OLD,LOC,D0)
+13 IF SVC'=""
KILL ^MAG(2006.587,"B",SVC,D0)
+14 KILL ^MAG(2006.587,D0)
+15 QUIT
End DoDot:1
+16 SET X=$GET(^MAG(2006.587,0))
+17 SET $PIECE(X,"^",1,2)="DICOM TRANSMIT DESTINATION^2006.587"
+18 SET $PIECE(X,"^",3)=$ORDER(^MAG(2006.587," "),-1)
+19 SET T=$PIECE(X,"^",4)-N
if T<1
SET T=""
SET $PIECE(X,"^",4)=T
+20 SET ^MAG(2006.587,0)=X
+21 LOCK -^MAG(2006.587,0)
+22 SET OUT=N_" entr"_$SELECT(N=1:"y",1:"ies")_" removed"
+23 QUIT
+24 ;
