PSGOE7 ;BIR/CML3-SELECT DRUG ;15 MAY 00 / 1:43 PM
;;5.0; INPATIENT MEDICATIONS ;**9,26,34,52,55,50,87,111**;16 DEC 97
;
; Reference to ^PS(50.7 is supported by DBIA 2180
; Reference to ^PS(59.7 is supported by DBIA 2181
; Reference to ^PSDRUG( is supported by DBIA 2192
; NFI-UD chgs for FR#: 1
;
;S PSGDICS="U"_$S($D(PSJOERR):",I",1:"")
S PSGDICS="U"
;
AD ; Ask Drug
K PSJDOSE,PSJDOX ;var array use in ^PSJDOSE
K PSGODO
K DIC S DIC="^PS(50.7,",DIC(0)="EMQZVT",D="B^C" I '$P(PSJSYSU,";",4) S DIC("S")="I $$ENOISC^PSJUTL(Y,""U"")"
E S DIC("T")="",DIC="^PSDRUG(",DIC("S")="I +$G(^PSDRUG(+Y,2)),$P($G(^PSDRUG(+Y,2)),""^"",3)[""U"" S X(1)=+$G(^(""I"")) I $S('X(1):1,1:X(1)'<DT)",D="B^C^VAPN^VAC^NDC^XATC"
;
AD1 ;
K PSGORD,PSJORD
S PSGORQF=0 R !!,"Select DRUG: ",X:DTIME I '$T W $C(7) S X="^"
I ("^"[X)!(X="") S PSGORQF=1 G DONE
G:X?1"S."1.E DONE
I X?1."?" W !!?2,"Select the medication you wish the patient to receive." W:PSJSYSU<3 " You should consult",!,"with your pharmacy before ordering any non-formulary medication." W !
D MIX^DIC1 G:X?1."?" AD1 G:"^"[X!(Y'>0) AD1 S (PSGDO,PSGDRG,PSGDRGN,PSGNEDFD,PSGPDRG,PSGPDRGN)=""
I $P(PSJSYSU,";",4) D G DO
.S PSGDRG=+Y,PSGDRGN=Y(0,0)
.D DIN^PSJDIN(+$G(^PSDRUG(PSGDRG,2)),PSGDRG)
.I $P(Y(0),"^",9) D NF S:Y>0 PSGDRG=+Y(0),PSGDRGN=Y(0,0) D SNFM
.S PSGPDRG=+$G(^PSDRUG(PSGDRG,2)),PSGPDRGN=$$OINAME^PSJLMUTL(PSGPDRG)
S PSGPDRG=+Y,PSGPDRGN=$$OINAME^PSJLMUTL(PSGPDRG)
;F Q=1:1:$L(PSGDICS) S X=$P(PSGDICS,",",Q) Q:X="" S PSJLUAPP=$O(^PS(50.3,PSGPDRG,1,"B",X,0)) I PSJLUAPP S X=$G(^PS(50.3,PSGPDRG,1,PSJLUAPP,0)) Q
S X=$O(^PSDRUG("ASP",PSGPDRG,0)) I X,'$O(^(X)) S PSGDRG=X,PSGDRGN=$$ENDDN^PSGMI(X)
;
DO ; dosage ordered
S PSGNEDFD=$$GTNEDFD("U",PSGPDRG)
I $G(PSGDRG),$P(PSJSYSU,";",4) D ENDDC^PSGSICHK(PSGP,PSGDRG) G:PSGORQF>0 AD
I '$P(PSJSYSU,";",4) S PSGX=PSGPDRG D END^PSGSICHK G:Y<0 AD
;S PSGNEDFD="" I PSGPDRG S PSGX=PSGPDRG D END^PSGSICHK
S PSGDO=""
;I PSGDO]"",'PSGDO,PSGDO?.E1N.E F S PSGDO=$E(PSGDO,2,999) Q:PSGDO Q:PSGDO=""
;G:Y<0 AD
;
DONE ;
K DIC,%,%Y,PSGDICS,PSJLUAPP,Q1,Q2,Q3,Z Q
;
;
NF ;
S Y=0 W $C(7),!!,"PLEASE NOTE: The selected item is not currently on your medical center's",!?13,"formulary." Q:'$P(PSJSYSU,";",2)
N CNT S CNT=0 F Q1=0:0 S Q1=$O(^PSDRUG(PSGDRG,65,Q1)) Q:'Q1 I $$CHKDRG(+$G(^(Q1,0))) S CNT=CNT+1
I CNT=0 W !!,"There are no formulary alternatives entered for this item." W:PSJSYSU>2 " You should consult",!,"with your pharmacy before ordering this item." S Y=0 Q
I CNT=1 S Q1=$O(^PSDRUG(PSGDRG,65,0)),Q1=+$G(^(Q1,0)),Q3=$P(^PSDRUG(Q1,0),"^") W !!,Q3," has been entered as a formulary " W:$X>67 ! W "alternative."
I F Q=1:1 S %=2 W !!,"Is ",$S(Q=1:"this",1:Q3)," acceptable" D YN^DICN Q:% D NFOH
I CNT=1 S:%=1 (Y(0),Y)=Q1,Y(0,0)=Q3 S:%<0 Y=-1 Q
K DA,DIC S DA(1)=PSGDRG,DIC="^PSDRUG("_PSGDRG_",65,",DIC(0)="AEMQZ",DIC("A")="Select FORMULARY ALTERNATIVE: " W ! D ^DIC K DIC Q
;
NFOH ;
S X="Answer 'YES' to order this formulary alternative ("_Q3_") for the patient instead of the non-formulary item originally selected. Answer 'NO' to use the drug originally selected."
W !!?2 F Y=1:1:$L(X," ") S Z=$P(X," ",Y) W:$L(Z)+$X+2>IOM ! W Z," "
Q
CHKDRG(DRG) ; Determine if dispense drug is valid for Unit Dose.
I $D(^PSDRUG(DRG,0)),$P($G(^(2)),U,3)["U" S X=+$G(^("I")) I 'X!(X>DT) Q DRG
Q 0
;
SNFM ; show non-formulary message
S Y=1 Q:PSJSYSU=3!'$O(^PS(59.7,1,21,0)) W $C(7),! S Q=0 F S Q=$O(^PS(59.7,1,21,Q)) Q:'Q W !,$G(^(Q,0))
W ! D READ^PSJUTL S Y=1 Q
;
GTNEDFD(APP,PDRG) ; Find defaults from Orderable Item.
Q $P($G(^PS(50.7,+PDRG,0)),"^",5,8)
N Q,X S X=""
F Q=1:1:$L(APP) S X=$E(APP,Q) Q:X="" S X=$O(^PS(50.3,+PDRG,1,"B",X,0)) I X S X=$P($G(^PS(50.3,+PDRG,1,X,0)),"^",5,8) Q
Q X
PSGOE7 ;BIR/CML3-SELECT DRUG ;15 MAY 00 / 1:43 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**9,26,34,52,55,50,87,111**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(50.7 is supported by DBIA 2180
+4 ; Reference to ^PS(59.7 is supported by DBIA 2181
+5 ; Reference to ^PSDRUG( is supported by DBIA 2192
+6 ; NFI-UD chgs for FR#: 1
+7 ;
+8 ;S PSGDICS="U"_$S($D(PSJOERR):",I",1:"")
+9 SET PSGDICS="U"
+10 ;
AD ; Ask Drug
+1 ;var array use in ^PSJDOSE
KILL PSJDOSE,PSJDOX
+2 KILL PSGODO
+3 KILL DIC
SET DIC="^PS(50.7,"
SET DIC(0)="EMQZVT"
SET D="B^C"
IF '$PIECE(PSJSYSU,";",4)
SET DIC("S")="I $$ENOISC^PSJUTL(Y,""U"")"
+4 IF '$TEST
SET DIC("T")=""
SET DIC="^PSDRUG("
SET DIC("S")="I +$G(^PSDRUG(+Y,2)),$P($G(^PSDRUG(+Y,2)),""^"",3)[""U"" S X(1)=+$G(^(""I"")) I $S('X(1):1,1:X(1)'<DT)"
SET D="B^C^VAPN^VAC^NDC^XATC"
+5 ;
AD1 ;
+1 KILL PSGORD,PSJORD
+2 SET PSGORQF=0
READ !!,"Select DRUG: ",X:DTIME
IF '$TEST
WRITE $CHAR(7)
SET X="^"
+3 IF ("^"[X)!(X="")
SET PSGORQF=1
GOTO DONE
+4 IF X?1"S."1.E
GOTO DONE
+5 IF X?1."?"
WRITE !!?2,"Select the medication you wish the patient to receive."
IF PSJSYSU<3
WRITE " You should consult",!,"with your pharmacy before ordering any non-formulary medication."
WRITE !
+6 DO MIX^DIC1
IF X?1."?"
GOTO AD1
IF "^"[X!(Y'>0)
GOTO AD1
SET (PSGDO,PSGDRG,PSGDRGN,PSGNEDFD,PSGPDRG,PSGPDRGN)=""
+7 IF $PIECE(PSJSYSU,";",4)
Begin DoDot:1
+8 SET PSGDRG=+Y
SET PSGDRGN=Y(0,0)
+9 DO DIN^PSJDIN(+$GET(^PSDRUG(PSGDRG,2)),PSGDRG)
+10 IF $PIECE(Y(0),"^",9)
DO NF
IF Y>0
SET PSGDRG=+Y(0)
SET PSGDRGN=Y(0,0)
DO SNFM
+11 SET PSGPDRG=+$GET(^PSDRUG(PSGDRG,2))
SET PSGPDRGN=$$OINAME^PSJLMUTL(PSGPDRG)
End DoDot:1
GOTO DO
+12 SET PSGPDRG=+Y
SET PSGPDRGN=$$OINAME^PSJLMUTL(PSGPDRG)
+13 ;F Q=1:1:$L(PSGDICS) S X=$P(PSGDICS,",",Q) Q:X="" S PSJLUAPP=$O(^PS(50.3,PSGPDRG,1,"B",X,0)) I PSJLUAPP S X=$G(^PS(50.3,PSGPDRG,1,PSJLUAPP,0)) Q
+14 SET X=$ORDER(^PSDRUG("ASP",PSGPDRG,0))
IF X
IF '$ORDER(^(X))
SET PSGDRG=X
SET PSGDRGN=$$ENDDN^PSGMI(X)
+15 ;
DO ; dosage ordered
+1 SET PSGNEDFD=$$GTNEDFD("U",PSGPDRG)
+2 IF $GET(PSGDRG)
IF $PIECE(PSJSYSU,";",4)
DO ENDDC^PSGSICHK(PSGP,PSGDRG)
IF PSGORQF>0
GOTO AD
+3 IF '$PIECE(PSJSYSU,";",4)
SET PSGX=PSGPDRG
DO END^PSGSICHK
IF Y<0
GOTO AD
+4 ;S PSGNEDFD="" I PSGPDRG S PSGX=PSGPDRG D END^PSGSICHK
+5 SET PSGDO=""
+6 ;I PSGDO]"",'PSGDO,PSGDO?.E1N.E F S PSGDO=$E(PSGDO,2,999) Q:PSGDO Q:PSGDO=""
+7 ;G:Y<0 AD
+8 ;
DONE ;
+1 KILL DIC,%,%Y,PSGDICS,PSJLUAPP,Q1,Q2,Q3,Z
QUIT
+2 ;
+3 ;
NF ;
+1 SET Y=0
WRITE $CHAR(7),!!,"PLEASE NOTE: The selected item is not currently on your medical center's",!?13,"formulary."
IF '$PIECE(PSJSYSU,";",2)
QUIT
+2 NEW CNT
SET CNT=0
FOR Q1=0:0
SET Q1=$ORDER(^PSDRUG(PSGDRG,65,Q1))
IF 'Q1
QUIT
IF $$CHKDRG(+$GET(^(Q1,0)))
SET CNT=CNT+1
+3 IF CNT=0
WRITE !!,"There are no formulary alternatives entered for this item."
IF PSJSYSU>2
WRITE " You should consult",!,"with your pharmacy before ordering this item."
SET Y=0
QUIT
+4 IF CNT=1
SET Q1=$ORDER(^PSDRUG(PSGDRG,65,0))
SET Q1=+$GET(^(Q1,0))
SET Q3=$PIECE(^PSDRUG(Q1,0),"^")
WRITE !!,Q3," has been entered as a formulary "
IF $X>67
WRITE !
WRITE "alternative."
+5 IF $TEST
FOR Q=1:1
SET %=2
WRITE !!,"Is ",$SELECT(Q=1:"this",1:Q3)," acceptable"
DO YN^DICN
IF %
QUIT
DO NFOH
+6 IF CNT=1
IF %=1
SET (Y(0),Y)=Q1
SET Y(0,0)=Q3
IF %<0
SET Y=-1
QUIT
+7 KILL DA,DIC
SET DA(1)=PSGDRG
SET DIC="^PSDRUG("_PSGDRG_",65,"
SET DIC(0)="AEMQZ"
SET DIC("A")="Select FORMULARY ALTERNATIVE: "
WRITE !
DO ^DIC
KILL DIC
QUIT
+8 ;
NFOH ;
+1 SET X="Answer 'YES' to order this formulary alternative ("_Q3_") for the patient instead of the non-formulary item originally selected. Answer 'NO' to use the drug originally selected."
+2 WRITE !!?2
FOR Y=1:1:$LENGTH(X," ")
SET Z=$PIECE(X," ",Y)
IF $LENGTH(Z)+$X+2>IOM
WRITE !
WRITE Z," "
+3 QUIT
CHKDRG(DRG) ; Determine if dispense drug is valid for Unit Dose.
+1 IF $DATA(^PSDRUG(DRG,0))
IF $PIECE($GET(^(2)),U,3)["U"
SET X=+$GET(^("I"))
IF 'X!(X>DT)
QUIT DRG
+2 QUIT 0
+3 ;
SNFM ; show non-formulary message
+1 SET Y=1
IF PSJSYSU=3!'$ORDER(^PS(59.7,1,21,0))
QUIT
WRITE $CHAR(7),!
SET Q=0
FOR
SET Q=$ORDER(^PS(59.7,1,21,Q))
IF 'Q
QUIT
WRITE !,$GET(^(Q,0))
+2 WRITE !
DO READ^PSJUTL
SET Y=1
QUIT
+3 ;
GTNEDFD(APP,PDRG) ; Find defaults from Orderable Item.
+1 QUIT $PIECE($GET(^PS(50.7,+PDRG,0)),"^",5,8)
+2 NEW Q,X
SET X=""
+3 FOR Q=1:1:$LENGTH(APP)
SET X=$EXTRACT(APP,Q)
IF X=""
QUIT
SET X=$ORDER(^PS(50.3,+PDRG,1,"B",X,0))
IF X
SET X=$PIECE($GET(^PS(50.3,+PDRG,1,X,0)),"^",5,8)
QUIT
+4 QUIT X
