source: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMGECP.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 7.6 KB
Line 
1PXRMGECP ;SLC/JVS -GEC-Prompts ;7/14/05 10:43
2 ;;2.0;CLINICAL REMINDERS;**2,4**;Feb 04, 2005;Build 21
3 Q
4EN ;Entry Point
5 ;^DISV( = DBIA #510
6 N POP,DIROUT,DIRUT,DUOUT,LOCNP,MENU,PROV,Y
7 N DETAIL,FORMAT,INC
8 ;D INIT^PXRMGECW
9 S X="IOUON;IOUOFF;IORVOFF;IORVON" D ENDR^%ZISS
10 W IOUOFF,IORVOFF
11 W @IOF
12 W !,"All Reports will print on 80 Columns"
13 K DIR
14 S DIR("A")="Select Option or ^ to Exit"
15 I $D(^DISV(DUZ,"PXRMGEC","EN")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","EN"))
16 S DIR(0)="S^1:Category;2:Patient;3:Provider by Patient;4:Referral Date;5:Location;6:Referral Count Totals;7:Category-Referred Service;8:Summary (Score);9:'Home Help' Eligibility;10:Restore or Merge Referrals"
17 D ^DIR
18 K DIR("A"),DIR("B"),DIR(0)
19 Q:$D(DIRUT)!($D(DIROUT))
20 ;DBIA #510
21 S MENU=Y,^DISV(DUZ,"PXRMGEC","EN")=MENU
22 I MENU=1 D CAT
23 I MENU=2 D PATIENT
24 I MENU=3 D PRO
25 I MENU=4 D DR
26 I MENU=5 D LOCDIR^PXRMGECO
27 I MENU=6 D CT^PXRMGECO
28 I MENU=7 D RS^PXRMGECO
29 I MENU=8 D SUM^PXRMGECO
30 I MENU=9 D HOME^PXRMG2R2
31 I MENU=10 D EN^PXRMGECJ
32 D KILL^%ZISS
33 Q
34 ;==========================================================
35 ;
36CAT ;#1 Start List and array of GEC Categories
37 ;
38 N CAT,CATNA,CNT,STAY,NUM,CATIEN,CATARY,BDT,EDT,CATDA,SYN
39 W @IOF
40 W "GEC Referral Categories"
41 S CNT=0
42 S SYN="" F S SYN=$O(^AUTTHF("D",SYN)) Q:SYN="" D
43 .I $E(SYN,1,3)="GEC",$E(SYN,5)="C" D
44 ..S CAT=0 F S CAT=$O(^AUTTHF("D",SYN,CAT)) Q:CAT="" D
45 ...Q:$P($G(^AUTTHF(CAT,0)),"^",11)=1
46 ...S CATNA=$P($G(^AUTTHF(CAT,0)),"^",1)
47 ...S CATNA=$P(CATNA," ",3,7)
48 ...S CATARY(CATNA,CAT)=""
49 S CATNA="" F S CATNA=$O(CATARY(CATNA)) Q:CATNA="" D
50 .S CAT=$O(CATARY(CATNA,0))
51 .S CNT=CNT+1
52 .S CATDA(CNT,CAT)=""
53 .W:CNT#2=1 !,CNT,?4,CATNA
54 .W:CNT#2=0 ?35,CNT,?39,CATNA
55SC ;=====Select Categories
56 W !
57 S DIR("A",1)="Select Categories from the list above using"
58 S DIR("A",2)="Commas and/or Dashes for ranges of numbers."
59 S DIR("A")="Select Categories or ^ to exit"
60 I $D(^DISV(DUZ,"PXRMGEC","SC")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","SC"))
61 S DIR(0)="L^1:"_CNT
62 D ^DIR
63 K DIR("A"),DIR("B"),DIR(0)
64 Q:$D(DIROUT)
65 Q:$D(DIRUT)
66 S ^DISV(DUZ,"PXRMGEC","SC")=X
67 N LEN,IME,MEY
68 S LEN=$L(Y,",")
69 S MEY=0 F IME=1:1:LEN-1 S MEY=$P(Y,",",IME) D
70 .S CATMEY(MEY)=""
71 S STAY=0 F S STAY=$O(CATDA(STAY)) Q:STAY="" D
72 .I '$D(CATMEY(STAY)) K CATDA(STAY)
73 S NUM=0 F S NUM=$O(CATDA(NUM)) Q:NUM="" D
74 .S CATIEN($O(CATDA(NUM,0)))=""
75 K CATDA,CATMEY
76CATBDT D BDT Q:$D(DIROUT)!$D(DIRUT)
77CATEDT D EDT Q:$D(DIROUT) I $D(DIRUT) K DIRUT G CATBDT
78CATPAT D PAT Q:$D(DIROUT) I $D(DIRUT) K DIRUT G CATEDT
79CATFOR D FOR Q:$D(DIROUT) I $D(DIRUT) K DIRUT G CATPAT
80CATIOO D CATIO Q:$D(DIROUT)
81 Q
82BDT ;=====Select Beginning Date
83 ;--Return BDT as DATE
84 W !
85 S DIR("A",1)="Select a Beginning Historical Date."
86 S DIR("A")="BEGINNING date or ^ to exit"
87 I $D(^DISV(DUZ,"PXRMGEC","BDT")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","BDT"))
88 S DIR(0)="D^2880101:"_DT_":EX"
89 D ^DIR
90 K DIR("A"),DIR("B"),DIR(0)
91 Q:$D(DIROUT)!($D(DIRUT))
92 S ^DISV(DUZ,"PXRMGEC","BDT")=X
93 S BDT=Y
94 Q
95 ;
96EDT ;=====Select Ending Date
97 ;--Return EDT as DATE
98 W !
99 S DIR("A",1)="Select Ending Date."
100 S DIR("A")="ENDING date or ^ to exit"
101 I $D(^DISV(DUZ,"PXRMGEC","EDT")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","EDT"))
102 S DIR(0)="D^"_BDT_":"_DT_":EX"
103 D ^DIR
104 K DIR("A"),DIR("B"),DIR(0)
105 Q:$D(DIROUT)!($D(DIRUT))
106 S ^DISV(DUZ,"PXRMGEC","EDT")=X
107 S EDT=Y
108 Q
109 ;=====Select Patients
110PAT ;--Return DFNONLY as Patient DFN
111 W @IOF
112 K DIR,DIR("A")
113 K DFNONLY
114 S DIR("A")="Select Patients or ^ to exit"
115 I $D(^DISV(DUZ,"PXRMGEC","PAT")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","PAT"))
116 S DIR(0)="S^A:All Patients;M:Multiple Patients"
117 D ^DIR
118 K DIR("A"),DIR("B"),DIR(0)
119 Q:$D(DIROUT)!($D(DIRUT))
120 S ^DISV(DUZ,"PXRMGEC","PAT")=X
121 I Y="A" S DFNONLY=0
122 I Y="M" D PATLU
123 Q
124 ;
125FOR ;=====Formatted or Delimited Report
126 ;--Return FORMAT equal to Y
127 S DIR("A")="Select Report Format or ^ to exit"
128 I $D(^DISV(DUZ,"PXRMGEC","FOR")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","FOR"))
129 S DIR(0)="S^F:Formatted;D:Delimited"
130 D ^DIR
131 K DIR("A"),DIR("B"),DIR(0)
132 Q:$D(DIRUT)!($D(DIROUT))
133 S ^DISV(DUZ,"PXRMGEC","FOR")=X
134 S FORMAT=Y
135 Q
136 ;
137CATIO ;=====Select IO device
138 Q:'$D(BDT)!('$D(EDT))!('$D(DFNONLY))!'$D(FORMAT)
139 N %ZIS
140 S %ZIS="QM" D ^%ZIS
141 I POP Q
142 I $D(IO("Q")) D
143 .S ZTRTN="HFCD^PXRMGECQ"
144 .S ZTDESC="Gec Report Printing"
145 .S ZTSAVE("*")=""
146 .D ^%ZTLOAD K IO("Q") Q
147 ;=====Call Report
148 E D HFCD^PXRMGECR
149 D HOME^%ZIS
150 D ^%ZISC
151 S:'$D(DIRUT)&('$D(DUOUT))&('$D(DIROUT)) DIR(0)="E" D ^DIR K DIR(0),Y
152 Q
153 ;
154 ;================SUB ROUTINES==============================
155PROV ;Select Provider
156 W @IOF
157 N DIC,Y
158 S PROV=0
159 K PROVARY
160 S DIC="^VA(200,"
161 S DIC(0)="QAMEZ"
162PROVR D ^DIC
163 I Y=-1 K DIC,DIC(0),Y Q
164 I +Y>0 S PROVARY(+Y)=""
165 S PROV=+Y
166 G PROVR
167 Q
168 ;
169PATLU ;Patient Look up
170 N Y,DIC
171 S DFNONLY=0
172 K DFNARY
173 S DIC="^DPT("
174 S DIC(0)="QAMEZ"
175PATLUR D ^DIC
176 I Y=-1 K DIC,DIC(0),Y Q
177 I +Y>0 S DFNONLY=+Y,DFNARY(+Y)=""
178 G PATLUR
179 Q
180 ;
181 ;================================================================
182PRO ; #3 Start of Provider by Patient Report
183 N BDT,EDT,DFNONLY
184 W @IOF
185 K DIR
186 I $D(^DISV(DUZ,"PXRMGEC","PRO")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","PRO"))
187 S DIR(0)="S^A:All Providers;M:Multiple Providers"
188 D ^DIR
189 K DIR("A"),DIR("B"),DIR(0)
190 Q:$D(DIRUT)!($D(DUOUT))
191 Q:$D(DIROUT)
192 S ^DISV(DUZ,"PXRMGEC","PRO")=X
193 I Y="A" S PROV=0
194 I Y="M" D PROV Q:'$D(PROVARY)
195 Q:$D(DIRUT)!($D(DIROUT))
196PROBDT D BDT Q:$D(DIRUT)!($D(DIRUT))
197PROEDT D EDT Q:$D(DIROUT) I $D(DIRUT) K DIRUT G PROBDT
198PROFOR D FOR Q:$D(DIROUT) I $D(DIRUT) K DIRUT G PROEDT
199PROIOO D PROIO Q:$D(DIROUT)
200 Q
201 ;
202PROIO ;=====Select IO device
203 N %ZIS
204 S %ZIS="QM" D ^%ZIS
205 I POP Q
206 I $D(IO("Q")) D
207 .S ZTRTN="DFN2^PXRMGECQ"
208 .S ZTDESC="GEC PROVIDER REPORT"
209 .S ZTSAVE("*")=""
210 .D ^%ZTLOAD K IO("Q") Q
211 ;=====Call Report
212 E D DFN2^PXRMGECS
213 D HOME^%ZIS
214 D ^%ZISC
215 S:'$D(DIRUT)&('$D(DUOUT))&('$D(DIROUT)) DIR(0)="E" D ^DIR K DIR(0),Y
216 Q
217 ;=================================================================
218DR ; #4 Referral Date
219 ;
220DRPAT D PAT Q:$D(DIROUT)!($D(DIRUT))
221DRBDT D BDT Q:$D(DIROUT) I $D(DIRUT) K DIRUT G DRPAT
222DREDT D EDT Q:$D(DIROUT) I $D(DIRUT) K DIRUT G DRBDT
223DRALL D ALL Q:$D(DIROUT) I $D(DIRUT) K DIRUT G DREDT
224DRFOR D FOR Q:$D(DIROUT) I $D(DIRUT) K DIRUT G DRALL
225DRIOO D DRIO Q:$D(DIROUT)
226 Q
227 ;
228ALL ;=====Select All Referrals or
229 ;--Return INC equal to Y
230 I $D(^DISV(DUZ,"PXRMGEC","ALL")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","ALL"))
231 S DIR(0)="S^I:Incomplete Referrals Only;C:Complete Referrals Only;B:Both Complete and Incomplete"
232 D ^DIR
233 K DIR("A"),DIR("B"),DIR(0)
234 Q:$D(DIRUT)!($D(DUOUT))
235 S ^DISV(DUZ,"PXRMGEC","ALL")=X
236 I Y="I" S INC=0
237 I Y="C" S INC=1
238 I Y="B" S INC=2
239 Q
240 ;
241DRIO ;=====Select IO device
242 N %ZIS
243 S %ZIS="QM" D ^%ZIS
244 I POP Q
245 I $D(IO("Q")) D
246 .S ZTRTN="DR^PXRMGECQ"
247 .S ZTDESC="GEC REPORT"
248 .S ZTSAVE("*")=""
249 .D ^%ZTLOAD K IO("Q") Q
250 ;=====Call Report
251 E D DR^PXRMGECR
252 D HOME^%ZIS
253 D ^%ZISC
254 S:'$D(DIRUT)&('$D(DUOUT))&('$D(DIROUT)) DIR(0)="E" D ^DIR K DIR(0),Y
255 Q
256 ;
257 ;==================================================================
258PATIENT ; #2 Start of Patient Report
259 ;
260PATPAT D PAT Q:$D(DIROUT)!($D(DIRUT))
261PATBDT D BDT Q:$D(DIROUT) I $D(DIRUT) K DIRUT G PATPAT
262PATEDT D EDT Q:$D(DIROUT) I $D(DIRUT) K DIRUT G PATBDT
263PATFOR D FOR Q:$D(DIROUT) I $D(DIRUT) K DIRUT G PATEDT
264PATIOO D PATIO Q:$D(DIROUT)
265 Q
266 ;
267PATIO ;=====Select IO device for Patient Report
268 N %ZIS
269 S %ZIS="QM" D ^%ZIS
270 I POP Q
271 I $D(IO("Q")) D
272 .S ZTRTN="HS1^PXRMGECQ"
273 .S ZTDESC="GEC PATIENT REPORT"
274 .S ZTSAVE("*")=""
275 .S ZTSAVE("FORMAT")=""
276 .S ZTSAVE("EDT")=""
277 .S ZTSAVE("BDT")=""
278 .S ZTSAVE("DFNONLY")=""
279 .I $D(DFNARY) S ZTSAVE("DFNARY(")=""
280 .D ^%ZTLOAD K IO("Q") Q
281 ;=====Call Report
282 E D HS1^PXRMGECR
283 D HOME^%ZIS
284 D ^%ZISC
285 S:'$D(DIRUT)&('$D(DUOUT))&('$D(DIROUT)) DIR(0)="E" D ^DIR K DIR(0),Y
286 Q
287 ;=========================================================
Note: See TracBrowser for help on using the repository browser.