PSODGAL1 ;BIR/LC,SAB - enhanced DRUG ALLERGY REACTION CHECKING ;12/09/07 02:22
;;7.0;OUTPATIENT PHARMACY;**251,401,390,424,429,411,500**;DEC 1997;Build 9
;External reference to $$ORCHK2^GMRAOR supported by DBIA 2378
;External reference to ^PS(50.605 supported by DBIA 696
;External reference to ^XUSEC("PSORPH" supported by DBIA 10076
;External reference to GETOC4^OROCAPI1 supported by DBIA 5729
;External reference to ^PS(55 supported by DBIA 2228
;External reference to ^PS(53.1 supported by DBIA 5793
;External reference to ^PSJRXI supported by DBIA 6076
;External reference to SIG^XUSESIG supported by DBIA 10050
;External reference to $$FINDC^PSJDGAL2 supportedby DBIA 6140
;
EN ; Called from both inpatient and outpatient pharmacy
N PSOACK,DFN,PSODAL,RXN,LPTR,PSOSEVT,PSOSEVT1,NDF,PSOSYMS,PSOINGRE,PSOSORT,PSOGIEN,PSODGCL,PSODGCL1,I,II,PSOADA,PSOADAT,PSOASEV,PSOASITE,PSODRCL1,PSODRCL
N PSOINGR,PSOGMRA,PSOGMRA2,PSOIADAT,PSOLCLAS,PSOLOC,PSOOINGR,PSOSEV,PSOSNAM,PTR,TYP,ZPOP,ZPOP2,ZSITE,ZZSITE,PSOCAGNT,PSORXORD
K ^TMP($J,"PSODRCLS"),DSPLQ,PSOMDC,ZGMRA,GMRAING,GMRADRCL,GMRAREAC,PSOALGYF,PSOASORT,GMRARSLT
S DFN=PSODFN
S (NDF,TYP,PTR,PSOALGYF)=""
I $D(PSODRUG("NDF")),PSODRUG("NDF")'=0 S NDF=$P(PSODRUG("NDF"),"A"),TYP=$P(PSODRUG("NDF"),"A",2),PTR=$S(NDF=0:"",1:NDF)_"."_TYP
S $P(PTR,".",3)=PSODRUG("IEN")
;
CHK ;matched to ndf
S:'$G(PSJALGCT) PSJALGCT=1 ;counter for inpatient; OP will always be 1
K ZMED,ZMEDLCL S PSOACK=$$ORCHK2^GMRAOR(DFN,"DR",PTR,"","GMRARSLT") D:+$G(PSOACK)>0
.D DSPLY Q:$G(PSORX("DFLG"))!($G(PSGORQF))
.Q:$D(^XUSEC("PSORPH",DUZ))!($G(PSODGCK))
.I +$G(PSOACK)=1 D
..N ZMSG,ZLOCAL,ZINGREDS,ZI,ZINGRED
..S ^TMP("PSODAI",$J,0)=1,(PSOSEV,PSOLOC,PSODRG)=""
..S ZMSG="" F S ZMSG=$O(GMRARSLT(ZMSG)) Q:'ZMSG D
...S PSOGIEN=$$GMSGPTR(ZMSG)
...Q:PSOGIEN=""
...S ZLOCAL=$S($P(GMRARSLT(ZMSG,PSOGIEN),U,2)="L":" (local)",1:" (remote)")
...S ZINGREDS=$G(GMRARSLT(ZMSG,"MESSAGE","OFFENDERS","ING"))
...Q:ZINGREDS=""
...S:$E(ZINGREDS,1)="~" ZINGREDS=$E(ZINGREDS,2,9999)
...F ZI=1:1:$L(ZINGREDS,"~") S ZINGRED=$P(ZINGREDS,"~",ZI) Q:ZINGRED="" D
....S ^TMP("PSODAI",$J,ZI,0)=ZINGRED_ZLOCAL
....Q
Q:$G(PSORX("DFLG"))!($G(PSGORQF))
S NDF=$P(PSODRUG("NDF"),"A")
I +$G(PSOACK)>0!$G(^TMP($J,"PSODRCLS",0)) D
.I '$D(^XUSEC("PSORPH",DUZ)),'$D(PSOMDC) K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue" D ^DIR K DIR,DUOUT,DIRUT Q
.I $D(PSJDGCK)!$D(PSODGCK) K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue" D ^DIR K DIR,DUOUT,DIRUT W @IOF Q
.S DIR("?",1)="Answer 'YES' if you DO want to enter a intervention for this medication,",DIR("?")=" 'NO' if you DON'T want to enter a intervention for this medication,"
.S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Intervene? ",DIR("B")="YES" D ^DIR I '$G(PSJAOC) W !
.I ($D(DTOUT))!($D(DUOUT)) S:'$G(PSJAOC) (PSODLQT,PSORX("DFLG"))=1 S:$G(PSJAOC) PSGORQF=1 Q
.I 'Y D:$G(PSOSEVT1("S"))=1 Q
..S:$G(PSJAOC) PSGORQF=1
..S:'$G(PSJAOC) (PSORX("DFLG"),PSOQUIT)=1
..W !!,"With a SEVERE reaction, an intervention is required!",! S VALMBCK="R"
..I $G(PSGCOPY)=1!($G(PSIVCOPY)=1) W !,"Order not copied!",! S PSJCOFLG=1 ;set flag if COPY to not repeat this message in PSGOD
..I $G(PSJREN)=1 W !,"No changes made to this order!",! S PSJRNFLG=1 ;set flag if RENEW to not repeat this message in PSGOEE
..I '$G(PSOSPRNW) K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue" D ^DIR
..S:$G(PSOSPRNW) PSORENW("DFLG")=1,PSORX("DFLG")=0,PSOQUIT=1
..I $D(DTOUT)!($D(DUOUT)) D K DIR,DUOUT,DIRUT W !
...I $G(PSJAOC) S PSGORQF=1 Q ;inpatient
...S (PSODLQT,PSOQUIT,PSORX("DFLG"))=1
.D CRI:$G(PSOSEVT1("S"))=1
.Q:$G(PSORX("DFLG"))!($G(PSGORQF))
.I $G(PSJAOC) S PSJDAL=1 D ^PSJRXI I $G(PSJDAL("DA")) S $P(^TMP("PSODAOC",$J,"ALLERGY",PSJALGCT,"INTERVENTION"),"^")=PSJDAL("DA") K PSJDAL("DA")
.I '$G(PSJAOC) S PSODAL=1 D ^PSORXI I $G(PSODAL("DA")) S $P(^TMP("PSODAOC",$J,"ALLERGY",PSJALGCT,"INTERVENTION"),"^")=PSODAL("DA") K PSODAL("DA")
.K PSJRXI("DA"),PSODAL("DA")
EX K DIR,DTOUT,DIRUT,DIROUT,DUOUT,Y,DSPLQ,PSOMDC,AGNL,SEV,SEV,ZGMRA,LPTR,ALTOT
K PSOACK,GMRAING,GMRADRCL,GMRAREAC,GMRARSLT,I,APTR,GMRA,LP,^TMP($J,"PSODRCLS"),ZCLA,ZCNT,ZINSTL,ZSAT
I $D(PSJDGCK)!$D(PSODGCK)!$G(PSORX("DFLG"))!$G(PSGORQF) K ^TMP("PSODAOC",$J)
I '$G(PSJAOC) K PSGORQF
Q
;
DSPLY ;
K PSOSYMS,PSOCAGNT
D SORTN^PSODGAL3,FULL^VALM1
K AGNL,SEV,SEVN,PSOHIS N INGLOC,ZINGLOC,ZMEDL,DACNT,DACNT2,ZSTA,ZDATE
N ZZING,ZZLOC,ZZALL,PSOACNT,PSOLOCAL,PSOPTR,PSOSITT,PSOCA,ZLOC,PSOATYPE S (ALTOT,DACNT,DACNT2,ZLOC,ZCLA,PSOACNT,PSOATYPE)=0,ZMEDL=""
S (ZZLOC,PSOCA,ZZALL,ZZING,PSOSEV,PSOINGR,PSOASITE,PSOIADAT,PSOGIEN,PSOADA)=""
F S PSOSEV=$O(PSOCAGNT(PSOSEV)) Q:PSOSEV="" F S PSOCA=$O(PSOCAGNT(PSOSEV,PSOCA)) Q:PSOCA="" F S PSOATYPE=$O(PSOCAGNT(PSOSEV,PSOCA,PSOATYPE)) Q:PSOATYPE="" S ALTOT=ALTOT+1
F S PSOSEV=$O(PSOCAGNT(PSOSEV)) Q:PSOSEV=""!($G(PSORX("DFLG")))!($G(PSGORQF)) F S PSOCA=$O(PSOCAGNT(PSOSEV,PSOCA)) Q:PSOCA=""!($G(PSORX("DFLG")))!($G(PSGORQF)) D
.F S PSOATYPE=$O(PSOCAGNT(PSOSEV,PSOCA,PSOATYPE)) Q:PSOATYPE=""!($G(PSORX("DFLG")))!($G(PSGORQF)) D
..S PSOGMRA2=""
..S PSOGMRA2=PSOCAGNT(PSOSEV,PSOCA,PSOATYPE)
..S (PSOPTR,ZZALL,PSODRCL)=""
..S PSOPTR=$P($P(PSOGMRA2,"^",1),"|")
..S PSOSITT=$P($P(PSOGMRA2,"^",1),"|",4)
..S ZZALL=$$GMSGPTR(PSOPTR)
..Q:ZZALL=""
..D DSPLY1
Q
DSPLY1 ;
; 1 2 3 4 5 6 7 8 9 10
N ZINDATE,ZSIGN,PSOINSTL,PSOSTA,PSOHIS,PSOSTYP,PSOMEDL,PSOLOCAL,PSODATA,PSOWCA,PSOCAR,PSOSTYPI,PSOLOCI,PSOMEDLI,PSOHISI,PSOSEVI,DRCLIEN,DRCLIENE,PSODCLAS,ZALL,ZMSG
S PSOHISI=$P(GMRARSLT(PSOPTR,ZZALL),U,8)
S PSOHIS=$S(PSOHISI="o":"OBSERVED",1:"HISTORICAL")
S PSOASEV=$$GETSEV^PSODGAL3(PSOSITT,PSOPTR,.GMRARSLT)
S PSOSEVT=PSOSEV
S DACNT=DACNT+1
S DACNT2=DACNT2+1
S:PSOSEV=1 PSOSEVT1("S")=1
W $C(7),!!,"A Drug-Allergy Reaction exists for this medication and/or class!",!
W !,$S($G(PSODGCKF)!($G(PSJDGFLG)):" Profile Drug: ",1:" Prospective Drug: ")
;
S PSORXORD=""
N PSJCPROS,PSJNCOM,PROSPECT S (PSJCPROS,PSJNCOM,PROPSECT)=""
I $G(PSJAOC) D
.S PSORXORD=$S($G(PSJORD):PSJORD,$G(ON55):ON55,$G(ON):ON,$G(PSJNORD):PSJNORD,1:"")
.I '$G(PSORXORD) S PSORXORD=$G(PSGORD)
.;for complex UD orders display format: orderable item doseform (units) ex: MORPHINE TAB,SA (100MG)
.I $G(PSJCOM) S PSJNCOM=$$FINDC^PSJDGAL2($G(PSORXORD)),PSJCPROS=$P(PSJNCOM,"^",2)
.I '$G(PSJDGCK)&('$G(PSODGCK)) W $S($G(PSORXORD)["V":PSODRUG("OIN"),$G(PSORXORD)["P"&($D(^PS(53.1,+$G(PSORXORD),"AD"))):PSODRUG("OIN"),$G(PSJCOM):PSJCPROS,1:PSODRUG("NAME"))
.I $G(PSJDGCK)!($G(PSODGCK)) W PSODRUG("NAME")
E W PSODRUG("NAME")
;
W !," Causative Agent: "
S (PSOWCA,PSOCAR)="",PSOALGYF=1
I PSOCA["/" D S PSOCAR=$E(PSOCAR,3,$L(PSOCAR))
. F I=1:1 S PSOWCA=$P(PSOCA,"/",I) Q:PSOWCA="" S PSOCAR=PSOCAR_"/ "_PSOWCA
I PSOCAR="" S PSOCAR=PSOCA
;
K ^UTILITY($J,"W"),X S DIWL=1,DIWR=55,(X,DIWF)=""
N CAUSAGNT S (X,PSODCLAS,CAUSAGNT,ZSITE)="",CAUSAGNT=PSOCAGNT(PSOSEV,PSOCA,PSOATYPE)
;
SITE ;
S X=""
F II=1:1 S ZSITE=$P(CAUSAGNT,"^",II) Q:ZSITE="" D
.S (ZDATE,PSOSNAM,ZZSITE,PSOLOCAL)=""
.S ZZSITE=$P(ZSITE,"|",4),ZDATE=$P(ZSITE,"|",2),PSOLOCAL=$P(ZSITE,"|",3),ZMSG=$P(ZSITE,"|")
.S PSOSNAM=$P(GMRARSLT(ZMSG,"MESSAGE",1,ZZSITE),U)
.;;S PSOSNAM=$$GET1^DIQ(4,ZZSITE,.01)
.S X=X_", "_PSOSNAM_" - "_$P(ZDATE,"@")
S X=$S(X'="":PSOCAR_" ("_$E(X,3,9999)_")",1:PSOCAR)
D ^DIWP,UTIL
;
W " Historical/Observed: "_$P(PSOHIS,";")
W !," Severity: "_$S(PSOASEV="":"Not Entered",1:PSOASEV)
S (PSOOINGR,ZPOP)="" N Z,ZI,ZX,ZOV,PSOWINGR,PSOWIN,REMSITE,REMTMP
S DIWL=1,DIWR=55,(X,DIWF)=""
F S PSOINGR=$O(PSOCAGNT(PSOSEV,PSOCA,PSOATYPE,PSOINGR)) Q:PSOINGR=""!(PSOINGR="ZZZSYMPTOMS") D
.I '$G(ZPOP) S ZPOP=1 W !?7," Ingredients: "
.S X=X_", "_PSOINGR
D ^DIWP,UTIL
K ^UTILITY($J,"W"),DIWL,DIWR,DIWF,I,ZX,X,^TMP("PSN",$J),PSNDA,PSNID
I $P(GMRARSLT(PSOPTR,"MESSAGE",2),U)]"" D SYM1 S ZSIGN=1
I '$G(ZSIGN) W ?3," Signs/Symptoms: None Entered",!
S PSOLOCAL="",PSOLOCAL=$P($P(ZZALL,"^",3),"|",2)
;
DRCL ;PSODRCL1(99,"AMPICILLIN/SULBACTAM","PENICILLINS,AMINO DERIVATIVES")=1
I $D(PSODRCL1(PSOSEV,PSOCA,PSOATYPE)) D
.W ?8," Drug Class: "
.N III,XX,X K ^UTILITY($J,"W") S DIWL=1,DIWR=55,(X,XX,DIWF)=""
.F S XX=$O(PSODRCL1(PSOSEV,PSOCA,PSOATYPE,XX)) Q:XX="" D
..S DRCLIEN=PSODRCL1(PSOSEV,PSOCA,PSOATYPE,XX),DRCLIENE=$$GET1^DIQ(50.605,DRCLIEN,.01,"E")
..S X=X_", "_$S(DRCLIENE'="":DRCLIENE_" ",1:"")_XX
.S X=$E(X,3,999) D ^DIWP
.D UTIL
D OVRD ;Override Reason
S PSOACNT=PSOACNT+1
I ALTOT>PSOACNT K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue" D ^DIR
I $D(DTOUT)!($D(DUOUT)) S:$G(PSJAOC) PSGORQF=1 S:'$G(PSJAOC) (PSODLQT,PSORX("DFLG"))=1 K DIR,DUOUT,DIRUT W @IOF
Q
;
OVRD ; Override Reason
N Z,ZI,ZX,ZOV,ZORN,X,PSOPRET,PSOOVRDR K ^UTILITY($J,"W") S DIWL=1,DIWR=50,(ZOV,ZORN,DIWF)=""
I '+$G(PSJORD) D G OVRDX
.I $G(PSOFOERR) D Q
..S PSOOVRDR=+$P($G(^PS(52.41,ORD,0)),"^") S:PSOOVRDR ZORN=PSOOVRDR
.I $G(PSOREINS) D Q
..I $G(ZRXN) S ZORN=$P(^PSRX(ZRXN,"OR1"),"^",2)
.I $G(PSOVER1),$G(PSONV) S PSOOVRDR=+$P($G(^PSRX(PSONV,"OR1")),"^",2) S:PSOOVRDR ZORN=PSOOVRDR
;
I '$G(PSJINFIN) G OVRDX
I PSJORD["P" S ZORN=+$P($G(^PS(53.1,+PSJORD,0)),U,21) G OVRDX
I PSJORD["U" S ZORN=+$P($G(^PS(55,DFN,5,+PSJORD,0)),U,21) G OVRDX
I PSJORD["V" S ZORN=+$P($G(^PS(55,DFN,"IV",+PSJORD,0)),U,21)
OVRDX ;
G:'$G(ZORN) NF
D GETOC4^OROCAPI1(ZORN,.PSOPRET)
F ZI=0:0 S ZI=$O(PSOPRET(ZORN,"DATA",ZI)) Q:'ZI I $P($P(PSOPRET(ZORN,"DATA",ZI,1),"^"),";",2)=3,$G(PSOPRET(ZORN,"DATA",ZI,"OR",1,0))]"" S ZOV=$G(PSOPRET(ZORN,"DATA",ZI,"OR",1,0))
S ^TMP("PSODAOC",$J,"ALLERGY","PROVR")=ZOV
NF ;
I '$G(PSODGCK)&('$G(PSJDGCK)) D
.W !?3,"Provider Override Reason: " S X=$S($G(ZOV)]"":ZOV,1:"N/A - Order Check Not Evaluated by Provider") D ^DIWP
.F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX W ?29,^UTILITY($J,"W",1,ZX,0),!
.K ^UTILITY($J,"W"),DIWL,DIWR,DIWF,ZORN,RET
; pso*7*401
I $D(PSOMDC) D
.W !,"Warning: The following drug class does not exist in the VA DRUG CLASS"
.W !,"file (#50.605). Please do a manual Drug-Allergy order check and notify"
.W !,"the pharmacy ADPAC for follow up.",!
.S PSOMDC="" F S PSOMDC=$O(PSOMDC(PSOMDC)) Q:PSOMDC="" W !,"VA Drug Class: "_PSOMDC,!
.W ! S DIR("A")="Press Return to continue",DIR(0)="E",DIR("?")="Press Return to continue"
.D ^DIR K DIR W !
Q
SYM1 ;format signs/symptoms
N PSOSYMX,QX,ZSYM
K ^UTILITY($J,"W"),X S DIWL=1,DIWR=55,DIWF=""
S (ZSYM,PSOSYMX)="",QX=0
F S ZSYM=$O(PSOSYMS(PSOSEV,PSOCA,PSOATYPE,"ZZZSYMPTOMS",ZSYM)) Q:ZSYM="" S QX=QX+1,PSOSYMX=PSOSYMX_", "_$P(ZSYM,";",1)
S PSOSYMX=$E(PSOSYMX,3,999),X=PSOSYMX D ^DIWP
W ?4," Signs/Symptoms: "
N ZNODE F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX D
.S ZNODE="",ZNODE=^UTILITY($J,"W",1,ZX,0)
.I $E(ZNODE,1,2)=", " S ZNODE=$E(ZNODE,3,999)
.W ?22,ZNODE,!
K ^UTILITY($J,"W"),DIWL,DIWR,DIWF,I,ZX
Q
;
CRI ;input electronic sig
N X1 D SIG^XUSESIG I X1="" D Q
.K PSORX("INTERVENE"),DIR
.I $G(PSJAOC) S PSGORQF=1
.E S PSORX("DFLG")=1,VALMBCK="R"
.S:$D(PSORENW) PSORENW("DFLG")=1
.W !!,"With a SEVERE reaction, an Electronic Signature is required!",!
.I $G(PSGCOPY)=1!($G(PSIVCOPY)=1) W !,"Order not copied!",!
.I $G(PSJREN)=1 W !,"No changes made to this order!",!
.S DIR("A")="Press Return to continue",DIR(0)="E",DIR("?")="Press Return to continue" D ^DIR K DIR W !
S PSORX("INTERVENE")=1
Q
DIR ;
S DIR("A")="Press Return to continue",DIR(0)="E",DIR("?")="Press Return to continue"
D ^DIR K DIR W !
Q
;
UTIL ;
N ZNODE F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX D
.S ZNODE="",ZNODE=^UTILITY($J,"W",1,ZX,0)
.I $E(ZNODE,1,2)=", " S ZNODE=$E(ZNODE,3,999)
.W ?22,ZNODE,!
K ^UTILITY($J,"W"),DIWL,DIWR,DIWF,I,ZX
Q
;
GMSGPTR(MSG,NODE) ; retrieve second level pointer from new allergy array
N RESULT
S RESULT=$O(GMRARSLT(MSG,$G(NODE)))
Q:+RESULT>0 RESULT
S:RESULT="MESSAGE" RESULT=$O(GMRARSLT(MSG,RESULT))
Q:$E(RESULT,1)="R" RESULT
S RESULT=""
Q RESULT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODGAL1 12369 printed Oct 16, 2024@18:27:31 Page 2
PSODGAL1 ;BIR/LC,SAB - enhanced DRUG ALLERGY REACTION CHECKING ;12/09/07 02:22
+1 ;;7.0;OUTPATIENT PHARMACY;**251,401,390,424,429,411,500**;DEC 1997;Build 9
+2 ;External reference to $$ORCHK2^GMRAOR supported by DBIA 2378
+3 ;External reference to ^PS(50.605 supported by DBIA 696
+4 ;External reference to ^XUSEC("PSORPH" supported by DBIA 10076
+5 ;External reference to GETOC4^OROCAPI1 supported by DBIA 5729
+6 ;External reference to ^PS(55 supported by DBIA 2228
+7 ;External reference to ^PS(53.1 supported by DBIA 5793
+8 ;External reference to ^PSJRXI supported by DBIA 6076
+9 ;External reference to SIG^XUSESIG supported by DBIA 10050
+10 ;External reference to $$FINDC^PSJDGAL2 supportedby DBIA 6140
+11 ;
EN ; Called from both inpatient and outpatient pharmacy
+1 NEW PSOACK,DFN,PSODAL,RXN,LPTR,PSOSEVT,PSOSEVT1,NDF,PSOSYMS,PSOINGRE,PSOSORT,PSOGIEN,PSODGCL,PSODGCL1,I,II,PSOADA,PSOADAT,PSOASEV,PSOASITE,PSODRCL1,PSODRCL
+2 NEW PSOINGR,PSOGMRA,PSOGMRA2,PSOIADAT,PSOLCLAS,PSOLOC,PSOOINGR,PSOSEV,PSOSNAM,PTR,TYP,ZPOP,ZPOP2,ZSITE,ZZSITE,PSOCAGNT,PSORXORD
+3 KILL ^TMP($JOB,"PSODRCLS"),DSPLQ,PSOMDC,ZGMRA,GMRAING,GMRADRCL,GMRAREAC,PSOALGYF,PSOASORT,GMRARSLT
+4 SET DFN=PSODFN
+5 SET (NDF,TYP,PTR,PSOALGYF)=""
+6 IF $DATA(PSODRUG("NDF"))
IF PSODRUG("NDF")'=0
SET NDF=$PIECE(PSODRUG("NDF"),"A")
SET TYP=$PIECE(PSODRUG("NDF"),"A",2)
SET PTR=$SELECT(NDF=0:"",1:NDF)_"."_TYP
+7 SET $PIECE(PTR,".",3)=PSODRUG("IEN")
+8 ;
CHK ;matched to ndf
+1 ;counter for inpatient; OP will always be 1
if '$GET(PSJALGCT)
SET PSJALGCT=1
+2 KILL ZMED,ZMEDLCL
SET PSOACK=$$ORCHK2^GMRAOR(DFN,"DR",PTR,"","GMRARSLT")
if +$GET(PSOACK)>0
Begin DoDot:1
+3 DO DSPLY
if $GET(PSORX("DFLG"))!($GET(PSGORQF))
QUIT
+4 if $DATA(^XUSEC("PSORPH",DUZ))!($GET(PSODGCK))
QUIT
+5 IF +$GET(PSOACK)=1
Begin DoDot:2
+6 NEW ZMSG,ZLOCAL,ZINGREDS,ZI,ZINGRED
+7 SET ^TMP("PSODAI",$JOB,0)=1
SET (PSOSEV,PSOLOC,PSODRG)=""
+8 SET ZMSG=""
FOR
SET ZMSG=$ORDER(GMRARSLT(ZMSG))
if 'ZMSG
QUIT
Begin DoDot:3
+9 SET PSOGIEN=$$GMSGPTR(ZMSG)
+10 if PSOGIEN=""
QUIT
+11 SET ZLOCAL=$SELECT($PIECE(GMRARSLT(ZMSG,PSOGIEN),U,2)="L":" (local)",1:" (remote)")
+12 SET ZINGREDS=$GET(GMRARSLT(ZMSG,"MESSAGE","OFFENDERS","ING"))
+13 if ZINGREDS=""
QUIT
+14 if $EXTRACT(ZINGREDS,1)="~"
SET ZINGREDS=$EXTRACT(ZINGREDS,2,9999)
+15 FOR ZI=1:1:$LENGTH(ZINGREDS,"~")
SET ZINGRED=$PIECE(ZINGREDS,"~",ZI)
if ZINGRED=""
QUIT
Begin DoDot:4
+16 SET ^TMP("PSODAI",$JOB,ZI,0)=ZINGRED_ZLOCAL
+17 QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+18 if $GET(PSORX("DFLG"))!($GET(PSGORQF))
QUIT
+19 SET NDF=$PIECE(PSODRUG("NDF"),"A")
+20 IF +$GET(PSOACK)>0!$GET(^TMP($JOB,"PSODRCLS",0))
Begin DoDot:1
+21 IF '$DATA(^XUSEC("PSORPH",DUZ))
IF '$DATA(PSOMDC)
KILL DIR
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR,DUOUT,DIRUT
QUIT
+22 IF $DATA(PSJDGCK)!$DATA(PSODGCK)
KILL DIR
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR,DUOUT,DIRUT
WRITE @IOF
QUIT
+23 SET DIR("?",1)="Answer 'YES' if you DO want to enter a intervention for this medication,"
SET DIR("?")=" 'NO' if you DON'T want to enter a intervention for this medication,"
+24 SET DIR(0)="SA^1:YES;0:NO"
SET DIR("A")="Do you want to Intervene? "
SET DIR("B")="YES"
DO ^DIR
IF '$GET(PSJAOC)
WRITE !
+25 IF ($DATA(DTOUT))!($DATA(DUOUT))
if '$GET(PSJAOC)
SET (PSODLQT,PSORX("DFLG"))=1
if $GET(PSJAOC)
SET PSGORQF=1
QUIT
+26 IF 'Y
if $GET(PSOSEVT1("S"))=1
Begin DoDot:2
+27 if $GET(PSJAOC)
SET PSGORQF=1
+28 if '$GET(PSJAOC)
SET (PSORX("DFLG"),PSOQUIT)=1
+29 WRITE !!,"With a SEVERE reaction, an intervention is required!",!
SET VALMBCK="R"
+30 ;set flag if COPY to not repeat this message in PSGOD
IF $GET(PSGCOPY)=1!($GET(PSIVCOPY)=1)
WRITE !,"Order not copied!",!
SET PSJCOFLG=1
+31 ;set flag if RENEW to not repeat this message in PSGOEE
IF $GET(PSJREN)=1
WRITE !,"No changes made to this order!",!
SET PSJRNFLG=1
+32 IF '$GET(PSOSPRNW)
KILL DIR
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
SET DIR("A")="Press Return to continue"
DO ^DIR
+33 if $GET(PSOSPRNW)
SET PSORENW("DFLG")=1
SET PSORX("DFLG")=0
SET PSOQUIT=1
+34 IF $DATA(DTOUT)!($DATA(DUOUT))
Begin DoDot:3
+35 ;inpatient
IF $GET(PSJAOC)
SET PSGORQF=1
QUIT
+36 SET (PSODLQT,PSOQUIT,PSORX("DFLG"))=1
End DoDot:3
KILL DIR,DUOUT,DIRUT
WRITE !
End DoDot:2
QUIT
+37 if $GET(PSOSEVT1("S"))=1
DO CRI
+38 if $GET(PSORX("DFLG"))!($GET(PSGORQF))
QUIT
+39 IF $GET(PSJAOC)
SET PSJDAL=1
DO ^PSJRXI
IF $GET(PSJDAL("DA"))
SET $PIECE(^TMP("PSODAOC",$JOB,"ALLERGY",PSJALGCT,"INTERVENTION"),"^")=PSJDAL("DA")
KILL PSJDAL("DA")
+40 IF '$GET(PSJAOC)
SET PSODAL=1
DO ^PSORXI
IF $GET(PSODAL("DA"))
SET $PIECE(^TMP("PSODAOC",$JOB,"ALLERGY",PSJALGCT,"INTERVENTION"),"^")=PSODAL("DA")
KILL PSODAL("DA")
+41 KILL PSJRXI("DA"),PSODAL("DA")
End DoDot:1
EX KILL DIR,DTOUT,DIRUT,DIROUT,DUOUT,Y,DSPLQ,PSOMDC,AGNL,SEV,SEV,ZGMRA,LPTR,ALTOT
+1 KILL PSOACK,GMRAING,GMRADRCL,GMRAREAC,GMRARSLT,I,APTR,GMRA,LP,^TMP($JOB,"PSODRCLS"),ZCLA,ZCNT,ZINSTL,ZSAT
+2 IF $DATA(PSJDGCK)!$DATA(PSODGCK)!$GET(PSORX("DFLG"))!$GET(PSGORQF)
KILL ^TMP("PSODAOC",$JOB)
+3 IF '$GET(PSJAOC)
KILL PSGORQF
+4 QUIT
+5 ;
DSPLY ;
+1 KILL PSOSYMS,PSOCAGNT
+2 DO SORTN^PSODGAL3
DO FULL^VALM1
+3 KILL AGNL,SEV,SEVN,PSOHIS
NEW INGLOC,ZINGLOC,ZMEDL,DACNT,DACNT2,ZSTA,ZDATE
+4 NEW ZZING,ZZLOC,ZZALL,PSOACNT,PSOLOCAL,PSOPTR,PSOSITT,PSOCA,ZLOC,PSOATYPE
SET (ALTOT,DACNT,DACNT2,ZLOC,ZCLA,PSOACNT,PSOATYPE)=0
SET ZMEDL=""
+5 SET (ZZLOC,PSOCA,ZZALL,ZZING,PSOSEV,PSOINGR,PSOASITE,PSOIADAT,PSOGIEN,PSOADA)=""
+6 FOR
SET PSOSEV=$ORDER(PSOCAGNT(PSOSEV))
if PSOSEV=""
QUIT
FOR
SET PSOCA=$ORDER(PSOCAGNT(PSOSEV,PSOCA))
if PSOCA=""
QUIT
FOR
SET PSOATYPE=$ORDER(PSOCAGNT(PSOSEV,PSOCA,PSOATYPE))
if PSOATYPE=""
QUIT
SET ALTOT=ALTOT+1
+7 FOR
SET PSOSEV=$ORDER(PSOCAGNT(PSOSEV))
if PSOSEV=""!($GET(PSORX("DFLG")))!($GET(PSGORQF))
QUIT
FOR
SET PSOCA=$ORDER(PSOCAGNT(PSOSEV,PSOCA))
if PSOCA=""!($GET(PSORX("DFLG")))!($GET(PSGORQF))
QUIT
Begin DoDot:1
+8 FOR
SET PSOATYPE=$ORDER(PSOCAGNT(PSOSEV,PSOCA,PSOATYPE))
if PSOATYPE=""!($GET(PSORX("DFLG")))!($GET(PSGORQF))
QUIT
Begin DoDot:2
+9 SET PSOGMRA2=""
+10 SET PSOGMRA2=PSOCAGNT(PSOSEV,PSOCA,PSOATYPE)
+11 SET (PSOPTR,ZZALL,PSODRCL)=""
+12 SET PSOPTR=$PIECE($PIECE(PSOGMRA2,"^",1),"|")
+13 SET PSOSITT=$PIECE($PIECE(PSOGMRA2,"^",1),"|",4)
+14 SET ZZALL=$$GMSGPTR(PSOPTR)
+15 if ZZALL=""
QUIT
+16 DO DSPLY1
End DoDot:2
End DoDot:1
+17 QUIT
DSPLY1 ;
+1 ; 1 2 3 4 5 6 7 8 9 10
+2 NEW ZINDATE,ZSIGN,PSOINSTL,PSOSTA,PSOHIS,PSOSTYP,PSOMEDL,PSOLOCAL,PSODATA,PSOWCA,PSOCAR,PSOSTYPI,PSOLOCI,PSOMEDLI,PSOHISI,PSOSEVI,DRCLIEN,DRCLIENE,PSODCLAS,ZALL,ZMSG
+3 SET PSOHISI=$PIECE(GMRARSLT(PSOPTR,ZZALL),U,8)
+4 SET PSOHIS=$SELECT(PSOHISI="o":"OBSERVED",1:"HISTORICAL")
+5 SET PSOASEV=$$GETSEV^PSODGAL3(PSOSITT,PSOPTR,.GMRARSLT)
+6 SET PSOSEVT=PSOSEV
+7 SET DACNT=DACNT+1
+8 SET DACNT2=DACNT2+1
+9 if PSOSEV=1
SET PSOSEVT1("S")=1
+10 WRITE $CHAR(7),!!,"A Drug-Allergy Reaction exists for this medication and/or class!",!
+11 WRITE !,$SELECT($GET(PSODGCKF)!($GET(PSJDGFLG)):" Profile Drug: ",1:" Prospective Drug: ")
+12 ;
+13 SET PSORXORD=""
+14 NEW PSJCPROS,PSJNCOM,PROSPECT
SET (PSJCPROS,PSJNCOM,PROPSECT)=""
+15 IF $GET(PSJAOC)
Begin DoDot:1
+16 SET PSORXORD=$SELECT($GET(PSJORD):PSJORD,$GET(ON55):ON55,$GET(ON):ON,$GET(PSJNORD):PSJNORD,1:"")
+17 IF '$GET(PSORXORD)
SET PSORXORD=$GET(PSGORD)
+18 ;for complex UD orders display format: orderable item doseform (units) ex: MORPHINE TAB,SA (100MG)
+19 IF $GET(PSJCOM)
SET PSJNCOM=$$FINDC^PSJDGAL2($GET(PSORXORD))
SET PSJCPROS=$PIECE(PSJNCOM,"^",2)
+20 IF '$GET(PSJDGCK)&('$GET(PSODGCK))
WRITE $SELECT($GET(PSORXORD)["V":PSODRUG("OIN"),$GET(PSORXORD)["P"&($DATA(^PS(53.1,+$GET(PSORXORD),"AD"))):PSODRUG("OIN"),$GET(PSJCOM):PSJCPROS,1:PSODRUG("NAME"))
+21 IF $GET(PSJDGCK)!($GET(PSODGCK))
WRITE PSODRUG("NAME")
End DoDot:1
+22 IF '$TEST
WRITE PSODRUG("NAME")
+23 ;
+24 WRITE !," Causative Agent: "
+25 SET (PSOWCA,PSOCAR)=""
SET PSOALGYF=1
+26 IF PSOCA["/"
Begin DoDot:1
+27 FOR I=1:1
SET PSOWCA=$PIECE(PSOCA,"/",I)
if PSOWCA=""
QUIT
SET PSOCAR=PSOCAR_"/ "_PSOWCA
End DoDot:1
SET PSOCAR=$EXTRACT(PSOCAR,3,$LENGTH(PSOCAR))
+28 IF PSOCAR=""
SET PSOCAR=PSOCA
+29 ;
+30 KILL ^UTILITY($JOB,"W"),X
SET DIWL=1
SET DIWR=55
SET (X,DIWF)=""
+31 NEW CAUSAGNT
SET (X,PSODCLAS,CAUSAGNT,ZSITE)=""
SET CAUSAGNT=PSOCAGNT(PSOSEV,PSOCA,PSOATYPE)
+32 ;
SITE ;
+1 SET X=""
+2 FOR II=1:1
SET ZSITE=$PIECE(CAUSAGNT,"^",II)
if ZSITE=""
QUIT
Begin DoDot:1
+3 SET (ZDATE,PSOSNAM,ZZSITE,PSOLOCAL)=""
+4 SET ZZSITE=$PIECE(ZSITE,"|",4)
SET ZDATE=$PIECE(ZSITE,"|",2)
SET PSOLOCAL=$PIECE(ZSITE,"|",3)
SET ZMSG=$PIECE(ZSITE,"|")
+5 SET PSOSNAM=$PIECE(GMRARSLT(ZMSG,"MESSAGE",1,ZZSITE),U)
+6 ;;S PSOSNAM=$$GET1^DIQ(4,ZZSITE,.01)
+7 SET X=X_", "_PSOSNAM_" - "_$PIECE(ZDATE,"@")
End DoDot:1
+8 SET X=$SELECT(X'="":PSOCAR_" ("_$EXTRACT(X,3,9999)_")",1:PSOCAR)
+9 DO ^DIWP
DO UTIL
+10 ;
+11 WRITE " Historical/Observed: "_$PIECE(PSOHIS,";")
+12 WRITE !," Severity: "_$SELECT(PSOASEV="":"Not Entered",1:PSOASEV)
+13 SET (PSOOINGR,ZPOP)=""
NEW Z,ZI,ZX,ZOV,PSOWINGR,PSOWIN,REMSITE,REMTMP
+14 SET DIWL=1
SET DIWR=55
SET (X,DIWF)=""
+15 FOR
SET PSOINGR=$ORDER(PSOCAGNT(PSOSEV,PSOCA,PSOATYPE,PSOINGR))
if PSOINGR=""!(PSOINGR="ZZZSYMPTOMS")
QUIT
Begin DoDot:1
+16 IF '$GET(ZPOP)
SET ZPOP=1
WRITE !?7," Ingredients: "
+17 SET X=X_", "_PSOINGR
End DoDot:1
+18 DO ^DIWP
DO UTIL
+19 KILL ^UTILITY($JOB,"W"),DIWL,DIWR,DIWF,I,ZX,X,^TMP("PSN",$JOB),PSNDA,PSNID
+20 IF $PIECE(GMRARSLT(PSOPTR,"MESSAGE",2),U)]""
DO SYM1
SET ZSIGN=1
+21 IF '$GET(ZSIGN)
WRITE ?3," Signs/Symptoms: None Entered",!
+22 SET PSOLOCAL=""
SET PSOLOCAL=$PIECE($PIECE(ZZALL,"^",3),"|",2)
+23 ;
DRCL ;PSODRCL1(99,"AMPICILLIN/SULBACTAM","PENICILLINS,AMINO DERIVATIVES")=1
+1 IF $DATA(PSODRCL1(PSOSEV,PSOCA,PSOATYPE))
Begin DoDot:1
+2 WRITE ?8," Drug Class: "
+3 NEW III,XX,X
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=55
SET (X,XX,DIWF)=""
+4 FOR
SET XX=$ORDER(PSODRCL1(PSOSEV,PSOCA,PSOATYPE,XX))
if XX=""
QUIT
Begin DoDot:2
+5 SET DRCLIEN=PSODRCL1(PSOSEV,PSOCA,PSOATYPE,XX)
SET DRCLIENE=$$GET1^DIQ(50.605,DRCLIEN,.01,"E")
+6 SET X=X_", "_$SELECT(DRCLIENE'="":DRCLIENE_" ",1:"")_XX
End DoDot:2
+7 SET X=$EXTRACT(X,3,999)
DO ^DIWP
+8 DO UTIL
End DoDot:1
+9 ;Override Reason
DO OVRD
+10 SET PSOACNT=PSOACNT+1
+11 IF ALTOT>PSOACNT
KILL DIR
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
SET DIR("A")="Press Return to continue"
DO ^DIR
+12 IF $DATA(DTOUT)!($DATA(DUOUT))
if $GET(PSJAOC)
SET PSGORQF=1
if '$GET(PSJAOC)
SET (PSODLQT,PSORX("DFLG"))=1
KILL DIR,DUOUT,DIRUT
WRITE @IOF
+13 QUIT
+14 ;
OVRD ; Override Reason
+1 NEW Z,ZI,ZX,ZOV,ZORN,X,PSOPRET,PSOOVRDR
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=50
SET (ZOV,ZORN,DIWF)=""
+2 IF '+$GET(PSJORD)
Begin DoDot:1
+3 IF $GET(PSOFOERR)
Begin DoDot:2
+4 SET PSOOVRDR=+$PIECE($GET(^PS(52.41,ORD,0)),"^")
if PSOOVRDR
SET ZORN=PSOOVRDR
End DoDot:2
QUIT
+5 IF $GET(PSOREINS)
Begin DoDot:2
+6 IF $GET(ZRXN)
SET ZORN=$PIECE(^PSRX(ZRXN,"OR1"),"^",2)
End DoDot:2
QUIT
+7 IF $GET(PSOVER1)
IF $GET(PSONV)
SET PSOOVRDR=+$PIECE($GET(^PSRX(PSONV,"OR1")),"^",2)
if PSOOVRDR
SET ZORN=PSOOVRDR
End DoDot:1
GOTO OVRDX
+8 ;
+9 IF '$GET(PSJINFIN)
GOTO OVRDX
+10 IF PSJORD["P"
SET ZORN=+$PIECE($GET(^PS(53.1,+PSJORD,0)),U,21)
GOTO OVRDX
+11 IF PSJORD["U"
SET ZORN=+$PIECE($GET(^PS(55,DFN,5,+PSJORD,0)),U,21)
GOTO OVRDX
+12 IF PSJORD["V"
SET ZORN=+$PIECE($GET(^PS(55,DFN,"IV",+PSJORD,0)),U,21)
OVRDX ;
+1 if '$GET(ZORN)
GOTO NF
+2 DO GETOC4^OROCAPI1(ZORN,.PSOPRET)
+3 FOR ZI=0:0
SET ZI=$ORDER(PSOPRET(ZORN,"DATA",ZI))
if 'ZI
QUIT
IF $PIECE($PIECE(PSOPRET(ZORN,"DATA",ZI,1),"^"),";",2)=3
IF $GET(PSOPRET(ZORN,"DATA",ZI,"OR",1,0))]""
SET ZOV=$GET(PSOPRET(ZORN,"DATA",ZI,"OR",1,0))
+4 SET ^TMP("PSODAOC",$JOB,"ALLERGY","PROVR")=ZOV
NF ;
+1 IF '$GET(PSODGCK)&('$GET(PSJDGCK))
Begin DoDot:1
+2 WRITE !?3,"Provider Override Reason: "
SET X=$SELECT($GET(ZOV)]"":ZOV,1:"N/A - Order Check Not Evaluated by Provider")
DO ^DIWP
+3 FOR ZX=0:0
SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
if 'ZX
QUIT
WRITE ?29,^UTILITY($JOB,"W",1,ZX,0),!
+4 KILL ^UTILITY($JOB,"W"),DIWL,DIWR,DIWF,ZORN,RET
End DoDot:1
+5 ; pso*7*401
+6 IF $DATA(PSOMDC)
Begin DoDot:1
+7 WRITE !,"Warning: The following drug class does not exist in the VA DRUG CLASS"
+8 WRITE !,"file (#50.605). Please do a manual Drug-Allergy order check and notify"
+9 WRITE !,"the pharmacy ADPAC for follow up.",!
+10 SET PSOMDC=""
FOR
SET PSOMDC=$ORDER(PSOMDC(PSOMDC))
if PSOMDC=""
QUIT
WRITE !,"VA Drug Class: "_PSOMDC,!
+11 WRITE !
SET DIR("A")="Press Return to continue"
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
+12 DO ^DIR
KILL DIR
WRITE !
End DoDot:1
+13 QUIT
SYM1 ;format signs/symptoms
+1 NEW PSOSYMX,QX,ZSYM
+2 KILL ^UTILITY($JOB,"W"),X
SET DIWL=1
SET DIWR=55
SET DIWF=""
+3 SET (ZSYM,PSOSYMX)=""
SET QX=0
+4 FOR
SET ZSYM=$ORDER(PSOSYMS(PSOSEV,PSOCA,PSOATYPE,"ZZZSYMPTOMS",ZSYM))
if ZSYM=""
QUIT
SET QX=QX+1
SET PSOSYMX=PSOSYMX_", "_$PIECE(ZSYM,";",1)
+5 SET PSOSYMX=$EXTRACT(PSOSYMX,3,999)
SET X=PSOSYMX
DO ^DIWP
+6 WRITE ?4," Signs/Symptoms: "
+7 NEW ZNODE
FOR ZX=0:0
SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
if 'ZX
QUIT
Begin DoDot:1
+8 SET ZNODE=""
SET ZNODE=^UTILITY($JOB,"W",1,ZX,0)
+9 IF $EXTRACT(ZNODE,1,2)=", "
SET ZNODE=$EXTRACT(ZNODE,3,999)
+10 WRITE ?22,ZNODE,!
End DoDot:1
+11 KILL ^UTILITY($JOB,"W"),DIWL,DIWR,DIWF,I,ZX
+12 QUIT
+13 ;
CRI ;input electronic sig
+1 NEW X1
DO SIG^XUSESIG
IF X1=""
Begin DoDot:1
+2 KILL PSORX("INTERVENE"),DIR
+3 IF $GET(PSJAOC)
SET PSGORQF=1
+4 IF '$TEST
SET PSORX("DFLG")=1
SET VALMBCK="R"
+5 if $DATA(PSORENW)
SET PSORENW("DFLG")=1
+6 WRITE !!,"With a SEVERE reaction, an Electronic Signature is required!",!
+7 IF $GET(PSGCOPY)=1!($GET(PSIVCOPY)=1)
WRITE !,"Order not copied!",!
+8 IF $GET(PSJREN)=1
WRITE !,"No changes made to this order!",!
+9 SET DIR("A")="Press Return to continue"
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
DO ^DIR
KILL DIR
WRITE !
End DoDot:1
QUIT
+10 SET PSORX("INTERVENE")=1
+11 QUIT
DIR ;
+1 SET DIR("A")="Press Return to continue"
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
+2 DO ^DIR
KILL DIR
WRITE !
+3 QUIT
+4 ;
UTIL ;
+1 NEW ZNODE
FOR ZX=0:0
SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
if 'ZX
QUIT
Begin DoDot:1
+2 SET ZNODE=""
SET ZNODE=^UTILITY($JOB,"W",1,ZX,0)
+3 IF $EXTRACT(ZNODE,1,2)=", "
SET ZNODE=$EXTRACT(ZNODE,3,999)
+4 WRITE ?22,ZNODE,!
End DoDot:1
+5 KILL ^UTILITY($JOB,"W"),DIWL,DIWR,DIWF,I,ZX
+6 QUIT
+7 ;
GMSGPTR(MSG,NODE) ; retrieve second level pointer from new allergy array
+1 NEW RESULT
+2 SET RESULT=$ORDER(GMRARSLT(MSG,$GET(NODE)))
+3 if +RESULT>0
QUIT RESULT
+4 if RESULT="MESSAGE"
SET RESULT=$ORDER(GMRARSLT(MSG,RESULT))
+5 if $EXTRACT(RESULT,1)="R"
QUIT RESULT
+6 SET RESULT=""
+7 QUIT RESULT
+8 ;
