source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETXR.m@ 1006

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

revised back to 6/30/08 version

File size: 8.8 KB
Line 
1PXRMETXR ; SLC/PJH,PKR - Reminder section of extract ;05/01/2006
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;
4 ; Called from PXRMETX
5 ;
6DATE ;Check if finding is most recent in evaluation group
7 N FDATE,GDATE
8 ;Determine finding date and existing group date
9 S FDATE=$G(FIEV(FNUM,"DATE")),GDATE=$G(GROUP(GSEQ,"DATE")) Q:FDATE=""
10 ;Ignore findings outside to the extract period
11 ;I $$FMDIFF^XLFDT(PXRMSTRT,FDATE,2)>0 Q
12 ;If this is first or only entry in group then save finding date
13 I 'GDATE S GROUP(GSEQ,"DATE")=FDATE,GROUP(GSEQ)=FSEQ Q
14 ;Save finding if most recent date for the group
15 I $$FMDIFF^XLFDT(FDATE,GDATE,2)>0 S GROUP(GSEQ,"DATE")=FDATE,GROUP(GSEQ)=FSEQ Q
16 Q
17 ;
18FIND(SEQ,RCNT,PXRMSTRT,PXRMSTOP) ;Process findings for reminder
19 ;Default is extract no findings
20 N DATA,FCNT,FIEN,FIND,FNUM,FSEQ,GDATA,GROUP,GSEQ,GTYP
21 S FNUM=0,FCNT=0
22 F S FNUM=$O(FIEV(FNUM)) Q:'FNUM D
23 .;Ignore if not found for patient
24 .I +FIEV(FNUM)=0 Q
25 .;Only terms are counted
26 .S FIND=$G(FIEV(FNUM,"TERM IEN")) Q:FIND=""
27 .;Check if in list to be accumulated
28 .I '$D(REM(RCNT,FIND)) Q
29 .;Find groups to which finding belongs
30 .S GSEQ=""
31 .F S GSEQ=$O(REM(RCNT,FIND,GSEQ)) Q:GSEQ="" D
32 ..;Determine Evaluation type
33 ..S GTYP=REM(RCNT,FIND,GSEQ)
34 ..;Ignore utilization groups
35 ..I GTYP="UR" Q
36 ..;Sequence determines where the finding will be stored
37 ..S FSEQ=""
38 ..F S FSEQ=$O(REM(RCNT,FIND,GSEQ,FSEQ)) Q:FSEQ="" D
39 ...;Evaluation Group logic to save latest entry only
40 ...I GTYP="MRFP" D DATE Q
41 ...;Save finding totals
42 ...D UPD(1)
43 ;
44 ;Check for group totals
45 S GSEQ=""
46 F S GSEQ=$O(GROUP(GSEQ)) Q:GSEQ="" D
47 .S GDATA=$G(GROUP(GSEQ)) Q:GDATA=""
48 .;Update if found
49 .S FSEQ=$P(GDATA,U) D UPD(1)
50 ;
51 ;Utilization counts are done separately
52 N CNT,FDATA,FIND,FINDPA,FTIEN,GTYP,TERMARR,TFIEVAL
53 ;modify start date to include incomplete dates
54 I $E(PXRMSTRT,6,7)="01" S PXRMSTRT=$E(PXRMSTRT,1,5)_"00"
55 ;Include incomplete dates in January
56 I $E(PXRMSTRT,4,5)="01" S PXRMSTRT=$E(PXRMSTRT,1,3)_"0000"
57 ;Set start and stop dates for term
58 ;S $P(FINDPA(0),U,8)=PXRMSTRT,$P(FINDPA(0),U,11)=PXRMSTOP
59 S $P(FINDPA(0),U,11)=PXRMSTOP
60 ;Count all entries
61 S $P(FINDPA(0),U,14)="*"
62 ;
63 S FTIEN="",GTYP="UR"
64 F S FTIEN=$O(FUTIL(RCNT,FTIEN)) Q:FTIEN="" D
65 .S GSEQ=""
66 .F S GSEQ=$O(FUTIL(RCNT,FTIEN,GSEQ)) Q:GSEQ="" D
67 ..S FSEQ=""
68 ..F S FSEQ=$O(FUTIL(RCNT,FTIEN,GSEQ,FSEQ)) Q:FSEQ="" D
69 ...;Recover list of term findings
70 ...K TERMARR M TERMARR=FUTIL(RCNT,FTIEN,GSEQ,FSEQ)
71 ...;Process term
72 ...K TFIEVAL D EVALTERM^PXRMTERM(DFN,.FINDPA,.TERMARR,.TFIEVAL)
73 ...D URCNT(PXRMSTRT,PXRMSTOP,.TFIEVAL)
74 ;Determine count from PLIST then add to ETX
75 ;S CNT=+$O(PLIST(1,999999),-1) Q:'CNT
76 ;D UPD(CNT)
77 Q
78 ;
79FRULE(FRIEN,RCNT,SEQ,REM,FUTIL) ;Build array of findings in the finding rule
80 N DATA,FIND,FSEQ,GIEN,GNAM,GSEQ,GTYP,GSTA,SUB,TLIST
81 S GSEQ=0
82 F S GSEQ=$O(^PXRM(810.7,FRIEN,10,"B",GSEQ)) Q:GSEQ="" D
83 .S SUB=$O(^PXRM(810.7,FRIEN,10,"B",GSEQ,"")) Q:'SUB
84 .S DATA=$G(^PXRM(810.7,FRIEN,10,SUB,0)) Q:DATA=""
85 .;Get the finding group ien and reminder status
86 .S GIEN=$P(DATA,U,2),GSTA=$P(DATA,U,3) Q:'GIEN
87 .;If no status then report finding totals for all patients
88 .I GSTA="" S GSTA="T"
89 .;Get finding group info
90 .S DATA=$G(^PXRM(810.8,GIEN,0)) Q:DATA=""
91 .;Get group name and count type
92 .S GTYP=$P(DATA,U,3),GNAM=$P(DATA,U) Q:GTYP=""
93 .;Save group in workfile
94 .S ^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ)=GNAM_U_GTYP_U_GSTA
95 .;Get all findings in group
96 .S FSEQ=0
97 .F S FSEQ=$O(^PXRM(810.8,GIEN,10,"B",FSEQ)) Q:FSEQ="" D
98 ..S SUB=$O(^PXRM(810.8,GIEN,10,"B",FSEQ,"")) Q:'SUB
99 ..S DATA=$G(^PXRM(810.8,GIEN,10,SUB,0)) Q:DATA=""
100 ..;Get the finding ien and exclusion status
101 ..S FIND=$P(DATA,U,2) Q:'FIND
102 ..;Initialize count for finding
103 ..S ^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)=FIND
104 ..;Reminder evaluation counts work from REM
105 ..I GTYP'="UR" D Q
106 ...S REM(RCNT,FIND,GSEQ,FSEQ)=""
107 ...S REM(RCNT,FIND,GSEQ)=GTYP
108 ..;Utilization counts work from FUTIL
109 ..D TERM^PXRMLDR(FIND,.TLIST)
110 ..;Save TLIST
111 ..M FUTIL(RCNT,FIND,GSEQ,FSEQ)=TLIST
112 Q
113 ;
114REM(SUB,PXRMLIST,PXRMSTRT,PXRMSTOP,PARTYPE) ;Run reminders against patient
115 ;lists.
116 N APPL,DATA,DEFARR,DEFSITE,DFN,DUE,FIEV,FRIEN,FUTIL,IND,INST
117 N PXRMDATE,RCNT,REM,RIEN,RNAM,STATUS,SUB1,TODAY
118 N END,START
119 ;S START=$H
120 S TODAY=$$DT^XLFDT
121 ;Evaluation date is period end except if the period is incomplete
122 S PXRMDATE=$S($$FMDIFF^XLFDT(PXRMSTOP,TODAY,2)>0:TODAY,1:PXRMSTOP)
123 ;Scan reminders for this parameter set
124 S (RCNT,SUB1)=0
125 F S SUB1=$O(^PXRM(810.2,IEN,10,SUB,10,SUB1)) Q:'SUB1 D
126 .S DATA=$G(^PXRM(810.2,IEN,10,SUB,10,SUB1,0)) Q:DATA=""
127 .;Reminder ien
128 .S RIEN=$P(DATA,U,2) Q:'RIEN
129 .;Evaluation date is period end except if the period is incomplete.
130 .S PXRMDATE=$S($$FMDIFF^XLFDT(PXRMSTOP,TODAY,2)>0:TODAY,1:PXRMSTOP)
131 .;Finding Rule
132 .S FRIEN=$P(DATA,U,3)
133 .;Reminder print name
134 .S RNAM=$P($G(^PXD(811.9,RIEN,0)),U,3)
135 .;Save details to REM array
136 .S RCNT=RCNT+1,REM(RCNT)=RIEN_U_RNAM_U_FRIEN
137 .;Build list of terms from extract finding rule #810.7
138 .I FRIEN D FRULE(FRIEN,RCNT,SEQ,.REM,.FUTIL) Q
139 .;If no extract finding rule defined collect all findings in reminder
140 .I 'FRIEN D REMF(RIEN,RCNT,SEQ,.REM)
141 ;
142 ;Process patient list
143 S IND=0,DEFSITE=+$P($$SITE^VASITE,U,3)
144 F S IND=$O(^PXRMXP(810.5,PXRMLIST,30,IND)) Q:'IND D
145 .S DFN=$P($G(^PXRMXP(810.5,PXRMLIST,30,IND,0)),U) Q:'DFN
146 .S INST=$P($G(^PXRMXP(810.5,PXRMLIST,30,IND,0)),U,2)
147 .I INST="" S INST=DEFSITE
148 .S RCNT=0
149 .F S RCNT=$O(REM(RCNT)) Q:'RCNT D
150 ..S RIEN=$P(REM(RCNT),U),RNAM=$P(REM(RCNT),U,2),FRIEN=$P(REM(RCNT),U,3)
151 ..;Clear evaluation arrays.
152 ..K ^TMP("PXRHM",$J),^TMP("PXRMID",$J),FIEV
153 ..;Evaluate reminders and store results
154 ..D DEF^PXRMLDR(RIEN,.DEFARR)
155 ..D EVAL^PXRM(DFN,.DEFARR,1,1,.FIEV,PXRMDATE)
156 ..;Determine update from reminder status
157 ..S STATUS=$P($G(^TMP("PXRHM",$J,RIEN,RNAM)),U) I STATUS="" Q
158 ..;Ignore not applicables
159 ..S APPL=$S(STATUS["DUE":1,STATUS="RESOLVED":1,STATUS="DONE":1,1:0)
160 ..;Check if due
161 ..S DUE=$S(STATUS="DUE NOW":1,1:0)
162 ..;Compliance totals
163 ..S DATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT))
164 ..;Reminder ien
165 ..I $P(DATA,U)="" S $P(DATA,U)=RIEN
166 ..;Evaluated total
167 ..S $P(DATA,U,2)=$P(DATA,U,2)+1
168 ..;Applicable total
169 ..S $P(DATA,U,3)=$P(DATA,U,3)+APPL
170 ..;Not applicable total
171 ..I 'APPL,'DUE S $P(DATA,U,4)=$P(DATA,U,4)+1
172 ..;Due total
173 ..S $P(DATA,U,5)=$P(DATA,U,5)+DUE
174 ..;Not due count
175 ..I APPL,'DUE S $P(DATA,U,6)=$P(DATA,U,6)+1
176 ..;Add patient list
177 ..I $P(DATA,U,7)="" S $P(DATA,U,7)=PXRMLIST
178 ..;Update workfile
179 ..S ^TMP("PXRMETX",$J,SEQ,INST,RCNT)=DATA
180 ..;Save finding totals
181 ..I PARTYPE="CF" D FIND(SEQ,RCNT,PXRMSTRT,PXRMSTOP)
182 ;Clear evaluation fields
183 K ^TMP("PXRHM",$J),^TMP("PXRMID",$J)
184 ;S END=$H
185 ;W !,"REMINDER EVALUATION TIME"
186 ;D DETIME^PXRMXSEL(START,END)
187 Q
188 ;
189REMF(RIEN,RCNT,SEQ,REM) ;Build array of all findings in the reminder
190 N GNAM,GSEQ,FIND,FSEQ,GTYP,SUB
191 S GNAM="Finding totals",GSEQ="001",FSEQ=0,GTYP="MRF"
192 ;Save group name
193 S ^TMP("PXRMETX",$J,SEQ,RCNT,GSEQ)=GNAM_U_GTYP
194 ;Select all findings in the reminder
195 S SUB=0
196 F S SUB=$O(^PXD(811.9,RIEN,20,SUB)) Q:'SUB D
197 .;Ignore if finding is not a term
198 .S FIND=$P($G(^PXD(811.9,RIEN,20,SUB,0)),U) Q:FIND'["PXRMD(811.5"
199 .;Convert to term ien
200 .S FIND=$P(FIND,";")
201 .;Build sequence number
202 .S FSEQ=FSEQ+1,FSEQ=$$RJ^XLFSTR(FSEQ,3,0)
203 .;Evaluation counts
204 .S REM(RCNT,FIND,GSEQ,FSEQ)=""
205 .S REM(RCNT,FIND,GSEQ)=GTYP
206 .;Update Workfile
207 .S ^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)=FIND
208 Q
209 ;
210URCNT(PXRMSTRT,PXRMSTOP,TFIEVAL) ;
211 ;Handle counting all valid occurrences for the finding items.
212 ;Includes historical entries that were entered within the reporting
213 ;period, cut the encounter date if it is outside the reporting period.
214 N CNT,DATEENT,FDATE,FILE,FNUM,FOCCNUM,HIST,NODE,SCAT,VIEN
215 S CNT=0,FNUM=0
216 F S FNUM=$O(TFIEVAL(FNUM)) Q:FNUM'>0 D
217 .S FILE=$G(TFIEVAL(FNUM,"FILE NUMBER"))
218 .S HIST=$S(FILE=9000010.18:1,FILE=9000010.13:1,FILE=9000010.23:1,FILE=9000010.16:1,FILE=9000010.07:1,FILE=9000010.12:1,FILE=9000010.15:1,1:0)
219 .S FOCCNUM=0 F S FOCCNUM=$O(TFIEVAL(FNUM,FOCCNUM)) Q:FOCCNUM'>0 D
220 ..S FDATE=$P(TFIEVAL(FNUM,FOCCNUM,"DATE"),".") Q:FDATE'>0
221 ..I HIST=0,FDATE=PXRMSTRT!(FDATE>PXRMSTRT) S CNT=CNT+1
222 ..I HIST=1 D
223 ...S VIEN=TFIEVAL(FNUM,FOCCNUM,"VISIT") Q:VIEN'>0
224 ...S NODE=$G(^AUPNVSIT(VIEN,0))
225 ...S SCAT=$P(NODE,U,7),DATEENT=$P($P(NODE,U,2),".")
226 ...I FDATE=PXRMSTRT!(FDATE>PXRMSTRT),SCAT'="E" S CNT=CNT+1 Q
227 ...I SCAT="E",(DATEENT=PXRMSTRT!(DATEENT>PXRMSTRT))&(DATEENT=PXRMSTOP!(DATEENT<PXRMSTOP)) S CNT=CNT+1
228 D UPD(CNT)
229 Q
230 ;
231UPD(CNT) ;Update totals
232 S DATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ))
233 ;Total count
234 S $P(DATA,U,2)=$P(DATA,U,2)+CNT
235 ;Applicable count
236 S $P(DATA,U,3)=$P(DATA,U,3)+(APPL*CNT)
237 ;Not applicable count
238 I 'APPL,'DUE S $P(DATA,U,4)=$P(DATA,U,4)+CNT
239 ;Due count
240 S $P(DATA,U,5)=$P(DATA,U,5)+(DUE*CNT)
241 ;Not due count
242 I APPL,'DUE S $P(DATA,U,6)=$P(DATA,U,6)+CNT
243 ;Update current count
244 S ^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ)=DATA
245 ;AGP REMOVE UNTIL A DECISION CAN BE MADE
246 ;I CNT=1,APPL=1 S ^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ,DFN)=DFN
247 Q
248 ;
Note: See TracBrowser for help on using the repository browser.