- 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 Jan 18, 2025@03:03:11 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