Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MAGBRTE4

MAGBRTE4.m

Go to the documentation of this file. 
  1. 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
  1.  ;; Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;; +---------------------------------------------------------------+
  1.  ;; | Property of the US Government.                                |
  1.  ;; | No permission to copy or redistribute this software is given. |
  1.  ;; | Use of unreleased versions of this software requires the user |
  1.  ;; | to execute a written test agreement with the VistA Imaging    |
  1.  ;; | Development Office of the Department of Veterans Affairs,     |
  1.  ;; | telephone (301) 734-0100.                                     |
  1.  ;; | The Food and Drug Administration classifies this software as  |
  1.  ;; | a medical device.  As such, it may not be changed in any way. |
  1.  ;; | Modifications to this software may result in an adulterated   |
  1.  ;; | medical device under 21CFR820, the use of which is considered |
  1.  ;; | to be a violation of US Federal Statutes.                     |
  1.  ;; +---------------------------------------------------------------+
  1.  ;;
  1.  Q
  1.  ;
  1. EVAL ;
  1.  N ACTIVE ;--- Switch that controls start/stop queue processor
  1.  N ANY ;------ Flag: processed any rule
  1.  N CONS ;----- Switch that indicates whether or not site has "consolidated" code
  1.  N KEYWORD ;-- Array with all keywords
  1.  N MAGFILE1 ;- Name of file
  1.  N XMSG ;----- Message counter
  1.  ;
  1.  F I="MAGEVAL","MAGEVALSTUDY" K ^XTMP(I,ZTSK)
  1.  D LOG^MAGBRTE5("Started at "_$H)
  1.  S XMSG=1,CONS=$$CONSOLID^MAGBAPI()
  1.  S PLACE=$S(CONS:$O(^MAG(2006.1,"B",LOCATION,"")),1:1)
  1.  L +^MAGDICOM(2006.563,1,"EVAL",LOCATION):0 E  D  Q
  1.  . D LOG^MAGBRTE5("A rule evaluator is already running for "_$$GET1^DIQ(4,LOCATION,.01))
  1.  . Q
  1.  S ^MAGDICOM(2006.563,1,"EVAL")=1
  1.  ;
  1.  S I="" F  S I=$O(RULES(I)) Q:I=""  D
  1.  . N D0,D1,D2,L,Q1
  1.  . S X=RULES(I),D0=$P(X,"^",1),Q1=$P(X,"^",2),L=$L(X,"^")
  1.  . I L=3 S RULE(D0,Q1)=$P(X,"^",3) Q
  1.  . I Q1="ACTION" S RULE(D0,Q1,$P(X,"^",3))=$P(X,"^",4,L) Q
  1.  . I Q1'="CONDITION" D LOG^MAGBRTE5("Rule "_D0_" has a qualifier """_Q1_""".") Q
  1.  . I L=5 S RULE(D0,Q1,$P(X,"^",3),$P(X,"^",4))=$P(X,"^",5) Q
  1.  . S RULE(D0,Q1,$P(X,"^",3),$P(X,"^",4),$P(X,"^",6),$P(X,"^",5))=$P(X,"^",7)
  1.  . Q
  1.  K RULES
  1.  ;
  1.  S ACTIVE=1 F  D  Q:'ACTIVE
  1.  . S ANY=0
  1.  . S ACTIVE=+$G(^MAGDICOM(2006.563,1,"EVAL")) I 'ACTIVE D  Q
  1.  . . D LOG^MAGBRTE5("Stopped at "_$H)
  1.  . . Q
  1.  . D
  1.  . . N IMAGE,QPTR,QPTR2,STATUS,X
  1.  . . D:'CONS ADD^MAGBAPI(0,"EVAL")
  1.  . . D:CONS ADD^MAGBAPI(0,"EVAL",PLACE)
  1.  . . ;S QPTR2=$O(^MAGQUEUE(2006.031,"B","EVAL",""))
  1.  . . S QPTR2=$O(^MAGQUEUE(2006.031,"C",PLACE,"EVAL","")) ; "C",PLACE    was  "B" ;p196
  1.  . . S QPTR=$S(QPTR2:$P(^MAGQUEUE(2006.031,QPTR2,0),"^",2),1:"")
  1.  . . ; Get next queue pointer value
  1.  . . S:'CONS QPTR=$O(^MAGQUEUE(2006.03,"C","EVAL",QPTR)) ;    "C"  WAS "B"  ;p196
  1.  . . S:CONS QPTR=$O(^MAGQUEUE(2006.03,"C",PLACE,"EVAL",QPTR))
  1.  . . I QPTR="" Q  ; Nothing to do
  1.  . . ;
  1.  . . S X=$G(^MAGQUEUE(2006.03,QPTR,0))
  1.  . . ; After an error, sometimes the entry is purged,
  1.  . . ; but the cross reference is still present.
  1.  . . ; In such a case, remove the cross reference.
  1.  . . I X="" D  Q
  1.  . . . K:'CONS ^MAGQUEUE(2006.03,"C","EVAL",QPTR) ; "C"   was   "B"  ;p196
  1.  . . . K:CONS ^MAGQUEUE(2006.03,"C",PLACE,"EVAL",QPTR)
  1.  . . . Q
  1.  . . ;
  1.  . . S IMAGE=$P(X,"^",7),ANY=1
  1.  . . I IMAGE,$D(^MAG(2005,IMAGE,0)) D
  1.  . . . S STATUS=$$RULES() Q:STATUS'<0
  1.  . . . I STATUS["NO NETWORK LOCATION" D  Q
  1.  . . . . D LOG^MAGBRTE5("Image "_IMAGE_" has no files associated with it")
  1.  . . . . Q
  1.  . . . D LOG^MAGBRTE5("*** EVAL queue error: "_STATUS_" ***")
  1.  . . . Q
  1.  . . ;D DQUE^MAGQBUT2(QPTR)  ; replaced with line below p196
  1.  . . D QPTER^MAGQBTM("EVAL",QPTR,PLACE),DQUE^MAGQBUT2(QPTR)
  1.  . . Q
  1.  . H:'ANY 1
  1.  . D:'$D(^XTMP("MAGEVAL",ZTSK)) XTINIT^MAGDRPC5,LOG^MAGBRTE5("^XTMP was cleaned up.")
  1.  . Q
  1.  L -^MAGDICOM(2006.563,1,"EVAL",LOCATION)
  1.  Q
  1.  ;
  1. RULES() ; To be called from above
  1.  ; IMAGE ;---- IEN for image (2005)
  1.  ; LOCATION ;- Location from which queue entry originates
  1.  N ACTION ;--- Action to be taken (SEND)
  1.  N C ;-------- Loop-variable for looping through parameters and conditions
  1.  N D ;-------- Data type
  1.  N DS ;------- Data type enclosed in space-characters
  1.  N F ;-------- ...
  1.  N METMSG ;--- Message to be issued when rule is evaluated
  1.  N O ;-------- Operator
  1.  N OK ;------- Flag: indicates whether or not rule is met
  1.  N RDT ;------ Current date (don't use DT, process might run over midnight)
  1.  N STUDYUID ;- Study UID
  1.  N V ;-------- Value for property as specified in rule
  1.  N VAL ;------ Actual value of property
  1.  N VRS ;------ String of Queue Entry numbers when rule(s) are met
  1.  N X ;-------- Scratch variable
  1.  ;
  1.  S VRS=""
  1.  ;
  1.  D KEYWORD^MAGBRTK
  1.  ;
  1.  D FILEFIND^MAGDFB(IMAGE,"FULL",0,0,.MAGFILE1)
  1.  Q:MAGFILE1<0 MAGFILE1
  1.  ;
  1.  S STUDYUID=$P($G(^MAG(2005,IMAGE,"PACS")),"^",1)
  1.  S X=$P($G(^MAG(2005,IMAGE,0)),"^",10)
  1.  S:X STUDYUID=$P($G(^MAG(2005,X,"PACS")),"^",1)
  1.  ;
  1.  S RULE=0 F  S RULE=$O(RULE(RULE)) Q:'RULE  D
  1.  . S METMSG=$G(RULE(RULE,"ACTION"))
  1.  . S X=" (",C=0 F  S C=$O(RULE(RULE,"ACTION",C)) Q:'C  D
  1.  . . S METMSG=METMSG_X_$G(RULE(RULE,"ACTION",C)),X=", "
  1.  . . Q
  1.  . S:X'=" (" METMSG=METMSG_")"
  1.  . S:METMSG="" METMSG="Rule #"_RULE
  1.  . I (STUDYUID="")!(ZTSK="")!(RULE="") Q  ; P156 DAC - Prevent deleted groups from causing hard crashes
  1.  . S OK=$G(^XTMP("MAGEVALSTUDY",ZTSK,STUDYUID,RULE))
  1.  . I OK="" S OK=1,C=0 F  S C=$O(RULE(RULE,"CONDITION",C)) Q:'C  D  Q:'OK
  1.  . . S F=$G(RULE(RULE,"CONDITION",C,"KW")) Q:F=""
  1.  . . S X=$G(KEYWORD("CONDITION",F),"^DICOM^MAGBRTE3(F,""OUT"",.VAL)")
  1.  . . K VAL D @$P(X,"^",2,9)
  1.  . . ; If the field is not defined, the test passes...
  1.  . . Q:$D(VAL)'=1  ; We won't deal with multiple values just yet...
  1.  . . ;
  1.  . . S V=$G(RULE(RULE,"CONDITION",C,"VA"))
  1.  . . S D=$G(RULE(RULE,"CONDITION",C,"DT"))
  1.  . . S O=$G(RULE(RULE,"CONDITION",C,"OP"))
  1.  . . S:D="" D="S"
  1.  . . S DS=" "_D_" "
  1.  . . D:" S CS DS IS LO LT OB OW PN SH ST "[DS
  1.  . . . N WILD ;-- Wildcard to be matched
  1.  . . . S WILD=$$WLDMATCH^MAGBRTE5(VAL,V)
  1.  . . . I O="=",'WILD S OK=0 Q
  1.  . . . I O="!=",WILD S OK=0 Q
  1.  . . . Q
  1.  . . D:" DT DA TM "[DS
  1.  . . . Q:O'="="  ; Only "within range" comparisons allowed currently
  1.  . . . ;
  1.  . . . N A ;--- Flag: indicates whether at least one time-frame matches
  1.  . . . N B ;--- Begin date/time
  1.  . . . N E ;--- End date/time
  1.  . . . N I ;--- Loopcounter
  1.  . . . N M ;--- Date/time mask
  1.  . . . N N ;--- Loopcounter (time-frames)
  1.  . . . N %T ;-- FileMan internal variable
  1.  . . . N VV ;-- Actual value
  1.  . . . N WD ;-- Weekday
  1.  . . . N X1 ;-- FileMan API parameter value -- date
  1.  . . . N X2 ;-- FileMan API parameter value -- date
  1.  . . . ;
  1.  . . . ; convert the literal date/time field into the format for comparison
  1.  . . . S VV=VAL
  1.  . . . ;
  1.  . . . S (A,N)=0 F  S N=$O(RULE(RULE,"CONDITION",C,"VA",N)) Q:'N  D
  1.  . . . . N T,VB,VC,VE
  1.  . . . . S M=$G(RULE(RULE,"CONDITION",C,"VA",N,"M"))
  1.  . . . . S B=$G(RULE(RULE,"CONDITION",C,"VA",N,"B"))
  1.  . . . . S E=$G(RULE(RULE,"CONDITION",C,"VA",N,"E"))
  1.  . . . . S T=1
  1.  . . . . I $E(M,1,3)="HOL" S:$$GET1^DIQ(40.5,+$E(VV,5,11),.01)="" T=0 ; IA 10038
  1.  . . . . I $E(M,1,3)="DDD",$E(B,1,3)'=$E(VAL,1,3) S T=0
  1.  . . . . S (VB,VC,VE)=""
  1.  . . . . 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)
  1.  . . . . S:VB>VC T=0
  1.  . . . . S:VE<VC T=0
  1.  . . . . S:T A=1
  1.  . . . . Q
  1.  . . . S:'A OK=0
  1.  . . . Q
  1.  . . Q
  1.  . S ^XTMP("MAGEVALSTUDY",ZTSK,STUDYUID,RULE)=OK
  1.  . S METMSG(OK,METMSG)=""
  1.  . S RDT=$$NOW^XLFDT()\1
  1.  . Q:'OK
  1.  . S ACTION=$G(RULE(RULE,"ACTION"))
  1.  . Q:ACTION=""
  1.  . I ACTION="SEND" D  Q
  1.  . . N D,PRI,X
  1.  . . S X=$G(RULE(RULE,"ACTION",1))
  1.  . . I X="" S METMSG(0,"No location for rule "_RULE)="" Q
  1.  . . D VALDEST^MAGDRPC1(.D,X)
  1.  . . I D<0 S METMSG(0,"Cannot find location """_X_""".")="" Q
  1.  . . S PRI=$$PRI($G(RULE(RULE,"PRIORITY")),IMAGE)
  1.  . . S VRS=$$VRS^MAGBRTE5(VRS,$$SEND^MAGBRTE5(IMAGE,D,PRI,1,LOCATION))
  1.  . . Q
  1.  . I ACTION="DICOM" D  Q
  1.  . . N D,PRI,X
  1.  . . S X=$G(RULE(RULE,"ACTION",1))
  1.  . . I X="" S METMSG(0,"No location for rule "_RULE)="" Q
  1.  . . S D=$O(^MAG(2006.587,"B",X,""))
  1.  . . I D="" S METMSG(0,"Cannot find location """_X_""".")="" Q
  1.  . . S PRI=$$PRI($G(RULE(RULE,"PRIORITY")),IMAGE)
  1.  . . S VRS=$$VRS^MAGBRTE5(VRS,$$SEND^MAGBRTE5(IMAGE,D,PRI,2,LOCATION))
  1.  . . Q
  1.  . I ACTION="BALANCE" D BALANCE^MAGBRTE5(IMAGE,.RULE) Q
  1.  . ;
  1.  . ; Other actions to be inserted here...
  1.  . ;
  1.  . Q
  1.  ;
  1.  ; Note: we may have:
  1.  ;    Rule 1: If CR, send to XXX
  1.  ;    Rule 2: If CT, send to XXX
  1.  ; For a CR, this would cause an entry of
  1.  ;    METMSG(0,"SEND(XXX)") for rule 2
  1.  ; and an entry of
  1.  ;    METMSG(1,"SEND(XXX)") for rule 1
  1.  ; and for a CT it would be the other way around.
  1.  ; So, first remove all "failed" entries that were successful
  1.  ; for a different rule.
  1.  ;
  1.  S X="" F  S X=$O(METMSG(1,X)) Q:X=""  D
  1.  . D LOG^MAGBRTE5("Image "_IMAGE_": "_X)
  1.  . K METMSG(0,X)
  1.  . Q
  1.  S X="" F  S X=$O(METMSG(0,X)) Q:X=""  D
  1.  . D LOG^MAGBRTE5("Image "_IMAGE_": Do not "_X)
  1.  . Q
  1.  Q VRS
  1.  ;
  1.  ;
  1. PRI(PRI,IMAGE) N C,D0,D1,D2,O,P,R,X
  1.  S PRI=$S(PRI="HIGH":750,PRI="NORMAL":500,PRI="LOW":250,1:500)
  1.  S X=$G(^MAG(2005,IMAGE,2))
  1.  S P=$P(X,"^",6) Q:P'=74 PRI
  1.  S R=$P(X,"^",7) Q:'R PRI
  1.  S C=$P($G(^RARPT(R,0)),"^",1) Q:C="" PRI  ; IA 1171
  1.  S D0=$O(^RADPT("ADC",C,"")) Q:'D0 PRI  ; IA 1172
  1.  S D1=$O(^RADPT("ADC",C,D0,"")) Q:'D1 PRI  ; IA 1172
  1.  S D2=$O(^RADPT("ADC",C,D0,D1,"")) Q:'D2 PRI  ; IA 1172
  1.  S O=$P($G(^RADPT(D0,"DT",D1,"P",D2,0)),"^",11) Q:'O PRI  ; IA 1172
  1.  S X=$P($G(^RAO(75.1,O,0)),"^",6) ; IA 3074
  1.  Q PRI+$S(X=1:20,X=2:10,1:0)
  1.  ;