PSOCPBA2 ;BIR/EJW-PHARMACY CO-PAY APPLICATION UTILITIES FOR IB ;03/29/03
;;7.0;OUTPATIENT PHARMACY;**137,303,460**;DEC 1997;Build 32
;
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^IBAM(354.7 supported by DBIA 3877
;External reference to $$CPTIER^PSNAPIS(P1,P3) supported by DBIA #2531
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,PSOCOMM,PSOOLD,PSONW,PSODA
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 nutritional supplement, investigational or supply
N DRG,DRGTYP
S DRG=+$P(^PSRX(RXP,0),"^",6),DRGTYP=$P($G(^PSDRUG(DRG,0)),"^",3)
I DRGTYP["I"!(DRGTYP["S")!(DRGTYP["N") 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
;***** begin - for regression test - sites must not use this as it will adversely affect billing results - only used by SQA
; The following is required for testing different effective dates. If date is less than 02/27/17 bills old way. Otherwise bills new way.
;S ^XTMP("PSOTIEREFTST",0)="3201231^3170227^FOR SQA TESTING ONLY" - Defined for SQA testing only. Delete this XTMP when regression complete
D NOW^%DTC N PSOTIERE
S PSOTIERE=1 ;use copay tiers - new
I $P(%,".")<3170227 S PSOTIERE=0 ;legacy billing - old
I $G(^XTMP("PSOTIEREFTST",0)) S PSOTIERE=1 ;for SQA testing only - bill with copay tiers - new
;***** end for regression test
G COPAYRE1:'PSOTIERE
; check copay tier. Tier zero does not have copay charges
N CPDATE,X,PSOCPT D NOW^%DTC S CPDATE=X S PSOCPT=$$CPTIER^PSNAPIS("",CPDATE,DRG) K CPDATE,X
I $P(PSOCPT,"^")=0 S PSOCHG=0 Q ;Tier zero do not send to IB for copay charge
I $P(PSOCPT,"^")'=0 S PSOCOMM="",PSOOLD="No Copay",PSONW="Copay" S PSODA=RXP,PREA="R" D ACTLOG^PSOCPA
COPAYRE1 ;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCPBA2 4896 printed Apr 09, 2024@21:34:41 Page 2
PSOCPBA2 ;BIR/EJW-PHARMACY CO-PAY APPLICATION UTILITIES FOR IB ;03/29/03
+1 ;;7.0;OUTPATIENT PHARMACY;**137,303,460**;DEC 1997;Build 32
+2 ;
+3 ;External reference to ^PSDRUG supported by DBIA 221
+4 ;External reference to ^IBAM(354.7 supported by DBIA 3877
+5 ;External reference to $$CPTIER^PSNAPIS(P1,P3) supported by DBIA #2531
TALLY ;
+1 ; IF NO IB NUMBER FOR THIS FILL, SET UP VARIABLES AND TALLY
+2 SET PSODFN=""
FOR
SET PSODFN=$ORDER(^XTMP("PSOCPBAK",$JOB,PSODFN))
if 'PSODFN
QUIT
Begin DoDot:1
+3 ; EXEMPT OR SC QUESTION APPLIES
IF $GET(^XTMP("PSOCPBAK",$JOB,PSODFN))
QUIT
+4 ; INITIAL ANNUAL CAP FLAG FOR PATIENT FOR 2002 AND 2003
SET (PSOCAP(302),PSOCAP(303))=0
+5 SET RXP=""
FOR
SET RXP=$ORDER(^XTMP("PSOCPBAK",$JOB,PSODFN,RXP))
if 'RXP
QUIT
SET YY=""
FOR
SET YY=$ORDER(^XTMP("PSOCPBAK",$JOB,PSODFN,RXP,YY))
if YY=""
QUIT
Begin DoDot:2
+6 SET PSOREL=$GET(^XTMP("PSOCPBAK",$JOB,PSODFN,RXP,YY))
+7 ; MET ANNUAL CAP FOR 2002 OR 2003
IF PSOCAP($EXTRACT(PSOREL,1,3))
QUIT
+8 IF 'YY
Begin DoDot:3
+9 ; ALREADY BILLED
IF $PIECE($GET(^PSRX(RXP,"IB")),"^",2)'=""
QUIT
+10 DO SITE
+11 DO CP
End DoDot:3
QUIT
+12 ; REFILL LEVEL
IF $PIECE($GET(^PSRX(RXP,1,YY,"IB")),"^",1)=""
Begin DoDot:3
+13 DO SITE
+14 DO CP
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
CP ; Entry point to Check if COPAY - Requires RXP,PSOSITE7
+1 IF '$DATA(PSOPAR)
DO ^PSOLSET
GOTO CP
+2 KILL PSOCP
+3 ; Set COPAY dfn PTR TO PATIENT
SET PSOCPN=$PIECE(^PSRX(RXP,0),"^",2)
+4 ; IB action type
SET PSOCP=$PIECE($GET(^PSRX(RXP,"IB")),"^")
+5 ; save current copay status
SET PSOSAVE=$SELECT(PSOCP:1,1:"")
+6 ; Set x=service^dfn^actiontype^user duz
+7 IF +$GET(PSOSITE7)'>0
SET PSOSITE7=$PIECE(^PS(59,PSOSITE,"IB"),"^")
+8 SET X=PSOSITE7_"^"_PSOCPN_"^"_PSOCP_"^"_$PIECE(^PSRX(RXP,0),"^",16)
+9 ;
RX ; Determine Original or Refill for RX
+1 NEW PSOIB
+2 SET PSOIB=0
+3 SET PSOREF=0
+4 IF $GET(^PSRX(RXP,1,+$GET(YY),0))]""
SET PSOREF=YY
+5 ; Check if bill # already exists for this RX or Refill
+6 IF 'PSOREF
IF +$PIECE($GET(^PSRX(RXP,"IB")),"^",2)>0
DO CHKIB^PSOCP1
IF PSOIB
GOTO QUIT
+7 ; 'POTENTIAL BILL' - ALREADY ATTEMPTED TO BILL, BUT EXCEEDED ANNUAL COPAY CAP
IF 'PSOREF
IF +$PIECE($GET(^PSRX(RXP,"IB")),"^",4)>0
GOTO QUIT
+8 IF PSOREF
IF +$GET(^PSRX(RXP,1,PSOREF,"IB"))
DO CHKIB^PSOCP1
IF PSOIB
GOTO QUIT
+9 ; POTENTIAL BILL
IF PSOREF
IF +$PIECE($GET(^PSRX(RXP,1,PSOREF,"IB")),"^",2)
GOTO QUIT
+10 ; set temporary variable to copay and then look for exceptions
SET PSOCHG=1
+11 DO COPAYREL
+12 ; NOT BILLABLE
IF 'PSOCHG
GOTO QUIT
+13 IF PSOCHG=2
IF 'PSOCP
GOTO QUIT
+14 ; Units for COPAY
+15 ; NUMBER OF 30-DAY UNITS ELIGIBLE TO BILL
SET PSOCPUN=$PIECE(($PIECE(^PSRX(RXP,0),"^",8)+29)/30,".",1)
+16 DO ACCUM
QUIT ;
+1 KILL Y,PSOCP1,PSOCP2,QQ,PSOCPN,X,PSOCPUN,PSOREF,PSOCHG,PSOSAVE,PREA,PSORSN,PSOCOMM,PSOOLD,PSONW,PSODA
+2 QUIT
+3 ;
COPAYREL ; Recheck copay status at release
+1 ;
+2 ; check Rx patient status
+3 IF $PIECE(^PSRX(RXP,0),"^",3)'=""
IF $PIECE($GET(^PS(53,$PIECE(^PSRX(RXP,0),"^",3),0)),"^",7)=1
SET PSOCHG=0
QUIT
+4 ; see if drug is nutritional supplement, investigational or supply
+5 NEW DRG,DRGTYP
+6 SET DRG=+$PIECE(^PSRX(RXP,0),"^",6)
SET DRGTYP=$PIECE($GET(^PSDRUG(DRG,0)),"^",3)
+7 IF DRGTYP["I"!(DRGTYP["S")!(DRGTYP["N")
SET PSOCHG=0
QUIT
+8 KILL PSOTG,CHKXTYPE
+9 IF +$GET(^PSRX(RXP,"IBQ"))
DO XTYPE1^PSOCP1
+10 IF $GET(^PSRX(RXP,"IBQ"))["1"
SET PSOCHG=0
QUIT
+11 ;***** begin - for regression test - sites must not use this as it will adversely affect billing results - only used by SQA
+12 ; The following is required for testing different effective dates. If date is less than 02/27/17 bills old way. Otherwise bills new way.
+13 ;S ^XTMP("PSOTIEREFTST",0)="3201231^3170227^FOR SQA TESTING ONLY" - Defined for SQA testing only. Delete this XTMP when regression complete
+14 DO NOW^%DTC
NEW PSOTIERE
+15 ;use copay tiers - new
SET PSOTIERE=1
+16 ;legacy billing - old
IF $PIECE(%,".")<3170227
SET PSOTIERE=0
+17 ;for SQA testing only - bill with copay tiers - new
IF $GET(^XTMP("PSOTIEREFTST",0))
SET PSOTIERE=1
+18 ;***** end for regression test
+19 if 'PSOTIERE
GOTO COPAYRE1
+20 ; check copay tier. Tier zero does not have copay charges
+21 NEW CPDATE,X,PSOCPT
DO NOW^%DTC
SET CPDATE=X
SET PSOCPT=$$CPTIER^PSNAPIS("",CPDATE,DRG)
KILL CPDATE,X
+22 ;Tier zero do not send to IB for copay charge
IF $PIECE(PSOCPT,"^")=0
SET PSOCHG=0
QUIT
+23 IF $PIECE(PSOCPT,"^")'=0
SET PSOCOMM=""
SET PSOOLD="No Copay"
SET PSONW="Copay"
SET PSODA=RXP
SET PREA="R"
DO ACTLOG^PSOCPA
COPAYRE1 ;
+1 QUIT
+2 ;
ACCUM ; ACCUMULATE TOTALS AND SEE IF PATIENT MET ANNUAL CAP
+1 SET PSOYR=$EXTRACT(PSOREL,1,3)
IF PSOYR=""
QUIT
+2 SET PSOYEAR=$SELECT(PSOYR="302":"YR2002",PSOYR="303":"YR2003",1:"")
IF PSOYEAR=""
QUIT
+3 SET PSOTOT=$GET(^XTMP("PSOCPBAK",$JOB,PSODFN,PSOYEAR))
+4 IF 'PSOTOT
Begin DoDot:1
+5 SET PSOSQ=""
FOR
SET PSOSQ=$ORDER(^IBAM(354.7,PSODFN,1,PSOSQ))
if 'PSOSQ
QUIT
SET PSOLOG=$GET(^IBAM(354.7,PSODFN,1,PSOSQ,0))
IF $EXTRACT(PSOLOG,1,3)=PSOYR
Begin DoDot:2
+6 SET PSOTOT=PSOTOT+$PIECE(PSOLOG,"^",2)
End DoDot:2
End DoDot:1
+7 ; BILLING FOR THIS WOULD EXCEED ANNUAL CAP
IF PSOTOT+(7*PSOCPUN)>840
SET PSOCAP(PSOYR)=1
QUIT
+8 SET ^XTMP("PSOCPBAK",$JOB,PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*7)
+9 SET ^XTMP("PSOCPBAK",$JOB,PSODFN,PSOYEAR,PSOCPUN)=$GET(^XTMP("PSOCPBAK",$JOB,PSODFN,PSOYEAR,PSOCPUN))+1
+10 QUIT
+11 ;
SITE ; SET UP VARIABLES NEEDED BY BILLING
+1 SET PSOSITE=$SELECT(YY=0:$PIECE(^PSRX(RXP,2),"^",9),1:$PIECE($GET(^PSRX(RXP,1,YY,0)),"^",9))
+2 IF PSOSITE=""
QUIT
+3 SET PSOPAR=$GET(^PS(59,PSOSITE,1))
+4 SET PSOSITE7=$PIECE($GET(^PS(59,PSOSITE,"IB")),"^")
+5 QUIT
