- 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 Jan 18, 2025@03:26:51 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 ;