- 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 Jan 18, 2025@03:37:12 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 ""