PSOCPD ;BHAM ISC/BaB - MULTIPLE COPAY CHARGE REMOVAL ;05/27/92
;;7.0;OUTPATIENT PHARMACY;**71,85,201**;DEC 1997
;
;REF/IA
;^IBARX/125
; Originally released as part of the copayment enhancement patch
; Mill Bill Copay enhancement -- entry point ASKCAN - called from PSOCPB
CR I '$D(PSOPAR) S PSOINDPT="" D ^PSOLSET G CR ; Setup site parameters
ASK K PSPEED,PSPEEDA,PSPOUT W ! R !,"PRESCRIPTION(s): ",PSX:DTIME S:'$T PSX="^" G LASTEX:"^"[PSX
I PSX["?"!($L(PSX)>245)!(PSX?.AP) W !?5,"Enter prescription number(s) for removal of charges. If more than one",!,"separate with commas. Do not exceed 245 characters including commas." G ASK
G SPEED:PSX[","
I '$D(^PSRX("B",PSX)) W !!,PSX," is not a valid RX #!!" G ASK
S PSODA=$O(^PSRX("B",PSX,"")) W:PSODA="" !!,PSX," is not a valid RX #!!" G ASK:PSODA=""
I '$D(^PSRX(PSODA,"IB")) W !!,"Rx # ",$P($G(^PSRX(PSODA,0)),"^")," is NOT a COPAY transaction...NO action taken." G EXIT
D REASON G:Y<0 LASTEX D SPEED1,LASTEX
Q
REASON ;
; Get Cancellation reason
W ! S DIC="^IBE(350.3,",DIC("S")="I $P(^(0),U,3)'=2",DIC(0)="AEQMZ",DIC("A")="Select CHARGE REMOVAL REASON : " D ^DIC K DIC D ENDMSG:Y<0 Q:Y<0 S PSORSN=+Y
S PREA="C-CPD"
Q
SPEED ;
S PSPEED=1 D REASON G:Y<0 LASTEX
F PSOI=1:1 S X=$P(PSX,",",PSOI) Q:$P(PSX,",",PSOI,99)=""!($G(PSPOUT)) I X S DIC=52,DIC(0)="M" D ^DIC K DIC S:Y<0 PSINV(X)="" I Y>0 S PSODA=+Y D SPEED1
INVALD G:'$D(PSINV) ASK
W !!,"The following are INVALID choices:" S PSOI="" F PSOJ=0:0 S PSOI=$O(PSINV(PSOI)) Q:PSOI'>0 W !?10,PSOI
K PSINV
G ASK
SPEED1 ;
S PSOFLAG=0
S PSO=1 ; Remove Co-Pay charge
S PSORXN=$P(^PSRX(PSODA,0),"^") ;..........Rx #
; Determine if Rx is COPAY
I '$D(^PSRX(PSODA,"IB")) W !,"Rx # ",PSORXN," is NOT a COPAY transaction...NO action taken." G EXIT
S PSOIB=^PSRX(PSODA,"IB")
G:($P(PSOIB,"^",2)'>0)&('$D(^PSRX(PSODA,1))) ERRBIL ;No bill#/no refills
;
; Determine last entry in ^PSRX
S PSOREF=0
G:'$D(^PSRX(PSODA,1)) CANCEL
F PSZ=0:0 S PSZ=$O(^PSRX(PSODA,1,PSZ)) Q:PSZ'>0 S PSOREF=PSZ
G:$S('$D(^PSRX(PSODA,1,PSOREF,"IB")):1,(+^("IB"))'>0:1,1:0) ERRBIL ;..No bill #
S:PSOREF>0 PSOIB=^PSRX(PSODA,1,PSOREF,"IB")
CANCEL ;
I '$G(PSPEED) W ! K DIR S DIR(0)="Y",DIR("B")="Y",DIR("A")="Are you sure you want to remove Copay charges for Rx # "_$G(PSORXN) D ^DIR K DIR I Y'=1 W !!,"No action taken.",! G EXIT
I $G(PSPEED),'$G(PSPEEDA) W ! K DIR S DIR(0)="Y",DIR("B")="Y",DIR("A")="Are you sure you want to remove Copay charges for these Rx's" D ^DIR K DIR S PSPEEDA=1 I Y'=1 W !!,"No action taken.",! S PSPOUT=1 G EXIT
W ! K X
; Set x=service^dfn^^user duz
; x(n)=IB number^cancellation reason
;
S X=PSOPAR7_"^"_+$P(^PSRX(PSODA,0),"^",2)_"^^"_DUZ
S:PSOREF=0 X(PSORXN)=+$P(PSOIB,"^",2)_"^"_PSORSN ; Original Rx
S:PSOREF>0 X(PSORXN)=+^PSRX(PSODA,1,PSOREF,"IB")_"^"_PSORSN ; Refill Rx
;
D CANCEL^IBARX
;
; Return y=1 if success, -1^error code if error
; y(n)=IB number^total charge^AR bill number
;
I +Y=-1 W !,"......No action taken." G EXIT
G EXIT:'$D(Y(PSORXN))
FILE ;
; File new Bill # in ^PSRX
;
S:PSOREF=0 $P(^PSRX(PSODA,"IB"),"^",2)=+Y(PSORXN) ;...Original Rx
S:PSOREF>0 ^PSRX(PSODA,1,PSOREF,"IB")=+Y(PSORXN) ; ...Refill Rx
W:PSO=1 !!,"Co-Pay transaction for Rx # ",PSORXN,$S(PSOREF>0:" refill # "_PSOREF,1:"")," has been cancelled."
;
D ACTLOG^PSOCPA
;
G EXIT
ERRBIL W !!,"No Entry # for Rx # "_$P($G(^PSRX(PSODA,0)),"^")_" ...No action taken."
EXIT ;
K PREA,C,PSO,PSODA,PSOIB,PSOPARNT,PSOREF,PSORXN,PSZ,X,Y
Q
LASTEX ;
K PSO,PSPOUT,PSPEED,PSPEEDA,PSOCPUN,PSODA,PSOFLAG,PSOIB,PSOPARNT,PSOREF,PSORSN,PSORXN,PSZ,X,Y,PSINV,PSOI,PSX,PSOJ,PREA,C
I $D(PSOINDPT) K PSOINDPT D FINAL^PSOLSET
Q
ENDMSG ;
W !!,"Unable to process without REASON entry."
Q
;
ASKCAN ; if any charges currently, give option to cancel some or all
I '$D(^PSRX(PSODA,"IB")) Q ;ok to quit based on IB node for PFSS because always have IB node when copay is billed.
N J,PSOREF,PSOCAN,CANTYPE
K X,XX
S J=0
I $P($G(^PSRX(PSODA,"PFS")),"^",2) S X(PSODA)="",J=1,PSOCAN(J)=PSODA_"^"_X(PSODA),$P(PSOCAN(J),"^",10)="PFS" ;if PFS and it has charge id
I $P(^PSRX(PSODA,"IB"),"^",2)>0 S X(PSORXN)=$P(^PSRX(PSODA,"IB"),"^",2),J=1,PSOCAN(J)=PSORXN_"^"_X(PSORXN) ; original fill
I $P(^PSRX(PSODA,"IB"),"^",4)>0,'$D(X(PSORXN)) S XX(PSORXN)=$P(^PSRX(PSODA,"IB"),"^",4),J=1,PSOCAN(J)=PSORXN_"^"_XX(PSORXN)_"^CAP" ; original fill
PFS D REFILL^PSOCPB
I '$D(X),'$D(XX) Q ; no "IB" numbers on original or refills
S PSOREF="" F S PSOREF=$O(X(PSOREF)) Q:PSOREF="" Q:PSOREF>12 S J=J+1,PSOCAN(J)=PSOREF_"^"_X(PSOREF) S:$P($G(^PSRX(PSODA,1,PSOREF,"PFS")),"^",2) $P(PSOCAN(J),"^",10)="PFS"
S PSOREF="" F S PSOREF=$O(XX(PSOREF)) Q:PSOREF="" Q:PSOREF>12 S J=J+1,PSOCAN(J)=PSOREF_"^"_XX(PSOREF)_"^CAP" S:$P($G(^PSRX(PSODA,1,PSOREF,"PFS")),"^",2) $P(PSOCAN(J),"^",10)="PFS"
ASKCAN2 W !!,"Do you want to cancel any charges (Y/N)? "
R X:DTIME S:'$T X="^" Q:X="" G:"Yy"[$E(X) ASKALL Q:"Nn^"[$E(X) D HELP2:"?"[$E(X) G ASKCAN2
HELP2 W !,"Answering YES will allow cancelling of all or selected charges"
Q
HELP3 W !,"Answering YES will proceed with cancelling selected charges"
Q
ASKALL ;PFS - check copay activity log to see if any fills were previously cancelled; mark as cancelled for display
N PSOPFSD,PSOFIL D GETS^DIQ(52,PSODA,"107*","I","PSOPFSD") D:$D(PSOPFSD)
.F I=1:1 Q:'$D(PSOPFSD(52.0107,I_","_PSODA_",")) D:$G(PSOPFSD(52.0107,I_","_PSODA_",",1,"I"))="C"
..S PSOFIL=$G(PSOPFSD(52.0107,I_","_PSODA_",",3,"I")),J=""
..F S J=$O(PSOCAN(J)) Q:J="" S:$P(PSOCAN(J),"^")=PSOFIL&($P(PSOCAN(J),"^",10)="PFS") $P(PSOCAN(J),"^",5)="CANCEL" S:$P(PSOCAN(J),"^")=PSODA&(PSOFIL=0)&($P(PSOCAN(J),"^",10)="PFS") $P(PSOCAN(J),"^",5)="CANCEL"
K PSOFIL,PSOPFSD
;
W !!,"(A)ll or (S)elect Charges? (A/S): "
R X:DTIME S:'$T X="^" I X="" Q
I X="^" Q
I X'="A",X'="a",X'="S",X'="s" W !,"Enter 'A' to cancel all charges or 'S' to select from list of charges" G ASKALL
I X="A"!(X="a") D D BILL2^PSOCPB Q
.W !!,"**********Charges are on file for this Rx.**********"
.W !,"Proceeding with cancellation of ALL charges."
.S CANTYPE=1
S CANTYPE=0
D SELECT
Q
;
SELECT ; Choose from list of fills that have charges
N J,I,PSORELDT,PSOBILL,FOOTNOTE
K FOOTNOTE
K X
F J=1:1 Q:'$D(PSOCAN(J)) D W:PSORELDT'="//" !,J,". ",$S(+PSOCAN(J)>11:"Original fill",1:"Refill #"_+PSOCAN(J)),?20,"(",PSORELDT,")",?35,PSOBILL
.S PSOBILL=""
.I $P(PSOCAN(J),"^",10)'="PFS" D
..I PSOCAN(J)["CAP" S PSOBILL="(Potential Charge *)",FOOTNOTE=1
..I $P(PSOCAN(J),"^",10)'="PFS" I $T(STATUS^IBARX)'="" I PSOCAN(J)'["CAP" S PSOBILL=$$STATUS^IBARX($P(PSOCAN(J),"^",2)) S:PSOBILL=2 $P(PSOCAN(J),"^",5)="CANCEL" S PSOBILL=$S(PSOBILL=2:"(Charge Cancelled)",1:"")
.I $P(PSOCAN(J),"^",10)="PFS" S:$P(PSOCAN(J),"^",5)="CANCEL" PSOBILL="(Charge Cancelled)"
.N RX2
.S RX2=$S(+PSOCAN(J)>11:$G(^PSRX(PSODA,2)),1:$G(^PSRX(PSODA,1,+PSOCAN(J),0)))
.I RX2="" S PSORELDT="" Q
.I +PSOCAN(J)>11 S PSORELDT=$S($P(RX2,"^",13):$E($P(RX2,"^",13),4,5)_"/"_$E($P(RX2,"^",13),6,7)_"/"_$E($P(RX2,"^",13),2,3),$P(RX2,"^",15):"RTS",1:"") Q
.S PSORELDT=$E($P(RX2,"^",18),4,5)_"/"_$E($P(RX2,"^",18),6,7)_"/"_$E($P(RX2,"^",18),2,3)
I $D(FOOTNOTE) D
. W !!,"* Potential charge indicates fill was not billed due to the annual cap."
. W !,"If cancelled, this fill will not be considered for future copay billing."
SELECT2 ;
K DIR
S DIR("?")="Select a list or a range, e.g., 1,3,5 or 2-5,8"
S DIR(0)="LO^1:"_(J-1)
D ^DIR K DIR
Q:(X="")!(X="^")!(Y=-1)
F I=1:1:$L(Y,",")-1 D
. S PSOSLCT=$P(Y,",",I)
. I $P(PSOCAN(PSOSLCT),"^",5)="" S X($P(PSOCAN(PSOSLCT),"^",1))=$P(PSOCAN(PSOSLCT),"^",2) Q
SELECT3 W !!,"Do you wish to continue (Y/N)? "
R X:DTIME S:'$T X="^" I X="" Q
I "Yy"[$E(X) G SELECT4
Q:"Nn^"[$E(X) D HELP3:"?"[$E(X) G SELECT3
SELECT4 I $O(X(""))'="" D D BILL2^PSOCPB ; cancel charges for selected fills only
. S I="" F S I=$O(PSOCAN(I)) Q:I="" I '$D(X($P(PSOCAN(I),"^",1))) K PSOCAN(I) ; remove unselected fills from cancellation list
Q
;
CHKCAN ; SEE IF SELECTION HAS ALREADY BEEN CANCELLED
I '$D(PSOCAN(J)) D Q
. I J>12!(J'?0.2N) W $C(7),!!,J," is an invalid selection. Please try again.",!
S PSI=0
I $P(PSOCAN(J),"^",5)="CANCEL" S PSOCOMM="Rx # "_PSORXN_" - "_$S(+PSOCAN(J)>11:"Original fill",1:"Refill #"_+PSOCAN(J))_" copay charge has already been cancelled!" D SETSUMM^PSOCPC
K PSI
Q
;
PSOCPD ;BHAM ISC/BaB - MULTIPLE COPAY CHARGE REMOVAL ;05/27/92
+1 ;;7.0;OUTPATIENT PHARMACY;**71,85,201**;DEC 1997
+2 ;
+3 ;REF/IA
+4 ;^IBARX/125
+5 ; Originally released as part of the copayment enhancement patch
+6 ; Mill Bill Copay enhancement -- entry point ASKCAN - called from PSOCPB
CR ; Setup site parameters
IF '$DATA(PSOPAR)
SET PSOINDPT=""
DO ^PSOLSET
GOTO CR
ASK KILL PSPEED,PSPEEDA,PSPOUT
WRITE !
READ !,"PRESCRIPTION(s): ",PSX:DTIME
IF '$TEST
SET PSX="^"
IF "^"[PSX
GOTO LASTEX
+1 IF PSX["?"!($LENGTH(PSX)>245)!(PSX?.AP)
WRITE !?5,"Enter prescription number(s) for removal of charges. If more than one",!,"separate with commas. Do not exceed 245 characters including commas."
GOTO ASK
+2 IF PSX[","
GOTO SPEED
+3 IF '$DATA(^PSRX("B",PSX))
WRITE !!,PSX," is not a valid RX #!!"
GOTO ASK
+4 SET PSODA=$ORDER(^PSRX("B",PSX,""))
IF PSODA=""
WRITE !!,PSX," is not a valid RX #!!"
IF PSODA=""
GOTO ASK
+5 IF '$DATA(^PSRX(PSODA,"IB"))
WRITE !!,"Rx # ",$PIECE($GET(^PSRX(PSODA,0)),"^")," is NOT a COPAY transaction...NO action taken."
GOTO EXIT
+6 DO REASON
IF Y<0
GOTO LASTEX
DO SPEED1
DO LASTEX
+7 QUIT
REASON ;
+1 ; Get Cancellation reason
+2 WRITE !
SET DIC="^IBE(350.3,"
SET DIC("S")="I $P(^(0),U,3)'=2"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select CHARGE REMOVAL REASON : "
DO ^DIC
KILL DIC
IF Y<0
DO ENDMSG
IF Y<0
QUIT
SET PSORSN=+Y
+3 SET PREA="C-CPD"
+4 QUIT
SPEED ;
+1 SET PSPEED=1
DO REASON
IF Y<0
GOTO LASTEX
+2 FOR PSOI=1:1
SET X=$PIECE(PSX,",",PSOI)
IF $PIECE(PSX,",",PSOI,99)=""!($GET(PSPOUT))
QUIT
IF X
SET DIC=52
SET DIC(0)="M"
DO ^DIC
KILL DIC
IF Y<0
SET PSINV(X)=""
IF Y>0
SET PSODA=+Y
DO SPEED1
INVALD IF '$DATA(PSINV)
GOTO ASK
+1 WRITE !!,"The following are INVALID choices:"
SET PSOI=""
FOR PSOJ=0:0
SET PSOI=$ORDER(PSINV(PSOI))
IF PSOI'>0
QUIT
WRITE !?10,PSOI
+2 KILL PSINV
+3 GOTO ASK
SPEED1 ;
+1 SET PSOFLAG=0
+2 ; Remove Co-Pay charge
SET PSO=1
+3 ;..........Rx #
SET PSORXN=$PIECE(^PSRX(PSODA,0),"^")
+4 ; Determine if Rx is COPAY
+5 IF '$DATA(^PSRX(PSODA,"IB"))
WRITE !,"Rx # ",PSORXN," is NOT a COPAY transaction...NO action taken."
GOTO EXIT
+6 SET PSOIB=^PSRX(PSODA,"IB")
+7 ;No bill#/no refills
IF ($PIECE(PSOIB,"^",2)'>0)&('$DATA(^PSRX(PSODA,1)))
GOTO ERRBIL
+8 ;
+9 ; Determine last entry in ^PSRX
+10 SET PSOREF=0
+11 IF '$DATA(^PSRX(PSODA,1))
GOTO CANCEL
+12 FOR PSZ=0:0
SET PSZ=$ORDER(^PSRX(PSODA,1,PSZ))
IF PSZ'>0
QUIT
SET PSOREF=PSZ
+13 ;..No bill #
IF $SELECT('$DATA(^PSRX(PSODA,1,PSOREF,"IB"))
GOTO ERRBIL
+14 IF PSOREF>0
SET PSOIB=^PSRX(PSODA,1,PSOREF,"IB")
CANCEL ;
+1 IF '$GET(PSPEED)
WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Are you sure you want to remove Copay charges for Rx # "_$GET(PSORXN)
DO ^DIR
KILL DIR
IF Y'=1
WRITE !!,"No action taken.",!
GOTO EXIT
+2 IF $GET(PSPEED)
IF '$GET(PSPEEDA)
WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Are you sure you want to remove Copay charges for these Rx's"
DO ^DIR
KILL DIR
SET PSPEEDA=1
IF Y'=1
WRITE !!,"No action taken.",!
SET PSPOUT=1
GOTO EXIT
+3 WRITE !
KILL X
+4 ; Set x=service^dfn^^user duz
+5 ; x(n)=IB number^cancellation reason
+6 ;
+7 SET X=PSOPAR7_"^"_+$PIECE(^PSRX(PSODA,0),"^",2)_"^^"_DUZ
+8 ; Original Rx
IF PSOREF=0
SET X(PSORXN)=+$PIECE(PSOIB,"^",2)_"^"_PSORSN
+9 ; Refill Rx
IF PSOREF>0
SET X(PSORXN)=+^PSRX(PSODA,1,PSOREF,"IB")_"^"_PSORSN
+10 ;
+11 DO CANCEL^IBARX
+12 ;
+13 ; Return y=1 if success, -1^error code if error
+14 ; y(n)=IB number^total charge^AR bill number
+15 ;
+16 IF +Y=-1
WRITE !,"......No action taken."
GOTO EXIT
+17 IF '$DATA(Y(PSORXN))
GOTO EXIT
FILE ;
+1 ; File new Bill # in ^PSRX
+2 ;
+3 ;...Original Rx
IF PSOREF=0
SET $PIECE(^PSRX(PSODA,"IB"),"^",2)=+Y(PSORXN)
+4 ; ...Refill Rx
IF PSOREF>0
SET ^PSRX(PSODA,1,PSOREF,"IB")=+Y(PSORXN)
+5 IF PSO=1
WRITE !!,"Co-Pay transaction for Rx # ",PSORXN,$SELECT(PSOREF>0:" refill # "_PSOREF,1:"")," has been cancelled."
+6 ;
+7 DO ACTLOG^PSOCPA
+8 ;
+9 GOTO EXIT
ERRBIL WRITE !!,"No Entry # for Rx # "_$PIECE($GET(^PSRX(PSODA,0)),"^")_" ...No action taken."
EXIT ;
+1 KILL PREA,C,PSO,PSODA,PSOIB,PSOPARNT,PSOREF,PSORXN,PSZ,X,Y
+2 QUIT
LASTEX ;
+1 KILL PSO,PSPOUT,PSPEED,PSPEEDA,PSOCPUN,PSODA,PSOFLAG,PSOIB,PSOPARNT,PSOREF,PSORSN,PSORXN,PSZ,X,Y,PSINV,PSOI,PSX,PSOJ,PREA,C
+2 IF $DATA(PSOINDPT)
KILL PSOINDPT
DO FINAL^PSOLSET
+3 QUIT
ENDMSG ;
+1 WRITE !!,"Unable to process without REASON entry."
+2 QUIT
+3 ;
ASKCAN ; if any charges currently, give option to cancel some or all
+1 ;ok to quit based on IB node for PFSS because always have IB node when copay is billed.
IF '$DATA(^PSRX(PSODA,"IB"))
QUIT
+2 NEW J,PSOREF,PSOCAN,CANTYPE
+3 KILL X,XX
+4 SET J=0
+5 ;if PFS and it has charge id
IF $PIECE($GET(^PSRX(PSODA,"PFS")),"^",2)
SET X(PSODA)=""
SET J=1
SET PSOCAN(J)=PSODA_"^"_X(PSODA)
SET $PIECE(PSOCAN(J),"^",10)="PFS"
+6 ; original fill
IF $PIECE(^PSRX(PSODA,"IB"),"^",2)>0
SET X(PSORXN)=$PIECE(^PSRX(PSODA,"IB"),"^",2)
SET J=1
SET PSOCAN(J)=PSORXN_"^"_X(PSORXN)
+7 ; original fill
IF $PIECE(^PSRX(PSODA,"IB"),"^",4)>0
IF '$DATA(X(PSORXN))
SET XX(PSORXN)=$PIECE(^PSRX(PSODA,"IB"),"^",4)
SET J=1
SET PSOCAN(J)=PSORXN_"^"_XX(PSORXN)_"^CAP"
PFS DO REFILL^PSOCPB
+1 ; no "IB" numbers on original or refills
IF '$DATA(X)
IF '$DATA(XX)
QUIT
+2 SET PSOREF=""
FOR
SET PSOREF=$ORDER(X(PSOREF))
IF PSOREF=""
QUIT
IF PSOREF>12
QUIT
SET J=J+1
SET PSOCAN(J)=PSOREF_"^"_X(PSOREF)
IF $PIECE($GET(^PSRX(PSODA,1,PSOREF,"PFS")),"^",2)
SET $PIECE(PSOCAN(J),"^",10)="PFS"
+3 SET PSOREF=""
FOR
SET PSOREF=$ORDER(XX(PSOREF))
IF PSOREF=""
QUIT
IF PSOREF>12
QUIT
SET J=J+1
SET PSOCAN(J)=PSOREF_"^"_XX(PSOREF)_"^CAP"
IF $PIECE($GET(^PSRX(PSODA,1,PSOREF,"PFS")),"^",2)
SET $PIECE(PSOCAN(J),"^",10)="PFS"
ASKCAN2 WRITE !!,"Do you want to cancel any charges (Y/N)? "
+1 READ X:DTIME
IF '$TEST
SET X="^"
IF X=""
QUIT
IF "Yy"[$EXTRACT(X)
GOTO ASKALL
IF "Nn^"[$EXTRACT(X)
QUIT
IF "?"[$EXTRACT(X)
DO HELP2
GOTO ASKCAN2
HELP2 WRITE !,"Answering YES will allow cancelling of all or selected charges"
+1 QUIT
HELP3 WRITE !,"Answering YES will proceed with cancelling selected charges"
+1 QUIT
ASKALL ;PFS - check copay activity log to see if any fills were previously cancelled; mark as cancelled for display
+1 NEW PSOPFSD,PSOFIL
DO GETS^DIQ(52,PSODA,"107*","I","PSOPFSD")
IF $DATA(PSOPFSD)
Begin DoDot:1
+2 FOR I=1:1
IF '$DATA(PSOPFSD(52.0107,I_","_PSODA_","))
QUIT
IF $GET(PSOPFSD(52.0107,I_","_PSODA_",",1,"I"))="C"
Begin DoDot:2
+3 SET PSOFIL=$GET(PSOPFSD(52.0107,I_","_PSODA_",",3,"I"))
SET J=""
+4 FOR
SET J=$ORDER(PSOCAN(J))
IF J=""
QUIT
IF $PIECE(PSOCAN(J),"^")=PSOFIL&($PIECE(PSOCAN(J),"^",10)="PFS")
SET $PIECE(PSOCAN(J),"^",5)="CANCEL"
IF $PIECE(PSOCAN(J),"^")=PSODA&(PSOFIL=0)&($PIECE(PSOCAN(J),"^",10)="PFS")
SET $PIECE(PSOCAN(J),"^",5)="CANCEL"
End DoDot:2
End DoDot:1
+5 KILL PSOFIL,PSOPFSD
+6 ;
+7 WRITE !!,"(A)ll or (S)elect Charges? (A/S): "
+8 READ X:DTIME
IF '$TEST
SET X="^"
IF X=""
QUIT
+9 IF X="^"
QUIT
+10 IF X'="A"
IF X'="a"
IF X'="S"
IF X'="s"
WRITE !,"Enter 'A' to cancel all charges or 'S' to select from list of charges"
GOTO ASKALL
+11 IF X="A"!(X="a")
Begin DoDot:1
+12 WRITE !!,"**********Charges are on file for this Rx.**********"
+13 WRITE !,"Proceeding with cancellation of ALL charges."
+14 SET CANTYPE=1
End DoDot:1
DO BILL2^PSOCPB
QUIT
+15 SET CANTYPE=0
+16 DO SELECT
+17 QUIT
+18 ;
SELECT ; Choose from list of fills that have charges
+1 NEW J,I,PSORELDT,PSOBILL,FOOTNOTE
+2 KILL FOOTNOTE
+3 KILL X
+4 FOR J=1:1
IF '$DATA(PSOCAN(J))
QUIT
Begin DoDot:1
+5 SET PSOBILL=""
+6 IF $PIECE(PSOCAN(J),"^",10)'="PFS"
Begin DoDot:2
+7 IF PSOCAN(J)["CAP"
SET PSOBILL="(Potential Charge *)"
SET FOOTNOTE=1
+8 IF $PIECE(PSOCAN(J),"^",10)'="PFS"
IF $TEXT(STATUS^IBARX)'=""
IF PSOCAN(J)'["CAP"
SET PSOBILL=$$STATUS^IBARX($PIECE(PSOCAN(J),"^",2))
IF PSOBILL=2
SET $PIECE(PSOCAN(J),"^",5)="CANCEL"
SET PSOBILL=$SELECT(PSOBILL=2:"(Charge Cancelled)",1:"")
End DoDot:2
+9 IF $PIECE(PSOCAN(J),"^",10)="PFS"
IF $PIECE(PSOCAN(J),"^",5)="CANCEL"
SET PSOBILL="(Charge Cancelled)"
+10 NEW RX2
+11 SET RX2=$SELECT(+PSOCAN(J)>11:$GET(^PSRX(PSODA,2)),1:$GET(^PSRX(PSODA,1,+PSOCAN(J),0)))
+12 IF RX2=""
SET PSORELDT=""
QUIT
+13 IF +PSOCAN(J)>11
SET PSORELDT=$SELECT($PIECE(RX2,"^",13):$EXTRACT($PIECE(RX2,"^",13),4,5)_"/"_$EXTRACT($PIECE(RX2,"^",13),6,7)_"/"_$EXTRACT($PIECE(RX2,"^",13),2,3),$PIECE(RX2,"^",15):"RTS",1:"")
QUIT
+14 SET PSORELDT=$EXTRACT($PIECE(RX2,"^",18),4,5)_"/"_$EXTRACT($PIECE(RX2,"^",18),6,7)_"/"_$EXTRACT($PIECE(RX2,"^",18),2,3)
End DoDot:1
IF PSORELDT'="//"
WRITE !,J,". ",$SELECT(+PSOCAN(J)>11:"Original fill",1:"Refill #"_+PSOCAN(J)),?20,"(",PSORELDT,")",?35,PSOBILL
+15 IF $DATA(FOOTNOTE)
Begin DoDot:1
+16 WRITE !!,"* Potential charge indicates fill was not billed due to the annual cap."
+17 WRITE !,"If cancelled, this fill will not be considered for future copay billing."
End DoDot:1
SELECT2 ;
+1 KILL DIR
+2 SET DIR("?")="Select a list or a range, e.g., 1,3,5 or 2-5,8"
+3 SET DIR(0)="LO^1:"_(J-1)
+4 DO ^DIR
KILL DIR
+5 IF (X="")!(X="^")!(Y=-1)
QUIT
+6 FOR I=1:1:$LENGTH(Y,",")-1
Begin DoDot:1
+7 SET PSOSLCT=$PIECE(Y,",",I)
+8 IF $PIECE(PSOCAN(PSOSLCT),"^",5)=""
SET X($PIECE(PSOCAN(PSOSLCT),"^",1))=$PIECE(PSOCAN(PSOSLCT),"^",2)
QUIT
End DoDot:1
SELECT3 WRITE !!,"Do you wish to continue (Y/N)? "
+1 READ X:DTIME
IF '$TEST
SET X="^"
IF X=""
QUIT
+2 IF "Yy"[$EXTRACT(X)
GOTO SELECT4
+3 IF "Nn^"[$EXTRACT(X)
QUIT
IF "?"[$EXTRACT(X)
DO HELP3
GOTO SELECT3
SELECT4 ; cancel charges for selected fills only
IF $ORDER(X(""))'=""
Begin DoDot:1
+1 ; remove unselected fills from cancellation list
SET I=""
FOR
SET I=$ORDER(PSOCAN(I))
IF I=""
QUIT
IF '$DATA(X($PIECE(PSOCAN(I),"^",1)))
KILL PSOCAN(I)
End DoDot:1
DO BILL2^PSOCPB
+2 QUIT
+3 ;
CHKCAN ; SEE IF SELECTION HAS ALREADY BEEN CANCELLED
+1 IF '$DATA(PSOCAN(J))
Begin DoDot:1
+2 IF J>12!(J'?0.2N)
WRITE $CHAR(7),!!,J," is an invalid selection. Please try again.",!
End DoDot:1
QUIT
+3 SET PSI=0
+4 IF $PIECE(PSOCAN(J),"^",5)="CANCEL"
SET PSOCOMM="Rx # "_PSORXN_" - "_$SELECT(+PSOCAN(J)>11:"Original fill",1:"Refill #"_+PSOCAN(J))_" copay charge has already been cancelled!"
DO SETSUMM^PSOCPC
+5 KILL PSI
+6 QUIT
+7 ;
