PSOCPB ;BIR/BaB - pharmacy co-pay application cont'd ;1/30/07 9:08am
;;7.0;OUTPATIENT PHARMACY;**72,71,85,185,143,219,239,201,263,303,431,476,463,514**;DEC 1997;Build 32
;
;REF/IA
;DIS^SDROUT2/112
;^IBARX/125
;VADPT/10061
;SWSTAT^IBBAPI/4663
;Reference to $$CPTIER^PSNAPIS(P1,P3) supported by DBIA #2531
COPAY ;
;Called by PSON52,PSORN52...Requires PSOCPAY,PSOBILL,DEA=PSDEA,PSOFLAG
;PSOFLAG=1 NEW, PSOFLAG=0 RENEW
S PSOSAVE=PSOCPAY ; Save original status of PSOCPAY
I '$G(PSOSCP)!('$G(PSOSCA)) D SCP^PSORN52D ;CIDC-must ask sc if flagged for it in enrollment
I $G(PSODRUG("DEA"))["S"!($G(PSODRUG("DEA"))["I")!($G(PSODRUG("DEA"))["N") S PSOCPAY=0
G:+PSOBILL'=2&('$G(PSOSCA)) COPAY2
D FULL^VALM1
I $G(PSOMESOI)=1,$G(PSORXED) W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESOI=2
I $G(PSOMESFI)=1 W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESFI=2
S DFN=+$G(PSODFN) D CHKPAG^PSOMLLD2,DISSCD^PSOMLLD2 ;*514
ASK ;
N PSOUFLAG S PSOUFLAG=0
K PSOCPZ("DFLG"),PSONEW("NEWCOPAY")
W ! K DIR,DTOUT,DIRUT,DUOUT
I $G(PSORX("SC"))="SC"!($G(PSORX("SC"))="NSC")!($G(PSOSCOTH)) D
.W:PSOSCP<50&($G(PSODRUG("DEA"))'["S")&($G(PSODRUG("DEA"))'["I")&($G(PSODRUG("DEA"))'["N") !,"This Rx has been flagged by the provider as: "_$S($G(PSOSCOTH):"NO COPAY",$G(PSORX("SC"))="SC":"NO COPAY",1:"COPAY"),!
.I $G(PSOSCOTX) S PSOSCOTX=2
S DIR("A")="Was treatment for Service Connected condition",DIR(0)="Y"
S DIR("?")="Enter 'Yes' if this prescription is for a Service Connected condition"
I $G(PSORX("SC"))]""!($G(PSORX(+$G(PSORENW("OIRXN")),"SC"))'="") S DIR("B")=$S($G(PSORX("SC"))="SC":"YES",$G(PSORX("SC"))="NSC":"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=1:"YES",$G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=0:"NO",1:"")
I $G(PSONEWFF),$G(PSOFLAG) I $G(PSOANSQD("SC"))=0!($G(PSOANSQD("SC"))=1) S DIR("B")=$S($G(PSOANSQD("SC"))=1:"YES",1:"NO")
I $G(DIR("B"))="YES"!($G(DIR("B"))="NO") S PSOUFLAG=$G(DIR("B"))
I $G(DIR("B"))="" K DIR("B")
D ^DIR
I $G(Y)=1!($G(Y)=0) S PSOANSQ("SC")=$G(Y) I $G(PSONEWFF),$G(PSOFLAG) S PSOANSQD("SC")=$G(Y)
I PSOFLAG I Y["^"!($D(DTOUT))!($D(DUOUT)) S PSOCPZ("DFLG")=1
S:Y=0 Y=2
S PSOANSR=+Y I 'PSOANSR,'PSOFLAG D S $P(PSOCPAY,"^")=$S($G(PSOUFLAG)="NO":1,1:0) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR G COPAY2
.W !!,"This Renewal has been designated as "_$S($G(PSOUFLAG)="YES":"SERVICE CONNECTED",1:"NON-SERVICE CONNECTED.")
.W:PSOSCP<50&($G(PSODRUG("DEA"))'["S")&($G(PSODRUG("DEA"))'["I")&($G(PSODRUG("DEA"))'["N") !,"Please use the 'Reset Copay Status/Cancel Charges' option to make corrections."
.S PSOANSQ("SC")=$S($G(PSOUFLAG)="YES":1,1:0)
I $G(PSOFLAG),$G(PSOCPZ("DFLG")) G EXIT
S:PSOANSR=1 PSOCPAY=0 S:PSOANSR=2 $P(PSOCPAY,"^")=1
COPAY2 ;
N PSOPFS S PSOPFS=$$SWSTAT^IBBAPI()
;***** begin - for regression test FMCT - 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 COPAY21:'PSOTIERE
;Check copay tier. Tier zero does not have copay charges. Tier billing will be effective 2/27/17 and IB rate table decides what amount to bill based on rate effective date
N CPDATE,X,PSOCPT D NOW^%DTC S CPDATE=X,PSOCPT=$$CPTIER^PSNAPIS("",CPDATE,PSODRUG("IEN")) K CPDATE,X
I $P(PSOCPT,"^")=0 S PSOCHG=0 K PSONEW("NEWCOPAY") G EXIT ;Tier zero do not send to IB for copay charge
;
COPAY21 I +PSOCPAY=1,($P(PSOCPAY,"^",2)=1)!($P(PSOCPAY,"^",2)=2) D
.;set IB node in ^PSRX for copay if xactn type is 1 or 2
.S PSONEW("NEWCOPAY")=$P($G(PSOCPAY),"^",2)_"^^"_$S(+$G(PSOPFS):"",1:$P($G(PSOCPAY),"^",2))
EXIT ;
S PSOCPAY=PSOSAVE ;Restore val of PSOCPAY
K PSOSAVE,PSOANSR,DIR,DUOUT,DIRUT,DTOUT,Y,X
Q
RESET ;RESET COPAY STATUS
K PSOSUMM,PSOPFS,PSOPFSA,PSOLFIL,PSOPFSG
I '$D(PSOPAR) D ^PSOLSET G RESET
W ! S DIC="^PSRX(",DIC(0)="AEQZ" D ^DIC K DIC G:Y<0 EXT S PSODA=+Y
W !,?17,"PATIENT: ",$P($G(^DPT($P(^PSRX(PSODA,0),"^",2),0)),"^")
D ICN^PSODPT($P(^PSRX(PSODA,0),"^",2))
S PSORXN=$P(^PSRX(PSODA,0),"^"),PREA="R"
S PCOPAY=$G(^PSRX(PSODA,"IB"))
W !!,"Rx # ",PSORXN," is a ",$S(+PCOPAY:"Copay",1:"No Copay")," prescription"
S PSOLFIL=$$LF^PSOPFSU1(PSODA) D PFSA^PSOPFSU1(PSODA,PSOLFIL,3) ;PSOCPC def PSOPFSA=1 if OP SC/EI's change.
D EXEMCHK^PSOCPC ; CHECK/CHANGE EXEMPTION FLAGS
S PSOIBQ=$G(^PSRX(PSODA,"IBQ"))
I '$G(^PSRX(PSODA,"IB")),PSOIBQ'["1" D G ASKCAN
. K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")="Do you want to reset the status to COPAY" D ^DIR K DIR
. I Y'=1 Q
. S DIC="^IBE(350.3,",DIC("S")="I $P(^(0),U,3)'=2",DIC(0)="AEQMZ",DIC("A")="Select Reason for Reset : " D ^DIC K DIC I Y'<0 S PSORSN=+Y
. S PREA="R",PSOOLD="No Copay",PSONW="Copay",PSOCOMM="" D ACTLOG^PSOCPA
. S PSI=0,PSOCOMM="Copay status of this Rx has been reset to COPAY." D SETSUMM^PSOCPC
. S $P(^PSRX(PSODA,"IB"),"^")=1 ;Reset flag to COPAY
;
I $G(^PSRX(PSODA,"IB")) D G ASKCAN
. K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")="Do you want to reset the status to NO COPAYMENT" D ^DIR K DIR
. I Y'=1 Q
. S DIC="^IBE(350.3,",DIC("S")="I $P(^(0),U,3)'=2",DIC(0)="AEQMZ",DIC("A")="Select Reason for Reset : " D ^DIC K DIC I Y'<0 S PSORSN=+Y
. S PREA="R",PSOOLD="Copay",PSONW="No Copay",PSOCOMM="" D ACTLOG^PSOCPA
. S PSI=0,PSOCOMM="Copay status of this Rx has been reset to NO COPAY." D SETSUMM^PSOCPC
. S $P(^PSRX(PSODA,"IB"),"^")="" ;Reset flag to NO COPAY
ASKCAN D ASKCAN^PSOCPD
I '$D(PSOSUMM) S PSI=0,PSOCOMM="No action taken" D SETSUMM^PSOCPC
D PRTSUMM
;I $P($G(PSOPFS),"^",3)>0&(+$G(PSOPFSA)) D CHRG^PSOPFSU1(PSODA,PSOLFIL,"CG",PSOPFS)
RESETE K PSODA,PSORXN,PSORSN,PSOREF,X,Y,PCOPAY,PREA,PSOCOMM,PSI
G RESET
EXT K PSODA,PSORXN,PSORSN,PSOREF,X,Y,PCOPAY,PREA,PSOCOPAY
Q
BILLED ;Collect IB nums,cancel chrgs,reset flag.
W !!,"**********Charges are on file for this Rx.**********"
Q
BILL2 ;
N PSOPREV ; VAR FOR PREV CANCELLED
S PSOPREV=0
S DIC="^IBE(350.3,",DIC("S")="I $P(^(0),U,3)'=2",DIC(0)="AEQMZ",DIC("A")="Select Reason for Reset or Charge Cancellation : " D ^DIC K DIC G ENDMSG:Y<0 S PSORSN=+Y
S X=PSOPAR7_"^"_+$P(^PSRX(PSODA,0),"^",2)_"^^"_DUZ
S SAVX=X
I $D(PSOCAN) D:'$G(PSOPFS) I +$G(PSOPFS)!($G(PSOPFSG)) D PFS^PSOPFSU1 G BILL2END:'$D(PSOCAN)
. N III S III="" F S III=$O(PSOCAN(III)) Q:III="" I PSOCAN(III)["PFS" S PSOPFSG=1 Q ;PFSS switch off, check for prev cots billing
D POTBILL2
I '$D(PSOCAN) G BILL2END
I $G(CANTYPE) D PREVCAN I $O(X(""))="" Q
I '$G(CANTYPE) S I="" F S I=$O(PSOCAN(I)) Q:I="" S X($P(PSOCAN(I),"^",1))=$P(PSOCAN(I),"^",2)_"^"_PSORSN
D CANCEL^IBARX
I $G(CANTYPE) D MSG
I '$D(Y) Q
I +Y=-1 Q
I $D(Y(PSORXN)),+Y(PSORXN)'=-1 S $P(^PSRX(PSODA,"IB"),"^",2)=+Y(PSORXN) K Y(PSORXN) S PREA="C",PSOREF=0,PSOOLD="",PSONW="" D ACTLOG^PSOCPA I '$G(CANTYPE) D MSG
F PSOREF=0:0 S PSOREF=$O(Y(PSOREF)) Q:PSOREF="" I +Y(PSOREF)'=-1 S ^PSRX(PSODA,1,PSOREF,"IB")=+Y(PSOREF) S PREA="C",PSOOLD="",PSONW="" D ACTLOG^PSOCPA I '$G(CANTYPE) D MSG
BILL2END K X,Y,SAVX,PSOREF,PSOCAN
Q
;
POTBILL2 ;see if any potential charges (entries from file 354.71 -- bills that exceeded cap prev) to be cancelled before cancelling regular charges
N X,I
S X=SAVX
I $T(CANIBAM^IBARX)="" Q
S I="" F S I=$O(PSOCAN(I)) Q:I="" I PSOCAN(I)["^CAP" S X($P(PSOCAN(I),"^",1))=$P(PSOCAN(I),"^",2)_"^"_PSORSN K PSOCAN(I)
I $O(X(""))="" Q
S PSOPREV=1
D CANIBAM^IBARX
I $D(X(PSORXN)) S $P(^PSRX(PSODA,"IB"),"^",4)="" S PREA="C",PSOREF=0,PSOCOMM="Potential charge cancelled",PSOOLD="",PSONW="" D ACTLOG^PSOCPA D POTMSG K X(PSORXN)
F PSOREF=0:0 S PSOREF=$O(X(PSOREF)) Q:PSOREF="" Q:PSOREF>11 S $P(^PSRX(PSODA,1,PSOREF,"IB"),"^",2)="" S PREA="C",PSOCOMM="Potential charge cancelled",PSOOLD="",PSONW="" D ACTLOG^PSOCPA D POTMSG
K PSOREF,PREA,PSOCOMM
Q
REFILL S PSOREF=0
F S PSOREF=$O(^PSRX(PSODA,1,PSOREF)) Q:PSOREF'?1N.N D
. I $D(^PSRX(PSODA,1,PSOREF,"PFS")) S:$P($G(^PSRX(PSODA,1,PSOREF,"PFS")),"^",2) X(PSOREF)="^"_$G(PSORSN) Q
. I $D(^PSRX(PSODA,1,PSOREF,"IB")),+^("IB")>0 S X(PSOREF)=+^PSRX(PSODA,1,PSOREF,"IB")_"^"_$G(PSORSN)
S PSOREF=0 F S PSOREF=$O(^PSRX(PSODA,1,PSOREF)) Q:PSOREF'?1N.N I '$D(X(PSOREF)),+$P($G(^PSRX(PSODA,1,PSOREF,"IB")),"^",2) S XX(PSOREF)=+$P(^PSRX(PSODA,1,PSOREF,"IB"),"^",2)_"^"_$G(PSORSN) ; IF ONLY ENTRY FROM 354.71 SAVE IT
Q
SETCP ;IF NOT COPAY MAKE ELIG CALL/SET FLAG FOR FUTURE
W ! S X=PSOPAR7_"^"_+$P(^PSRX(PSODA,0),"^",2)
D XTYPE^IBARX
I +Y=-1 W !!,"Error in processing Copay eligibility, no action taken." Q
S (ACTYP,BL)="",(PSOBILL,PSOCPAY)=0
CP ;
S ACTYP=$O(Y(ACTYP)) G:'ACTYP CP1
F I=0:0 S BL=$O(Y(ACTYP,BL)) Q:BL="" I BL>0 S PSOBILL=BL,PSOCPAY=ACTYP
G CP
CP1 K ACTYP,BL,I
I (PSOBILL'>0)!(PSOCPAY=0) G INELIG
S $P(^PSRX(PSODA,"IB"),"^")=PSOCPAY
W !,"COPAY status on this Rx has been reset.",!,"*** Future refills will be classified as COPAY."
S PREA="R",PSOOLD="No Copay",PSONW="Copay"
D ACTLOG^PSOCPA
Q
INELIG W !,"This Rx does not meet patient eligibility requirement for Copay.",!,"****** Status unchanged *******"
S Y=-1
Q
ENDMSG K X W !,"Unable to process CHARGE REMOVAL without REASON for Reset."
R !,"ENTER a REASON now? (Y/N) ",X:DTIME Q:'$T
I ($E(X)["?")!("YyNn^"'[$E(X)) W !,"Enter YES to select REASON and RESET STATUS." G ENDMSG
I "Yy"[$E(X) G BILL2
Q
MSG ;
S PSI=0
I $G(CANTYPE) S PSOCOMM="Rx # "_PSORXN_" - All copay charges cancelled" D SETSUMM^PSOCPC K PSOCOMM Q
S PSOCOMM="Rx # "_PSORXN_" - "_$S(PSOREF=0:"Original fill",1:"Refill "_PSOREF)_" copay charge cancelled"
D SETSUMM^PSOCPC
K PSOCOMM
Q
POTMSG ;
S PSI=0
I $G(CANTYPE) Q ; (MESSAGE WILL GET SET LATER)
S PSOCOMM="Rx # "_PSORXN_" - "_$S(PSOREF=0:"Original fill",1:"Refill "_PSOREF)_" potential copay charge cancelled"
D SETSUMM^PSOCPC
K PSOCOMM
Q
MSGNOCAN ;
S PSI=0
S PSOCOMM="Rx # "_PSORXN_" - All copay charges have already been cancelled." D SETSUMM^PSOCPC K PSOCOMM
Q
;
PRTSUMM ; prt sum of actions in reset/cancel
I '$D(PSOSUMM) Q
W !
S PSI=""
F S PSI=$O(PSOSUMM(PSI)) Q:PSI="" W !,PSOSUMM(PSI)
K PSOSUMM
Q
PREVCAN ; PREVIEW CANCELS IF "ALL" IS SELECTED
N I,PSOBILL
S I="" F S I=$O(PSOCAN(I)) Q:I="" D I PSOBILL S X($P(PSOCAN(I),"^",1))=$P(PSOCAN(I),"^",2)_"^"_PSORSN
. S PSOBILL=1 I $T(STATUS^IBARX)'="" I PSOCAN(I)'["CAP" S PSOBILL=$$STATUS^IBARX($P(PSOCAN(I),"^",2)) S:PSOBILL=2 PSOBILL=0 ; PREVIOUSLY CANCELLED
I $O(X(""))="" D
. I PSOPREV D MSG Q
. D MSGNOCAN
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCPB 11157 printed Apr 09, 2024@21:25:25 Page 2
PSOCPB ;BIR/BaB - pharmacy co-pay application cont'd ;1/30/07 9:08am
+1 ;;7.0;OUTPATIENT PHARMACY;**72,71,85,185,143,219,239,201,263,303,431,476,463,514**;DEC 1997;Build 32
+2 ;
+3 ;REF/IA
+4 ;DIS^SDROUT2/112
+5 ;^IBARX/125
+6 ;VADPT/10061
+7 ;SWSTAT^IBBAPI/4663
+8 ;Reference to $$CPTIER^PSNAPIS(P1,P3) supported by DBIA #2531
COPAY ;
+1 ;Called by PSON52,PSORN52...Requires PSOCPAY,PSOBILL,DEA=PSDEA,PSOFLAG
+2 ;PSOFLAG=1 NEW, PSOFLAG=0 RENEW
+3 ; Save original status of PSOCPAY
SET PSOSAVE=PSOCPAY
+4 ;CIDC-must ask sc if flagged for it in enrollment
IF '$GET(PSOSCP)!('$GET(PSOSCA))
DO SCP^PSORN52D
+5 IF $GET(PSODRUG("DEA"))["S"!($GET(PSODRUG("DEA"))["I")!($GET(PSODRUG("DEA"))["N")
SET PSOCPAY=0
+6 if +PSOBILL'=2&('$GET(PSOSCA))
GOTO COPAY2
+7 DO FULL^VALM1
+8 IF $GET(PSOMESOI)=1
IF $GET(PSORXED)
WRITE !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",!
SET PSOMESOI=2
+9 IF $GET(PSOMESFI)=1
WRITE !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",!
SET PSOMESFI=2
+10 ;*514
SET DFN=+$GET(PSODFN)
DO CHKPAG^PSOMLLD2
DO DISSCD^PSOMLLD2
ASK ;
+1 NEW PSOUFLAG
SET PSOUFLAG=0
+2 KILL PSOCPZ("DFLG"),PSONEW("NEWCOPAY")
+3 WRITE !
KILL DIR,DTOUT,DIRUT,DUOUT
+4 IF $GET(PSORX("SC"))="SC"!($GET(PSORX("SC"))="NSC")!($GET(PSOSCOTH))
Begin DoDot:1
+5 if PSOSCP<50&($GET(PSODRUG("DEA"))'["S")&($GET(PSODRUG("DEA"))'["I")&($GET(PSODRUG("DEA"))'["N")
WRITE !,"This Rx has been flagged by the provider as: "_$SELECT($GET(PSOSCOTH):"NO COPAY",$GET(PSORX("SC"))="SC":"NO COPAY",1:"COPAY"),!
+6 IF $GET(PSOSCOTX)
SET PSOSCOTX=2
End DoDot:1
+7 SET DIR("A")="Was treatment for Service Connected condition"
SET DIR(0)="Y"
+8 SET DIR("?")="Enter 'Yes' if this prescription is for a Service Connected condition"
+9 IF $GET(PSORX("SC"))]""!($GET(PSORX(+$GET(PSORENW("OIRXN")),"SC"))'="")
SET DIR("B")=$SELECT($GET(PSORX("SC"))="SC":"YES",$GET(PSORX("SC"))="NSC":"NO",$GET(PSORX(+$GET(PSORENW("OIRXN")),"SC"))=1:"YES",$GET(PSORX(+$GET(PSORENW("OIRXN")),"SC"))=0:"NO",1:"")
+10 IF $GET(PSONEWFF)
IF $GET(PSOFLAG)
IF $GET(PSOANSQD("SC"))=0!($GET(PSOANSQD("SC"))=1)
SET DIR("B")=$SELECT($GET(PSOANSQD("SC"))=1:"YES",1:"NO")
+11 IF $GET(DIR("B"))="YES"!($GET(DIR("B"))="NO")
SET PSOUFLAG=$GET(DIR("B"))
+12 IF $GET(DIR("B"))=""
KILL DIR("B")
+13 DO ^DIR
+14 IF $GET(Y)=1!($GET(Y)=0)
SET PSOANSQ("SC")=$GET(Y)
IF $GET(PSONEWFF)
IF $GET(PSOFLAG)
SET PSOANSQD("SC")=$GET(Y)
+15 IF PSOFLAG
IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
SET PSOCPZ("DFLG")=1
+16 if Y=0
SET Y=2
+17 SET PSOANSR=+Y
IF 'PSOANSR
IF 'PSOFLAG
Begin DoDot:1
+18 WRITE !!,"This Renewal has been designated as "_$SELECT($GET(PSOUFLAG)="YES":"SERVICE CONNECTED",1:"NON-SERVICE CONNECTED.")
+19 if PSOSCP<50&($GET(PSODRUG("DEA"))'["S")&($GET(PSODRUG("DEA"))'["I")&($GET(PSODRUG("DEA"))'["N")
WRITE !,"Please use the 'Reset Copay Status/Cancel Charges' option to make corrections."
+20 SET PSOANSQ("SC")=$SELECT($GET(PSOUFLAG)="YES":1,1:0)
End DoDot:1
SET $PIECE(PSOCPAY,"^")=$SELECT($GET(PSOUFLAG)="NO":1,1:0)
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
GOTO COPAY2
+21 IF $GET(PSOFLAG)
IF $GET(PSOCPZ("DFLG"))
GOTO EXIT
+22 if PSOANSR=1
SET PSOCPAY=0
if PSOANSR=2
SET $PIECE(PSOCPAY,"^")=1
COPAY2 ;
+1 NEW PSOPFS
SET PSOPFS=$$SWSTAT^IBBAPI()
+2 ;***** begin - for regression test FMCT - sites must not use this as it will adversely affect billing results - only used by SQA
+3 ; The following is required for testing different effective dates. If date is less than 02/27/17 bills old way. Otherwise bills new way.
+4 ;S ^XTMP("PSOTIEREFTST",0)="3201231^3170227^FOR SQA TESTING ONLY" - Defined for SQA testing only. Delete this XTMP when regression complete
+5 DO NOW^%DTC
NEW PSOTIERE
+6 ;use copay tiers - new
SET PSOTIERE=1
+7 ;legacy billing - old
IF $PIECE(%,".")<3170227
SET PSOTIERE=0
+8 ;for SQA testing only - bill with copay tiers - new
IF $GET(^XTMP("PSOTIEREFTST",0))
SET PSOTIERE=1
+9 ;***** end for regression test
+10 if 'PSOTIERE
GOTO COPAY21
+11 ;Check copay tier. Tier zero does not have copay charges. Tier billing will be effective 2/27/17 and IB rate table decides what amount to bill based on rate effective date
+12 NEW CPDATE,X,PSOCPT
DO NOW^%DTC
SET CPDATE=X
SET PSOCPT=$$CPTIER^PSNAPIS("",CPDATE,PSODRUG("IEN"))
KILL CPDATE,X
+13 ;Tier zero do not send to IB for copay charge
IF $PIECE(PSOCPT,"^")=0
SET PSOCHG=0
KILL PSONEW("NEWCOPAY")
GOTO EXIT
+14 ;
COPAY21 IF +PSOCPAY=1
IF ($PIECE(PSOCPAY,"^",2)=1)!($PIECE(PSOCPAY,"^",2)=2)
Begin DoDot:1
+1 ;set IB node in ^PSRX for copay if xactn type is 1 or 2
+2 SET PSONEW("NEWCOPAY")=$PIECE($GET(PSOCPAY),"^",2)_"^^"_$SELECT(+$GET(PSOPFS):"",1:$PIECE($GET(PSOCPAY),"^",2))
End DoDot:1
EXIT ;
+1 ;Restore val of PSOCPAY
SET PSOCPAY=PSOSAVE
+2 KILL PSOSAVE,PSOANSR,DIR,DUOUT,DIRUT,DTOUT,Y,X
+3 QUIT
RESET ;RESET COPAY STATUS
+1 KILL PSOSUMM,PSOPFS,PSOPFSA,PSOLFIL,PSOPFSG
+2 IF '$DATA(PSOPAR)
DO ^PSOLSET
GOTO RESET
+3 WRITE !
SET DIC="^PSRX("
SET DIC(0)="AEQZ"
DO ^DIC
KILL DIC
if Y<0
GOTO EXT
SET PSODA=+Y
+4 WRITE !,?17,"PATIENT: ",$PIECE($GET(^DPT($PIECE(^PSRX(PSODA,0),"^",2),0)),"^")
+5 DO ICN^PSODPT($PIECE(^PSRX(PSODA,0),"^",2))
+6 SET PSORXN=$PIECE(^PSRX(PSODA,0),"^")
SET PREA="R"
+7 SET PCOPAY=$GET(^PSRX(PSODA,"IB"))
+8 WRITE !!,"Rx # ",PSORXN," is a ",$SELECT(+PCOPAY:"Copay",1:"No Copay")," prescription"
+9 ;PSOCPC def PSOPFSA=1 if OP SC/EI's change.
SET PSOLFIL=$$LF^PSOPFSU1(PSODA)
DO PFSA^PSOPFSU1(PSODA,PSOLFIL,3)
+10 ; CHECK/CHANGE EXEMPTION FLAGS
DO EXEMCHK^PSOCPC
+11 SET PSOIBQ=$GET(^PSRX(PSODA,"IBQ"))
+12 IF '$GET(^PSRX(PSODA,"IB"))
IF PSOIBQ'["1"
Begin DoDot:1
+13 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="N"
SET DIR("A")="Do you want to reset the status to COPAY"
DO ^DIR
KILL DIR
+14 IF Y'=1
QUIT
+15 SET DIC="^IBE(350.3,"
SET DIC("S")="I $P(^(0),U,3)'=2"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select Reason for Reset : "
DO ^DIC
KILL DIC
IF Y'<0
SET PSORSN=+Y
+16 SET PREA="R"
SET PSOOLD="No Copay"
SET PSONW="Copay"
SET PSOCOMM=""
DO ACTLOG^PSOCPA
+17 SET PSI=0
SET PSOCOMM="Copay status of this Rx has been reset to COPAY."
DO SETSUMM^PSOCPC
+18 ;Reset flag to COPAY
SET $PIECE(^PSRX(PSODA,"IB"),"^")=1
End DoDot:1
GOTO ASKCAN
+19 ;
+20 IF $GET(^PSRX(PSODA,"IB"))
Begin DoDot:1
+21 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="N"
SET DIR("A")="Do you want to reset the status to NO COPAYMENT"
DO ^DIR
KILL DIR
+22 IF Y'=1
QUIT
+23 SET DIC="^IBE(350.3,"
SET DIC("S")="I $P(^(0),U,3)'=2"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select Reason for Reset : "
DO ^DIC
KILL DIC
IF Y'<0
SET PSORSN=+Y
+24 SET PREA="R"
SET PSOOLD="Copay"
SET PSONW="No Copay"
SET PSOCOMM=""
DO ACTLOG^PSOCPA
+25 SET PSI=0
SET PSOCOMM="Copay status of this Rx has been reset to NO COPAY."
DO SETSUMM^PSOCPC
+26 ;Reset flag to NO COPAY
SET $PIECE(^PSRX(PSODA,"IB"),"^")=""
End DoDot:1
GOTO ASKCAN
ASKCAN DO ASKCAN^PSOCPD
+1 IF '$DATA(PSOSUMM)
SET PSI=0
SET PSOCOMM="No action taken"
DO SETSUMM^PSOCPC
+2 DO PRTSUMM
+3 ;I $P($G(PSOPFS),"^",3)>0&(+$G(PSOPFSA)) D CHRG^PSOPFSU1(PSODA,PSOLFIL,"CG",PSOPFS)
RESETE KILL PSODA,PSORXN,PSORSN,PSOREF,X,Y,PCOPAY,PREA,PSOCOMM,PSI
+1 GOTO RESET
EXT KILL PSODA,PSORXN,PSORSN,PSOREF,X,Y,PCOPAY,PREA,PSOCOPAY
+1 QUIT
BILLED ;Collect IB nums,cancel chrgs,reset flag.
+1 WRITE !!,"**********Charges are on file for this Rx.**********"
+2 QUIT
BILL2 ;
+1 ; VAR FOR PREV CANCELLED
NEW PSOPREV
+2 SET PSOPREV=0
+3 SET DIC="^IBE(350.3,"
SET DIC("S")="I $P(^(0),U,3)'=2"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select Reason for Reset or Charge Cancellation : "
DO ^DIC
KILL DIC
if Y<0
GOTO ENDMSG
SET PSORSN=+Y
+4 SET X=PSOPAR7_"^"_+$PIECE(^PSRX(PSODA,0),"^",2)_"^^"_DUZ
+5 SET SAVX=X
+6 IF $DATA(PSOCAN)
if '$GET(PSOPFS)
Begin DoDot:1
+7 ;PFSS switch off, check for prev cots billing
NEW III
SET III=""
FOR
SET III=$ORDER(PSOCAN(III))
if III=""
QUIT
IF PSOCAN(III)["PFS"
SET PSOPFSG=1
QUIT
End DoDot:1
IF +$GET(PSOPFS)!($GET(PSOPFSG))
DO PFS^PSOPFSU1
if '$DATA(PSOCAN)
GOTO BILL2END
+8 DO POTBILL2
+9 IF '$DATA(PSOCAN)
GOTO BILL2END
+10 IF $GET(CANTYPE)
DO PREVCAN
IF $ORDER(X(""))=""
QUIT
+11 IF '$GET(CANTYPE)
SET I=""
FOR
SET I=$ORDER(PSOCAN(I))
if I=""
QUIT
SET X($PIECE(PSOCAN(I),"^",1))=$PIECE(PSOCAN(I),"^",2)_"^"_PSORSN
+12 DO CANCEL^IBARX
+13 IF $GET(CANTYPE)
DO MSG
+14 IF '$DATA(Y)
QUIT
+15 IF +Y=-1
QUIT
+16 IF $DATA(Y(PSORXN))
IF +Y(PSORXN)'=-1
SET $PIECE(^PSRX(PSODA,"IB"),"^",2)=+Y(PSORXN)
KILL Y(PSORXN)
SET PREA="C"
SET PSOREF=0
SET PSOOLD=""
SET PSONW=""
DO ACTLOG^PSOCPA
IF '$GET(CANTYPE)
DO MSG
+17 FOR PSOREF=0:0
SET PSOREF=$ORDER(Y(PSOREF))
if PSOREF=""
QUIT
IF +Y(PSOREF)'=-1
SET ^PSRX(PSODA,1,PSOREF,"IB")=+Y(PSOREF)
SET PREA="C"
SET PSOOLD=""
SET PSONW=""
DO ACTLOG^PSOCPA
IF '$GET(CANTYPE)
DO MSG
BILL2END KILL X,Y,SAVX,PSOREF,PSOCAN
+1 QUIT
+2 ;
POTBILL2 ;see if any potential charges (entries from file 354.71 -- bills that exceeded cap prev) to be cancelled before cancelling regular charges
+1 NEW X,I
+2 SET X=SAVX
+3 IF $TEXT(CANIBAM^IBARX)=""
QUIT
+4 SET I=""
FOR
SET I=$ORDER(PSOCAN(I))
if I=""
QUIT
IF PSOCAN(I)["^CAP"
SET X($PIECE(PSOCAN(I),"^",1))=$PIECE(PSOCAN(I),"^",2)_"^"_PSORSN
KILL PSOCAN(I)
+5 IF $ORDER(X(""))=""
QUIT
+6 SET PSOPREV=1
+7 DO CANIBAM^IBARX
+8 IF $DATA(X(PSORXN))
SET $PIECE(^PSRX(PSODA,"IB"),"^",4)=""
SET PREA="C"
SET PSOREF=0
SET PSOCOMM="Potential charge cancelled"
SET PSOOLD=""
SET PSONW=""
DO ACTLOG^PSOCPA
DO POTMSG
KILL X(PSORXN)
+9 FOR PSOREF=0:0
SET PSOREF=$ORDER(X(PSOREF))
if PSOREF=""
QUIT
if PSOREF>11
QUIT
SET $PIECE(^PSRX(PSODA,1,PSOREF,"IB"),"^",2)=""
SET PREA="C"
SET PSOCOMM="Potential charge cancelled"
SET PSOOLD=""
SET PSONW=""
DO ACTLOG^PSOCPA
DO POTMSG
+10 KILL PSOREF,PREA,PSOCOMM
+11 QUIT
REFILL SET PSOREF=0
+1 FOR
SET PSOREF=$ORDER(^PSRX(PSODA,1,PSOREF))
if PSOREF'?1N.N
QUIT
Begin DoDot:1
+2 IF $DATA(^PSRX(PSODA,1,PSOREF,"PFS"))
if $PIECE($GET(^PSRX(PSODA,1,PSOREF,"PFS")),"^",2)
SET X(PSOREF)="^"_$GET(PSORSN)
QUIT
+3 IF $DATA(^PSRX(PSODA,1,PSOREF,"IB"))
IF +^("IB")>0
SET X(PSOREF)=+^PSRX(PSODA,1,PSOREF,"IB")_"^"_$GET(PSORSN)
End DoDot:1
+4 ; IF ONLY ENTRY FROM 354.71 SAVE IT
SET PSOREF=0
FOR
SET PSOREF=$ORDER(^PSRX(PSODA,1,PSOREF))
if PSOREF'?1N.N
QUIT
IF '$DATA(X(PSOREF))
IF +$PIECE($GET(^PSRX(PSODA,1,PSOREF,"IB")),"^",2)
SET XX(PSOREF)=+$PIECE(^PSRX(PSODA,1,PSOREF,"IB"),"^",2)_"^"_$GET(PSORSN)
+5 QUIT
SETCP ;IF NOT COPAY MAKE ELIG CALL/SET FLAG FOR FUTURE
+1 WRITE !
SET X=PSOPAR7_"^"_+$PIECE(^PSRX(PSODA,0),"^",2)
+2 DO XTYPE^IBARX
+3 IF +Y=-1
WRITE !!,"Error in processing Copay eligibility, no action taken."
QUIT
+4 SET (ACTYP,BL)=""
SET (PSOBILL,PSOCPAY)=0
CP ;
+1 SET ACTYP=$ORDER(Y(ACTYP))
if 'ACTYP
GOTO CP1
+2 FOR I=0:0
SET BL=$ORDER(Y(ACTYP,BL))
if BL=""
QUIT
IF BL>0
SET PSOBILL=BL
SET PSOCPAY=ACTYP
+3 GOTO CP
CP1 KILL ACTYP,BL,I
+1 IF (PSOBILL'>0)!(PSOCPAY=0)
GOTO INELIG
+2 SET $PIECE(^PSRX(PSODA,"IB"),"^")=PSOCPAY
+3 WRITE !,"COPAY status on this Rx has been reset.",!,"*** Future refills will be classified as COPAY."
+4 SET PREA="R"
SET PSOOLD="No Copay"
SET PSONW="Copay"
+5 DO ACTLOG^PSOCPA
+6 QUIT
INELIG WRITE !,"This Rx does not meet patient eligibility requirement for Copay.",!,"****** Status unchanged *******"
+1 SET Y=-1
+2 QUIT
ENDMSG KILL X
WRITE !,"Unable to process CHARGE REMOVAL without REASON for Reset."
+1 READ !,"ENTER a REASON now? (Y/N) ",X:DTIME
if '$TEST
QUIT
+2 IF ($EXTRACT(X)["?")!("YyNn^"'[$EXTRACT(X))
WRITE !,"Enter YES to select REASON and RESET STATUS."
GOTO ENDMSG
+3 IF "Yy"[$EXTRACT(X)
GOTO BILL2
+4 QUIT
MSG ;
+1 SET PSI=0
+2 IF $GET(CANTYPE)
SET PSOCOMM="Rx # "_PSORXN_" - All copay charges cancelled"
DO SETSUMM^PSOCPC
KILL PSOCOMM
QUIT
+3 SET PSOCOMM="Rx # "_PSORXN_" - "_$SELECT(PSOREF=0:"Original fill",1:"Refill "_PSOREF)_" copay charge cancelled"
+4 DO SETSUMM^PSOCPC
+5 KILL PSOCOMM
+6 QUIT
POTMSG ;
+1 SET PSI=0
+2 ; (MESSAGE WILL GET SET LATER)
IF $GET(CANTYPE)
QUIT
+3 SET PSOCOMM="Rx # "_PSORXN_" - "_$SELECT(PSOREF=0:"Original fill",1:"Refill "_PSOREF)_" potential copay charge cancelled"
+4 DO SETSUMM^PSOCPC
+5 KILL PSOCOMM
+6 QUIT
MSGNOCAN ;
+1 SET PSI=0
+2 SET PSOCOMM="Rx # "_PSORXN_" - All copay charges have already been cancelled."
DO SETSUMM^PSOCPC
KILL PSOCOMM
+3 QUIT
+4 ;
PRTSUMM ; prt sum of actions in reset/cancel
+1 IF '$DATA(PSOSUMM)
QUIT
+2 WRITE !
+3 SET PSI=""
+4 FOR
SET PSI=$ORDER(PSOSUMM(PSI))
if PSI=""
QUIT
WRITE !,PSOSUMM(PSI)
+5 KILL PSOSUMM
+6 QUIT
PREVCAN ; PREVIEW CANCELS IF "ALL" IS SELECTED
+1 NEW I,PSOBILL
+2 SET I=""
FOR
SET I=$ORDER(PSOCAN(I))
if I=""
QUIT
Begin DoDot:1
+3 ; PREVIOUSLY CANCELLED
SET PSOBILL=1
IF $TEXT(STATUS^IBARX)'=""
IF PSOCAN(I)'["CAP"
SET PSOBILL=$$STATUS^IBARX($PIECE(PSOCAN(I),"^",2))
if PSOBILL=2
SET PSOBILL=0
End DoDot:1
IF PSOBILL
SET X($PIECE(PSOCAN(I),"^",1))=$PIECE(PSOCAN(I),"^",2)_"^"_PSORSN
+4 IF $ORDER(X(""))=""
Begin DoDot:1
+5 IF PSOPREV
DO MSG
QUIT
+6 DO MSGNOCAN
End DoDot:1
+7 QUIT
+8 ;
