source: FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXUCBOC.m@ 979

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

initial load of FOIAVistA 6/30/08 version

File size: 7.8 KB
Line 
1ECXUCBOC ;ALB/TJL-CBOC Activity Report ; 10/20/03 11:19am
2 ;;3.0;DSS EXTRACTS;**49**;July 1, 2003
3 ;
4EN ; entry point
5 N X,Y,DATE,PG,COUNT,ECRUN,ECXDESC,ECXSAVE,ECXTL,YYYYMM,ECXJOB
6 N ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG
7 S (QFLG,COUNT,PG)=0
8 ; get today's date
9 D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT
10 ;D BEGIN Q:QFLG
11 D SELECT Q:QFLG
12 S ECXDESC="CBOC Activity Report"
13 S ECXSAVE("EC*")=""
14 W !!,"This report requires 80-column format."
15 D EN^XUTMDEVQ("PROCESS^ECXUCBOC",ECXDESC,.ECXSAVE)
16 I POP W !!,"No device selected...exiting.",! Q
17 I IO'=IO(0) D ^%ZISC
18 D HOME^%ZIS
19 D AUDIT^ECXKILL
20 Q
21 ;
22BEGIN ; display report description
23 W @IOF
24 W !,"This report prints a listing of all Clinical (CLI) records"
25 W !,"that have a Community Based Outpatient Clinic (CBOC) status of"
26 W !,"Y (=Yes). Reports are grouped by Feeder Key, Division, and"
27 W !,"Clinic; detail lines include Patient Name, SSN, and Date of Visit."
28 W !,"Totals for unique SSNs and unique Dates of Visit will be displayed"
29 W !,"at the Clinic, Division, Feeder Key, and Report levels."
30 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
31 W:$Y!($E(IOST)="C") @IOF,!!
32 Q
33 ;
34SELECT ; user inputs for start date
35 N OUT,DONE,LIST,IEN,ECXFROM,ECXEND,ECXRUN,ECXCNT,ECXDIV,LN
36 W @IOF
37 S (PG,QFLG)=0,$P(LN,"-",80)=""
38 D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") S HDT=Y D LISTHDR
39 S IEN=0 F S IEN=$O(^ECX(727,IEN)) Q:IEN="" Q:QFLG D:$Y+4>IOSL LISTHDR Q:QFLG I $G(^ECX(727,IEN,"HEAD"))="CLI" D
40 .I $G(^ECX(727,IEN,"PURG")) Q
41 .I '$D(^ECX(727,IEN,0)) Q
42 .I $P(^ECX(727,IEN,0),U,4)<3030101 Q
43 .S ECXJOB=$P(^ECX(727,IEN,0),U)
44 .S ECXFROM=$TR($$FMTE^XLFDT($P(^ECX(727,IEN,0),U,4),"5DF")," ","0")
45 .S ECXEND=$TR($$FMTE^XLFDT($P(^ECX(727,IEN,0),U,5),"5DF")," ","0")
46 .S ECXRUN=$TR($$FMTE^XLFDT($P(^ECX(727,IEN,0),U,2),"5DF")," ","0")
47 .S ECXCNT=$P(^ECX(727,IEN,0),U,6)
48 .S ECXDIV=$P($G(^ECX(727,IEN,"DIV")),U) I ECXDIV D
49 ..S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
50 ..D EN^DIQ1 S ECXDIV=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
51 .D:$Y+3>IOSL LISTHDR Q:QFLG
52 .W !?4,ECXJOB,?14,ECXRUN,?28,$J(ECXCNT,9),?41,ECXFROM," - ",ECXEND,?71,ECXDIV
53 .S LIST(ECXJOB)=1
54 S LO=$O(LIST(0)),HI=$O(LIST(" "),-1)
55 S DIR(0)="L^"_LO_":"_HI_"",DIR("A")="Create the CBOC Activity Report for the following extract"
56 W ! D ^DIR K DIR I $D(DIRUT) K LIST S QFLG=1 Q
57 S JJ=0,Y=","_Y
58 F S JJ=$O(LIST(JJ)) Q:'JJ S JZ=","_JJ_"," I Y'[JZ K LIST(JJ)
59 I '$D(LIST) W !!,"Invalid choice. Please try again." S DIR(0)="E" W ! D ^DIR K DIR D Q:QFLG G SELECT
60 .I 'Y S QFLG=1
61 S ECXJOB=X
62 S Y=$P(^ECX(727,ECXJOB,0),U,4) D DD^%DT
63 S ECSTART=$P(Y," ")_$P(Y,",",2)
64 Q
65 ;
66LISTHDR ;
67 I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !
68 I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
69 S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"Selectable Clinic Extracts for CBOC Activity Report",?72,"Page: ",PG
70 W !!,"Extract #",?15,"Run Date",?28,"Rec Count",?42,"Date Range of Extract",?68,"Division",!,LN
71 Q
72 ;
73PROCESS ; entry point for queued report
74 N ECXD,QFLG,PG,RECDA,LN,COUNT
75 N FKEY,DIV,CLIN,SSN,DFN,VDATE,KEY
76 N TSSN,FSSN,DSSN,CSSN,TVISIT,FVISIT,DVISIT,CVISIT
77 N OLDFKEY,OLDDIV,OLDCLIN,OLDSSN,OLDDFN,OLDVDATE,OLDKEY,HEADKEY
78 S (QFLG,COUNT,PG)=0,ZTREQ="@",ECXD="-",$P(LN,"-",80)=""
79 K ^TMP($J)
80 W @IOF
81 ;
82 ; set report created indicator
83 K DA,DIC,DD,DO
84 S DA(1)=1
85 I '$D(^ECX(728,DA(1),"CBOC","B",ECXJOB)) D
86 .S DLAYGO=728,DIC(0)="L",DIC("P")=$P(^DD(728,68,0),U,2)
87 .S DIC="^ECX(728,"_DA(1)_",""CBOC"",",X=ECXJOB
88 .D FILE^DICN
89 ;
90 I $O(^ECX(727.827,"AC",ECXJOB,0))="" D Q
91 .W !,"No extract records exist for the selected extract."
92 S RECDA=0
93 F S RECDA=$O(^ECX(727.827,"AC",ECXJOB,RECDA)) Q:'RECDA D ISCBOC
94 ;
95 I '$D(^TMP($J)) W !,"No records were found with a CBOC Indicator value of ""Y""." S QFLG=1 Q
96 ;
97 S (TSSN,FSSN,DSSN,CSSN,TVISIT,FVISIT,DVISIT,CVISIT)=0
98 S RECDA=$O(^TMP($J,"AKEY",""))
99 S HEADKEY=RECDA
100 D HEADER Q:QFLG D DETAIL Q:QFLG D INCVIS D INCSSN D SETOLD
101 ;
102 ; process all CBOC records
103 F S RECDA=$O(^TMP($J,"AKEY",RECDA)) Q:RECDA="" D Q:QFLG
104 .S HEADKEY=OLDKEY
105 .; key fields match, so print detail record and increment total(s)
106 .I $P(RECDA,ECXD,1,3)=OLDKEY D Q
107 ..D DETAIL Q:QFLG
108 ..D INCVIS
109 ..S SSN=$P(RECDA,ECXD,4)
110 ..I '$D(^TMP($J,"C",OLDCLIN,SSN)) D INCSSN S OLDSSN=SSN
111 .;
112 .; if fkey changed, print "C","D", and "F" totals
113 .I $P(RECDA,ECXD)'=OLDFKEY D Q:QFLG
114 ..D CLINTOT Q:QFLG D DIVTOT Q:QFLG D FKEYTOT Q:QFLG
115 .E D Q:QFLG
116 ..I $P(RECDA,ECXD,2)'=OLDDIV D
117 ...D CLINTOT Q:QFLG D DIVTOT Q:QFLG
118 ..E D CLINTOT Q:QFLG
119 .;
120 .; something changed, so print subheader and detail line
121 .Q:QFLG S HEADKEY=RECDA
122 .D HEADER2 Q:QFLG
123 .D DETAIL Q:QFLG
124 .D INCVIS
125 .D INCSSN
126 .D SETOLD
127 .Q
128 Q:QFLG
129 ; print totals for clinic, division, feeder key, and grand totals
130 S HEADKEY=OLDKEY
131 D CLINTOT Q:QFLG
132 D DIVTOT Q:QFLG
133 D FKEYTOT Q:QFLG
134 D GTOTAL Q:QFLG
135 Q
136 ;
137ISCBOC ;
138 I $P(^ECX(727.827,RECDA,2),U,15)="Y" D SETKEY
139 Q
140 ;
141INCVIS ;
142 S TVISIT=TVISIT+1
143 S FVISIT=FVISIT+1
144 S DVISIT=DVISIT+1
145 S CVISIT=CVISIT+1
146 Q
147 ;
148INCSSN ;
149 N ZSSN,ZF,ZD,ZC
150 S ZSSN=$P(RECDA,ECXD,4)
151 S ZF=$P(RECDA,ECXD,1)
152 S ZD=$P(RECDA,ECXD,2)
153 S ZC=$P(RECDA,ECXD,3)
154 I '$D(^TMP($J,"SSN",ZSSN)) S ^TMP($J,"SSN",ZSSN)="" S TSSN=TSSN+1
155 I '$D(^TMP($J,"F",ZF,ZSSN)) S ^TMP($J,"F",ZF,ZSSN)="" S FSSN=FSSN+1
156 I '$D(^TMP($J,"D",ZD,ZSSN)) S ^TMP($J,"D",ZD,ZSSN)="" S DSSN=DSSN+1
157 I '$D(^TMP($J,"C",ZC,ZSSN)) S ^TMP($J,"C",ZC,ZSSN)="" S CSSN=CSSN+1
158 Q
159 ;
160SETOLD ;
161 S OLDKEY=$P(RECDA,ECXD,1,3)
162 S OLDFKEY=$P(RECDA,ECXD)
163 S OLDDIV=$P(RECDA,ECXD,2)
164 S OLDCLIN=$P(RECDA,ECXD,3)
165 S OLDSSN=$P(RECDA,ECXD,4)
166 Q
167 ;
168SETKEY ;
169 N CLIN,DIV,FKEY,DFN,SSN,VDATE
170 S CLIN=$P(^ECX(727.827,RECDA,0),U,12)
171 S DIV=$P(^ECX(727.827,RECDA,2),U,8)
172 S FKEY=$P(^ECX(727.827,RECDA,0),U,10)
173 S DFN=$P(^ECX(727.827,RECDA,0),U,5)
174 S SSN=$P(^ECX(727.827,RECDA,0),U,6)
175 S VDATE=$P(^ECX(727.827,RECDA,0),U,9)_"."_$P(^ECX(727.827,RECDA,0),U,14)
176 S KEY=FKEY_ECXD_DIV_ECXD_CLIN_ECXD_SSN_ECXD_DFN_ECXD_VDATE
177 S ^TMP($J,"AKEY",KEY)=""
178 Q
179 ;
180DETAIL ; print detail line
181 N DFN,PTNAME,DISPDT,DISPTM
182 U IO
183 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
184 S COUNT=COUNT+1
185 ;S QFLG=0
186 I $Y+3>IOSL D HEADER Q:QFLG
187 ; get patient name using DFN
188 S DFN=$P(RECDA,ECXD,5)
189 S PTNAME=$S(DFN'="":$P(^DPT(DFN,0),U),1:"")
190 S DISPDT=$P(RECDA,ECXD,6)
191 S DISPTM=$E(DISPDT,9,14)
192 S DISPDT=$E(DISPDT,1,4)-1700_$E(DISPDT,5,8)
193 S DISPDT=DISPDT_DISPTM
194 W !,PTNAME,?36,$P(RECDA,ECXD,4),?51,$$FMTE^XLFDT(DISPDT,1)
195 Q
196 ;
197CLINTOT ;
198 S COUNT=COUNT+2
199 I $Y+3>IOSL D HEADER Q:QFLG
200 W !!,?5,"Total Unique SSNs for Clinic:"
201 W ?35,$J(CSSN,10),?50,$J(CVISIT,10),?61,"Clinic Visits"
202 S (CSSN,CVISIT)=0 S OLDCLIN=$P(RECDA,ECXD,3) K ^TMP($J,"C")
203 Q
204 ;
205DIVTOT ;
206 S COUNT=COUNT+1
207 I $Y+3>IOSL D HEADER Q:QFLG
208 W !,?3,"Total Unique SSNs for Division:"
209 W ?35,$J(DSSN,10),?50,$J(DVISIT,10),?61,"Division Visits"
210 S (DSSN,DVISIT)=0 S OLDDIV=$P(RECDA,ECXD,2) K ^TMP($J,"D")
211 Q
212 ;
213FKEYTOT ;
214 S COUNT=COUNT+1
215 I $Y+3>IOSL D HEADER Q:QFLG
216 W !,?1,"Total Unique SSNs for Feeder Key:"
217 W ?35,$J(FSSN,10),?50,$J(FVISIT,10),?61,"Feeder Key Visits"
218 S (FSSN,FVISIT)=0 S OLDFKEY=$P(RECDA,ECXD) K ^TMP($J,"F")
219 Q
220 ;
221GTOTAL ;
222 S COUNT=COUNT+1
223 I $Y+3>IOSL D HEADER Q:QFLG
224 W !,"Total Unique SSNs (entire report):"
225 W ?35,$J(TSSN,10),?50,$J(TVISIT,10),?61,"Total Visits"
226 Q
227 ;
228CLOSE ;
229 I $E(IOST)="C",'QFLG D
230 .S SS=22-$Y F JJ=1:1:SS W !
231 .S DIR(0)="E" W ! D ^DIR K DIR
232 Q
233 ;
234HEADER ;header and page control
235 D HEADER1 Q:QFLG
236 D HEADER2 Q:QFLG
237 Q
238HEADER1 ;header1 and page control
239 N SS,JJ
240 I $E(IOST)="C" D
241 .S SS=22-$Y F JJ=1:1:SS W !
242 .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1
243 Q:QFLG
244 W:$Y!($E(IOST)="C") @IOF S PG=PG+1
245 W !,"CBOC Activity Report"
246 W ?(73-$L(PG)),"Page: "_PG
247 W !,ECSTART,?50,"Report Run Date: "_ECRUN
248 Q
249 ;
250HEADER2 ;display whenever feeder key, division, or clinic changes
251 I $Y+8>IOSL D HEADER1 Q:QFLG
252 N CLINIC
253 S CLINIC=$$GET1^DIQ(44,$P($P(HEADKEY,ECXD,3),U),.01,)
254 W !!,"Feeder Key: ",$P(HEADKEY,ECXD)
255 W ?31,"Division: ",$P(HEADKEY,ECXD,2)
256 W ?51,"Clinic: ",$E(CLINIC,1,20)
257 W !!,"Patient",?39,"SSN",?51,"Visit Date/Time"
258 W !,LN
259 Q
Note: See TracBrowser for help on using the repository browser.