MAGDRPC8 ;WOIFO/EdM,BT,DAC,PMK - RPCs for Master Files ; Apr 03, 2020@10:13:43
;;3.0;IMAGING;**11,30,51,54,118,138,156,161,231**;Mar 19, 2002;Build 9;Sep 1, 2015
;; 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 #4389 reference $$FIND^DIC function call
; Supported IA #2056 reference $$GET1^DIQ function call
; Supported IA #2171 reference SIBLING^XUAF4 subroutine call
; Supported IA #10103 reference $$FMTE^XLFDT function call
; Supported IA #10103 reference $$NOW^XLFDT function call
; Supported IA #2541 reference $$KSP^XUPARAM function call
;
Q
;
UPDTAPP(OUT,APP) ; RPC = MAG DICOM UPDATE SCU LIST
N A,D0,D1,DIMSE,GWLOC,GWNAM,HDR,I,MIN,N,NOW,P5,P7,PLUS,SERVNAM,UP,X
S (GWNAM,GWLOC)="",N=0
S A="" F S A=$O(APP(A)) Q:A="" D
. Q:A["_"
. S X=APP(A) F I=1:1:7 S:$P(X,"^",I)="" N=N+1 ; P161 DAC - fix for SCU LIST field checking
. S:GWNAM="" GWNAM=$P(X,"^",5)
. S:GWLOC="" GWLOC=$P(X,"^",7)
. S:GWNAM'=$P(X,"^",5) N=N+1
. S:GWLOC'=$P(X,"^",7) N=N+1
. S:'N A($P(X,"^",1))=A ; ^MAGDMFBS guarantees unique names
. Q
I N S OUT="-1,Missing or Inconsistent Parameters." Q
;
L +^MAG(2006.587,0):1E9 ; Background task MUST wait
S HDR=$G(^MAG(2006.587,0))
S $P(HDR,"^",1,2)="DICOM TRANSMIT DESTINATION^2006.587"
;
S NOW=$$NOW^XLFDT(),(MIN,PLUS,UP)=0
;
S D0="" F S D0=$O(^MAG(2006.587,"D",GWNAM,GWLOC,D0)) Q:D0="" D
. S X=$G(^MAG(2006.587,D0,0)),SERVNAM=$P(X,"^",1) Q:SERVNAM=""
. S P5=$P(X,"^",5),P7=$P(X,"^",7)
. I P5'="",P7'="" K ^MAG(2006.587,"C",SERVNAM,P7,P5,D0),^MAG(2006.587,"D",P5,P7,D0)
. I '$D(A(SERVNAM)) D Q
. . K ^MAG(2006.587,D0),^MAG(2006.587,"B",SERVNAM,D0) S MIN=MIN+1
. . Q
. S X=APP(A(SERVNAM)),$P(X,"^",8)=NOW K APP(A(SERVNAM))
. S ^MAG(2006.587,D0,0)=$P(X,"^",1,9),UP=UP+1
. S ^MAG(2006.587,"C",SERVNAM,GWLOC,GWNAM,D0)=""
. S ^MAG(2006.587,"D",GWNAM,GWLOC,D0)=""
. K DIMSE S DIMSE=A(SERVNAM)_"_"
. S X=DIMSE F S X=$O(APP(X)) Q:$E(X,1,$L(DIMSE))'=DIMSE D
. . S N=$P(X,"_",2) Q:N=""
. . S DIMSE(N)=APP(X)
. . S DIMSE("C-ECHO")="1^1"
. . Q
. K ^MAG(2006.587,D0,1)
. S D1=0,X="" F S X=$O(DIMSE(X)) Q:X="" D
. . S D1=D1+1,^MAG(2006.587,D0,1,D1,0)=X_"^"_DIMSE(X)
. . S ^MAG(2006.587,D0,1,"B",X,D1)=""
. . Q
. S:D1 ^MAG(2006.587,D0,1,0)="^2006.5871SA^"_D1_"^"_D1
. Q
S $P(HDR,"^",4)=$P(HDR,"^",4)-MIN
;
S A="" F S A=$O(APP(A)) Q:A="" D
. Q:A["_"
. S X=APP(A),$P(X,"^",8)=NOW
. S D0=$O(^MAG(2006.587," "),-1)+1,PLUS=PLUS+1,$P(HDR,"^",3)=D0
. S ^MAG(2006.587,D0,0)=$P(X,"^",1,9),SERVNAM=$P(X,"^",1) ; PMK P231 2/5/2020
. S ^MAG(2006.587,"B",SERVNAM,D0)=""
. S ^MAG(2006.587,"C",SERVNAM,GWLOC,GWNAM,D0)=""
. S ^MAG(2006.587,"D",GWNAM,GWLOC,D0)=""
. K DIMSE S DIMSE=A_"_"
. S X=DIMSE F S X=$O(APP(X)) Q:$E(X,1,$L(DIMSE))'=DIMSE D
. . S N=$P(X,"_",2) Q:N=""
. . S DIMSE(N)=APP(X)
. . S DIMSE("C-ECHO")="1^1"
. . Q
. K ^MAG(2006.587,D0,1)
. S D1=0,X="" F S X=$O(DIMSE(X)) Q:X="" D
. . S D1=D1+1,^MAG(2006.587,D0,1,D1,0)=X_"^"_DIMSE(X)
. . S ^MAG(2006.587,D0,1,"B",X,D1)=""
. . Q
. S:D1 ^MAG(2006.587,D0,1,0)="^2006.5871SA^"_D1_"^"_D1
. Q
S (N,D0)=0 F S D0=$O(^MAG(2006.587,D0)) Q:'D0 S N=N+1
S $P(HDR,"^",4)=N
S ^MAG(2006.587,0)=HDR
L -^MAG(2006.587,0)
S OUT="1"
S:PLUS OUT=OUT_", "_PLUS_" added"
S:MIN OUT=OUT_", "_MIN_" removed"
S:UP OUT=OUT_", "_UP_" updated"
Q
;
UPDTGW(OUT,ONAM,NNAM,OLOC,NLOC) ; RPC = MAG DICOM UPDATE GATEWAY NAME
N D0,P1,P5,P7,N
I $G(NNAM)="" S OUT="-1,No Gateway Name specified" Q
I '$G(NLOC) S OUT="-2,No Gateway Location specified" Q
S OLOC=$G(OLOC),ONAM=$G(ONAM)
S (N,D0)=0 F S D0=$O(^MAG(2006.587,D0)) Q:'D0 D
. S X=$G(^MAG(2006.587,D0,0)),P5=$P(X,"^",5) Q:P5'=ONAM
. S P1=$P(X,"^",1),P7=$P(X,"^",7)
. I OLOC'="",P5'="",P1'="" K ^MAG(2006.587,"C",P1,OLOC,P5,D0)
. I OLOC'="",P5'="" K ^MAG(2006.587,"D",P5,OLOC,D0)
. S $P(X,"^",5)=NNAM,$P(X,"^",7)=NLOC
. S ^MAG(2006.587,D0,0)=X
. S:P1'="" ^MAG(2006.587,"C",P1,NLOC,NNAM,D0)=""
. S ^MAG(2006.587,"D",NNAM,NLOC,D0)=""
. S N=N+1
. Q
S OUT=N
Q
;
SIBS(P0,T) N MAGLOC,P1,P2
S T(P0)=""
D SIBLING^XUAF4("MAGLOC",P0,"PARENT FACILITY")
S P1="" F S P1=$O(MAGLOC("P",P1)) Q:P1="" D
. S P2="" F S P2=$O(MAGLOC("P",P1,"C",P2)) Q:P2="" S T(P2)=""
. Q
Q
;
LOCS(OUT) ; RPC = MAG DICOM VALID LOCATIONS
N D0,I,MAGM,N,P1,MAGR,T
S N=1
S D0=0 F S D0=$O(^MAG(2006.1,D0)) Q:'D0 D
. S X=$G(^MAG(2006.1,D0,0)),P1=$P(X,"^",1) Q:P1=""
. I +P1=P1 S T(P1)="" Q
. D FIND^DIC(4,"","","BX",P1,"*","","","","MAGR","MAGM")
. S I=0 F S I=$O(MAGR("DILIST",2,I)) Q:'I D
. . S P1=MAGR("DILIST",2,I) I P1 K MAGR S T(P1)=""
. . Q
. Q
I $T(^XUPARAM)'="" S P1=$$KSP^XUPARAM("INST") D:P1 SIBS(P1,.T)
S P1=+$G(^DD("SITE",1)) D:P1 SIBS(P1,.T)
;
S P1="" F S P1=$O(T(P1)) Q:P1="" D
. S N=N+1,OUT(N)=P1_"^"_$$GET1^DIQ(4,P1,.01)_"^"_$$GET1^DIQ(4,P1,99)
. Q
S OUT(1)=N-1
Q
;
GETPLACE(OUT,LOCATION) ; RPC = MAG DICOM GET PLACE
N D0,P1,MAGM,MAGR,X
S LOCATION=+$G(LOCATION)
S OUT="-1,Location """_LOCATION_""" not found."
S D0=0 F S D0=$O(^MAG(2006.1,D0)) Q:'D0 D Q:OUT>0
. S X=$G(^MAG(2006.1,D0,0)),P1=$P(X,"^",1) Q:P1=""
. I +P1=P1,LOCATION=P1 S OUT=D0 Q
. D FIND^DIC(4,"","","BX",P1,"*","","","","MAGR","MAGM")
. S I=0 F S I=$O(MAGR("DILIST",2,I)) Q:'I D
. . I LOCATION=MAGR("DILIST",2,I) S OUT=D0
. . Q
. Q
Q
;
SETPACS(OUT,D0) ; RPC = MAG DICOM SET PACS PARAMS
N X
I '$G(D0) S OUT="-1,No Place Specified." Q
I '$D(^MAG(2006.1,D0)) S OUT="-2,Invalid Place Specified." Q
;
; There is a PACS
S $P(^MAG(2006.1,D0,"PACS"),"^",1)=1
;
; Number of days to retain "PACS" images
S X=$P($G(^MAG(2006.1,D0,1)),"^",5)
S:'X $P(^MAG(2006.1,D0,1),"^",5)=30
;
; Set minimum % of free disk space to trigger automatic file delete
S X=$P($G(^MAG(2006.1,D0,3)),"^",6)
S:'X $P(^MAG(2006.1,D0,3),"^",6)=25
S OUT=1
Q
;
HIGHHL7(OUT) ; RPC = MAG DICOM GET HIGHEST HL7
S OUT=+$O(^MAGDHL7(2006.5," "),-1)
Q
;
FINDLOC(OUT,NAME) ; RPC = MAG DICOM FIND LOCATION
; NAME is the location to find in either Institution Name or Station Number
; fields of the Institution File (#4)
;
N MAGM,MAGR,I
S OUT="-1,Invalid location """_NAME_"""."
;
; Find NAME in either Institution Name or Station Number fields
D FIND^DIC(4,"",.01,"BXA",NAME,"*","B^D","","","MAGR","MAGM")
;
I MAGR("DILIST",0) D
. S I=$O(MAGR("DILIST",2,"")) ; If multiple found, return the first IEN
. S OUT=MAGR("DILIST",2,I)
Q
;
VALIMGT(OUT) ; RPC = MAG DICOM GET IMAGING TYPES
N N,X
S N=1
; Lists of valid imaging types
S X="" F S X=$O(^RA(79.2,"C",X)) Q:X="" S N=N+1,OUT(N)="RAD^"_X
S X="" F S X=$O(^MAG(2005.84,"C",X)) Q:X="" S N=N+1,OUT(N)="CON^"_X
S X="" F S X=$O(^MAG(2005.85,"C",X)) Q:X="" S N=N+1,OUT(N)="CON PROC^"_X
S OUT(1)=N-1
Q
;
CORRECT(OUT,LOCATION,MACHID) ; RPC = MAG DICOM INCORRECT IMAGE CT
; Check for images needing corrections
N CNT,D0,STUDY
I '$G(LOCATION) S OUT="-1,No Location Specified" Q
I $G(MACHID)="" S OUT="-2,No Gateway Specified" Q
S OUT=0
Q:'$O(^MAGD(2006.575,0))
Q:'$D(^MAGD(2006.575,"F",LOCATION))
S STUDY="" F S STUDY=$O(^MAGD(2006.575,"F",LOCATION,STUDY)) Q:STUDY="" D
. S D0=0 S D0=$O(^MAGD(2006.575,"F",LOCATION,STUDY,D0)) Q:'D0 D
. . Q:'$D(^MAGD(2006.575,D0,0))
. . S:MACHID=$P($G(^MAGD(2006.575,D0,1)),"^",4) OUT=OUT+1
. . Q
. Q
Q
;
HL7PTR(OUT,ACTION,VALUE) ; RPC = MAG DICOM HL7 POINTER ACTION
; Manipulate HL7 Pointer
N D0,P1,P2,X,Y
S ACTION=$G(ACTION),VALUE=$G(VALUE)
S OUT="-2,Invalid Request: """_ACTION_"""."
I ACTION="GetDate" D Q
. S X=$G(^MAGDHL7(2006.5,+VALUE,0))
. I X="" S OUT="-1,Invalid Pointer """_VALUE_"""." Q
. S OUT=$$FMTE^XLFDT($P(X,"^",3),1)
. Q
I ACTION="DatePtr" D Q
. S Y=$O(^MAGDHL7(2006.5,"C",VALUE),-1)
. I 'Y D ; before any date on file
. . ; if the requested date is before the first entry,
. . ; move the pointer to the first entry
. . S OUT=0
. . Q
. E D ; if the requested date is in the cross reference, use it.
. . S Y=$O(^MAGDHL7(2006.5,"C",Y,""))
. . I Y S OUT=Y ; found date
. . E D
. . . ; otherwise, find the appropriate entry the hard way
. . . S D0=$O(^MAGDHL7(2006.5,0))
. . . S Y=$P($G(^MAGDHL7(2006.5,D0,0)),"^",3) I Y'<X S OUT=0 Q
. . . S D0=" " F S D0=$O(^MAGDHL7(2006.5,D0),-1) Q:'D0 D Q:OUT
. . . . S Y=$P($G(^MAGDHL7(2006.5,D0,0)),"^",3) S:Y<X OUT=D0
. . . . Q
. . . Q
. . Q
. Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDRPC8 9431 printed Sep 23, 2025@19:37:39 Page 2
MAGDRPC8 ;WOIFO/EdM,BT,DAC,PMK - RPCs for Master Files ; Apr 03, 2020@10:13:43
+1 ;;3.0;IMAGING;**11,30,51,54,118,138,156,161,231**;Mar 19, 2002;Build 9;Sep 1, 2015
+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 #4389 reference $$FIND^DIC function call
+19 ; Supported IA #2056 reference $$GET1^DIQ function call
+20 ; Supported IA #2171 reference SIBLING^XUAF4 subroutine call
+21 ; Supported IA #10103 reference $$FMTE^XLFDT function call
+22 ; Supported IA #10103 reference $$NOW^XLFDT function call
+23 ; Supported IA #2541 reference $$KSP^XUPARAM function call
+24 ;
+25 QUIT
+26 ;
UPDTAPP(OUT,APP) ; RPC = MAG DICOM UPDATE SCU LIST
+1 NEW A,D0,D1,DIMSE,GWLOC,GWNAM,HDR,I,MIN,N,NOW,P5,P7,PLUS,SERVNAM,UP,X
+2 SET (GWNAM,GWLOC)=""
SET N=0
+3 SET A=""
FOR
SET A=$ORDER(APP(A))
if A=""
QUIT
Begin DoDot:1
+4 if A["_"
QUIT
+5 ; P161 DAC - fix for SCU LIST field checking
SET X=APP(A)
FOR I=1:1:7
if $PIECE(X,"^",I)=""
SET N=N+1
+6 if GWNAM=""
SET GWNAM=$PIECE(X,"^",5)
+7 if GWLOC=""
SET GWLOC=$PIECE(X,"^",7)
+8 if GWNAM'=$PIECE(X,"^",5)
SET N=N+1
+9 if GWLOC'=$PIECE(X,"^",7)
SET N=N+1
+10 ; ^MAGDMFBS guarantees unique names
if 'N
SET A($PIECE(X,"^",1))=A
+11 QUIT
End DoDot:1
+12 IF N
SET OUT="-1,Missing or Inconsistent Parameters."
QUIT
+13 ;
+14 ; Background task MUST wait
LOCK +^MAG(2006.587,0):1E9
+15 SET HDR=$GET(^MAG(2006.587,0))
+16 SET $PIECE(HDR,"^",1,2)="DICOM TRANSMIT DESTINATION^2006.587"
+17 ;
+18 SET NOW=$$NOW^XLFDT()
SET (MIN,PLUS,UP)=0
+19 ;
+20 SET D0=""
FOR
SET D0=$ORDER(^MAG(2006.587,"D",GWNAM,GWLOC,D0))
if D0=""
QUIT
Begin DoDot:1
+21 SET X=$GET(^MAG(2006.587,D0,0))
SET SERVNAM=$PIECE(X,"^",1)
if SERVNAM=""
QUIT
+22 SET P5=$PIECE(X,"^",5)
SET P7=$PIECE(X,"^",7)
+23 IF P5'=""
IF P7'=""
KILL ^MAG(2006.587,"C",SERVNAM,P7,P5,D0),^MAG(2006.587,"D",P5,P7,D0)
+24 IF '$DATA(A(SERVNAM))
Begin DoDot:2
+25 KILL ^MAG(2006.587,D0),^MAG(2006.587,"B",SERVNAM,D0)
SET MIN=MIN+1
+26 QUIT
End DoDot:2
QUIT
+27 SET X=APP(A(SERVNAM))
SET $PIECE(X,"^",8)=NOW
KILL APP(A(SERVNAM))
+28 SET ^MAG(2006.587,D0,0)=$PIECE(X,"^",1,9)
SET UP=UP+1
+29 SET ^MAG(2006.587,"C",SERVNAM,GWLOC,GWNAM,D0)=""
+30 SET ^MAG(2006.587,"D",GWNAM,GWLOC,D0)=""
+31 KILL DIMSE
SET DIMSE=A(SERVNAM)_"_"
+32 SET X=DIMSE
FOR
SET X=$ORDER(APP(X))
if $EXTRACT(X,1,$LENGTH(DIMSE))'=DIMSE
QUIT
Begin DoDot:2
+33 SET N=$PIECE(X,"_",2)
if N=""
QUIT
+34 SET DIMSE(N)=APP(X)
+35 SET DIMSE("C-ECHO")="1^1"
+36 QUIT
End DoDot:2
+37 KILL ^MAG(2006.587,D0,1)
+38 SET D1=0
SET X=""
FOR
SET X=$ORDER(DIMSE(X))
if X=""
QUIT
Begin DoDot:2
+39 SET D1=D1+1
SET ^MAG(2006.587,D0,1,D1,0)=X_"^"_DIMSE(X)
+40 SET ^MAG(2006.587,D0,1,"B",X,D1)=""
+41 QUIT
End DoDot:2
+42 if D1
SET ^MAG(2006.587,D0,1,0)="^2006.5871SA^"_D1_"^"_D1
+43 QUIT
End DoDot:1
+44 SET $PIECE(HDR,"^",4)=$PIECE(HDR,"^",4)-MIN
+45 ;
+46 SET A=""
FOR
SET A=$ORDER(APP(A))
if A=""
QUIT
Begin DoDot:1
+47 if A["_"
QUIT
+48 SET X=APP(A)
SET $PIECE(X,"^",8)=NOW
+49 SET D0=$ORDER(^MAG(2006.587," "),-1)+1
SET PLUS=PLUS+1
SET $PIECE(HDR,"^",3)=D0
+50 ; PMK P231 2/5/2020
SET ^MAG(2006.587,D0,0)=$PIECE(X,"^",1,9)
SET SERVNAM=$PIECE(X,"^",1)
+51 SET ^MAG(2006.587,"B",SERVNAM,D0)=""
+52 SET ^MAG(2006.587,"C",SERVNAM,GWLOC,GWNAM,D0)=""
+53 SET ^MAG(2006.587,"D",GWNAM,GWLOC,D0)=""
+54 KILL DIMSE
SET DIMSE=A_"_"
+55 SET X=DIMSE
FOR
SET X=$ORDER(APP(X))
if $EXTRACT(X,1,$LENGTH(DIMSE))'=DIMSE
QUIT
Begin DoDot:2
+56 SET N=$PIECE(X,"_",2)
if N=""
QUIT
+57 SET DIMSE(N)=APP(X)
+58 SET DIMSE("C-ECHO")="1^1"
+59 QUIT
End DoDot:2
+60 KILL ^MAG(2006.587,D0,1)
+61 SET D1=0
SET X=""
FOR
SET X=$ORDER(DIMSE(X))
if X=""
QUIT
Begin DoDot:2
+62 SET D1=D1+1
SET ^MAG(2006.587,D0,1,D1,0)=X_"^"_DIMSE(X)
+63 SET ^MAG(2006.587,D0,1,"B",X,D1)=""
+64 QUIT
End DoDot:2
+65 if D1
SET ^MAG(2006.587,D0,1,0)="^2006.5871SA^"_D1_"^"_D1
+66 QUIT
End DoDot:1
+67 SET (N,D0)=0
FOR
SET D0=$ORDER(^MAG(2006.587,D0))
if 'D0
QUIT
SET N=N+1
+68 SET $PIECE(HDR,"^",4)=N
+69 SET ^MAG(2006.587,0)=HDR
+70 LOCK -^MAG(2006.587,0)
+71 SET OUT="1"
+72 if PLUS
SET OUT=OUT_", "_PLUS_" added"
+73 if MIN
SET OUT=OUT_", "_MIN_" removed"
+74 if UP
SET OUT=OUT_", "_UP_" updated"
+75 QUIT
+76 ;
UPDTGW(OUT,ONAM,NNAM,OLOC,NLOC) ; RPC = MAG DICOM UPDATE GATEWAY NAME
+1 NEW D0,P1,P5,P7,N
+2 IF $GET(NNAM)=""
SET OUT="-1,No Gateway Name specified"
QUIT
+3 IF '$GET(NLOC)
SET OUT="-2,No Gateway Location specified"
QUIT
+4 SET OLOC=$GET(OLOC)
SET ONAM=$GET(ONAM)
+5 SET (N,D0)=0
FOR
SET D0=$ORDER(^MAG(2006.587,D0))
if 'D0
QUIT
Begin DoDot:1
+6 SET X=$GET(^MAG(2006.587,D0,0))
SET P5=$PIECE(X,"^",5)
if P5'=ONAM
QUIT
+7 SET P1=$PIECE(X,"^",1)
SET P7=$PIECE(X,"^",7)
+8 IF OLOC'=""
IF P5'=""
IF P1'=""
KILL ^MAG(2006.587,"C",P1,OLOC,P5,D0)
+9 IF OLOC'=""
IF P5'=""
KILL ^MAG(2006.587,"D",P5,OLOC,D0)
+10 SET $PIECE(X,"^",5)=NNAM
SET $PIECE(X,"^",7)=NLOC
+11 SET ^MAG(2006.587,D0,0)=X
+12 if P1'=""
SET ^MAG(2006.587,"C",P1,NLOC,NNAM,D0)=""
+13 SET ^MAG(2006.587,"D",NNAM,NLOC,D0)=""
+14 SET N=N+1
+15 QUIT
End DoDot:1
+16 SET OUT=N
+17 QUIT
+18 ;
SIBS(P0,T) NEW MAGLOC,P1,P2
+1 SET T(P0)=""
+2 DO SIBLING^XUAF4("MAGLOC",P0,"PARENT FACILITY")
+3 SET P1=""
FOR
SET P1=$ORDER(MAGLOC("P",P1))
if P1=""
QUIT
Begin DoDot:1
+4 SET P2=""
FOR
SET P2=$ORDER(MAGLOC("P",P1,"C",P2))
if P2=""
QUIT
SET T(P2)=""
+5 QUIT
End DoDot:1
+6 QUIT
+7 ;
LOCS(OUT) ; RPC = MAG DICOM VALID LOCATIONS
+1 NEW D0,I,MAGM,N,P1,MAGR,T
+2 SET N=1
+3 SET D0=0
FOR
SET D0=$ORDER(^MAG(2006.1,D0))
if 'D0
QUIT
Begin DoDot:1
+4 SET X=$GET(^MAG(2006.1,D0,0))
SET P1=$PIECE(X,"^",1)
if P1=""
QUIT
+5 IF +P1=P1
SET T(P1)=""
QUIT
+6 DO FIND^DIC(4,"","","BX",P1,"*","","","","MAGR","MAGM")
+7 SET I=0
FOR
SET I=$ORDER(MAGR("DILIST",2,I))
if 'I
QUIT
Begin DoDot:2
+8 SET P1=MAGR("DILIST",2,I)
IF P1
KILL MAGR
SET T(P1)=""
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 IF $TEXT(^XUPARAM)'=""
SET P1=$$KSP^XUPARAM("INST")
if P1
DO SIBS(P1,.T)
+12 SET P1=+$GET(^DD("SITE",1))
if P1
DO SIBS(P1,.T)
+13 ;
+14 SET P1=""
FOR
SET P1=$ORDER(T(P1))
if P1=""
QUIT
Begin DoDot:1
+15 SET N=N+1
SET OUT(N)=P1_"^"_$$GET1^DIQ(4,P1,.01)_"^"_$$GET1^DIQ(4,P1,99)
+16 QUIT
End DoDot:1
+17 SET OUT(1)=N-1
+18 QUIT
+19 ;
GETPLACE(OUT,LOCATION) ; RPC = MAG DICOM GET PLACE
+1 NEW D0,P1,MAGM,MAGR,X
+2 SET LOCATION=+$GET(LOCATION)
+3 SET OUT="-1,Location """_LOCATION_""" not found."
+4 SET D0=0
FOR
SET D0=$ORDER(^MAG(2006.1,D0))
if 'D0
QUIT
Begin DoDot:1
+5 SET X=$GET(^MAG(2006.1,D0,0))
SET P1=$PIECE(X,"^",1)
if P1=""
QUIT
+6 IF +P1=P1
IF LOCATION=P1
SET OUT=D0
QUIT
+7 DO FIND^DIC(4,"","","BX",P1,"*","","","","MAGR","MAGM")
+8 SET I=0
FOR
SET I=$ORDER(MAGR("DILIST",2,I))
if 'I
QUIT
Begin DoDot:2
+9 IF LOCATION=MAGR("DILIST",2,I)
SET OUT=D0
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
if OUT>0
QUIT
+12 QUIT
+13 ;
SETPACS(OUT,D0) ; RPC = MAG DICOM SET PACS PARAMS
+1 NEW X
+2 IF '$GET(D0)
SET OUT="-1,No Place Specified."
QUIT
+3 IF '$DATA(^MAG(2006.1,D0))
SET OUT="-2,Invalid Place Specified."
QUIT
+4 ;
+5 ; There is a PACS
+6 SET $PIECE(^MAG(2006.1,D0,"PACS"),"^",1)=1
+7 ;
+8 ; Number of days to retain "PACS" images
+9 SET X=$PIECE($GET(^MAG(2006.1,D0,1)),"^",5)
+10 if 'X
SET $PIECE(^MAG(2006.1,D0,1),"^",5)=30
+11 ;
+12 ; Set minimum % of free disk space to trigger automatic file delete
+13 SET X=$PIECE($GET(^MAG(2006.1,D0,3)),"^",6)
+14 if 'X
SET $PIECE(^MAG(2006.1,D0,3),"^",6)=25
+15 SET OUT=1
+16 QUIT
+17 ;
HIGHHL7(OUT) ; RPC = MAG DICOM GET HIGHEST HL7
+1 SET OUT=+$ORDER(^MAGDHL7(2006.5," "),-1)
+2 QUIT
+3 ;
FINDLOC(OUT,NAME) ; RPC = MAG DICOM FIND LOCATION
+1 ; NAME is the location to find in either Institution Name or Station Number
+2 ; fields of the Institution File (#4)
+3 ;
+4 NEW MAGM,MAGR,I
+5 SET OUT="-1,Invalid location """_NAME_"""."
+6 ;
+7 ; Find NAME in either Institution Name or Station Number fields
+8 DO FIND^DIC(4,"",.01,"BXA",NAME,"*","B^D","","","MAGR","MAGM")
+9 ;
+10 IF MAGR("DILIST",0)
Begin DoDot:1
+11 ; If multiple found, return the first IEN
SET I=$ORDER(MAGR("DILIST",2,""))
+12 SET OUT=MAGR("DILIST",2,I)
End DoDot:1
+13 QUIT
+14 ;
VALIMGT(OUT) ; RPC = MAG DICOM GET IMAGING TYPES
+1 NEW N,X
+2 SET N=1
+3 ; Lists of valid imaging types
+4 SET X=""
FOR
SET X=$ORDER(^RA(79.2,"C",X))
if X=""
QUIT
SET N=N+1
SET OUT(N)="RAD^"_X
+5 SET X=""
FOR
SET X=$ORDER(^MAG(2005.84,"C",X))
if X=""
QUIT
SET N=N+1
SET OUT(N)="CON^"_X
+6 SET X=""
FOR
SET X=$ORDER(^MAG(2005.85,"C",X))
if X=""
QUIT
SET N=N+1
SET OUT(N)="CON PROC^"_X
+7 SET OUT(1)=N-1
+8 QUIT
+9 ;
CORRECT(OUT,LOCATION,MACHID) ; RPC = MAG DICOM INCORRECT IMAGE CT
+1 ; Check for images needing corrections
+2 NEW CNT,D0,STUDY
+3 IF '$GET(LOCATION)
SET OUT="-1,No Location Specified"
QUIT
+4 IF $GET(MACHID)=""
SET OUT="-2,No Gateway Specified"
QUIT
+5 SET OUT=0
+6 if '$ORDER(^MAGD(2006.575,0))
QUIT
+7 if '$DATA(^MAGD(2006.575,"F",LOCATION))
QUIT
+8 SET STUDY=""
FOR
SET STUDY=$ORDER(^MAGD(2006.575,"F",LOCATION,STUDY))
if STUDY=""
QUIT
Begin DoDot:1
+9 SET D0=0
SET D0=$ORDER(^MAGD(2006.575,"F",LOCATION,STUDY,D0))
if 'D0
QUIT
Begin DoDot:2
+10 if '$DATA(^MAGD(2006.575,D0,0))
QUIT
+11 if MACHID=$PIECE($GET(^MAGD(2006.575,D0,1)),"^",4)
SET OUT=OUT+1
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
HL7PTR(OUT,ACTION,VALUE) ; RPC = MAG DICOM HL7 POINTER ACTION
+1 ; Manipulate HL7 Pointer
+2 NEW D0,P1,P2,X,Y
+3 SET ACTION=$GET(ACTION)
SET VALUE=$GET(VALUE)
+4 SET OUT="-2,Invalid Request: """_ACTION_"""."
+5 IF ACTION="GetDate"
Begin DoDot:1
+6 SET X=$GET(^MAGDHL7(2006.5,+VALUE,0))
+7 IF X=""
SET OUT="-1,Invalid Pointer """_VALUE_"""."
QUIT
+8 SET OUT=$$FMTE^XLFDT($PIECE(X,"^",3),1)
+9 QUIT
End DoDot:1
QUIT
+10 IF ACTION="DatePtr"
Begin DoDot:1
+11 SET Y=$ORDER(^MAGDHL7(2006.5,"C",VALUE),-1)
+12 ; before any date on file
IF 'Y
Begin DoDot:2
+13 ; if the requested date is before the first entry,
+14 ; move the pointer to the first entry
+15 SET OUT=0
+16 QUIT
End DoDot:2
+17 ; if the requested date is in the cross reference, use it.
IF '$TEST
Begin DoDot:2
+18 SET Y=$ORDER(^MAGDHL7(2006.5,"C",Y,""))
+19 ; found date
IF Y
SET OUT=Y
+20 IF '$TEST
Begin DoDot:3
+21 ; otherwise, find the appropriate entry the hard way
+22 SET D0=$ORDER(^MAGDHL7(2006.5,0))
+23 SET Y=$PIECE($GET(^MAGDHL7(2006.5,D0,0)),"^",3)
IF Y'<X
SET OUT=0
QUIT
+24 SET D0=" "
FOR
SET D0=$ORDER(^MAGDHL7(2006.5,D0),-1)
if 'D0
QUIT
Begin DoDot:4
+25 SET Y=$PIECE($GET(^MAGDHL7(2006.5,D0,0)),"^",3)
if Y<X
SET OUT=D0
+26 QUIT
End DoDot:4
if OUT
QUIT
+27 QUIT
End DoDot:3
+28 QUIT
End DoDot:2
+29 QUIT
End DoDot:1
QUIT
+30 QUIT
+31 ;
