PSGSICHK ;BIR/CML3-CHECKS SPECIAL INSTRUCTIONS ;19-Oct-2017 12:55;PT
;;5.0; INPATIENT MEDICATIONS ;**3,9,26,29,44,49,59,1013,110,139,146,160,175,201,185,1015,1022**;16 DEC 97;Build 20
;
; Reference to ^PS(50.605 is supported by DBIA 696.
; Reference to EN^PSOORDRG is supported by DBIA 2190.
; Reference to ^PSI(58.1 is supported by DBIA 2284.
; Reference to ^PSDRUG( is supported by DBIA 2192.
; Reference to ^PSD(58.8 is supported by DBIA 2283.
; Reference to ^PS(55 is supported by DBIA 2191.
; Reference to ^PS(51.2 is supported by DBIA 2178.
; Reference to ^PS(51 is supported by DBIA 2176.
; Reference to ^ORRDI1 is supported by DBIA 4659.
; Reference to ^XTMP("ORRDI" is supported by DBIA 4660.
; Reference to GETDATA^GMRAOR supported by DBIA 4847.
; Reference to ^TMP("GMRAOC" supported by DBIA 4848.
;Modified - IHS/MSC/MGH - 02/08/2012 - Line ENDL+2
;Modified - IHS/MSC/MGH - 04/06/2012 - IVSOL+5,ALGCLASS+13,ALGC2+19,CLASSDSP+5
; for adding reactions patch 1014
;Modified - IHS/MSC/MGH - 12/21/2012 - IVSOL+5,IVSOL+7 patch 1015
START ;
I $S(X'?.ANP:1,X["^":1,1:$L(X)>180) K X Q
S Y="" F Y(1)=1:1:$L(X," ") S Y(2)=$P(X," ",Y(1)) I Y(2)]"" D CHK Q:'$D(X)
I $D(X),Y]"",X'=$E(Y,1,$L(Y)-1) D EN^DDIOL("EXPANDS TO: ") W Y F Y(1)=1:1 S Y(2)=$P(Y," ",Y(1)) Q:Y(2)="" D:$L(Y(2))+$X>78 EN^DDIOL(Y(2)_" ")
Q
;
CHK ;
I $L(Y(2))<31,$D(^PS(51,+$O(^PS(51,"B",Y(2),0)),0)),$P(^(0),"^",2)]"",$P(^(0),"^",4) S Y(2)=$P(^(0),"^",2)
I $L(Y)+$L(Y(2))>180 K X Q
S Y=Y_Y(2)_" " Q
;
ENSET(X) ; expands the SPECIAL INSTRUCTIONS field contained in X into Y
N X1,X2,Y S Y=""
;BHW;PSJ*5*185;Modified Logic below to NOT strip spaces and allow existing logic to flow.
; ;Removed code I X2]"" Before Set of Y and created argumentless DO structure.
F X1=1:1:$L(X," ") S X2=$P(X," ",X1) D
. I X2']"" S Y=Y_" " Q ;if multiple spaces in text and were $P'ing through text, X2 will="" so just add space and continue
. S Y=Y_$S($L(X2)>30:X2,'$D(^PS(51,+$O(^PS(51,"B",X2,0)),0)):X2,$P(^(0),"^",2)]""&$P(^(0),"^",4):$P(^(0),"^",2),1:X2)_" "
. Q
;BHW;Modified stripping of spaces at end of string
F X1=$L(Y):-1:0 Q:$E(Y,X1,X1)'=" " S Y=$E(Y,1,X1-1)
Q Y
;
END ; used by DRUG (55.06,101 & 53.1,101) x-refs to warn user if patient is receiving or about to receive the drug just ordered
Q:$D(PSJHLSKP)
N Z,ZZ,STATUSNP I $G(PSJPWD)&($P($G(PSJSYSU),";")=3)&($G(PSGDRG)) I ($D(^PSI(58.1,"D",PSGDRG,PSJPWD)))!($D(^PSD(58.8,"D",PSGDRG,PSJPWD))) D EN^DDIOL(" *** A WARD STOCK ITEM ***")
D NOW^%DTC
N PSJDCHK F Z=%:0 S Z=$O(^PS(55,+PSGP,5,"AUS",Z)) Q:'Z!$D(DUOUT) F ZZ=0:0 S ZZ=$O(^PS(55,+PSGP,5,"AUS",Z,ZZ)) Q:'ZZ!$D(DUOUT) I +$G(^PS(55,+PSGP,5,ZZ,.2))=PSGX D PDWCHK(+PSGP,ZZ_"U") S PSJDCHK=1
F STATUSNP="N","P" F Z=0:0 S Z=$O(^PS(53.1,"AS",STATUSNP,+PSGP,Z)) Q:'Z!$D(DUOUT) I +$G(^PS(53.1,+Z,.2))=PSGX D PDWCHK(+PSGP,Z_"P") S PSJDCHK=1
I $D(PSJDCHK) N DIR D
.S DIR(0)="Y",DIR("A")="Do you wish to continue entering this order",DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order,"
.S DIR("?")="or ""Y"" to continue with the order entry process." D ^DIR S:'Y Y=-1,X="^"
K Z,ZZ
Q
;
ENDDC(PSGP,PSJDD) ; Perform Duplicate Drug, Duplicate Class,
; Drug-Drug interaction check, Drug-Allergy interaction check.
N PSJLINE,Z,ZZ,PSJFST
S (PSJLINE,PSJFST)=0
I $G(PSJPWD)&($P($G(PSJSYSU),";")=3)&($G(PSJDD)) I ($D(^PSI(58.1,"D",PSJDD,PSJPWD)))!($D(^PSD(58.8,"D",PSJDD,PSJPWD))) W !?25,"*** A WARD STOCK ITEM ***"
D EN^PSOORDRG(PSGP,PSJDD) K PSJPDRG N INTERVEN,PSJIREQ,PSJRXREQ S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)="" S DFN=PSGP
I $T(HAVEHDR^ORRDI1)]"",$$HAVEHDR^ORRDI1,'$D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) D
. I $P($G(^XTMP("ORRDI","PSOO",PSGP,0)),"^",3)<0 W !,"Remote data not available - Only local order checks processed." D PAUSE^PSJLMUT1
I $D(^TMP($J,"DD")) D ORDCHK^PSJLMUT1(PSGP,"DD",4)
I $D(^TMP($J,"DC")) D ORDCHK^PSJLMUT1(PSGP,"DC",6)
IVSOL ;*** Start order check for IV solution at this point.
I '$D(PSJFST) N PSJFST S PSJFST=0
I $D(^TMP($J,"DI")) S INTERVEN=1 D ORDCHK^PSJLMUT1(PSGP,"DI",8)
;*** Allergy/adverse reaction check.
N PTR,X,CMP,CMPDR,CDRG
S CMP=$P($G(^PSDRUG(PSJDD,999999935)),U,1) ;IHS/MSC/MGH check for compound
S PTR=$P($G(^PSDRUG(PSJDD,"ND")),U)_"."_$P($G(^PSDRUG(PSJDD,"ND")),U,3)
I +CMP=0 D ALGCHK(PSJDD)
;IHS/MSC/MGH Patch 1015 for compound meds
I +CMP=1 D
.S CMPDR=0
.F S CMPDR=$O(^PSDRUG(PSJDD,999999936,CMPDR)) Q:'+CMPDR D
..S CDRG=$P($G(^PSDRUG(PSJDD,999999936,CMPDR,0)),U,1)
..I CDRG'="" S PTR=$P($G(^PSDRUG(CDRG,"ND")),U)_"."_$P($G(^PSDRUG(CDRG,"ND")),U,3)
..D ALGCHK(CDRG)
..;END mod for compound meds
CONT ; Ask user if they wish to continue in spite of an order check.
Q:'$D(PSJPDRG) N DIR S DIR(0)="Y",DIR("A")="Do you wish to continue entering this order",DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order,"
S DIR("?")="or ""Y"" to continue with the order entry process.",DIR("B")="NO" D ^DIR I 'Y S PSGORQF=1,X="^",COMQUIT=1 Q
I 'INTERVEN!($P(PSJSYSU,";")'=3) Q
NEW PSJY
W:PSJIREQ !!,"This is a CRITICAL interaction, you must enter an intervention log to continue"
S DIR(0)="Y",DIR("A")="Do you wish to log an intervention",DIR("?",1)="Enter ""N"" if you do not wish to log an intervention,",DIR("?")="or ""Y"" to log an intervention." D ^DIR S PSJY=Y D:Y ^PSJRXI
I 'PSJY,PSJIREQ S PSGORQF=1,COMQUIT=1
Q
ALGCHK(PSJDD) ;CHECK FOR ALLERGIES
;IHS/MSC/MGH - 04/06/12
;K ^TMP("PSJDAI",$J) S PSJACK=$$ORCHK^GMRAOR(DFN,"DR",PTR,"",1) D:$G(PSJACK)=1
S PSJACK=0
K ^TMP("PSJDAI",$J) S PSJACK=$$ORCHK^GMRAOR(DFN,"DR",PTR,"",1) D:$G(PSJACK)=1
.S ^TMP("PSJDAI",$J,0)=1
.S I=0 F S I=$O(GMRAING(I)) Q:'I S ^TMP("PSJDAI",$J,I,0)=GMRAING(I)
I $D(^TMP("PSJDAI",$J)) S PSJPDRG=1 D
.W $C(7),!!,"A Drug-Allergy Reaction exists for this medication!",!!
.W !?7,"Drug: "_$P($G(^PSDRUG(PSJDD,0)),"^") I $O(^TMP("PSJDAI",$J)) W !,"Ingredients: " D
..S I=0 F S I=$O(^TMP("PSJDAI",$J,I)) Q:'I W:$X+$L($G(^(I,0)))+2>IOM !?19 W:I=1 $G(^TMP("PSJDAI",$J,I,0)) W:I>1 ", ",$G(^TMP("PSJDAI",$J,I,0))
.;IHS/MSC/MGH Added for reactions Patch 1014
.I $O(GMRAREAC(0)) W !,?6,"Reactions: "
.W ?19 S I=0 F S I=$O(GMRAREAC(I)) Q:'I W:$X+$L($G(GMRAREAC(I)))+2>IOM !?19 W $G(GMRAREAC(I))_", "
.W !!
;K PSJACK,GMRAING,I,^TMP($J)
K PSJACK,GMRAING,GMRAREAC,I,^TMP($J) ;IHS/MSC/MGH - 04/06/12
D ALGCLASS(PSJDD)
Q
;
ENDL ; used by PSGTRAIN DRUG LOOK-UP option
D ENCV^PSGSETU Q:$D(XQUIT)
;IHS/MSC/MGH changed for mixed case lookup, uses new cross-reference
;F S DIC="^PSDRUG(",DIC(0)="AEIMOQZ",DIC("A")="Select DRUG: " W ! D ^DIC K DIC Q:+Y'>0
F S DIC="^PSDRUG(",DIC(0)="AEIMOQZ",D="BCAP",DIC("A")="Select DRUG: " W ! D IX^DIC K DIC Q:+Y'>0 D SF
D ENKV^PSGSETU K N5,ND,Q,Y Q
;
SF ;
S Y=+Y,ND=$G(^PSDRUG(Y,0)),PSGID=+$G(^("I")) I PSGID W !!,"THIS DRUG IS INACTIVE AS OF ",$E($$ENDTC^PSGMI(PSGID),1,8)
W !!,$S($P(ND,"^",9):"NON-",1:""),"FORMULARY ITEM" W:$P(ND,"^",10)]"" !,$P(ND,"^",10)
S ND=$P($G(^PSDRUG(Y,2)),"^",3)["U" W !,$P("NOT^","^",ND+1)," A UNIT DOSE DRUG" W ! S ND=$G(^(8)),N5=$G(^(8.5)) W !?2,"DAY (nD) or DOSE (nL) LIMIT: " I ND W $P(ND,"^")
W !?10,"UNIT DOSE MED ROUTE: " I $P(ND,"^",2) W $S($D(^PS(51.2,$P(ND,"^",2),0)):$P(^(0),"^"),1:$P(ND,"^",2))
; NAKED REF below refers to ^PS(51.2, on line above.
W !?6,"UNIT DOSE SCHEDULE TYPE: " I $P(ND,"^",3)]"" W $P($P(";"_$P(^(0),"^",3),";"_$P(ND,"^",3)_":",2),";")
W !?11,"UNIT DOSE SCHEDULE: " I $P(ND,"^",4)]"" W $P(ND,"^",4)
W !,"CORRESPONDING OUTPATIENT DRUG: " I $P(ND,"^",5) W $S('$D(^PSDRUG(+$P(ND,"^",5),0)):$P(ND,"^",5),$P(^(0),"^")]"":$P(^(0),"^"),1:$P(ND,"^",5))
W !?17,"ATC MNEMONIC: " I $P(N5,"^",2)]"" W $P(N5,"^",2)
W !?17,"ATC CANISTER: " F Q=0:0 S Q=$O(^PSDRUG(Y,212,Q)) Q:'Q S ND=$G(^(Q,0)) I ND,$P(ND,"^",2) W ?31,$S('$D(^PS(57.5,+ND,0)):+ND_";PS(57.5,",$P(^(0),"^")]"":$P(^(0),"^"),1:+ND_";PS(57.5,"),?56,$P(ND,"^",2),!
Q
;
OCHK ; Add drugs in current order to ^TMP("ORDERS" and call order checker.
; Set PSJOCHK=1 so OP order check doesn't Kill array.
;
K ^TMP($J,"ORDERS")
N PSJOCHK S PSJOCHK=1
PDWCHK(DFN,ON) ; Print Dup Drug order.
N ND,ND0,ND2,X
W:'$D(PSJDCHK) $C(7),$C(7),!!,"WARNING! THIS PATIENT HAS THE FOLLOWING ORDER(S) FOR THIS MEDICATION:",!!
S ND=$$DRUGNAME^PSJLMUTL(DFN,ON)
S F=$S(ON["P":"^PS(53.1,",1:"^PS(55,"_DFN_",5,"),ND0=$G(@(F_+ON_",0)")),ND2=$G(^(2)),X=$P(ND,U,2),X=$S(X=.2:$P($G(^(.2)),U,2),1:$G(^(.3)))
W ?10,$P(ND,U),!,?13,"Give: ",X," ",$$ENMRN^PSGMI(+$P(ND0,U,3))," ",$P(ND2,U),!!
Q
ALGCLASS(PSJDD) ; checks any Drug allergies or reactions to see if
; the new drug is the same class
; this call can be removed by commenting out the call on IVSOL+16
N PSJLIST,CT,CLS,CLCHK,CNT,PSJL,LIST,DCCNT,PSCLASS,LEN
S PSCLASS=$P($G(^PSDRUG(PSJDD,0)),"^",2),LEN=4 I $E(PSCLASS,1,4)="CN10" S LEN=5 ;look at 5 chars if ANALGESICS
I $T(GETDATA^GMRAOR)]"" G ALGC2
S GMRA="0^0^111" D EN1^GMRADPT
F PSJLIST=0:0 S PSJLIST=$O(GMRAL(PSJLIST)) Q:'PSJLIST D
.K PSJAGL D EN1^GMRAOR2(PSJLIST,"PSJAGL")
.; is the allergy/reaction drug class first four digits the same as the
.; the class for the drug being entered?
.S (CT,CLS)="",DCCNT=0
.I $D(PSJAGL("V")) D
..;IHS/MSC/MGH Modified for reactions
..;F S DCCNT=$O(PSJAGL("V",DCCNT)) Q:'DCCNT S:$E($P($G(PSJAGL("V",DCCNT)),"^"),1,LEN)=$E(PSCLASS,1,LEN) (PSJPDRG,CLCHK)=1,CNT=$S('$D(CNT):1,1:CNT+1),LIST(CNT)=$P($G(PSJAGL),"^")_"^"_$P($G(PSJAGL("V",DCCNT)),"^",2)
..F S DCCNT=$O(PSJAGL("V",DCCNT)) Q:'DCCNT D
...I $E($P($G(PSJAGL("V",DCCNT)),"^"),1,LEN)=$E(PSCLASS,1,LEN) D
....S (PSJPDRG,CLCHK)=1,CNT=$S('$D(CNT):1,1:CNT+1)
....S LIST(CNT)=$P($G(PSJAGL),"^")_"^"_$P($G(PSJAGL("V",DCCNT)),"^",2)
....I $D(PSJAGL("S")) D
.....N K S K=0 S K=$O(PSJAGL("S",K)) Q:'+K D
......S LIST(CNT,"S",K)=$G(PSJAGL("S",K))
..;END MOD
D:$G(CLCHK)
.W !!,$C(7),"A Drug-Allergy Reaction exists for this medication and/or class!"
.F PSJL=0:0 S PSJL=$O(LIST(PSJL)) Q:'PSJL D
..W !?6,"Drug: "_$P(LIST(PSJL),"^"),!,"Drug Class: "_$P(LIST(PSJL),"^",2),!
..;IHS/MSC/MGH Updated for reactions Patch 1014
..N J S J=0 F S J=$O(LIST(PSJL,"S",J)) Q:J="" D
...I J=1 W !?6,"Reaction: "_$G(LIST(PSJL,"S",J))
...E W !,?19,$G(LIST(PSJL,"S",J))
Q
ALGC2 ;
K GMRADRCL
D GETDATA^GMRAOR(DFN) Q:'$D(^TMP("GMRAOC",$J,"APC"))
N GMRACL,RET
S RET=0,GMRACL="" F S GMRACL=$O(^TMP("GMRAOC",$J,"APC",GMRACL)) Q:'$L(GMRACL) D
.N GMRANM,GMRALOC
.S GMRALOC=^TMP("GMRAOC",$J,"APC",GMRACL)
.S GMRANM=$P(^PS(50.605,+$O(^PS(50.605,"B",GMRACL,0)),0),U,2)
.S GMRADRCL(GMRACL)=GMRACL_U_GMRANM_" ("_GMRALOC_")"
.;IHS/MSC/MGH added for reaction data patch 1014
.S J=0 F S J=$O(^TMP("GMRAOC",$J,"APC",GMRACL,"REAC",J)) Q:'+J D
..S GMRAREAC(GMRACL,J)=$G(^TMP("GMRAOC",$J,"APC",GMRACL,"REAC",J))
.;END MOD
.S RET=RET+1
Q:'RET K ^TMP("GMRAOC",$J)
;IHS/GDIT/MSC/MGH fix for reactions patch 1022
S CLCHK="",CT="" F S CT=$O(GMRADRCL(CT)) Q:CT="" D
.I $E(PSCLASS,1,LEN)=$E(CT,1,LEN) D
..S CLCHK=$G(CLCHK)+1,^TMP($J,"PSJDRCLS",CLCHK)=CT_" "_$P(GMRADRCL(CT),"^",2)
..S K=0 F S K=$O(GMRAREAC(CT,K)) Q:'+K D
...I K=1 S ^TMP($J,"PSODRCLS","REAC",K)="Reactions: "_$G(GMRAREAC(CT,K))
...E S ^TMP($J,"PSODRCLS","REAC",K)=$G(GMRAREAC(CT,K))
CLASSDSP ;
I '$D(^TMP($J,"PSJDRCLS")) Q
W $C(7),!,"A Drug-Allergy Reaction exists for this medication and/or class!",!
W !,"Drug: "_$P($G(^PSDRUG(PSJDD,0)),"^")
S CT="" F S CT=$O(^TMP($J,"PSJDRCLS",CT)) Q:CT="" W !,"Drug Class: "_^TMP($J,"PSJDRCLS",CT)
;IHS/MSC/MGH added patch 1014 for reactions
;IHS/GDIT/MSC/MGH fix for reactions patch 1022
S K=0 F S K=$O(^TMP($J,"PSODRCLS","REAC",K)) Q:K="" D
.I K=1 W !?6,"Reactions: "_$G(^TMP($J,"PSODRCLS","REAC",K))
.E W !?19,$G(^TMP($J,"PSODRCLS","REAC",K))
.;S K=0 F S K=$O(GMRAREAC(K)) Q:'+K D
.;I K=1 W !?6,"Reactions: "_$G(GMRAREAC(K))
.;E W !?19,$G(GMRAREAC(K))
;END MOD
K ^TMP($J,"PSJDRCLS")
S DIR("?",1)="Answer 'YES' if you DO want to enter a reaction for this medication,"
S DIR("?")=" 'NO' if you DON'T want to enter a reaction for this medication,"
S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Intervene? ",DIR("B")="Y" W ! D ^DIR
I Y D ^PSJRXI
I '$G(Y) K DIR,DTOUT,DIRUT,DIROUT,DUOUT,Y Q
Q
PSGSICHK ;BIR/CML3-CHECKS SPECIAL INSTRUCTIONS ;19-Oct-2017 12:55;PT
+1 ;;5.0; INPATIENT MEDICATIONS ;**3,9,26,29,44,49,59,1013,110,139,146,160,175,201,185,1015,1022**;16 DEC 97;Build 20
+2 ;
+3 ; Reference to ^PS(50.605 is supported by DBIA 696.
+4 ; Reference to EN^PSOORDRG is supported by DBIA 2190.
+5 ; Reference to ^PSI(58.1 is supported by DBIA 2284.
+6 ; Reference to ^PSDRUG( is supported by DBIA 2192.
+7 ; Reference to ^PSD(58.8 is supported by DBIA 2283.
+8 ; Reference to ^PS(55 is supported by DBIA 2191.
+9 ; Reference to ^PS(51.2 is supported by DBIA 2178.
+10 ; Reference to ^PS(51 is supported by DBIA 2176.
+11 ; Reference to ^ORRDI1 is supported by DBIA 4659.
+12 ; Reference to ^XTMP("ORRDI" is supported by DBIA 4660.
+13 ; Reference to GETDATA^GMRAOR supported by DBIA 4847.
+14 ; Reference to ^TMP("GMRAOC" supported by DBIA 4848.
+15 ;Modified - IHS/MSC/MGH - 02/08/2012 - Line ENDL+2
+16 ;Modified - IHS/MSC/MGH - 04/06/2012 - IVSOL+5,ALGCLASS+13,ALGC2+19,CLASSDSP+5
+17 ; for adding reactions patch 1014
+18 ;Modified - IHS/MSC/MGH - 12/21/2012 - IVSOL+5,IVSOL+7 patch 1015
START ;
+1 IF $SELECT(X'?.ANP:1,X["^":1,1:$LENGTH(X)>180)
KILL X
QUIT
+2 SET Y=""
FOR Y(1)=1:1:$LENGTH(X," ")
SET Y(2)=$PIECE(X," ",Y(1))
IF Y(2)]""
DO CHK
IF '$DATA(X)
QUIT
+3 IF $DATA(X)
IF Y]""
IF X'=$EXTRACT(Y,1,$LENGTH(Y)-1)
DO EN^DDIOL("EXPANDS TO: ")
WRITE Y
FOR Y(1)=1:1
SET Y(2)=$PIECE(Y," ",Y(1))
IF Y(2)=""
QUIT
IF $LENGTH(Y(2))+$X>78
DO EN^DDIOL(Y(2)_" ")
+4 QUIT
+5 ;
CHK ;
+1 IF $LENGTH(Y(2))<31
IF $DATA(^PS(51,+$ORDER(^PS(51,"B",Y(2),0)),0))
IF $PIECE(^(0),"^",2)]""
IF $PIECE(^(0),"^",4)
SET Y(2)=$PIECE(^(0),"^",2)
+2 IF $LENGTH(Y)+$LENGTH(Y(2))>180
KILL X
QUIT
+3 SET Y=Y_Y(2)_" "
QUIT
+4 ;
ENSET(X) ; expands the SPECIAL INSTRUCTIONS field contained in X into Y
+1 NEW X1,X2,Y
SET Y=""
+2 ;BHW;PSJ*5*185;Modified Logic below to NOT strip spaces and allow existing logic to flow.
+3 ; ;Removed code I X2]"" Before Set of Y and created argumentless DO structure.
+4 FOR X1=1:1:$LENGTH(X," ")
SET X2=$PIECE(X," ",X1)
Begin DoDot:1
+5 ;if multiple spaces in text and were $P'ing through text, X2 will="" so just add space and continue
IF X2']""
SET Y=Y_" "
QUIT
+6 SET Y=Y_$SELECT($LENGTH(X2)>30:X2,'$DATA(^PS(51,+$ORDER(^PS(51,"B",X2,0)),0)):X2,$PIECE(^(0),"^",2)]""&$PIECE(^(0),"^",4):$PIECE(^(0),"^",2),1:X2)_" "
+7 QUIT
End DoDot:1
+8 ;BHW;Modified stripping of spaces at end of string
+9 FOR X1=$LENGTH(Y):-1:0
IF $EXTRACT(Y,X1,X1)'=" "
QUIT
SET Y=$EXTRACT(Y,1,X1-1)
+10 QUIT Y
+11 ;
END ; used by DRUG (55.06,101 & 53.1,101) x-refs to warn user if patient is receiving or about to receive the drug just ordered
+1 IF $DATA(PSJHLSKP)
QUIT
+2 NEW Z,ZZ,STATUSNP
IF $GET(PSJPWD)&($PIECE($GET(PSJSYSU),";")=3)&($GET(PSGDRG))
IF ($DATA(^PSI(58.1,"D",PSGDRG,PSJPWD)))!($DATA(^PSD(58.8,"D",PSGDRG,PSJPWD)))
DO EN^DDIOL(" *** A WARD STOCK ITEM ***")
+3 DO NOW^%DTC
+4 NEW PSJDCHK
FOR Z=%:0
SET Z=$ORDER(^PS(55,+PSGP,5,"AUS",Z))
IF 'Z!$DATA(DUOUT)
QUIT
FOR ZZ=0:0
SET ZZ=$ORDER(^PS(55,+PSGP,5,"AUS",Z,ZZ))
IF 'ZZ!$DATA(DUOUT)
QUIT
IF +$GET(^PS(55,+PSGP,5,ZZ,.2))=PSGX
DO PDWCHK(+PSGP,ZZ_"U")
SET PSJDCHK=1
+5 FOR STATUSNP="N","P"
FOR Z=0:0
SET Z=$ORDER(^PS(53.1,"AS",STATUSNP,+PSGP,Z))
IF 'Z!$DATA(DUOUT)
QUIT
IF +$GET(^PS(53.1,+Z,.2))=PSGX
DO PDWCHK(+PSGP,Z_"P")
SET PSJDCHK=1
+6 IF $DATA(PSJDCHK)
NEW DIR
Begin DoDot:1
+7 SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue entering this order"
SET DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order,"
+8 SET DIR("?")="or ""Y"" to continue with the order entry process."
DO ^DIR
IF 'Y
SET Y=-1
SET X="^"
End DoDot:1
+9 KILL Z,ZZ
+10 QUIT
+11 ;
ENDDC(PSGP,PSJDD) ; Perform Duplicate Drug, Duplicate Class,
+1 ; Drug-Drug interaction check, Drug-Allergy interaction check.
+2 NEW PSJLINE,Z,ZZ,PSJFST
+3 SET (PSJLINE,PSJFST)=0
+4 IF $GET(PSJPWD)&($PIECE($GET(PSJSYSU),";")=3)&($GET(PSJDD))
IF ($DATA(^PSI(58.1,"D",PSJDD,PSJPWD)))!($DATA(^PSD(58.8,"D",PSJDD,PSJPWD)))
WRITE !?25,"*** A WARD STOCK ITEM ***"
+5 DO EN^PSOORDRG(PSGP,PSJDD)
KILL PSJPDRG
NEW INTERVEN,PSJIREQ,PSJRXREQ
SET Y=1
SET (PSJIREQ,PSJRXREQ,INTERVEN,X)=""
SET DFN=PSGP
+6 IF $TEXT(HAVEHDR^ORRDI1)]""
IF $$HAVEHDR^ORRDI1
IF '$DATA(^XTMP("ORRDI","OUTAGE INFO","DOWN"))
Begin DoDot:1
+7 IF $PIECE($GET(^XTMP("ORRDI","PSOO",PSGP,0)),"^",3)<0
WRITE !,"Remote data not available - Only local order checks processed."
DO PAUSE^PSJLMUT1
End DoDot:1
+8 IF $DATA(^TMP($JOB,"DD"))
DO ORDCHK^PSJLMUT1(PSGP,"DD",4)
+9 IF $DATA(^TMP($JOB,"DC"))
DO ORDCHK^PSJLMUT1(PSGP,"DC",6)
IVSOL ;*** Start order check for IV solution at this point.
+1 IF '$DATA(PSJFST)
NEW PSJFST
SET PSJFST=0
+2 IF $DATA(^TMP($JOB,"DI"))
SET INTERVEN=1
DO ORDCHK^PSJLMUT1(PSGP,"DI",8)
+3 ;*** Allergy/adverse reaction check.
+4 NEW PTR,X,CMP,CMPDR,CDRG
+5 ;IHS/MSC/MGH check for compound
SET CMP=$PIECE($GET(^PSDRUG(PSJDD,999999935)),U,1)
+6 SET PTR=$PIECE($GET(^PSDRUG(PSJDD,"ND")),U)_"."_$PIECE($GET(^PSDRUG(PSJDD,"ND")),U,3)
+7 IF +CMP=0
DO ALGCHK(PSJDD)
+8 ;IHS/MSC/MGH Patch 1015 for compound meds
+9 IF +CMP=1
Begin DoDot:1
+10 SET CMPDR=0
+11 FOR
SET CMPDR=$ORDER(^PSDRUG(PSJDD,999999936,CMPDR))
IF '+CMPDR
QUIT
Begin DoDot:2
+12 SET CDRG=$PIECE($GET(^PSDRUG(PSJDD,999999936,CMPDR,0)),U,1)
+13 IF CDRG'=""
SET PTR=$PIECE($GET(^PSDRUG(CDRG,"ND")),U)_"."_$PIECE($GET(^PSDRUG(CDRG,"ND")),U,3)
+14 DO ALGCHK(CDRG)
+15 ;END mod for compound meds
End DoDot:2
End DoDot:1
CONT ; Ask user if they wish to continue in spite of an order check.
+1 IF '$DATA(PSJPDRG)
QUIT
NEW DIR
SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue entering this order"
SET DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order,"
+2 SET DIR("?")="or ""Y"" to continue with the order entry process."
SET DIR("B")="NO"
DO ^DIR
IF 'Y
SET PSGORQF=1
SET X="^"
SET COMQUIT=1
QUIT
+3 IF 'INTERVEN!($PIECE(PSJSYSU,";")'=3)
QUIT
+4 NEW PSJY
+5 IF PSJIREQ
WRITE !!,"This is a CRITICAL interaction, you must enter an intervention log to continue"
+6 SET DIR(0)="Y"
SET DIR("A")="Do you wish to log an intervention"
SET DIR("?",1)="Enter ""N"" if you do not wish to log an intervention,"
SET DIR("?")="or ""Y"" to log an intervention."
DO ^DIR
SET PSJY=Y
IF Y
DO ^PSJRXI
+7 IF 'PSJY
IF PSJIREQ
SET PSGORQF=1
SET COMQUIT=1
+8 QUIT
ALGCHK(PSJDD) ;CHECK FOR ALLERGIES
+1 ;IHS/MSC/MGH - 04/06/12
+2 ;K ^TMP("PSJDAI",$J) S PSJACK=$$ORCHK^GMRAOR(DFN,"DR",PTR,"",1) D:$G(PSJACK)=1
+3 SET PSJACK=0
+4 KILL ^TMP("PSJDAI",$JOB)
SET PSJACK=$$ORCHK^GMRAOR(DFN,"DR",PTR,"",1)
IF $GET(PSJACK)=1
Begin DoDot:1
+5 SET ^TMP("PSJDAI",$JOB,0)=1
+6 SET I=0
FOR
SET I=$ORDER(GMRAING(I))
IF 'I
QUIT
SET ^TMP("PSJDAI",$JOB,I,0)=GMRAING(I)
End DoDot:1
+7 IF $DATA(^TMP("PSJDAI",$JOB))
SET PSJPDRG=1
Begin DoDot:1
+8 WRITE $CHAR(7),!!,"A Drug-Allergy Reaction exists for this medication!",!!
+9 WRITE !?7,"Drug: "_$PIECE($GET(^PSDRUG(PSJDD,0)),"^")
IF $ORDER(^TMP("PSJDAI",$JOB))
WRITE !,"Ingredients: "
Begin DoDot:2
+10 SET I=0
FOR
SET I=$ORDER(^TMP("PSJDAI",$JOB,I))
IF 'I
QUIT
IF $X+$LENGTH($GET(^(I,0)))+2>IOM
WRITE !?19
IF I=1
WRITE $GET(^TMP("PSJDAI",$JOB,I,0))
IF I>1
WRITE ", ",$GET(^TMP("PSJDAI",$JOB,I,0))
End DoDot:2
+11 ;IHS/MSC/MGH Added for reactions Patch 1014
+12 IF $ORDER(GMRAREAC(0))
WRITE !,?6,"Reactions: "
+13 WRITE ?19
SET I=0
FOR
SET I=$ORDER(GMRAREAC(I))
IF 'I
QUIT
IF $X+$LENGTH($GET(GMRAREAC(I)))+2>IOM
WRITE !?19
WRITE $GET(GMRAREAC(I))_", "
+14 WRITE !!
End DoDot:1
+15 ;K PSJACK,GMRAING,I,^TMP($J)
+16 ;IHS/MSC/MGH - 04/06/12
KILL PSJACK,GMRAING,GMRAREAC,I,^TMP($JOB)
+17 DO ALGCLASS(PSJDD)
+18 QUIT
+19 ;
ENDL ; used by PSGTRAIN DRUG LOOK-UP option
+1 DO ENCV^PSGSETU
IF $DATA(XQUIT)
QUIT
+2 ;IHS/MSC/MGH changed for mixed case lookup, uses new cross-reference
+3 ;F S DIC="^PSDRUG(",DIC(0)="AEIMOQZ",DIC("A")="Select DRUG: " W ! D ^DIC K DIC Q:+Y'>0
+4 FOR
SET DIC="^PSDRUG("
SET DIC(0)="AEIMOQZ"
SET D="BCAP"
SET DIC("A")="Select DRUG: "
WRITE !
DO IX^DIC
KILL DIC
IF +Y'>0
QUIT
DO SF
+5 DO ENKV^PSGSETU
KILL N5,ND,Q,Y
QUIT
+6 ;
SF ;
+1 SET Y=+Y
SET ND=$GET(^PSDRUG(Y,0))
SET PSGID=+$GET(^("I"))
IF PSGID
WRITE !!,"THIS DRUG IS INACTIVE AS OF ",$EXTRACT($$ENDTC^PSGMI(PSGID),1,8)
+2 WRITE !!,$SELECT($PIECE(ND,"^",9):"NON-",1:""),"FORMULARY ITEM"
IF $PIECE(ND,"^",10)]""
WRITE !,$PIECE(ND,"^",10)
+3 SET ND=$PIECE($GET(^PSDRUG(Y,2)),"^",3)["U"
WRITE !,$PIECE("NOT^","^",ND+1)," A UNIT DOSE DRUG"
WRITE !
SET ND=$GET(^(8))
SET N5=$GET(^(8.5))
WRITE !?2,"DAY (nD) or DOSE (nL) LIMIT: "
IF ND
WRITE $PIECE(ND,"^")
+4 WRITE !?10,"UNIT DOSE MED ROUTE: "
IF $PIECE(ND,"^",2)
WRITE $SELECT($DATA(^PS(51.2,$PIECE(ND,"^",2),0)):$PIECE(^(0),"^"),1:$PIECE(ND,"^",2))
+5 ; NAKED REF below refers to ^PS(51.2, on line above.
+6 WRITE !?6,"UNIT DOSE SCHEDULE TYPE: "
IF $PIECE(ND,"^",3)]""
WRITE $PIECE($PIECE(";"_$PIECE(^(0),"^",3),";"_$PIECE(ND,"^",3)_":",2),";")
+7 WRITE !?11,"UNIT DOSE SCHEDULE: "
IF $PIECE(ND,"^",4)]""
WRITE $PIECE(ND,"^",4)
+8 WRITE !,"CORRESPONDING OUTPATIENT DRUG: "
IF $PIECE(ND,"^",5)
WRITE $SELECT('$DATA(^PSDRUG(+$PIECE(ND,"^",5),0)):$PIECE(ND,"^",5),$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:$PIECE(ND,"^",5))
+9 WRITE !?17,"ATC MNEMONIC: "
IF $PIECE(N5,"^",2)]""
WRITE $PIECE(N5,"^",2)
+10 WRITE !?17,"ATC CANISTER: "
FOR Q=0:0
SET Q=$ORDER(^PSDRUG(Y,212,Q))
IF 'Q
QUIT
SET ND=$GET(^(Q,0))
IF ND
IF $PIECE(ND,"^",2)
WRITE ?31,$SELECT('$DATA(^PS(57.5,+ND,0)):+ND_";PS(57.5,",$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:+ND_";PS(57.5,"),?56,$PIECE(ND,"^",2),!
+11 QUIT
+12 ;
OCHK ; Add drugs in current order to ^TMP("ORDERS" and call order checker.
+1 ; Set PSJOCHK=1 so OP order check doesn't Kill array.
+2 ;
+3 KILL ^TMP($JOB,"ORDERS")
+4 NEW PSJOCHK
SET PSJOCHK=1
PDWCHK(DFN,ON) ; Print Dup Drug order.
+1 NEW ND,ND0,ND2,X
+2 IF '$DATA(PSJDCHK)
WRITE $CHAR(7),$CHAR(7),!!,"WARNING! THIS PATIENT HAS THE FOLLOWING ORDER(S) FOR THIS MEDICATION:",!!
+3 SET ND=$$DRUGNAME^PSJLMUTL(DFN,ON)
+4 SET F=$SELECT(ON["P":"^PS(53.1,",1:"^PS(55,"_DFN_",5,")
SET ND0=$GET(@(F_+ON_",0)"))
SET ND2=$GET(^(2))
SET X=$PIECE(ND,U,2)
SET X=$SELECT(X=.2:$PIECE($GET(^(.2)),U,2),1:$GET(^(.3)))
+5 WRITE ?10,$PIECE(ND,U),!,?13,"Give: ",X," ",$$ENMRN^PSGMI(+$PIECE(ND0,U,3))," ",$PIECE(ND2,U),!!
+6 QUIT
ALGCLASS(PSJDD) ; checks any Drug allergies or reactions to see if
+1 ; the new drug is the same class
+2 ; this call can be removed by commenting out the call on IVSOL+16
+3 NEW PSJLIST,CT,CLS,CLCHK,CNT,PSJL,LIST,DCCNT,PSCLASS,LEN
+4 ;look at 5 chars if ANALGESICS
SET PSCLASS=$PIECE($GET(^PSDRUG(PSJDD,0)),"^",2)
SET LEN=4
IF $EXTRACT(PSCLASS,1,4)="CN10"
SET LEN=5
+5 IF $TEXT(GETDATA^GMRAOR)]""
GOTO ALGC2
+6 SET GMRA="0^0^111"
DO EN1^GMRADPT
+7 FOR PSJLIST=0:0
SET PSJLIST=$ORDER(GMRAL(PSJLIST))
IF 'PSJLIST
QUIT
Begin DoDot:1
+8 KILL PSJAGL
DO EN1^GMRAOR2(PSJLIST,"PSJAGL")
+9 ; is the allergy/reaction drug class first four digits the same as the
+10 ; the class for the drug being entered?
+11 SET (CT,CLS)=""
SET DCCNT=0
+12 IF $DATA(PSJAGL("V"))
Begin DoDot:2
+13 ;IHS/MSC/MGH Modified for reactions
+14 ;F S DCCNT=$O(PSJAGL("V",DCCNT)) Q:'DCCNT S:$E($P($G(PSJAGL("V",DCCNT)),"^"),1,LEN)=$E(PSCLASS,1,LEN) (PSJPDRG,CLCHK)=1,CNT=$S('$D(CNT):1,1:CNT+1),LIST(CNT)=$P($G(PSJAGL),"^")_"^"_$P($G(PSJAGL("V",DCCNT)),"^",2)
+15 FOR
SET DCCNT=$ORDER(PSJAGL("V",DCCNT))
IF 'DCCNT
QUIT
Begin DoDot:3
+16 IF $EXTRACT($PIECE($GET(PSJAGL("V",DCCNT)),"^"),1,LEN)=$EXTRACT(PSCLASS,1,LEN)
Begin DoDot:4
+17 SET (PSJPDRG,CLCHK)=1
SET CNT=$SELECT('$DATA(CNT):1,1:CNT+1)
+18 SET LIST(CNT)=$PIECE($GET(PSJAGL),"^")_"^"_$PIECE($GET(PSJAGL("V",DCCNT)),"^",2)
+19 IF $DATA(PSJAGL("S"))
Begin DoDot:5
+20 NEW K
SET K=0
SET K=$ORDER(PSJAGL("S",K))
IF '+K
QUIT
Begin DoDot:6
+21 SET LIST(CNT,"S",K)=$GET(PSJAGL("S",K))
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
+22 ;END MOD
End DoDot:2
End DoDot:1
+23 IF $GET(CLCHK)
Begin DoDot:1
+24 WRITE !!,$CHAR(7),"A Drug-Allergy Reaction exists for this medication and/or class!"
+25 FOR PSJL=0:0
SET PSJL=$ORDER(LIST(PSJL))
IF 'PSJL
QUIT
Begin DoDot:2
+26 WRITE !?6,"Drug: "_$PIECE(LIST(PSJL),"^"),!,"Drug Class: "_$PIECE(LIST(PSJL),"^",2),!
+27 ;IHS/MSC/MGH Updated for reactions Patch 1014
+28 NEW J
SET J=0
FOR
SET J=$ORDER(LIST(PSJL,"S",J))
IF J=""
QUIT
Begin DoDot:3
+29 IF J=1
WRITE !?6,"Reaction: "_$GET(LIST(PSJL,"S",J))
+30 IF '$TEST
WRITE !,?19,$GET(LIST(PSJL,"S",J))
End DoDot:3
End DoDot:2
End DoDot:1
+31 QUIT
ALGC2 ;
+1 KILL GMRADRCL
+2 DO GETDATA^GMRAOR(DFN)
IF '$DATA(^TMP("GMRAOC",$JOB,"APC"))
QUIT
+3 NEW GMRACL,RET
+4 SET RET=0
SET GMRACL=""
FOR
SET GMRACL=$ORDER(^TMP("GMRAOC",$JOB,"APC",GMRACL))
IF '$LENGTH(GMRACL)
QUIT
Begin DoDot:1
+5 NEW GMRANM,GMRALOC
+6 SET GMRALOC=^TMP("GMRAOC",$JOB,"APC",GMRACL)
+7 SET GMRANM=$PIECE(^PS(50.605,+$ORDER(^PS(50.605,"B",GMRACL,0)),0),U,2)
+8 SET GMRADRCL(GMRACL)=GMRACL_U_GMRANM_" ("_GMRALOC_")"
+9 ;IHS/MSC/MGH added for reaction data patch 1014
+10 SET J=0
FOR
SET J=$ORDER(^TMP("GMRAOC",$JOB,"APC",GMRACL,"REAC",J))
IF '+J
QUIT
Begin DoDot:2
+11 SET GMRAREAC(GMRACL,J)=$GET(^TMP("GMRAOC",$JOB,"APC",GMRACL,"REAC",J))
End DoDot:2
+12 ;END MOD
+13 SET RET=RET+1
End DoDot:1
+14 IF 'RET
QUIT
KILL ^TMP("GMRAOC",$JOB)
+15 ;IHS/GDIT/MSC/MGH fix for reactions patch 1022
+16 SET CLCHK=""
SET CT=""
FOR
SET CT=$ORDER(GMRADRCL(CT))
IF CT=""
QUIT
Begin DoDot:1
+17 IF $EXTRACT(PSCLASS,1,LEN)=$EXTRACT(CT,1,LEN)
Begin DoDot:2
+18 SET CLCHK=$GET(CLCHK)+1
SET ^TMP($JOB,"PSJDRCLS",CLCHK)=CT_" "_$PIECE(GMRADRCL(CT),"^",2)
+19 SET K=0
FOR
SET K=$ORDER(GMRAREAC(CT,K))
IF '+K
QUIT
Begin DoDot:3
+20 IF K=1
SET ^TMP($JOB,"PSODRCLS","REAC",K)="Reactions: "_$GET(GMRAREAC(CT,K))
+21 IF '$TEST
SET ^TMP($JOB,"PSODRCLS","REAC",K)=$GET(GMRAREAC(CT,K))
End DoDot:3
End DoDot:2
End DoDot:1
CLASSDSP ;
+1 IF '$DATA(^TMP($JOB,"PSJDRCLS"))
QUIT
+2 WRITE $CHAR(7),!,"A Drug-Allergy Reaction exists for this medication and/or class!",!
+3 WRITE !,"Drug: "_$PIECE($GET(^PSDRUG(PSJDD,0)),"^")
+4 SET CT=""
FOR
SET CT=$ORDER(^TMP($JOB,"PSJDRCLS",CT))
IF CT=""
QUIT
WRITE !,"Drug Class: "_^TMP($JOB,"PSJDRCLS",CT)
+5 ;IHS/MSC/MGH added patch 1014 for reactions
+6 ;IHS/GDIT/MSC/MGH fix for reactions patch 1022
+7 SET K=0
FOR
SET K=$ORDER(^TMP($JOB,"PSODRCLS","REAC",K))
IF K=""
QUIT
Begin DoDot:1
+8 IF K=1
WRITE !?6,"Reactions: "_$GET(^TMP($JOB,"PSODRCLS","REAC",K))
+9 IF '$TEST
WRITE !?19,$GET(^TMP($JOB,"PSODRCLS","REAC",K))
+10 ;S K=0 F S K=$O(GMRAREAC(K)) Q:'+K D
+11 ;I K=1 W !?6,"Reactions: "_$G(GMRAREAC(K))
+12 ;E W !?19,$G(GMRAREAC(K))
End DoDot:1
+13 ;END MOD
+14 KILL ^TMP($JOB,"PSJDRCLS")
+15 SET DIR("?",1)="Answer 'YES' if you DO want to enter a reaction for this medication,"
+16 SET DIR("?")=" 'NO' if you DON'T want to enter a reaction for this medication,"
+17 SET DIR(0)="SA^1:YES;0:NO"
SET DIR("A")="Do you want to Intervene? "
SET DIR("B")="Y"
WRITE !
DO ^DIR
+18 IF Y
DO ^PSJRXI
+19 IF '$GET(Y)
KILL DIR,DTOUT,DIRUT,DIROUT,DUOUT,Y
QUIT
+20 QUIT
