source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDPBP.m@ 1375

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

initial load of FOIAVistA 6/30/08 version

File size: 8.4 KB
Line 
1SDPBP ; BP-IOFO/OWAIN ; Pharmacy Benefits Print. ; ; Compiled November 13, 2003 09:55:19
2 ;;5.3;Scheduling;**318**; SEP 29, 2003
3 ;
4EN0 ; Inquire date range.
5 K %DT
6 S %DT="AEX",%DT("A")="Appointment start date for report: "
7 D ^%DT Q:Y=-1
8 K %DT
9 S (SDT,%DT(0))=Y K Y
10 S %DT="AEX",%DT("A")="Appointment end date for report: "
11 D ^%DT Q:Y=-1
12 S EDT=Y
13 S DIR("?",1)="Enter YES to show only summary totals.",DIR("?")="Enter NO to list patient level details as well."
14 S DIR("A")="Summary?",DIR(0)="Y",DIR("B")="YES" D ^DIR
15 K DIR
16 Q:Y="^"
17 S SDSUMM=Y
18 D DEV
19 Q
20 ;
21EN ;
22 N SDCL,SDSS,NAME,DFN,INST,LINE,MAXLEN,PAGE,TODAY,CTR,SDCUTOFF,SDCUTOFD,TDAYS,TRSA
23 D INIT(.SDSS)
24 S (SDCL,CTR)=0,(SDCUTOFF,Y)=3031022 D DD^%DT S SDCUTOFD=Y
25 D SCH^PSOTPCAN ; Pharmacy call to generate ^TMP global of eligible patients.
26 D NOW^%DTC S TODAY=X
27 S NAME=""
28 F S NAME=$O(^TMP($J,"PSODFN",NAME)) Q:NAME="" D
29 .S DFN=0
30 .F S DFN=$O(^TMP($J,"PSODFN",NAME,DFN)) Q:+DFN'=DFN D
31 ..N SDAPDTT,SSN,SSNP,SEL,RESCHED
32 ..D DEM^VADPT
33 ..S (SSN,SSNP)="" S SSN=$P($G(VADM(2)),"^") I SSN["P" S SSNP="P",SSN=$E(SSN,1,9) ; Social security number.
34 ..Q:$E(SSN,1,5)="00000" ; Exclude test patients.
35 ..S SDAPDTT=$O(^DPT(DFN,"S",SDT),-1)
36 ..F S SDAPDTT=$O(^DPT(DFN,"S",SDAPDTT)) Q:+SDAPDTT'=SDAPDTT!(SDAPDTT>(EDT+.24)) D
37 ...N SDAP0,SDCL0,SDCP,SDST,SDNAPDT,DAYS
38 ...S SDAP0=^DPT(DFN,"S",SDAPDTT,0),SDCL=+SDAP0
39 ...S SDCL0=$G(^SC(SDCL,0)) Q:'$L(SDCL0) ; Get clinic 0 node.
40 ...S SDCP=$$CPAIR(SDCL0) ; Get DSS credit pair.
41 ...Q:'$D(SDSS(SDCP)) ; Not a primary care appointment.
42 ...S SDST=$P(SDAP0,U,2),SDCDTT=$P(SDAP0,U,14)
43 ...S INST=$$DIV(SDCL0)
44 ...I 'INST S INST(0)="*NO INSTITUTION"
45 ...E S INST(INST)=$$GET1^DIQ(4,INST_",",.01)
46 ...S RESCHED=$$RESCHED(DFN,SDAPDTT,SDCL,SDST,.SDNAPDT)
47 ...I 'RESCHED S SEL(INST,SDAPDTT)=SDCL Q
48 ...S:'$D(RESCHED(INST)) RESCHED(INST)=2
49 ...S X1=SDNAPDT,X2=SDAPDTT D ^%DTC S DAYS=X
50 ...S Y=SDAPDTT\1 D DD^%DT S SDAPDTT0=Y
51 ...I SDNAPDT'="" S Y=SDNAPDT\1 D DD^%DT S SDNAPDT=Y
52 ...S ^TMP($J,"SDOUT",INST(INST),"PT",NAME,DFN,SDAPDTT)=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)_U_$$GET1^DIQ(44,SDCL_",",.01)_U_SDAPDTT0_U_$S($E(SDST)="N":"No-Show",1:"Canc by Patient")_U_SDNAPDT_U_DAYS
53 ...Q:SDAPDTT<SDCUTOFF!(RESCHED=2)
54 ...S RESCHED(INST)=1
55 ...S ^TMP($J,"SDOUT",INST(INST),"CAN")=$G(^TMP($J,"SDOUT",INST(INST),"CAN"))+1
56 ...S ^TMP($J,"SDOUT",INST(INST),"RSA")=$G(^TMP($J,"SDOUT",INST(INST),"RSA"))+1
57 ...S ^TMP($J,"SDOUT",INST(INST),"DAYS")=$G(^TMP($J,"SDOUT",INST(INST),"DAYS"))+DAYS
58 ...Q
59 ..; For episodes that were not no-show or cancelled by patient, show the first
60 ..; future appointment or if there is not a future appointment the nearest
61 ..; previous appointment.
62 ..S INST=""
63 ..S SSN=SSN_SSNP
64 ..F S INST=$O(SEL(INST)) Q:INST="" D:'$D(^TMP($J,"SDOUT",INST(INST),"PT",NAME,DFN))
65 ...S SDAPDTT="" D
66 ....S SDAPDTT1=$O(SEL(INST,TODAY))
67 ....S SDAPDTT0=$O(SEL(INST,TODAY),-1)
68 ....I SDAPDTT0="" S SDAPDTT=SDAPDTT1 Q
69 ....I SDAPDTT1="" S SDAPDTT=SDAPDTT0 Q
70 ....S X1=SDAPDTT0,X2=TODAY D ^%DTC S X0=X
71 ....S X1=TODAY,X2=SDAPDTT1 D ^%DTC
72 ....S SDAPDTT=$S(X0<X:SDAPDTT0,1:SDAPDTT1)
73 ....Q
74 ...I SDAPDTT'="" D
75 ....S Y=SDAPDTT\1 D DD^%DT S SDNEAPT=Y
76 ....S ^TMP($J,"SDOUT",INST(INST),"PT",NAME,DFN,SDAPDTT)=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)_U_$$GET1^DIQ(44,SEL(INST,SDAPDTT)_",",.01)_U_U_U_SDNEAPT
77 ....Q
78 ...Q
79 ..S INST=""
80 ..F S INST=$O(RESCHED(INST)) Q:INST="" I RESCHED(INST)=1 S ^TMP($J,"SDOUT",INST(INST),"RSP")=$G(^TMP($J,"SDOUT",INST(INST),"RSP"))+1
81 ..Q
82 .Q
83 ;
84 S PAGE=0,(TDAYS,TRSA)=0
85 I 'SDSUMM D
86 .D HEAD10
87 .I '$D(^TMP($J,"SDOUT")) W !!!?47,"********** NO DATA TO PRINT **********" Q
88 .D HEAD20
89 .S INSTX=""
90 .F S INSTX=$O(^TMP($J,"SDOUT",INSTX)) Q:INSTX="" D Q:CTR
91 ..I LINE+5>IOSL D HEAD10 Q:CTR D HEAD20
92 ..W !!,"Institution : ",INSTX,! S LINE=LINE+3
93 ..S NAME=""
94 ..F S NAME=$O(^TMP($J,"SDOUT",INSTX,"PT",NAME)) Q:NAME="" D Q:CTR
95 ...S DFN=0
96 ...F S DFN=$O(^TMP($J,"SDOUT",INSTX,"PT",NAME,DFN)) Q:+DFN'=DFN D
97 ....S SDAPDT=0
98 ....F S SDAPDT=$O(^TMP($J,"SDOUT",INSTX,"PT",NAME,DFN,SDAPDT)) Q:+SDAPDT'=SDAPDT D
99 .....N REC
100 .....S REC=^TMP($J,"SDOUT",INSTX,"PT",NAME,DFN,SDAPDT)
101 .....I LINE+($P(REC,U,6)'="")+2>IOSL D HEAD10 Q:CTR D HEAD20
102 .....W !,$E(NAME,1,33),?38,$P(REC,U),?52,$E($P(REC,U,2),1,33),?89,$P(REC,U,3),?103,$P(REC,U,4),?120,$P(REC,U,5)
103 .....S LINE=LINE+1
104 .....I $P(REC,U,6)'="" W !?8,"Deferred Number of Days: ",$P(REC,U,6) S LINE=LINE+1
105 .....Q
106 ....Q
107 ...Q
108 ..I LINE+5>IOSL D HEAD10
109 ..D HEAD21,SUMMARY
110 ..Q
111 .Q
112 I SDSUMM D
113 .N INSTX,X,CAN
114 .D HEAD10,HEAD21
115 .S (INSTX,X)=""
116 .F S INSTX=$O(^TMP($J,"SDOUT",INSTX)) Q:INSTX="" S CAN=+$G(^TMP($J,"SDOUT",INSTX,"CAN")) D SUMMARY Q:CTR
117 .I X="" W !!!?21,"********** NO DATA TO PRINT **********"
118 .E W !!,"Overall average time between appointments : ",$S(TRSA=0:$J(TDAYS,2),1:$J(TDAYS/TRSA,2))
119 .Q
120 ;
121 K ^TMP($J,"PSODFN"),^TMP($J,"SDOUT")
122 Q:CTR
123 I $E(IOST)="C" S DIR(0)="E" D ^DIR
124 Q
125 ;
126SUMMARY ;
127 ; In - INSTX, IOSL
128 ; Out - TRSA, TDAYS
129 ;
130 N RSA,DAYS
131 S X=INSTX
132 S RSA=+$G(^TMP($J,"SDOUT",INSTX,"RSA")),TRSA=TRSA+RSA
133 S DAYS=+$G(^TMP($J,"SDOUT",INSTX,"DAYS")),TDAYS=TDAYS+DAYS
134 I LINE+2>IOSL D HEAD10 Q:CTR D HEAD21
135 W !
136 W:SDSUMM X,?9,INST
137 W ?41,+$G(^TMP($J,"SDOUT",INSTX,"CAN"))
138 W ?52,RSA
139 W ?62,+$G(^TMP($J,"SDOUT",INSTX,"RSP"))
140 W ?71,$S(RSA=0:"0.00",1:$J(DAYS/RSA,"",2))
141 S LINE=LINE+1
142 Q
143 ;
144BUILD(NAME,SSN,SDCL,SDST,SDCAPDTT,SDNEAPT) ;
145 N DAYS,INST
146 S DAYS=""
147 I SDCAPDTT'="" D
148 .S X1=SDNEAPT,X2=SDAPDTT D ^%DTC S DAYS=X
149 .S Y=SDCAPDTT\1 D DD^%DT S SDCAPDTT=Y
150 .Q
151 I SDNEAPT'="" S Y=SDNEAPT\1 D DD^%DT S SDNEAPT=Y
152 ; Get institution for 3rd node.
153 ; The patient names are already in alphabetical order so a numeric index is sufficient.
154 S UNQ=$O(^TMP($J,"SDOUT",INST,"PT",NAME,":"),-1)+1
155 S ^TMP($J,"SDOUT",INST,"PT",NAME,UNQ)=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)_U_$$GET1^DIQ(44,SDCL_",",.01)_U_SDCAPDTT_U_$S(SDST="N":"No-Show",SDST="P":"Canc by Patient",1:"")_U_SDNEAPT_U_DAYS
156 Q
157 ;
158RESCHED(DFN,SDAPDTT,SDCL,SDST,SDNAPDT) ; Search for a subsequent appointment at the same clinic.
159 ; 0 - no rescheduled appointment
160 ; 1 - cancelled by patient and rescheduled
161 ; 2 - no-show and rescheduled
162 N SDOK
163 I SDST="NA"!(SDST="PCA") S SDNAPDT=$P(^DPT(DFN,"S",SDAPDTT,0),U,10) Q:SDNAPDT>SDAPDTT SDST="NA"+1
164 Q:SDST'="N"&(SDST'="PC") 0
165 S SDOK=0,SDNAPDT=""
166 F S SDAPDTT=$O(^DPT(DFN,"S",SDAPDTT)) Q:+SDAPDTT'=SDAPDTT S SDOK=$P(^DPT(DFN,"S",SDAPDTT,0),U)=SDCL I SDOK S SDNAPDT=SDAPDTT Q
167 Q (SDST="NA"+1)*SDOK
168 ;
169HEAD10 ;
170 S PAGE=PAGE+1
171 I PAGE>1,$E(IOST)="C" S DIR(0)="E" D ^DIR I $D(DIRUT) S CTR=1 Q
172 S SDTTL="Transitional Pharmacy Benefit Deferred Appointment Report"
173 I SDSUMM S SDTTL=SDTTL_" (Summary)"
174 W @IOF,!?IOM-$L(SDTTL)\2,SDTTL
175 I 'SDSUMM W ?122,"Page : "_PAGE
176 S Y=SDT D DD^%DT
177 S SDTTL="Report for the period of "_Y_" and "
178 S Y=EDT D DD^%DT
179 S SDTTL=SDTTL_Y
180 W !?IOM-$L(SDTTL)\2,SDTTL
181 W !
182 S LINE=4
183 Q
184 ;
185HEAD20 ;
186 W !?89,"Cancelled",?103,"Reason for",?120,"New/Closest"
187 W !,"Patient",?38,"SSN",?52,"Clinic",?89,"Appt. Date",?103,"Cancellation",?120,"Appt. Date"
188 W !,"=======",?38,"===",?52,"======",?89,"==========",?103,"============",?120,"==========="
189 S LINE=LINE+3
190 Q
191 ;
192HEAD21 ;
193 W !!
194 W:'SDSUMM "Count for appts. after "_SDCUTOFD
195 W ?41,"Appts",?52,"Appts",?62,"Patients",?71,"Ave time"
196 W !
197 W:SDSUMM "Institution"
198 W ?41,"Cancelled",?52,"Deferred",?62,"Deferred",?71,"/appts"
199 W !
200 W:SDSUMM "==========="
201 W ?41,"=========",?52,"========",?62,"========",?71,"========"
202 S LINE=LINE+4
203 Q
204 ;
205INIT(SDSS) ;
206 N SDI,SDII
207 F SDI=322,323,350 F SDII="000",185,186,187 S SDSS(SDI_SDII)=""
208 K ^TMP($J,"SDOUT")
209 Q
210 ;
211CPAIR(SDCL0) ; Get credit pair
212 ; Input: SDCL0=hospital location zeroeth node
213 N SDX
214 S SDX=$P($G(^DIC(40.7,+$P(SDCL0,U,7),0)),U,2)
215 S SDX=SDX_$P($G(^DIC(40.7,+$P(SDCL0,U,18),0)),U,2)
216 S SDX=$E(SDX_"000000",1,6)
217 Q SDX
218 ;
219DIV(SDCL0) ;Get facility division name and number
220 ;Input: SDCL0=hospital location zeroeth node
221 N SDIVV,SDHOLD S SDIVV=$P(SDCL0,U,15)
222 S SDHOLD=0
223 I SDIVV>0 S SDHOLD=$P($$SITE^VASITE(,SDIVV),"^")
224 I SDHOLD>0 Q SDHOLD
225 S SDHOLD=$P(SDCL0,"^",4)
226 I 'SDHOLD Q 0
227 I SDHOLD,'$D(^DIC(4,SDHOLD,0)) S SDHOLD=0
228 Q SDHOLD
229 ;
230DEV ;
231 K %ZIS,IOP,POP,ZTSK S SDDIO=ION,%ZIS="QM" D ^%ZIS K %ZIS
232 S IOM=$S(SDSUMM:80,1:132)
233 I POP S IOP=SDDIO D ^%ZIS K IOP,SDDIO W !,"Please try later!" G END
234 K SDDIO I $D(IO("Q")) K IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK D G END
235 .S ZTRTN="EN^SDPBP",ZTDTH=$H,ZTDESC="TRANSITIONAL PHARMACY BENEFITS ELIGIBILITY PRINT"
236 .S ZTSAVE("SDT")=""
237 .S ZTSAVE("EDT")=""
238 .S ZTSAVE("SDSUMM")=""
239 .D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print !!" K ZTSK
240 .Q
241 D EN
242END ;
243 W ! D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
244 K ^TMP($J)
245 Q
Note: See TracBrowser for help on using the repository browser.