PSGSICHK ;BIR/CML3-CHECKS SPECIAL INSTRUCTIONS ;17 Aug 98 / 8:33 AM
;;5.0;INPATIENT MEDICATIONS ;**3,9,26,29,44,49,59,110,139,146,160,175,201,185,181,256,347**;16 DEC 97;Build 6
;
; 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 ^PSSDSAPI is supported by DBIA 5425.
;
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)
;
;***This module is no longer used after PSJ*5*181***
Q
;
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
;Using FDB OC
NEW PSPDRG,PSJDSPNM,X
K ^TMP($J,"PSJPRE")
S PSJDSPNM=""
;If it is an active or pending order then check for multiple dispense drugs.
I $G(PSJMULDD)>1!($G(PSGORD)]"") S PSJDSPNM=$$DRGNM()
S PSPDRG(1)=PSJDD_U_$S(PSJDSPNM]"":PSJDSPNM,1:$$DN^PSJMISC(+PSJDD))
I $$SUP^PSSDSAPI(+PSJDD) D DISPLAY^PSJOC Q
D OC^PSJOC(.PSPDRG,"I;"_$G(PSGORD))
Q
DRGNM() ;
;Return the OI name + Dosage form if more than one DD in the order
NEW PSJCNT,PSJDSPNM,X
;If it's speed finish then get the drug name from 53.1 (^PS(53.45 is not set to the current order yet)
I $G(PSJSPEED),($G(PSGORD)["P") S PSJDSPNM=$$OINM^PSJOCDS(PSGORD) Q PSJDSPNM
S PSJCNT=0,PSJDSPNM=""
F X=0:0 S X=$O(^PS(53.45,+$G(PSJSYSP),2,X)) Q:'X S PSJCNT=PSJCNT+1
I PSJCNT>1,+$G(PSGPDRG) S PSJDSPNM=$$OIDF^PSJLMUT1(+PSGPDRG)
Q PSJDSPNM
;
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
;
ENDL ; used by PSGTRAIN DRUG LOOK-UP option
D ENCV^PSGSETU Q:$D(XQUIT)
F S DIC="^PSDRUG(",DIC(0)="AEIMOQZ",DIC("A")="Select DRUG: " W ! D ^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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGSICHK 6588 printed Oct 16, 2024@18:04:03 Page 2
PSGSICHK ;BIR/CML3-CHECKS SPECIAL INSTRUCTIONS ;17 Aug 98 / 8:33 AM
+1 ;;5.0;INPATIENT MEDICATIONS ;**3,9,26,29,44,49,59,110,139,146,160,175,201,185,181,256,347**;16 DEC 97;Build 6
+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 ^PSSDSAPI is supported by DBIA 5425.
+14 ;
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 ;
+3 ;***This module is no longer used after PSJ*5*181***
+4 QUIT
+5 ;
+6 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 ***")
+7 DO NOW^%DTC
+8 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
+9 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
+10 IF $DATA(PSJDCHK)
NEW DIR
Begin DoDot:1
+11 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,"
+12 SET DIR("?")="or ""Y"" to continue with the order entry process."
DO ^DIR
if 'Y
SET Y=-1
SET X="^"
End DoDot:1
+13 KILL Z,ZZ
+14 QUIT
+15 ;
ENDDC(PSGP,PSJDD) ; Perform Duplicate Drug, Duplicate Class
+1 ;Using FDB OC
+2 NEW PSPDRG,PSJDSPNM,X
+3 KILL ^TMP($JOB,"PSJPRE")
+4 SET PSJDSPNM=""
+5 ;If it is an active or pending order then check for multiple dispense drugs.
+6 IF $GET(PSJMULDD)>1!($GET(PSGORD)]"")
SET PSJDSPNM=$$DRGNM()
+7 SET PSPDRG(1)=PSJDD_U_$SELECT(PSJDSPNM]"":PSJDSPNM,1:$$DN^PSJMISC(+PSJDD))
+8 IF $$SUP^PSSDSAPI(+PSJDD)
DO DISPLAY^PSJOC
QUIT
+9 DO OC^PSJOC(.PSPDRG,"I;"_$GET(PSGORD))
+10 QUIT
DRGNM() ;
+1 ;Return the OI name + Dosage form if more than one DD in the order
+2 NEW PSJCNT,PSJDSPNM,X
+3 ;If it's speed finish then get the drug name from 53.1 (^PS(53.45 is not set to the current order yet)
+4 IF $GET(PSJSPEED)
IF ($GET(PSGORD)["P")
SET PSJDSPNM=$$OINM^PSJOCDS(PSGORD)
QUIT PSJDSPNM
+5 SET PSJCNT=0
SET PSJDSPNM=""
+6 FOR X=0:0
SET X=$ORDER(^PS(53.45,+$GET(PSJSYSP),2,X))
if 'X
QUIT
SET PSJCNT=PSJCNT+1
+7 IF PSJCNT>1
IF +$GET(PSGPDRG)
SET PSJDSPNM=$$OIDF^PSJLMUT1(+PSGPDRG)
+8 QUIT PSJDSPNM
+9 ;
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
+9 ;
ENDL ; used by PSGTRAIN DRUG LOOK-UP option
+1 DO ENCV^PSGSETU
if $DATA(XQUIT)
QUIT
+2 FOR
SET DIC="^PSDRUG("
SET DIC(0)="AEIMOQZ"
SET DIC("A")="Select DRUG: "
WRITE !
DO ^DIC
KILL DIC
if +Y'>0
QUIT
DO SF
+3 DO ENKV^PSGSETU
KILL N5,ND,Q,Y
QUIT
+4 ;
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
