PSOUTIL ;IHS/DSD/JCM - outpatient pharmacy utility routine ;12/28/15 4:01pm
;;7.0;OUTPATIENT PHARMACY;**64,456,444,469,504,651,545,731**;DEC 1997;Build 18
;External reference $$MXDAYSUP^PSSUTIL1 supported by DBIA 6229
;External reference to ^ORDEA is supported by DBIA 5709
;
Q
;
NPSOSD(PSORX) ; Entry point to add newly added rx to patients PSOSD array
S STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUE^^DISCONTINUE^DISCONTINUE^HOLD"
S STAT=$P(STA,"^",$P(^PSRX(PSORX("IRXN"),"STA"),"^")+1)
I $D(PSOSD(STAT,PSODRUG("NAME"))),$P(PSOSD(STAT,PSODRUG("NAME")),"^",2)<10 D
. S PSOSD(STAT,PSODRUG("NAME")_"^"_PSORX("IRXN"))=PSORX("IRXN")_"^"_$P($G(^PSRX(PSORX("IRXN"),"STA")),"^")_"^^^"_PSODRUG("VA CLASS")_"^"_$P(^PSRX(PSORX("IRXN"),0),"^",9)_"^"_PSODRUG("NDF")_"^"_$P(^PSRX(PSORX("IRXN"),0),"^",8)_"^1"
E S PSOSD(STAT,PSODRUG("NAME"))=PSORX("IRXN")_"^"_$P($G(^PSRX(PSORX("IRXN"),"STA")),"^")_"^^^"_PSODRUG("VA CLASS")_"^"_$P(^PSRX(PSORX("IRXN"),0),"^",9)_"^"_PSODRUG("NDF")_"^"_$P(^PSRX(PSORX("IRXN"),0),"^",8)_"^1"
S PSOSD=$S($G(PSOSD)]"":PSOSD+1,1:1),^TMP("PS",$J,STAT,PSODRUG("NAME"))=1
Q
;
RNPSOSD ;update PSOSD array for renewals
S STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUE^^DISCONTINUE^DISCONTINUE^HOLD"
S STAT=$P(STA,"^",$P(^PSRX(PSORENW("OIRXN"),"STA"),"^")+1)
I $D(PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("OIRXN"))) D
. S PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("IRXN"))=PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("OIRXN")),$P(PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("IRXN")),"^",2)=$P($G(^PSRX(PSORENW("IRXN"),"STA")),"^")
. S $P(PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("IRXN")),"^",6)=$P(^PSRX(PSORENW("IRXN"),0),"^",9)
. K PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("OIRXN")) Q
E D
.S $P(PSOSD(STAT,PSODRUG("NAME")),"^")=PSORENW("IRXN"),$P(PSOSD(STAT,PSODRUG("NAME")),"^",2)=$P($G(^PSRX(PSORENW("IRXN"),"STA")),"^")
.S $P(PSOSD(STAT,PSODRUG("NAME")),"^",6)=$P(^PSRX(PSORENW("IRXN"),0),"^",9)
.S ^TMP("PS",$J,STAT,PSODRUG("NAME"))=1
Q
;
PROV(PSORENW) ;called from psoornew
CHKPRV ;check inactive providers and cosinging providers called from PSORENW (renew rx)
N OK
I '$D(^VA(200,PSORENW("PROVIDER"),0)) D I 'OK G:PSORENW("DFLG") CHKPRVX
.W !,$C(7),"Provider not in New Person File .. You must select a new provider"
.S PSODIR("FIELD")=0 K PSORENW("PROVIDER") D PROV^PSODIR(.PSORENW)
.S:$G(PSORENW("PROVIDER"))']"" PSORENW("DFLG")=1
;
I '$G(^VA(200,PSORENW("PROVIDER"),"PS")) D G:PSORENW("DFLG") CHKPRVX
.I $$ISSPLY(),$D(^XUSEC("ORSUPPLY",PSORENW("PROVIDER"))) S OK=1 Q
.S OK=0 W !,$C(7),$P(^VA(200,PSORENW("PROVIDER"),0),"^")_" is not a Valid provider .. You must select a new provider"
.S PSODIR("FIELD")=0 K PSORENW("PROVIDER") D PROV^PSODIR(.PSORENW)
.S:$G(PSORENW("PROVIDER"))']"" PSORENW("DFLG")=1
;
K PSOX S PSOX=$P($G(^VA(200,PSORENW("PROVIDER"),"PS")),"^",4)
I PSOX,PSOX<DT D G:PSORENW("DFLG") CHKPRVX
.W !,$C(7),$P(^VA(200,PSORENW("PROVIDER"),0),"^")_" is inactive as a provider .. You must select a new provider"
.S PSODIR("FIELD")=0 K PSORENW("PROVIDER") D PROV^PSODIR(.PSORENW)
.I $G(PSORENW("PROVIDER"))']"" S PSORENW("DFLG")=1
;
I '$D(PSORENW("COSIGNING PROVIDER")),$D(PSORENW("COSIGNER")) K PSOX S PSOX=$P(^VA(200,PSORENW("COSIGNER"),"PS"),"^",4) I PSOX,PSOX<DT D
.W !,$C(7),"Inactive Cosigning Provider .. You must select a new cosigner"
.S PSODIR("FIELD")=0,PSODIR("PROVIDER")=$S($D(PSORENW("PROVIDER")):PSORENW("PROVIDER"),1:PSORENW("PROVIDER"))
.D COSIGN^PSODIR I '$D(PSODIR("COSIGNING PROVIDER")) S PSORENW("DFLG")=1
.S PSORENW("COSIGNING PROVIDER")=PSODIR("COSIGNING PROVIDER")
;
CHKPRVX K PSODIR,PSOX
Q
;
NEXT(PSOX) ;
S PSOX("RX0")=^PSRX(PSOX("IRXN"),0)
S PSOX("RX2")=^PSRX(PSOX("IRXN"),2)
S PSOX("RX3")=^PSRX(PSOX("IRXN"),3)
S PSOX1=$P(PSOX("RX2"),"^",2)
I '$O(^PSRX(PSOX("IRXN"),1,0)) D G NEXTX
. S $P(PSOX("RX3"),"^")=PSOX1,X1=PSOX1
. S X2=$P(PSOX("RX0"),"^",8)-10\1
. D C^%DTC
. S:'$P(PSOX("RX3"),"^",8) $P(PSOX("RX3"),"^",2)=X
. K X Q
;
S PSOY2=0
F PSOY=0:0 S PSOY=$O(^PSRX(PSOX("IRXN"),1,PSOY)) Q:'PSOY S PSOY1=PSOY,PSOY2=PSOY2+1
S PSOY=^PSRX(PSOX("IRXN"),1,PSOY1,0)
S PSOX2=$P(PSOY,"^")
S $P(PSOX("RX3"),"^")=PSOX2,X1=PSOX2
S X2=$P(PSOX("RX0"),"^",8)-10\1
D C^%DTC S PSOY3=X
S X1=PSOX1,X2=(PSOY2+1)*$P(PSOX("RX0"),"^",8)-10\1
D C^%DTC S PSOY4=X
S $P(PSOX("RX3"),"^",2)=$S(PSOY3<PSOY4:PSOY4,1:PSOY3)
NEXTX ;
K X,PSOX1,PSOX2,PSOY,PSOY1,PSOY2,PSOY3,PSOY4
Q
;
SUSDATE(PSOX) ;
S PSOX("OLD FILL DATE")=PSOX("FILL DATE")
S PSORX("OLD FILL DATE")=PSORX("FILL DATE")
S PSOX("FILL DATE")=$P(PSOX("RX3"),"^",2)
I $O(^PS(52.5,"B",PSOX("IRXN"),0)),'$G(^PS(52.5,+$O(^PS(52.5,"B",PSOX("IRXN"),0)),"P")) S PSOX("FILL DATE")=$P(PSOX("RX3"),"^")
S Y=PSOX("FILL DATE")
X ^DD("DD") S PSORX("FILL DATE")=Y K Y
Q
;
SUSDATEK(PSOX) ;
S PSOX("FILL DATE")=PSOX("OLD FILL DATE")
I $G(PSORX("OLD FILL DATE"))="",$G(PSORENW("OLD FILL DATE")) S Y=PSORENW("OLD FILL DATE") D DD^%DT S PSORX("OLD FILL DATE")=Y K Y
S PSORX("FILL DATE")=PSORX("OLD FILL DATE")
K PSOX("OLD FILL DATE"),PSORX("OLD FILL DATE")
Q
;
STATUS(PSOREA,PSOSTAT) ;
S DSMSG="Cannot "_$S($G(PSOOPT)=3:"renew",1:"refill")_" Rx. " S:$G(OR0) ACOM=DSMSG
I PSOREA["A" W:$G(SPEED) ", Inactive Drug.",! D
.S:$G(POERR)&('$G(SPEED)) VALMSG=DSMSG_"Inactive Drug.",VALMBCK="R" W:'$G(POERR) !," Inactive Drug"
.S:$G(OR0) ACOM=ACOM_" Inactive Drug."
I PSOREA["M" W:$G(SPEED) ", Drug no longer used by Outpatient.",! D
.S:$G(POERR)&('$G(SPEED)) VALMSG=DSMSG_"Drug no longer used by Outpatient.",VALMBCK="R" W:'$G(POERR) !," Drug no longer used by Outpatient."
.S:$G(OR0) ACOM=ACOM_" Drug no longer used by Outpatient."
;
I PSOREA["B" W:$G(SPEED) ", Narcotic Drug." D
.W:'$G(POERR) !,"Narcotic Drug" S:$G(POERR)&('$G(SPEED)) VALMSG=DSMSG_"Narcotic Drug.",VALMBCK="R"
.S:$G(OR0) ACOM=ACOM_" Narcotic Drug."
;
I PSOREA["C" W:$G(SPEED) ", Non-Renewable Drug." D
.W:'$G(POERR) !,"Non-Renewable Drug" S:$G(POERR)&('$G(SPEED)) VALMSG=DSMSG_"Non-Renewable Drug.",VALMBCK="R"
.S:$G(OR0) ACOM=ACOM_" Non-Renewable Drug."
;
I PSOREA["D" W:$G(SPEED) ", Non-Renewable Patient Status." D
.W:'$G(POERR) !,"Non-Renewable Patient Status" S:$G(POERR)&('$G(SPEED)) VALMSG=DSMSG_"Non-Renewable Patient Status.",VALMBCK="R"
.S:$G(OR0) ACOM=ACOM_" Non-Renewable Patient Status."
;
I PSOREA["E" W:$G(SPEED) ", Non-Verified Rx." D
.W:'$G(POERR) !,"Non-Verified Rx" S:$G(POERR)&('$G(SPEED)) VALMSG=DSMSG_"Non-Verified Rx.",VALMBCK="R"
.S:$G(OR0) ACOM=ACOM_" Non-Verified Rx."
;
I PSOREA["F" W:$G(SPEED) ", Maximum of 26 Renewals." D
.W:'$G(POERR) !,"Maximum of 26 Renewals" S:$G(POERR)&('$G(SPEED)) VALMSG=DSMSG_"Maximum of 26 Renewals.",VALMBCK="R"
.S:$G(OR0) ACOM=ACOM_" Maximum of 26 Renewals."
;
I PSOREA["G",PSOREA'["B" W:$G(SPEED) ", No more refills left." W:'$G(POERR) !,"No more refills left" S:$G(POERR)&('$G(SPEED)) VALMSG=DSMSG_"No more refills left.",VALMBCK="R"
;
I PSOREA["Z" D
. S:PSOSTAT=4 PSOSTAT=1
. S PSOA=";"_PSOSTAT,PSOB=$P(^DD(52,100,0),"^",3),PSOA=$F(PSOB,PSOA),PSOA=$P($E(PSOB,PSOA,999),";",1)
. W:$G(SPEED) ", Rx is in "_$P(PSOA,":",2)_" status."
. W:'$G(POERR)&('$G(SPEED)) !,"Rx is in "_$P(PSOA,":",2)_" status"
.S:$G(POERR)&($G(VALMSG)']"")&('$G(SPEED)) VALMSG=DSMSG_"Rx is in "_$P(PSOA,":",2)_" status.",VALMBCK="R"
. K PSOA,PSOB
. Q
I $G(SPEED) K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIRUT,DUOUT,DTOUT,DIR
Q
ACP I $P(^PSRX(PSOX("IRXN"),0),"^",11)="W",$G(^("IB")) S ^PSRX("ACP",$P(^PSRX(PSOX("IRXN"),0),"^",2),$P(^(2),"^",2),0,PSOX("IRXN"))=""
Q
;
RENFDT(PSOX) ;gets the correct fill date
S PSOX("OLD FILL DATE")=PSOX("FILL DATE")
S PSORX("OLD FILL DATE")=PSORX("FILL DATE")
S PSOX("FILL DATE")=$P(PSOX("RX3"),"^",2)
N RXY,LBL,SUPN,LBP,RF,RFN,RFD
S RXY=PSOX("IRXN"),RFN=0
I '$O(^PSRX(RXY,1,0)) D GFDT G SDTX
F RF=0:0 S RF=$O(^PSRX(RXY,1,RF)) Q:'RF S RFN=RF
S RF=^PSRX(RXY,1,RFN,0) D GFDT
I PSOX("FILL DATE")<DT,PSOX("FILL DATE")<PSORNW("FILL DATE") S PSOX("FILL DATE")=DT
SDTX ;
S Y=PSOX("FILL DATE")
X ^DD("DD") S PSORX("FILL DATE")=Y K Y
Q
GFDT ;
I 'RFN,$P(^PSRX(RXY,2),"^",13) Q
I RFN,$P(RF,"^",18) Q
F LBL=0:0 S LBL=$O(^PSRX(RXY,"L",LBL)) Q:'LBL I $P(^PSRX(RXY,"L",LBL,0),"^",2)=RFN S LBP=1 Q
Q:$G(LBP)
S SUPN=$O(^PS(52.5,"B",RXY,0))
I SUPN,$P($G(^PS(52.5,SUPN,0)),"^",7)="L"!($P($G(^(0)),"^",7)="X") Q
S:RFN RFD=$E($P(RF,"^"),1,7) S:'RFN RFD=$P(PSOX("RX3"),"^")
I SUPN,RFD,$D(^PS(52.5,"C",RFD,SUPN)),$G(^PS(52.5,SUPN,"P"))=1 Q
S PSOX("FILL DATE")=$P(PSOX("RX3"),"^")
Q
;
ISSPLY() ;is the drug a supply item
;assumes the existence of the PSODRUG array
I $G(PSODRUG("DEA"))="" Q 0
I $G(PSODRUG("VA CLASS"))="" Q 0
I PSODRUG("VA CLASS")?1"XA".E!(PSODRUG("VA CLASS")?1"XX".E)!(PSODRUG("VA CLASS")="DX900"&(PSODRUG("DEA")["S")) Q 1
Q 0
;
DAYSUP(DRUG,RXARR,RCLQTY) ; Adjusts DAYS SUPPLY and QUANTITY based on the maximum allowed
; Input: DRUG - DRUG file (#50) IEN
; RXARR - Array containing prescription information
; RVWQTY - Re-calculate Quantity (1: YES / 0: NO)
;Output: RXARR - Array with "DAYS SUPPLY" and "QTY" values modified
;
; - Invalid Dispense Drug
I '$D(^PSDRUG(+$G(DRUG),0))!'$D(RXARR) Q
N MXDAYSUP,RXDAYSUP,RXQTY,NEWQTY
S MXDAYSUP=$$MXDAYSUP^PSSUTIL1(DRUG)
S RXDAYSUP=+$G(RXARR("DAYS SUPPLY"))
I RXDAYSUP>MXDAYSUP D
. W !!,"The current DAYS SUPPLY value (",RXDAYSUP,") exceeds the Maximum allowed"
. W !,"for ",$$GET1^DIQ(50,DRUG,.01)," (",MXDAYSUP,") and will be reset.",$C(7)
. S RXARR("DAYS SUPPLY")=MXDAYSUP
. S RXQTY=+$G(RXARR("QTY"))
. I $G(RCLQTY),RXQTY,RCLQTY'=RXQTY D
. . S NEWQTY=((RXQTY*MXDAYSUP)/RXDAYSUP)+.5\1
. . W !!,"The Quantity was changed from ",RXQTY," to ",NEWQTY,"."
. . S RXARR("QTY")=NEWQTY
. W !!,"Please, review the modified order before accepting it."
. W ! N DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR
Q
;
MAXNUMRF(DRUG,DAYSUP,PTST,CLOZPAT) ; Returns the Maximum Number of Refills Allowed
; Input: DRUG - DRUG file (#50) IEN
; DAYSUP - Number of DAYS SUPPLY per fill
; PTST - RX PATIENT STATUES (#53) IEN
; CLOZPAT - Clozapine Indicator Variable (used throughout PSO)
;Output: MAXNUMRF - Maximum Number of Refills
;
N MAXNUMRF,DEAHDLG,CSDRUG,MAXPTST
; - Invalid Drug or DAYS SUPPLY value
I '$D(^PSDRUG(+$G(DRUG),0)),'$G(DAYSUP) Q 0
;
; - Calculating Maximum for Clozapine Drug
I $D(CLOZPAT) Q $S(CLOZPAT=2&(DAYSUP=14):1,CLOZPAT=2&(DAYSUP=7):3,CLOZPAT=1&(DAYSUP=7):1,1:0)
;
; - Non-Refillable Drugs based on DEA SPECIAL HDLG field
S DEAHDLG=""
I $G(DRUG) S DEAHDLG=$$GET1^DIQ(50,DRUG,3) I DEAHDLG["A"&(DEAHDLG'["B")!(DEAHDLG["F")!(DEAHDLG[1)!(DEAHDLG[2) Q 0
S CSDRUG=0 I (DEAHDLG[3)!(DEAHDLG[4)!(DEAHDLG[5) S CSDRUG=1
;
; - The Maximum Number of Refills Calculation is different for up to 90 Days Supply Vs. Above 90 Days Supply
I $G(CSDRUG) D
. I DAYSUP'>90 D
. . S MAXNUMRF=$S(DAYSUP<60:5,DAYSUP'<60&(DAYSUP'>89):2,DAYSUP=90:1,1:0)
. E D
. . S MAXNUMRF=182\DAYSUP-1
E D
. I DAYSUP'>90 D
. . S MAXNUMRF=$S(DAYSUP<60:11,DAYSUP'<60&(DAYSUP'>89):5,DAYSUP=90:3,1:0)
. E D
. . S MAXNUMRF=365\DAYSUP-1
;
; - Adjusting Maximum based Rx Patient Status
I $G(PTST) S MAXPTST=$$GET1^DIQ(53,PTST,4) I MAXNUMRF>MAXPTST S MAXNUMRF=MAXPTST
;
Q MAXNUMRF
;
BADADDFL(RXIEN) ; Indicate whether an Rx should be flagged with a Bad Address
; Input: RXIEN - Rx IEN (#52) to be checked
;Output: BADADDFL - 1: Rx Flagged for Bad Address / 0: Rx NOT Flagged Bad Address
N BADADDFL,LSTLBLSQ,LSTLBLTX
S BADADDFL=0
I '$G(^PSRX(+$G(RXIEN),0)) Q BADADDFL
S LSTLBLSQ=$O(^PSRX(+RXIEN,"L",9999),-1)
I LSTLBLSQ D
. S LSTLBLTX=$G(^PSRX(+RXIEN,"L",LSTLBLSQ,0)) I LSTLBLTX["(BAD ADDRESS)" S BADADDFL=1
Q BADADDFL
;
PRVDETOX(PRVIEN) ; Returns the Provider DETOX#, if available and not expired
; Input: (r) PRVIEN - Provider IEN (Pointer to VA PERSON file (#200))
;Output: PRVDETOX - Provider Detox #
Q "" ;P731 detox/x-waiver removal
N PRVDETOX
S PRVDETOX=$$DETOX^XUSER(PRVIEN) I PRVDETOX?2A7N Q PRVDETOX
Q ""
;
RXDEA(RXIEN,ORIEN) ; Returns the Provider DEA# associated with the Prescription/CPRS Order (At least one of RXIEN or ORIEN is required)
; Input: (o) RXIEN - Prescription IEN (Pointer to the PRESCRIPTION file (#52))
; (o) ORIEN - CPRS Order IEN (Pointer to ORDER file (#100))
;Output: RXDEA - Provider DEA# associated with the Prescription
N RXDEA
I $G(RXIEN) S ORIEN=+$$GET1^DIQ(52,RXIEN,39.3,"I")
I $G(ORIEN) K ^TMP($J,"ORDEA") D ARCHIVE^ORDEA(ORIEN) S RXDEA=$P($G(^TMP($J,"ORDEA",ORIEN,2)),"^",1) K ^TMP($J,"ORDEA")
Q $G(RXDEA)
;
RXDETOX(RXIEN,ORIEN) ; Returns the Provider DETOX# associated with the Prescription/CPRS Order (At least one of RXIEN or ORIEN is required)
; Input: (o) RXIEN - Prescription IEN (Pointer to the PRESCRIPTION file (#52))
; (o) ORIEN - CPRS Order IEN (Pointer to the ORDER file (#100))
;Output: RXDETOX - Provider DETOX# associated with the Prescription
N RXDETOX
I $G(RXIEN) S ORIEN=+$$GET1^DIQ(52,RXIEN,39.3,"I")
I $G(ORIEN) K ^TMP($J,"ORDEA") D ARCHIVE^ORDEA(ORIEN) S RXDETOX=$P($G(^TMP($J,"ORDEA",ORIEN,2)),"^",2) K ^TMP($J,"ORDEA")
;Q $G(RXDETOX) ;P731 detox/x-waiver removal
Q ""
;
CHKRXPRV(RXIEN,PRVIEN) ; Check if the Provider can be assigned to a specific Prescription (Used for Rx Copy, Rx Renewal, etc.)
; Input: (r) RXIEN - Prescription IEN (Pointer to the PRESCRIPTION file (#52))
; (o) PRVIEN - Provider IEN (Pointer to the NEW PERSON file (#200))
;Output: $CHKRXPRV - 1: YES / 0: NO^Short Reason (Listman)^Long Reason (Write to screen)
N CHKRXPRV,DRUGIEN,CLOZDRUG,DRUGDEA,REASON
I '$D(^PSRX(+$G(RXIEN),0)) Q "0^Prescription not found^Prescription not found"
I '$G(PRVIEN) S PRVIEN=$$GET1^DIQ(52,RXIEN,4,"I")
I '$D(^VA(200,+$G(PRVIEN),0)) Q "0^Provider not found^Provider not found"
S DRUGIEN=$$GET1^DIQ(52,RXIEN,6,"I") I 'DRUGIEN Q "0^Invalid Dispense Drug^Invalid Dispense Drug"
S CLOZDRUG=$S($D(^PSDRUG("ACLOZ",DRUGIEN)):1,1:0)
I CLOZDRUG,'$D(^XUSEC("YSCL AUTHORIZED",PRVIEN)) Q "0^Provider does not hold YSCL AUTHORIZED key^Provider on the Rx does not hold the YSCL AUTHORIZED key required for clozapine prescriptions."
S DRUGDEA=$$DRUGSCHD(DRUGIEN)
I DRUGDEA'="" S REASON="" D I REASON'="" Q REASON
. N PRVDEA
. S PRVDEA=$P($$SDEA^XUSER(0,PRVIEN,DRUGDEA,,$$RXDEA^PSOUTIL(RXIEN)),"^") ;*545
. I $L(PRVDEA)<3 D
. . I PRVDEA=2 D Q
. . . S REASON="0^Provider not authorized to write Federal Schedule "_DRUGDEA_" prescriptions. Please contact the provider^Provider not authorized to write Federal Schedule "_DRUGDEA_" prescriptions. Please contact the provider^2"
. . S REASON="0^Provider must have a valid DEA# or VA# for this Rx^Provider does not have a valid DEA# or VA# required for this Rx^1"
I $$DETOX^PSSOPKI(DRUGIEN),$$PRVDETOX^PSOUTIL(PRVIEN)="" Q "0^Provider must have a valid DETOX# for this Rx^Provider does not have a valid DETOX# required for this Rx"
Q 1
;
DRUGSCHD(DRUGIEN) ; Return Drug DEA Schedule or "" (blank) for non-controlled substances
; Input: (r) DRUGIEN - Dispense Drug IEN (Pointer to the DRUG file (#50))
;Output: $DRUGSCHD - DEA Schedule or "" (blank) for non-controlled substances
N NDFSCHD,DRUGDEA,NDFIEN
S NDFSCHD="",DRUGDEA=$$GET1^DIQ(50,DRUGIEN,3)
S NDFIEN=+$$GET1^DIQ(50,DRUGIEN,22,"I") I NDFIEN S NDFSCHD=$$GET1^DIQ(50.68,NDFIEN,19,"I")
I +NDFIEN>0!(DRUGDEA="") Q $S('NDFSCHD:"",1:NDFSCHD)
I "^2^3^"[+DRUGDEA Q $S(DRUGDEA["A":+DRUGDEA,1:+DRUGDEA_"n")
I "^4^5^"[+DRUGDEA Q +DRUGDEA
Q ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOUTIL 15744 printed Oct 16, 2024@18:36:42 Page 2
PSOUTIL ;IHS/DSD/JCM - outpatient pharmacy utility routine ;12/28/15 4:01pm
+1 ;;7.0;OUTPATIENT PHARMACY;**64,456,444,469,504,651,545,731**;DEC 1997;Build 18
+2 ;External reference $$MXDAYSUP^PSSUTIL1 supported by DBIA 6229
+3 ;External reference to ^ORDEA is supported by DBIA 5709
+4 ;
+5 QUIT
+6 ;
NPSOSD(PSORX) ; Entry point to add newly added rx to patients PSOSD array
+1 SET STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUE^^DISCONTINUE^DISCONTINUE^HOLD"
+2 SET STAT=$PIECE(STA,"^",$PIECE(^PSRX(PSORX("IRXN"),"STA"),"^")+1)
+3 IF $DATA(PSOSD(STAT,PSODRUG("NAME")))
IF $PIECE(PSOSD(STAT,PSODRUG("NAME")),"^",2)<10
Begin DoDot:1
+4 SET PSOSD(STAT,PSODRUG("NAME")_"^"_PSORX("IRXN"))=PSORX("IRXN")_"^"_$PIECE($GET(^PSRX(PSORX("IRXN"),"STA")),"^")_"^^^"_PSODRUG("VA CLASS")_"^"_$PIECE(^PSRX(PSORX("IRXN"),0),"^",9)_"^"_PSODRUG("NDF")_"^"_$PIECE(^PSRX(PSORX("IRXN"),0)
,"^",8)_"^1"
End DoDot:1
+5 IF '$TEST
SET PSOSD(STAT,PSODRUG("NAME"))=PSORX("IRXN")_"^"_$PIECE($GET(^PSRX(PSORX("IRXN"),"STA")),"^")_"^^^"_PSODRUG("VA CLASS")_"^"_$PIECE(^PSRX(PSORX("IRXN"),0),"^",9)_"^"_PSODRUG("NDF")_"^"_$PIECE(^PSRX(PSORX("IRXN"),0),"^",8)_"^1"
+6 SET PSOSD=$SELECT($GET(PSOSD)]"":PSOSD+1,1:1)
SET ^TMP("PS",$JOB,STAT,PSODRUG("NAME"))=1
+7 QUIT
+8 ;
RNPSOSD ;update PSOSD array for renewals
+1 SET STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUE^^DISCONTINUE^DISCONTINUE^HOLD"
+2 SET STAT=$PIECE(STA,"^",$PIECE(^PSRX(PSORENW("OIRXN"),"STA"),"^")+1)
+3 IF $DATA(PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("OIRXN")))
Begin DoDot:1
+4 SET PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("IRXN"))=PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("OIRXN"))
SET $PIECE(PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("IRXN")),"^",2)=$PIECE($GET(^PSRX(PSORENW("IRXN"),"STA")),"^")
+5 SET $PIECE(PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("IRXN")),"^",6)=$PIECE(^PSRX(PSORENW("IRXN"),0),"^",9)
+6 KILL PSOSD(STAT,PSODRUG("NAME")_"^"_PSORENW("OIRXN"))
QUIT
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET $PIECE(PSOSD(STAT,PSODRUG("NAME")),"^")=PSORENW("IRXN")
SET $PIECE(PSOSD(STAT,PSODRUG("NAME")),"^",2)=$PIECE($GET(^PSRX(PSORENW("IRXN"),"STA")),"^")
+9 SET $PIECE(PSOSD(STAT,PSODRUG("NAME")),"^",6)=$PIECE(^PSRX(PSORENW("IRXN"),0),"^",9)
+10 SET ^TMP("PS",$JOB,STAT,PSODRUG("NAME"))=1
End DoDot:1
+11 QUIT
+12 ;
PROV(PSORENW) ;called from psoornew
CHKPRV ;check inactive providers and cosinging providers called from PSORENW (renew rx)
+1 NEW OK
+2 IF '$DATA(^VA(200,PSORENW("PROVIDER"),0))
Begin DoDot:1
+3 WRITE !,$CHAR(7),"Provider not in New Person File .. You must select a new provider"
+4 SET PSODIR("FIELD")=0
KILL PSORENW("PROVIDER")
DO PROV^PSODIR(.PSORENW)
+5 if $GET(PSORENW("PROVIDER"))']""
SET PSORENW("DFLG")=1
End DoDot:1
IF 'OK
if PSORENW("DFLG")
GOTO CHKPRVX
+6 ;
+7 IF '$GET(^VA(200,PSORENW("PROVIDER"),"PS"))
Begin DoDot:1
+8 IF $$ISSPLY()
IF $DATA(^XUSEC("ORSUPPLY",PSORENW("PROVIDER")))
SET OK=1
QUIT
+9 SET OK=0
WRITE !,$CHAR(7),$PIECE(^VA(200,PSORENW("PROVIDER"),0),"^")_" is not a Valid provider .. You must select a new provider"
+10 SET PSODIR("FIELD")=0
KILL PSORENW("PROVIDER")
DO PROV^PSODIR(.PSORENW)
+11 if $GET(PSORENW("PROVIDER"))']""
SET PSORENW("DFLG")=1
End DoDot:1
if PSORENW("DFLG")
GOTO CHKPRVX
+12 ;
+13 KILL PSOX
SET PSOX=$PIECE($GET(^VA(200,PSORENW("PROVIDER"),"PS")),"^",4)
+14 IF PSOX
IF PSOX<DT
Begin DoDot:1
+15 WRITE !,$CHAR(7),$PIECE(^VA(200,PSORENW("PROVIDER"),0),"^")_" is inactive as a provider .. You must select a new provider"
+16 SET PSODIR("FIELD")=0
KILL PSORENW("PROVIDER")
DO PROV^PSODIR(.PSORENW)
+17 IF $GET(PSORENW("PROVIDER"))']""
SET PSORENW("DFLG")=1
End DoDot:1
if PSORENW("DFLG")
GOTO CHKPRVX
+18 ;
+19 IF '$DATA(PSORENW("COSIGNING PROVIDER"))
IF $DATA(PSORENW("COSIGNER"))
KILL PSOX
SET PSOX=$PIECE(^VA(200,PSORENW("COSIGNER"),"PS"),"^",4)
IF PSOX
IF PSOX<DT
Begin DoDot:1
+20 WRITE !,$CHAR(7),"Inactive Cosigning Provider .. You must select a new cosigner"
+21 SET PSODIR("FIELD")=0
SET PSODIR("PROVIDER")=$SELECT($DATA(PSORENW("PROVIDER")):PSORENW("PROVIDER"),1:PSORENW("PROVIDER"))
+22 DO COSIGN^PSODIR
IF '$DATA(PSODIR("COSIGNING PROVIDER"))
SET PSORENW("DFLG")=1
+23 SET PSORENW("COSIGNING PROVIDER")=PSODIR("COSIGNING PROVIDER")
End DoDot:1
+24 ;
CHKPRVX KILL PSODIR,PSOX
+1 QUIT
+2 ;
NEXT(PSOX) ;
+1 SET PSOX("RX0")=^PSRX(PSOX("IRXN"),0)
+2 SET PSOX("RX2")=^PSRX(PSOX("IRXN"),2)
+3 SET PSOX("RX3")=^PSRX(PSOX("IRXN"),3)
+4 SET PSOX1=$PIECE(PSOX("RX2"),"^",2)
+5 IF '$ORDER(^PSRX(PSOX("IRXN"),1,0))
Begin DoDot:1
+6 SET $PIECE(PSOX("RX3"),"^")=PSOX1
SET X1=PSOX1
+7 SET X2=$PIECE(PSOX("RX0"),"^",8)-10\1
+8 DO C^%DTC
+9 if '$PIECE(PSOX("RX3"),"^",8)
SET $PIECE(PSOX("RX3"),"^",2)=X
+10 KILL X
QUIT
End DoDot:1
GOTO NEXTX
+11 ;
+12 SET PSOY2=0
+13 FOR PSOY=0:0
SET PSOY=$ORDER(^PSRX(PSOX("IRXN"),1,PSOY))
if 'PSOY
QUIT
SET PSOY1=PSOY
SET PSOY2=PSOY2+1
+14 SET PSOY=^PSRX(PSOX("IRXN"),1,PSOY1,0)
+15 SET PSOX2=$PIECE(PSOY,"^")
+16 SET $PIECE(PSOX("RX3"),"^")=PSOX2
SET X1=PSOX2
+17 SET X2=$PIECE(PSOX("RX0"),"^",8)-10\1
+18 DO C^%DTC
SET PSOY3=X
+19 SET X1=PSOX1
SET X2=(PSOY2+1)*$PIECE(PSOX("RX0"),"^",8)-10\1
+20 DO C^%DTC
SET PSOY4=X
+21 SET $PIECE(PSOX("RX3"),"^",2)=$SELECT(PSOY3<PSOY4:PSOY4,1:PSOY3)
NEXTX ;
+1 KILL X,PSOX1,PSOX2,PSOY,PSOY1,PSOY2,PSOY3,PSOY4
+2 QUIT
+3 ;
SUSDATE(PSOX) ;
+1 SET PSOX("OLD FILL DATE")=PSOX("FILL DATE")
+2 SET PSORX("OLD FILL DATE")=PSORX("FILL DATE")
+3 SET PSOX("FILL DATE")=$PIECE(PSOX("RX3"),"^",2)
+4 IF $ORDER(^PS(52.5,"B",PSOX("IRXN"),0))
IF '$GET(^PS(52.5,+$ORDER(^PS(52.5,"B",PSOX("IRXN"),0)),"P"))
SET PSOX("FILL DATE")=$PIECE(PSOX("RX3"),"^")
+5 SET Y=PSOX("FILL DATE")
+6 XECUTE ^DD("DD")
SET PSORX("FILL DATE")=Y
KILL Y
+7 QUIT
+8 ;
SUSDATEK(PSOX) ;
+1 SET PSOX("FILL DATE")=PSOX("OLD FILL DATE")
+2 IF $GET(PSORX("OLD FILL DATE"))=""
IF $GET(PSORENW("OLD FILL DATE"))
SET Y=PSORENW("OLD FILL DATE")
DO DD^%DT
SET PSORX("OLD FILL DATE")=Y
KILL Y
+3 SET PSORX("FILL DATE")=PSORX("OLD FILL DATE")
+4 KILL PSOX("OLD FILL DATE"),PSORX("OLD FILL DATE")
+5 QUIT
+6 ;
STATUS(PSOREA,PSOSTAT) ;
+1 SET DSMSG="Cannot "_$SELECT($GET(PSOOPT)=3:"renew",1:"refill")_" Rx. "
if $GET(OR0)
SET ACOM=DSMSG
+2 IF PSOREA["A"
if $GET(SPEED)
WRITE ", Inactive Drug.",!
Begin DoDot:1
+3 if $GET(POERR)&('$GET(SPEED))
SET VALMSG=DSMSG_"Inactive Drug."
SET VALMBCK="R"
if '$GET(POERR)
WRITE !," Inactive Drug"
+4 if $GET(OR0)
SET ACOM=ACOM_" Inactive Drug."
End DoDot:1
+5 IF PSOREA["M"
if $GET(SPEED)
WRITE ", Drug no longer used by Outpatient.",!
Begin DoDot:1
+6 if $GET(POERR)&('$GET(SPEED))
SET VALMSG=DSMSG_"Drug no longer used by Outpatient."
SET VALMBCK="R"
if '$GET(POERR)
WRITE !," Drug no longer used by Outpatient."
+7 if $GET(OR0)
SET ACOM=ACOM_" Drug no longer used by Outpatient."
End DoDot:1
+8 ;
+9 IF PSOREA["B"
if $GET(SPEED)
WRITE ", Narcotic Drug."
Begin DoDot:1
+10 if '$GET(POERR)
WRITE !,"Narcotic Drug"
if $GET(POERR)&('$GET(SPEED))
SET VALMSG=DSMSG_"Narcotic Drug."
SET VALMBCK="R"
+11 if $GET(OR0)
SET ACOM=ACOM_" Narcotic Drug."
End DoDot:1
+12 ;
+13 IF PSOREA["C"
if $GET(SPEED)
WRITE ", Non-Renewable Drug."
Begin DoDot:1
+14 if '$GET(POERR)
WRITE !,"Non-Renewable Drug"
if $GET(POERR)&('$GET(SPEED))
SET VALMSG=DSMSG_"Non-Renewable Drug."
SET VALMBCK="R"
+15 if $GET(OR0)
SET ACOM=ACOM_" Non-Renewable Drug."
End DoDot:1
+16 ;
+17 IF PSOREA["D"
if $GET(SPEED)
WRITE ", Non-Renewable Patient Status."
Begin DoDot:1
+18 if '$GET(POERR)
WRITE !,"Non-Renewable Patient Status"
if $GET(POERR)&('$GET(SPEED))
SET VALMSG=DSMSG_"Non-Renewable Patient Status."
SET VALMBCK="R"
+19 if $GET(OR0)
SET ACOM=ACOM_" Non-Renewable Patient Status."
End DoDot:1
+20 ;
+21 IF PSOREA["E"
if $GET(SPEED)
WRITE ", Non-Verified Rx."
Begin DoDot:1
+22 if '$GET(POERR)
WRITE !,"Non-Verified Rx"
if $GET(POERR)&('$GET(SPEED))
SET VALMSG=DSMSG_"Non-Verified Rx."
SET VALMBCK="R"
+23 if $GET(OR0)
SET ACOM=ACOM_" Non-Verified Rx."
End DoDot:1
+24 ;
+25 IF PSOREA["F"
if $GET(SPEED)
WRITE ", Maximum of 26 Renewals."
Begin DoDot:1
+26 if '$GET(POERR)
WRITE !,"Maximum of 26 Renewals"
if $GET(POERR)&('$GET(SPEED))
SET VALMSG=DSMSG_"Maximum of 26 Renewals."
SET VALMBCK="R"
+27 if $GET(OR0)
SET ACOM=ACOM_" Maximum of 26 Renewals."
End DoDot:1
+28 ;
+29 IF PSOREA["G"
IF PSOREA'["B"
if $GET(SPEED)
WRITE ", No more refills left."
if '$GET(POERR)
WRITE !,"No more refills left"
if $GET(POERR)&('$GET(SPEED))
SET VALMSG=DSMSG_"No more refills left."
SET VALMBCK="R"
+30 ;
+31 IF PSOREA["Z"
Begin DoDot:1
+32 if PSOSTAT=4
SET PSOSTAT=1
+33 SET PSOA=";"_PSOSTAT
SET PSOB=$PIECE(^DD(52,100,0),"^",3)
SET PSOA=$FIND(PSOB,PSOA)
SET PSOA=$PIECE($EXTRACT(PSOB,PSOA,999),";",1)
+34 if $GET(SPEED)
WRITE ", Rx is in "_$PIECE(PSOA,":",2)_" status."
+35 if '$GET(POERR)&('$GET(SPEED))
WRITE !,"Rx is in "_$PIECE(PSOA,":",2)_" status"
+36 if $GET(POERR)&($GET(VALMSG)']"")&('$GET(SPEED))
SET VALMSG=DSMSG_"Rx is in "_$PIECE(PSOA,":",2)_" status."
SET VALMBCK="R"
+37 KILL PSOA,PSOB
+38 QUIT
End DoDot:1
+39 IF $GET(SPEED)
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIRUT,DUOUT,DTOUT,DIR
+40 QUIT
ACP IF $PIECE(^PSRX(PSOX("IRXN"),0),"^",11)="W"
IF $GET(^("IB"))
SET ^PSRX("ACP",$PIECE(^PSRX(PSOX("IRXN"),0),"^",2),$PIECE(^(2),"^",2),0,PSOX("IRXN"))=""
+1 QUIT
+2 ;
RENFDT(PSOX) ;gets the correct fill date
+1 SET PSOX("OLD FILL DATE")=PSOX("FILL DATE")
+2 SET PSORX("OLD FILL DATE")=PSORX("FILL DATE")
+3 SET PSOX("FILL DATE")=$PIECE(PSOX("RX3"),"^",2)
+4 NEW RXY,LBL,SUPN,LBP,RF,RFN,RFD
+5 SET RXY=PSOX("IRXN")
SET RFN=0
+6 IF '$ORDER(^PSRX(RXY,1,0))
DO GFDT
GOTO SDTX
+7 FOR RF=0:0
SET RF=$ORDER(^PSRX(RXY,1,RF))
if 'RF
QUIT
SET RFN=RF
+8 SET RF=^PSRX(RXY,1,RFN,0)
DO GFDT
+9 IF PSOX("FILL DATE")<DT
IF PSOX("FILL DATE")<PSORNW("FILL DATE")
SET PSOX("FILL DATE")=DT
SDTX ;
+1 SET Y=PSOX("FILL DATE")
+2 XECUTE ^DD("DD")
SET PSORX("FILL DATE")=Y
KILL Y
+3 QUIT
GFDT ;
+1 IF 'RFN
IF $PIECE(^PSRX(RXY,2),"^",13)
QUIT
+2 IF RFN
IF $PIECE(RF,"^",18)
QUIT
+3 FOR LBL=0:0
SET LBL=$ORDER(^PSRX(RXY,"L",LBL))
if 'LBL
QUIT
IF $PIECE(^PSRX(RXY,"L",LBL,0),"^",2)=RFN
SET LBP=1
QUIT
+4 if $GET(LBP)
QUIT
+5 SET SUPN=$ORDER(^PS(52.5,"B",RXY,0))
+6 IF SUPN
IF $PIECE($GET(^PS(52.5,SUPN,0)),"^",7)="L"!($PIECE($GET(^(0)),"^",7)="X")
QUIT
+7 if RFN
SET RFD=$EXTRACT($PIECE(RF,"^"),1,7)
if 'RFN
SET RFD=$PIECE(PSOX("RX3"),"^")
+8 IF SUPN
IF RFD
IF $DATA(^PS(52.5,"C",RFD,SUPN))
IF $GET(^PS(52.5,SUPN,"P"))=1
QUIT
+9 SET PSOX("FILL DATE")=$PIECE(PSOX("RX3"),"^")
+10 QUIT
+11 ;
ISSPLY() ;is the drug a supply item
+1 ;assumes the existence of the PSODRUG array
+2 IF $GET(PSODRUG("DEA"))=""
QUIT 0
+3 IF $GET(PSODRUG("VA CLASS"))=""
QUIT 0
+4 IF PSODRUG("VA CLASS")?1"XA".E!(PSODRUG("VA CLASS")?1"XX".E)!(PSODRUG("VA CLASS")="DX900"&(PSODRUG("DEA")["S"))
QUIT 1
+5 QUIT 0
+6 ;
DAYSUP(DRUG,RXARR,RCLQTY) ; Adjusts DAYS SUPPLY and QUANTITY based on the maximum allowed
+1 ; Input: DRUG - DRUG file (#50) IEN
+2 ; RXARR - Array containing prescription information
+3 ; RVWQTY - Re-calculate Quantity (1: YES / 0: NO)
+4 ;Output: RXARR - Array with "DAYS SUPPLY" and "QTY" values modified
+5 ;
+6 ; - Invalid Dispense Drug
+7 IF '$DATA(^PSDRUG(+$GET(DRUG),0))!'$DATA(RXARR)
QUIT
+8 NEW MXDAYSUP,RXDAYSUP,RXQTY,NEWQTY
+9 SET MXDAYSUP=$$MXDAYSUP^PSSUTIL1(DRUG)
+10 SET RXDAYSUP=+$GET(RXARR("DAYS SUPPLY"))
+11 IF RXDAYSUP>MXDAYSUP
Begin DoDot:1
+12 WRITE !!,"The current DAYS SUPPLY value (",RXDAYSUP,") exceeds the Maximum allowed"
+13 WRITE !,"for ",$$GET1^DIQ(50,DRUG,.01)," (",MXDAYSUP,") and will be reset.",$CHAR(7)
+14 SET RXARR("DAYS SUPPLY")=MXDAYSUP
+15 SET RXQTY=+$GET(RXARR("QTY"))
+16 IF $GET(RCLQTY)
IF RXQTY
IF RCLQTY'=RXQTY
Begin DoDot:2
+17 SET NEWQTY=((RXQTY*MXDAYSUP)/RXDAYSUP)+.5\1
+18 WRITE !!,"The Quantity was changed from ",RXQTY," to ",NEWQTY,"."
+19 SET RXARR("QTY")=NEWQTY
End DoDot:2
+20 WRITE !!,"Please, review the modified order before accepting it."
+21 WRITE !
NEW DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
End DoDot:1
+22 QUIT
+23 ;
MAXNUMRF(DRUG,DAYSUP,PTST,CLOZPAT) ; Returns the Maximum Number of Refills Allowed
+1 ; Input: DRUG - DRUG file (#50) IEN
+2 ; DAYSUP - Number of DAYS SUPPLY per fill
+3 ; PTST - RX PATIENT STATUES (#53) IEN
+4 ; CLOZPAT - Clozapine Indicator Variable (used throughout PSO)
+5 ;Output: MAXNUMRF - Maximum Number of Refills
+6 ;
+7 NEW MAXNUMRF,DEAHDLG,CSDRUG,MAXPTST
+8 ; - Invalid Drug or DAYS SUPPLY value
+9 IF '$DATA(^PSDRUG(+$GET(DRUG),0))
IF '$GET(DAYSUP)
QUIT 0
+10 ;
+11 ; - Calculating Maximum for Clozapine Drug
+12 IF $DATA(CLOZPAT)
QUIT $SELECT(CLOZPAT=2&(DAYSUP=14):1,CLOZPAT=2&(DAYSUP=7):3,CLOZPAT=1&(DAYSUP=7):1,1:0)
+13 ;
+14 ; - Non-Refillable Drugs based on DEA SPECIAL HDLG field
+15 SET DEAHDLG=""
+16 IF $GET(DRUG)
SET DEAHDLG=$$GET1^DIQ(50,DRUG,3)
IF DEAHDLG["A"&(DEAHDLG'["B")!(DEAHDLG["F")!(DEAHDLG[1)!(DEAHDLG[2)
QUIT 0
+17 SET CSDRUG=0
IF (DEAHDLG[3)!(DEAHDLG[4)!(DEAHDLG[5)
SET CSDRUG=1
+18 ;
+19 ; - The Maximum Number of Refills Calculation is different for up to 90 Days Supply Vs. Above 90 Days Supply
+20 IF $GET(CSDRUG)
Begin DoDot:1
+21 IF DAYSUP'>90
Begin DoDot:2
+22 SET MAXNUMRF=$SELECT(DAYSUP<60:5,DAYSUP'<60&(DAYSUP'>89):2,DAYSUP=90:1,1:0)
End DoDot:2
+23 IF '$TEST
Begin DoDot:2
+24 SET MAXNUMRF=182\DAYSUP-1
End DoDot:2
End DoDot:1
+25 IF '$TEST
Begin DoDot:1
+26 IF DAYSUP'>90
Begin DoDot:2
+27 SET MAXNUMRF=$SELECT(DAYSUP<60:11,DAYSUP'<60&(DAYSUP'>89):5,DAYSUP=90:3,1:0)
End DoDot:2
+28 IF '$TEST
Begin DoDot:2
+29 SET MAXNUMRF=365\DAYSUP-1
End DoDot:2
End DoDot:1
+30 ;
+31 ; - Adjusting Maximum based Rx Patient Status
+32 IF $GET(PTST)
SET MAXPTST=$$GET1^DIQ(53,PTST,4)
IF MAXNUMRF>MAXPTST
SET MAXNUMRF=MAXPTST
+33 ;
+34 QUIT MAXNUMRF
+35 ;
BADADDFL(RXIEN) ; Indicate whether an Rx should be flagged with a Bad Address
+1 ; Input: RXIEN - Rx IEN (#52) to be checked
+2 ;Output: BADADDFL - 1: Rx Flagged for Bad Address / 0: Rx NOT Flagged Bad Address
+3 NEW BADADDFL,LSTLBLSQ,LSTLBLTX
+4 SET BADADDFL=0
+5 IF '$GET(^PSRX(+$GET(RXIEN),0))
QUIT BADADDFL
+6 SET LSTLBLSQ=$ORDER(^PSRX(+RXIEN,"L",9999),-1)
+7 IF LSTLBLSQ
Begin DoDot:1
+8 SET LSTLBLTX=$GET(^PSRX(+RXIEN,"L",LSTLBLSQ,0))
IF LSTLBLTX["(BAD ADDRESS)"
SET BADADDFL=1
End DoDot:1
+9 QUIT BADADDFL
+10 ;
PRVDETOX(PRVIEN) ; Returns the Provider DETOX#, if available and not expired
+1 ; Input: (r) PRVIEN - Provider IEN (Pointer to VA PERSON file (#200))
+2 ;Output: PRVDETOX - Provider Detox #
+3 ;P731 detox/x-waiver removal
QUIT ""
+4 NEW PRVDETOX
+5 SET PRVDETOX=$$DETOX^XUSER(PRVIEN)
IF PRVDETOX?2A7N
QUIT PRVDETOX
+6 QUIT ""
+7 ;
RXDEA(RXIEN,ORIEN) ; Returns the Provider DEA# associated with the Prescription/CPRS Order (At least one of RXIEN or ORIEN is required)
+1 ; Input: (o) RXIEN - Prescription IEN (Pointer to the PRESCRIPTION file (#52))
+2 ; (o) ORIEN - CPRS Order IEN (Pointer to ORDER file (#100))
+3 ;Output: RXDEA - Provider DEA# associated with the Prescription
+4 NEW RXDEA
+5 IF $GET(RXIEN)
SET ORIEN=+$$GET1^DIQ(52,RXIEN,39.3,"I")
+6 IF $GET(ORIEN)
KILL ^TMP($JOB,"ORDEA")
DO ARCHIVE^ORDEA(ORIEN)
SET RXDEA=$PIECE($GET(^TMP($JOB,"ORDEA",ORIEN,2)),"^",1)
KILL ^TMP($JOB,"ORDEA")
+7 QUIT $GET(RXDEA)
+8 ;
RXDETOX(RXIEN,ORIEN) ; Returns the Provider DETOX# associated with the Prescription/CPRS Order (At least one of RXIEN or ORIEN is required)
+1 ; Input: (o) RXIEN - Prescription IEN (Pointer to the PRESCRIPTION file (#52))
+2 ; (o) ORIEN - CPRS Order IEN (Pointer to the ORDER file (#100))
+3 ;Output: RXDETOX - Provider DETOX# associated with the Prescription
+4 NEW RXDETOX
+5 IF $GET(RXIEN)
SET ORIEN=+$$GET1^DIQ(52,RXIEN,39.3,"I")
+6 IF $GET(ORIEN)
KILL ^TMP($JOB,"ORDEA")
DO ARCHIVE^ORDEA(ORIEN)
SET RXDETOX=$PIECE($GET(^TMP($JOB,"ORDEA",ORIEN,2)),"^",2)
KILL ^TMP($JOB,"ORDEA")
+7 ;Q $G(RXDETOX) ;P731 detox/x-waiver removal
+8 QUIT ""
+9 ;
CHKRXPRV(RXIEN,PRVIEN) ; Check if the Provider can be assigned to a specific Prescription (Used for Rx Copy, Rx Renewal, etc.)
+1 ; Input: (r) RXIEN - Prescription IEN (Pointer to the PRESCRIPTION file (#52))
+2 ; (o) PRVIEN - Provider IEN (Pointer to the NEW PERSON file (#200))
+3 ;Output: $CHKRXPRV - 1: YES / 0: NO^Short Reason (Listman)^Long Reason (Write to screen)
+4 NEW CHKRXPRV,DRUGIEN,CLOZDRUG,DRUGDEA,REASON
+5 IF '$DATA(^PSRX(+$GET(RXIEN),0))
QUIT "0^Prescription not found^Prescription not found"
+6 IF '$GET(PRVIEN)
SET PRVIEN=$$GET1^DIQ(52,RXIEN,4,"I")
+7 IF '$DATA(^VA(200,+$GET(PRVIEN),0))
QUIT "0^Provider not found^Provider not found"
+8 SET DRUGIEN=$$GET1^DIQ(52,RXIEN,6,"I")
IF 'DRUGIEN
QUIT "0^Invalid Dispense Drug^Invalid Dispense Drug"
+9 SET CLOZDRUG=$SELECT($DATA(^PSDRUG("ACLOZ",DRUGIEN)):1,1:0)
+10 IF CLOZDRUG
IF '$DATA(^XUSEC("YSCL AUTHORIZED",PRVIEN))
QUIT "0^Provider does not hold YSCL AUTHORIZED key^Provider on the Rx does not hold the YSCL AUTHORIZED key required for clozapine prescriptions."
+11 SET DRUGDEA=$$DRUGSCHD(DRUGIEN)
+12 IF DRUGDEA'=""
SET REASON=""
Begin DoDot:1
+13 NEW PRVDEA
+14 ;*545
SET PRVDEA=$PIECE($$SDEA^XUSER(0,PRVIEN,DRUGDEA,,$$RXDEA^PSOUTIL(RXIEN)),"^")
+15 IF $LENGTH(PRVDEA)<3
Begin DoDot:2
+16 IF PRVDEA=2
Begin DoDot:3
+17 SET REASON="0^Provider not authorized to write Federal Schedule "_DRUGDEA_" prescriptions. Please contact the provider^Provider not authorized to write Federal Schedule "_DRUGDEA_" prescriptions. Please contact the provi
der^2"
End DoDot:3
QUIT
+18 SET REASON="0^Provider must have a valid DEA# or VA# for this Rx^Provider does not have a valid DEA# or VA# required for this Rx^1"
End DoDot:2
End DoDot:1
IF REASON'=""
QUIT REASON
+19 IF $$DETOX^PSSOPKI(DRUGIEN)
IF $$PRVDETOX^PSOUTIL(PRVIEN)=""
QUIT "0^Provider must have a valid DETOX# for this Rx^Provider does not have a valid DETOX# required for this Rx"
+20 QUIT 1
+21 ;
DRUGSCHD(DRUGIEN) ; Return Drug DEA Schedule or "" (blank) for non-controlled substances
+1 ; Input: (r) DRUGIEN - Dispense Drug IEN (Pointer to the DRUG file (#50))
+2 ;Output: $DRUGSCHD - DEA Schedule or "" (blank) for non-controlled substances
+3 NEW NDFSCHD,DRUGDEA,NDFIEN
+4 SET NDFSCHD=""
SET DRUGDEA=$$GET1^DIQ(50,DRUGIEN,3)
+5 SET NDFIEN=+$$GET1^DIQ(50,DRUGIEN,22,"I")
IF NDFIEN
SET NDFSCHD=$$GET1^DIQ(50.68,NDFIEN,19,"I")
+6 IF +NDFIEN>0!(DRUGDEA="")
QUIT $SELECT('NDFSCHD:"",1:NDFSCHD)
+7 IF "^2^3^"[+DRUGDEA
QUIT $SELECT(DRUGDEA["A":+DRUGDEA,1:+DRUGDEA_"n")
+8 IF "^4^5^"[+DRUGDEA
QUIT +DRUGDEA
+9 QUIT ""
