- 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
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCPD 8520 printed Feb 18, 2025@23:52:18 Page 2
- 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 ;
