source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPBK4.m@ 1586

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1PSOCPBK4 ;BIR/GN-Copay Back Bill for Automated-release refills cont. ;10/12/05 9:55am
2 ;;7.0;OUTPATIENT PHARMACY;**217**;DEC 1997
3 ;External reference to ^PSDRUG supported by DBIA 221
4 ;External reference to ^IBAM(354.7 supported by DBIA 3877
5 ;External reference to $$PROD^XUPROD(1) supported by DBIA 4440
6 ;External reference to $$PTCOV^IBCNSU3 supported by DBIA 4115
7 ;External reference to ^IBARX supported by DBIA 125
8 ;
9 Q
10 ;
11ADDBILL ;add to billable ^XTMP if ok, quit if not
12 S PSOTRF=PSOTRF+1
13 S PSOREL=$P($G(^PSRX(RXP,1,YY,0)),"^",18)
14 Q:'PSOREL ;not released
15 Q:'YY ;orig fill
16 Q:+$$RXST^IBARXEU(PSODFN,$P(PSOREL,".")) ;Exempt on Rel dte
17 ;check refill
18 Q:$P($G(^PSRX(RXP,1,YY,"IB")),"^",1)'="" ;already billed
19 Q:$P($G(^PSRX(RXP,1,YY,"IB")),"^",2)'="" ;exceeded ann. cap
20 ;
21 ;look for Activity log entry per refill # with the below text
22 S FOUND=0
23 F XX=999:0 S XX=$O(^PSRX(RXP,"A",XX),-1) Q:'XX D Q:FOUND
24 .Q:$P(^PSRX(RXP,"A",XX,0),"^",4)'=YY
25 .Q:^PSRX(RXP,"A",XX,0)'["External Interface Dispensing is Complete"
26 .S FOUND=1
27 Q:'FOUND
28 ;
29 S ^XTMP(NAMSP,PSODFN,RXP,YY)=$P(PSOREL,".") ;add to XTMP to be bill
30 Q
31 ;
32XTYPE ;
33 N Y,VADM,I,J,X,SAVY,DFN
34 S DFN=PSODFN D DEM^VADPT I +$G(VADM(6)) S PSOSCMX="" Q ; DECEASED
35 S (X,PSOSCMX,SAVY)=""
36 S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q
37 I 'X Q
38 S X=X_"^"_PSODFN D XTYPE^IBARX
39 I $G(Y)'=1 Q
40 S J="" F S J=$O(Y(J)) Q:'J S I="" F S SAVY=I,I=$O(Y(J,I)) Q:I="" S:I>0 PSOSCMX=I
41 I PSOSCMX="",SAVY=0 Q ; INCOME EXEMPT OR SERVICE-CONNECTED
42 I PSOSCMX=2 Q ; NEED TO ASK SC QUESTION
43 Q
44 ;
45TOTAL ;
46 N COUNT,COUNTED
47 I '$D(PSOVETS) S PSOVETS=0
48 N I,J
49 F I=1:1:3 S (PSOCNT("YR2004",I),PSOCNT("YR2005",I))=0
50 S PSODFN=0 F S PSODFN=$O(^XTMP(NAMSP,PSODFN)) Q:'PSODFN D
51 .S COUNTED=0
52 .F J="YR2004","YR2005" F I=1:1:3 S COUNT=$G(^XTMP(NAMSP,PSODFN,J,I)) I COUNT>0 S:'$G(COUNTED) COUNTED=1,PSOVETS=PSOVETS+1 S PSOCNT(J,I)=PSOCNT(J,I)+COUNT
53 F I=1:1:3 S PSOCNT=PSOCNT+PSOCNT("YR2004",I)+PSOCNT("YR2005",I)
54 Q
55 ;
56BILLIT ;
57 ; IF NO IB NUMBER FOR THIS FILL, SET UP VARIABLES AND TALLY
58 N PSOCAP,PSODIV,PSODV,PSOFILL,PSOLOG,PSOOUT,PSOPAR,PSOPATID,PSOSITE
59 N PSOSITE7,PSOSQ,PSOTOT,PSOYEAR,PSOYR,SSN,SAVCPUN,SAVREF
60 S PSODFN=0
61 F CC=1:1 S PSODFN=$O(^XTMP(NAMSP,PSODFN)) Q:'PSODFN D Q:STOP
62 .I CC#100=0,$D(^XTMP(NAMSP,0,"STOP")) D Q
63 ..S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT,STOP=1
64 .S (PSOCAP(304),PSOCAP(305))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005
65 .F RXP=0:0 S RXP=$O(^XTMP(NAMSP,PSODFN,RXP)) Q:'RXP D
66 ..;calc number of 30-day units eligible to bill
67 ..S (SAVCPUN,PSOCPUN)=($P(^PSRX(RXP,0),"^",8)+29)\30
68 ..F YY=0:0 S YY=$O(^XTMP(NAMSP,PSODFN,RXP,YY)) Q:YY="" D
69 ...S (SAVREF,PSOREF)=YY
70 ...S PSOREL=$G(^XTMP(NAMSP,PSODFN,RXP,YY))
71 ...I PSOCAP($E(PSOREL,1,3)) Q ; MET ANNUAL CAP FOR 2004 OR 2005
72 ...I $P($G(^PSRX(RXP,1,YY,"IB")),"^",1)="" D ; REFILL LEVEL
73 ....D SITE
74 ....D CP^PSOCP ;call back billing
75 ....S PSOCPUN=SAVCPUN,PSOREF=SAVREF
76 ....I $P($G(^PSRX(RXP,1,YY,"IB")),"^",1) D ACCUM ;Do if was billed?
77 ....D CP I +$G(PSOREF) D ACCUM
78 Q
79 ;
80CP ; Entry point to Check if COPAY - Requires RXP,PSOSITE7
81 I '$D(PSOPAR) D ^PSOLSET G CP
82 K PSOCP
83 S PSOCPN=$P(^PSRX(RXP,0),"^",2) ; Set COPAY dfn PTR TO PATIENT
84 S PSOCP=$P($G(^PSRX(RXP,"IB")),"^") ; IB action type
85 S PSOSAVE=$S(PSOCP:1,1:"") ; save current copay status
86 ; Set x=service^dfn^actiontype^user duz
87 I +$G(PSOSITE7)'>0 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^")
88 S X=PSOSITE7_"^"_PSOCPN_"^"_PSOCP_"^"_$P(^PSRX(RXP,0),"^",16)
89 ;
90RX ; Determine Original or Refill for RX
91 N PSOIB
92 S PSOIB=0
93 S PSOREF=0
94 ;set refill number if this is a refill
95 I $G(^PSRX(RXP,1,+$G(YY),0))]"" S PSOREF=YY
96 ;
97 ;Orig fill -check if bill # already exists
98 I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1
99 I PSOIB D QUIT Q
100 ;already attempted to bill, but exceeded Anuual Cap
101 I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",4)>0 D QUIT Q
102 ;
103 ;Refill -check if bill # already exists
104 I PSOREF,+$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1
105 I PSOIB D QUIT Q
106 ;already attempted to bill, but exceeded Anuual Cap
107 I PSOREF,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^",2) G QUIT
108 ;
109 ;set temporary variable to copay and then look for exceptions
110 S PSOCHG=1
111 D COPAYREL
112 I 'PSOCHG D QUIT Q ;not billable
113 I PSOCHG=2,'PSOCP D QUIT
114 Q
115QUIT ;
116 K Y,PSOCP1,PSOREF,PSOCPUN,PSOCP2,PSOCPN,X,PSOCHG,PSOSAVE,PREA,PSORSN
117 Q
118 ;
119COPAYREL ; Recheck copay status at release
120 ;
121 ; check Rx patient status
122 I $P(^PSRX(RXP,0),"^",3)'="",$P($G(^PS(53,$P(^PSRX(RXP,0),"^",3),0)),"^",7)=1 S PSOCHG=0 Q
123 ; see if drug is investigational or supply
124 N DRG,DRGTYP
125 S DRG=+$P(^PSRX(RXP,0),"^",6),DRGTYP=$P($G(^PSDRUG(DRG,0)),"^",3)
126 I DRGTYP["I" S PSOCHG=0 Q
127 I DRGTYP["S" S PSOCHG=0 Q
128 K PSOTG,CHKXTYPE
129 I +$G(^PSRX(RXP,"IBQ")) D XTYPE1^PSOCP1
130 I $G(^PSRX(RXP,"IBQ"))["1" S PSOCHG=0 Q
131 Q
132 ;
133ACCUM ; ACCUMULATE TOTALS AND SEE IF PATIENT MET ANNUAL CAP
134 S PSOYR=$E(PSOREL,1,3) I PSOYR="" Q
135 S PSOYEAR=$S(PSOYR="304":"YR2004",PSOYR="305":"YR2005",1:"")
136 Q:PSOYEAR=""
137 ;
138 ;get Xtmp billing amt which would be IBAM tot + any previous refills
139 S PSOTOT=$G(^XTMP(NAMSP,PSODFN,PSOYEAR))
140 ;
141 ;if none yet then init to the IBAM total for the year
142 I 'PSOTOT D
143 .F PSOSQ=0:0 S PSOSQ=$O(^IBAM(354.7,PSODFN,1,PSOSQ)) Q:'PSOSQ D
144 ..S PSOLOG=$G(^IBAM(354.7,PSODFN,1,PSOSQ,0))
145 ..I $E(PSOLOG,1,3)=PSOYR S PSOTOT=PSOTOT+$P(PSOLOG,"^",2)
146 ;
147 ;update Xtmp tot nodes with current refill amounts
148 S ^XTMP(NAMSP,PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*7)
149 S ^XTMP(NAMSP,PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,PSODFN,PSOYEAR,PSOCPUN))+1
150 ;
151 ;indicate this refill may be billable or (was billed, if BILLING run)
152 ;by adding to Xtmp "BILLED"
153 N PSONAM
154 S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",")
155 S PSONAM=$E(PSONAM,1,6)
156 S ^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOREF)=PSOREL
157 Q
158 ;
159SITE ; SET UP VARIABLES NEEDED BY BILLING
160 S PSOSITE=$S(YY=0:$P(^PSRX(RXP,2),"^",9),1:$P($G(^PSRX(RXP,1,YY,0)),"^",9))
161 Q:PSOSITE=""
162 S PSOPAR=$G(^PS(59,PSOSITE,1))
163 S PSOSITE7=$P($G(^PS(59,PSOSITE,"IB")),"^")
164 Q
165 ;
166RPT ;
167 N JOBN,NAMSP,ZTDESC,ZTRTN
168 S NAMSP=$$NAMSP^PSOCPBK3
169 S JOBN=$S(^XTMP(NAMSP,0)["BACK":"Back Billing",1:"Tally")
170 L +^XTMP(NAMSP):0 I '$T D Q
171 .W !,JOBN_" job for PSO*7*217 is still running. Halting..."
172 L -^XTMP(NAMSP)
173 W !!,"This report shows the patient name and prescription information for refills"
174 W:JOBN["Tally" !,"that were identified as billable by the patch PSO*7*217"
175 W:JOBN["Back" !,"that were back-billed by the patch PSO*7*217"
176 W !!,"You may queue the report to print, if you wish.",!
177 ;
178DVC K %ZIS,POP,IOP S %ZIS="QM" D ^%ZIS I $G(POP) W !!,"Nothing queued to print.",! G DONE
179QUEUE I $D(IO("Q")) S ZTRTN="START^PSOCPBK4",ZTDESC=JOBN_" copay report" D ^%ZTLOAD K %ZSI W !,"Report queued to print.",! G DONE
180START ;
181 U IO
182 N BLDT,RXO,NAMSP,PSOFILL,PSODFN,PSONAM,PSOOUT,PSODV,RXP,SSN,PSODIV
183 N JOBN,PSOPATID
184 S NAMSP=$$NAMSP^PSOCPBK3
185 S JOBN=$S(^XTMP(NAMSP,0)["BACK":"Back Billing",1:"Tally")
186 S PSOOUT=0,PSODV=$S($E(IOST)="C":"C",1:"P")
187 S PSOPGCT=0,PSOPGLN=IOSL-7,PSOPGCT=1
188 S BLDT=$P($G(^XTMP(NAMSP,0,"LAST")),"^",2)
189 D TITLE
190 S PSONAM=""
191 F S PSONAM=$O(^XTMP(NAMSP,"BILLED",PSONAM)) Q:PSONAM="" D
192 .S PSODFN=""
193 .F S PSODFN=$O(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN)) Q:PSODFN="" D
194 ..S RXP=""
195 ..F S RXP=$O(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP)) Q:RXP="" D
196 ...S PSOFILL=""
197 ...F S PSOFILL=$O(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOFILL)) Q:PSOFILL="" D
198 ....N XX,RXO,Y,PSONAME
199 ....S XX=$G(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOFILL)) D
200 .....D FULL Q:$G(PSOOUT) S PSONAME=$P($G(^DPT(PSODFN,0)),"^")
201 .....W !,$E(PSONAME,1,14)
202 .....D PRTSSN
203 .....S RXO=$P($G(^PSRX(RXP,0)),"^")
204 .....W ?42," ",RXO," (",PSOFILL,")"
205 .....S Y=XX I Y>0 X ^DD("DD")
206 .....W ?55," ",Y
207 .....W ?69,$S($$PTCOV^IBCNSU3(PSODFN,XX,"PHARMACY"):"YES",1:" NO")
208 .....W ?75,$S($$PTCOV^IBCNSU3(PSODFN,BLDT,"PHARMACY"):"YES",1:" NO")
209 G END
210 ;
211FULL ;
212 I ($Y+7)>IOSL&('$G(PSOOUT)) D TITLE
213 Q
214 ;
215TITLE ;
216 I $G(PSODV)="C",$G(PSOPGCT)'=1 W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSOOUT=1 Q
217 ;
218 W @IOF D
219 . W !,"Patch PSO*7*217 -COPAY PRESCRIPTION REFILLS "_JOBN
220 S Y=DT X ^DD("DD") W !,"Date printed: ",Y,?70,"Page: ",PSOPGCT,!
221 F MJT=1:1:79 W "="
222 W !,?69,"INS ON DTE"
223 W !,"PATIENT NAME (SSN) DIV",?43,"RX# (FILL)",?55,"RELEASE DATE",?69,"REL BILL"
224 W !,"-------------- ------- ----------------",?42,"------------"
225 W ?55,"------------",?69,"---- -----"
226 S PSOPGCT=PSOPGCT+1
227 Q
228END ;
229 I '$G(PSOOUT),$G(PSODV)="C" W !!,"** End of Report **" K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
230 I $G(PSODV)="C" W !
231 E W @IOF
232DONE ;
233 K MJT,PSOPGCT,PSOPGLN,Y,DIR,X,IOP,POP,IO("Q"),DIRUT,DUOUT,DTOUT
234 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
235 Q
236 ;
237PRTSSN ;
238 S SSN=$P(^DPT(PSODFN,0),"^",9),SSN=$E(SSN,$L(SSN)-3,$L(SSN))
239 S PSOPATID=$E(PSONAM,1)_SSN
240 S PSODIV=$P($G(^PSRX(RXP,2)),"^",9)
241 S:PSODIV'="" PSODIV=$P($G(^PS(59,PSODIV,0)),"^",1)
242 W ?16,"("_PSOPATID_")"_" "_PSODIV
243 Q
244 ;
245ETIME(SECTIME) ;convert seconds to day:hr:min:sec
246 N DAY,HR,MIN,SEC,ETIM
247 S (DAY,HR,MIN,SEC)=""
248 I SECTIME>86400 S DAY=SECTIME\86400,SECTIME=SECTIME#86400
249 I SECTIME>3600 S HR=SECTIME\3600,SECTIME=SECTIME#3600
250 I SECTIME>60 S MIN=SECTIME\60,SECTIME=SECTIME#60
251 S SEC=SECTIME
252 S ETIM=""
253 S:$L(HR)=1 HR=0_HR S:$L(MIN)=1 MIN=0_MIN S:$L(SEC)=1 SEC=0_SEC
254 S:DAY ETIM=DAY_" Day " S:HR ETIM=ETIM_HR_":" S:MIN ETIM=ETIM_MIN
255 S ETIM=ETIM_":"_SEC
256 Q ETIM
Note: See TracBrowser for help on using the repository browser.