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