- 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 Feb 18, 2025@23:52:19 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 ;