source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPBK2.m@ 1520

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

initial load of WorldVistAEHR

File size: 7.4 KB
Line 
1PSOCPBK2 ;BIR/EJW,GN-Tally Automated-release refill copay cont. ;8/10/05 12:03pm
2 ;;7.0;OUTPATIENT PHARMACY;**215**;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 ;
7TALLY ;
8 ; IF NO IB NUMBER FOR THIS FILL, SET UP VARIABLES AND TALLY
9 N PSOCAP,PSODIV,PSODV,PSOFILL,PSOLOG,PSOOUT,PSOPAR,PSOPATID,PSOSITE
10 N PSOSITE7,PSOSQ,PSOTOT,PSOYEAR,PSOYR,SSN
11 S PSODFN=0
12 F QQ=1:1 S PSODFN=$O(^XTMP(NAMSP,PSODFN)) Q:'PSODFN D Q:STOP
13 .I QQ#100=0,$D(^XTMP(NAMSP,0,"STOP")) K ^XTMP(NAMSP) S STOP=1
14 .S (PSOCAP(304),PSOCAP(305))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005
15 .F RXP=0:0 S RXP=$O(^XTMP(NAMSP,PSODFN,RXP)) Q:'RXP D
16 ..F YY=0:0 S YY=$O(^XTMP(NAMSP,PSODFN,RXP,YY)) Q:YY="" D
17 ...S PSOREL=$G(^XTMP(NAMSP,PSODFN,RXP,YY))
18 ...I PSOCAP($E(PSOREL,1,3)) Q ; MET ANNUAL CAP FOR 2004 OR 2005
19 ...I $P($G(^PSRX(RXP,1,YY,"IB")),"^",1)="" D ; REFILL LEVEL
20 ....D SITE
21 ....D CP
22 Q
23 ;
24CP ; Entry point to Check if COPAY - Requires RXP,PSOSITE7
25 I '$D(PSOPAR) D ^PSOLSET G CP
26 K PSOCP
27 S PSOCPN=$P(^PSRX(RXP,0),"^",2) ; Set COPAY dfn PTR TO PATIENT
28 S PSOCP=$P($G(^PSRX(RXP,"IB")),"^") ; IB action type
29 S PSOSAVE=$S(PSOCP:1,1:"") ; save current copay status
30 ; Set x=service^dfn^actiontype^user duz
31 I +$G(PSOSITE7)'>0 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^")
32 S X=PSOSITE7_"^"_PSOCPN_"^"_PSOCP_"^"_$P(^PSRX(RXP,0),"^",16)
33 ;
34RX ; Determine Original or Refill for RX
35 N PSOIB
36 S PSOIB=0
37 S PSOREF=0
38 ;set refill number if this is a refill
39 I $G(^PSRX(RXP,1,+$G(YY),0))]"" S PSOREF=YY
40 ;
41 ;Orig fill -check if bill # already exists
42 I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1
43 I PSOIB G QUIT
44 ;already attempted to bill, but exceeded Anuual Cap
45 I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",4)>0 G QUIT
46 ;
47 ;Refill -check if bill # already exists
48 I PSOREF,+$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1
49 I PSOIB G QUIT
50 ;already attempted to bill, but exceeded Anuual Cap
51 I PSOREF,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^",2) G QUIT
52 ;
53 ;set temporary variable to copay and then look for exceptions
54 S PSOCHG=1
55 D COPAYREL
56 I 'PSOCHG G QUIT ;not billable
57 I PSOCHG=2 I 'PSOCP G QUIT
58 ; Units for COPAY
59 ;calc number of 30-day units eligible to bill
60 S PSOCPUN=($P(^PSRX(RXP,0),"^",8)+29)\30
61 D ACCUM
62QUIT ;
63 K Y,PSOCP1,PSOCP2,PSOCPN,X,PSOCPUN,PSOREF,PSOCHG,PSOSAVE,PREA,PSORSN
64 Q
65 ;
66COPAYREL ; Recheck copay status at release
67 ;
68 ; check Rx patient status
69 I $P(^PSRX(RXP,0),"^",3)'="",$P($G(^PS(53,$P(^PSRX(RXP,0),"^",3),0)),"^",7)=1 S PSOCHG=0 Q
70 ; see if drug is investigational or supply
71 N DRG,DRGTYP
72 S DRG=+$P(^PSRX(RXP,0),"^",6),DRGTYP=$P($G(^PSDRUG(DRG,0)),"^",3)
73 I DRGTYP["I" S PSOCHG=0 Q
74 I DRGTYP["S" S PSOCHG=0 Q
75 K PSOTG,CHKXTYPE
76 I +$G(^PSRX(RXP,"IBQ")) D XTYPE1^PSOCP1
77 I $G(^PSRX(RXP,"IBQ"))["1" S PSOCHG=0 Q
78 Q
79 ;
80ACCUM ; ACCUMULATE TOTALS AND SEE IF PATIENT MET ANNUAL CAP
81 S PSOYR=$E(PSOREL,1,3) I PSOYR="" Q
82 S PSOYEAR=$S(PSOYR="304":"YR2004",PSOYR="305":"YR2005",1:"")
83 Q:PSOYEAR=""
84 ;
85 ;get Xtmp billing amt which would be IBAM tot + any previous refills
86 S PSOTOT=$G(^XTMP(NAMSP,PSODFN,PSOYEAR))
87 ;
88 ;if none yegt then init to the IBAM total for the year
89 I 'PSOTOT D
90 .F PSOSQ=0:0 S PSOSQ=$O(^IBAM(354.7,PSODFN,1,PSOSQ)) Q:'PSOSQ D
91 ..S PSOLOG=$G(^IBAM(354.7,PSODFN,1,PSOSQ,0))
92 ..I $E(PSOLOG,1,3)=PSOYR S PSOTOT=PSOTOT+$P(PSOLOG,"^",2)
93 ;
94 ;see if current refill added to tot exceeds annual cap and quit
95 I PSOTOT+(7*PSOCPUN)>840 S PSOCAP(PSOYR)=1 Q
96 ;
97 ;update Xtmp tot nodes with current refill amounts
98 S ^XTMP(NAMSP,PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*7)
99 S ^XTMP(NAMSP,PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,PSODFN,PSOYEAR,PSOCPUN))+1
100 ;
101 ;indicate this refill would be billable by adding to Xtmp "BILLED"
102 N PSONAM
103 S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",")
104 S PSONAM=$E(PSONAM,1,6)
105 S ^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOREF)=PSOREL
106 Q
107 ;
108SITE ; SET UP VARIABLES NEEDED BY BILLING
109 S PSOSITE=$S(YY=0:$P(^PSRX(RXP,2),"^",9),1:$P($G(^PSRX(RXP,1,YY,0)),"^",9))
110 Q:PSOSITE=""
111 S PSOPAR=$G(^PS(59,PSOSITE,1))
112 S PSOSITE7=$P($G(^PS(59,PSOSITE,"IB")),"^")
113 Q
114 ;
115RPT ;
116 N NAMSP S NAMSP=$$NAMSP^PSOCPBK1
117 L +^XTMP(NAMSP):0 I '$T D Q
118 . W !,"Copay Tally job for PSO*7*215 is still running. Halting..."
119 L -^XTMP(NAMSP)
120 W !!,"This report shows the patient name and prescription information for refills"
121 W !,"that were indentified as billable by the tally patch PSO*7*215"
122 W !!,"You may queue the report to print, if you wish.",!
123 ;
124DVC K %ZIS,POP,IOP S %ZIS="QM" D ^%ZIS I $G(POP) W !!,"Nothing queued to print.",! G DONE
125QUEUE I $D(IO("Q")) S ZTRTN="START^PSOCPBK2",ZTDESC="Potential Billable copay report" D ^%ZTLOAD K %ZSI W !,"Report queued to print.",! G DONE
126START ;
127 U IO
128 N NAMSP S NAMSP=$$NAMSP^PSOCPBK1
129 S PSOOUT=0,PSODV=$S($E(IOST)="C":"C",1:"P")
130 S PSOPGCT=0,PSOPGLN=IOSL-7,PSOPGCT=1
131 D TITLE
132 S PSONAM=""
133 F S PSONAM=$O(^XTMP(NAMSP,"BILLED",PSONAM)) Q:PSONAM="" D
134 .S PSODFN=""
135 .F S PSODFN=$O(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN)) Q:PSODFN="" D
136 ..S RXP=""
137 ..F S RXP=$O(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP)) Q:RXP="" D
138 ...S PSOFILL=""
139 ...F S PSOFILL=$O(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOFILL)) Q:PSOFILL="" D
140 ....N XX,PSONAME
141 ....S XX=$G(^XTMP(NAMSP,"BILLED",PSONAM,PSODFN,RXP,PSOFILL)) D
142 .....D FULL Q:$G(PSOOUT) S PSONAME=$P($G(^DPT(PSODFN,0)),"^")
143 .....W !,$E(PSONAME,1,14) D PRTSSN
144 .....W ?46," ",RXP," (",PSOFILL,")" D
145 ......S Y=XX I Y>0 X ^DD("DD")
146 ......W ?65," ",Y
147 G END
148 ;
149FULL ;
150 I ($Y+7)>IOSL&('$G(PSOOUT)) D TITLE
151 Q
152 ;
153TITLE ;
154 I $G(PSODV)="C",$G(PSOPGCT)'=1 W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSOOUT=1 Q
155 ;
156 W @IOF D
157 . W !,"Patch PSO*7*215 -COPAY PRESCRIPTION REFILLS BILLABLE"
158 S Y=DT X ^DD("DD") W !,"Date printed: ",Y,?70,"Page: ",PSOPGCT,!
159 F MJT=1:1:79 W "="
160 W !,"PATIENT NAME (SSN) DIV",?48,"RX# (FILL)",?66,"RELEASE DATE"
161 W !,"-------------- ------- ----------------",?47,"------------"
162 W ?66,"------------"
163 S PSOPGCT=PSOPGCT+1
164 Q
165END ;
166 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
167 I $G(PSODV)="C" W !
168 E W @IOF
169DONE ;
170 K MJT,PSOPGCT,PSOPGLN,Y,DIR,X,IOP,POP,IO("Q"),DIRUT,DUOUT,DTOUT
171 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
172 Q
173 ;
174PRTSSN ;
175 S SSN=$P(^DPT(PSODFN,0),"^",9),SSN=$E(SSN,$L(SSN)-3,$L(SSN))
176 S PSOPATID=$E(PSONAM,1)_SSN
177 S PSODIV=$P($G(^PSRX(RXP,2)),"^",9)
178 S:PSODIV'="" PSODIV=$P($G(^PS(59,PSODIV,0)),"^",1)
179 W " ("_PSOPATID_")"_" "_PSODIV
180 Q
181 ;
182ETIME(SECTIME) ;convert seconds to day:hr:min:sec
183 N DAY,HR,MIN,SEC,ETIM
184 S (DAY,HR,MIN,SEC)=""
185 I SECTIME>86400 S DAY=SECTIME\86400,SECTIME=SECTIME#86400
186 I SECTIME>3600 S HR=SECTIME\3600,SECTIME=SECTIME#3600
187 I SECTIME>60 S MIN=SECTIME\60,SECTIME=SECTIME#60
188 S SEC=SECTIME
189 S ETIM=""
190 S:$L(HR)=1 HR=0_HR S:$L(MIN)=1 MIN=0_MIN S:$L(SEC)=1 SEC=0_SEC
191 S:DAY ETIM=DAY_" Day " S:HR ETIM=ETIM_HR_":" S:MIN ETIM=ETIM_MIN
192 S ETIM=ETIM_":"_SEC
193 Q ETIM
194 ;
195MAIL3(MSG) ;
196 S PSOINST=$P($G(^DIC(4,+$P($G(^XMB(1,1,"XUS")),"^",17),99)),"^")
197 D NOW^%DTC S Y=% D DD^%DT S PSOEND=Y
198 K PSOTEXT
199 S XMY(DUZ)=""
200 S XMY("NAPOLIELLO.GREG@FORUM.VA.GOV")=""
201 S XMY("WHITE.ELAINE@FORUM.VA.GOV")=""
202 S:$$PROD^XUPROD(1) XMY("WILLIAMSON.ERIC@FORUM.VA.GOV")=""
203 S XMDUZ="PSO*7*215 TALLY"
204 S XMSUB="STATION "_$G(PSOINST)
205 S XMSUB=XMSUB_$S($$PROD^XUPROD(1):"(Prod)",1:"(Test)")
206 S XMSUB=XMSUB_" UNBILLED COPAYS FOR PRESCRIPTION REFILLS"
207 S PSOTEXT(1)=""
208 S PSOTEXT(2)="Started "_PSOSTART
209 S PSOTEXT(3)=""
210 S PSOTEXT(4)=" "_MSG
211 S XMTEXT="PSOTEXT(" N DIFROM D ^XMD K XMDUZ,XMTEXT,XMSUB
212 Q
Note: See TracBrowser for help on using the repository browser.