PSODRG ;IHS/DSD/JCM - ORDER ENTRY DRUG SELECTION ;10/23/18 8:47am
;;7.0;OUTPATIENT PHARMACY;**20,23,36,53,54,46,112,139,207,148,243,268,324,251,375,387,398,390,427,411,458,504,517,457,574,524,747**;DEC 1997;Build 7
; Reference to ^PSDRUG( in ICR #221
; Reference to ^PS(50.7 in ICR #2223
; Reference to $$PROMPT^PSSDIN in ICR #3166
; Reference to EN^PSSDIN in ICR #3166
; Reference to $$GETNDC^PSSNDCUT in ICR #4707
; Reference to ^OROCAPI in ICR #5367
; Reference to $$OITM^ORX8 in ICR #5469
; Reference to ^VADPT in ICR #10061
; Reference to IN^PSSHRQ2 in ICR #5369
; Reference to ^XTMP("ORRDI" in ICR #5440
;
;*524 Add HAZ Handle & Haz Dispose Alert pre-order checks
;----------------------------------------------------------
START ;
S (PSONEW("DFLG"),PSONEW("FIELD"),PSODRG("QFLG"))=0 K PSORX("DFLG")
D @($S(+$G(PSOEDIT)=1&('$D(DA)):"SELECT^PSODRGN",1:"SELECT"))
G:$G(PSORXED("DFLG")) END ; Select Drug
;PATCH PSO*7*517 - Blocking action FN if issuing a controlled substance to a patient without a zipcode
N DRGIEN S DRGIEN=$P($G(PSOY),U)
I $$CSBLOCK^PSOORNEW(PSODFN,DRGIEN) D S DIR(0)="E" W ! D ^DIR K DIR,Y G END
.W !,"Controlled substance prescriptions require a patient address. Please update"
.W !,"patient address information. This action will also invalidate a digitally"
.W !,"signed prescription and require the provider to re-enter the order."
.S PSONEW("DFLG")=1
;PSO*7*517 - END
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:$G(PSONEW("DFLG"))!($G(PSODRG("QFLG")))!($G(PSORXED("DFLG"))) END
D SET ; Set various drug information
D NFI ; Display dispense drug/orderable item text
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 IT,DIC,X,Y,PSODRUG("TRADE NAME"),PSODRUG("NDC"),PSODRUG("DAW"),PSODRUG("BAD") S:$G(POERR)&($P($G(OR0),"^",9)) Y=$$GET1^DIQ(50,$P(OR0,"^",9),.01)
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
S DIC=50,DIC(0)="EMQZVT",DIC("T")="",D="B^C^VAPN^VAC"
S DIC("S")="I $S('$$GET1^DIQ(50,+Y,100,""I""):1,DT'>$$GET1^DIQ(50,+Y,100,""I""):1,1:0),$S($$GET1^DIQ(50,+Y,63,""I"")'[""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
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 Released Rx's or for Unresolved ECME Rejects
S NDC=$S($G(NDC)'="":$G(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
; Check if we should edit the NDC
; Needs to be released or have unresolved billable rejects (PSO*7*427)
;
N PSOCONT S PSOCONT=0 ; continue flag
D Q:'PSOCONT ; get out if NDC edit not allowed
. I $$RXRLDT^PSOBPSUT(RX,RFL) S PSOCONT=1 Q ; Released - continue and allow edit
. I $$FIND^PSOREJUT(RX,RFL),$$STATUS^PSOBPSUT(RX,RFL)'="" S PSOCONT=1 Q ; unreleased w/unresolved billable rejections
. 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 PSOHZ S PSOHZ=0 ;init haz alert shown to user=no *524
N STAT S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2)
S PSODRUG("NAME")=$P(PSOY(0),"^")
S PSODRUG("OI")=+$$GET1^DIQ(50,+PSOY,2.1,"I"),PSODRUG("OIN")=$$GET1^DIQ(50,+PSOY,2.1)
S PSODRUG("NDF")=$S(PSODRUG("OI"):$$GET1^DIQ(50,+PSOY,20,"I")_"A"_$$GET1^DIQ(50,+PSOY,22,"I"),1:0)
S PSODRUG("MAXDOSE")=$P(PSOY(0),"^",4),PSODRUG("DEA")=$P(PSOY(0),"^",3)
; (#25) NATIONAL DRUG CLASS [6P:50.605]
S PSODRUG("CLN")=+$$GET1^DIQ(50,+PSOY,25,"I") ; zero if field is null
S PSODRUG("SIG")=$P(PSOY(0),"^",5)
I $G(PSODRUG("NDC"))="" S PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSOY,$G(PSOSITE))
S PSODRUG("DAW")=$$GET1^DIQ(50,+PSOY,81)
I PSODRUG("DAW")="" S PSODRUG("DAW")=0
S PSODRUG("STKLVL")=$$GET1^DIQ(50,+PSOY,50)
;PSO*7*574 - Defect 1181628 Replaced code for PRICE PER DISPENSE UNIT display
G:$G(^PSDRUG(+PSOY,660))']"" SETX
S PSOX1=$G(^PSDRUG(+PSOY,660))
S PSODRUG("COST")=$$GET1^DIQ(50,+PSOY,16) ; PSO*7*574 changed field to (#16) PRICE PER DISPENSE UNIT [6N]
S PSODRUG("UNIT")=$$GET1^DIQ(50,+PSOY,14.5)
S PSODRUG("EXPIRATION DATE")=$$GET1^DIQ(50,+PSOY,17.1,"I")
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
;add Hazardous to Handle/Dispose warning messages *524
N HAZ,HAZH,HAZD,HTXT,LL S HAZ=$$HAZ^PSSUTIL(PSODRUG("IEN")),HAZH=$P(HAZ,U),HAZD=$P(HAZ,U,2)
I ('$G(PSOHZ)!(PSODRUG("IEN")'=$G(PSOLSTDR))),(HAZH!HAZD) D
. S PSOHZ=1,PSOLSTDR=PSODRUG("IEN")
. D HAZWARNG^PSSUTIL(PSODRUG("IEN"),"O",HAZH,HAZD,.HTXT)
. S $P(LL,"-",80)="-"
. W #,$C(7),LL,!
. W $J("***** WARNING *****",47)
. D WRAPTEXT(HTXT,65,5) W !
. W LL,!
. K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue" D ^DIR
N LIST S LIST="PSOPEPS"
K PSODOSD,^TMP("PSORXDC",$J),^TMP($J,LIST),^TMP("PSODAOC",$J)
K ZDGDG,ZTHER,IT,PSODLQT,PSODOSD
I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) S ^TMP("PSODAOC",$J,"NORDI",1,0)="Remote data not available - Only local order checks processed."
S ^TMP($J,LIST,"IN","PING")="" D IN^PSSHRQ2(LIST)
K DIR I $P(^TMP($J,LIST,"OUT",0),"^")=-1 D
.D DATACK^PSODDPRE
.S ^TMP("PSODAOC",$J,"NOSYS",1,0)="No Enhanced Order Checks can be performed. Reason(s): "_$P($G(^TMP($J,LIST,"OUT",0)),"^",2)
K ^TMP($J,LIST,"IN"),^TMP($J,LIST,"OUT","EXCEPTIONS")
G:$G(PSORX("DFLG"))!($G(PSORXED("DFLG"))) POSTX
K PSORX("INTERVENE"),PSOQUIT N STAT,SIG,PTR,NDF,VAP S PSORX("DFLG")=0
W !! D HD^PSODDPR2():(($Y+5)'>IOSL)
D ^PSOBUILD
D:'$D(PSODGCK) @$S($G(COPY):"^PSOCPPRE",1:"^PSODDPRE") ; Duplicate drug check
G:$G(PSORX("DFLG")) POSTX
D HD^PSODDPR2():(($Y+5)'>IOSL)
I $$GET1^DIQ(50,+$G(PSODRUG("IEN")),17.5)="PSOCLO1" D CLOZ
G:PSORX("DFLG") POSTX
D HD^PSODDPR2():(($Y+5)'>IOSL)
W !,"Now doing allergy checks. Please wait...",! H 1
S PSONOAL="" D ALLERGY^PSOORUT2 D:PSONOAL'="" NOALRGY K PSONOAL
D HD^PSODDPR2():(($Y+5)'>IOSL)
I '$G(PSODGCKX) D ^PSODGAL1 K PSORX("INTERVENE")
G:PSORX("DFLG")!$G(PSOQUIT) POSTX
;This is the allergy check for profile drugs CK action
I $D(PSODGCK),$D(PSOSD) D PRFLP^PSOUTL
G:$G(PSORX("DFLG")) POSTX ;pso*7*412
G:$G(PSOSPRNW)&($G(PSORENW("DFLG"))) POSTX ;speed renew
;aminoglycoside
N AOC,CROCPFLG S CROCPFLG=0
D HD^PSODDPR2():(($Y+5)'>IOSL)
S AOC=$$AOC^OROCAPI(PSODFN,$P(PSODRUG("NDF"),"A",2)) I $P(AOC,"^",4)]"" D
.S CROCPFLG=1
.W !!,"***Aminoglycoside Ordered***",!!
.K ^UTILITY($J,"W") S DIWL=1,DIWR=78,DIWF="" S X=$P(AOC,"^",4) D ^DIWP
.W ! F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX W ?2,^UTILITY($J,"W",1,ZX,0),! D HD^PSODDPR2():(($Y+5)'>IOSL)
.K ^UTILITY($J,"W")
.S ^TMP("PSODAOC",$J,"CPRS",$P(AOC,"^",2),0)=PSODRUG("IEN")_"^"_$P(AOC,"^",4)
.W !
D HD^PSODDPR2():(($Y+5)'>IOSL)
;dangerous meds for pat >64
I $G(PSODRUG("OI")) D
.N OI,OIR S OI=$$OITM^ORX8(PSODRUG("OI"),"99PSP") Q:'OI
.S OIR=$$DOC^OROCAPI(PSODFN,OI) I $P(OIR,"^",4)]"" D
..S CROCPFLG=1
..D HD^PSODDPR2():(($Y+5)'>IOSL) W !!,"***Dangerous Meds for Patient >64***",!! S DFN=PSODFN D DEM^VADPT
..K ^UTILITY($J,"W") S DIWL=1,DIWR=78,DIWF="" S X=$P(OIR,"^",4) D ^DIWP
..F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX W ?2,^UTILITY($J,"W",1,ZX,0),! D HD^PSODDPR2():(($Y+5)'>IOSL)
..K ^UTILITY($J,"W")
..S ^TMP("PSODAOC",$J,"CPRS",$P(OIR,"^",2),0)=PSODRUG("IEN")_"^"_$P(OIR,"^",4)
..W !
D HD^PSODDPR2():(($Y+5)'>IOSL)
;metformin lab results
N GOC S GOC=$$GOC^OROCAPI(PSODFN,PSODRUG("NAME")) I $P(GOC,"^",4)]"" D
.S CROCPFLG=1
.W !!,"***Metformin Lab Results***",!!
.K ^UTILITY($J,"W") S DIWL=1,DIWR=78,DIWF="" S X=$P(GOC,"^",4) D ^DIWP
.F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX W ?2,^UTILITY($J,"W",1,ZX,0),! D HD^PSODDPR2():(($Y+5)'>IOSL)
.K ^UTILITY($J,"W")
.S ^TMP("PSODAOC",$J,"CPRS",$P(GOC,"^",2),0)=PSODRUG("IEN")_"^"_$P(GOC,"^",4)
.W !
D HD^PSODDPR2():(($Y+5)'>IOSL)
;clinical reminder oc
D:'$G(PSONCROC) CK^PSOCROC K CROCPFLG I $G(PSORX("DFLG")) Q
K DIWF,DIWL,DIWR,ZX,DFN,CROCPFLG
I $G(PSODRUG("DEA"))["S"!($E($G(PSODRUG("VA CLASS")),1,2)="XA"),'$G(PSODGCK) D G POSTX ;stops if drug is supply
.W !,"Now Processing Enhanced Order Checks! Please wait...",! H 1
;enhanced OC
D HD^PSODDPR2():(($Y+5)'>IOSL)
W ! D @$S($G(COPY):"OBX^PSOCPPRE",1:"OBX^PSODDPRE") ; Set PSORX("DFLG")=1 if process to stop new enhanced order checks
POSTX ;
K IT,^TMP($J,"DI"),PSORX("INTERVENE"),DA,^TMP($J,"PSODRDI"),ZDGDG,ZTHER,^TMP($J,"DI"_PSODFN),PSZZQUIT
I '$G(PSORXED),'$G(PSOREINS) K PSOQUIT
Q
;
EOJ ;
K PSODRG
Q
WAIT ;
K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue..." W !
D ^DIR K DIRUT,DUOUT,DIR,X,Y
Q
;
CLOZ ;
S ANQRTN=$$GET1^DIQ(50,+$G(PSODRUG("IEN")),17.5),ANQX=0
S P(5)=PSODRUG("IEN"),DFN=PSODFN,X=ANQRTN
X ^%ZOSF("TEST") I D ^PSOCLO1 S:$G(ANQX) PSORX("DFLG")=1
K P(5),ANQRTN,ANQX,X,DFN
Q
;
EN(DRG) ;returns lab test identified for clozapine order checking
K LAB I $$GET1^DIQ(50,+$G(DRG),17.5)'="PSOCLO1" S LAB("NOT")=0 Q
N LABARR D LIST^DIC(50.02,","_DRG_",","2;3","I",,,,,,,"LABARR")
I +LABARR("DILIST",0)'=2 S LAB("BAD TEST")=0 K CNT Q
K CNT F I=1:1 Q:'$D(LABARR("DILIST",2,I)) D
.S LABT=$S(LABARR("DILIST","ID",I,3)=1:"WBC",1:"ANC")
.S LAB(LABT)=LABARR("DILIST",1,I)_"^"_LABARR("DILIST","ID",I,2)_"^"_LABARR("DILIST","ID",I,3)
K LABT,I
Q
NOALRGY ;
D HD^PSODDPR2():(($Y+5)'>IOSL)
N DIR S DIR(0)="SA^1:YES;0:NO"
I $D(^TMP($J,"PSOINTERVENE",+PSODFN)) D Q
.S DIR("A")="No Allergy Assessment - Do you want to duplicate Intervention?: ",DIR("B")="Yes"
.D ^DIR
.I 'Y D Q
..I Y=0 D ^PSORXI Q
..S PSORX("DFLG")=1
.D DUPINV^PSORXI
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"
I $D(PSODGCK) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue..." D ^DIR K DIR
Q:$D(PSODGCK)
N DUOUT,DTOUT,RXIEN,RXSTA ;*398
S DIR("A")="Do you want to Continue?: ",DIR("B")="N" D ^DIR
I 'Y!($D(DUOUT))!($D(DTOUT)) D Q ;*398 - Exit/Timeout
.I $D(PSONV) S PSZZQUIT=1 Q
.S PSORX("DFLG")=1
.I '$O(PSCAN(0)) Q ;*398 - Array has Rx IEN
.I $G(REA)'="R" Q ;*398 - Reinstate only
.S RXIEN=+$G(PSCAN(RX)) I 'RXIEN Q ;*398 - Get Rx IEN
.S RXSTA=$$GET1^DIQ(52,RXIEN,100,"I") ;*398 - Get status
.I RXSTA=12 Q ;*398 - Correct status
.S DIE="^PSRX(",DA=RXIEN,DR="100///12" ;*398 - Discontinued
.D ^DIE ;*398 - Update Rx file
I $D(PSONV) S PSORX("INTERVENE")=0 D EN1^PSORXI(PSONV) Q
D ^PSORXI
Q
;
WRAPTEXT(TEXT,LIMIT,CSPACES) ;Wrap text util copied in from a PSO routine originally *524
;;FUNCTION TO DISPLAY (WRITE) TEXT WRAPPED TO A CERTAIN COLUMN LENGTH
;;DEFAULT=74 CHARACTERS WITH NO SPACES IN FRONT
N WORDS,COUNT,LINE,NEXTWORD
Q:$G(TEXT)']"" ""
S LIMIT=$G(LIMIT,74)
S CSPACES=$S($G(CSPACES):CSPACES,1:0)
S WORDS=$L(TEXT," ")
W !,$$REPEAT^XLFSTR(" ",CSPACES)
F COUNT=1:1:WORDS D
. S NEXTWORD=$P(TEXT," ",COUNT)
. Q:NEXTWORD="" ;TO REMOVE LEADING OR DOUBLE SPACES
. S LINE=$G(LINE)_NEXTWORD_" "
. I $L($G(LINE))>LIMIT W !,$$REPEAT^XLFSTR(" ",CSPACES) K LINE
. W NEXTWORD_" "
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODRG 13017 printed Dec 13, 2024@02:27:23 Page 2
PSODRG ;IHS/DSD/JCM - ORDER ENTRY DRUG SELECTION ;10/23/18 8:47am
+1 ;;7.0;OUTPATIENT PHARMACY;**20,23,36,53,54,46,112,139,207,148,243,268,324,251,375,387,398,390,427,411,458,504,517,457,574,524,747**;DEC 1997;Build 7
+2 ; Reference to ^PSDRUG( in ICR #221
+3 ; Reference to ^PS(50.7 in ICR #2223
+4 ; Reference to $$PROMPT^PSSDIN in ICR #3166
+5 ; Reference to EN^PSSDIN in ICR #3166
+6 ; Reference to $$GETNDC^PSSNDCUT in ICR #4707
+7 ; Reference to ^OROCAPI in ICR #5367
+8 ; Reference to $$OITM^ORX8 in ICR #5469
+9 ; Reference to ^VADPT in ICR #10061
+10 ; Reference to IN^PSSHRQ2 in ICR #5369
+11 ; Reference to ^XTMP("ORRDI" in ICR #5440
+12 ;
+13 ;*524 Add HAZ Handle & Haz Dispose Alert pre-order checks
+14 ;----------------------------------------------------------
START ;
+1 SET (PSONEW("DFLG"),PSONEW("FIELD"),PSODRG("QFLG"))=0
KILL PSORX("DFLG")
+2 DO @($SELECT(+$GET(PSOEDIT)=1&('$DATA(DA)):"SELECT^PSODRGN",1:"SELECT"))
+3 ; Select Drug
if $GET(PSORXED("DFLG"))
GOTO END
+4 ;PATCH PSO*7*517 - Blocking action FN if issuing a controlled substance to a patient without a zipcode
+5 NEW DRGIEN
SET DRGIEN=$PIECE($GET(PSOY),U)
+6 IF $$CSBLOCK^PSOORNEW(PSODFN,DRGIEN)
Begin DoDot:1
+7 WRITE !,"Controlled substance prescriptions require a patient address. Please update"
+8 WRITE !,"patient address information. This action will also invalidate a digitally"
+9 WRITE !,"signed prescription and require the provider to re-enter the order."
+10 SET PSONEW("DFLG")=1
End DoDot:1
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR,Y
GOTO END
+11 ;PSO*7*517 - END
+12 IF $GET(PSORX("EDIT"))
IF $GET(PSOY)
IF $GET(PSODRUG("IEN"))=+PSOY
Begin DoDot:1
+13 NEW NDC
DO NDC(+$GET(PSORXED("IRXN")),0,+PSOY,.NDC)
IF $GET(NDC)="^"
SET PSORXED("DFLG")=1
QUIT
+14 IF $GET(NDC)'=""
SET (PSODRUG("NDC"),PSORXED("FLD",27))=NDC
End DoDot:1
if $GET(PSORXED("DFLG"))
GOTO END
+15 ;
+16 IF $GET(PSORX("EDIT"))]""
IF 'PSONEW("FIELD")
DO TRADE
+17 if $GET(PSONEW("DFLG"))!($GET(PSODRG("QFLG")))!($GET(PSORXED("DFLG")))
GOTO END
+18 ; Set various drug information
DO SET
+19 ; Display dispense drug/orderable item text
DO NFI
+20 ; 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 IT,DIC,X,Y,PSODRUG("TRADE NAME"),PSODRUG("NDC"),PSODRUG("DAW"),PSODRUG("BAD")
if $GET(POERR)&($PIECE($GET(OR0),"^",9))
SET Y=$$GET1^DIQ(50,$PIECE(OR0,"^",9),.01)
+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 SET DIC=50
SET DIC(0)="EMQZVT"
SET DIC("T")=""
SET D="B^C^VAPN^VAC"
+12 ;,$D(^PSDRUG(""ASP"",+$G(^(2)),+Y))"
SET DIC("S")="I $S('$$GET1^DIQ(50,+Y,100,""I""):1,DT'>$$GET1^DIQ(50,+Y,100,""I""):1,1:0),$S($$GET1^DIQ(50,+Y,63,""I"")'[""O"":0,1:1)"
+13 DO MIX^DIC1
KILL DIC,D
+14 IF $DATA(DTOUT)
SET PSONEW("DFLG")=1
GOTO SELECTX
+15 IF $DATA(DUOUT)
KILL DUOUT
GOTO SELECT
+16 IF Y<0
GOTO SELECT
+17 if $GET(PSONEW("OLD VAL"))=+Y&('$GET(PSOEDIT))
SET PSODRG("QFLG")=1
+18 KILL PSOY
SET PSOY=Y
SET PSOY(0)=Y(0)
+19 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 Released Rx's or for Unresolved ECME Rejects
+1 SET NDC=$SELECT($GET(NDC)'="":$GET(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
+2 ; Check if we should edit the NDC
+3 ; Needs to be released or have unresolved billable rejects (PSO*7*427)
+4 ;
+5 ; continue flag
NEW PSOCONT
SET PSOCONT=0
+6 ; get out if NDC edit not allowed
Begin DoDot:1
+7 ; Released - continue and allow edit
IF $$RXRLDT^PSOBPSUT(RX,RFL)
SET PSOCONT=1
QUIT
+8 ; unreleased w/unresolved billable rejections
IF $$FIND^PSOREJUT(RX,RFL)
IF $$STATUS^PSOBPSUT(RX,RFL)'=""
SET PSOCONT=1
QUIT
+9 QUIT
End DoDot:1
if 'PSOCONT
QUIT
+10 ;
+11 SET NDC=$SELECT($GET(NDC)'="":$GET(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
+12 DO NDCEDT^PSONDCUT(RX,.RFL,$GET(DRG),$GET(PSOSITE),.NDC)
+13 QUIT
+14 ;
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 ;init haz alert shown to user=no *524
NEW PSOHZ
SET PSOHZ=0
+2 NEW STAT
SET PSODRUG("IEN")=+PSOY
SET PSODRUG("VA CLASS")=$PIECE(PSOY(0),"^",2)
+3 SET PSODRUG("NAME")=$PIECE(PSOY(0),"^")
+4 SET PSODRUG("OI")=+$$GET1^DIQ(50,+PSOY,2.1,"I")
SET PSODRUG("OIN")=$$GET1^DIQ(50,+PSOY,2.1)
+5 SET PSODRUG("NDF")=$SELECT(PSODRUG("OI"):$$GET1^DIQ(50,+PSOY,20,"I")_"A"_$$GET1^DIQ(50,+PSOY,22,"I"),1:0)
+6 SET PSODRUG("MAXDOSE")=$PIECE(PSOY(0),"^",4)
SET PSODRUG("DEA")=$PIECE(PSOY(0),"^",3)
+7 ; (#25) NATIONAL DRUG CLASS [6P:50.605]
+8 ; zero if field is null
SET PSODRUG("CLN")=+$$GET1^DIQ(50,+PSOY,25,"I")
+9 SET PSODRUG("SIG")=$PIECE(PSOY(0),"^",5)
+10 IF $GET(PSODRUG("NDC"))=""
SET PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSOY,$GET(PSOSITE))
+11 SET PSODRUG("DAW")=$$GET1^DIQ(50,+PSOY,81)
+12 IF PSODRUG("DAW")=""
SET PSODRUG("DAW")=0
+13 SET PSODRUG("STKLVL")=$$GET1^DIQ(50,+PSOY,50)
+14 ;PSO*7*574 - Defect 1181628 Replaced code for PRICE PER DISPENSE UNIT display
+15 if $GET(^PSDRUG(+PSOY,660))']""
GOTO SETX
+16 SET PSOX1=$GET(^PSDRUG(+PSOY,660))
+17 ; PSO*7*574 changed field to (#16) PRICE PER DISPENSE UNIT [6N]
SET PSODRUG("COST")=$$GET1^DIQ(50,+PSOY,16)
+18 SET PSODRUG("UNIT")=$$GET1^DIQ(50,+PSOY,14.5)
+19 SET PSODRUG("EXPIRATION DATE")=$$GET1^DIQ(50,+PSOY,17.1,"I")
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 ;add Hazardous to Handle/Dispose warning messages *524
+2 NEW HAZ,HAZH,HAZD,HTXT,LL
SET HAZ=$$HAZ^PSSUTIL(PSODRUG("IEN"))
SET HAZH=$PIECE(HAZ,U)
SET HAZD=$PIECE(HAZ,U,2)
+3 IF ('$GET(PSOHZ)!(PSODRUG("IEN")'=$GET(PSOLSTDR)))
IF (HAZH!HAZD)
Begin DoDot:1
+4 SET PSOHZ=1
SET PSOLSTDR=PSODRUG("IEN")
+5 DO HAZWARNG^PSSUTIL(PSODRUG("IEN"),"O",HAZH,HAZD,.HTXT)
+6 SET $PIECE(LL,"-",80)="-"
+7 WRITE #,$CHAR(7),LL,!
+8 WRITE $JUSTIFY("***** WARNING *****",47)
+9 DO WRAPTEXT(HTXT,65,5)
WRITE !
+10 WRITE LL,!
+11 KILL DIR
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
SET DIR("A")="Press Return to continue"
DO ^DIR
End DoDot:1
+12 NEW LIST
SET LIST="PSOPEPS"
+13 KILL PSODOSD,^TMP("PSORXDC",$JOB),^TMP($JOB,LIST),^TMP("PSODAOC",$JOB)
+14 KILL ZDGDG,ZTHER,IT,PSODLQT,PSODOSD
+15 IF $DATA(^XTMP("ORRDI","OUTAGE INFO","DOWN"))
SET ^TMP("PSODAOC",$JOB,"NORDI",1,0)="Remote data not available - Only local order checks processed."
+16 SET ^TMP($JOB,LIST,"IN","PING")=""
DO IN^PSSHRQ2(LIST)
+17 KILL DIR
IF $PIECE(^TMP($JOB,LIST,"OUT",0),"^")=-1
Begin DoDot:1
+18 DO DATACK^PSODDPRE
+19 SET ^TMP("PSODAOC",$JOB,"NOSYS",1,0)="No Enhanced Order Checks can be performed. Reason(s): "_$PIECE($GET(^TMP($JOB,LIST,"OUT",0)),"^",2)
End DoDot:1
+20 KILL ^TMP($JOB,LIST,"IN"),^TMP($JOB,LIST,"OUT","EXCEPTIONS")
+21 if $GET(PSORX("DFLG"))!($GET(PSORXED("DFLG")))
GOTO POSTX
+22 KILL PSORX("INTERVENE"),PSOQUIT
NEW STAT,SIG,PTR,NDF,VAP
SET PSORX("DFLG")=0
+23 WRITE !!
if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
+24 DO ^PSOBUILD
+25 ; Duplicate drug check
if '$DATA(PSODGCK)
DO @$SELECT($GET(COPY):"^PSOCPPRE",1:"^PSODDPRE")
+26 if $GET(PSORX("DFLG"))
GOTO POSTX
+27 if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
+28 IF $$GET1^DIQ(50,+$GET(PSODRUG("IEN")),17.5)="PSOCLO1"
DO CLOZ
+29 if PSORX("DFLG")
GOTO POSTX
+30 if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
+31 WRITE !,"Now doing allergy checks. Please wait...",!
HANG 1
+32 SET PSONOAL=""
DO ALLERGY^PSOORUT2
if PSONOAL'=""
DO NOALRGY
KILL PSONOAL
+33 if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
+34 IF '$GET(PSODGCKX)
DO ^PSODGAL1
KILL PSORX("INTERVENE")
+35 if PSORX("DFLG")!$GET(PSOQUIT)
GOTO POSTX
+36 ;This is the allergy check for profile drugs CK action
+37 IF $DATA(PSODGCK)
IF $DATA(PSOSD)
DO PRFLP^PSOUTL
+38 ;pso*7*412
if $GET(PSORX("DFLG"))
GOTO POSTX
+39 ;speed renew
if $GET(PSOSPRNW)&($GET(PSORENW("DFLG")))
GOTO POSTX
+40 ;aminoglycoside
+41 NEW AOC,CROCPFLG
SET CROCPFLG=0
+42 if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
+43 SET AOC=$$AOC^OROCAPI(PSODFN,$PIECE(PSODRUG("NDF"),"A",2))
IF $PIECE(AOC,"^",4)]""
Begin DoDot:1
+44 SET CROCPFLG=1
+45 WRITE !!,"***Aminoglycoside Ordered***",!!
+46 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=78
SET DIWF=""
SET X=$PIECE(AOC,"^",4)
DO ^DIWP
+47 WRITE !
FOR ZX=0:0
SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
if 'ZX
QUIT
WRITE ?2,^UTILITY($JOB,"W",1,ZX,0),!
if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
+48 KILL ^UTILITY($JOB,"W")
+49 SET ^TMP("PSODAOC",$JOB,"CPRS",$PIECE(AOC,"^",2),0)=PSODRUG("IEN")_"^"_$PIECE(AOC,"^",4)
+50 WRITE !
End DoDot:1
+51 if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
+52 ;dangerous meds for pat >64
+53 IF $GET(PSODRUG("OI"))
Begin DoDot:1
+54 NEW OI,OIR
SET OI=$$OITM^ORX8(PSODRUG("OI"),"99PSP")
if 'OI
QUIT
+55 SET OIR=$$DOC^OROCAPI(PSODFN,OI)
IF $PIECE(OIR,"^",4)]""
Begin DoDot:2
+56 SET CROCPFLG=1
+57 if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
WRITE !!,"***Dangerous Meds for Patient >64***",!!
SET DFN=PSODFN
DO DEM^VADPT
+58 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=78
SET DIWF=""
SET X=$PIECE(OIR,"^",4)
DO ^DIWP
+59 FOR ZX=0:0
SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
if 'ZX
QUIT
WRITE ?2,^UTILITY($JOB,"W",1,ZX,0),!
if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
+60 KILL ^UTILITY($JOB,"W")
+61 SET ^TMP("PSODAOC",$JOB,"CPRS",$PIECE(OIR,"^",2),0)=PSODRUG("IEN")_"^"_$PIECE(OIR,"^",4)
+62 WRITE !
End DoDot:2
End DoDot:1
+63 if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
+64 ;metformin lab results
+65 NEW GOC
SET GOC=$$GOC^OROCAPI(PSODFN,PSODRUG("NAME"))
IF $PIECE(GOC,"^",4)]""
Begin DoDot:1
+66 SET CROCPFLG=1
+67 WRITE !!,"***Metformin Lab Results***",!!
+68 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=78
SET DIWF=""
SET X=$PIECE(GOC,"^",4)
DO ^DIWP
+69 FOR ZX=0:0
SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
if 'ZX
QUIT
WRITE ?2,^UTILITY($JOB,"W",1,ZX,0),!
if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
+70 KILL ^UTILITY($JOB,"W")
+71 SET ^TMP("PSODAOC",$JOB,"CPRS",$PIECE(GOC,"^",2),0)=PSODRUG("IEN")_"^"_$PIECE(GOC,"^",4)
+72 WRITE !
End DoDot:1
+73 if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
+74 ;clinical reminder oc
+75 if '$GET(PSONCROC)
DO CK^PSOCROC
KILL CROCPFLG
IF $GET(PSORX("DFLG"))
QUIT
+76 KILL DIWF,DIWL,DIWR,ZX,DFN,CROCPFLG
+77 ;stops if drug is supply
IF $GET(PSODRUG("DEA"))["S"!($EXTRACT($GET(PSODRUG("VA CLASS")),1,2)="XA")
IF '$GET(PSODGCK)
Begin DoDot:1
+78 WRITE !,"Now Processing Enhanced Order Checks! Please wait...",!
HANG 1
End DoDot:1
GOTO POSTX
+79 ;enhanced OC
+80 if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
+81 ; Set PSORX("DFLG")=1 if process to stop new enhanced order checks
WRITE !
DO @$SELECT($GET(COPY):"OBX^PSOCPPRE",1:"OBX^PSODDPRE")
POSTX ;
+1 KILL IT,^TMP($JOB,"DI"),PSORX("INTERVENE"),DA,^TMP($JOB,"PSODRDI"),ZDGDG,ZTHER,^TMP($JOB,"DI"_PSODFN),PSZZQUIT
+2 IF '$GET(PSORXED)
IF '$GET(PSOREINS)
KILL PSOQUIT
+3 QUIT
+4 ;
EOJ ;
+1 KILL PSODRG
+2 QUIT
WAIT ;
+1 KILL DIR
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
SET DIR("A")="Press Return to continue..."
WRITE !
+2 DO ^DIR
KILL DIRUT,DUOUT,DIR,X,Y
+3 QUIT
+4 ;
CLOZ ;
+1 SET ANQRTN=$$GET1^DIQ(50,+$GET(PSODRUG("IEN")),17.5)
SET ANQX=0
+2 SET P(5)=PSODRUG("IEN")
SET DFN=PSODFN
SET X=ANQRTN
+3 XECUTE ^%ZOSF("TEST")
IF $TEST
DO ^PSOCLO1
if $GET(ANQX)
SET PSORX("DFLG")=1
+4 KILL P(5),ANQRTN,ANQX,X,DFN
+5 QUIT
+6 ;
EN(DRG) ;returns lab test identified for clozapine order checking
+1 KILL LAB
IF $$GET1^DIQ(50,+$GET(DRG),17.5)'="PSOCLO1"
SET LAB("NOT")=0
QUIT
+2 NEW LABARR
DO LIST^DIC(50.02,","_DRG_",","2;3","I",,,,,,,"LABARR")
+3 IF +LABARR("DILIST",0)'=2
SET LAB("BAD TEST")=0
KILL CNT
QUIT
+4 KILL CNT
FOR I=1:1
if '$DATA(LABARR("DILIST",2,I))
QUIT
Begin DoDot:1
+5 SET LABT=$SELECT(LABARR("DILIST","ID",I,3)=1:"WBC",1:"ANC")
+6 SET LAB(LABT)=LABARR("DILIST",1,I)_"^"_LABARR("DILIST","ID",I,2)_"^"_LABARR("DILIST","ID",I,3)
End DoDot:1
+7 KILL LABT,I
+8 QUIT
NOALRGY ;
+1 if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
+2 NEW DIR
SET DIR(0)="SA^1:YES;0:NO"
+3 IF $DATA(^TMP($JOB,"PSOINTERVENE",+PSODFN))
Begin DoDot:1
+4 SET DIR("A")="No Allergy Assessment - Do you want to duplicate Intervention?: "
SET DIR("B")="Yes"
+5 DO ^DIR
+6 IF 'Y
Begin DoDot:2
+7 IF Y=0
DO ^PSORXI
QUIT
+8 SET PSORX("DFLG")=1
End DoDot:2
QUIT
+9 DO DUPINV^PSORXI
End DoDot:1
QUIT
+10 WRITE $CHAR(7),!,"There is no allergy assessment on file for this patient."
+11 WRITE !,"You will be prompted to intervene if you continue with this prescription"
+12 IF $DATA(PSODGCK)
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue..."
DO ^DIR
KILL DIR
+13 if $DATA(PSODGCK)
QUIT
+14 ;*398
NEW DUOUT,DTOUT,RXIEN,RXSTA
+15 SET DIR("A")="Do you want to Continue?: "
SET DIR("B")="N"
DO ^DIR
+16 ;*398 - Exit/Timeout
IF 'Y!($DATA(DUOUT))!($DATA(DTOUT))
Begin DoDot:1
+17 IF $DATA(PSONV)
SET PSZZQUIT=1
QUIT
+18 SET PSORX("DFLG")=1
+19 ;*398 - Array has Rx IEN
IF '$ORDER(PSCAN(0))
QUIT
+20 ;*398 - Reinstate only
IF $GET(REA)'="R"
QUIT
+21 ;*398 - Get Rx IEN
SET RXIEN=+$GET(PSCAN(RX))
IF 'RXIEN
QUIT
+22 ;*398 - Get status
SET RXSTA=$$GET1^DIQ(52,RXIEN,100,"I")
+23 ;*398 - Correct status
IF RXSTA=12
QUIT
+24 ;*398 - Discontinued
SET DIE="^PSRX("
SET DA=RXIEN
SET DR="100///12"
+25 ;*398 - Update Rx file
DO ^DIE
End DoDot:1
QUIT
+26 IF $DATA(PSONV)
SET PSORX("INTERVENE")=0
DO EN1^PSORXI(PSONV)
QUIT
+27 DO ^PSORXI
+28 QUIT
+29 ;
WRAPTEXT(TEXT,LIMIT,CSPACES) ;Wrap text util copied in from a PSO routine originally *524
+1 ;;FUNCTION TO DISPLAY (WRITE) TEXT WRAPPED TO A CERTAIN COLUMN LENGTH
+2 ;;DEFAULT=74 CHARACTERS WITH NO SPACES IN FRONT
+3 NEW WORDS,COUNT,LINE,NEXTWORD
+4 if $GET(TEXT)']""
QUIT ""
+5 SET LIMIT=$GET(LIMIT,74)
+6 SET CSPACES=$SELECT($GET(CSPACES):CSPACES,1:0)
+7 SET WORDS=$LENGTH(TEXT," ")
+8 WRITE !,$$REPEAT^XLFSTR(" ",CSPACES)
+9 FOR COUNT=1:1:WORDS
Begin DoDot:1
+10 SET NEXTWORD=$PIECE(TEXT," ",COUNT)
+11 ;TO REMOVE LEADING OR DOUBLE SPACES
if NEXTWORD=""
QUIT
+12 SET LINE=$GET(LINE)_NEXTWORD_" "
+13 IF $LENGTH($GET(LINE))>LIMIT
WRITE !,$$REPEAT^XLFSTR(" ",CSPACES)
KILL LINE
+14 WRITE NEXTWORD_" "
End DoDot:1
+15 QUIT
