PSGOE7.m

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