Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOCPE

PSOCPE.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;REF/IA
  1. ;^XUSEC/10076
  1. ;^PSDRUG(/221
  1. ;Routine initially released as part of the copayment enhancement.
  1. ;called from PSOLBL
  1. INV ; Entry point from PSOCP - Prints one copay invoice
  1. I '$D(PSOCPN)!($G(RXP)) Q
  1. S PSOCPBAR=0
  1. I $D(PSOBARS),PSOBARS S PSOCPBAR=1
  1. D DEM^VADPT S Y=DT X ^DD("DD") S EDT=Y
  1. W ?54,"PRESCRIPTION COPAYMENT INFORMATION"
  1. W !!,?54,VADM(1)," ",VA("PID")," ",EDT
  1. S PSZ1=0,PSZ2="",PSOCPBN=$P(VADM(2),"^"),PSOCPBN=$S(PSOCPBN]"":PSOCPBN,1:"Unavailable")
  1. ;I '$G(PSOCPN) S PSOCPN=$P(^PSRX(RX,0),U,2)
  1. I PSOCPBAR,(PSOCPBN]"") S X="S",X2=PSOCPBN W !,?54,@PSOBAR1,PSOCPBN,@PSOBAR0
  1. E W !
  1. W !,?54,"The following prescriptions are"
  1. W !,?54,"eligible for prescription copayment.",!!
  1. DRUG S PSZ2="" F S PSZ2=$O(^TMP($J,"PSOCP",PSOCPN,PSZ2)) Q:PSZ2']"" S PSZ=^(PSZ2) D PRT
  1. NAR ; Print narrative from site parameter file
  1. K ^UTILITY($J,"W") S DIWL=55,DIWR=99,DIWF="" W !
  1. G:'$D(^PS(59,PSOSITE,4,0)) END
  1. G:$P(^PS(59,PSOSITE,4,0),"^",3)'>0 END
  1. 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
  1. P1 D ^DIWW
  1. K DIWF,DIWL,DIWR,PSO9
  1. END ;
  1. W @IOF
  1. K ^TMP($J,"PSOCP",PSOCPN),PSOCPBAR,PSOCPBN,PSZ1,PSZ2,PSOCPN,DIWF,DIWL,DIWR,PSO9
  1. Q
  1. PRT ;
  1. W ?54,PSZ2
  1. W ?72," ",$P(^TMP($J,"PSOCP",PSOCPN,PSZ2),"^",3)," ","Days Supply",!
  1. W ?56,$E($P(^TMP($J,"PSOCP",PSOCPN,PSZ2),U,2),1,45),!
  1. Q
  1. XMPT ; Entry point for menu option to select copay exemption
  1. N PSORXPNM,PSORXPRE,PSOCPEDA
  1. I '$D(PSOPAR) D ^PSOLSET G XMPT
  1. W ! S (DIC,DIE)="^PS(53,",DIC(0)="AEQMZ" D ^DIC K DIC G:Y<0 QUIT
  1. G:$D(DTOUT) QUIT
  1. S PSORXPRE=$P($G(^PS(53,+$G(Y),0)),"^",7)
  1. S PSORXPNM=$P($G(^PS(53,+$G(Y),0)),"^")
  1. 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
  1. W ! D ^DIE
  1. 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
  1. 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
  1. D WARN L -^PS(53,DA)
  1. QUIT K PSORXPRE,DIE,DIC,DA,DR,X,C,Y
  1. Q
  1. PAGE ;
  1. I '$G(DUZ("AUTO")) K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
  1. Q
  1. WARN ;
  1. S PSOCPEDA=$G(DA)
  1. W !!?28,"**** WARNING ****",!
  1. 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.",!
  1. 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.",!
  1. W !,"A mail message will be sent to PSORPH and PSO COPAY Key holders informing",!,"them of your change."
  1. W ! K DIR S DIR(0)="Y",DIR("A")="Are you sure you want to do this",DIR("B")="Y" D ^DIR K DIR
  1. I $G(Y) D D MAIL G WARNX
  1. .I 'PSORXPRE W !!,"Setting ",PSORXPNM," Rx Patient Status to Exempt from Copayment." Q
  1. .W !!,"Setting Exempt from Copayment to 'NO' for the ",PSORXPNM,!,"Rx Patient Status."
  1. I 'PSORXPRE W !!,"No action taken." S $P(^PS(53,PSOCPEDA,0),"^",7)=0 H 1
  1. I PSORXPRE W !!,"No action taken." S $P(^PS(53,PSOCPEDA,0),"^",7)=1 H 1
  1. WARNX W ! D PAGE
  1. S DA=$G(PSOCPEDA) K PSOCPEDA
  1. Q
  1. MAIL ;
  1. K PSOTXT,PSOCFN,PSODCPA
  1. 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
  1. 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."
  1. 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"
  1. I PSORXPRE S PSOTXT(4,0)="Copayment."
  1. F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSORPH",PSOCXPDA)) Q:'PSOCXPDA S XMY(PSOCXPDA)=""
  1. F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSO COPAY",PSOCXPDA)) Q:'PSOCXPDA S XMY(PSOCXPDA)=""
  1. I $G(DUZ) S XMY(DUZ)=""
  1. S XMSUB="Exempt from Copayment",XMTEXT="PSOTXT(",XMDUZ="Outpatient Pharmacy" D ^XMD
  1. K PSOTXT,PSOCXPDA,XMDUZ,PSOCFN,XMTEXT,XMSUB,XMY
  1. Q
  1. ;
  1. MAIL2 ; SEND MAIL TO PHARMACIST, PROVIDER, AND HOLDERS OF PSO COPAY KEY
  1. N PSOC,PSOTXT,X
  1. K XMY
  1. S XMSUB="PRESCRIPTION QUESTIONS REVIEW NEEDED"
  1. S XMDUZ="Outpatient Pharmacy Package"
  1. S PSOTXT(1)=" "
  1. S DFN=+$P($G(^PSRX(RXP,0)),"^",2) D PID^VADPT
  1. 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
  1. S PSOTXT(2)=$P($G(^DPT($P(^PSRX(RXP,0),"^",2),0)),"^",1)_" ("_$G(VA("BID"))_")"_" "_PSODIV
  1. D ELIG
  1. S PSOTXT(PSOC)="Rx# "_$P(^PSRX(RXP,0),"^",1)_" ("_PSOREF_") "_$S('$G(^PSRX(RXP,"IB")):"NO COPAY",1:"COPAY")
  1. S PSOC=PSOC+1
  1. S DRG=+$P(^PSRX(RXP,0),"^",6)
  1. S PSOC=PSOC+1
  1. S PSOTXT(PSOC)=$P($G(^PSDRUG(DRG,0)),"^",1)
  1. S PSOC=PSOC+1
  1. S PSOTXT(PSOC)=" "
  1. S PSOC=PSOC+1
  1. S PSOTXT(PSOC)="Due to a change in criteria, additional information listed below is needed"
  1. S PSOC=PSOC+1
  1. S PSOTXT(PSOC)="to determine the final VA copay and/or insurance billable status for this Rx"
  1. S PSOC=PSOC+1
  1. S PSOTXT(PSOC)="so that appropriate action can be taken by pharmacy personnel."
  1. S PSOC=PSOC+1
  1. S PSOTXT(PSOC)=" "
  1. S PSOC=PSOC+1
  1. F EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC" I $D(PSOTG(EXMT)) D
  1. . I PSOTG(EXMT)'="" Q
  1. . S PSOLTAG="REL"_EXMT
  1. . S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q
  1. . S PSOC=PSOC+1,PSOTXT(PSOC)=PSOQUES
  1. . S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q
  1. S PSOC=PSOC+1,PSOTXT(PSOC)=" "
  1. S PSOC=PSOC+1,PSOTXT(PSOC)="This message has been sent to the provider of record, the pharmacist who"
  1. S PSOC=PSOC+1,PSOTXT(PSOC)="finished the prescription order, and all holders of the PSO COPAY key."
  1. S PSOC=PSOC+1,PSOTXT(PSOC)=" "
  1. S PSOC=PSOC+1,PSOTXT(PSOC)="Providers:"
  1. S PSOC=PSOC+1,PSOTXT(PSOC)="Please respond with your answer to the question(s) as a reply to this"
  1. S PSOC=PSOC+1,PSOTXT(PSOC)="message. The prescription will be updated by the appropriate staff."
  1. S PSOC=PSOC+1,PSOTXT(PSOC)=" "
  1. S PSOC=PSOC+1,PSOTXT(PSOC)="Staff assigned to update the Prescription responses:"
  1. S PSOC=PSOC+1,PSOTXT(PSOC)="Please use the RESET COPAY STATUS/CANCEL CHARGES option to enter the responses"
  1. S PSOC=PSOC+1,PSOTXT(PSOC)="to the questions above, which may result in a Rx copay status change and/or"
  1. S PSOC=PSOC+1,PSOTXT(PSOC)="the need to remove VA copay charges or may result in a charge to the patient's"
  1. S PSOC=PSOC+1,PSOTXT(PSOC)="insurance carrier."
  1. S PSOC=PSOC+1,PSOTXT(PSOC)=" "
  1. S PSOC=PSOC+1,PSOTXT(PSOC)="Note: The SC question is now asked for Veterans who are SC>49% in order to"
  1. S PSOC=PSOC+1,PSOTXT(PSOC)="determine if the Rx can be billed to a third party insurance. These Veterans"
  1. S PSOC=PSOC+1,PSOTXT(PSOC)="will NOT be charged a VA copay."
  1. S PSOC=PSOC+1,PSOTXT(PSOC)=" "
  1. S PSOC=PSOC+1,PSOTXT(PSOC)="Supply, nutritional and investigational drugs are not charged a VA copay"
  1. S PSOC=PSOC+1,PSOTXT(PSOC)="but could be reimbursable by third party insurance."
  1. ; S XMY() TO ALL THE RECIPIENTS
  1. I '$G(PSOREF) S XMY(+$P(^PSRX(RXP,0),"^",4))="" ; ORIGINAL
  1. I $G(PSOREF) S XMY(+$P(^PSRX(RXP,1,PSOREF,0),"^",17))="" ; REFILL
  1. I $G(^PSRX(RXP,"OR1")) I $P(^PSRX(RXP,"OR1"),"^",5)'="" S XMY($P(^PSRX(RXP,"OR1"),"^",5))=""
  1. F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSO COPAY",PSOCXPDA)) Q:'PSOCXPDA S XMY(PSOCXPDA)=""
  1. S XMTEXT="PSOTXT("
  1. D ^XMD K XMSUB,XMY,XMDUZ,XMTEXT,PSODIV,PSOCXPDA,PSOLTAG,PSOC,PSOQUES,PSOTG
  1. Q
  1. ;
  1. 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
  1. N N,I,I1,PSDIS,PSCNT
  1. 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
  1. S PSOTXT(PSOC)=" ",PSOC=PSOC+1,PSOTXT(PSOC)="Disabilities: "
  1. 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
  1. .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)
  1. .S:$L(PSOTXT(PSOC)_PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")>80 PSOC=PSOC+1,$P(PSOTXT(PSOC)," ",14)=" "
  1. .S PSOTXT(PSOC)=$G(PSOTXT(PSOC))_PSDIS_"-"_PSCNT_"%("_$S($P(I1,"^",3):"SC",1:"NSC")_"), "
  1. S PSOC=PSOC+1 S PSOTXT(PSOC)=" ",PSOC=PSOC+1
  1. Q
  1. ;
  1. ;EXEMPTION QUESTIONS - MAIL MESSAGE POSITION;SUBSCRIPT IN "IBQ" NODE
  1. RELSC ;Is this Rx for a Service Connected Condition?;1
  1. RELMST ;Is this Rx related to the treatment of Military Sexual Trauma?;2
  1. RELAO ;Is this Rx for treatment of Vietnam-Era Herbicide (Agent Orange) exposure?;3
  1. RELIR ;Is this Rx for treatment of Ionizing Radiation exposure?;4
  1. RELEC ;Is this Rx for treatment related to service in SW Asia?;5
  1. RELHNC ;Is this Rx related to treatment of Head and/or Neck Cancer?;6
  1. RELCV ;Is this Rx potentially for treatment related to Combat?;7
  1. RELSHAD ;Is this Rx related to treatment of PROJ 112/SHAD?;8
  1. ;