PSGOE7 ;BIR/CML3 - SELECT DRUG ;Mar 25, 2020@13:21:35
;;5.0;INPATIENT MEDICATIONS;**9,26,34,52,55,50,87,111,181,254,267,260,288,281,317,355,327,319,415**;16 DEC 97;Build 3
;
; 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
; Reference to ^PSNAPIS is supported by DBIA 2531
; Reference to $$GET^XPAR is supported by DBIA 2263
; Reference to ^VADPT is supported by DBIA 10061
; Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
; NFI-UD chgs for FR#: 1
;
S PSGDICS="U"
;
AD ; Ask Drug
K PSJDOSE,PSJDOX ;var array use in ^PSJDOSE
K PSGODO,^TMP("PSJINTER",$J) D KILL^PSJBCMA5(+$G(PSJSYSP))
D ENKILL^PSJLMUDE
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"")"
N PSJTABS,PSJPLTYP,PSJPDLOC
E D
.I '$D(PSJDGCK) S DIC("T")="",DIC="^PSDRUG(",DIC("S")="I $$GET1^DIQ(50,+Y,2.1,""I""),$$GET1^DIQ(50,+Y,63)[""U"" S X(1)=+$$GET1^DIQ(50,+Y,100,""I"") I $S('X(1):1,1:X(1)>DT)",D="B^C^VAPN^VAC^NDC^XATC"
.I $D(PSJDGCK) S DIC("T")="",DIC="^PSDRUG(",DIC("S")="I $$GET1^DIQ(50,+Y,2.1,""I""),$$GCN^PSGOE7(+Y),$$PKGFLG^PSGOE7($$GET1^DIQ(50,+Y,63)) S X(1)=+$$GET1^DIQ(50,+Y,100,""I"") I $S('X(1):1,1:X(1)>DT)",D="B^C^VAPN^VAC^NDC^XATC"
;
AD1 ;
K PSGORD,PSJORD,PSJALLGY,PSGUSRX,^TMP("PSJINTER",$J),^PS(53.45,+$G(PSJSYSP),5),^PS(53.45,+$G(PSJSYSP),6),PSJPLTYP,PSJPDLOC
K ^TMP("PSODAOC",$J)
S PSGORQF=0 R !!,"Select DRUG: ",X:DTIME I '$T W $C(7) S X="^"
; -- save off value of X in PSGUSRX so variable can be reliable checked at DO tag
S PSGUSRX=X
I $D(PSJDGCK) I ($G(PSJOCNT)=1&(X="")) D Q
.W !!,"Not enough active profile drugs to perform drug check",!
.K DIR S DIR(0)="E",DIR("A")="Press Return to Continue..." D ^DIR K DIR W @IOF
I $D(PSJDGCK),X="" N PSGDGCKF S PSGDGCKF=1 G DGCKX
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 !
; PSJ*5*317 - PADE - Define PADE identifier for lookups if kernel parameter turned on
I $$GET^XPAR("SYS","PSJ PADE OE BALANCES") N PSJTABS,DFN N:'$G(VAIN(4))&$G(PSGP) VAIN D
.N PSJORCL,PSJCLNK K DIC("W")
.S DFN=$G(PSGP)
.I $P(PSJPCAF,"^",2),'$G(VAIN(4)),$G(DFN) D INP^VADPT
.; If clinic order, quit if clinic location is not linked to PADE
.S PSJORCL="" I $G(PSJCLAPP) S PSJORCL=PSJCLAPP I 1 ;p319 - Clinic order
.E I $G(PSGORD)["P" S PSJORCL=$$GET1^DIQ(53.1,+$G(PSGORD),113,"I")_"^"_$$GET1^DIQ(53.1,+$G(PSGORD),126,"I") I 1
.E I $G(PSGORD)["U" S PSJORCL=$$GET1^DIQ(55.06,+$G(PSGORD)_","_+$G(PSGP),130,"I")_"^"_$$GET1^DIQ(55.06,+$G(PSGORD)_","_+$G(PSGP),131,"I") I 1
.E I $G(PSGORD)["V" S PSJORCL=$$GET1^DIQ(55.01,+$G(PSGORD)_","_+$G(PSGP),136,"I")_"^"_$$GET1^DIQ(55.01,+$G(PSGORD)_","_+$G(PSGP),139,"I")
.I PSJORCL,$P(PSJORCL,"^",2) S PSJCLNK=$$PADECL^PSJPAD50(+$G(PSJORCL)) Q:'PSJCLNK
.I '$G(PSJCLNK) Q:'$$PADEWD^PSJPAD50(+$G(VAIN(4)))
.S $P(PSJTABS," ",40)=""
.S PSJPLTYP=$S($G(PSJCLNK):"""CL""",1:"""WD"""),PSJPDLOC=$S(PSJPLTYP["CL":+PSJORCL,1:+$G(VAIN(4)))
.S DIC("W")="W $E(PSJTABS,1,(40-$L($S($G(DIY)]"""":$G(DIY),1:$$GET1^DIQ(50,+$G(Y),.01)))))_"" PADE: ""_$$DRGQTY^PSJPADSI(+Y,"_PSJPLTYP_","_$G(PSJPDLOC)_")_"" ""_$$GET1^DIQ(50,+Y,101)"
;
D MIX^DIC1 G:X?1."?" AD1 G:"^"[X!(Y'>0) AD1 S (PSGDO,PSGDRG,PSGDRGN,PSGNEDFD,PSGPDRG,PSGPDRGN)=""
I $D(PSJDGCK) I $$PSJSUPCK^PSJDGCK(+Y) G AD1
;
DGCKX I $P(PSJSYSU,";",4) D G DO
.S:'$D(PSJDGCK) PSGDRG=+Y,PSGDRGN=Y(0,0)
.S:$D(PSJDGCK)&'$D(PSGDGCKF) PSGDRG=+Y,PSGDRGN=Y(0,0)
.S:$D(PSJDGCK)&$D(PSGDGCKF) PSGDRG=$P($$DGCKIEN^PSJDGCK(),";",2),PSGDRGN=$$GET1^DIQ(50,PSGDRG,.01)
.D DIN^PSJDIN(+$$GET1^DIQ(50,PSGDRG,2.1,"I"),PSGDRG)
.I '$D(PSJDGCK) I $P(Y(0),"^",9) D NF S:Y>0 PSGDRG=+Y(0),PSGDRGN=Y(0,0) D SNFM
.I $D(PSJDGCK)&'$D(PSGDGCKF) I $P(Y(0),"^",9) D NF S:Y>0 PSGDRG=+Y(0),PSGDRGN=Y(0,0) D SNFM
.S PSGPDRG=+$$GET1^DIQ(50,PSGDRG,2.1,"I"),PSGPDRGN=$$OINAME^PSJLMUTL(PSGPDRG)
I '$D(PSJDGCK) S PSGPDRG=+Y,PSGPDRGN=$$OINAME^PSJLMUTL(PSGPDRG)
I $D(PSJDGCK)&'$D(PSGDGCKF) S PSGPDRG=+Y,PSGPDRGN=$$OINAME^PSJLMUTL(PSGPDRG)
D LIST^DIC(50,,.01,"I",,,PSGPDRG,"ASP",,,"ARRAY") I +ARRAY("DILIST",0)=1 S (X,PSGDRG)=ARRAY("DILIST",2,1),PSGDRGN=$$ENDDN^PSGMI(X)
;
DO ; dosage ordered
NEW PSJALLGY,PSGFLG,ANQX ;; NCC Remediation 317/327 intergation. RJS-327
S PSGNEDFD=$$GTNEDFD("U",PSGPDRG)
; -- if PSGDGCKF is set, CK action is being used and no DRUG was entered, do not set PSJALLGY array
I $G(PSGDRG),$P(PSJSYSU,";",4) D G:$G(PSGORQF) AD
.S:'$G(PSGDGCKF) PSJALLGY(PSGDRG)=$S($G(PSGUSRX)=""&($G(PSGDRG)):"",1:"P")
.D ENDDC^PSGSICHK(PSGP,PSGDRG)
;;START NCC T4 MODS >> 327*RJS
N CLOZFLG S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,,,PSGDRG)
I $P(PSJSYSU,";",4),CLOZFLG D G:$G(ANQX) AD
.D ^PSOCLO1
I '$P(PSJSYSU,";",4) D G:$G(ANQX) AD S PSGX=PSGPDRG D END^PSGSICHK G:Y<0 AD
.I CLOZFLG D ^PSOCLO1 S PSGFLG=1
;; END NCC T4 MODS << 327*RJS
S PSGDO=""
;
DONE ;
K DIC,%,%Y,PSGDICS,PSJLUAPP,Q1,Q2,Q3,Z,PSJALLGY,PSGUSRX 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
;
PKGFLG(PKF) ;Return 0 for not in range of acceptable package flags, 1 for within range
I $S(PKF["U":1,1:0) Q 1
I $S(PKF["I":1,1:0) Q 1
Q 0
;
GCN(PSGIENID) ;Return 0 for not matched, 1 for matched with no GCNSEQNO, 1^1 for matched with a GCNSEQNO
N PSGNDFID,PSGGCNPT,PSGGCNID
S PSGNDFID=$P($G(^PSDRUG(PSGIENID,"ND")),"^"),PSGGCNPT=$P($G(^PSDRUG(PSGIENID,"ND")),"^",3)
I 'PSGNDFID!('PSGGCNPT) Q 0
S PSGGCNID=$$PROD0^PSNAPIS(PSGNDFID,PSGGCNPT)
I $P(PSGGCNID,"^",7) Q PSGIENID_";"_PSGNDFID_";"_$P(PSGGCNID,"^",7)
Q PSGIENID_";"_PSGNDFID
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOE7 7399 printed Dec 13, 2024@02:01:57 Page 2
PSGOE7 ;BIR/CML3 - SELECT DRUG ;Mar 25, 2020@13:21:35
+1 ;;5.0;INPATIENT MEDICATIONS;**9,26,34,52,55,50,87,111,181,254,267,260,288,281,317,355,327,319,415**;16 DEC 97;Build 3
+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 ; Reference to ^PSNAPIS is supported by DBIA 2531
+7 ; Reference to $$GET^XPAR is supported by DBIA 2263
+8 ; Reference to ^VADPT is supported by DBIA 10061
+9 ; Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
+10 ; NFI-UD chgs for FR#: 1
+11 ;
+12 SET PSGDICS="U"
+13 ;
AD ; Ask Drug
+1 ;var array use in ^PSJDOSE
KILL PSJDOSE,PSJDOX
+2 KILL PSGODO,^TMP("PSJINTER",$JOB)
DO KILL^PSJBCMA5(+$GET(PSJSYSP))
+3 DO ENKILL^PSJLMUDE
+4 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"")"
+5 NEW PSJTABS,PSJPLTYP,PSJPDLOC
+6 IF '$TEST
Begin DoDot:1
+7 IF '$DATA(PSJDGCK)
SET DIC("T")=""
SET DIC="^PSDRUG("
SET DIC("S")="I $$GET1^DIQ(50,+Y,2.1,""I""),$$GET1^DIQ(50,+Y,63)[""U"" S X(1)=+$$GET1^DIQ(50,+Y,100,""I"") I $S('X(1):1,1:X(1)>DT)"
SET D="B^C^VAPN^VAC^NDC^XATC"
+8 IF $DATA(PSJDGCK)
SET DIC("T")=""
SET DIC="^PSDRUG("
SET DIC("S")="I $$GET1^DIQ(50,+Y,2.1,""I""),$$GCN^PSGOE7(+Y),$$PKGFLG^PSGOE7($$GET1^DIQ(50,+Y,63)) S X(1)=+$$GET1^DIQ(50,+Y,100,""I"") I $S('X(1):1,1:X(1)>DT)"
SET D="B^C^VAPN^VAC^NDC^XATC"
End DoDot:1
+9 ;
AD1 ;
+1 KILL PSGORD,PSJORD,PSJALLGY,PSGUSRX,^TMP("PSJINTER",$JOB),^PS(53.45,+$GET(PSJSYSP),5),^PS(53.45,+$GET(PSJSYSP),6),PSJPLTYP,PSJPDLOC
+2 KILL ^TMP("PSODAOC",$JOB)
+3 SET PSGORQF=0
READ !!,"Select DRUG: ",X:DTIME
IF '$TEST
WRITE $CHAR(7)
SET X="^"
+4 ; -- save off value of X in PSGUSRX so variable can be reliable checked at DO tag
+5 SET PSGUSRX=X
+6 IF $DATA(PSJDGCK)
IF ($GET(PSJOCNT)=1&(X=""))
Begin DoDot:1
+7 WRITE !!,"Not enough active profile drugs to perform drug check",!
+8 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue..."
DO ^DIR
KILL DIR
WRITE @IOF
End DoDot:1
QUIT
+9 IF $DATA(PSJDGCK)
IF X=""
NEW PSGDGCKF
SET PSGDGCKF=1
GOTO DGCKX
+10 IF ("^"[X)!(X="")
SET PSGORQF=1
GOTO DONE
+11 if X?1"S."1.E
GOTO DONE
+12 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 !
+13 ; PSJ*5*317 - PADE - Define PADE identifier for lookups if kernel parameter turned on
+14 IF $$GET^XPAR("SYS","PSJ PADE OE BALANCES")
NEW PSJTABS,DFN
if '$GET(VAIN(4))&$GET(PSGP)
NEW VAIN
Begin DoDot:1
+15 NEW PSJORCL,PSJCLNK
KILL DIC("W")
+16 SET DFN=$GET(PSGP)
+17 IF $PIECE(PSJPCAF,"^",2)
IF '$GET(VAIN(4))
IF $GET(DFN)
DO INP^VADPT
+18 ; If clinic order, quit if clinic location is not linked to PADE
+19 ;p319 - Clinic order
SET PSJORCL=""
IF $GET(PSJCLAPP)
SET PSJORCL=PSJCLAPP
IF 1
+20 IF '$TEST
IF $GET(PSGORD)["P"
SET PSJORCL=$$GET1^DIQ(53.1,+$GET(PSGORD),113,"I")_"^"_$$GET1^DIQ(53.1,+$GET(PSGORD),126,"I")
IF 1
+21 IF '$TEST
IF $GET(PSGORD)["U"
SET PSJORCL=$$GET1^DIQ(55.06,+$GET(PSGORD)_","_+$GET(PSGP),130,"I")_"^"_$$GET1^DIQ(55.06,+$GET(PSGORD)_","_+$GET(PSGP),131,"I")
IF 1
+22 IF '$TEST
IF $GET(PSGORD)["V"
SET PSJORCL=$$GET1^DIQ(55.01,+$GET(PSGORD)_","_+$GET(PSGP),136,"I")_"^"_$$GET1^DIQ(55.01,+$GET(PSGORD)_","_+$GET(PSGP),139,"I")
+23 IF PSJORCL
IF $PIECE(PSJORCL,"^",2)
SET PSJCLNK=$$PADECL^PSJPAD50(+$GET(PSJORCL))
if 'PSJCLNK
QUIT
+24 IF '$GET(PSJCLNK)
if '$$PADEWD^PSJPAD50(+$GET(VAIN(4)))
QUIT
+25 SET $PIECE(PSJTABS," ",40)=""
+26 SET PSJPLTYP=$SELECT($GET(PSJCLNK):"""CL""",1:"""WD""")
SET PSJPDLOC=$SELECT(PSJPLTYP["CL":+PSJORCL,1:+$GET(VAIN(4)))
+27 SET DIC("W")="W $E(PSJTABS,1,(40-$L($S($G(DIY)]"""":$G(DIY),1:$$GET1^DIQ(50,+$G(Y),.01)))))_"" PADE: ""_$$DRGQTY^PSJPADSI(+Y,"_PSJPLTYP_","_$GET(PSJPDLOC)_")_"" ""_$$GET1^DIQ(50,+Y,101)"
End DoDot:1
+28 ;
+29 DO MIX^DIC1
if X?1."?"
GOTO AD1
if "^"[X!(Y'>0)
GOTO AD1
SET (PSGDO,PSGDRG,PSGDRGN,PSGNEDFD,PSGPDRG,PSGPDRGN)=""
+30 IF $DATA(PSJDGCK)
IF $$PSJSUPCK^PSJDGCK(+Y)
GOTO AD1
+31 ;
DGCKX IF $PIECE(PSJSYSU,";",4)
Begin DoDot:1
+1 if '$DATA(PSJDGCK)
SET PSGDRG=+Y
SET PSGDRGN=Y(0,0)
+2 if $DATA(PSJDGCK)&'$DATA(PSGDGCKF)
SET PSGDRG=+Y
SET PSGDRGN=Y(0,0)
+3 if $DATA(PSJDGCK)&$DATA(PSGDGCKF)
SET PSGDRG=$PIECE($$DGCKIEN^PSJDGCK(),";",2)
SET PSGDRGN=$$GET1^DIQ(50,PSGDRG,.01)
+4 DO DIN^PSJDIN(+$$GET1^DIQ(50,PSGDRG,2.1,"I"),PSGDRG)
+5 IF '$DATA(PSJDGCK)
IF $PIECE(Y(0),"^",9)
DO NF
if Y>0
SET PSGDRG=+Y(0)
SET PSGDRGN=Y(0,0)
DO SNFM
+6 IF $DATA(PSJDGCK)&'$DATA(PSGDGCKF)
IF $PIECE(Y(0),"^",9)
DO NF
if Y>0
SET PSGDRG=+Y(0)
SET PSGDRGN=Y(0,0)
DO SNFM
+7 SET PSGPDRG=+$$GET1^DIQ(50,PSGDRG,2.1,"I")
SET PSGPDRGN=$$OINAME^PSJLMUTL(PSGPDRG)
End DoDot:1
GOTO DO
+8 IF '$DATA(PSJDGCK)
SET PSGPDRG=+Y
SET PSGPDRGN=$$OINAME^PSJLMUTL(PSGPDRG)
+9 IF $DATA(PSJDGCK)&'$DATA(PSGDGCKF)
SET PSGPDRG=+Y
SET PSGPDRGN=$$OINAME^PSJLMUTL(PSGPDRG)
+10 DO LIST^DIC(50,,.01,"I",,,PSGPDRG,"ASP",,,"ARRAY")
IF +ARRAY("DILIST",0)=1
SET (X,PSGDRG)=ARRAY("DILIST",2,1)
SET PSGDRGN=$$ENDDN^PSGMI(X)
+11 ;
DO ; dosage ordered
+1 ;; NCC Remediation 317/327 intergation. RJS-327
NEW PSJALLGY,PSGFLG,ANQX
+2 SET PSGNEDFD=$$GTNEDFD("U",PSGPDRG)
+3 ; -- if PSGDGCKF is set, CK action is being used and no DRUG was entered, do not set PSJALLGY array
+4 IF $GET(PSGDRG)
IF $PIECE(PSJSYSU,";",4)
Begin DoDot:1
+5 if '$GET(PSGDGCKF)
SET PSJALLGY(PSGDRG)=$SELECT($GET(PSGUSRX)=""&($GET(PSGDRG)):"",1:"P")
+6 DO ENDDC^PSGSICHK(PSGP,PSGDRG)
End DoDot:1
if $GET(PSGORQF)
GOTO AD
+7 ;;START NCC T4 MODS >> 327*RJS
+8 NEW CLOZFLG
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,,,PSGDRG)
+9 IF $PIECE(PSJSYSU,";",4)
IF CLOZFLG
Begin DoDot:1
+10 DO ^PSOCLO1
End DoDot:1
if $GET(ANQX)
GOTO AD
+11 IF '$PIECE(PSJSYSU,";",4)
Begin DoDot:1
+12 IF CLOZFLG
DO ^PSOCLO1
SET PSGFLG=1
End DoDot:1
if $GET(ANQX)
GOTO AD
SET PSGX=PSGPDRG
DO END^PSGSICHK
if Y<0
GOTO AD
+13 ;; END NCC T4 MODS << 327*RJS
+14 SET PSGDO=""
+15 ;
DONE ;
+1 KILL DIC,%,%Y,PSGDICS,PSJLUAPP,Q1,Q2,Q3,Z,PSJALLGY,PSGUSRX
QUIT
+2 ;
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
+5 ;
PKGFLG(PKF) ;Return 0 for not in range of acceptable package flags, 1 for within range
+1 IF $SELECT(PKF["U":1,1:0)
QUIT 1
+2 IF $SELECT(PKF["I":1,1:0)
QUIT 1
+3 QUIT 0
+4 ;
GCN(PSGIENID) ;Return 0 for not matched, 1 for matched with no GCNSEQNO, 1^1 for matched with a GCNSEQNO
+1 NEW PSGNDFID,PSGGCNPT,PSGGCNID
+2 SET PSGNDFID=$PIECE($GET(^PSDRUG(PSGIENID,"ND")),"^")
SET PSGGCNPT=$PIECE($GET(^PSDRUG(PSGIENID,"ND")),"^",3)
+3 IF 'PSGNDFID!('PSGGCNPT)
QUIT 0
+4 SET PSGGCNID=$$PROD0^PSNAPIS(PSGNDFID,PSGGCNPT)
+5 IF $PIECE(PSGGCNID,"^",7)
QUIT PSGIENID_";"_PSGNDFID_";"_$PIECE(PSGGCNID,"^",7)
+6 QUIT PSGIENID_";"_PSGNDFID
