source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPB.m@ 1708

Last change on this file since 1708 was 613, checked in by George Lilly, 16 years ago

initial load of WorldVistAEHR
File size: 9.5 KB
RevLine 
[613]1PSOCPB ;BIR/BaB - pharmacy co-pay application cont'd ; 1/30/07 9:08am
2 ;;7.0;OUTPATIENT PHARMACY;**72,71,85,185,143,219,239,201,263**;DEC 1997;Build 11
3 ;
4 ;REF/IA
5 ;DIS^SDROUT2/112
6 ;^IBARX/125
7 ;VADPT/10061
8 ;SWSTAT^IBBAPI/4663
9COPAY ;
10 ;Called by PSON52,PSORN52...Requires PSOCPAY,PSOBILL,DEA=PSDEA,PSOFLAG
11 ;PSOFLAG=1 NEW, PSOFLAG=0 RENEW
12 S PSOSAVE=PSOCPAY ; Save original status of PSOCPAY
13 I '$G(PSOSCP)!('$G(PSOSCA)) D SCP^PSORN52D ;CIDC-must ask sc if flagged for it in enrollment
14 I $G(PSODRUG("DEA"))["S"!($G(PSODRUG("DEA"))["I") S PSOCPAY=0
15 G:+PSOBILL'=2&('$G(PSOSCA)) COPAY2
16 D FULL^VALM1
17 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
18 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
19 S DFN=+$G(PSODFN) D DIS^SDROUT2
20ASK ;
21 N PSOUFLAG S PSOUFLAG=0
22 K PSOCPZ("DFLG"),PSONEW("NEWCOPAY")
23 W ! K DIR,DTOUT,DIRUT,DUOUT
24 I $G(PSORX("SC"))="SC"!($G(PSORX("SC"))="NSC")!($G(PSOSCOTH)) D
25 . W:PSOSCP<50&($G(PSODRUG("DEA"))'["S")&($G(PSODRUG("DEA"))'["I") !,"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
26 S DIR("A")="Was treatment for Service Connected condition",DIR(0)="Y"
27 S DIR("?")="Enter 'Yes' if this prescription is for a Service Connected condition"
28 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:"")
29 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")
30 I $G(DIR("B"))="YES"!($G(DIR("B"))="NO") S PSOUFLAG=$G(DIR("B"))
31 I $G(DIR("B"))="" K DIR("B")
32 D ^DIR
33 I $G(Y)=1!($G(Y)=0) S PSOANSQ("SC")=$G(Y) I $G(PSONEWFF),$G(PSOFLAG) S PSOANSQD("SC")=$G(Y)
34 I PSOFLAG I Y["^"!($D(DTOUT))!($D(DUOUT)) S PSOCPZ("DFLG")=1
35 S:Y=0 Y=2
36 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
37 .W !!,"This Renewal has been designated as "_$S($G(PSOUFLAG)="YES":"SERVICE CONNECTED",1:"NON-SERVICE CONNECTED.")
38 .W:PSOSCP<50&($G(PSODRUG("DEA"))'["S")&($G(PSODRUG("DEA"))'["I") !,"Please use the 'Reset Copay Status/Cancel Charges' option to make corrections."
39 .S PSOANSQ("SC")=$S($G(PSOUFLAG)="YES":1,1:0)
40 I $G(PSOFLAG),$G(PSOCPZ("DFLG")) G EXIT
41 S:PSOANSR=1 PSOCPAY=0 S:PSOANSR=2 $P(PSOCPAY,"^")=1
42COPAY2 ;
43 N PSOPFS S PSOPFS=$$SWSTAT^IBBAPI()
44 I +PSOCPAY=1,($P(PSOCPAY,"^",2)=1)!($P(PSOCPAY,"^",2)=2) D
45 .;set IB node in ^PSRX for copay if xactn type is 1 or 2
46 .S PSONEW("NEWCOPAY")=$P($G(PSOCPAY),"^",2)_"^^"_$S(+$G(PSOPFS):"",1:$P($G(PSOCPAY),"^",2))
47EXIT ;
48 S PSOCPAY=PSOSAVE ;Restore val of PSOCPAY
49 K PSOSAVE,PSOANSR,DIR,DUOUT,DIRUT,DTOUT,Y,X
50 Q
51RESET ;RESET COPAY STATUS
52 K PSOSUMM,PSOPFS,PSOPFSA,PSOLFIL,PSOPFSG
53 I '$D(PSOPAR) D ^PSOLSET G RESET
54 W ! S DIC="^PSRX(",DIC(0)="AEQZ" D ^DIC K DIC G:Y<0 EXT S PSODA=+Y
55 W !,?17,"PATIENT: ",$P($G(^DPT($P(^PSRX(PSODA,0),"^",2),0)),"^")
56 D ICN^PSODPT($P(^PSRX(PSODA,0),"^",2))
57 S PSORXN=$P(^PSRX(PSODA,0),"^"),PREA="R"
58 S PCOPAY=$G(^PSRX(PSODA,"IB"))
59 W !!,"Rx # ",PSORXN," is a ",$S(+PCOPAY:"Copay",1:"No Copay")," prescription"
60 S PSOLFIL=$$LF^PSOPFSU1(PSODA) D PFSA^PSOPFSU1(PSODA,PSOLFIL,3) ;PSOCPC def PSOPFSA=1 if OP SC/EI's change.
61 D EXEMCHK^PSOCPC ; CHECK/CHANGE EXEMPTION FLAGS
62 S PSOIBQ=$G(^PSRX(PSODA,"IBQ"))
63 I '$G(^PSRX(PSODA,"IB")),PSOIBQ'["1" D G ASKCAN
64 . K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")="Do you want to reset the status to COPAY" D ^DIR K DIR
65 . I Y'=1 Q
66 . 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
67 . S PREA="R",PSOOLD="No Copay",PSONW="Copay",PSOCOMM="" D ACTLOG^PSOCPA
68 . S PSI=0,PSOCOMM="Copay status of this Rx has been reset to COPAY." D SETSUMM^PSOCPC
69 . S $P(^PSRX(PSODA,"IB"),"^")=1 ;Reset flag to COPAY
70 ;
71 I $G(^PSRX(PSODA,"IB")) D G ASKCAN
72 . 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
73 . I Y'=1 Q
74 . 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
75 . S PREA="R",PSOOLD="Copay",PSONW="No Copay",PSOCOMM="" D ACTLOG^PSOCPA
76 . S PSI=0,PSOCOMM="Copay status of this Rx has been reset to NO COPAY." D SETSUMM^PSOCPC
77 . S $P(^PSRX(PSODA,"IB"),"^")="" ;Reset flag to NO COPAY
78ASKCAN D ASKCAN^PSOCPD
79 I '$D(PSOSUMM) S PSI=0,PSOCOMM="No action taken" D SETSUMM^PSOCPC
80 D PRTSUMM
81 I $P($G(PSOPFS),"^",3)>0&(+$G(PSOPFSA)) D CHRG^PSOPFSU1(PSODA,PSOLFIL,"CG",PSOPFS)
82RESETE K PSODA,PSORXN,PSORSN,PSOREF,X,Y,PCOPAY,PREA,PSOCOMM,PSI
83 G RESET
84EXT K PSODA,PSORXN,PSORSN,PSOREF,X,Y,PCOPAY,PREA,PSOCOPAY
85 Q
86BILLED ;Collect IB nums,cancel chrgs,reset flag.
87 W !!,"**********Charges are on file for this Rx.**********"
88 Q
89BILL2 ;
90 N PSOPREV ; VAR FOR PREV CANCELLED
91 S PSOPREV=0
92 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
93 S X=PSOPAR7_"^"_+$P(^PSRX(PSODA,0),"^",2)_"^^"_DUZ
94 S SAVX=X
95 I $D(PSOCAN) D:'$G(PSOPFS) I +$G(PSOPFS)!($G(PSOPFSG)) D PFS^PSOPFSU1 G BILL2END:'$D(PSOCAN)
96 . 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
97 D POTBILL2
98 I '$D(PSOCAN) G BILL2END
99 I $G(CANTYPE) D PREVCAN I $O(X(""))="" Q
100 I '$G(CANTYPE) S I="" F S I=$O(PSOCAN(I)) Q:I="" S X($P(PSOCAN(I),"^",1))=$P(PSOCAN(I),"^",2)_"^"_PSORSN
101 D CANCEL^IBARX
102 I $G(CANTYPE) D MSG
103 I '$D(Y) Q
104 I +Y=-1 Q
105 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
106 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
107BILL2END K X,Y,SAVX,PSOREF,PSOCAN
108 Q
109 ;
110POTBILL2 ;see if any potential charges (entries from file 354.71 -- bills that exceeded cap prev) to be cancelled before cancelling regular charges
111 N X,I
112 S X=SAVX
113 I $T(CANIBAM^IBARX)="" Q
114 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)
115 I $O(X(""))="" Q
116 S PSOPREV=1
117 D CANIBAM^IBARX
118 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)
119 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
120 K PSOREF,PREA,PSOCOMM
121 Q
122REFILL S PSOREF=0
123 F S PSOREF=$O(^PSRX(PSODA,1,PSOREF)) Q:PSOREF'?1N.N D
124 . I $D(^PSRX(PSODA,1,PSOREF,"PFS")) S:$P($G(^PSRX(PSODA,1,PSOREF,"PFS")),"^",2) X(PSOREF)="^"_$G(PSORSN) Q
125 . I $D(^PSRX(PSODA,1,PSOREF,"IB")),+^("IB")>0 S X(PSOREF)=+^PSRX(PSODA,1,PSOREF,"IB")_"^"_$G(PSORSN)
126 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
127 Q
128SETCP ;IF NOT COPAY MAKE ELIG CALL/SET FLAG FOR FUTURE
129 W ! S X=PSOPAR7_"^"_+$P(^PSRX(PSODA,0),"^",2)
130 D XTYPE^IBARX
131 I +Y=-1 W !!,"Error in processing Copay eligibility, no action taken." Q
132 S (ACTYP,BL)="",(PSOBILL,PSOCPAY)=0
133CP ;
134 S ACTYP=$O(Y(ACTYP)) G:'ACTYP CP1
135 F I=0:0 S BL=$O(Y(ACTYP,BL)) Q:BL="" I BL>0 S PSOBILL=BL,PSOCPAY=ACTYP
136 G CP
137CP1 K ACTYP,BL,I
138 I (PSOBILL'>0)!(PSOCPAY=0) G INELIG
139 S $P(^PSRX(PSODA,"IB"),"^")=PSOCPAY
140 W !,"COPAY status on this Rx has been reset.",!,"*** Future refills will be classified as COPAY."
141 S PREA="R",PSOOLD="No Copay",PSONW="Copay"
142 D ACTLOG^PSOCPA
143 Q
144INELIG W !,"This Rx does not meet patient eligibility requirement for Copay.",!,"****** Status unchanged *******"
145 S Y=-1
146 Q
147ENDMSG K X W !,"Unable to process CHARGE REMOVAL without REASON for Reset."
148 R !,"ENTER a REASON now? (Y/N) ",X:DTIME Q:'$T
149 I ($E(X)["?")!("YyNn^"'[$E(X)) W !,"Enter YES to select REASON and RESET STATUS." G ENDMSG
150 I "Yy"[$E(X) G BILL2
151 Q
152MSG ;
153 S PSI=0
154 I $G(CANTYPE) S PSOCOMM="Rx # "_PSORXN_" - All copay charges cancelled" D SETSUMM^PSOCPC K PSOCOMM Q
155 S PSOCOMM="Rx # "_PSORXN_" - "_$S(PSOREF=0:"Original fill",1:"Refill "_PSOREF)_" copay charge cancelled"
156 D SETSUMM^PSOCPC
157 K PSOCOMM
158 Q
159POTMSG ;
160 S PSI=0
161 I $G(CANTYPE) Q ; (MESSAGE WILL GET SET LATER)
162 S PSOCOMM="Rx # "_PSORXN_" - "_$S(PSOREF=0:"Original fill",1:"Refill "_PSOREF)_" potential copay charge cancelled"
163 D SETSUMM^PSOCPC
164 K PSOCOMM
165 Q
166MSGNOCAN ;
167 S PSI=0
168 S PSOCOMM="Rx # "_PSORXN_" - All copay charges have already been cancelled." D SETSUMM^PSOCPC K PSOCOMM
169 Q
170 ;
171PRTSUMM ; prt sum of actions in reset/cancel
172 I '$D(PSOSUMM) Q
173 W !
174 S PSI=""
175 F S PSI=$O(PSOSUMM(PSI)) Q:PSI="" W !,PSOSUMM(PSI)
176 K PSOSUMM
177 Q
178PREVCAN ; PREVIEW CANCELS IF "ALL" IS SELECTED
179 N I,PSOBILL
180 S I="" F S I=$O(PSOCAN(I)) Q:I="" D I PSOBILL S X($P(PSOCAN(I),"^",1))=$P(PSOCAN(I),"^",2)_"^"_PSORSN
181 . 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
182 I $O(X(""))="" D
183 . I PSOPREV D MSG Q
184 . D MSGNOCAN
185 Q
186 ;
Note: See TracBrowser for help on using the repository browser.