source: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPD.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1PSOCPD ;BHAM ISC/BaB - MULTIPLE COPAY CHARGE REMOVAL ;05/27/92
2 ;;7.0;OUTPATIENT PHARMACY;**71,85,201**;DEC 1997
3 ;
4 ;REF/IA
5 ;^IBARX/125
6 ; Originally released as part of the copayment enhancement patch
7 ; Mill Bill Copay enhancement -- entry point ASKCAN - called from PSOCPB
8CR I '$D(PSOPAR) S PSOINDPT="" D ^PSOLSET G CR ; Setup site parameters
9ASK K PSPEED,PSPEEDA,PSPOUT W ! R !,"PRESCRIPTION(s): ",PSX:DTIME S:'$T PSX="^" G LASTEX:"^"[PSX
10 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
11 G SPEED:PSX[","
12 I '$D(^PSRX("B",PSX)) W !!,PSX," is not a valid RX #!!" G ASK
13 S PSODA=$O(^PSRX("B",PSX,"")) W:PSODA="" !!,PSX," is not a valid RX #!!" G ASK:PSODA=""
14 I '$D(^PSRX(PSODA,"IB")) W !!,"Rx # ",$P($G(^PSRX(PSODA,0)),"^")," is NOT a COPAY transaction...NO action taken." G EXIT
15 D REASON G:Y<0 LASTEX D SPEED1,LASTEX
16 Q
17REASON ;
18 ; Get Cancellation reason
19 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
20 S PREA="C-CPD"
21 Q
22SPEED ;
23 S PSPEED=1 D REASON G:Y<0 LASTEX
24 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
25INVALD G:'$D(PSINV) ASK
26 W !!,"The following are INVALID choices:" S PSOI="" F PSOJ=0:0 S PSOI=$O(PSINV(PSOI)) Q:PSOI'>0 W !?10,PSOI
27 K PSINV
28 G ASK
29SPEED1 ;
30 S PSOFLAG=0
31 S PSO=1 ; Remove Co-Pay charge
32 S PSORXN=$P(^PSRX(PSODA,0),"^") ;..........Rx #
33 ; Determine if Rx is COPAY
34 I '$D(^PSRX(PSODA,"IB")) W !,"Rx # ",PSORXN," is NOT a COPAY transaction...NO action taken." G EXIT
35 S PSOIB=^PSRX(PSODA,"IB")
36 G:($P(PSOIB,"^",2)'>0)&('$D(^PSRX(PSODA,1))) ERRBIL ;No bill#/no refills
37 ;
38 ; Determine last entry in ^PSRX
39 S PSOREF=0
40 G:'$D(^PSRX(PSODA,1)) CANCEL
41 F PSZ=0:0 S PSZ=$O(^PSRX(PSODA,1,PSZ)) Q:PSZ'>0 S PSOREF=PSZ
42 G:$S('$D(^PSRX(PSODA,1,PSOREF,"IB")):1,(+^("IB"))'>0:1,1:0) ERRBIL ;..No bill #
43 S:PSOREF>0 PSOIB=^PSRX(PSODA,1,PSOREF,"IB")
44CANCEL ;
45 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
46 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
47 W ! K X
48 ; Set x=service^dfn^^user duz
49 ; x(n)=IB number^cancellation reason
50 ;
51 S X=PSOPAR7_"^"_+$P(^PSRX(PSODA,0),"^",2)_"^^"_DUZ
52 S:PSOREF=0 X(PSORXN)=+$P(PSOIB,"^",2)_"^"_PSORSN ; Original Rx
53 S:PSOREF>0 X(PSORXN)=+^PSRX(PSODA,1,PSOREF,"IB")_"^"_PSORSN ; Refill Rx
54 ;
55 D CANCEL^IBARX
56 ;
57 ; Return y=1 if success, -1^error code if error
58 ; y(n)=IB number^total charge^AR bill number
59 ;
60 I +Y=-1 W !,"......No action taken." G EXIT
61 G EXIT:'$D(Y(PSORXN))
62FILE ;
63 ; File new Bill # in ^PSRX
64 ;
65 S:PSOREF=0 $P(^PSRX(PSODA,"IB"),"^",2)=+Y(PSORXN) ;...Original Rx
66 S:PSOREF>0 ^PSRX(PSODA,1,PSOREF,"IB")=+Y(PSORXN) ; ...Refill Rx
67 W:PSO=1 !!,"Co-Pay transaction for Rx # ",PSORXN,$S(PSOREF>0:" refill # "_PSOREF,1:"")," has been cancelled."
68 ;
69 D ACTLOG^PSOCPA
70 ;
71 G EXIT
72ERRBIL W !!,"No Entry # for Rx # "_$P($G(^PSRX(PSODA,0)),"^")_" ...No action taken."
73EXIT ;
74 K PREA,C,PSO,PSODA,PSOIB,PSOPARNT,PSOREF,PSORXN,PSZ,X,Y
75 Q
76LASTEX ;
77 K PSO,PSPOUT,PSPEED,PSPEEDA,PSOCPUN,PSODA,PSOFLAG,PSOIB,PSOPARNT,PSOREF,PSORSN,PSORXN,PSZ,X,Y,PSINV,PSOI,PSX,PSOJ,PREA,C
78 I $D(PSOINDPT) K PSOINDPT D FINAL^PSOLSET
79 Q
80ENDMSG ;
81 W !!,"Unable to process without REASON entry."
82 Q
83 ;
84ASKCAN ; if any charges currently, give option to cancel some or all
85 I '$D(^PSRX(PSODA,"IB")) Q ;ok to quit based on IB node for PFSS because always have IB node when copay is billed.
86 N J,PSOREF,PSOCAN,CANTYPE
87 K X,XX
88 S J=0
89 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
90 I $P(^PSRX(PSODA,"IB"),"^",2)>0 S X(PSORXN)=$P(^PSRX(PSODA,"IB"),"^",2),J=1,PSOCAN(J)=PSORXN_"^"_X(PSORXN) ; original fill
91 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
92PFS D REFILL^PSOCPB
93 I '$D(X),'$D(XX) Q ; no "IB" numbers on original or refills
94 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"
95 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"
96ASKCAN2 W !!,"Do you want to cancel any charges (Y/N)? "
97 R X:DTIME S:'$T X="^" Q:X="" G:"Yy"[$E(X) ASKALL Q:"Nn^"[$E(X) D HELP2:"?"[$E(X) G ASKCAN2
98HELP2 W !,"Answering YES will allow cancelling of all or selected charges"
99 Q
100HELP3 W !,"Answering YES will proceed with cancelling selected charges"
101 Q
102ASKALL ;PFS - check copay activity log to see if any fills were previously cancelled; mark as cancelled for display
103 N PSOPFSD,PSOFIL D GETS^DIQ(52,PSODA,"107*","I","PSOPFSD") D:$D(PSOPFSD)
104 .F I=1:1 Q:'$D(PSOPFSD(52.0107,I_","_PSODA_",")) D:$G(PSOPFSD(52.0107,I_","_PSODA_",",1,"I"))="C"
105 ..S PSOFIL=$G(PSOPFSD(52.0107,I_","_PSODA_",",3,"I")),J=""
106 ..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"
107 K PSOFIL,PSOPFSD
108 ;
109 W !!,"(A)ll or (S)elect Charges? (A/S): "
110 R X:DTIME S:'$T X="^" I X="" Q
111 I X="^" Q
112 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
113 I X="A"!(X="a") D D BILL2^PSOCPB Q
114 .W !!,"**********Charges are on file for this Rx.**********"
115 .W !,"Proceeding with cancellation of ALL charges."
116 .S CANTYPE=1
117 S CANTYPE=0
118 D SELECT
119 Q
120 ;
121SELECT ; Choose from list of fills that have charges
122 N J,I,PSORELDT,PSOBILL,FOOTNOTE
123 K FOOTNOTE
124 K X
125 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
126 .S PSOBILL=""
127 .I $P(PSOCAN(J),"^",10)'="PFS" D
128 ..I PSOCAN(J)["CAP" S PSOBILL="(Potential Charge *)",FOOTNOTE=1
129 ..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:"")
130 .I $P(PSOCAN(J),"^",10)="PFS" S:$P(PSOCAN(J),"^",5)="CANCEL" PSOBILL="(Charge Cancelled)"
131 .N RX2
132 .S RX2=$S(+PSOCAN(J)>11:$G(^PSRX(PSODA,2)),1:$G(^PSRX(PSODA,1,+PSOCAN(J),0)))
133 .I RX2="" S PSORELDT="" Q
134 .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
135 .S PSORELDT=$E($P(RX2,"^",18),4,5)_"/"_$E($P(RX2,"^",18),6,7)_"/"_$E($P(RX2,"^",18),2,3)
136 I $D(FOOTNOTE) D
137 . W !!,"* Potential charge indicates fill was not billed due to the annual cap."
138 . W !,"If cancelled, this fill will not be considered for future copay billing."
139SELECT2 ;
140 K DIR
141 S DIR("?")="Select a list or a range, e.g., 1,3,5 or 2-5,8"
142 S DIR(0)="LO^1:"_(J-1)
143 D ^DIR K DIR
144 Q:(X="")!(X="^")!(Y=-1)
145 F I=1:1:$L(Y,",")-1 D
146 . S PSOSLCT=$P(Y,",",I)
147 . I $P(PSOCAN(PSOSLCT),"^",5)="" S X($P(PSOCAN(PSOSLCT),"^",1))=$P(PSOCAN(PSOSLCT),"^",2) Q
148SELECT3 W !!,"Do you wish to continue (Y/N)? "
149 R X:DTIME S:'$T X="^" I X="" Q
150 I "Yy"[$E(X) G SELECT4
151 Q:"Nn^"[$E(X) D HELP3:"?"[$E(X) G SELECT3
152SELECT4 I $O(X(""))'="" D D BILL2^PSOCPB ; cancel charges for selected fills only
153 . 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
154 Q
155 ;
156CHKCAN ; SEE IF SELECTION HAS ALREADY BEEN CANCELLED
157 I '$D(PSOCAN(J)) D Q
158 . I J>12!(J'?0.2N) W $C(7),!!,J," is an invalid selection. Please try again.",!
159 S PSI=0
160 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
161 K PSI
162 Q
163 ;
Note: See TracBrowser for help on using the repository browser.