source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPE.m@ 1046

Last change on this file since 1046 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version
File size: 9.0 KB
Line 
1PSOCPE ;BIR/BAB - PHARMACY COPAY APPLICATION UTILITIES FOR IB ;10/26/92
2 ;;7.0;OUTPATPSOCT PHARMACY;**26,71,85,114,157,219,268**;DEC 1997;Build 9
3 ;
4 ;REF/IA
5 ;^XUSEC/10076
6 ;^PSDRUG(/221
7 ;Routine initially released as part of the copayment enhancement.
8 ;called from PSOLBL
9INV ; Entry point from PSOCP - Prints one copay invoice
10 I '$D(PSOCPN)!($G(RXP)) Q
11 S PSOCPBAR=0
12 I $D(PSOBARS),PSOBARS S PSOCPBAR=1
13 D DEM^VADPT S Y=DT X ^DD("DD") S EDT=Y
14 W ?54,"PRESCRIPTION COPAYMENT INFORMATION"
15 W !!,?54,VADM(1)," ",VA("PID")," ",EDT
16 S PSZ1=0,PSZ2="",PSOCPBN=$P(VADM(2),"^"),PSOCPBN=$S(PSOCPBN]"":PSOCPBN,1:"Unavailable")
17 ;I '$G(PSOCPN) S PSOCPN=$P(^PSRX(RX,0),U,2)
18 I PSOCPBAR,(PSOCPBN]"") S X="S",X2=PSOCPBN W !,?54,@PSOBAR1,PSOCPBN,@PSOBAR0
19 E W !
20 W !,?54,"The following prescriptions are"
21 W !,?54,"eligible for prescription copayment.",!!
22DRUG S PSZ2="" F S PSZ2=$O(^TMP($J,"PSOCP",PSOCPN,PSZ2)) Q:PSZ2']"" S PSZ=^(PSZ2) D PRT
23NAR ; Print narrative from site parameter file
24 K ^UTILITY($J,"W") S DIWL=55,DIWR=99,DIWF="" W !
25 G:'$D(^PS(59,PSOSITE,4,0)) END
26 G:$P(^PS(59,PSOSITE,4,0),"^",3)'>0 END
27 F PSO9=0:0 S PSO9=$O(^PS(59,PSOSITE,4,PSO9)) G:'PSO9 P1 I $D(^PS(59,PSOSITE,4,PSO9,0)) S X=^(0) D ^DIWP
28P1 D ^DIWW
29 K DIWF,DIWL,DIWR,PSO9
30END ;
31 W @IOF
32 K ^TMP($J,"PSOCP",PSOCPN),PSOCPBAR,PSOCPBN,PSZ1,PSZ2,PSOCPN,DIWF,DIWL,DIWR,PSO9
33 Q
34PRT ;
35 W ?54,PSZ2
36 W ?72," ",$P(^TMP($J,"PSOCP",PSOCPN,PSZ2),"^",3)," ","Days Supply",!
37 W ?56,$E($P(^TMP($J,"PSOCP",PSOCPN,PSZ2),U,2),1,45),!
38 Q
39XMPT ; Entry point for menu option to select copay exemption
40 N PSORXPNM,PSORXPRE,PSOCPEDA
41 I '$D(PSOPAR) D ^PSOLSET G XMPT
42 W ! S (DIC,DIE)="^PS(53,",DIC(0)="AEQMZ" D ^DIC K DIC G:Y<0 QUIT
43 G:$D(DTOUT) QUIT
44 S PSORXPRE=$P($G(^PS(53,+$G(Y),0)),"^",7)
45 S PSORXPNM=$P($G(^PS(53,+$G(Y),0)),"^")
46 S DA=+Y,DR="15" L +^PS(53,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !!,PSORXPNM_" is locked by another user. Try Later!" W ! D PAGE G QUIT
47 W ! D ^DIE
48 I PSORXPRE,$P($G(^PS(53,DA,0)),"^",7) W !!,"All Rx's entered with this Rx Patient Status will be EXEMPT from Copayment.",! D PAGE L -^PS(53,DA) G QUIT
49 I 'PSORXPRE,'$P($G(^PS(53,DA,0)),"^",7) W !!,"All Rx's entered with this Rx Patient Status will NOT be exempt from Copayment.",! D PAGE L -^PS(53,DA) G QUIT
50 D WARN L -^PS(53,DA)
51QUIT K PSORXPRE,DIE,DIC,DA,DR,X,C,Y
52 Q
53PAGE ;
54 I '$G(DUZ("AUTO")) K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
55 Q
56WARN ;
57 S PSOCPEDA=$G(DA)
58 W !!?28,"**** WARNING ****",!
59 I 'PSORXPRE W !,"By setting the Exempt from Copayment for the Rx Patient Status of",!,PSORXPNM," to 'YES', every prescription entered",!,"with this Rx Patient Status will NOT be charged a Copayment.",!
60 I PSORXPRE W !,"By setting the EXEMPT FROM COPAYMENT for the Rx Patient Status of ",!,PSORXPNM," to 'NO', prescriptions entered with this Rx",!,"Patient Status from this point on will NOT be exempt from Copayment.",!
61 W !,"A mail message will be sent to PSORPH and PSO COPAY Key holders informing",!,"them of your change."
62 W ! K DIR S DIR(0)="Y",DIR("A")="Are you sure you want to do this",DIR("B")="Y" D ^DIR K DIR
63 I $G(Y) D D MAIL G WARNX
64 .I 'PSORXPRE W !!,"Setting ",PSORXPNM," Rx Patient Status to Exempt from Copayment." Q
65 .W !!,"Setting Exempt from Copayment to 'NO' for the ",PSORXPNM,!,"Rx Patient Status."
66 I 'PSORXPRE W !!,"No action taken." S $P(^PS(53,PSOCPEDA,0),"^",7)=0 H 1
67 I PSORXPRE W !!,"No action taken." S $P(^PS(53,PSOCPEDA,0),"^",7)=1 H 1
68WARNX W ! D PAGE
69 S DA=$G(PSOCPEDA) K PSOCPEDA
70 Q
71MAIL ;
72 K PSOTXT,PSOCFN,PSODCPA
73 I $G(DUZ) S DIC=200,DR=".01",DA=DUZ,DIQ(0)="E",DIQ="PSODCPA(" D EN^DIQ1 S PSOCFN=$G(PSODCPA(200,DA,.01,"E")) K PSODCPA,DIC,DIQ,DR
74 I 'PSORXPRE S PSOTXT(1,0)="The "_PSORXPNM_" Rx Patient Status has been marked as",PSOTXT(2,0)="Exempt from Copayment by "_$G(PSOCFN)_".",PSOTXT(3,0)="Every prescription with this Rx Patient Status will not be charged a Copayment."
75 I PSORXPRE S PSOTXT(1,0)="The Exempt from Copayment status has been removed from the",PSOTXT(2,0)=PSORXPNM_" Rx Patient Status by "_$G(PSOCFN)_".",PSOTXT(3,0)="Prescriptions entered with this Rx Patient Status will not be exempt from"
76 I PSORXPRE S PSOTXT(4,0)="Copayment."
77 F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSORPH",PSOCXPDA)) Q:'PSOCXPDA S XMY(PSOCXPDA)=""
78 F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSO COPAY",PSOCXPDA)) Q:'PSOCXPDA S XMY(PSOCXPDA)=""
79 I $G(DUZ) S XMY(DUZ)=""
80 S XMSUB="Exempt from Copayment",XMTEXT="PSOTXT(",XMDUZ="Outpatient Pharmacy" D ^XMD
81 K PSOTXT,PSOCXPDA,XMDUZ,PSOCFN,XMTEXT,XMSUB,XMY
82 Q
83 ;
84MAIL2 ; SEND MAIL TO PHARMACIST, PROVIDER, AND HOLDERS OF PSO COPAY KEY
85 N PSOC,PSOTXT,X
86 K XMY
87 S XMSUB="PRESCRIPTION QUESTIONS REVIEW NEEDED"
88 S XMDUZ="Outpatient Pharmacy Package"
89 S PSOTXT(1)=" "
90 S DFN=+$P($G(^PSRX(RXP,0)),"^",2) D PID^VADPT
91 S PSODIV=$P($G(^PSRX(RXP,2)),"^",9) S:PSODIV'="" XMSUB=XMSUB_" ("_$P($G(^PS(59,PSODIV,0)),"^",6)_")",PSODIV=$P($G(^PS(59,PSODIV,0)),"^",1) ; ADDED DIVISION NUMBER TO SUBJECT LINE - PATCH 85
92 S PSOTXT(2)=$P($G(^DPT($P(^PSRX(RXP,0),"^",2),0)),"^",1)_" ("_$G(VA("BID"))_")"_" "_PSODIV
93 D ELIG
94 S PSOTXT(PSOC)="Rx# "_$P(^PSRX(RXP,0),"^",1)_" ("_PSOREF_") "_$S('$G(^PSRX(RXP,"IB")):"NO COPAY",1:"COPAY")
95 S PSOC=PSOC+1
96 S DRG=+$P(^PSRX(RXP,0),"^",6)
97 S PSOC=PSOC+1
98 S PSOTXT(PSOC)=$P($G(^PSDRUG(DRG,0)),"^",1)
99 S PSOC=PSOC+1
100 S PSOTXT(PSOC)=" "
101 S PSOC=PSOC+1
102 S PSOTXT(PSOC)="Due to a change in criteria, additional information listed below is needed"
103 S PSOC=PSOC+1
104 S PSOTXT(PSOC)="to determine the final VA copay and/or insurance billable status for this Rx"
105 S PSOC=PSOC+1
106 S PSOTXT(PSOC)="so that appropriate action can be taken by pharmacy personnel."
107 S PSOC=PSOC+1
108 S PSOTXT(PSOC)=" "
109 S PSOC=PSOC+1
110 F EXMT="SC","CV","AO","IR","EC","MST","HNC" I $D(PSOTG(EXMT)) D
111 . I PSOTG(EXMT)'="" Q
112 . S PSOLTAG="REL"_EXMT
113 . S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q
114 . S PSOC=PSOC+1,PSOTXT(PSOC)=PSOQUES
115 . S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q
116 S PSOC=PSOC+1,PSOTXT(PSOC)=" "
117 S PSOC=PSOC+1,PSOTXT(PSOC)="This message has been sent to the provider of record, the pharmacist who"
118 S PSOC=PSOC+1,PSOTXT(PSOC)="finished the prescription order, and all holders of the PSO COPAY key."
119 S PSOC=PSOC+1,PSOTXT(PSOC)=" "
120 S PSOC=PSOC+1,PSOTXT(PSOC)="Providers:"
121 S PSOC=PSOC+1,PSOTXT(PSOC)="Please respond with your answer to the question(s) as a reply to this"
122 S PSOC=PSOC+1,PSOTXT(PSOC)="message. The prescription will be updated by the appropriate staff."
123 S PSOC=PSOC+1,PSOTXT(PSOC)=" "
124 S PSOC=PSOC+1,PSOTXT(PSOC)="Staff assigned to update the Prescription responses:"
125 S PSOC=PSOC+1,PSOTXT(PSOC)="Please use the RESET COPAY STATUS/CANCEL CHARGES option to enter the responses"
126 S PSOC=PSOC+1,PSOTXT(PSOC)="to the questions above, which may result in a Rx copay status change and/or"
127 S PSOC=PSOC+1,PSOTXT(PSOC)="the need to remove VA copay charges or may result in a charge to the patient's"
128 S PSOC=PSOC+1,PSOTXT(PSOC)="insurance carrier."
129 S PSOC=PSOC+1,PSOTXT(PSOC)=" "
130 S PSOC=PSOC+1,PSOTXT(PSOC)="Note: The SC question is now asked for Veterans who are SC>49% in order to"
131 S PSOC=PSOC+1,PSOTXT(PSOC)="determine if the Rx can be billed to a third party insurance. These Veterans"
132 S PSOC=PSOC+1,PSOTXT(PSOC)="will NOT be charged a VA copay."
133 S PSOC=PSOC+1,PSOTXT(PSOC)=" "
134 S PSOC=PSOC+1,PSOTXT(PSOC)="Supply and investigational drugs are not charged a VA copay but could be"
135 S PSOC=PSOC+1,PSOTXT(PSOC)="reimbursable by third party insurance."
136 ; S XMY() TO ALL THE RECIPIENTS
137 I '$G(PSOREF) S XMY(+$P(^PSRX(RXP,0),"^",4))="" ; ORIGINAL
138 I $G(PSOREF) S XMY(+$P(^PSRX(RXP,1,PSOREF,0),"^",17))="" ; REFILL
139 I $G(^PSRX(RXP,"OR1")) I $P(^PSRX(RXP,"OR1"),"^",5)'="" S XMY($P(^PSRX(RXP,"OR1"),"^",5))=""
140 F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSO COPAY",PSOCXPDA)) Q:'PSOCXPDA S XMY(PSOCXPDA)=""
141 S XMTEXT="PSOTXT("
142 D ^XMD K XMSUB,XMY,XMDUZ,XMTEXT,PSODIV,PSOCXPDA,PSOLTAG,PSOC,PSOQUES,PSOTG
143 Q
144 ;
145ELIG D ELIG^VADPT S PSOC=3,PSOTXT(PSOC)="Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:""),PSOC=PSOC+1
146 N N,I,I1,PSDIS,PSCNT
147 S N=0 F S N=$O(VAEL(1,N)) Q:'N S $P(PSOTXT(PSOC)," ",14)=$P(VAEL(1,N),"^",2),PSOC=PSOC+1
148 S PSOTXT(PSOC)=" ",PSOC=PSOC+1,PSOTXT(PSOC)="Disabilities: "
149 F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1
150 .S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),PSCNT=$P(I1,"^",2)
151 .S:$L(PSOTXT(PSOC)_PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")>80 PSOC=PSOC+1,$P(PSOTXT(PSOC)," ",14)=" "
152 .S PSOTXT(PSOC)=$G(PSOTXT(PSOC))_PSDIS_"-"_PSCNT_"%("_$S($P(I1,"^",3):"SC",1:"NSC")_"), "
153 S PSOC=PSOC+1 S PSOTXT(PSOC)=" ",PSOC=PSOC+1
154 Q
155 ;
156 ;EXEMPTION QUESTIONS - MAIL MESSAGE POSITION;SUBSCRIPT IN "IBQ" NODE
157RELSC ;Is this Rx for a Service Connected Condition?;1
158RELMST ;Is this Rx related to the treatment of Military Sexual Trauma?;2
159RELAO ;Is this Rx for treatment of Vietnam-Era Herbicide (Agent Orange) exposure?;3
160RELIR ;Is this Rx for treatment of Ionizing Radiation exposure?;4
161RELEC ;Is this Rx for treatment of Environmental Contaminants exposure?;5
162RELHNC ;Is this Rx related to treatment of Head and/or Neck Cancer?;6
163RELCV ;Is this Rx potentially for treatment related to Combat?;7
164 ;
Note: See TracBrowser for help on using the repository browser.