source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPBA2.m@ 785

PSOCPBA2 ;BIR/EJW-PHARMACY CO-PAY APPLICATION UTILITIES FOR IB ; 03/29/03
 ;;7.0;OUTPATIENT PHARMACY;**137**;DEC 1997
 ;
 ;External reference to ^PSDRUG supported by DBIA 221
 ;External reference to ^IBAM(354.7 supported by DBIA 3877
TALLY ;
 ; IF NO IB NUMBER FOR THIS FILL, SET UP VARIABLES AND TALLY
 S PSODFN="" F  S PSODFN=$O(^XTMP("PSOCPBAK",$J,PSODFN)) Q:'PSODFN  D
 .I $G(^XTMP("PSOCPBAK",$J,PSODFN)) Q  ; EXEMPT OR SC QUESTION APPLIES
 .S (PSOCAP(302),PSOCAP(303))=0 ; INITIAL ANNUAL CAP FLAG FOR PATIENT FOR 2002 AND 2003
 .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
 ..S PSOREL=$G(^XTMP("PSOCPBAK",$J,PSODFN,RXP,YY))
 ..I PSOCAP($E(PSOREL,1,3)) Q  ; MET ANNUAL CAP FOR 2002 OR 2003
 ..I 'YY D  Q
 ...I $P($G(^PSRX(RXP,"IB")),"^",2)'="" Q  ; ALREADY BILLED
 ...D SITE
 ...D CP
 ..I $P($G(^PSRX(RXP,1,YY,"IB")),"^",1)="" D  ; REFILL LEVEL
 ...D SITE
 ...D CP
 Q
 ;
CP ; Entry point to Check if COPAY  -   Requires RXP,PSOSITE7
 I '$D(PSOPAR) D ^PSOLSET G CP
 K PSOCP
 S PSOCPN=$P(^PSRX(RXP,0),"^",2) ; Set COPAY dfn PTR TO PATIENT
 S PSOCP=$P($G(^PSRX(RXP,"IB")),"^") ; IB action type
 S PSOSAVE=$S(PSOCP:1,1:"") ; save current copay status
 ;         Set x=service^dfn^actiontype^user duz
 I +$G(PSOSITE7)'>0 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^")
 S X=PSOSITE7_"^"_PSOCPN_"^"_PSOCP_"^"_$P(^PSRX(RXP,0),"^",16)
 ;
RX ;         Determine Original or Refill for RX
 N PSOIB
 S PSOIB=0
 S PSOREF=0
 I $G(^PSRX(RXP,1,+$G(YY),0))]"" S PSOREF=YY
 ;         Check if bill # already exists for this RX or Refill
 I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 I PSOIB G QUIT
 I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",4)>0 G QUIT ; 'POTENTIAL BILL' - ALREADY ATTEMPTED TO BILL, BUT EXCEEDED ANNUAL COPAY CAP
 I PSOREF,+$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1 I PSOIB G QUIT
 I PSOREF,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^",2) G QUIT ; POTENTIAL BILL
 S PSOCHG=1 ; set temporary variable to copay and then look for exceptions
 D COPAYREL
 I 'PSOCHG G QUIT ; NOT BILLABLE
 I PSOCHG=2 I 'PSOCP G QUIT
 ;         Units for COPAY
 S PSOCPUN=$P(($P(^PSRX(RXP,0),"^",8)+29)/30,".",1) ; NUMBER OF 30-DAY UNITS ELIGIBLE TO BILL
 D ACCUM
QUIT ;
 K Y,PSOCP1,PSOCP2,QQ,PSOCPN,X,PSOCPUN,PSOREF,PSOCHG,PSOSAVE,PREA,PSORSN
 Q
 ;
COPAYREL ; Recheck copay status at release
 ;
 ; check Rx patient status
 I $P(^PSRX(RXP,0),"^",3)'="",$P($G(^PS(53,$P(^PSRX(RXP,0),"^",3),0)),"^",7)=1 S PSOCHG=0 Q
 ; see if drug is investigational or supply
 N DRG,DRGTYP
 S DRG=+$P(^PSRX(RXP,0),"^",6),DRGTYP=$P($G(^PSDRUG(DRG,0)),"^",3)
 I DRGTYP["I" S PSOCHG=0 Q
 I DRGTYP["S" S PSOCHG=0 Q
 K PSOTG,CHKXTYPE
 I +$G(^PSRX(RXP,"IBQ")) D XTYPE1^PSOCP1
 I $G(^PSRX(RXP,"IBQ"))["1" S PSOCHG=0 Q
 Q
 ;
ACCUM ; ACCUMULATE TOTALS AND SEE IF PATIENT MET ANNUAL CAP
 S PSOYR=$E(PSOREL,1,3) I PSOYR="" Q
 S PSOYEAR=$S(PSOYR="302":"YR2002",PSOYR="303":"YR2003",1:"") I PSOYEAR="" Q
 S PSOTOT=$G(^XTMP("PSOCPBAK",$J,PSODFN,PSOYEAR))
 I 'PSOTOT D
 .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
 ..S PSOTOT=PSOTOT+$P(PSOLOG,"^",2)
 I PSOTOT+(7*PSOCPUN)>840 S PSOCAP(PSOYR)=1 Q  ; BILLING FOR THIS WOULD EXCEED ANNUAL CAP
 S ^XTMP("PSOCPBAK",$J,PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*7)
 S ^XTMP("PSOCPBAK",$J,PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP("PSOCPBAK",$J,PSODFN,PSOYEAR,PSOCPUN))+1
 Q
 ;
SITE ; SET UP VARIABLES NEEDED BY BILLING
 S PSOSITE=$S(YY=0:$P(^PSRX(RXP,2),"^",9),1:$P($G(^PSRX(RXP,1,YY,0)),"^",9))
 I PSOSITE="" Q
 S PSOPAR=$G(^PS(59,PSOSITE,1))
 S PSOSITE7=$P($G(^PS(59,PSOSITE,"IB")),"^")
 Q