186 lines
6.5 KiB
Mathematica
186 lines
6.5 KiB
Mathematica
RORUPR ;HCIOFO/SG - SELECTION RULES PREPARATION ; 5/12/05 9:22am
|
|
;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
|
|
;
|
|
Q
|
|
;
|
|
;***** PREPARES SELECTION RULES AND OTHER DATA
|
|
;
|
|
; .REGLST Reference to a local array containing registry names
|
|
; as subscripts and optional registry IENs as values
|
|
;
|
|
; [LMODE] When stop looping through records of the patient:
|
|
; 0 always loop through all records
|
|
; 1 all top level rules have been triggered (deflt)
|
|
; 2 patient has been marked for addition to all
|
|
; registries being processed
|
|
;
|
|
; [DSBEG] Start date/time of the data scan (the earliest
|
|
; registry update date by default)
|
|
;
|
|
; [DSEND] End date/time of the data scan (NOW by default)
|
|
;
|
|
; Return Values:
|
|
; 0 Ok
|
|
; <0 Error code
|
|
;
|
|
PREPARE(REGLST,LMODE,DSBEG,DSEND) ;
|
|
N FILE,I,RC
|
|
;--- Clear loop control lists
|
|
K RORUPD("LM") S RORUPD("LM")=+$G(LMODE,1)
|
|
;--- Load registry parameters
|
|
S RC=$$PREPARE1(.REGLST,$G(DSBEG),$G(DSEND)) Q:RC<0 RC
|
|
;--- Load selection rules
|
|
S RC=$$LOAD^RORUPR1(.REGLST) Q:RC<0 $$ERROR^RORERR(-19)
|
|
;--- Load and prepare Lab search data
|
|
S RC=$$LABSRCH^RORUPR1() Q:RC<0 $$ERROR^RORERR(-12)
|
|
;--- Sort loaded rules
|
|
S RC=$$SORT() Q:RC<0 $$ERROR^RORERR(-20)
|
|
;--- Load and prepare metadata
|
|
S RC=$$METADATA^RORUPR1() Q:RC<0 RC
|
|
Q 0
|
|
;
|
|
;***** LOADS REGISTRY PARAMETERS
|
|
;
|
|
; .REGLST Reference to a local array containing
|
|
; registry names as subscripts
|
|
;
|
|
; [DSBEG] Start date of the data scan (the earliest registry
|
|
; update date by default). Time part of the parameter
|
|
; value is ignored.
|
|
;
|
|
; [DSEND] End date/time of the data scan (NOW by default).
|
|
;
|
|
; Return Values:
|
|
; 0 Ok
|
|
; <0 Error code
|
|
;
|
|
PREPARE1(REGLST,DSBEG,DSEND) ;
|
|
N DATE,EVTPROT,I,RC,REGIEN,REGNAME,RORBUF,TMP,UPDSTART
|
|
K RORUPD("LD"),RORUPD("LM2"),RORUPD("UPD")
|
|
S DSBEG=$G(DSBEG)\1,DSEND=+$G(DSEND)
|
|
S UPDSTART=$$DT^XLFDT,EVTPROT=0
|
|
;---
|
|
S REGNAME="",RC=0
|
|
F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D Q:RC<0
|
|
. S TMP="1I;6.1;6.2;15.1;25I;26I"
|
|
. S REGIEN=$$REGIEN^RORUTL02(REGNAME,TMP,.RORBUF)
|
|
. I REGIEN'>0 S RC=$$ERROR^RORERR(-46,,REGNAME) Q
|
|
. ;--- Add an item to the static list of registries
|
|
. S RORUPD("LM2",REGIEN)=U_$G(RORBUF("DILIST","ID",1,26))
|
|
. ;--- Load and verify update entry points
|
|
. S RC=0
|
|
. F I=1,2 D Q:RC<0
|
|
. . S TMP=$G(RORBUF("DILIST","ID",1,+("6."_I)))
|
|
. . S TMP=$$TRIM^XLFSTR(TMP) Q:TMP=""
|
|
. . S RC=$$VERIFYEP^RORUTL01(TMP)
|
|
. . S:RC'<0 RORUPD("UPD",REGIEN,I)=TMP
|
|
. I RC<0 S RC=$$ERROR^RORERR(-6,,REGNAME,,TMP) Q
|
|
. ;--- Calculate the earliest update date for the registries
|
|
. ; being processed
|
|
. S DATE=$G(RORBUF("DILIST","ID",1,1))\1
|
|
. I DATE S:DATE<UPDSTART UPDSTART=DATE
|
|
. ;--- Calculate the longest lag interval
|
|
. S TMP=$G(RORBUF("DILIST","ID",1,15.1))
|
|
. S:TMP>$G(RORUPD("LD",1)) RORUPD("LD",1)=TMP
|
|
. ;--- Check if event references should be used
|
|
. S:$G(RORBUF("DILIST","ID",1,25)) EVTPROT=1
|
|
Q:RC<0 RC
|
|
;--- Check the lag interval
|
|
S:$G(RORUPD("LD",1))'>0 RORUPD("LD",1)=1
|
|
;--- Define data scan period
|
|
S RORUPD("DT")=$$NOW^XLFDT
|
|
S RORUPD("DSBEG")=$S(DSBEG:DSBEG,1:UPDSTART)
|
|
S RORUPD("DSEND")=$S(DSEND:DSEND,1:RORUPD("DT"))
|
|
;--- Check if we have event references in the file #798.3
|
|
S RORUPD("EETS")=$O(^RORDATA(798.3,"AT",""))
|
|
S:'RORUPD("EETS") EVTPROT=0
|
|
;--- Check the control flags
|
|
S:'EVTPROT RORUPD("FLAGS")=$TR($G(RORUPD("FLAGS")),"E")
|
|
Q 0
|
|
;
|
|
;***** PUTS THE RULE INTO THE LIST
|
|
;
|
|
; RULENAME Name of the rule
|
|
; MODE "A" (process after subfiles) or
|
|
; "B" (process before subfiles)
|
|
; PARENT Name of the parent rule
|
|
;
|
|
; Return Values:
|
|
; 0 Ok
|
|
; <0 Error code
|
|
;
|
|
PUTRULE(RULENAME,MODE,PARENT) ;
|
|
N CODE,DSTNODE,DEPNAME,HDR,FILE,IR,IC
|
|
S HDR=$G(@RORUPDPI@(3,RULENAME)),FILE=+$P(HDR,U,2)
|
|
;--- If the rule has already been processed, try to remove it from
|
|
; the dependency list of the parent rule
|
|
I $P(HDR,U,3) D REMOVE(RULENAME,FILE,MODE,$G(PARENT)) Q 0
|
|
;--- If the rule is in the list of parent rules already, it has been
|
|
; mentioned ; somewhere above in the current processing path.
|
|
; So, we have "cirle refrenece" (the rule directly or inderectly
|
|
; depends on itself)
|
|
Q:$D(LSTRUL(RULENAME)) $$ERROR^RORERR(-5,,RULENAME)
|
|
;--- Put the rule into the list of parent rules
|
|
S LSTRUL(RULENAME)=""
|
|
;--- Process the rules that this one depends on
|
|
S DEPNAME=""
|
|
F S DEPNAME=$O(@RORUPDPI@(3,RULENAME,3,DEPNAME)) Q:DEPNAME="" D Q:RC<0
|
|
. S RC=$$PUTRULE(DEPNAME,MODE,RULENAME)
|
|
;--- Remove the rule from the list of parent rules
|
|
K LSTRUL(RULENAME) Q:RC<0 RC
|
|
;--- Process the rule (put it in the sorted list of rules) if there
|
|
; are no rules left in its dependency list
|
|
D:$D(@RORUPDPI@(3,RULENAME,3))<10
|
|
. S IR=$O(RORUPD("SR",FILE,MODE,""),-1)+1
|
|
. S DSTNODE=$NA(RORUPD("SR",FILE,MODE,IR))
|
|
. S @DSTNODE=RULENAME_U_+HDR_U_$P(HDR,U,4)
|
|
. S @DSTNODE@(1)=@RORUPDPI@(3,RULENAME,1)
|
|
. M @DSTNODE@(2)=@RORUPDPI@(3,RULENAME,2)
|
|
. S $P(@RORUPDPI@(3,RULENAME),U,3)=1
|
|
. ;--- Try to remove the rule from the dependency list of
|
|
. ; the parent rule
|
|
. D REMOVE(RULENAME,FILE,MODE,$G(PARENT))
|
|
Q 0
|
|
;
|
|
;***** REMOVES THE RULE FROM THE DEPENDENCY LIST OF THE PARENT RULE
|
|
;
|
|
; RULENAME Name of the rule
|
|
; FILE File number
|
|
; MODE "A" (process after subfiles) or
|
|
; "B" (process before subfiles)
|
|
; PARENT Name of the parent rule
|
|
;
|
|
; During the first pass of the sort ("before" rules) a rule is
|
|
; removed from the parent's dependency list only if the rule is
|
|
; associated with the same file as its parent.
|
|
;
|
|
; Rules are always removed from the dependency list during
|
|
; the second sort pass ("after" rules").
|
|
;
|
|
REMOVE(RULENAME,FILE,MODE,PARENT) ;
|
|
Q:$G(PARENT)=""
|
|
K:(+$P($G(@RORUPDPI@(3,PARENT)),U,2)=FILE)!(MODE="A") @RORUPDPI@(3,PARENT,3,RULENAME)
|
|
Q
|
|
;
|
|
;***** SORTS SELECTION RULES
|
|
;
|
|
; Return Values:
|
|
; 0 Ok
|
|
; <0 Error code
|
|
;
|
|
SORT() ;
|
|
N LSTRUL ; List of names of the parent rules above in the path
|
|
;
|
|
N FILE,MODE,RC,RULENAME
|
|
S RC=0 K RORUPD("SR")
|
|
;--- Process "before" selection rules first and then process
|
|
; "after" rules
|
|
F MODE="B","A" D Q:RC
|
|
. S FILE="" ; Loop through affected files
|
|
. F S FILE=$O(@RORUPDPI@(1,FILE)) Q:FILE="" D Q:RC
|
|
. . S RULENAME="" ; Loop through top level rules
|
|
. . F S RULENAME=$O(@RORUPDPI@(1,FILE,"S",RULENAME)) Q:RULENAME="" D Q:RC<0
|
|
. . . S RC=$$PUTRULE(RULENAME,MODE)
|
|
;---
|
|
Q $S(RC<0:RC,1:0)
|