source: FOIAVistA/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORUPR.m@ 1611

Last change on this file since 1611 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.5 KB
Line 
1RORUPR ;HCIOFO/SG - SELECTION RULES PREPARATION ; 5/12/05 9:22am
2 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
3 ;
4 Q
5 ;
6 ;***** PREPARES SELECTION RULES AND OTHER DATA
7 ;
8 ; .REGLST Reference to a local array containing registry names
9 ; as subscripts and optional registry IENs as values
10 ;
11 ; [LMODE] When stop looping through records of the patient:
12 ; 0 always loop through all records
13 ; 1 all top level rules have been triggered (deflt)
14 ; 2 patient has been marked for addition to all
15 ; registries being processed
16 ;
17 ; [DSBEG] Start date/time of the data scan (the earliest
18 ; registry update date by default)
19 ;
20 ; [DSEND] End date/time of the data scan (NOW by default)
21 ;
22 ; Return Values:
23 ; 0 Ok
24 ; <0 Error code
25 ;
26PREPARE(REGLST,LMODE,DSBEG,DSEND) ;
27 N FILE,I,RC
28 ;--- Clear loop control lists
29 K RORUPD("LM") S RORUPD("LM")=+$G(LMODE,1)
30 ;--- Load registry parameters
31 S RC=$$PREPARE1(.REGLST,$G(DSBEG),$G(DSEND)) Q:RC<0 RC
32 ;--- Load selection rules
33 S RC=$$LOAD^RORUPR1(.REGLST) Q:RC<0 $$ERROR^RORERR(-19)
34 ;--- Load and prepare Lab search data
35 S RC=$$LABSRCH^RORUPR1() Q:RC<0 $$ERROR^RORERR(-12)
36 ;--- Sort loaded rules
37 S RC=$$SORT() Q:RC<0 $$ERROR^RORERR(-20)
38 ;--- Load and prepare metadata
39 S RC=$$METADATA^RORUPR1() Q:RC<0 RC
40 Q 0
41 ;
42 ;***** LOADS REGISTRY PARAMETERS
43 ;
44 ; .REGLST Reference to a local array containing
45 ; registry names as subscripts
46 ;
47 ; [DSBEG] Start date of the data scan (the earliest registry
48 ; update date by default). Time part of the parameter
49 ; value is ignored.
50 ;
51 ; [DSEND] End date/time of the data scan (NOW by default).
52 ;
53 ; Return Values:
54 ; 0 Ok
55 ; <0 Error code
56 ;
57PREPARE1(REGLST,DSBEG,DSEND) ;
58 N DATE,EVTPROT,I,RC,REGIEN,REGNAME,RORBUF,TMP,UPDSTART
59 K RORUPD("LD"),RORUPD("LM2"),RORUPD("UPD")
60 S DSBEG=$G(DSBEG)\1,DSEND=+$G(DSEND)
61 S UPDSTART=$$DT^XLFDT,EVTPROT=0
62 ;---
63 S REGNAME="",RC=0
64 F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D Q:RC<0
65 . S TMP="1I;6.1;6.2;15.1;25I;26I"
66 . S REGIEN=$$REGIEN^RORUTL02(REGNAME,TMP,.RORBUF)
67 . I REGIEN'>0 S RC=$$ERROR^RORERR(-46,,REGNAME) Q
68 . ;--- Add an item to the static list of registries
69 . S RORUPD("LM2",REGIEN)=U_$G(RORBUF("DILIST","ID",1,26))
70 . ;--- Load and verify update entry points
71 . S RC=0
72 . F I=1,2 D Q:RC<0
73 . . S TMP=$G(RORBUF("DILIST","ID",1,+("6."_I)))
74 . . S TMP=$$TRIM^XLFSTR(TMP) Q:TMP=""
75 . . S RC=$$VERIFYEP^RORUTL01(TMP)
76 . . S:RC'<0 RORUPD("UPD",REGIEN,I)=TMP
77 . I RC<0 S RC=$$ERROR^RORERR(-6,,REGNAME,,TMP) Q
78 . ;--- Calculate the earliest update date for the registries
79 . ; being processed
80 . S DATE=$G(RORBUF("DILIST","ID",1,1))\1
81 . I DATE S:DATE<UPDSTART UPDSTART=DATE
82 . ;--- Calculate the longest lag interval
83 . S TMP=$G(RORBUF("DILIST","ID",1,15.1))
84 . S:TMP>$G(RORUPD("LD",1)) RORUPD("LD",1)=TMP
85 . ;--- Check if event references should be used
86 . S:$G(RORBUF("DILIST","ID",1,25)) EVTPROT=1
87 Q:RC<0 RC
88 ;--- Check the lag interval
89 S:$G(RORUPD("LD",1))'>0 RORUPD("LD",1)=1
90 ;--- Define data scan period
91 S RORUPD("DT")=$$NOW^XLFDT
92 S RORUPD("DSBEG")=$S(DSBEG:DSBEG,1:UPDSTART)
93 S RORUPD("DSEND")=$S(DSEND:DSEND,1:RORUPD("DT"))
94 ;--- Check if we have event references in the file #798.3
95 S RORUPD("EETS")=$O(^RORDATA(798.3,"AT",""))
96 S:'RORUPD("EETS") EVTPROT=0
97 ;--- Check the control flags
98 S:'EVTPROT RORUPD("FLAGS")=$TR($G(RORUPD("FLAGS")),"E")
99 Q 0
100 ;
101 ;***** PUTS THE RULE INTO THE LIST
102 ;
103 ; RULENAME Name of the rule
104 ; MODE "A" (process after subfiles) or
105 ; "B" (process before subfiles)
106 ; PARENT Name of the parent rule
107 ;
108 ; Return Values:
109 ; 0 Ok
110 ; <0 Error code
111 ;
112PUTRULE(RULENAME,MODE,PARENT) ;
113 N CODE,DSTNODE,DEPNAME,HDR,FILE,IR,IC
114 S HDR=$G(@RORUPDPI@(3,RULENAME)),FILE=+$P(HDR,U,2)
115 ;--- If the rule has already been processed, try to remove it from
116 ; the dependency list of the parent rule
117 I $P(HDR,U,3) D REMOVE(RULENAME,FILE,MODE,$G(PARENT)) Q 0
118 ;--- If the rule is in the list of parent rules already, it has been
119 ; mentioned ; somewhere above in the current processing path.
120 ; So, we have "cirle refrenece" (the rule directly or inderectly
121 ; depends on itself)
122 Q:$D(LSTRUL(RULENAME)) $$ERROR^RORERR(-5,,RULENAME)
123 ;--- Put the rule into the list of parent rules
124 S LSTRUL(RULENAME)=""
125 ;--- Process the rules that this one depends on
126 S DEPNAME=""
127 F S DEPNAME=$O(@RORUPDPI@(3,RULENAME,3,DEPNAME)) Q:DEPNAME="" D Q:RC<0
128 . S RC=$$PUTRULE(DEPNAME,MODE,RULENAME)
129 ;--- Remove the rule from the list of parent rules
130 K LSTRUL(RULENAME) Q:RC<0 RC
131 ;--- Process the rule (put it in the sorted list of rules) if there
132 ; are no rules left in its dependency list
133 D:$D(@RORUPDPI@(3,RULENAME,3))<10
134 . S IR=$O(RORUPD("SR",FILE,MODE,""),-1)+1
135 . S DSTNODE=$NA(RORUPD("SR",FILE,MODE,IR))
136 . S @DSTNODE=RULENAME_U_+HDR_U_$P(HDR,U,4)
137 . S @DSTNODE@(1)=@RORUPDPI@(3,RULENAME,1)
138 . M @DSTNODE@(2)=@RORUPDPI@(3,RULENAME,2)
139 . S $P(@RORUPDPI@(3,RULENAME),U,3)=1
140 . ;--- Try to remove the rule from the dependency list of
141 . ; the parent rule
142 . D REMOVE(RULENAME,FILE,MODE,$G(PARENT))
143 Q 0
144 ;
145 ;***** REMOVES THE RULE FROM THE DEPENDENCY LIST OF THE PARENT RULE
146 ;
147 ; RULENAME Name of the rule
148 ; FILE File number
149 ; MODE "A" (process after subfiles) or
150 ; "B" (process before subfiles)
151 ; PARENT Name of the parent rule
152 ;
153 ; During the first pass of the sort ("before" rules) a rule is
154 ; removed from the parent's dependency list only if the rule is
155 ; associated with the same file as its parent.
156 ;
157 ; Rules are always removed from the dependency list during
158 ; the second sort pass ("after" rules").
159 ;
160REMOVE(RULENAME,FILE,MODE,PARENT) ;
161 Q:$G(PARENT)=""
162 K:(+$P($G(@RORUPDPI@(3,PARENT)),U,2)=FILE)!(MODE="A") @RORUPDPI@(3,PARENT,3,RULENAME)
163 Q
164 ;
165 ;***** SORTS SELECTION RULES
166 ;
167 ; Return Values:
168 ; 0 Ok
169 ; <0 Error code
170 ;
171SORT() ;
172 N LSTRUL ; List of names of the parent rules above in the path
173 ;
174 N FILE,MODE,RC,RULENAME
175 S RC=0 K RORUPD("SR")
176 ;--- Process "before" selection rules first and then process
177 ; "after" rules
178 F MODE="B","A" D Q:RC
179 . S FILE="" ; Loop through affected files
180 . F S FILE=$O(@RORUPDPI@(1,FILE)) Q:FILE="" D Q:RC
181 . . S RULENAME="" ; Loop through top level rules
182 . . F S RULENAME=$O(@RORUPDPI@(1,FILE,"S",RULENAME)) Q:RULENAME="" D Q:RC<0
183 . . . S RC=$$PUTRULE(RULENAME,MODE)
184 ;---
185 Q $S(RC<0:RC,1:0)
Note: See TracBrowser for help on using the repository browser.