PSOCPE ;BIR/BAB - PHARMACY COPAY APPLICATION UTILITIES FOR IB ;10/26/92
;;7.0;OUTPATPSOCT PHARMACY;**26,71,85,114,157,219,268,225,303**;DEC 1997;Build 19
;
;REF/IA
;^XUSEC/10076
;^PSDRUG(/221
;Routine initially released as part of the copayment enhancement.
;called from PSOLBL
INV ; Entry point from PSOCP - Prints one copay invoice
I '$D(PSOCPN)!($G(RXP)) Q
S PSOCPBAR=0
I $D(PSOBARS),PSOBARS S PSOCPBAR=1
D DEM^VADPT S Y=DT X ^DD("DD") S EDT=Y
W ?54,"PRESCRIPTION COPAYMENT INFORMATION"
W !!,?54,VADM(1)," ",VA("PID")," ",EDT
S PSZ1=0,PSZ2="",PSOCPBN=$P(VADM(2),"^"),PSOCPBN=$S(PSOCPBN]"":PSOCPBN,1:"Unavailable")
;I '$G(PSOCPN) S PSOCPN=$P(^PSRX(RX,0),U,2)
I PSOCPBAR,(PSOCPBN]"") S X="S",X2=PSOCPBN W !,?54,@PSOBAR1,PSOCPBN,@PSOBAR0
E W !
W !,?54,"The following prescriptions are"
W !,?54,"eligible for prescription copayment.",!!
DRUG S PSZ2="" F S PSZ2=$O(^TMP($J,"PSOCP",PSOCPN,PSZ2)) Q:PSZ2']"" S PSZ=^(PSZ2) D PRT
NAR ; Print narrative from site parameter file
K ^UTILITY($J,"W") S DIWL=55,DIWR=99,DIWF="" W !
G:'$D(^PS(59,PSOSITE,4,0)) END
G:$P(^PS(59,PSOSITE,4,0),"^",3)'>0 END
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
P1 D ^DIWW
K DIWF,DIWL,DIWR,PSO9
END ;
W @IOF
K ^TMP($J,"PSOCP",PSOCPN),PSOCPBAR,PSOCPBN,PSZ1,PSZ2,PSOCPN,DIWF,DIWL,DIWR,PSO9
Q
PRT ;
W ?54,PSZ2
W ?72," ",$P(^TMP($J,"PSOCP",PSOCPN,PSZ2),"^",3)," ","Days Supply",!
W ?56,$E($P(^TMP($J,"PSOCP",PSOCPN,PSZ2),U,2),1,45),!
Q
XMPT ; Entry point for menu option to select copay exemption
N PSORXPNM,PSORXPRE,PSOCPEDA
I '$D(PSOPAR) D ^PSOLSET G XMPT
W ! S (DIC,DIE)="^PS(53,",DIC(0)="AEQMZ" D ^DIC K DIC G:Y<0 QUIT
G:$D(DTOUT) QUIT
S PSORXPRE=$P($G(^PS(53,+$G(Y),0)),"^",7)
S PSORXPNM=$P($G(^PS(53,+$G(Y),0)),"^")
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
W ! D ^DIE
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
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
D WARN L -^PS(53,DA)
QUIT K PSORXPRE,DIE,DIC,DA,DR,X,C,Y
Q
PAGE ;
I '$G(DUZ("AUTO")) K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
Q
WARN ;
S PSOCPEDA=$G(DA)
W !!?28,"**** WARNING ****",!
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.",!
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.",!
W !,"A mail message will be sent to PSORPH and PSO COPAY Key holders informing",!,"them of your change."
W ! K DIR S DIR(0)="Y",DIR("A")="Are you sure you want to do this",DIR("B")="Y" D ^DIR K DIR
I $G(Y) D D MAIL G WARNX
.I 'PSORXPRE W !!,"Setting ",PSORXPNM," Rx Patient Status to Exempt from Copayment." Q
.W !!,"Setting Exempt from Copayment to 'NO' for the ",PSORXPNM,!,"Rx Patient Status."
I 'PSORXPRE W !!,"No action taken." S $P(^PS(53,PSOCPEDA,0),"^",7)=0 H 1
I PSORXPRE W !!,"No action taken." S $P(^PS(53,PSOCPEDA,0),"^",7)=1 H 1
WARNX W ! D PAGE
S DA=$G(PSOCPEDA) K PSOCPEDA
Q
MAIL ;
K PSOTXT,PSOCFN,PSODCPA
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
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."
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"
I PSORXPRE S PSOTXT(4,0)="Copayment."
F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSORPH",PSOCXPDA)) Q:'PSOCXPDA S XMY(PSOCXPDA)=""
F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSO COPAY",PSOCXPDA)) Q:'PSOCXPDA S XMY(PSOCXPDA)=""
I $G(DUZ) S XMY(DUZ)=""
S XMSUB="Exempt from Copayment",XMTEXT="PSOTXT(",XMDUZ="Outpatient Pharmacy" D ^XMD
K PSOTXT,PSOCXPDA,XMDUZ,PSOCFN,XMTEXT,XMSUB,XMY
Q
;
MAIL2 ; SEND MAIL TO PHARMACIST, PROVIDER, AND HOLDERS OF PSO COPAY KEY
N PSOC,PSOTXT,X
K XMY
S XMSUB="PRESCRIPTION QUESTIONS REVIEW NEEDED"
S XMDUZ="Outpatient Pharmacy Package"
S PSOTXT(1)=" "
S DFN=+$P($G(^PSRX(RXP,0)),"^",2) D PID^VADPT
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
S PSOTXT(2)=$P($G(^DPT($P(^PSRX(RXP,0),"^",2),0)),"^",1)_" ("_$G(VA("BID"))_")"_" "_PSODIV
D ELIG
S PSOTXT(PSOC)="Rx# "_$P(^PSRX(RXP,0),"^",1)_" ("_PSOREF_") "_$S('$G(^PSRX(RXP,"IB")):"NO COPAY",1:"COPAY")
S PSOC=PSOC+1
S DRG=+$P(^PSRX(RXP,0),"^",6)
S PSOC=PSOC+1
S PSOTXT(PSOC)=$P($G(^PSDRUG(DRG,0)),"^",1)
S PSOC=PSOC+1
S PSOTXT(PSOC)=" "
S PSOC=PSOC+1
S PSOTXT(PSOC)="Due to a change in criteria, additional information listed below is needed"
S PSOC=PSOC+1
S PSOTXT(PSOC)="to determine the final VA copay and/or insurance billable status for this Rx"
S PSOC=PSOC+1
S PSOTXT(PSOC)="so that appropriate action can be taken by pharmacy personnel."
S PSOC=PSOC+1
S PSOTXT(PSOC)=" "
S PSOC=PSOC+1
F EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC" I $D(PSOTG(EXMT)) D
. I PSOTG(EXMT)'="" Q
. S PSOLTAG="REL"_EXMT
. S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q
. S PSOC=PSOC+1,PSOTXT(PSOC)=PSOQUES
. S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q
S PSOC=PSOC+1,PSOTXT(PSOC)=" "
S PSOC=PSOC+1,PSOTXT(PSOC)="This message has been sent to the provider of record, the pharmacist who"
S PSOC=PSOC+1,PSOTXT(PSOC)="finished the prescription order, and all holders of the PSO COPAY key."
S PSOC=PSOC+1,PSOTXT(PSOC)=" "
S PSOC=PSOC+1,PSOTXT(PSOC)="Providers:"
S PSOC=PSOC+1,PSOTXT(PSOC)="Please respond with your answer to the question(s) as a reply to this"
S PSOC=PSOC+1,PSOTXT(PSOC)="message. The prescription will be updated by the appropriate staff."
S PSOC=PSOC+1,PSOTXT(PSOC)=" "
S PSOC=PSOC+1,PSOTXT(PSOC)="Staff assigned to update the Prescription responses:"
S PSOC=PSOC+1,PSOTXT(PSOC)="Please use the RESET COPAY STATUS/CANCEL CHARGES option to enter the responses"
S PSOC=PSOC+1,PSOTXT(PSOC)="to the questions above, which may result in a Rx copay status change and/or"
S PSOC=PSOC+1,PSOTXT(PSOC)="the need to remove VA copay charges or may result in a charge to the patient's"
S PSOC=PSOC+1,PSOTXT(PSOC)="insurance carrier."
S PSOC=PSOC+1,PSOTXT(PSOC)=" "
S PSOC=PSOC+1,PSOTXT(PSOC)="Note: The SC question is now asked for Veterans who are SC>49% in order to"
S PSOC=PSOC+1,PSOTXT(PSOC)="determine if the Rx can be billed to a third party insurance. These Veterans"
S PSOC=PSOC+1,PSOTXT(PSOC)="will NOT be charged a VA copay."
S PSOC=PSOC+1,PSOTXT(PSOC)=" "
S PSOC=PSOC+1,PSOTXT(PSOC)="Supply, nutritional and investigational drugs are not charged a VA copay"
S PSOC=PSOC+1,PSOTXT(PSOC)="but could be reimbursable by third party insurance."
; S XMY() TO ALL THE RECIPIENTS
I '$G(PSOREF) S XMY(+$P(^PSRX(RXP,0),"^",4))="" ; ORIGINAL
I $G(PSOREF) S XMY(+$P(^PSRX(RXP,1,PSOREF,0),"^",17))="" ; REFILL
I $G(^PSRX(RXP,"OR1")) I $P(^PSRX(RXP,"OR1"),"^",5)'="" S XMY($P(^PSRX(RXP,"OR1"),"^",5))=""
F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSO COPAY",PSOCXPDA)) Q:'PSOCXPDA S XMY(PSOCXPDA)=""
S XMTEXT="PSOTXT("
D ^XMD K XMSUB,XMY,XMDUZ,XMTEXT,PSODIV,PSOCXPDA,PSOLTAG,PSOC,PSOQUES,PSOTG
Q
;
ELIG 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
N N,I,I1,PSDIS,PSCNT
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
S PSOTXT(PSOC)=" ",PSOC=PSOC+1,PSOTXT(PSOC)="Disabilities: "
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
.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)
.S:$L(PSOTXT(PSOC)_PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")>80 PSOC=PSOC+1,$P(PSOTXT(PSOC)," ",14)=" "
.S PSOTXT(PSOC)=$G(PSOTXT(PSOC))_PSDIS_"-"_PSCNT_"%("_$S($P(I1,"^",3):"SC",1:"NSC")_"), "
S PSOC=PSOC+1 S PSOTXT(PSOC)=" ",PSOC=PSOC+1
Q
;
;EXEMPTION QUESTIONS - MAIL MESSAGE POSITION;SUBSCRIPT IN "IBQ" NODE
RELSC ;Is this Rx for a Service Connected Condition?;1
RELMST ;Is this Rx related to the treatment of Military Sexual Trauma?;2
RELAO ;Is this Rx for treatment of Vietnam-Era Herbicide (Agent Orange) exposure?;3
RELIR ;Is this Rx for treatment of Ionizing Radiation exposure?;4
RELEC ;Is this Rx for treatment related to service in SW Asia?;5
RELHNC ;Is this Rx related to treatment of Head and/or Neck Cancer?;6
RELCV ;Is this Rx potentially for treatment related to Combat?;7
RELSHAD ;Is this Rx related to treatment of PROJ 112/SHAD?;8
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCPE 9511 printed Oct 16, 2024@18:26:32 Page 2
PSOCPE ;BIR/BAB - PHARMACY COPAY APPLICATION UTILITIES FOR IB ;10/26/92
+1 ;;7.0;OUTPATPSOCT PHARMACY;**26,71,85,114,157,219,268,225,303**;DEC 1997;Build 19
+2 ;
+3 ;REF/IA
+4 ;^XUSEC/10076
+5 ;^PSDRUG(/221
+6 ;Routine initially released as part of the copayment enhancement.
+7 ;called from PSOLBL
INV ; Entry point from PSOCP - Prints one copay invoice
+1 IF '$DATA(PSOCPN)!($GET(RXP))
QUIT
+2 SET PSOCPBAR=0
+3 IF $DATA(PSOBARS)
IF PSOBARS
SET PSOCPBAR=1
+4 DO DEM^VADPT
SET Y=DT
XECUTE ^DD("DD")
SET EDT=Y
+5 WRITE ?54,"PRESCRIPTION COPAYMENT INFORMATION"
+6 WRITE !!,?54,VADM(1)," ",VA("PID")," ",EDT
+7 SET PSZ1=0
SET PSZ2=""
SET PSOCPBN=$PIECE(VADM(2),"^")
SET PSOCPBN=$SELECT(PSOCPBN]"":PSOCPBN,1:"Unavailable")
+8 ;I '$G(PSOCPN) S PSOCPN=$P(^PSRX(RX,0),U,2)
+9 IF PSOCPBAR
IF (PSOCPBN]"")
SET X="S"
SET X2=PSOCPBN
WRITE !,?54,@PSOBAR1,PSOCPBN,@PSOBAR0
+10 IF '$TEST
WRITE !
+11 WRITE !,?54,"The following prescriptions are"
+12 WRITE !,?54,"eligible for prescription copayment.",!!
DRUG SET PSZ2=""
FOR
SET PSZ2=$ORDER(^TMP($JOB,"PSOCP",PSOCPN,PSZ2))
if PSZ2']""
QUIT
SET PSZ=^(PSZ2)
DO PRT
NAR ; Print narrative from site parameter file
+1 KILL ^UTILITY($JOB,"W")
SET DIWL=55
SET DIWR=99
SET DIWF=""
WRITE !
+2 if '$DATA(^PS(59,PSOSITE,4,0))
GOTO END
+3 if $PIECE(^PS(59,PSOSITE,4,0),"^",3)'>0
GOTO END
+4 FOR PSO9=0:0
SET PSO9=$ORDER(^PS(59,PSOSITE,4,PSO9))
if 'PSO9
GOTO P1
IF $DATA(^PS(59,PSOSITE,4,PSO9,0))
SET X=^(0)
DO ^DIWP
P1 DO ^DIWW
+1 KILL DIWF,DIWL,DIWR,PSO9
END ;
+1 WRITE @IOF
+2 KILL ^TMP($JOB,"PSOCP",PSOCPN),PSOCPBAR,PSOCPBN,PSZ1,PSZ2,PSOCPN,DIWF,DIWL,DIWR,PSO9
+3 QUIT
PRT ;
+1 WRITE ?54,PSZ2
+2 WRITE ?72," ",$PIECE(^TMP($JOB,"PSOCP",PSOCPN,PSZ2),"^",3)," ","Days Supply",!
+3 WRITE ?56,$EXTRACT($PIECE(^TMP($JOB,"PSOCP",PSOCPN,PSZ2),U,2),1,45),!
+4 QUIT
XMPT ; Entry point for menu option to select copay exemption
+1 NEW PSORXPNM,PSORXPRE,PSOCPEDA
+2 IF '$DATA(PSOPAR)
DO ^PSOLSET
GOTO XMPT
+3 WRITE !
SET (DIC,DIE)="^PS(53,"
SET DIC(0)="AEQMZ"
DO ^DIC
KILL DIC
if Y<0
GOTO QUIT
+4 if $DATA(DTOUT)
GOTO QUIT
+5 SET PSORXPRE=$PIECE($GET(^PS(53,+$GET(Y),0)),"^",7)
+6 SET PSORXPNM=$PIECE($GET(^PS(53,+$GET(Y),0)),"^")
+7 SET DA=+Y
SET DR="15"
LOCK +^PS(53,DA):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
WRITE !!,PSORXPNM_" is locked by another user. Try Later!"
WRITE !
DO PAGE
GOTO QUIT
+8 WRITE !
DO ^DIE
+9 IF PSORXPRE
IF $PIECE($GET(^PS(53,DA,0)),"^",7)
WRITE !!,"All Rx's entered with this Rx Patient Status will be EXEMPT from Copayment.",!
DO PAGE
LOCK -^PS(53,DA)
GOTO QUIT
+10 IF 'PSORXPRE
IF '$PIECE($GET(^PS(53,DA,0)),"^",7)
WRITE !!,"All Rx's entered with this Rx Patient Status will NOT be exempt from Copayment.",!
DO PAGE
LOCK -^PS(53,DA)
GOTO QUIT
+11 DO WARN
LOCK -^PS(53,DA)
QUIT KILL PSORXPRE,DIE,DIC,DA,DR,X,C,Y
+1 QUIT
PAGE ;
+1 IF '$GET(DUZ("AUTO"))
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+2 QUIT
WARN ;
+1 SET PSOCPEDA=$GET(DA)
+2 WRITE !!?28,"**** WARNING ****",!
+3 IF 'PSORXPRE
WRITE !,"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.",!
+4 IF PSORXPRE
WRITE !,"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.",!
+5 WRITE !,"A mail message will be sent to PSORPH and PSO COPAY Key holders informing",!,"them of your change."
+6 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to do this"
SET DIR("B")="Y"
DO ^DIR
KILL DIR
+7 IF $GET(Y)
Begin DoDot:1
+8 IF 'PSORXPRE
WRITE !!,"Setting ",PSORXPNM," Rx Patient Status to Exempt from Copayment."
QUIT
+9 WRITE !!,"Setting Exempt from Copayment to 'NO' for the ",PSORXPNM,!,"Rx Patient Status."
End DoDot:1
DO MAIL
GOTO WARNX
+10 IF 'PSORXPRE
WRITE !!,"No action taken."
SET $PIECE(^PS(53,PSOCPEDA,0),"^",7)=0
HANG 1
+11 IF PSORXPRE
WRITE !!,"No action taken."
SET $PIECE(^PS(53,PSOCPEDA,0),"^",7)=1
HANG 1
WARNX WRITE !
DO PAGE
+1 SET DA=$GET(PSOCPEDA)
KILL PSOCPEDA
+2 QUIT
MAIL ;
+1 KILL PSOTXT,PSOCFN,PSODCPA
+2 IF $GET(DUZ)
SET DIC=200
SET DR=".01"
SET DA=DUZ
SET DIQ(0)="E"
SET DIQ="PSODCPA("
DO EN^DIQ1
SET PSOCFN=$GET(PSODCPA(200,DA,.01,"E"))
KILL PSODCPA,DIC,DIQ,DR
+3 IF 'PSORXPRE
SET PSOTXT(1,0)="The "_PSORXPNM_" Rx Patient Status has been marked as"
SET PSOTXT(2,0)="Exempt from Copayment by "_$GET(PSOCFN)_"."
SET PSOTXT(3,0)="Every prescription with this Rx Patient Status will not be charged a Copayment."
+4 IF PSORXPRE
SET PSOTXT(1,0)="The Exempt from Copayment status has been removed from the"
SET PSOTXT(2,0)=PSORXPNM_" Rx Patient Status by "_$GET(PSOCFN)_"."
SET PSOTXT(3,0)="Prescriptions entered with this Rx Patient Status will not be exempt from"
+5 IF PSORXPRE
SET PSOTXT(4,0)="Copayment."
+6 FOR PSOCXPDA=0:0
SET PSOCXPDA=$ORDER(^XUSEC("PSORPH",PSOCXPDA))
if 'PSOCXPDA
QUIT
SET XMY(PSOCXPDA)=""
+7 FOR PSOCXPDA=0:0
SET PSOCXPDA=$ORDER(^XUSEC("PSO COPAY",PSOCXPDA))
if 'PSOCXPDA
QUIT
SET XMY(PSOCXPDA)=""
+8 IF $GET(DUZ)
SET XMY(DUZ)=""
+9 SET XMSUB="Exempt from Copayment"
SET XMTEXT="PSOTXT("
SET XMDUZ="Outpatient Pharmacy"
DO ^XMD
+10 KILL PSOTXT,PSOCXPDA,XMDUZ,PSOCFN,XMTEXT,XMSUB,XMY
+11 QUIT
+12 ;
MAIL2 ; SEND MAIL TO PHARMACIST, PROVIDER, AND HOLDERS OF PSO COPAY KEY
+1 NEW PSOC,PSOTXT,X
+2 KILL XMY
+3 SET XMSUB="PRESCRIPTION QUESTIONS REVIEW NEEDED"
+4 SET XMDUZ="Outpatient Pharmacy Package"
+5 SET PSOTXT(1)=" "
+6 SET DFN=+$PIECE($GET(^PSRX(RXP,0)),"^",2)
DO PID^VADPT
+7 ; ADDED DIVISION NUMBER TO SUBJECT LINE - PATCH 85
SET PSODIV=$PIECE($GET(^PSRX(RXP,2)),"^",9)
if PSODIV'=""
SET XMSUB=XMSUB_" ("_$PIECE($GET(^PS(59,PSODIV,0)),"^",6)_")"
SET PSODIV=$PIECE($GET(^PS(59,PSODIV,0)),"^",1)
+8 SET PSOTXT(2)=$PIECE($GET(^DPT($PIECE(^PSRX(RXP,0),"^",2),0)),"^",1)_" ("_$GET(VA("BID"))_")"_" "_PSODIV
+9 DO ELIG
+10 SET PSOTXT(PSOC)="Rx# "_$PIECE(^PSRX(RXP,0),"^",1)_" ("_PSOREF_") "_$SELECT('$GET(^PSRX(RXP,"IB")):"NO COPAY",1:"COPAY")
+11 SET PSOC=PSOC+1
+12 SET DRG=+$PIECE(^PSRX(RXP,0),"^",6)
+13 SET PSOC=PSOC+1
+14 SET PSOTXT(PSOC)=$PIECE($GET(^PSDRUG(DRG,0)),"^",1)
+15 SET PSOC=PSOC+1
+16 SET PSOTXT(PSOC)=" "
+17 SET PSOC=PSOC+1
+18 SET PSOTXT(PSOC)="Due to a change in criteria, additional information listed below is needed"
+19 SET PSOC=PSOC+1
+20 SET PSOTXT(PSOC)="to determine the final VA copay and/or insurance billable status for this Rx"
+21 SET PSOC=PSOC+1
+22 SET PSOTXT(PSOC)="so that appropriate action can be taken by pharmacy personnel."
+23 SET PSOC=PSOC+1
+24 SET PSOTXT(PSOC)=" "
+25 SET PSOC=PSOC+1
+26 FOR EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC"
IF $DATA(PSOTG(EXMT))
Begin DoDot:1
+27 IF PSOTG(EXMT)'=""
QUIT
+28 SET PSOLTAG="REL"_EXMT
+29 SET PSOQUES=$PIECE($TEXT(@PSOLTAG),";",2)
IF PSOQUES=""
QUIT
+30 SET PSOC=PSOC+1
SET PSOTXT(PSOC)=PSOQUES
+31 SET PSOQUES=$PIECE($TEXT(@PSOLTAG),";",2)
IF PSOQUES=""
QUIT
End DoDot:1
+32 SET PSOC=PSOC+1
SET PSOTXT(PSOC)=" "
+33 SET PSOC=PSOC+1
SET PSOTXT(PSOC)="This message has been sent to the provider of record, the pharmacist who"
+34 SET PSOC=PSOC+1
SET PSOTXT(PSOC)="finished the prescription order, and all holders of the PSO COPAY key."
+35 SET PSOC=PSOC+1
SET PSOTXT(PSOC)=" "
+36 SET PSOC=PSOC+1
SET PSOTXT(PSOC)="Providers:"
+37 SET PSOC=PSOC+1
SET PSOTXT(PSOC)="Please respond with your answer to the question(s) as a reply to this"
+38 SET PSOC=PSOC+1
SET PSOTXT(PSOC)="message. The prescription will be updated by the appropriate staff."
+39 SET PSOC=PSOC+1
SET PSOTXT(PSOC)=" "
+40 SET PSOC=PSOC+1
SET PSOTXT(PSOC)="Staff assigned to update the Prescription responses:"
+41 SET PSOC=PSOC+1
SET PSOTXT(PSOC)="Please use the RESET COPAY STATUS/CANCEL CHARGES option to enter the responses"
+42 SET PSOC=PSOC+1
SET PSOTXT(PSOC)="to the questions above, which may result in a Rx copay status change and/or"
+43 SET PSOC=PSOC+1
SET PSOTXT(PSOC)="the need to remove VA copay charges or may result in a charge to the patient's"
+44 SET PSOC=PSOC+1
SET PSOTXT(PSOC)="insurance carrier."
+45 SET PSOC=PSOC+1
SET PSOTXT(PSOC)=" "
+46 SET PSOC=PSOC+1
SET PSOTXT(PSOC)="Note: The SC question is now asked for Veterans who are SC>49% in order to"
+47 SET PSOC=PSOC+1
SET PSOTXT(PSOC)="determine if the Rx can be billed to a third party insurance. These Veterans"
+48 SET PSOC=PSOC+1
SET PSOTXT(PSOC)="will NOT be charged a VA copay."
+49 SET PSOC=PSOC+1
SET PSOTXT(PSOC)=" "
+50 SET PSOC=PSOC+1
SET PSOTXT(PSOC)="Supply, nutritional and investigational drugs are not charged a VA copay"
+51 SET PSOC=PSOC+1
SET PSOTXT(PSOC)="but could be reimbursable by third party insurance."
+52 ; S XMY() TO ALL THE RECIPIENTS
+53 ; ORIGINAL
IF '$GET(PSOREF)
SET XMY(+$PIECE(^PSRX(RXP,0),"^",4))=""
+54 ; REFILL
IF $GET(PSOREF)
SET XMY(+$PIECE(^PSRX(RXP,1,PSOREF,0),"^",17))=""
+55 IF $GET(^PSRX(RXP,"OR1"))
IF $PIECE(^PSRX(RXP,"OR1"),"^",5)'=""
SET XMY($PIECE(^PSRX(RXP,"OR1"),"^",5))=""
+56 FOR PSOCXPDA=0:0
SET PSOCXPDA=$ORDER(^XUSEC("PSO COPAY",PSOCXPDA))
if 'PSOCXPDA
QUIT
SET XMY(PSOCXPDA)=""
+57 SET XMTEXT="PSOTXT("
+58 DO ^XMD
KILL XMSUB,XMY,XMDUZ,XMTEXT,PSODIV,PSOCXPDA,PSOLTAG,PSOC,PSOQUES,PSOTG
+59 QUIT
+60 ;
ELIG DO ELIG^VADPT
SET PSOC=3
SET PSOTXT(PSOC)="Eligibility: "_$PIECE(VAEL(1),"^",2)_$SELECT(+VAEL(3):" SC%: "_$PIECE(VAEL(3),"^",2),1:"")
SET PSOC=PSOC+1
+1 NEW N,I,I1,PSDIS,PSCNT
+2 SET N=0
FOR
SET N=$ORDER(VAEL(1,N))
if 'N
QUIT
SET $PIECE(PSOTXT(PSOC)," ",14)=$PIECE(VAEL(1,N),"^",2)
SET PSOC=PSOC+1
+3 SET PSOTXT(PSOC)=" "
SET PSOC=PSOC+1
SET PSOTXT(PSOC)="Disabilities: "
+4 FOR I=0:0
SET I=$ORDER(^DPT(DFN,.372,I))
if 'I
QUIT
SET I1=$SELECT($DATA(^DPT(DFN,.372,I,0)):^(0),1:"")
if +I1
Begin DoDot:1
+5 SET PSDIS=$SELECT($PIECE($GET(^DIC(31,+I1,0)),"^")]""&($PIECE($GET(^(0)),"^",4)']""):$PIECE(^(0),"^"),$PIECE($GET(^DIC(31,+I1,0)),"^",4)]"":$PIECE(^(0),"^",4),1:"")
SET PSCNT=$PIECE(I1,"^",2)
+6 if $LENGTH(PSOTXT(PSOC)_PSDIS_"-"_PSCNT_"% ("_$SELECT($PIECE(I1,"^",3)
SET PSOC=PSOC+1
SET $PIECE(PSOTXT(PSOC)," ",14)=" "
+7 SET PSOTXT(PSOC)=$GET(PSOTXT(PSOC))_PSDIS_"-"_PSCNT_"%("_$SELECT($PIECE(I1,"^",3):"SC",1:"NSC")_"), "
End DoDot:1
+8 SET PSOC=PSOC+1
SET PSOTXT(PSOC)=" "
SET PSOC=PSOC+1
+9 QUIT
+10 ;
+11 ;EXEMPTION QUESTIONS - MAIL MESSAGE POSITION;SUBSCRIPT IN "IBQ" NODE
RELSC ;Is this Rx for a Service Connected Condition?;1
RELMST ;Is this Rx related to the treatment of Military Sexual Trauma?;2
RELAO ;Is this Rx for treatment of Vietnam-Era Herbicide (Agent Orange) exposure?;3
RELIR ;Is this Rx for treatment of Ionizing Radiation exposure?;4
RELEC ;Is this Rx for treatment related to service in SW Asia?;5
RELHNC ;Is this Rx related to treatment of Head and/or Neck Cancer?;6
RELCV ;Is this Rx potentially for treatment related to Combat?;7
RELSHAD ;Is this Rx related to treatment of PROJ 112/SHAD?;8
+1 ;
