MAGBRTE3 ;WOIFO/EdM/DAC - Find value of variable ; 02/08/2017 1:05PM
;;3.0;IMAGING;**11,51,166**;Mar 19, 2002;Build 45
;; 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
;
; The subroutines in this routine calculate the values for
; certain variables that may be needed for the "routing rule processor"
;
; Entry DICOM is the generic value finder that looks for values
; in the data structure that describes an image file.
; The other entries deal with other (computed) values.
;
; The value is always returned in output parameter VAL.
; Note that this variable needs to be an output parameter,
; because in some cases an "undefined value" needs to be returned,
; and in some cases, multiple values may need to be returned.
;
DICOM(NAME,TYPE,VAL) N C,I,N,X
;
; Arbitrary decision: the routine stops when the first occurrence
; of a value is found.
; Should we continue until we find all codes that have values?
;
S C="" F S C=$O(KEYWORD("CONDITION",NAME,C)) Q:C="" D Q:$D(VAL)
. Q:'$D(^TMP("MAG",$J,"DICOM",TYPE,C))
. S (I,N)=0 F S N=$O(^TMP("MAG",$J,"DICOM",TYPE,C,N)) Q:N="" D
. . S X=$G(^TMP("MAG",$J,"DICOM",TYPE,C,N,1),"<unknown>") Q:X="<unknown>"
. . S I=I+1,N(I)=X
. . Q
. Q:'I
. I I=1 S VAL=N(1) Q
. F N=1:1:I S VAL(N)=N(N)
. Q
Q
;
NOW(VAL) N %,DISYS,X
; P166 DAC - 'NOW^%DTC' required after update to FileMan v22.2
D DT^DICRW,NOW^%DTC
S VAL=$P("THU FRI SAT SUN MON TUE WED"," ",$H#7+1)_" "_%
Q
;
SOURCE(IMAGE,VAL) N X
S X=$P($G(^MAG(2005,IMAGE,100)),"^",3)
S:'X X=$G(DUZ(2))
S:'X X=$$KSP^XUPARAM("INST")
S VAL=$$GET1^DIQ(4,+X,.01)
Q
;
MAG(IMAGE,TYPE,NODE,PIECE,VAL) N D0,D1,PARENT,X
; First look in the image itself,
; then in its parent (if any)
; then in any siblings.
; Return the first value found.
;
K VAL
S X=$P($G(^MAG(2005,IMAGE,NODE)),"^",PIECE) I X'="" S VAL=X D:$D(VAL) MAGX Q
;
S PARENT=$P($G(^MAG(2005,IMAGE,0)),"^",10) Q:PARENT=""
S X=$P($G(^MAG(2005,PARENT,NODE)),"^",PIECE) I X'="" S VAL=X D:$D(VAL) MAGX Q
;
S D1=0 F S D1=$O(^MAG(2005,IMAGE,1,D1)) Q:'D1 D Q:$D(VAL)
. S D0=$G(^MAG(2005,IMAGE,1,D1,1)) Q:'D0
. S X=$P($G(^MAG(2005,D0,NODE)),"^",PIECE) I X'="" S VAL=X Q
. Q
D:$D(VAL) MAGX
Q
;
MAGX I TYPE=0 Q
I (TYPE=2005.02)!(TYPE=2005.03)!(TYPE=2005.81)!(TYPE=2005.2) D Q
. S X=$P($G(^MAG(TYPE,+VAL,0)),"^",1) K VAL S:X'="" VAL=X
. Q
I TYPE=2 D Q
. S X=$P($G(^DPT(+VAL,0)),"^",1) K VAL S:X'="" VAL=X ; IA 10035
. Q
I TYPE=200 D Q
. S X=$$GET1^DIQ(200,+VAL,.01) K VAL S:X'="" VAL=X ; IA 10060
. Q
I TYPE=44 D Q
. S X=$P($G(^SC(+VAL,0)),"^",1) K VAL S:X'="" VAL=X ; IA 10040
. Q
I TYPE=71 D Q
. S X=$P($G(^RAMIS(71,+VAL,0)),"^",1) K VAL S:X'="" VAL=X ; IA 1174
. Q
I TYPE=74 D Q
. S X=$P($G(^RARPT(+VAL,0)),"^",1) K VAL S:X'="" VAL=X ; IA 1171
. Q
Q
;
DATE(IMAGE,TYPE,NODE,PIECE,WHEN,VAL) N D0,D1,FIRST,LAST,PARENT,X
; First look in the image itself,
; then in its parent (if any)
; then in any siblings.
; Return the first value found.
;
K VAL
I WHEN=0 D MAG(IMAGE,TYPE,NODE,PIECE,.VAL) Q
;
S X=$P($G(^MAG(2005,IMAGE,NODE)),"^",PIECE) I X'="" S X(X)=""
;
S PARENT=$P($G(^MAG(2005,IMAGE,0)),"^",10) Q:PARENT=""
S X=$P($G(^MAG(2005,PARENT,NODE)),"^",PIECE) I X'="" S X(X)=""
;
S D1=0 F S D1=$O(^MAG(2005,IMAGE,1,D1)) Q:'D1 D
. S D0=$G(^MAG(2005,IMAGE,1,D1,1)) Q:'D0
. S X=$P($G(^MAG(2005,D0,NODE)),"^",PIECE) I X'="" S X(X)=""
. Q
;
I WHEN=1 S VAL=$O(X(""),+1)
I WHEN=2 S VAL=$O(X(""),-1)
K:VAL="" VAL
Q
;
URGENCY(IMAGE,VAL) N P
S P=$$PRI^MAGBRTE4("NORMAL",IMAGE)
S VAL=$S(P=500:"ROUTINE",P=510:"URGENT",P=520:"STAT",1:P)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGBRTE3 4710 printed Sep 23, 2025@19:35:40 Page 2
MAGBRTE3 ;WOIFO/EdM/DAC - Find value of variable ; 02/08/2017 1:05PM
+1 ;;3.0;IMAGING;**11,51,166**;Mar 19, 2002;Build 45
+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 ;; | |
+11 ;; | The Food and Drug Administration classifies this software as |
+12 ;; | a medical device. As such, it may not be changed in any way. |
+13 ;; | Modifications to this software may result in an adulterated |
+14 ;; | medical device under 21CFR820, the use of which is considered |
+15 ;; | to be a violation of US Federal Statutes. |
+16 ;; +---------------------------------------------------------------+
+17 ;;
+18 QUIT
+19 ;
+20 ; The subroutines in this routine calculate the values for
+21 ; certain variables that may be needed for the "routing rule processor"
+22 ;
+23 ; Entry DICOM is the generic value finder that looks for values
+24 ; in the data structure that describes an image file.
+25 ; The other entries deal with other (computed) values.
+26 ;
+27 ; The value is always returned in output parameter VAL.
+28 ; Note that this variable needs to be an output parameter,
+29 ; because in some cases an "undefined value" needs to be returned,
+30 ; and in some cases, multiple values may need to be returned.
+31 ;
DICOM(NAME,TYPE,VAL) NEW C,I,N,X
+1 ;
+2 ; Arbitrary decision: the routine stops when the first occurrence
+3 ; of a value is found.
+4 ; Should we continue until we find all codes that have values?
+5 ;
+6 SET C=""
FOR
SET C=$ORDER(KEYWORD("CONDITION",NAME,C))
if C=""
QUIT
Begin DoDot:1
+7 if '$DATA(^TMP("MAG",$JOB,"DICOM",TYPE,C))
QUIT
+8 SET (I,N)=0
FOR
SET N=$ORDER(^TMP("MAG",$JOB,"DICOM",TYPE,C,N))
if N=""
QUIT
Begin DoDot:2
+9 SET X=$GET(^TMP("MAG",$JOB,"DICOM",TYPE,C,N,1),"<unknown>")
if X="<unknown>"
QUIT
+10 SET I=I+1
SET N(I)=X
+11 QUIT
End DoDot:2
+12 if 'I
QUIT
+13 IF I=1
SET VAL=N(1)
QUIT
+14 FOR N=1:1:I
SET VAL(N)=N(N)
+15 QUIT
End DoDot:1
if $DATA(VAL)
QUIT
+16 QUIT
+17 ;
NOW(VAL) NEW %,DISYS,X
+1 ; P166 DAC - 'NOW^%DTC' required after update to FileMan v22.2
+2 DO DT^DICRW
DO NOW^%DTC
+3 SET VAL=$PIECE("THU FRI SAT SUN MON TUE WED"," ",$HOROLOG#7+1)_" "_%
+4 QUIT
+5 ;
SOURCE(IMAGE,VAL) NEW X
+1 SET X=$PIECE($GET(^MAG(2005,IMAGE,100)),"^",3)
+2 if 'X
SET X=$GET(DUZ(2))
+3 if 'X
SET X=$$KSP^XUPARAM("INST")
+4 SET VAL=$$GET1^DIQ(4,+X,.01)
+5 QUIT
+6 ;
MAG(IMAGE,TYPE,NODE,PIECE,VAL) NEW D0,D1,PARENT,X
+1 ; First look in the image itself,
+2 ; then in its parent (if any)
+3 ; then in any siblings.
+4 ; Return the first value found.
+5 ;
+6 KILL VAL
+7 SET X=$PIECE($GET(^MAG(2005,IMAGE,NODE)),"^",PIECE)
IF X'=""
SET VAL=X
if $DATA(VAL)
DO MAGX
QUIT
+8 ;
+9 SET PARENT=$PIECE($GET(^MAG(2005,IMAGE,0)),"^",10)
if PARENT=""
QUIT
+10 SET X=$PIECE($GET(^MAG(2005,PARENT,NODE)),"^",PIECE)
IF X'=""
SET VAL=X
if $DATA(VAL)
DO MAGX
QUIT
+11 ;
+12 SET D1=0
FOR
SET D1=$ORDER(^MAG(2005,IMAGE,1,D1))
if 'D1
QUIT
Begin DoDot:1
+13 SET D0=$GET(^MAG(2005,IMAGE,1,D1,1))
if 'D0
QUIT
+14 SET X=$PIECE($GET(^MAG(2005,D0,NODE)),"^",PIECE)
IF X'=""
SET VAL=X
QUIT
+15 QUIT
End DoDot:1
if $DATA(VAL)
QUIT
+16 if $DATA(VAL)
DO MAGX
+17 QUIT
+18 ;
MAGX IF TYPE=0
QUIT
+1 IF (TYPE=2005.02)!(TYPE=2005.03)!(TYPE=2005.81)!(TYPE=2005.2)
Begin DoDot:1
+2 SET X=$PIECE($GET(^MAG(TYPE,+VAL,0)),"^",1)
KILL VAL
if X'=""
SET VAL=X
+3 QUIT
End DoDot:1
QUIT
+4 IF TYPE=2
Begin DoDot:1
+5 ; IA 10035
SET X=$PIECE($GET(^DPT(+VAL,0)),"^",1)
KILL VAL
if X'=""
SET VAL=X
+6 QUIT
End DoDot:1
QUIT
+7 IF TYPE=200
Begin DoDot:1
+8 ; IA 10060
SET X=$$GET1^DIQ(200,+VAL,.01)
KILL VAL
if X'=""
SET VAL=X
+9 QUIT
End DoDot:1
QUIT
+10 IF TYPE=44
Begin DoDot:1
+11 ; IA 10040
SET X=$PIECE($GET(^SC(+VAL,0)),"^",1)
KILL VAL
if X'=""
SET VAL=X
+12 QUIT
End DoDot:1
QUIT
+13 IF TYPE=71
Begin DoDot:1
+14 ; IA 1174
SET X=$PIECE($GET(^RAMIS(71,+VAL,0)),"^",1)
KILL VAL
if X'=""
SET VAL=X
+15 QUIT
End DoDot:1
QUIT
+16 IF TYPE=74
Begin DoDot:1
+17 ; IA 1171
SET X=$PIECE($GET(^RARPT(+VAL,0)),"^",1)
KILL VAL
if X'=""
SET VAL=X
+18 QUIT
End DoDot:1
QUIT
+19 QUIT
+20 ;
DATE(IMAGE,TYPE,NODE,PIECE,WHEN,VAL) NEW D0,D1,FIRST,LAST,PARENT,X
+1 ; First look in the image itself,
+2 ; then in its parent (if any)
+3 ; then in any siblings.
+4 ; Return the first value found.
+5 ;
+6 KILL VAL
+7 IF WHEN=0
DO MAG(IMAGE,TYPE,NODE,PIECE,.VAL)
QUIT
+8 ;
+9 SET X=$PIECE($GET(^MAG(2005,IMAGE,NODE)),"^",PIECE)
IF X'=""
SET X(X)=""
+10 ;
+11 SET PARENT=$PIECE($GET(^MAG(2005,IMAGE,0)),"^",10)
if PARENT=""
QUIT
+12 SET X=$PIECE($GET(^MAG(2005,PARENT,NODE)),"^",PIECE)
IF X'=""
SET X(X)=""
+13 ;
+14 SET D1=0
FOR
SET D1=$ORDER(^MAG(2005,IMAGE,1,D1))
if 'D1
QUIT
Begin DoDot:1
+15 SET D0=$GET(^MAG(2005,IMAGE,1,D1,1))
if 'D0
QUIT
+16 SET X=$PIECE($GET(^MAG(2005,D0,NODE)),"^",PIECE)
IF X'=""
SET X(X)=""
+17 QUIT
End DoDot:1
+18 ;
+19 IF WHEN=1
SET VAL=$ORDER(X(""),+1)
+20 IF WHEN=2
SET VAL=$ORDER(X(""),-1)
+21 if VAL=""
KILL VAL
+22 QUIT
+23 ;
URGENCY(IMAGE,VAL) NEW P
+1 SET P=$$PRI^MAGBRTE4("NORMAL",IMAGE)
+2 SET VAL=$SELECT(P=500:"ROUTINE",P=510:"URGENT",P=520:"STAT",1:P)
+3 QUIT
+4 ;
