source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPBA2.m@ 1144

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

initial load of WorldVistAEHR

File size: 3.5 KB
Line 
1PSOCPBA2 ;BIR/EJW-PHARMACY CO-PAY APPLICATION UTILITIES FOR IB ; 03/29/03
2 ;;7.0;OUTPATIENT PHARMACY;**137**;DEC 1997
3 ;
4 ;External reference to ^PSDRUG supported by DBIA 221
5 ;External reference to ^IBAM(354.7 supported by DBIA 3877
6TALLY ;
7 ; IF NO IB NUMBER FOR THIS FILL, SET UP VARIABLES AND TALLY
8 S PSODFN="" F S PSODFN=$O(^XTMP("PSOCPBAK",$J,PSODFN)) Q:'PSODFN D
9 .I $G(^XTMP("PSOCPBAK",$J,PSODFN)) Q ; EXEMPT OR SC QUESTION APPLIES
10 .S (PSOCAP(302),PSOCAP(303))=0 ; INITIAL ANNUAL CAP FLAG FOR PATIENT FOR 2002 AND 2003
11 .S RXP="" F S RXP=$O(^XTMP("PSOCPBAK",$J,PSODFN,RXP)) Q:'RXP S YY="" F S YY=$O(^XTMP("PSOCPBAK",$J,PSODFN,RXP,YY)) Q:YY="" D
12 ..S PSOREL=$G(^XTMP("PSOCPBAK",$J,PSODFN,RXP,YY))
13 ..I PSOCAP($E(PSOREL,1,3)) Q ; MET ANNUAL CAP FOR 2002 OR 2003
14 ..I 'YY D Q
15 ...I $P($G(^PSRX(RXP,"IB")),"^",2)'="" Q ; ALREADY BILLED
16 ...D SITE
17 ...D CP
18 ..I $P($G(^PSRX(RXP,1,YY,"IB")),"^",1)="" D ; REFILL LEVEL
19 ...D SITE
20 ...D CP
21 Q
22 ;
23CP ; Entry point to Check if COPAY - Requires RXP,PSOSITE7
24 I '$D(PSOPAR) D ^PSOLSET G CP
25 K PSOCP
26 S PSOCPN=$P(^PSRX(RXP,0),"^",2) ; Set COPAY dfn PTR TO PATIENT
27 S PSOCP=$P($G(^PSRX(RXP,"IB")),"^") ; IB action type
28 S PSOSAVE=$S(PSOCP:1,1:"") ; save current copay status
29 ; Set x=service^dfn^actiontype^user duz
30 I +$G(PSOSITE7)'>0 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^")
31 S X=PSOSITE7_"^"_PSOCPN_"^"_PSOCP_"^"_$P(^PSRX(RXP,0),"^",16)
32 ;
33RX ; Determine Original or Refill for RX
34 N PSOIB
35 S PSOIB=0
36 S PSOREF=0
37 I $G(^PSRX(RXP,1,+$G(YY),0))]"" S PSOREF=YY
38 ; Check if bill # already exists for this RX or Refill
39 I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 I PSOIB G QUIT
40 I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",4)>0 G QUIT ; 'POTENTIAL BILL' - ALREADY ATTEMPTED TO BILL, BUT EXCEEDED ANNUAL COPAY CAP
41 I PSOREF,+$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1 I PSOIB G QUIT
42 I PSOREF,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^",2) G QUIT ; POTENTIAL BILL
43 S PSOCHG=1 ; set temporary variable to copay and then look for exceptions
44 D COPAYREL
45 I 'PSOCHG G QUIT ; NOT BILLABLE
46 I PSOCHG=2 I 'PSOCP G QUIT
47 ; Units for COPAY
48 S PSOCPUN=$P(($P(^PSRX(RXP,0),"^",8)+29)/30,".",1) ; NUMBER OF 30-DAY UNITS ELIGIBLE TO BILL
49 D ACCUM
50QUIT ;
51 K Y,PSOCP1,PSOCP2,QQ,PSOCPN,X,PSOCPUN,PSOREF,PSOCHG,PSOSAVE,PREA,PSORSN
52 Q
53 ;
54COPAYREL ; Recheck copay status at release
55 ;
56 ; check Rx patient status
57 I $P(^PSRX(RXP,0),"^",3)'="",$P($G(^PS(53,$P(^PSRX(RXP,0),"^",3),0)),"^",7)=1 S PSOCHG=0 Q
58 ; see if drug is investigational or supply
59 N DRG,DRGTYP
60 S DRG=+$P(^PSRX(RXP,0),"^",6),DRGTYP=$P($G(^PSDRUG(DRG,0)),"^",3)
61 I DRGTYP["I" S PSOCHG=0 Q
62 I DRGTYP["S" S PSOCHG=0 Q
63 K PSOTG,CHKXTYPE
64 I +$G(^PSRX(RXP,"IBQ")) D XTYPE1^PSOCP1
65 I $G(^PSRX(RXP,"IBQ"))["1" S PSOCHG=0 Q
66 Q
67 ;
68ACCUM ; ACCUMULATE TOTALS AND SEE IF PATIENT MET ANNUAL CAP
69 S PSOYR=$E(PSOREL,1,3) I PSOYR="" Q
70 S PSOYEAR=$S(PSOYR="302":"YR2002",PSOYR="303":"YR2003",1:"") I PSOYEAR="" Q
71 S PSOTOT=$G(^XTMP("PSOCPBAK",$J,PSODFN,PSOYEAR))
72 I 'PSOTOT D
73 .S PSOSQ="" F S PSOSQ=$O(^IBAM(354.7,PSODFN,1,PSOSQ)) Q:'PSOSQ S PSOLOG=$G(^IBAM(354.7,PSODFN,1,PSOSQ,0)) I $E(PSOLOG,1,3)=PSOYR D
74 ..S PSOTOT=PSOTOT+$P(PSOLOG,"^",2)
75 I PSOTOT+(7*PSOCPUN)>840 S PSOCAP(PSOYR)=1 Q ; BILLING FOR THIS WOULD EXCEED ANNUAL CAP
76 S ^XTMP("PSOCPBAK",$J,PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*7)
77 S ^XTMP("PSOCPBAK",$J,PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP("PSOCPBAK",$J,PSODFN,PSOYEAR,PSOCPUN))+1
78 Q
79 ;
80SITE ; SET UP VARIABLES NEEDED BY BILLING
81 S PSOSITE=$S(YY=0:$P(^PSRX(RXP,2),"^",9),1:$P($G(^PSRX(RXP,1,YY,0)),"^",9))
82 I PSOSITE="" Q
83 S PSOPAR=$G(^PS(59,PSOSITE,1))
84 S PSOSITE7=$P($G(^PS(59,PSOSITE,"IB")),"^")
85 Q
Note: See TracBrowser for help on using the repository browser.