PSGSICHK.m

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)