- 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 Feb 18, 2025@23:26 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 ;