source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETX.m@ 1553

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

initial load of FOIAVistA 6/30/08 version

File size: 7.7 KB
Line 
1PXRMETX ; SLC/PJH - Run Extract for QUERI ;07/10/2007
2 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
3 ;
4AUTO(ID,PURGE) ;Called from option scheduling (#19.2)
5 N IEN,LIST,LUVALUE,MODE,NEXT
6 S LUVALUE(1)=ID
7 D FIND^DIC(810.2,"","","U",.LUVALUE,"","","","","LIST")
8 ;Get ien of extract parameter
9 S IEN=$P(LIST("DILIST",2,1),U,1) Q:'IEN
10 ;Get next extract period
11 S NEXT=$P($G(^PXRM(810.2,IEN,0)),U,6) Q:NEXT=""
12 ;Node is Extract and Transmit
13 S MODE=$S($P($G(^PXRM(810.2,IEN,100)),U)="N":0,1:1)
14 ;Run extract
15 D RUN^PXRMETX(IEN,NEXT,MODE,PURGE)
16 ;Purge Extract Summary
17 D PRGES^PXRMETXU
18 ;Purge Patient Lists
19 D PRGPL^PXRMETXU
20 Q
21 ;
22GETNAME(NAME,CLASS) ;Get the extract name.
23 I '$D(^PXRMXT(810.3,"B",NAME)) Q NAME
24 N CNT,NEW
25 S (CNT,NEW)=0
26 ;If name exists concatenate count
27 F D Q:NEW
28 .I '$D(^PXRMXT(810.3,"B",NAME)) S NEW=1 Q
29 .S CNT=CNT+1,NAME=$P(NAME,"/")_"/"_$$RJ^XLFSTR(CNT,2,0)
30 Q NAME
31 ;
32IHD ;Monthly IHD Extract, called from option PXRM EXTRACT VA-IHD QUERI.
33 D AUTO("VA-IHD QUERI","Y")
34 Q
35 ;
36MAIL(NAME,NEXT,MODE) ;Completion mail message
37 N FREQ,TEXT
38 S FREQ="year"
39 I $E(NEXT)="M" S FREQ="month"
40 I $E(NEXT)="Q" S FREQ="quarter"
41 ;
42 I MODE=0 S TEXT="Extract and Transmission"
43 I MODE=1 S TEXT="Extract (No Transmission)"
44 I MODE=2 S TEXT="Manual Extract and Transmission"
45 I MODE=3 S TEXT="Manual Extract (No Transmission)"
46 ;
47 S TEXT=NAME_" "_TEXT_" completed for "_FREQ_" "_NEXT
48 D MES^PXRMEUT(TEXT)
49 Q
50 ;
51MH ;Monthly MH Extract, called from option PXRM EXTRACT VA-MH QUERI.
52 D AUTO("VA-MH QUERI","Y")
53 Q
54 ;
55RUN(IEN,NEXT,MODE,PURGE) ;Process extract parameter
56 ; IEN is ien of Extract Parameter
57 ; NEXT is period to extract
58 ; MODE = 0 is extract and transmission
59 ; MODE = 1 is extract only
60 ; MODE = 2 is manual extract and transmission (doesn't update 810.2)
61 ; MODE = 3 is manual extract only (doesn't update 810.2)
62 ;
63 N CLASS,FDA,FDAIEN,MSG
64 N PXRMIDOD,PXRMLIST,PXRMNODE,PXRMRULE,PXRMSTRT,PXRMXIEN,PATCREAT,XNAME
65 N ITER
66 ;Initialise
67 K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J)
68 ;Workfile node for ^TMP
69 S PXRMNODE="PXRMRULE"
70 ;Get details from parameter file
71 N DATA,INDP,INTP,LIST,NAME,PARTYPE,PERIOD,SNAME,TEXT,YEAR
72 ;Get class from extract parameter
73 S CLASS=$P($G(^PXRM(810.2,IEN,100)),U)
74 ;Otherwise default to local
75 I $G(CLASS)="" S CLASS="L"
76 ;
77 S DATA=$G(^PXRM(810.2,IEN,0))
78 ;Determine Extract Name and period
79 S NAME=$P(DATA,U),PARTYPE=$P(DATA,U,2)
80 S YEAR=$P(NEXT,"/",2),PERIOD=$P(NEXT,"/")
81 ;Calculate report period start and end dates
82 D CALC^PXRMEUT(NEXT,.PXRMSTRT,.PXRMSTOP)
83 ;Determine output name for patient list and extract summary
84 S XNAME=NAME_" "_YEAR_" "_PERIOD
85 S NAME=$$GETNAME(XNAME)
86 S ITER=$P(NAME,"/",2)
87 ;Process (single) Denominator rule into patient list
88 N SEQ,SUB
89 S SEQ=""
90 F S SEQ=$O(^PXRM(810.2,IEN,10,"B",SEQ)) Q:'SEQ D
91 .S SUB=$O(^PXRM(810.2,IEN,10,"B",SEQ,"")) Q:'SUB
92 .S DATA=$G(^PXRM(810.2,IEN,10,SUB,0)) Q:DATA=""
93 .S PXRMRULE=$P(DATA,U,2) Q:'PXRMRULE
94 .S LIST=$P(DATA,U,3) Q:LIST=""
95 .I LIST["yyyy" S LIST=$P(LIST,"yyyy")_YEAR_$P(LIST,"yyyy",2)
96 .I LIST["nn" S LIST=$P(LIST,"nn")_$E(PERIOD,2,10)_$P(LIST,"nn",2)
97 .S INDP=+$P(DATA,U,4)
98 .S INTP=+$P(DATA,U,5)
99 .;Create new patient list
100 .I ITER'="" S LIST=LIST_"/"_ITER
101 .S PATCREAT="Y",PXRMLIST=$$CRLST^PXRMRUL1(LIST,CLASS) Q:'PXRMLIST
102 .;
103 .D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,YEAR,PERIOD,INDP,INTP,ITER)
104 .;Clear ^TMP lists created for rule
105 .D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
106 .;Process reminders and finding rules
107 .;If include deceased patients is true then set the flag so reminders
108 .;will be evaluated for deceased patients.
109 .S PXRMIDOD=$S(INDP:1,1:0)
110 .D REM^PXRMETXR(SUB,PXRMLIST,PXRMSTRT,PXRMSTOP,PARTYPE)
111 ;
112 ;Get the name
113 ;S NAME=$$GETNAME(XNAME)
114 ;Create extract summary entry
115 S FDA(810.3,"+1,",.01)=NAME
116 S FDA(810.3,"+1,",.02)=PXRMSTRT
117 S FDA(810.3,"+1,",.03)=PXRMSTOP
118 S FDA(810.3,"+1,",.06)=$$NOW^XLFDT
119 S FDA(810.3,"+1,",1)=IEN
120 S FDA(810.3,"+1,",2)=PARTYPE
121 S FDA(810.3,"+1,",3)=$E(PERIOD,2,99)
122 S FDA(810.3,"+1,",4)=YEAR
123 S FDA(810.3,"+1,",5)=$S(MODE<2:"A",1:"M")
124 S FDA(810.3,"+1,",7)=$E(PERIOD)
125 I PURGE="Y" S FDA(810.3,"+1,",50)=1
126 S FDA(810.3,"+1,",100)=CLASS
127 D UPDATE^DIE("","FDA","FDAIEN","MSG")
128 I $D(MSG) D AWRITE^PXRMUTIL("MSG") G EXIT
129 ;
130 ;Update extract summary from ^TMP
131 D UPDEX(FDAIEN(1))
132 ;
133 ;Transmit results
134 I (MODE=0)!(MODE=2) D TRANS(FDAIEN(1))
135 ;
136 ;Update extract parameters
137 I MODE<2 D UPDPAR
138 ;
139 ;Mail message that extract completed
140 D MAIL(NAME,NEXT,MODE)
141 ;
142EXIT ;Clear workfile
143 K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J)
144 Q
145 ;
146TRANS(PXRMXIEN) ;Transmit HL7 messages
147 N HL7ID,NAME,NEXT
148 S HL7ID=""
149 D HL7^PXRM7API(PXRMXIEN,1,.HL7ID)
150 H 2
151 ;Lock extract summary
152 D LOCK(PXRMXIEN) Q:$D(DUOUT)
153 ;Update run information
154 S NAME=$P($G(^PXRMXT(810.3,PXRMXIEN,0)),U)
155 S NEXT=$P($G(^PXRMXT(810.3,PXRMXIEN,4)),U,3)
156 S FDA(810.3,"?1,",.01)=NAME
157 S FDA(810.36,"?+2,?1,",.01)=HL7ID
158 S FDA(810.36,"?+2,?1,",.02)=$$NOW^XLFDT
159 D UPDATE^DIE("","FDA","","MSG")
160 ;Unlock extract summary
161 D UNLOCK(PXRMXIEN)
162 Q
163 ;
164UPDEX(IEN) ;Update extract summary
165 N DUOUT
166 ;Lock extract summary
167 D LOCK(IEN) Q:$D(DUOUT)
168 ;
169 ;Update totals section
170 N APPL,CNT,DFN,DUE,DATA,ETYP,EVAL
171 N FAPPL,FCNT,FDATA,FDUE,FEVAL,FGNAM,FGSTA,FIND,FNAPPL,FNDUE,FSEQ
172 N GDATA,GSEQ,INST,NAPPL,NDUE,PCNT,PXRMLIST,RCNT,RIEN,RSEQ,SEQ,TEMP
173 S SEQ="",CNT=1,RSEQ=0
174 F S SEQ=$O(^TMP("PXRMETX",$J,SEQ)) Q:SEQ="" D
175 .S INST=0
176 .F S INST=$O(^TMP("PXRMETX",$J,SEQ,INST)) Q:'INST D
177 ..S RCNT=""
178 ..F S RCNT=$O(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) Q:RCNT="" D
179 ...S DATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) Q:'DATA
180 ...S RIEN=$P(DATA,U,1),EVAL=$P(DATA,U,2),APPL=$P(DATA,U,3)
181 ...S NAPPL=$P(DATA,U,4),DUE=$P(DATA,U,5),NDUE=$P(DATA,U,6)
182 ...S PXRMLIST=$P(DATA,U,7)
183 ...S CNT=CNT+1,RSEQ=RSEQ+1
184 ...S TEMP=$$RJ^XLFSTR(RSEQ,3,0)_U_RIEN_U_INST_U_PXRMLIST_U_EVAL_U_APPL_U_NAPPL_U_DUE_U_NDUE
185 ...S ^PXRMXT(810.3,IEN,3,RSEQ,0)=TEMP
186 ...S ^PXRMXT(810.3,IEN,3,"B",$P(TEMP,U,1),RSEQ)=""
187 ...;For each count type
188 ...S GSEQ="",FCNT=0
189 ...F S GSEQ=$O(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ)) Q:GSEQ="" D
190 ....S GDATA=$G(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ))
191 ....S FGNAM=$P(GDATA,U),ETYP=$P(GDATA,U,2),FGSTA=$P(GDATA,U,3)
192 ....;For each term
193 ....S FSEQ=0
194 ....F S FSEQ=$O(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)) Q:FSEQ="" D
195 .....;Get the term ien
196 .....S FIND=$P($G(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)),U),FCNT=FCNT+1
197 .....;Update finding totals
198 .....S FDATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ))
199 .....S FEVAL=$P(FDATA,U,2),FAPPL=$P(FDATA,U,3),FNAPPL=$P(FDATA,U,4)
200 .....S FDUE=$P(FDATA,U,5),FNDUE=$P(FDATA,U,6)
201 .....S TEMP=FSEQ_U_$P(FIND,";")_U_ETYP_U_FEVAL_U_FAPPL_U_FNAPPL_U_FDUE_U_FNDUE_U_FGNAM_U_FGSTA
202 .....S ^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,0)=TEMP
203 .....;
204 .....;AGP REMOVE UNTIL A DECISION CAN BE MADE
205 .....;S DFN=0,PCNT=0
206 .....;F S DFN=$O(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ,DFN)) Q:DFN'>0 D
207 .....;.S PCNT=PCNT+1,^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,1,PCNT,0)=DFN
208 .....;I PCNT>0 S ^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,1,0)="^810.3316PA"_U_PCNT_U_PCNT
209 ....I FCNT>0 S ^PXRMXT(810.3,IEN,3,RSEQ,1,0)="^810.331I"_U_FCNT_U_FCNT
210 .I RSEQ>0 S ^PXRMXT(810.3,IEN,3,0)="^810.33I"_U_RSEQ_U_RSEQ
211 ;Unlock extract summary
212 D UNLOCK(IEN)
213 Q
214 ;
215 ;File locking
216LOCK(PXRMXIEN) L +^PXRMXT(810.3,PXRMXIEN):0
217 I '$T W !!?5,"Another user is using this extract summary" S DUOUT=1
218 Q
219 ;
220UNLOCK(PXRMXIEN) L -^PXRMXT(810.3,PXRMXIEN) Q
221 ;
222UPDPAR ;Update parameters when run complete
223 N DATA,LAST,NEXT,PERIOD,TYPE,YEAR
224 S DATA=$G(^PXRM(810.2,IEN,0)),NEXT=$P(DATA,U,6),TYPE=$P(DATA,U,3)
225 ;Last run updated
226 S LAST=NEXT
227 ;Calculate next run
228 I TYPE="Y" S NEXT=NEXT+1
229 I "QM"[TYPE D
230 .N NUM
231 .S PERIOD=$P(NEXT,"/",1),YEAR=$P(NEXT,"/",2)
232 .S NUM=$P(PERIOD,TYPE,2)+1
233 .I TYPE="Q",NUM>4 S NUM=1,YEAR=YEAR+1
234 .I TYPE="M",NUM>12 S NUM=1,YEAR=YEAR+1
235 .S NEXT=TYPE_NUM_"/"_YEAR
236 ;Update last and next run fields
237 S $P(^PXRM(810.2,IEN,0),U,4,6)=LAST_U_$$NOW^XLFDT_U_NEXT
238 Q
239 ;
Note: See TracBrowser for help on using the repository browser.