MAGDRPC1 ;WOIFO/EDM,DAC - Imaging RPCs ; Feb 15, 2022@10:28:27
;;3.0;IMAGING;**11,30,51,50,54,49,122,138,239,305**;Mar 19, 2002;Build 3
;; 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. |
;; +---------------------------------------------------------------+
;;
;;
; Supported IA #3065 reference $$HLNAME^XLFNAME function call
;
Q
;
GETPID(OUT) ; RPC = MAG DICOM GET PROCESS ID
S OUT=$J
Q
;
GETID(OUT,HOSTNAME) ; RPC = MAG DICOM GET MACHINE ID
N D0,I,LO,N,UP,X
S HOSTNAME=$TR($G(HOSTNAME),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
I HOSTNAME="" S OUT="-1,No Hostname Specified" Q
S OUT=$O(^MAGDICOM(2006.5641,"C",HOSTNAME,""))
Q:OUT>0
L +^MAGDICOM(2006.5641,0):1E9 ; Background process MUST wait
S D0=$O(^MAGDICOM(2006.5641," "),-1)+1
S ^MAGDICOM(2006.5641,D0,0)=D0_"^"_HOSTNAME_"^"_$H
S ^MAGDICOM(2006.5641,"B",D0,D0)=""
S ^MAGDICOM(2006.5641,"C",HOSTNAME,D0)=""
S (N,I,D0)=0 F S D0=$O(^MAGDICOM(2006.5641,D0)) Q:'D0 S N=N+1,I=D0
S ^MAGDICOM(2006.5641,0)="DICOM GATEWAY MACHINE ID^2006.5641^"_I_"^"_N
L -^MAGDICOM(2006.5641,0)
S OUT=D0
Q
;
DOMAIN(OUT) ; RPC = MAG DICOM GET DOMAIN
N X
S OUT=$$KSP^XUPARAM("WHERE") Q:OUT'="" ; ICR 2541
; The coding standards frown upon the line below,
; but it is the best we can do when the line above cannot be used.
S X=^DD("SITE") S:X'[".DOMAIN.EXT" X=X_".DOMAIN.EXT"
S OUT=X
Q
;
AGENCY(OUT) ; RPC = MAG DICOM GET AGENCY
S OUT=$G(DUZ("AG")) ;P123
Q
;
INFO(OUT,LOCATION) ; RPC = MAG DICOM ET PHONE HOME
N FST,N,X
K OUT
S FST=$$FMADD^XLFDT(DT,-25)
S N=2
;
; Site-ID
D DOMAIN(.X)
S OUT(N)=X
;
D ROUTEDAY^MAGDRPC2 ; Get routing statistics
;
D ; Text Gateway Statistics
. N A,C,D0,D2,M,X
. S A=0,D0=FST F S D0=$O(^MAGDAUDT(2006.5761,D0)) Q:'D0 D
. . S D2=0 F S D2=$O(^MAGDAUDT(2006.5761,D0,1,LOCATION,1,D2)) Q:'D2 D
. . . S X=$G(^MAGDAUDT(2006.5761,D0,1,LOCATION,1,D2,0))
. . . S M=$P(X,"^",2) Q:'M
. . . S:'A N=N+1,OUT(N)="Audit",A=1
. . . S N=N+1,OUT(N)="STTX="_D0_"^"_$P(X,"^",1)_"^"_M
. . . Q
. . Q
. Q
;
S OUT(1)=N-1
Q
;
STATION(OUT,STATION,VERSION) ; RPC = MAG DICOM WORKSTATION VERSION
N D0,X
I $G(STATION)="" S OUT="-1,No Station Identifier Specified" Q
;
S D0=$O(^MAG(2006.83,"B",STATION,"")) D:'D0
. L +^MAG(2006.83,0):1E9 ; Background process must wait for LOCK
. S X=$G(^MAG(2006.83,0))
. S $P(X,"^",1,2)="DICOM WORKSTATION^2006.83"
. S D0=$O(^MAG(2006.83," "),-1)+1
. S $P(X,"^",3)=D0
. S $P(X,"^",4)=$P(X,"^",4)+1
. S ^MAG(2006.83,0)=X,^MAG(2006.83,D0,0)=STATION
. S ^MAG(2006.83,"B",STATION,D0)=""
. L -^MAG(2006.83,0)
. Q
S $P(^MAG(2006.83,D0,0),"^",3)=VERSION
S X=$P(^MAG(2006.83,D0,0),"^",2)
S $P(^MAG(2006.83,D0,0),"^",2)=$$NOW^XLFDT()
S OUT=D0
Q
;
FMGET(OUT,FILE,D0,FIELD) ; RPC = MAG DICOM FILEMAN GET
; Get the value of a data field
S OUT=$$GET1^DIQ(FILE,D0,FIELD)
Q
;
CUTOFF(OUT,D0) ; RPC = MAG DICOM PACS CUTOFF DATE
; Retention Period for PACS
N X
I '$$CONSOLID^MAGBAPI() D Q
. ; Non-consolidated site
. I '$D(^MAG(2006.1,"APACS")) S OUT="-2,No PACS Installed" Q
. ;
. S X=$G(^MAG(2006.1,"AIMDELPACS"))
. I X="" S OUT="-3,PACS Retention Parameter not defined" Q
. S OUT=X
. Q
; Consolidated site:
I '$P($G(^MAG(2006.1,D0,"PACS")),"^",1) S OUT="-2,No PACS Installed" Q
;
S X=$P($G(^MAG(2006.1,D0,1)),"^",5)
I X="" S OUT="-3,PACS Retention Parameter not defined" Q
S OUT=X
Q
;
MINSPACE(OUT,D0) ; RPC = MAG DICOM PACS MINIMUM SPACE
; Minimum Percentage of Free Disk Space
N X
I '$$CONSOLID^MAGBAPI() D Q
. ; Non-consolidated site
. I '$D(^MAG(2006.1,"APACS")) S OUT="-2,No PACS Installed" Q
. ;
. S X=$G(^MAG(2006.1,"AIMDELPACS2"))
. I X="" S OUT="-3,PACS Minimum Space Percentage Parameter not defined" Q
. S OUT=X
. Q
; Consolidated site:
I '$P($G(^MAG(2006.1,D0,"PACS")),"^",1) S OUT="-2,No PACS Installed" Q
;
S X=$P($G(^MAG(2006.1,D0,3)),"^",5)
I X="" S OUT="-3,PACS Minimum Space Percentage Parameter not defined" Q
S OUT=X
Q
;
HL7PURGE(OUT,CUTOFF) ; RPC = MAG DICOM PURGE HL7
; Purge HL7 transactions
N D,D0,P,T,X
S OUT=0
S D="" F S D=$O(^MAGDHL7(2006.5,"B",D)) Q:'D Q:D'<CUTOFF D
. S D0="" F S D0=$O(^MAGDHL7(2006.5,"B",D,D0)) Q:'D0 D
. . S X=$G(^MAGDHL7(2006.5,D0,0)),P=$P(X,"^",4),T=$P(X,"^",3)
. . K ^MAGDHL7(2006.5,D0)
. . K ^MAGDHL7(2006.5,"B",D,D0)
. . K:T'="" ^MAGDHL7(2006.5,"C",T,D0)
. . K:P'="" ^MAGDHL7(2006.5,"D",P,D0)
. . S OUT=OUT+1
. . Q
. Q
D:OUT
. L +^MAGDHL7(2006.5,0):1E9
. S X=$G(^MAGDHL7(2006.5,0))
. S $P(X,"^",1,2)="PACS MESSAGES^2006.5D"
. S $P(X,"^",4)=$P(X,"^",4)-OUT
. S ^MAGDHL7(2006.5,0)=X
. L -^MAGDHL7(2006.5,0)
. Q
Q
;
VALDEST(OUT,NAME) ; RPC = MAG DICOM ROUTE VALID DEST
N D0,PLACE,X
; This function is also called from various routines
; that belong to automated routing.
;
S OUT="-1,"""_NAME_""" is not a valid destination"
;
I $D(^MAG(2005.2,"B")) D Q
. S D0=$O(^MAG(2005.2,"B",NAME,"")) Q:'D0
. S:$P($G(^MAG(2005.2,D0,0)),"^",9) OUT=D0
. Q
;
S D0=""
S PLACE="" F S PLACE=$O(^MAG(2005.2,"D",PLACE)) Q:PLACE="" D Q:OUT>0
. S D0=$O(^MAG(2005.2,"D",PLACE,NAME,""))
. S:$P($G(^MAG(2005.2,D0,0)),"^",9) OUT=D0
. Q
Q
;
PAT(OUT,DFN) ; RPC = MAG DICOM GET PATIENT
N DIQUIET,I,N,VA,VADM,VAIN,VAPA,VASD
K OUT
I '$G(DFN) S OUT(1)="-1,No Patient Identified" Q
S N=1,DIQUIET=1
D DEM^VADPT,VA("DEM","VADM","") D VA("ID","VA","")
D ADD^VADPT,VA("ADD","VAPA","")
D INP^VADPT,VA("INP","VAIN","")
D SDA^VADPT,VA("SDA","VASD","")
I $T(GETICN^MPIF001)'="" S X=$$GETICN^MPIF001(DFN) S:X'<0 N=N+1,OUT(N)="ICN^1^"_X
S N=N+1,OUT(N)="Site-DFN^1^"_$$STATNUMB^MAGDFCNV()_"-"_DFN
S OUT(1)=N-1
Q
;
DCMNAME(OUT,DFN,DELIM) ; RPC = MAG GET DICOM FMT PATIENT NAME
; P239 DAC - New RPC added
; HL7: family ^ given ^ middle ^ suffix ^ prefix ^ degree
; DICOM: family ^ given ^ middle ^ prefix ^ suffix (4 & 5 swapped, no degree)
N DGNAME,DICOMNAME,HL7NAME
K OUT
I '$G(DFN) S OUT="-1,No Patient Identified" Q
S DGNAME("FILE")=2,DGNAME("IENS")=DFN,DGNAME("FIELD")=.01
S HL7NAME=$$HLNAME^XLFNAME(.DGNAME,"","^") ; get HL7 formatted name
I HL7NAME="" S OUT="-2,No patient found with DFN="_DFN Q
; convert to DICOM format by swapping 4th and 5th components
S DICOMNAME=$P(HL7NAME,"^",1,3) ; family ^ given ^ middle
S $P(DICOMNAME,"^",4)=$P(HL7NAME,"^",5) ; prefix (e.g., DR)
S $P(DICOMNAME,"^",5)=$P(HL7NAME,"^",4) ; suffix (e.g., JR or III)
I $D(DELIM) S DICOMNAME=$TR(DICOMNAME,"^",DELIM)
S OUT=DICOMNAME
Q
;
VA(PRE,ARR,SUB) N A,I,X
S I="" F S I=$O(@ARR@(I)) Q:I="" D
. S A=$NAME(@ARR@(I))
. S X=$G(@A) S:X'="" N=N+1,OUT(N)=PRE_"^"_SUB_I_"^"_X
. D:$D(@A)>9 VA(PRE,A,SUB_I_",")
. Q
Q
;
RARPTO(OUT,TYPE,D0,F,D1) ; RPC = MAG DICOM GET RAD RPT INFO
S TYPE=$G(TYPE),D0=$G(D0),F=$G(F,1),D1=+$G(D1)
I TYPE="O1" S OUT=+$O(^RARPT(D0),F) Q
I TYPE="O2" S OUT=+$O(^RARPT(D0,F,D1)) Q
I TYPE="G1" S OUT=$G(^RARPT(D0,0)) Q
I TYPE="G2" S OUT=$G(^RARPT(D0,F,D1,0)) Q
S OUT="-1,Invalid request type ("""_TYPE_""")"
Q
;
LISTORIG(OUT) ; RPC = MAG GET DICOM XMIT ORIGIN
N FROM,MSG,N,PRI,RTN
S N=1,OUT(1)="No entries in transmission queue"
S FROM="" F S FROM=$O(^MAGDOUTP(2006.574,"STATE",FROM)) Q:FROM="" D
. D GETS^DIQ(4,FROM,.01,"","RTN","MSG")
. S N=N+1,OUT(N)=FROM_"^"_$G(RTN(4,FROM_",",.01))
. Q
S:N>1 OUT(1)=N
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDRPC1 8325 printed Sep 23, 2025@19:37:32 Page 2
MAGDRPC1 ;WOIFO/EDM,DAC - Imaging RPCs ; Feb 15, 2022@10:28:27
+1 ;;3.0;IMAGING;**11,30,51,50,54,49,122,138,239,305**;Mar 19, 2002;Build 3
+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 ;;
+18 ; Supported IA #3065 reference $$HLNAME^XLFNAME function call
+19 ;
+20 QUIT
+21 ;
GETPID(OUT) ; RPC = MAG DICOM GET PROCESS ID
+1 SET OUT=$JOB
+2 QUIT
+3 ;
GETID(OUT,HOSTNAME) ; RPC = MAG DICOM GET MACHINE ID
+1 NEW D0,I,LO,N,UP,X
+2 SET HOSTNAME=$TRANSLATE($GET(HOSTNAME),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+3 IF HOSTNAME=""
SET OUT="-1,No Hostname Specified"
QUIT
+4 SET OUT=$ORDER(^MAGDICOM(2006.5641,"C",HOSTNAME,""))
+5 if OUT>0
QUIT
+6 ; Background process MUST wait
LOCK +^MAGDICOM(2006.5641,0):1E9
+7 SET D0=$ORDER(^MAGDICOM(2006.5641," "),-1)+1
+8 SET ^MAGDICOM(2006.5641,D0,0)=D0_"^"_HOSTNAME_"^"_$HOROLOG
+9 SET ^MAGDICOM(2006.5641,"B",D0,D0)=""
+10 SET ^MAGDICOM(2006.5641,"C",HOSTNAME,D0)=""
+11 SET (N,I,D0)=0
FOR
SET D0=$ORDER(^MAGDICOM(2006.5641,D0))
if 'D0
QUIT
SET N=N+1
SET I=D0
+12 SET ^MAGDICOM(2006.5641,0)="DICOM GATEWAY MACHINE ID^2006.5641^"_I_"^"_N
+13 LOCK -^MAGDICOM(2006.5641,0)
+14 SET OUT=D0
+15 QUIT
+16 ;
DOMAIN(OUT) ; RPC = MAG DICOM GET DOMAIN
+1 NEW X
+2 ; ICR 2541
SET OUT=$$KSP^XUPARAM("WHERE")
if OUT'=""
QUIT
+3 ; The coding standards frown upon the line below,
+4 ; but it is the best we can do when the line above cannot be used.
+5 SET X=^DD("SITE")
if X'[".DOMAIN.EXT"
SET X=X_".DOMAIN.EXT"
+6 SET OUT=X
+7 QUIT
+8 ;
AGENCY(OUT) ; RPC = MAG DICOM GET AGENCY
+1 ;P123
SET OUT=$GET(DUZ("AG"))
+2 QUIT
+3 ;
INFO(OUT,LOCATION) ; RPC = MAG DICOM ET PHONE HOME
+1 NEW FST,N,X
+2 KILL OUT
+3 SET FST=$$FMADD^XLFDT(DT,-25)
+4 SET N=2
+5 ;
+6 ; Site-ID
+7 DO DOMAIN(.X)
+8 SET OUT(N)=X
+9 ;
+10 ; Get routing statistics
DO ROUTEDAY^MAGDRPC2
+11 ;
+12 ; Text Gateway Statistics
Begin DoDot:1
+13 NEW A,C,D0,D2,M,X
+14 SET A=0
SET D0=FST
FOR
SET D0=$ORDER(^MAGDAUDT(2006.5761,D0))
if 'D0
QUIT
Begin DoDot:2
+15 SET D2=0
FOR
SET D2=$ORDER(^MAGDAUDT(2006.5761,D0,1,LOCATION,1,D2))
if 'D2
QUIT
Begin DoDot:3
+16 SET X=$GET(^MAGDAUDT(2006.5761,D0,1,LOCATION,1,D2,0))
+17 SET M=$PIECE(X,"^",2)
if 'M
QUIT
+18 if 'A
SET N=N+1
SET OUT(N)="Audit"
SET A=1
+19 SET N=N+1
SET OUT(N)="STTX="_D0_"^"_$PIECE(X,"^",1)_"^"_M
+20 QUIT
End DoDot:3
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
+23 ;
+24 SET OUT(1)=N-1
+25 QUIT
+26 ;
STATION(OUT,STATION,VERSION) ; RPC = MAG DICOM WORKSTATION VERSION
+1 NEW D0,X
+2 IF $GET(STATION)=""
SET OUT="-1,No Station Identifier Specified"
QUIT
+3 ;
+4 SET D0=$ORDER(^MAG(2006.83,"B",STATION,""))
if 'D0
Begin DoDot:1
+5 ; Background process must wait for LOCK
LOCK +^MAG(2006.83,0):1E9
+6 SET X=$GET(^MAG(2006.83,0))
+7 SET $PIECE(X,"^",1,2)="DICOM WORKSTATION^2006.83"
+8 SET D0=$ORDER(^MAG(2006.83," "),-1)+1
+9 SET $PIECE(X,"^",3)=D0
+10 SET $PIECE(X,"^",4)=$PIECE(X,"^",4)+1
+11 SET ^MAG(2006.83,0)=X
SET ^MAG(2006.83,D0,0)=STATION
+12 SET ^MAG(2006.83,"B",STATION,D0)=""
+13 LOCK -^MAG(2006.83,0)
+14 QUIT
End DoDot:1
+15 SET $PIECE(^MAG(2006.83,D0,0),"^",3)=VERSION
+16 SET X=$PIECE(^MAG(2006.83,D0,0),"^",2)
+17 SET $PIECE(^MAG(2006.83,D0,0),"^",2)=$$NOW^XLFDT()
+18 SET OUT=D0
+19 QUIT
+20 ;
FMGET(OUT,FILE,D0,FIELD) ; RPC = MAG DICOM FILEMAN GET
+1 ; Get the value of a data field
+2 SET OUT=$$GET1^DIQ(FILE,D0,FIELD)
+3 QUIT
+4 ;
CUTOFF(OUT,D0) ; RPC = MAG DICOM PACS CUTOFF DATE
+1 ; Retention Period for PACS
+2 NEW X
+3 IF '$$CONSOLID^MAGBAPI()
Begin DoDot:1
+4 ; Non-consolidated site
+5 IF '$DATA(^MAG(2006.1,"APACS"))
SET OUT="-2,No PACS Installed"
QUIT
+6 ;
+7 SET X=$GET(^MAG(2006.1,"AIMDELPACS"))
+8 IF X=""
SET OUT="-3,PACS Retention Parameter not defined"
QUIT
+9 SET OUT=X
+10 QUIT
End DoDot:1
QUIT
+11 ; Consolidated site:
+12 IF '$PIECE($GET(^MAG(2006.1,D0,"PACS")),"^",1)
SET OUT="-2,No PACS Installed"
QUIT
+13 ;
+14 SET X=$PIECE($GET(^MAG(2006.1,D0,1)),"^",5)
+15 IF X=""
SET OUT="-3,PACS Retention Parameter not defined"
QUIT
+16 SET OUT=X
+17 QUIT
+18 ;
MINSPACE(OUT,D0) ; RPC = MAG DICOM PACS MINIMUM SPACE
+1 ; Minimum Percentage of Free Disk Space
+2 NEW X
+3 IF '$$CONSOLID^MAGBAPI()
Begin DoDot:1
+4 ; Non-consolidated site
+5 IF '$DATA(^MAG(2006.1,"APACS"))
SET OUT="-2,No PACS Installed"
QUIT
+6 ;
+7 SET X=$GET(^MAG(2006.1,"AIMDELPACS2"))
+8 IF X=""
SET OUT="-3,PACS Minimum Space Percentage Parameter not defined"
QUIT
+9 SET OUT=X
+10 QUIT
End DoDot:1
QUIT
+11 ; Consolidated site:
+12 IF '$PIECE($GET(^MAG(2006.1,D0,"PACS")),"^",1)
SET OUT="-2,No PACS Installed"
QUIT
+13 ;
+14 SET X=$PIECE($GET(^MAG(2006.1,D0,3)),"^",5)
+15 IF X=""
SET OUT="-3,PACS Minimum Space Percentage Parameter not defined"
QUIT
+16 SET OUT=X
+17 QUIT
+18 ;
HL7PURGE(OUT,CUTOFF) ; RPC = MAG DICOM PURGE HL7
+1 ; Purge HL7 transactions
+2 NEW D,D0,P,T,X
+3 SET OUT=0
+4 SET D=""
FOR
SET D=$ORDER(^MAGDHL7(2006.5,"B",D))
if 'D
QUIT
if D'<CUTOFF
QUIT
Begin DoDot:1
+5 SET D0=""
FOR
SET D0=$ORDER(^MAGDHL7(2006.5,"B",D,D0))
if 'D0
QUIT
Begin DoDot:2
+6 SET X=$GET(^MAGDHL7(2006.5,D0,0))
SET P=$PIECE(X,"^",4)
SET T=$PIECE(X,"^",3)
+7 KILL ^MAGDHL7(2006.5,D0)
+8 KILL ^MAGDHL7(2006.5,"B",D,D0)
+9 if T'=""
KILL ^MAGDHL7(2006.5,"C",T,D0)
+10 if P'=""
KILL ^MAGDHL7(2006.5,"D",P,D0)
+11 SET OUT=OUT+1
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 if OUT
Begin DoDot:1
+15 LOCK +^MAGDHL7(2006.5,0):1E9
+16 SET X=$GET(^MAGDHL7(2006.5,0))
+17 SET $PIECE(X,"^",1,2)="PACS MESSAGES^2006.5D"
+18 SET $PIECE(X,"^",4)=$PIECE(X,"^",4)-OUT
+19 SET ^MAGDHL7(2006.5,0)=X
+20 LOCK -^MAGDHL7(2006.5,0)
+21 QUIT
End DoDot:1
+22 QUIT
+23 ;
VALDEST(OUT,NAME) ; RPC = MAG DICOM ROUTE VALID DEST
+1 NEW D0,PLACE,X
+2 ; This function is also called from various routines
+3 ; that belong to automated routing.
+4 ;
+5 SET OUT="-1,"""_NAME_""" is not a valid destination"
+6 ;
+7 IF $DATA(^MAG(2005.2,"B"))
Begin DoDot:1
+8 SET D0=$ORDER(^MAG(2005.2,"B",NAME,""))
if 'D0
QUIT
+9 if $PIECE($GET(^MAG(2005.2,D0,0)),"^",9)
SET OUT=D0
+10 QUIT
End DoDot:1
QUIT
+11 ;
+12 SET D0=""
+13 SET PLACE=""
FOR
SET PLACE=$ORDER(^MAG(2005.2,"D",PLACE))
if PLACE=""
QUIT
Begin DoDot:1
+14 SET D0=$ORDER(^MAG(2005.2,"D",PLACE,NAME,""))
+15 if $PIECE($GET(^MAG(2005.2,D0,0)),"^",9)
SET OUT=D0
+16 QUIT
End DoDot:1
if OUT>0
QUIT
+17 QUIT
+18 ;
PAT(OUT,DFN) ; RPC = MAG DICOM GET PATIENT
+1 NEW DIQUIET,I,N,VA,VADM,VAIN,VAPA,VASD
+2 KILL OUT
+3 IF '$GET(DFN)
SET OUT(1)="-1,No Patient Identified"
QUIT
+4 SET N=1
SET DIQUIET=1
+5 DO DEM^VADPT
DO VA("DEM","VADM","")
DO VA("ID","VA","")
+6 DO ADD^VADPT
DO VA("ADD","VAPA","")
+7 DO INP^VADPT
DO VA("INP","VAIN","")
+8 DO SDA^VADPT
DO VA("SDA","VASD","")
+9 IF $TEXT(GETICN^MPIF001)'=""
SET X=$$GETICN^MPIF001(DFN)
if X'<0
SET N=N+1
SET OUT(N)="ICN^1^"_X
+10 SET N=N+1
SET OUT(N)="Site-DFN^1^"_$$STATNUMB^MAGDFCNV()_"-"_DFN
+11 SET OUT(1)=N-1
+12 QUIT
+13 ;
DCMNAME(OUT,DFN,DELIM) ; RPC = MAG GET DICOM FMT PATIENT NAME
+1 ; P239 DAC - New RPC added
+2 ; HL7: family ^ given ^ middle ^ suffix ^ prefix ^ degree
+3 ; DICOM: family ^ given ^ middle ^ prefix ^ suffix (4 & 5 swapped, no degree)
+4 NEW DGNAME,DICOMNAME,HL7NAME
+5 KILL OUT
+6 IF '$GET(DFN)
SET OUT="-1,No Patient Identified"
QUIT
+7 SET DGNAME("FILE")=2
SET DGNAME("IENS")=DFN
SET DGNAME("FIELD")=.01
+8 ; get HL7 formatted name
SET HL7NAME=$$HLNAME^XLFNAME(.DGNAME,"","^")
+9 IF HL7NAME=""
SET OUT="-2,No patient found with DFN="_DFN
QUIT
+10 ; convert to DICOM format by swapping 4th and 5th components
+11 ; family ^ given ^ middle
SET DICOMNAME=$PIECE(HL7NAME,"^",1,3)
+12 ; prefix (e.g., DR)
SET $PIECE(DICOMNAME,"^",4)=$PIECE(HL7NAME,"^",5)
+13 ; suffix (e.g., JR or III)
SET $PIECE(DICOMNAME,"^",5)=$PIECE(HL7NAME,"^",4)
+14 IF $DATA(DELIM)
SET DICOMNAME=$TRANSLATE(DICOMNAME,"^",DELIM)
+15 SET OUT=DICOMNAME
+16 QUIT
+17 ;
VA(PRE,ARR,SUB) NEW A,I,X
+1 SET I=""
FOR
SET I=$ORDER(@ARR@(I))
if I=""
QUIT
Begin DoDot:1
+2 SET A=$NAME(@ARR@(I))
+3 SET X=$GET(@A)
if X'=""
SET N=N+1
SET OUT(N)=PRE_"^"_SUB_I_"^"_X
+4 if $DATA(@A)>9
DO VA(PRE,A,SUB_I_",")
+5 QUIT
End DoDot:1
+6 QUIT
+7 ;
RARPTO(OUT,TYPE,D0,F,D1) ; RPC = MAG DICOM GET RAD RPT INFO
+1 SET TYPE=$GET(TYPE)
SET D0=$GET(D0)
SET F=$GET(F,1)
SET D1=+$GET(D1)
+2 IF TYPE="O1"
SET OUT=+$ORDER(^RARPT(D0),F)
QUIT
+3 IF TYPE="O2"
SET OUT=+$ORDER(^RARPT(D0,F,D1))
QUIT
+4 IF TYPE="G1"
SET OUT=$GET(^RARPT(D0,0))
QUIT
+5 IF TYPE="G2"
SET OUT=$GET(^RARPT(D0,F,D1,0))
QUIT
+6 SET OUT="-1,Invalid request type ("""_TYPE_""")"
+7 QUIT
+8 ;
LISTORIG(OUT) ; RPC = MAG GET DICOM XMIT ORIGIN
+1 NEW FROM,MSG,N,PRI,RTN
+2 SET N=1
SET OUT(1)="No entries in transmission queue"
+3 SET FROM=""
FOR
SET FROM=$ORDER(^MAGDOUTP(2006.574,"STATE",FROM))
if FROM=""
QUIT
Begin DoDot:1
+4 DO GETS^DIQ(4,FROM,.01,"","RTN","MSG")
+5 SET N=N+1
SET OUT(N)=FROM_"^"_$GET(RTN(4,FROM_",",.01))
+6 QUIT
End DoDot:1
+7 if N>1
SET OUT(1)=N
+8 QUIT
+9 ;
