PSODRG ;IHS/DSD/JCM-ORDER ENTRY DRUG SELECTION ;28-Mar-2016 12:57;DU
;;7.0;OUTPATIENT PHARMACY;**20,23,36,53,54,46,112,139,1005,1013,207,148,243,268,1015,1016,1021**;DEC 1997;Build 14
;Reference ^PSDRUG supported by DBIA 221
;Reference ^PS(50.7 supported by DBIA 2223
;Reference to PSSDIN supported by DBIA 3166
;Reference to $$NDCFMT^PSSNDCUT supported by IA 4707
; Modified IHS/CIA/PLS - 12/30/03 - Line SET+15 and POST+11
; IHS/MSC/PLS - 01/05/07 - Line SET+9
; IHS/MSC/MGH - 10/05/11 - Line START+7
; IHS/MSC/MGH - 02/08/12 - Line SELECT+11
; IHS/MSC/MGH - 12/21/12 - Line POST+16 and POST+21
; IHS/MSC/MGH - 04/04/13 - Line POST+7
; IHS/MSC/PLS - 0/28/2016 - Line SELECT+19
;----------------------------------------------------------
START ;
S (PSONEW("DFLG"),PSONEW("FIELD"),PSODRG("QFLG"))=0
D @($S(+$G(PSOEDIT)=1&('$D(DA)):"SELECT^PSODRGN",1:"SELECT"))
G:$G(PSORXED("DFLG")) END ; Select Drug
I $G(PSORX("EDIT")),$G(PSOY),$G(PSODRUG("IEN"))=+PSOY D G:$G(PSORXED("DFLG")) END
. N NDC D NDC(+$G(PSORXED("IRXN")),0,+PSOY,.NDC) I $G(NDC)="^" S PSORXED("DFLG")=1 Q
. I $G(NDC)'="" S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC
;
I $G(PSORX("EDIT"))]"",'PSONEW("FIELD") D TRADE
G:PSONEW("DFLG")!(PSODRG("QFLG"))!($G(PSORXED("DFLG"))) END
D SET ; Set various drug information
D NFI ; Display dispense drug/orderable item text
;IHS/MSC/MGH Add text for REM medication Patch 1013
D REMMSG^APSPFUNC(PSODRUG("IEN"))
D:'$G(PSOEDIT) POST I $G(PSORX("DFLG")) S PSONEW("DFLG")=1 K:'$G(PSORX("EDIT")) PSORX("DFLG") ; Do any post selection action
END ;D EOJ
Q
;------------------------------------------------------------
;
SELECT ;
K:'$G(PSORXED) CLOZPAT
K DIC,X,Y,PSODRUG("TRADE NAME"),PSODRUG("NDC"),PSODRUG("DAW") S:$G(POERR)&($P($G(OR0),"^",9)) Y=$P(^PSDRUG($P(OR0,"^",9),0),"^")
I $G(PSODRUG("IEN"))]"" S Y=PSODRUG("NAME"),PSONEW("OLD VAL")=PSODRUG("IEN")
W !,"DRUG: "_$S($G(Y)]"":Y_"// ",1:"") R X:$S($D(DTIME):DTIME,1:300) I '$T S DTOUT=1
I X="",$G(Y)]"" S:Y X=Y S:'X X=$G(PSODRUG("IEN")) S:X X="`"_X
G:X="" SELECT
I X?1."?" W !!,"Answer with DRUG NUMBER, or GENERIC NAME, or VA PRODUCT NAME, or",!,"NATIONAL DRUG CLASS, or SYNONYM" G SELECT
I $G(PSORXED),X["^" S PSORXED("DFLG")=1 G SELECTX
I X="^"!(X["^^")!($D(DTOUT)) S PSONEW("DFLG")=1 G SELECTX
I '$G(POERR),X[U,$L(X)>1 S PSODIR("FLD")=PSONEW("FLD") D JUMP^PSODIR1 S:$G(PSODIR("FIELD")) PSONEW("FIELD")=PSODIR("FIELD") K PSODIR S PSODRG("QFLG")=1 G SELECTX
;IHS/MSC/MGH changed for mixed case lookup, uses new cross-reference
;S DIC=50,DIC(0)="EMQZVT",DIC("T")="",D="B^C^VAPN^VAC"
S DIC=50,DIC(0)="EMQZVT",DIC("T")="",D="BCAP^C^VAPN^VAC"
S DIC("S")="I $S('$D(^PSDRUG(+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0),$S($P($G(^PSDRUG(+Y,2)),""^"",3)'[""O"":0,1:1),$D(^PSDRUG(""ASP"",+$G(^(2)),+Y))"
D MIX^DIC1 K DIC,D
I $D(DTOUT) S PSONEW("DFLG")=1 G SELECTX
I $D(DUOUT) K DUOUT G SELECT
I Y<0 G SELECT
;IHS/MSC/PLS - 03/28/2016 - CR5951
I $$ERXONLY^APSPFNC6(+Y) D S Y=-1 G SELECT
.W !,"Drug is marked as ERX Only",*7,!
S:$G(PSONEW("OLD VAL"))=+Y&('$G(PSOEDIT)) PSODRG("QFLG")=1
K PSOY S PSOY=Y,PSOY(0)=Y(0)
I $P(PSOY(0),"^")="OTHER DRUG"!($P(PSOY(0),"^")="OUTSIDE DRUG") D TRADE
SELECTX K X,Y,DTOUT,DUOUT,PSONEW("OLD VAL")
Q
;
NDC(RX,RFL,DRG,NDC) ; Editing NDC for ECME Released Rx's
S NDC=$S($G(NDC)'="":$G(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
I $$STATUS^PSOBPSUT(RX,RFL)="" Q
I '$$RXRLDT^PSOBPSUT(RX,RFL) Q
;
S NDC=$S($G(NDC)'="":$G(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
D NDCEDT^PSONDCUT(RX,.RFL,$G(DRG),$G(PSOSITE),.NDC)
Q
;
TRADE ;
K DIR,DIC,DA,X,Y
S DIR(0)="52,6.5" S:$G(PSOTRN)]"" DIR("B")=$G(PSOTRN) D ^DIR K DIR,DIC
I X="@" S Y=X K DIRUT
I $D(DIRUT) S:$D(DUOUT)!$D(DTOUT)&('$D(PSORX("EDIT"))) PSONEW("DFLG")=1 G TRADEX
S PSODRUG("TRADE NAME")=Y
TRADEX I $G(PSORXED("DFLG")),$D(DIRUT) S PSORXED("DFLG")=1
K DIRUT,DTOUT,DUOUT,X,Y,DA,DR,DIE
Q
SET ;
N STAT S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2)
S PSODRUG("NAME")=$P(PSOY(0),"^")
S:+$G(^PSDRUG(+PSOY,2)) PSODRUG("OI")=+$G(^(2)),PSODRUG("OIN")=$P(^PS(50.7,+$G(^(2)),0),"^")
S PSODRUG("NDF")=$S($G(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
S PSODRUG("MAXDOSE")=$P(PSOY(0),"^",4),PSODRUG("DEA")=$P(PSOY(0),"^",3)
S PSODRUG("CLN")=$S($D(^PSDRUG(+PSOY,"ND")):+$P(^("ND"),"^",6),1:0)
S PSODRUG("SIG")=$P(PSOY(0),"^",5)
I $G(PSODRUG("NDC"))="" S PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSOY,$G(PSOSITE))
S:$D(PSONEW("NDC")) PSONEW("NDC")=PSODRUG("NDC") ;IHS/MSC/PLS
S PSODRUG("DAW")=+$$GET1^DIQ(50,+PSOY,81)
S PSODRUG("STKLVL")=$G(^PSDRUG(+PSOY,660.1))
G:$G(^PSDRUG(+PSOY,660))']"" SETX
S PSOX1=$G(^PSDRUG(+PSOY,660))
S PSODRUG("COST")=$P($G(PSOX1),"^",6)
S PSODRUG("UNIT")=$P($G(PSOX1),"^",8)
S PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9)
; IHS/CIA/PLS - 12/29/03 - Added IHS specific fields
S PSODRUG("AWP")=+$P($G(^PSDRUG(+PSOY,999999931)),U,2) ; AWP Price
S PSODRUG("MANUFACTURER")=$$GET1^DIQ(50,+PSOY,9999999.24,"E")
S PSODRUG("LOT #")=$$GET1^DIQ(50,+PSOY,9999999.25)
;IHS/MSC/MGH Added check if manufacturers expiration date shows up
N APSPMAN S APSPMAN=$P($G(^APSPCTRL(PSOSITE,1)),U)
I APSPMAN<3 S PSODRUG("EXPIRATION DATE")=$$GET1^DIQ(50,+PSOY,9999999.26,"I")
S:($P(%APSITE,"^",11)]"")&((PSODRUG("EXPIRATION DATE")="")!(PSODRUG("EXPIRATION DATE")'>DT)) PSODRUG("EXPIRATION DATE")=$$FMADD^XLFDT(DT,$P(%APSITE,"^",11))
SETX K PSOX1,PSOY
Q
NFI ;display restriction/guidelines
D EN^PSSDIN(PSODRUG("OI"),PSODRUG("IEN")) S NFI=$$PROMPT^PSSDIN
I NFI]"","ODY"[NFI D TD^PSONFI
K NFI Q
POST ;order checks
K PSORX("INTERVENE") N STAT,SIG,PTR,NDF,VAP S PSORX("DFLG")=0
N CMP,CMPDR,PTR
D ^PSOBUILD
D @$S($G(COPY):"^PSOCPDUP",1:"^PSODRDUP") ; Set PSORX("DFLG")=1 if process to stop
Q:$G(PSORX("DFLG"))
W:$G(PSOFIN)']"" !,"Now doing drug interaction and allergy checks. Please wait...",!
;IHS/MSC/MGH Check for compound med
S CMP=$P($G(^PSDRUG(PSODRUG("IEN"),999999935)),U,1)
I CMP D CMP(.PSODRUG)
E D ^PSODGDGI
I $G(PSORX("INTERVENE"))]"" D FULL^VALM1,^PSORXI S VALMBCK="R"
G:PSORX("DFLG") POSTX
D:$P($G(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),"^")]"" CLOZ G:PSORX("DFLG") POSTX
K PSORX("INTERVENE")
S X="APSQLAB" X ^%ZOSF("TEST") I $T D PRINT^APSQLAB ; IHS/CIA/PLS - 01/18/04 - Output lab information
S PSONOAL="" D ALLERGY^PSOORUT2 D:PSONOAL'="" NOALRGY K PSONOAL
G:PSORX("DFLG") POSTX
I $D(PSODRUG("NDF")) S NDF=$P(PSODRUG("NDF"),"A"),VAP=$P(PSODRUG("NDF"),"A",2),PTR=NDF_"."_VAP
I $G(NDF) D CHK^PSODGAL(PSODFN,"DR",PTR) K NDF,VAP,PTR
I $P($G(PSODRUG("NDF")),"A")=0 D CHK1^PSODGAL(PSODFN)
I $D(PSODRUG("VA CLASS")) D CLASS^PSODGAL(PSODFN)
Q
CMP(PSODRUG) ;IHS/MSC/MGH Check for compound med
N SAVE,CDRG
S CMPDR=0
S SAVE("VA CLASS")=PSODRUG("VA CLASS")
S SAVE("NDF")=PSODRUG("NDF")
F S CMPDR=$O(^PSDRUG(PSODRUG("IEN"),999999936,CMPDR)) Q:'+CMPDR D
.S CDRG=$P($G(^PSDRUG(PSODRUG("IEN"),999999936,CMPDR,0)),U,1)
.S PSODRUG("NDF")=$S($G(^PSDRUG(CDRG,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
.;do allergy checks
.S PTR=$$GET1^DIQ(50,CDRG,20,"I")_"."_$$GET1^DIQ(50,CDRG,22,"I")
.D CHK^PSODGAL(PSODFN,"DR",PTR) K PTR
.S PSODRUG("VA CLASS")=$$GET1^DIQ(50,CDRG,2)
.I $D(PSODRUG("VA CLASS")) D CLASS^PSODGAL(PSODFN)
.;Do interventions
.D ^PSODGDGI
S PSODRUG("VA CLASS")=SAVE("VA CLASS")
S PSODRUG("NDF")=SAVE("NDF")
;END MOD
POSTX ;
K ^TMP($J,"DI"_PSODFN),^TMP($J,"DI")
K PSORX("INTERVENE"),DA
Q
;
EOJ ;
K PSODRG
Q
;
CLOZ ;
S ANQRTN=$P(^PSDRUG(PSODRUG("IEN"),"CLOZ1"),"^"),ANQX=0
S P(5)=PSODRUG("IEN"),DFN=PSODFN,X=ANQRTN
X ^%ZOSF("TEST") I D @("^"_ANQRTN) S:$G(ANQX) PSORX("DFLG")=1
K P(5),ANQRTN,ANQX,X
Q
;
EN(DRG) ;returns lab test identified for clozapine order checking
K LAB I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")'="PSOCLO1" S LAB("NOT")=0 Q
I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")="PSOCLO1" D
.S (CNT,I)=0 F S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I S CNT=$G(CNT)+1
.I CNT'=2 S LAB("BAD TEST")=0 K CNT Q
.K CNT F I=0:0 S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I D
..S LABT=$S($P(^PSDRUG(DRG,"CLOZ2",I,0),"^",4)=1:"WBC",1:"ANC"),LAB(LABT)=$P(^PSDRUG(DRG,"CLOZ2",I,0),"^")_"^"_$P(^(0),"^",3)_"^"_$P(^(0),"^",4)
K LABT,I
Q
NOALRGY ;
W $C(7),!,"There is no allergy assessment on file for this patient."
W !,"You will be prompted to intervene if you continue with this prescription"
K DIR
S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Continue?: ",DIR("B")="N" D ^DIR
I 'Y S PSORX("DFLG")=1 Q
D ^PSORXI
Q
PSODRG ;IHS/DSD/JCM-ORDER ENTRY DRUG SELECTION ;28-Mar-2016 12:57;DU
+1 ;;7.0;OUTPATIENT PHARMACY;**20,23,36,53,54,46,112,139,1005,1013,207,148,243,268,1015,1016,1021**;DEC 1997;Build 14
+2 ;Reference ^PSDRUG supported by DBIA 221
+3 ;Reference ^PS(50.7 supported by DBIA 2223
+4 ;Reference to PSSDIN supported by DBIA 3166
+5 ;Reference to $$NDCFMT^PSSNDCUT supported by IA 4707
+6 ; Modified IHS/CIA/PLS - 12/30/03 - Line SET+15 and POST+11
+7 ; IHS/MSC/PLS - 01/05/07 - Line SET+9
+8 ; IHS/MSC/MGH - 10/05/11 - Line START+7
+9 ; IHS/MSC/MGH - 02/08/12 - Line SELECT+11
+10 ; IHS/MSC/MGH - 12/21/12 - Line POST+16 and POST+21
+11 ; IHS/MSC/MGH - 04/04/13 - Line POST+7
+12 ; IHS/MSC/PLS - 0/28/2016 - Line SELECT+19
+13 ;----------------------------------------------------------
START ;
+1 SET (PSONEW("DFLG"),PSONEW("FIELD"),PSODRG("QFLG"))=0
+2 DO @($SELECT(+$GET(PSOEDIT)=1&('$DATA(DA)):"SELECT^PSODRGN",1:"SELECT"))
+3 ; Select Drug
IF $GET(PSORXED("DFLG"))
GOTO END
+4 IF $GET(PSORX("EDIT"))
IF $GET(PSOY)
IF $GET(PSODRUG("IEN"))=+PSOY
Begin DoDot:1
+5 NEW NDC
DO NDC(+$GET(PSORXED("IRXN")),0,+PSOY,.NDC)
IF $GET(NDC)="^"
SET PSORXED("DFLG")=1
QUIT
+6 IF $GET(NDC)'=""
SET (PSODRUG("NDC"),PSORXED("FLD",27))=NDC
End DoDot:1
IF $GET(PSORXED("DFLG"))
GOTO END
+7 ;
+8 IF $GET(PSORX("EDIT"))]""
IF 'PSONEW("FIELD")
DO TRADE
+9 IF PSONEW("DFLG")!(PSODRG("QFLG"))!($GET(PSORXED("DFLG")))
GOTO END
+10 ; Set various drug information
DO SET
+11 ; Display dispense drug/orderable item text
DO NFI
+12 ;IHS/MSC/MGH Add text for REM medication Patch 1013
+13 DO REMMSG^APSPFUNC(PSODRUG("IEN"))
+14 ; Do any post selection action
IF '$GET(PSOEDIT)
DO POST
IF $GET(PSORX("DFLG"))
SET PSONEW("DFLG")=1
IF '$GET(PSORX("EDIT"))
KILL PSORX("DFLG")
END ;D EOJ
+1 QUIT
+2 ;------------------------------------------------------------
+3 ;
SELECT ;
+1 IF '$GET(PSORXED)
KILL CLOZPAT
+2 KILL DIC,X,Y,PSODRUG("TRADE NAME"),PSODRUG("NDC"),PSODRUG("DAW")
IF $GET(POERR)&($PIECE($GET(OR0),"^",9))
SET Y=$PIECE(^PSDRUG($PIECE(OR0,"^",9),0),"^")
+3 IF $GET(PSODRUG("IEN"))]""
SET Y=PSODRUG("NAME")
SET PSONEW("OLD VAL")=PSODRUG("IEN")
+4 WRITE !,"DRUG: "_$SELECT($GET(Y)]"":Y_"// ",1:"")
READ X:$SELECT($DATA(DTIME):DTIME,1:300)
IF '$TEST
SET DTOUT=1
+5 IF X=""
IF $GET(Y)]""
IF Y
SET X=Y
IF 'X
SET X=$GET(PSODRUG("IEN"))
IF X
SET X="`"_X
+6 IF X=""
GOTO SELECT
+7 IF X?1."?"
WRITE !!,"Answer with DRUG NUMBER, or GENERIC NAME, or VA PRODUCT NAME, or",!,"NATIONAL DRUG CLASS, or SYNONYM"
GOTO SELECT
+8 IF $GET(PSORXED)
IF X["^"
SET PSORXED("DFLG")=1
GOTO SELECTX
+9 IF X="^"!(X["^^")!($DATA(DTOUT))
SET PSONEW("DFLG")=1
GOTO SELECTX
+10 IF '$GET(POERR)
IF X[U
IF $LENGTH(X)>1
SET PSODIR("FLD")=PSONEW("FLD")
DO JUMP^PSODIR1
IF $GET(PSODIR("FIELD"))
SET PSONEW("FIELD")=PSODIR("FIELD")
KILL PSODIR
SET PSODRG("QFLG")=1
GOTO SELECTX
+11 ;IHS/MSC/MGH changed for mixed case lookup, uses new cross-reference
+12 ;S DIC=50,DIC(0)="EMQZVT",DIC("T")="",D="B^C^VAPN^VAC"
+13 SET DIC=50
SET DIC(0)="EMQZVT"
SET DIC("T")=""
SET D="BCAP^C^VAPN^VAC"
+14 SET DIC("S")="I $S('$D(^PSDRUG(+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0),$S($P($G(^PSDRUG(+Y,2)),""^"",3)'[""O"":0,1:1),$D(^PSDRUG(""ASP"",+$G(^(2)),+Y))"
+15 DO MIX^DIC1
KILL DIC,D
+16 IF $DATA(DTOUT)
SET PSONEW("DFLG")=1
GOTO SELECTX
+17 IF $DATA(DUOUT)
KILL DUOUT
GOTO SELECT
+18 IF Y<0
GOTO SELECT
+19 ;IHS/MSC/PLS - 03/28/2016 - CR5951
+20 IF $$ERXONLY^APSPFNC6(+Y)
Begin DoDot:1
+21 WRITE !,"Drug is marked as ERX Only",*7,!
End DoDot:1
SET Y=-1
GOTO SELECT
+22 IF $GET(PSONEW("OLD VAL"))=+Y&('$GET(PSOEDIT))
SET PSODRG("QFLG")=1
+23 KILL PSOY
SET PSOY=Y
SET PSOY(0)=Y(0)
+24 IF $PIECE(PSOY(0),"^")="OTHER DRUG"!($PIECE(PSOY(0),"^")="OUTSIDE DRUG")
DO TRADE
SELECTX KILL X,Y,DTOUT,DUOUT,PSONEW("OLD VAL")
+1 QUIT
+2 ;
NDC(RX,RFL,DRG,NDC) ; Editing NDC for ECME Released Rx's
+1 SET NDC=$SELECT($GET(NDC)'="":$GET(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
+2 IF $$STATUS^PSOBPSUT(RX,RFL)=""
QUIT
+3 IF '$$RXRLDT^PSOBPSUT(RX,RFL)
QUIT
+4 ;
+5 SET NDC=$SELECT($GET(NDC)'="":$GET(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
+6 DO NDCEDT^PSONDCUT(RX,.RFL,$GET(DRG),$GET(PSOSITE),.NDC)
+7 QUIT
+8 ;
TRADE ;
+1 KILL DIR,DIC,DA,X,Y
+2 SET DIR(0)="52,6.5"
IF $GET(PSOTRN)]""
SET DIR("B")=$GET(PSOTRN)
DO ^DIR
KILL DIR,DIC
+3 IF X="@"
SET Y=X
KILL DIRUT
+4 IF $DATA(DIRUT)
IF $DATA(DUOUT)!$DATA(DTOUT)&('$DATA(PSORX("EDIT")))
SET PSONEW("DFLG")=1
GOTO TRADEX
+5 SET PSODRUG("TRADE NAME")=Y
TRADEX IF $GET(PSORXED("DFLG"))
IF $DATA(DIRUT)
SET PSORXED("DFLG")=1
+1 KILL DIRUT,DTOUT,DUOUT,X,Y,DA,DR,DIE
+2 QUIT
SET ;
+1 NEW STAT
SET PSODRUG("IEN")=+PSOY
SET PSODRUG("VA CLASS")=$PIECE(PSOY(0),"^",2)
+2 SET PSODRUG("NAME")=$PIECE(PSOY(0),"^")
+3 IF +$GET(^PSDRUG(+PSOY,2))
SET PSODRUG("OI")=+$GET(^(2))
SET PSODRUG("OIN")=$PIECE(^PS(50.7,+$GET(^(2)),0),"^")
+4 SET PSODRUG("NDF")=$SELECT($GET(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$PIECE(^("ND"),"^",3),1:0)
+5 SET PSODRUG("MAXDOSE")=$PIECE(PSOY(0),"^",4)
SET PSODRUG("DEA")=$PIECE(PSOY(0),"^",3)
+6 SET PSODRUG("CLN")=$SELECT($DATA(^PSDRUG(+PSOY,"ND")):+$PIECE(^("ND"),"^",6),1:0)
+7 SET PSODRUG("SIG")=$PIECE(PSOY(0),"^",5)
+8 IF $GET(PSODRUG("NDC"))=""
SET PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSOY,$GET(PSOSITE))
+9 ;IHS/MSC/PLS
IF $DATA(PSONEW("NDC"))
SET PSONEW("NDC")=PSODRUG("NDC")
+10 SET PSODRUG("DAW")=+$$GET1^DIQ(50,+PSOY,81)
+11 SET PSODRUG("STKLVL")=$GET(^PSDRUG(+PSOY,660.1))
+12 IF $GET(^PSDRUG(+PSOY,660))']""
GOTO SETX
+13 SET PSOX1=$GET(^PSDRUG(+PSOY,660))
+14 SET PSODRUG("COST")=$PIECE($GET(PSOX1),"^",6)
+15 SET PSODRUG("UNIT")=$PIECE($GET(PSOX1),"^",8)
+16 SET PSODRUG("EXPIRATION DATE")=$PIECE($GET(PSOX1),"^",9)
+17 ; IHS/CIA/PLS - 12/29/03 - Added IHS specific fields
+18 ; AWP Price
SET PSODRUG("AWP")=+$PIECE($GET(^PSDRUG(+PSOY,999999931)),U,2)
+19 SET PSODRUG("MANUFACTURER")=$$GET1^DIQ(50,+PSOY,9999999.24,"E")
+20 SET PSODRUG("LOT #")=$$GET1^DIQ(50,+PSOY,9999999.25)
+21 ;IHS/MSC/MGH Added check if manufacturers expiration date shows up
+22 NEW APSPMAN
SET APSPMAN=$PIECE($GET(^APSPCTRL(PSOSITE,1)),U)
+23 IF APSPMAN<3
SET PSODRUG("EXPIRATION DATE")=$$GET1^DIQ(50,+PSOY,9999999.26,"I")
+24 IF ($PIECE(%APSITE,"^",11)]"")&((PSODRUG("EXPIRATION DATE")="")!(PSODRUG("EXPIRATION DATE")'>DT))
SET PSODRUG("EXPIRATION DATE")=$$FMADD^XLFDT(DT,$PIECE(%APSITE,"^",11))
SETX KILL PSOX1,PSOY
+1 QUIT
NFI ;display restriction/guidelines
+1 DO EN^PSSDIN(PSODRUG("OI"),PSODRUG("IEN"))
SET NFI=$$PROMPT^PSSDIN
+2 IF NFI]""
IF "ODY"[NFI
DO TD^PSONFI
+3 KILL NFI
QUIT
POST ;order checks
+1 KILL PSORX("INTERVENE")
NEW STAT,SIG,PTR,NDF,VAP
SET PSORX("DFLG")=0
+2 NEW CMP,CMPDR,PTR
+3 DO ^PSOBUILD
+4 ; Set PSORX("DFLG")=1 if process to stop
DO @$SELECT($GET(COPY):"^PSOCPDUP",1:"^PSODRDUP")
+5 IF $GET(PSORX("DFLG"))
QUIT
+6 IF $GET(PSOFIN)']""
WRITE !,"Now doing drug interaction and allergy checks. Please wait...",!
+7 ;IHS/MSC/MGH Check for compound med
+8 SET CMP=$PIECE($GET(^PSDRUG(PSODRUG("IEN"),999999935)),U,1)
+9 IF CMP
DO CMP(.PSODRUG)
+10 IF '$TEST
DO ^PSODGDGI
+11 IF $GET(PSORX("INTERVENE"))]""
DO FULL^VALM1
DO ^PSORXI
SET VALMBCK="R"
+12 IF PSORX("DFLG")
GOTO POSTX
+13 IF $PIECE($GET(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),"^")]""
DO CLOZ
IF PSORX("DFLG")
GOTO POSTX
+14 KILL PSORX("INTERVENE")
+15 ; IHS/CIA/PLS - 01/18/04 - Output lab information
SET X="APSQLAB"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO PRINT^APSQLAB
+16 SET PSONOAL=""
DO ALLERGY^PSOORUT2
IF PSONOAL'=""
DO NOALRGY
KILL PSONOAL
+17 IF PSORX("DFLG")
GOTO POSTX
+18 IF $DATA(PSODRUG("NDF"))
SET NDF=$PIECE(PSODRUG("NDF"),"A")
SET VAP=$PIECE(PSODRUG("NDF"),"A",2)
SET PTR=NDF_"."_VAP
+19 IF $GET(NDF)
DO CHK^PSODGAL(PSODFN,"DR",PTR)
KILL NDF,VAP,PTR
+20 IF $PIECE($GET(PSODRUG("NDF")),"A")=0
DO CHK1^PSODGAL(PSODFN)
+21 IF $DATA(PSODRUG("VA CLASS"))
DO CLASS^PSODGAL(PSODFN)
+22 QUIT
CMP(PSODRUG) ;IHS/MSC/MGH Check for compound med
+1 NEW SAVE,CDRG
+2 SET CMPDR=0
+3 SET SAVE("VA CLASS")=PSODRUG("VA CLASS")
+4 SET SAVE("NDF")=PSODRUG("NDF")
+5 FOR
SET CMPDR=$ORDER(^PSDRUG(PSODRUG("IEN"),999999936,CMPDR))
IF '+CMPDR
QUIT
Begin DoDot:1
+6 SET CDRG=$PIECE($GET(^PSDRUG(PSODRUG("IEN"),999999936,CMPDR,0)),U,1)
+7 SET PSODRUG("NDF")=$SELECT($GET(^PSDRUG(CDRG,"ND"))]"":+^("ND")_"A"_$PIECE(^("ND"),"^",3),1:0)
+8 ;do allergy checks
+9 SET PTR=$$GET1^DIQ(50,CDRG,20,"I")_"."_$$GET1^DIQ(50,CDRG,22,"I")
+10 DO CHK^PSODGAL(PSODFN,"DR",PTR)
KILL PTR
+11 SET PSODRUG("VA CLASS")=$$GET1^DIQ(50,CDRG,2)
+12 IF $DATA(PSODRUG("VA CLASS"))
DO CLASS^PSODGAL(PSODFN)
+13 ;Do interventions
+14 DO ^PSODGDGI
End DoDot:1
+15 SET PSODRUG("VA CLASS")=SAVE("VA CLASS")
+16 SET PSODRUG("NDF")=SAVE("NDF")
+17 ;END MOD
POSTX ;
+1 KILL ^TMP($JOB,"DI"_PSODFN),^TMP($JOB,"DI")
+2 KILL PSORX("INTERVENE"),DA
+3 QUIT
+4 ;
EOJ ;
+1 KILL PSODRG
+2 QUIT
+3 ;
CLOZ ;
+1 SET ANQRTN=$PIECE(^PSDRUG(PSODRUG("IEN"),"CLOZ1"),"^")
SET ANQX=0
+2 SET P(5)=PSODRUG("IEN")
SET DFN=PSODFN
SET X=ANQRTN
+3 XECUTE ^%ZOSF("TEST")
IF $TEST
DO @("^"_ANQRTN)
IF $GET(ANQX)
SET PSORX("DFLG")=1
+4 KILL P(5),ANQRTN,ANQX,X
+5 QUIT
+6 ;
EN(DRG) ;returns lab test identified for clozapine order checking
+1 KILL LAB
IF $PIECE($GET(^PSDRUG(DRG,"CLOZ1")),"^")'="PSOCLO1"
SET LAB("NOT")=0
QUIT
+2 IF $PIECE($GET(^PSDRUG(DRG,"CLOZ1")),"^")="PSOCLO1"
Begin DoDot:1
+3 SET (CNT,I)=0
FOR
SET I=$ORDER(^PSDRUG(DRG,"CLOZ2",I))
IF 'I
QUIT
SET CNT=$GET(CNT)+1
+4 IF CNT'=2
SET LAB("BAD TEST")=0
KILL CNT
QUIT
+5 KILL CNT
FOR I=0:0
SET I=$ORDER(^PSDRUG(DRG,"CLOZ2",I))
IF 'I
QUIT
Begin DoDot:2
+6 SET LABT=$SELECT($PIECE(^PSDRUG(DRG,"CLOZ2",I,0),"^",4)=1:"WBC",1:"ANC")
SET LAB(LABT)=$PIECE(^PSDRUG(DRG,"CLOZ2",I,0),"^")_"^"_$PIECE(^(0),"^",3)_"^"_$PIECE(^(0),"^",4)
End DoDot:2
End DoDot:1
+7 KILL LABT,I
+8 QUIT
NOALRGY ;
+1 WRITE $CHAR(7),!,"There is no allergy assessment on file for this patient."
+2 WRITE !,"You will be prompted to intervene if you continue with this prescription"
+3 KILL DIR
+4 SET DIR(0)="SA^1:YES;0:NO"
SET DIR("A")="Do you want to Continue?: "
SET DIR("B")="N"
DO ^DIR
+5 IF 'Y
SET PSORX("DFLG")=1
QUIT
+6 DO ^PSORXI
+7 QUIT
