source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETX.m@ 1361

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

revised back to 6/30/08 version
File size: 8.8 KB
Line 
1PXRMETX ; SLC/PJH - Run Extract for QUERI ;1/22/07 21:25
2 ;;2.0;CLINICAL REMINDERS;**4,7**;Feb 04, 2005;Build 14
3 ; Modified from FOIA VISTA,
4 ; Copyright (C) 2007 WorldVistA
5 ;
6 ; This program is free software; you can redistribute it and/or modify
7 ; it under the terms of the GNU General Public License as published by
8 ; the Free Software Foundation; either version 2 of the License, or
9 ; (at your option) any later version.
10 ;
11 ; This program is distributed in the hope that it will be useful,
12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ; GNU General Public License for more details.
15 ;
16 ; You should have received a copy of the GNU General Public License
17 ; along with this program; if not, write to the Free Software
18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
19 ;
20AUTO(ID,PURGE) ;Called from option scheduling (#19.2)
21 N IEN,LIST,LUVALUE,MODE,NEXT
22 S LUVALUE(1)=ID
23 D FIND^DIC(810.2,"","","U",.LUVALUE,"","","","","LIST")
24 ;Get ien of extract parameter
25 S IEN=$P(LIST("DILIST",2,1),U,1) Q:'IEN
26 ;Get next extract period
27 S NEXT=$P($G(^PXRM(810.2,IEN,0)),U,6) Q:NEXT=""
28 ;Node is Extract and Transmit
29 S MODE=$S($P($G(^PXRM(810.2,IEN,100)),U)="N":0,1:1)
30 ;Run extract
31 D RUN^PXRMETX(IEN,NEXT,MODE,PURGE)
32 ;Purge Extract Summary
33 D PRGES^PXRMETXU
34 ;Purge Patient Lists
35 D PRGPL^PXRMETXU
36 ;Call the DOQ-IT HL7 generating routine
37 ;D EXTRACT^VEPER7EX(VDATA(810.2,IEN_",",3,"I"),VDATA(810.2,IEN_",",5,"I"))
38 Q
39 ;
40GETNAME(NAME,CLASS) ;Get the extract name.
41 I '$D(^PXRMXT(810.3,"B",NAME)) Q NAME
42 N CNT,NEW
43 S (CNT,NEW)=0
44 ;If name exists concatenate count
45 F D Q:NEW
46 .I '$D(^PXRMXT(810.3,"B",NAME)) S NEW=1 Q
47 .S CNT=CNT+1,NAME=$P(NAME,"/")_"/"_$$RJ^XLFSTR(CNT,2,0)
48 Q NAME
49 ;
50IHD ;Monthly IHD Extract, called from option PXRM EXTRACT VA-IHD QUERI.
51 D AUTO("VA-IHD QUERI","Y")
52 Q
53 ;
54MAIL(NAME,NEXT,MODE) ;Completion mail message
55 N FREQ,TEXT
56 S FREQ="year"
57 I $E(NEXT)="M" S FREQ="month"
58 I $E(NEXT)="Q" S FREQ="quarter"
59 ;
60 I MODE=0 S TEXT="Extract and Transmission"
61 I MODE=1 S TEXT="Extract (No Transmission)"
62 I MODE=2 S TEXT="Manual Extract and Transmission"
63 I MODE=3 S TEXT="Manual Extract (No Transmission)"
64 ;
65 S TEXT=NAME_" "_TEXT_" completed for "_FREQ_" "_NEXT
66 D MES^PXRMEUT(TEXT)
67 Q
68 ;
69MH ;Monthly MH Extract, called from option PXRM EXTRACT VA-MH QUERI.
70 D AUTO("VA-MH QUERI","Y")
71 Q
72 ;
73ACAD ;Auto CAD entry point
74 D AUTO("VOE DOQ-IT CAD EXTRACTION")
75 Q
76 ;
77ADM ;Auto DM entry point
78 D AUTO("VOE DOQ-IT DM EXTRACTION")
79 Q
80 ;
81AHF ;Auto HF entry point
82 D AUTO("VOE DOQ-IT HF EXTRACTION")
83 Q
84 ;
85AHTN ;Auto HTN entry point
86 D AUTO("VOE DOQ-IT HTN EXTRACTION")
87 Q
88 ;
89APC ;Auto PC entry point
90 D AUTO("VOE DOQ-IT PC EXTRACTION")
91 Q
92 ;
93RUN(IEN,NEXT,MODE,PURGE) ;Process extract parameter
94 ; IEN is ien of Extract Parameter
95 ; NEXT is period to extract
96 ; MODE = 0 is extract and transmission
97 ; MODE = 1 is extract only
98 ; MODE = 2 is manual extract and transmission (doesn't update 810.2)
99 ; MODE = 3 is manual extract only (doesn't update 810.2)
100 ;
101 N CLASS,FDA,FDAIEN,MSG
102 N PXRMLIST,PXRMNODE,PXRMRULE,PXRMSTRT,PXRMXIEN,PATCREAT,XNAME
103 ;Initialise
104 K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J)
105 ;Workfile node for ^TMP
106 S PXRMNODE="PXRMRULE"
107 ;Get details from parameter file
108 N DATA,INDP,INTP,LIST,NAME,PARTYPE,PERIOD,SNAME,TEXT,YEAR
109 ;Get class from extract parameter
110 S CLASS=$P($G(^PXRM(810.2,IEN,100)),U)
111 ;Otherwise default to local
112 I $G(CLASS)="" S CLASS="L"
113 ;
114 S DATA=$G(^PXRM(810.2,IEN,0))
115 ;Determine Extract Name and period
116 S NAME=$P(DATA,U),PARTYPE=$P(DATA,U,2)
117 S YEAR=$P(NEXT,"/",2),PERIOD=$P(NEXT,"/")
118 ;Calculate report period start and end dates
119 D CALC^PXRMEUT(NEXT,.PXRMSTRT,.PXRMSTOP)
120 ;Determine output name for patient list and extract summary
121 S XNAME=NAME_" "_YEAR_" "_PERIOD
122 ;Process (single) Denominator rule into patient list
123 N SEQ,SUB
124 S SEQ=""
125 F S SEQ=$O(^PXRM(810.2,IEN,10,"B",SEQ)) Q:'SEQ D
126 .S SUB=$O(^PXRM(810.2,IEN,10,"B",SEQ,"")) Q:'SUB
127 .S DATA=$G(^PXRM(810.2,IEN,10,SUB,0)) Q:DATA=""
128 .S PXRMRULE=$P(DATA,U,2) Q:'PXRMRULE
129 .S LIST=$P(DATA,U,3) Q:LIST=""
130 .I LIST["yyyy" S LIST=$P(LIST,"yyyy")_YEAR_$P(LIST,"yyyy",2)
131 .I LIST["nn" S LIST=$P(LIST,"nn")_$E(PERIOD,2,10)_$P(LIST,"nn",2)
132 .S INDP=+$P(DATA,U,4)
133 .S INTP=+$P(DATA,U,5)
134 .;Create new patient list
135 .S PATCREAT="Y",PXRMLIST=$$CRLST^PXRMRULE(LIST,CLASS) Q:'PXRMLIST
136 .;
137 .D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,YEAR,PERIOD,INDP,INTP)
138 .;Clear ^TMP lists created for rule
139 .D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
140 .;Process reminders and finding rules
141 .D REM^PXRMETXR(SUB,PXRMLIST,PXRMSTRT,PXRMSTOP,PARTYPE)
142 ;
143 ;Get the name
144 S NAME=$$GETNAME(XNAME)
145 ;Create extract summary entry
146 S FDA(810.3,"+1,",.01)=NAME
147 S FDA(810.3,"+1,",.02)=PXRMSTRT
148 S FDA(810.3,"+1,",.03)=PXRMSTOP
149 S FDA(810.3,"+1,",.06)=$$NOW^XLFDT
150 S FDA(810.3,"+1,",1)=IEN
151 S FDA(810.3,"+1,",2)=PARTYPE
152 S FDA(810.3,"+1,",3)=$E(PERIOD,2,99)
153 S FDA(810.3,"+1,",4)=YEAR
154 S FDA(810.3,"+1,",5)=$S(MODE<2:"A",1:"M")
155 S FDA(810.3,"+1,",7)=$E(PERIOD)
156 I PURGE="Y" S FDA(810.3,"+1,",50)=1
157 S FDA(810.3,"+1,",100)=CLASS
158 D UPDATE^DIE("","FDA","FDAIEN","MSG")
159 I $D(MSG) D AWRITE^PXRMUTIL("MSG") G EXIT
160 ;
161 ;Update extract summary from ^TMP
162 D UPDEX(FDAIEN(1))
163 ;
164 ;Transmit results
165 I (MODE=0)!(MODE=2) D TRANS(FDAIEN(1))
166 ;
167 I $$GET^XPAR("SYS","DOQ-IT")="YES" D EXTRACT^VEPER7EX(VDATA(810.2,IEN_",",3,"I"),VDATA(810.2,IEN_",",5,"I"),PXRMLIST)
168 ;
169 ;Update extract parameters
170 I MODE<2 D UPDPAR
171 ;
172 ;Mail message that extract completed
173 D MAIL(NAME,NEXT,MODE)
174 ;
175EXIT ;Clear workfile
176 K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J)
177 Q
178 ;
179TRANS(PXRMXIEN) ;Transmit HL7 messages
180 N HL7ID,NAME,NEXT
181 S HL7ID=""
182 D HL7^PXRM7API(PXRMXIEN,1,.HL7ID)
183 H 2
184 ;Lock extract summary
185 D LOCK(PXRMXIEN) Q:$D(DUOUT)
186 ;Update run information
187 S NAME=$P($G(^PXRMXT(810.3,PXRMXIEN,0)),U)
188 S NEXT=$P($G(^PXRMXT(810.3,PXRMXIEN,4)),U,3)
189 S FDA(810.3,"?1,",.01)=NAME
190 S FDA(810.36,"?+2,?1,",.01)=HL7ID
191 S FDA(810.36,"?+2,?1,",.02)=$$NOW^XLFDT
192 D UPDATE^DIE("","FDA","","MSG")
193 ;Unlock extract summary
194 D UNLOCK(PXRMXIEN)
195 Q
196 ;
197UPDEX(IEN) ;Update extract summary
198 N DUOUT
199 ;Lock extract summary
200 D LOCK(IEN) Q:$D(DUOUT)
201 ;
202 ;Update totals section
203 N APPL,CNT,DFN,DUE,DATA,ETYP,EVAL
204 N FAPPL,FCNT,FDATA,FDUE,FEVAL,FGNAM,FGSTA,FIND,FNAPPL,FNDUE,FSEQ
205 N GDATA,GSEQ,INST,NAPPL,NDUE,PCNT,PXRMLIST,RCNT,RIEN,RSEQ,SEQ,TEMP
206 S SEQ="",CNT=1,RSEQ=0
207 F S SEQ=$O(^TMP("PXRMETX",$J,SEQ)) Q:SEQ="" D
208 .S INST=0
209 .F S INST=$O(^TMP("PXRMETX",$J,SEQ,INST)) Q:'INST D
210 ..S RCNT=""
211 ..F S RCNT=$O(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) Q:RCNT="" D
212 ...S DATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) Q:'DATA
213 ...S RIEN=$P(DATA,U,1),EVAL=$P(DATA,U,2),APPL=$P(DATA,U,3)
214 ...S NAPPL=$P(DATA,U,4),DUE=$P(DATA,U,5),NDUE=$P(DATA,U,6)
215 ...S PXRMLIST=$P(DATA,U,7)
216 ...S CNT=CNT+1,RSEQ=RSEQ+1
217 ...S TEMP=$$RJ^XLFSTR(RSEQ,3,0)_U_RIEN_U_INST_U_PXRMLIST_U_EVAL_U_APPL_U_NAPPL_U_DUE_U_NDUE
218 ...S ^PXRMXT(810.3,IEN,3,RSEQ,0)=TEMP
219 ...S ^PXRMXT(810.3,IEN,3,"B",$P(TEMP,U,1),RSEQ)=""
220 ...;For each count type
221 ...S GSEQ="",FCNT=0
222 ...F S GSEQ=$O(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ)) Q:GSEQ="" D
223 ....S GDATA=$G(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ))
224 ....S FGNAM=$P(GDATA,U),ETYP=$P(GDATA,U,2),FGSTA=$P(GDATA,U,3)
225 ....;For each term
226 ....S FSEQ=0
227 ....F S FSEQ=$O(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)) Q:FSEQ="" D
228 .....;Get the term ien
229 .....S FIND=$P($G(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)),U),FCNT=FCNT+1
230 .....;Update finding totals
231 .....S FDATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ))
232 .....S FEVAL=$P(FDATA,U,2),FAPPL=$P(FDATA,U,3),FNAPPL=$P(FDATA,U,4)
233 .....S FDUE=$P(FDATA,U,5),FNDUE=$P(FDATA,U,6)
234 .....S TEMP=FSEQ_U_$P(FIND,";")_U_ETYP_U_FEVAL_U_FAPPL_U_FNAPPL_U_FDUE_U_FNDUE_U_FGNAM_U_FGSTA
235 .....S ^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,0)=TEMP
236 .....;
237 .....;AGP REMOVE UNTIL A DECISION CAN BE MADE
238 .....;S DFN=0,PCNT=0
239 .....;F S DFN=$O(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ,DFN)) Q:DFN'>0 D
240 .....;.S PCNT=PCNT+1,^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,1,PCNT,0)=DFN
241 .....;I PCNT>0 S ^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,1,0)="^810.3316PA"_U_PCNT_U_PCNT
242 ....I FCNT>0 S ^PXRMXT(810.3,IEN,3,RSEQ,1,0)="^810.331I"_U_FCNT_U_FCNT
243 .I RSEQ>0 S ^PXRMXT(810.3,IEN,3,0)="^810.33I"_U_RSEQ_U_RSEQ
244 ;Unlock extract summary
245 D UNLOCK(IEN)
246 Q
247 ;
248 ;File locking
249LOCK(PXRMXIEN) L +^PXRMXT(810.3,PXRMXIEN):0
250 I '$T W !!?5,"Another user is using this extract summary" S DUOUT=1
251 Q
252 ;
253UNLOCK(PXRMXIEN) L -^PXRMXT(810.3,PXRMXIEN) Q
254 ;
255UPDPAR ;Update parameters when run complete
256 N DATA,LAST,NEXT,PERIOD,TYPE,YEAR
257 S DATA=$G(^PXRM(810.2,IEN,0)),NEXT=$P(DATA,U,6),TYPE=$P(DATA,U,3)
258 ;Last run updated
259 S LAST=NEXT
260 ;Calculate next run
261 I TYPE="Y" S NEXT=NEXT+1
262 I "QM"[TYPE D
263 .N NUM
264 .S PERIOD=$P(NEXT,"/",1),YEAR=$P(NEXT,"/",2)
265 .S NUM=$P(PERIOD,TYPE,2)+1
266 .I TYPE="Q",NUM>4 S NUM=1,YEAR=YEAR+1
267 .I TYPE="M",NUM>12 S NUM=1,YEAR=YEAR+1
268 .S NEXT=TYPE_NUM_"/"_YEAR
269 ;Update last and next run fields
270 S $P(^PXRM(810.2,IEN,0),U,4,6)=LAST_U_$$NOW^XLFDT_U_NEXT
271 Q
272 ;
Note: See TracBrowser for help on using the repository browser.