MAGBRTE4 ;WOIFO/EdM,DAC,gek - Process Routing Rule Evaluation Queue ;
;;3.0;IMAGING;**11,30,51,85,54,39,156,196**;Mar 19, 2002;Build 30;Feb 9, 2018
;; 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
;
EVAL ;
N ACTIVE ;--- Switch that controls start/stop queue processor
N ANY ;------ Flag: processed any rule
N CONS ;----- Switch that indicates whether or not site has "consolidated" code
N KEYWORD ;-- Array with all keywords
N MAGFILE1 ;- Name of file
N XMSG ;----- Message counter
;
F I="MAGEVAL","MAGEVALSTUDY" K ^XTMP(I,ZTSK)
D LOG^MAGBRTE5("Started at "_$H)
S XMSG=1,CONS=$$CONSOLID^MAGBAPI()
S PLACE=$S(CONS:$O(^MAG(2006.1,"B",LOCATION,"")),1:1)
L +^MAGDICOM(2006.563,1,"EVAL",LOCATION):0 E D Q
. D LOG^MAGBRTE5("A rule evaluator is already running for "_$$GET1^DIQ(4,LOCATION,.01))
. Q
S ^MAGDICOM(2006.563,1,"EVAL")=1
;
S I="" F S I=$O(RULES(I)) Q:I="" D
. N D0,D1,D2,L,Q1
. S X=RULES(I),D0=$P(X,"^",1),Q1=$P(X,"^",2),L=$L(X,"^")
. I L=3 S RULE(D0,Q1)=$P(X,"^",3) Q
. I Q1="ACTION" S RULE(D0,Q1,$P(X,"^",3))=$P(X,"^",4,L) Q
. I Q1'="CONDITION" D LOG^MAGBRTE5("Rule "_D0_" has a qualifier """_Q1_""".") Q
. I L=5 S RULE(D0,Q1,$P(X,"^",3),$P(X,"^",4))=$P(X,"^",5) Q
. S RULE(D0,Q1,$P(X,"^",3),$P(X,"^",4),$P(X,"^",6),$P(X,"^",5))=$P(X,"^",7)
. Q
K RULES
;
S ACTIVE=1 F D Q:'ACTIVE
. S ANY=0
. S ACTIVE=+$G(^MAGDICOM(2006.563,1,"EVAL")) I 'ACTIVE D Q
. . D LOG^MAGBRTE5("Stopped at "_$H)
. . Q
. D
. . N IMAGE,QPTR,QPTR2,STATUS,X
. . D:'CONS ADD^MAGBAPI(0,"EVAL")
. . D:CONS ADD^MAGBAPI(0,"EVAL",PLACE)
. . ;S QPTR2=$O(^MAGQUEUE(2006.031,"B","EVAL",""))
. . S QPTR2=$O(^MAGQUEUE(2006.031,"C",PLACE,"EVAL","")) ; "C",PLACE was "B" ;p196
. . S QPTR=$S(QPTR2:$P(^MAGQUEUE(2006.031,QPTR2,0),"^",2),1:"")
. . ; Get next queue pointer value
. . S:'CONS QPTR=$O(^MAGQUEUE(2006.03,"C","EVAL",QPTR)) ; "C" WAS "B" ;p196
. . S:CONS QPTR=$O(^MAGQUEUE(2006.03,"C",PLACE,"EVAL",QPTR))
. . I QPTR="" Q ; Nothing to do
. . ;
. . S X=$G(^MAGQUEUE(2006.03,QPTR,0))
. . ; After an error, sometimes the entry is purged,
. . ; but the cross reference is still present.
. . ; In such a case, remove the cross reference.
. . I X="" D Q
. . . K:'CONS ^MAGQUEUE(2006.03,"C","EVAL",QPTR) ; "C" was "B" ;p196
. . . K:CONS ^MAGQUEUE(2006.03,"C",PLACE,"EVAL",QPTR)
. . . Q
. . ;
. . S IMAGE=$P(X,"^",7),ANY=1
. . I IMAGE,$D(^MAG(2005,IMAGE,0)) D
. . . S STATUS=$$RULES() Q:STATUS'<0
. . . I STATUS["NO NETWORK LOCATION" D Q
. . . . D LOG^MAGBRTE5("Image "_IMAGE_" has no files associated with it")
. . . . Q
. . . D LOG^MAGBRTE5("*** EVAL queue error: "_STATUS_" ***")
. . . Q
. . ;D DQUE^MAGQBUT2(QPTR) ; replaced with line below p196
. . D QPTER^MAGQBTM("EVAL",QPTR,PLACE),DQUE^MAGQBUT2(QPTR)
. . Q
. H:'ANY 1
. D:'$D(^XTMP("MAGEVAL",ZTSK)) XTINIT^MAGDRPC5,LOG^MAGBRTE5("^XTMP was cleaned up.")
. Q
L -^MAGDICOM(2006.563,1,"EVAL",LOCATION)
Q
;
RULES() ; To be called from above
; IMAGE ;---- IEN for image (2005)
; LOCATION ;- Location from which queue entry originates
N ACTION ;--- Action to be taken (SEND)
N C ;-------- Loop-variable for looping through parameters and conditions
N D ;-------- Data type
N DS ;------- Data type enclosed in space-characters
N F ;-------- ...
N METMSG ;--- Message to be issued when rule is evaluated
N O ;-------- Operator
N OK ;------- Flag: indicates whether or not rule is met
N RDT ;------ Current date (don't use DT, process might run over midnight)
N STUDYUID ;- Study UID
N V ;-------- Value for property as specified in rule
N VAL ;------ Actual value of property
N VRS ;------ String of Queue Entry numbers when rule(s) are met
N X ;-------- Scratch variable
;
S VRS=""
;
D KEYWORD^MAGBRTK
;
D FILEFIND^MAGDFB(IMAGE,"FULL",0,0,.MAGFILE1)
Q:MAGFILE1<0 MAGFILE1
;
S STUDYUID=$P($G(^MAG(2005,IMAGE,"PACS")),"^",1)
S X=$P($G(^MAG(2005,IMAGE,0)),"^",10)
S:X STUDYUID=$P($G(^MAG(2005,X,"PACS")),"^",1)
;
S RULE=0 F S RULE=$O(RULE(RULE)) Q:'RULE D
. S METMSG=$G(RULE(RULE,"ACTION"))
. S X=" (",C=0 F S C=$O(RULE(RULE,"ACTION",C)) Q:'C D
. . S METMSG=METMSG_X_$G(RULE(RULE,"ACTION",C)),X=", "
. . Q
. S:X'=" (" METMSG=METMSG_")"
. S:METMSG="" METMSG="Rule #"_RULE
. I (STUDYUID="")!(ZTSK="")!(RULE="") Q ; P156 DAC - Prevent deleted groups from causing hard crashes
. S OK=$G(^XTMP("MAGEVALSTUDY",ZTSK,STUDYUID,RULE))
. I OK="" S OK=1,C=0 F S C=$O(RULE(RULE,"CONDITION",C)) Q:'C D Q:'OK
. . S F=$G(RULE(RULE,"CONDITION",C,"KW")) Q:F=""
. . S X=$G(KEYWORD("CONDITION",F),"^DICOM^MAGBRTE3(F,""OUT"",.VAL)")
. . K VAL D @$P(X,"^",2,9)
. . ; If the field is not defined, the test passes...
. . Q:$D(VAL)'=1 ; We won't deal with multiple values just yet...
. . ;
. . S V=$G(RULE(RULE,"CONDITION",C,"VA"))
. . S D=$G(RULE(RULE,"CONDITION",C,"DT"))
. . S O=$G(RULE(RULE,"CONDITION",C,"OP"))
. . S:D="" D="S"
. . S DS=" "_D_" "
. . D:" S CS DS IS LO LT OB OW PN SH ST "[DS
. . . N WILD ;-- Wildcard to be matched
. . . S WILD=$$WLDMATCH^MAGBRTE5(VAL,V)
. . . I O="=",'WILD S OK=0 Q
. . . I O="!=",WILD S OK=0 Q
. . . Q
. . D:" DT DA TM "[DS
. . . Q:O'="=" ; Only "within range" comparisons allowed currently
. . . ;
. . . N A ;--- Flag: indicates whether at least one time-frame matches
. . . N B ;--- Begin date/time
. . . N E ;--- End date/time
. . . N I ;--- Loopcounter
. . . N M ;--- Date/time mask
. . . N N ;--- Loopcounter (time-frames)
. . . N %T ;-- FileMan internal variable
. . . N VV ;-- Actual value
. . . N WD ;-- Weekday
. . . N X1 ;-- FileMan API parameter value -- date
. . . N X2 ;-- FileMan API parameter value -- date
. . . ;
. . . ; convert the literal date/time field into the format for comparison
. . . S VV=VAL
. . . ;
. . . S (A,N)=0 F S N=$O(RULE(RULE,"CONDITION",C,"VA",N)) Q:'N D
. . . . N T,VB,VC,VE
. . . . S M=$G(RULE(RULE,"CONDITION",C,"VA",N,"M"))
. . . . S B=$G(RULE(RULE,"CONDITION",C,"VA",N,"B"))
. . . . S E=$G(RULE(RULE,"CONDITION",C,"VA",N,"E"))
. . . . S T=1
. . . . I $E(M,1,3)="HOL" S:$$GET1^DIQ(40.5,+$E(VV,5,11),.01)="" T=0 ; IA 10038
. . . . I $E(M,1,3)="DDD",$E(B,1,3)'=$E(VAL,1,3) S T=0
. . . . S (VB,VC,VE)=""
. . . . F I=4:1:$L(M) S:$E(M,I)?1U VC=VC_$E(VV,I),VB=VB_$E(B,I),VE=VE_$E(E,I)
. . . . S:VB>VC T=0
. . . . S:VE<VC T=0
. . . . S:T A=1
. . . . Q
. . . S:'A OK=0
. . . Q
. . Q
. S ^XTMP("MAGEVALSTUDY",ZTSK,STUDYUID,RULE)=OK
. S METMSG(OK,METMSG)=""
. S RDT=$$NOW^XLFDT()\1
. Q:'OK
. S ACTION=$G(RULE(RULE,"ACTION"))
. Q:ACTION=""
. I ACTION="SEND" D Q
. . N D,PRI,X
. . S X=$G(RULE(RULE,"ACTION",1))
. . I X="" S METMSG(0,"No location for rule "_RULE)="" Q
. . D VALDEST^MAGDRPC1(.D,X)
. . I D<0 S METMSG(0,"Cannot find location """_X_""".")="" Q
. . S PRI=$$PRI($G(RULE(RULE,"PRIORITY")),IMAGE)
. . S VRS=$$VRS^MAGBRTE5(VRS,$$SEND^MAGBRTE5(IMAGE,D,PRI,1,LOCATION))
. . Q
. I ACTION="DICOM" D Q
. . N D,PRI,X
. . S X=$G(RULE(RULE,"ACTION",1))
. . I X="" S METMSG(0,"No location for rule "_RULE)="" Q
. . S D=$O(^MAG(2006.587,"B",X,""))
. . I D="" S METMSG(0,"Cannot find location """_X_""".")="" Q
. . S PRI=$$PRI($G(RULE(RULE,"PRIORITY")),IMAGE)
. . S VRS=$$VRS^MAGBRTE5(VRS,$$SEND^MAGBRTE5(IMAGE,D,PRI,2,LOCATION))
. . Q
. I ACTION="BALANCE" D BALANCE^MAGBRTE5(IMAGE,.RULE) Q
. ;
. ; Other actions to be inserted here...
. ;
. Q
;
; Note: we may have:
; Rule 1: If CR, send to XXX
; Rule 2: If CT, send to XXX
; For a CR, this would cause an entry of
; METMSG(0,"SEND(XXX)") for rule 2
; and an entry of
; METMSG(1,"SEND(XXX)") for rule 1
; and for a CT it would be the other way around.
; So, first remove all "failed" entries that were successful
; for a different rule.
;
S X="" F S X=$O(METMSG(1,X)) Q:X="" D
. D LOG^MAGBRTE5("Image "_IMAGE_": "_X)
. K METMSG(0,X)
. Q
S X="" F S X=$O(METMSG(0,X)) Q:X="" D
. D LOG^MAGBRTE5("Image "_IMAGE_": Do not "_X)
. Q
Q VRS
;
;
PRI(PRI,IMAGE) N C,D0,D1,D2,O,P,R,X
S PRI=$S(PRI="HIGH":750,PRI="NORMAL":500,PRI="LOW":250,1:500)
S X=$G(^MAG(2005,IMAGE,2))
S P=$P(X,"^",6) Q:P'=74 PRI
S R=$P(X,"^",7) Q:'R PRI
S C=$P($G(^RARPT(R,0)),"^",1) Q:C="" PRI ; IA 1171
S D0=$O(^RADPT("ADC",C,"")) Q:'D0 PRI ; IA 1172
S D1=$O(^RADPT("ADC",C,D0,"")) Q:'D1 PRI ; IA 1172
S D2=$O(^RADPT("ADC",C,D0,D1,"")) Q:'D2 PRI ; IA 1172
S O=$P($G(^RADPT(D0,"DT",D1,"P",D2,0)),"^",11) Q:'O PRI ; IA 1172
S X=$P($G(^RAO(75.1,O,0)),"^",6) ; IA 3074
Q PRI+$S(X=1:20,X=2:10,1:0)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGBRTE4 9628 printed May 14, 2023@14:26:33 Page 2
MAGBRTE4 ;WOIFO/EdM,DAC,gek - Process Routing Rule Evaluation Queue ;
+1 ;;3.0;IMAGING;**11,30,51,85,54,39,156,196**;Mar 19, 2002;Build 30;Feb 9, 2018
+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 ;
EVAL ;
+1 ;--- Switch that controls start/stop queue processor
NEW ACTIVE
+2 ;------ Flag: processed any rule
NEW ANY
+3 ;----- Switch that indicates whether or not site has "consolidated" code
NEW CONS
+4 ;-- Array with all keywords
NEW KEYWORD
+5 ;- Name of file
NEW MAGFILE1
+6 ;----- Message counter
NEW XMSG
+7 ;
+8 FOR I="MAGEVAL","MAGEVALSTUDY"
KILL ^XTMP(I,ZTSK)
+9 DO LOG^MAGBRTE5("Started at "_$HOROLOG)
+10 SET XMSG=1
SET CONS=$$CONSOLID^MAGBAPI()
+11 SET PLACE=$SELECT(CONS:$ORDER(^MAG(2006.1,"B",LOCATION,"")),1:1)
+12 LOCK +^MAGDICOM(2006.563,1,"EVAL",LOCATION):0
IF '$TEST
Begin DoDot:1
+13 DO LOG^MAGBRTE5("A rule evaluator is already running for "_$$GET1^DIQ(4,LOCATION,.01))
+14 QUIT
End DoDot:1
QUIT
+15 SET ^MAGDICOM(2006.563,1,"EVAL")=1
+16 ;
+17 SET I=""
FOR
SET I=$ORDER(RULES(I))
if I=""
QUIT
Begin DoDot:1
+18 NEW D0,D1,D2,L,Q1
+19 SET X=RULES(I)
SET D0=$PIECE(X,"^",1)
SET Q1=$PIECE(X,"^",2)
SET L=$LENGTH(X,"^")
+20 IF L=3
SET RULE(D0,Q1)=$PIECE(X,"^",3)
QUIT
+21 IF Q1="ACTION"
SET RULE(D0,Q1,$PIECE(X,"^",3))=$PIECE(X,"^",4,L)
QUIT
+22 IF Q1'="CONDITION"
DO LOG^MAGBRTE5("Rule "_D0_" has a qualifier """_Q1_""".")
QUIT
+23 IF L=5
SET RULE(D0,Q1,$PIECE(X,"^",3),$PIECE(X,"^",4))=$PIECE(X,"^",5)
QUIT
+24 SET RULE(D0,Q1,$PIECE(X,"^",3),$PIECE(X,"^",4),$PIECE(X,"^",6),$PIECE(X,"^",5))=$PIECE(X,"^",7)
+25 QUIT
End DoDot:1
+26 KILL RULES
+27 ;
+28 SET ACTIVE=1
FOR
Begin DoDot:1
+29 SET ANY=0
+30 SET ACTIVE=+$GET(^MAGDICOM(2006.563,1,"EVAL"))
IF 'ACTIVE
Begin DoDot:2
+31 DO LOG^MAGBRTE5("Stopped at "_$HOROLOG)
+32 QUIT
End DoDot:2
QUIT
+33 Begin DoDot:2
+34 NEW IMAGE,QPTR,QPTR2,STATUS,X
+35 if 'CONS
DO ADD^MAGBAPI(0,"EVAL")
+36 if CONS
DO ADD^MAGBAPI(0,"EVAL",PLACE)
+37 ;S QPTR2=$O(^MAGQUEUE(2006.031,"B","EVAL",""))
+38 ; "C",PLACE was "B" ;p196
SET QPTR2=$ORDER(^MAGQUEUE(2006.031,"C",PLACE,"EVAL",""))
+39 SET QPTR=$SELECT(QPTR2:$PIECE(^MAGQUEUE(2006.031,QPTR2,0),"^",2),1:"")
+40 ; Get next queue pointer value
+41 ; "C" WAS "B" ;p196
if 'CONS
SET QPTR=$ORDER(^MAGQUEUE(2006.03,"C","EVAL",QPTR))
+42 if CONS
SET QPTR=$ORDER(^MAGQUEUE(2006.03,"C",PLACE,"EVAL",QPTR))
+43 ; Nothing to do
IF QPTR=""
QUIT
+44 ;
+45 SET X=$GET(^MAGQUEUE(2006.03,QPTR,0))
+46 ; After an error, sometimes the entry is purged,
+47 ; but the cross reference is still present.
+48 ; In such a case, remove the cross reference.
+49 IF X=""
Begin DoDot:3
+50 ; "C" was "B" ;p196
if 'CONS
KILL ^MAGQUEUE(2006.03,"C","EVAL",QPTR)
+51 if CONS
KILL ^MAGQUEUE(2006.03,"C",PLACE,"EVAL",QPTR)
+52 QUIT
End DoDot:3
QUIT
+53 ;
+54 SET IMAGE=$PIECE(X,"^",7)
SET ANY=1
+55 IF IMAGE
IF $DATA(^MAG(2005,IMAGE,0))
Begin DoDot:3
+56 SET STATUS=$$RULES()
if STATUS'<0
QUIT
+57 IF STATUS["NO NETWORK LOCATION"
Begin DoDot:4
+58 DO LOG^MAGBRTE5("Image "_IMAGE_" has no files associated with it")
+59 QUIT
End DoDot:4
QUIT
+60 DO LOG^MAGBRTE5("*** EVAL queue error: "_STATUS_" ***")
+61 QUIT
End DoDot:3
+62 ;D DQUE^MAGQBUT2(QPTR) ; replaced with line below p196
+63 DO QPTER^MAGQBTM("EVAL",QPTR,PLACE)
DO DQUE^MAGQBUT2(QPTR)
+64 QUIT
End DoDot:2
+65 if 'ANY
HANG 1
+66 if '$DATA(^XTMP("MAGEVAL",ZTSK))
DO XTINIT^MAGDRPC5
DO LOG^MAGBRTE5("^XTMP was cleaned up.")
+67 QUIT
End DoDot:1
if 'ACTIVE
QUIT
+68 LOCK -^MAGDICOM(2006.563,1,"EVAL",LOCATION)
+69 QUIT
+70 ;
RULES() ; To be called from above
+1 ; IMAGE ;---- IEN for image (2005)
+2 ; LOCATION ;- Location from which queue entry originates
+3 ;--- Action to be taken (SEND)
NEW ACTION
+4 ;-------- Loop-variable for looping through parameters and conditions
NEW C
+5 ;-------- Data type
NEW D
+6 ;------- Data type enclosed in space-characters
NEW DS
+7 ;-------- ...
NEW F
+8 ;--- Message to be issued when rule is evaluated
NEW METMSG
+9 ;-------- Operator
NEW O
+10 ;------- Flag: indicates whether or not rule is met
NEW OK
+11 ;------ Current date (don't use DT, process might run over midnight)
NEW RDT
+12 ;- Study UID
NEW STUDYUID
+13 ;-------- Value for property as specified in rule
NEW V
+14 ;------ Actual value of property
NEW VAL
+15 ;------ String of Queue Entry numbers when rule(s) are met
NEW VRS
+16 ;-------- Scratch variable
NEW X
+17 ;
+18 SET VRS=""
+19 ;
+20 DO KEYWORD^MAGBRTK
+21 ;
+22 DO FILEFIND^MAGDFB(IMAGE,"FULL",0,0,.MAGFILE1)
+23 if MAGFILE1<0
QUIT MAGFILE1
+24 ;
+25 SET STUDYUID=$PIECE($GET(^MAG(2005,IMAGE,"PACS")),"^",1)
+26 SET X=$PIECE($GET(^MAG(2005,IMAGE,0)),"^",10)
+27 if X
SET STUDYUID=$PIECE($GET(^MAG(2005,X,"PACS")),"^",1)
+28 ;
+29 SET RULE=0
FOR
SET RULE=$ORDER(RULE(RULE))
if 'RULE
QUIT
Begin DoDot:1
+30 SET METMSG=$GET(RULE(RULE,"ACTION"))
+31 SET X=" ("
SET C=0
FOR
SET C=$ORDER(RULE(RULE,"ACTION",C))
if 'C
QUIT
Begin DoDot:2
+32 SET METMSG=METMSG_X_$GET(RULE(RULE,"ACTION",C))
SET X=", "
+33 QUIT
End DoDot:2
+34 if X'=" ("
SET METMSG=METMSG_")"
+35 if METMSG=""
SET METMSG="Rule #"_RULE
+36 ; P156 DAC - Prevent deleted groups from causing hard crashes
IF (STUDYUID="")!(ZTSK="")!(RULE="")
QUIT
+37 SET OK=$GET(^XTMP("MAGEVALSTUDY",ZTSK,STUDYUID,RULE))
+38 IF OK=""
SET OK=1
SET C=0
FOR
SET C=$ORDER(RULE(RULE,"CONDITION",C))
if 'C
QUIT
Begin DoDot:2
+39 SET F=$GET(RULE(RULE,"CONDITION",C,"KW"))
if F=""
QUIT
+40 SET X=$GET(KEYWORD("CONDITION",F),"^DICOM^MAGBRTE3(F,""OUT"",.VAL)")
+41 KILL VAL
DO @$PIECE(X,"^",2,9)
+42 ; If the field is not defined, the test passes...
+43 ; We won't deal with multiple values just yet...
if $DATA(VAL)'=1
QUIT
+44 ;
+45 SET V=$GET(RULE(RULE,"CONDITION",C,"VA"))
+46 SET D=$GET(RULE(RULE,"CONDITION",C,"DT"))
+47 SET O=$GET(RULE(RULE,"CONDITION",C,"OP"))
+48 if D=""
SET D="S"
+49 SET DS=" "_D_" "
+50 if " S CS DS IS LO LT OB OW PN SH ST "[DS
Begin DoDot:3
+51 ;-- Wildcard to be matched
NEW WILD
+52 SET WILD=$$WLDMATCH^MAGBRTE5(VAL,V)
+53 IF O="="
IF 'WILD
SET OK=0
QUIT
+54 IF O="!="
IF WILD
SET OK=0
QUIT
+55 QUIT
End DoDot:3
+56 if " DT DA TM "[DS
Begin DoDot:3
+57 ; Only "within range" comparisons allowed currently
if O'="="
QUIT
+58 ;
+59 ;--- Flag: indicates whether at least one time-frame matches
NEW A
+60 ;--- Begin date/time
NEW B
+61 ;--- End date/time
NEW E
+62 ;--- Loopcounter
NEW I
+63 ;--- Date/time mask
NEW M
+64 ;--- Loopcounter (time-frames)
NEW N
+65 ;-- FileMan internal variable
NEW %T
+66 ;-- Actual value
NEW VV
+67 ;-- Weekday
NEW WD
+68 ;-- FileMan API parameter value -- date
NEW X1
+69 ;-- FileMan API parameter value -- date
NEW X2
+70 ;
+71 ; convert the literal date/time field into the format for comparison
+72 SET VV=VAL
+73 ;
+74 SET (A,N)=0
FOR
SET N=$ORDER(RULE(RULE,"CONDITION",C,"VA",N))
if 'N
QUIT
Begin DoDot:4
+75 NEW T,VB,VC,VE
+76 SET M=$GET(RULE(RULE,"CONDITION",C,"VA",N,"M"))
+77 SET B=$GET(RULE(RULE,"CONDITION",C,"VA",N,"B"))
+78 SET E=$GET(RULE(RULE,"CONDITION",C,"VA",N,"E"))
+79 SET T=1
+80 ; IA 10038
IF $EXTRACT(M,1,3)="HOL"
if $$GET1^DIQ(40.5,+$EXTRACT(VV,5,11),.01)=""
SET T=0
+81 IF $EXTRACT(M,1,3)="DDD"
IF $EXTRACT(B,1,3)'=$EXTRACT(VAL,1,3)
SET T=0
+82 SET (VB,VC,VE)=""
+83 FOR I=4:1:$LENGTH(M)
if $EXTRACT(M,I)?1U
SET VC=VC_$EXTRACT(VV,I)
SET VB=VB_$EXTRACT(B,I)
SET VE=VE_$EXTRACT(E,I)
+84 if VB>VC
SET T=0
+85 if VE<VC
SET T=0
+86 if T
SET A=1
+87 QUIT
End DoDot:4
+88 if 'A
SET OK=0
+89 QUIT
End DoDot:3
+90 QUIT
End DoDot:2
if 'OK
QUIT
+91 SET ^XTMP("MAGEVALSTUDY",ZTSK,STUDYUID,RULE)=OK
+92 SET METMSG(OK,METMSG)=""
+93 SET RDT=$$NOW^XLFDT()\1
+94 if 'OK
QUIT
+95 SET ACTION=$GET(RULE(RULE,"ACTION"))
+96 if ACTION=""
QUIT
+97 IF ACTION="SEND"
Begin DoDot:2
+98 NEW D,PRI,X
+99 SET X=$GET(RULE(RULE,"ACTION",1))
+100 IF X=""
SET METMSG(0,"No location for rule "_RULE)=""
QUIT
+101 DO VALDEST^MAGDRPC1(.D,X)
+102 IF D<0
SET METMSG(0,"Cannot find location """_X_""".")=""
QUIT
+103 SET PRI=$$PRI($GET(RULE(RULE,"PRIORITY")),IMAGE)
+104 SET VRS=$$VRS^MAGBRTE5(VRS,$$SEND^MAGBRTE5(IMAGE,D,PRI,1,LOCATION))
+105 QUIT
End DoDot:2
QUIT
+106 IF ACTION="DICOM"
Begin DoDot:2
+107 NEW D,PRI,X
+108 SET X=$GET(RULE(RULE,"ACTION",1))
+109 IF X=""
SET METMSG(0,"No location for rule "_RULE)=""
QUIT
+110 SET D=$ORDER(^MAG(2006.587,"B",X,""))
+111 IF D=""
SET METMSG(0,"Cannot find location """_X_""".")=""
QUIT
+112 SET PRI=$$PRI($GET(RULE(RULE,"PRIORITY")),IMAGE)
+113 SET VRS=$$VRS^MAGBRTE5(VRS,$$SEND^MAGBRTE5(IMAGE,D,PRI,2,LOCATION))
+114 QUIT
End DoDot:2
QUIT
+115 IF ACTION="BALANCE"
DO BALANCE^MAGBRTE5(IMAGE,.RULE)
QUIT
+116 ;
+117 ; Other actions to be inserted here...
+118 ;
+119 QUIT
End DoDot:1
+120 ;
+121 ; Note: we may have:
+122 ; Rule 1: If CR, send to XXX
+123 ; Rule 2: If CT, send to XXX
+124 ; For a CR, this would cause an entry of
+125 ; METMSG(0,"SEND(XXX)") for rule 2
+126 ; and an entry of
+127 ; METMSG(1,"SEND(XXX)") for rule 1
+128 ; and for a CT it would be the other way around.
+129 ; So, first remove all "failed" entries that were successful
+130 ; for a different rule.
+131 ;
+132 SET X=""
FOR
SET X=$ORDER(METMSG(1,X))
if X=""
QUIT
Begin DoDot:1
+133 DO LOG^MAGBRTE5("Image "_IMAGE_": "_X)
+134 KILL METMSG(0,X)
+135 QUIT
End DoDot:1
+136 SET X=""
FOR
SET X=$ORDER(METMSG(0,X))
if X=""
QUIT
Begin DoDot:1
+137 DO LOG^MAGBRTE5("Image "_IMAGE_": Do not "_X)
+138 QUIT
End DoDot:1
+139 QUIT VRS
+140 ;
+141 ;
PRI(PRI,IMAGE) NEW C,D0,D1,D2,O,P,R,X
+1 SET PRI=$SELECT(PRI="HIGH":750,PRI="NORMAL":500,PRI="LOW":250,1:500)
+2 SET X=$GET(^MAG(2005,IMAGE,2))
+3 SET P=$PIECE(X,"^",6)
if P'=74
QUIT PRI
+4 SET R=$PIECE(X,"^",7)
if 'R
QUIT PRI
+5 ; IA 1171
SET C=$PIECE($GET(^RARPT(R,0)),"^",1)
if C=""
QUIT PRI
+6 ; IA 1172
SET D0=$ORDER(^RADPT("ADC",C,""))
if 'D0
QUIT PRI
+7 ; IA 1172
SET D1=$ORDER(^RADPT("ADC",C,D0,""))
if 'D1
QUIT PRI
+8 ; IA 1172
SET D2=$ORDER(^RADPT("ADC",C,D0,D1,""))
if 'D2
QUIT PRI
+9 ; IA 1172
SET O=$PIECE($GET(^RADPT(D0,"DT",D1,"P",D2,0)),"^",11)
if 'O
QUIT PRI
+10 ; IA 3074
SET X=$PIECE($GET(^RAO(75.1,O,0)),"^",6)
+11 QUIT PRI+$SELECT(X=1:20,X=2:10,1:0)
+12 ;
