PSGOE92 ;BIR/CML - ACTIVE ORDER EDIT (CONT.) ;2/18/10 4:15pm
;;5.0;INPATIENT MEDICATIONS ;**2,35,50,58,81,110,215,237,276,316,317,366,327,372,449**;16 DEC 97;Build 18
;
;Reference to ^DD(53.1 is supported by DBIA #2256.
;Reference to ^PS(55 is supported by DBIA #2191.
;Reference to ^PSDRUG is supported by DBIA #2192.
;Reference to $$GET^XPAR is supported by DBIA #2263
;Reference to $$SDEA^XUSER supported by DBIA #2343
;
1 ; provider
S MSG=0,PSGF2=1 S:PSGOEEF(PSGF2) BACK="1^PSGOE92"
A1 I $G(PSJORD),$G(PSGP) I $$COMPLEX^PSJOE(PSGP,PSJORD) S PSGOEE=0 D G DONE
. W !!?5,"Provider may not be edited for active complex orders." D PAUSE^VALM1
W !,"PROVIDER: ",$S(PSGPR:PSGPRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
;; START NCC T4 MODS >> 327*RJS
S PSTMPI=PSGPR,PSTMPN=PSGPRN
I $S(X="":'PSGPR,1:X="@") W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(55.06,1) G A1
I +$G(ANQX) G A2
I X="",PSGPR S X=PSGPRN I PSGPR'=PSGPRN,$L($$GET1^DIQ(200,PSGPR,53.1)) G DONE
I X?1."?" D ENHLP^PSGOEM(55.06,1)
I $E(X)="^" D ENFF G:Y>0 @Y G A1
;*366 - check provider credentials
K DIC S DIC="^VA(200,",DIC(0)="EMQZ",DIC("S")="I $$ACTPRO^PSGOE1(+Y)" D ^DIC K DIC I Y'>0 G A1
A2 D CLOZPRV^PSGOE82
I $G(ANQX) W ! S PSGPR=PSTMPI,PSGPRN=PSTMPN K PSTMPN,PSTMPI,ANQX G A1
;; END NCC T4 MODS << 327*RJS
S PSGPR=+Y,PSGPRN=Y(0,0)
N PSJDEA,PSDEA,PDEA,PSPPKG
I $G(PSGPDRG)]"" D
.S PSPPKG=$S(PSJPROT=1:"U",PSJPROT=3:"UI",1:"") Q:PSPPKG=""
.S PSJDEA=$$OIDEA^PSSOPKI(PSGPDRG,PSPPKG),PSDEA=$P(PSJDEA,";",2) I +PSDEA>=2,+PSDEA<=5 S PDEA=$$SDEA^XUSER(,+PSGPR,PSDEA,,"I")
I ($G(PDEA)=2)!($G(PDEA)=1)!(+$G(PDEA)=4) D G A1
.W !,"Provider not authorized to prescribe medications in Federal Schedule "_PSDEA_".",!,"Please contact the provider.",!
.S PSGPR=PSTMPI,PSGPRN=PSTMPN K PSTMPN,PSTMPI
G DONE
;
5 ; self med
I $G(PSJORD),$G(PSGP) I $$COMPLEX^PSJOE(PSGP,PSJORD) S PSGOEE=0 D G DONE
. W !!?5,"Self Med may not be edited for active complex orders." D PAUSE^VALM1
S MSG=0,PSGF2=5 S:PSGOEEF(PSGF2) BACK="5^PSGOE92" K PSGOEEF(6) S:PSGSM PSGOEEF(6)=""
A5 W !,"SELF MED: " W:PSGSM]"" $P("NO^YES","^",PSGSM+1),"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
I "01"[X,$L(X)<2 S:X]"" PSGSM=+X W:PSGSM]"" " (",$P("NO^YES","^",PSGSM+1),")" G:'PSGSM DONE S PSGOEEF(6)="" G 6
I X="@" W $C(7)," (Required)" G A5
I X?1"^".E D ENFF G:Y>0 @Y G A5
I X?1."?" D ENHLP^PSGOEM(55.06,5) G A5
D YN I S PSGSM=$E(X)="Y" K PSGOEEF(6) G:'PSGSM DONE S PSGOEEF(6)="" G 6
W $C(7) D ENHLP^PSGOEM(55.06,5) G A5
;
6 ; hospital supplied self med
S MSG=0,PSGF2=6 S:PSGOEEF(PSGF2) BACK="6^PSGOE92"
A6 I $G(PSJORD),$G(PSGP) I $$COMPLEX^PSJOE(PSGP,PSJORD) S PSGOEE=0 D G DONE
. W !!?5,"Hospital Supplied Self Med may not be edited for active complex orders." D PAUSE^VALM1
W !,"HOSPITAL SUPPLIED SELF MED: " W:PSGHSM]"" $P("NO^YES","^",PSGHSM+1),"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
I "01"[X,$L(X)=1 S:X]"" PSGHSM=+X W " (",$P("NO^YES","^",PSGHSM+1),")" S MSG=0,PSGF2=5 G DONE
I X="@" W $C(7)," (Required)" G A6
I X?1"^".E D ENFF G:Y>0 @Y G A6
I X?1."?" D ENHLP^PSGOEM(55.06,6) G A6
D YN I S PSGHSM=$E(X)="Y" S MSG=0,PSGF2=5 G DONE
W $C(7) D ENHLP^PSGOEM(55.06,6) G A6
;
2 ; dispense drug multiple
;*276 - Disallow unauthorized nurses from editing Dispense Drug
I '$P($G(PSJSYSU),";",4) W !,"You are not authorized to edit Dispense Drugs." D PAUSE^VALM1 Q
I $G(PSGP),$G(PSGORD) I $$COMPLEX^PSJOE(PSGP,PSGORD) D
.N X,Y,PARENT S PARENT=$S(PSGORD["U":$$GET1^DIQ(55.06,+PSGORD_","_PSGP,125,"I"),1:$$GET1^DIQ(53.1,+PSGORD,125,"I"))
.I PARENT D FULL^VALM1 W !!?5,"This order is part of a complex order. Please review the following ",!?5,"associated orders before changing this order." D CMPLX^PSJCOM1(PSGP,PARENT,PSGORD)
S MSG=0,PSGF2=2,BACK="2^PSGOE92",PSGOEEND=1
N PSGX,ARRAY D LIST^DIC(53.4502,","_PSJSYSP_",",,"I",,,,,,,"ARRAY") S PSGX=+ARRAY("DILIST",0)
; PSJ*5*317 - If PSJ PADE OE BALANCES parameter is YES, PADE balances should display as identifier.
N PSJPADLK S PSJPADLK=0 ; Flag indicating PADE drug lookup was done, don't do drug lookup twice - PSJ*5*317
I $$GET^XPAR("SYS","PSJ PADE OE BALANCES") D
.N DA,DIC,DIE,DR,DIR,PSJLOC,PSJDRG,PSJDDC,PSJORD,DFN,PSJORCL,PSJCLNK,PSJCLND S PSJCLND=""
.; If clinic order, quit if clinic location is not linked to PADE
.I $G(PSGORD)["P" S PSJCLND=$$GET1^DIQ(53.1,+$G(PSGORD),113,"I")_"^"_$$GET1^DIQ(53.1,+$G(PSGORD),126,"I") I 1
.E I $G(PSGORD)["U" S PSJCLND=$$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 PSJCLND=$$GET1^DIQ(55.01,+$G(PSGORD)_","_+$G(PSGP),136,"I")_"^"_$$GET1^DIQ(55.01,+$G(PSGORD)_","_+$G(PSGP),139,"I")
.S PSJORCL=$S(PSJCLND&$P(PSJCLND,"^",2):+PSJCLND_"C",1:"")
.I PSJORCL S PSJCLNK=$$PADECL^PSJPAD50(+$G(PSJORCL)) Q:'PSJCLNK
.I '$G(PSJCLNK) Q:'$$PADEWD^PSJPAD50(+$G(VAIN(4)))
.S DFN=$G(PSGP),PSJORD=$G(PSGORD)
.N ARRAY D LIST^DIC(53.4502,","_PSJSYSP_",",,"I",,,,,,,"ARRAY")
.F I=1:1 Q:'$D(ARRAY("DILIST",2,I)) S PSJDDC=ARRAY("DILIST",2,I),PSJDRG(PSJDDC)=$$GET1^DIQ(53.4502,PSJDDC_","_PSJSYSP,.01,"I")
.S PSJLOC=$S($G(PSJORD)["U":+$$GET1^DIQ(55.06,+PSJORD_","_DFN,130,"I")_"C",$G(PSJORD)["P":+$$GET1^DIQ(53.1,+$G(PSGORD),113,"I")_"C",1:"")
.S:'PSJLOC PSJLOC=+$G(VAIN(4)) I '$G(PSJLOC) D
..N VAIN D INP^VADPT S PSJLOC=$G(VAIN(4))
.S PSJPADLK=1
.D READDD^PSJPAD50(.PSJDRG,$G(PSGPDRG),PSJLOC,PSJORD,$G(PSGORD))
; PSJ*5*317 - If PSJ PADE OE BALANCES parameter is NO, PADE balances should NOT display as identifer.
I '$G(PSJPADLK) N DA,DIE,DR S DIE="^PS(53.45,",DA=PSJSYSP,DR=2,DR(2,53.4502)=".02//1;.03" D ^DIE
I '$G(ARRAY("DILIST",0)) W $C(7),!!,"WARNING: This order must have at least one dispense drug before pharmacy can",!?9,"verify it!",! S MSG=1
D DDOC^PSGOE82(PSGX) ;* Perform allergy/adv. reaction order checks
N PSJDOSE
D DOSECHK^PSJDOSE
;PSJ*5*449 Display 0 unit Per Dose warning
I +$G(PSJDSFLG0) D DSPWARN0^PSJDOSE
I +$G(PSJDSFLG) D DSPWARN^PSJDOSE S:$G(PSGOEEF(109))="" PSGOEEF(109)=1 ; PSJ*5*237 - Check PSGOEEF(109) to prevent infinite loop
;PSJ*5*449 pause moved here from PSJDOSE
I PSJDSFLG0!+$G(PSJDSFLG) D PAUSE^VALM1
; PSJ*5*215 - If Dispense Drug(s) changed, make entry in Activity Log.
; Compare the edited dispense drug information in ^PS(53.45 to the active
; order dispense drug information in ^PS(55.
S (PSJDDTMP,PSJDD55,PSJDTMP1,PSJDD551)=""
N ARRAY D LIST^DIC(53.4502,","_PSJSYSP_",",.02,"I",,,,,,,"ARRAY")
F I=1:1 Q:'$D(ARRAY("DILIST",2,I)) S PSJDDTMP=ARRAY("DILIST",2,I) D
.S PSJDDTMP(PSJDDTMP)=ARRAY("DILIST",1,I)_"^"_ARRAY("DILIST","ID",I,.02)
.S PSJDTMP1="Disp Drug: "_"("_$P($G(PSJDDTMP(PSJDDTMP)),"^",1)_") "_$$GET1^DIQ(50,$P($G(PSJDDTMP(PSJDDTMP)),"^",1),.01)_" Units: "_$P($G(PSJDDTMP(PSJDDTMP)),"^",2)_" "
N ARR1 D LIST^DIC(55.07,","_+ON_","_DFN_",",.02,"I",,,,,,,"ARR1")
F I=1:1 Q:'$D(ARR1("DILIST",2,I)) S PSJDD55=ARR1("DILIST",2,I) D
.S PSJDD55(PSJDD55)=ARR1("DILIST",1,I)_"^"_ARR1("DILIST","ID",I,.02)
.S PSJDD551="Disp Drug: "_"("_$P($G(PSJDD55(PSJDD55)),"^",1)_") "_$$GET1^DIQ(50,$P($G(PSJDD55(PSJDD55)),"^",1),.01)_" Units: "_$P($G(PSJDD55(PSJDD55)),"^",2)_" "
; If the two temporary strings PSJDTMP1 and PSJDD551 do not match each other exactly
; then an edit has been made to the Dispense Drug Field. Make a new entry in
; the Activity Log for this order.
I PSJDTMP1'=PSJDD551 D NEWUDAL^PSGAL5(DFN,+ON,6000,"Dispense Drug",PSJDD551)
K PSGOEEND,PSJDDTMP,PSJDTMP1,PSJDD55,PSJDD551 G DONE
;
15 ; comments
I $G(PSJORD),$G(PSGP) I $$COMPLEX^PSJOE(PSGP,PSJORD) S PSGOEE=0 D G DONE
. W !!?5,"Comments may not be edited for active complex orders." D PAUSE^VALM1
S MSG=0,PSGF2=15,BACK="15^PSGOE92",DA=PSJSYSP,DR=1,DIE="^PS(53.45," D ^DIE W ! G DONE
;
72 ; provider comments
;
DONE ;
I PSGOEE G:'PSGOEEF(PSGF2) @BACK S PSGOEE=PSGOEEF(PSGF2)
K F,F0,PSGF2,F3,PSG,SDT Q
;
ENFF ; up-arrow to another field
S Y=-1 I '$D(PSGOEEF) W $C(7)," ??" Q
S X=$E(X,2,99) I X=+X S Y=$S($D(PSGOEEF(X)):X,1:-1) W " " W:Y>0 $$CODES2^PSIVUTL(53.1,X) W:Y'>0 $C(7),"??" Q
K DIC S DIC="^DD(53.1,",DIC(0)="QEM",DIC("S")="I $D(PSGOEEF(+Y))" D ^DIC K DIC S Y=+Y S:Y>0 Y=$P($T(@("F"_Y)),";",3) Q
;
DEL ; delete entry
W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7)," <NOTHING DELETED>"
Q
;
YN ; yes/no as a set of codes
I X'?.U F Y=1:1:$L(X) I $E(X,Y)?1L S X=$E(X,1,Y-1)_$C($A(X,Y)-32)_$E(X,Y+1,$L(X))
F Y="NO","YES" I $P(Y,X)="" W $P(Y,X,2) Q
Q
;
F101 ;;101^PSGOE9
F109 ;;109^PSGOE9
F3 ;;3^PSGOE9
F7 ;;7^PSGOE9
PSGF26 ;;26^PSGOE9
F41 ;;41^PSGOE91
F8 ;;8^PSGOE91
F10 ;;10^PSGOE91
F34 ;;34^PSGOE91
F1 ;;1^PSGOE92
F5 ;;5^PSGOE92
PSGF2 ;;2^PSGOE92
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOE92 8793 printed Sep 23, 2025@19:38:10 Page 2
PSGOE92 ;BIR/CML - ACTIVE ORDER EDIT (CONT.) ;2/18/10 4:15pm
+1 ;;5.0;INPATIENT MEDICATIONS ;**2,35,50,58,81,110,215,237,276,316,317,366,327,372,449**;16 DEC 97;Build 18
+2 ;
+3 ;Reference to ^DD(53.1 is supported by DBIA #2256.
+4 ;Reference to ^PS(55 is supported by DBIA #2191.
+5 ;Reference to ^PSDRUG is supported by DBIA #2192.
+6 ;Reference to $$GET^XPAR is supported by DBIA #2263
+7 ;Reference to $$SDEA^XUSER supported by DBIA #2343
+8 ;
1 ; provider
+1 SET MSG=0
SET PSGF2=1
if PSGOEEF(PSGF2)
SET BACK="1^PSGOE92"
A1 IF $GET(PSJORD)
IF $GET(PSGP)
IF $$COMPLEX^PSJOE(PSGP,PSJORD)
SET PSGOEE=0
Begin DoDot:1
+1 WRITE !!?5,"Provider may not be edited for active complex orders."
DO PAUSE^VALM1
End DoDot:1
GOTO DONE
+2 WRITE !,"PROVIDER: ",$SELECT(PSGPR:PSGPRN_"// ",1:"")
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOEE=0
GOTO DONE
+3 ;; START NCC T4 MODS >> 327*RJS
+4 SET PSTMPI=PSGPR
SET PSTMPN=PSGPRN
+5 IF $SELECT(X="":'PSGPR,1:X="@")
WRITE $CHAR(7)," (Required)"
SET X="?"
DO ENHLP^PSGOEM(55.06,1)
GOTO A1
+6 IF +$GET(ANQX)
GOTO A2
+7 IF X=""
IF PSGPR
SET X=PSGPRN
IF PSGPR'=PSGPRN
IF $LENGTH($$GET1^DIQ(200,PSGPR,53.1))
GOTO DONE
+8 IF X?1."?"
DO ENHLP^PSGOEM(55.06,1)
+9 IF $EXTRACT(X)="^"
DO ENFF
if Y>0
GOTO @Y
GOTO A1
+10 ;*366 - check provider credentials
+11 KILL DIC
SET DIC="^VA(200,"
SET DIC(0)="EMQZ"
SET DIC("S")="I $$ACTPRO^PSGOE1(+Y)"
DO ^DIC
KILL DIC
IF Y'>0
GOTO A1
A2 DO CLOZPRV^PSGOE82
+1 IF $GET(ANQX)
WRITE !
SET PSGPR=PSTMPI
SET PSGPRN=PSTMPN
KILL PSTMPN,PSTMPI,ANQX
GOTO A1
+2 ;; END NCC T4 MODS << 327*RJS
+3 SET PSGPR=+Y
SET PSGPRN=Y(0,0)
+4 NEW PSJDEA,PSDEA,PDEA,PSPPKG
+5 IF $GET(PSGPDRG)]""
Begin DoDot:1
+6 SET PSPPKG=$SELECT(PSJPROT=1:"U",PSJPROT=3:"UI",1:"")
if PSPPKG=""
QUIT
+7 SET PSJDEA=$$OIDEA^PSSOPKI(PSGPDRG,PSPPKG)
SET PSDEA=$PIECE(PSJDEA,";",2)
IF +PSDEA>=2
IF +PSDEA<=5
SET PDEA=$$SDEA^XUSER(,+PSGPR,PSDEA,,"I")
End DoDot:1
+8 IF ($GET(PDEA)=2)!($GET(PDEA)=1)!(+$GET(PDEA)=4)
Begin DoDot:1
+9 WRITE !,"Provider not authorized to prescribe medications in Federal Schedule "_PSDEA_".",!,"Please contact the provider.",!
+10 SET PSGPR=PSTMPI
SET PSGPRN=PSTMPN
KILL PSTMPN,PSTMPI
End DoDot:1
GOTO A1
+11 GOTO DONE
+12 ;
5 ; self med
+1 IF $GET(PSJORD)
IF $GET(PSGP)
IF $$COMPLEX^PSJOE(PSGP,PSJORD)
SET PSGOEE=0
Begin DoDot:1
+2 WRITE !!?5,"Self Med may not be edited for active complex orders."
DO PAUSE^VALM1
End DoDot:1
GOTO DONE
+3 SET MSG=0
SET PSGF2=5
if PSGOEEF(PSGF2)
SET BACK="5^PSGOE92"
KILL PSGOEEF(6)
if PSGSM
SET PSGOEEF(6)=""
A5 WRITE !,"SELF MED: "
if PSGSM]""
WRITE $PIECE("NO^YES","^",PSGSM+1),"// "
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOEE=0
GOTO DONE
+1 IF "01"[X
IF $LENGTH(X)<2
if X]""
SET PSGSM=+X
if PSGSM]""
WRITE " (",$PIECE("NO^YES","^",PSGSM+1),")"
if 'PSGSM
GOTO DONE
SET PSGOEEF(6)=""
GOTO 6
+2 IF X="@"
WRITE $CHAR(7)," (Required)"
GOTO A5
+3 IF X?1"^".E
DO ENFF
if Y>0
GOTO @Y
GOTO A5
+4 IF X?1."?"
DO ENHLP^PSGOEM(55.06,5)
GOTO A5
+5 DO YN
IF $TEST
SET PSGSM=$EXTRACT(X)="Y"
KILL PSGOEEF(6)
if 'PSGSM
GOTO DONE
SET PSGOEEF(6)=""
GOTO 6
+6 WRITE $CHAR(7)
DO ENHLP^PSGOEM(55.06,5)
GOTO A5
+7 ;
6 ; hospital supplied self med
+1 SET MSG=0
SET PSGF2=6
if PSGOEEF(PSGF2)
SET BACK="6^PSGOE92"
A6 IF $GET(PSJORD)
IF $GET(PSGP)
IF $$COMPLEX^PSJOE(PSGP,PSJORD)
SET PSGOEE=0
Begin DoDot:1
+1 WRITE !!?5,"Hospital Supplied Self Med may not be edited for active complex orders."
DO PAUSE^VALM1
End DoDot:1
GOTO DONE
+2 WRITE !,"HOSPITAL SUPPLIED SELF MED: "
if PSGHSM]""
WRITE $PIECE("NO^YES","^",PSGHSM+1),"// "
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOEE=0
GOTO DONE
+3 IF "01"[X
IF $LENGTH(X)=1
if X]""
SET PSGHSM=+X
WRITE " (",$PIECE("NO^YES","^",PSGHSM+1),")"
SET MSG=0
SET PSGF2=5
GOTO DONE
+4 IF X="@"
WRITE $CHAR(7)," (Required)"
GOTO A6
+5 IF X?1"^".E
DO ENFF
if Y>0
GOTO @Y
GOTO A6
+6 IF X?1."?"
DO ENHLP^PSGOEM(55.06,6)
GOTO A6
+7 DO YN
IF $TEST
SET PSGHSM=$EXTRACT(X)="Y"
SET MSG=0
SET PSGF2=5
GOTO DONE
+8 WRITE $CHAR(7)
DO ENHLP^PSGOEM(55.06,6)
GOTO A6
+9 ;
2 ; dispense drug multiple
+1 ;*276 - Disallow unauthorized nurses from editing Dispense Drug
+2 IF '$PIECE($GET(PSJSYSU),";",4)
WRITE !,"You are not authorized to edit Dispense Drugs."
DO PAUSE^VALM1
QUIT
+3 IF $GET(PSGP)
IF $GET(PSGORD)
IF $$COMPLEX^PSJOE(PSGP,PSGORD)
Begin DoDot:1
+4 NEW X,Y,PARENT
SET PARENT=$SELECT(PSGORD["U":$$GET1^DIQ(55.06,+PSGORD_","_PSGP,125,"I"),1:$$GET1^DIQ(53.1,+PSGORD,125,"I"))
+5 IF PARENT
DO FULL^VALM1
WRITE !!?5,"This order is part of a complex order. Please review the following ",!?5,"associated orders before changing this order."
DO CMPLX^PSJCOM1(PSGP,PARENT,PSGORD)
End DoDot:1
+6 SET MSG=0
SET PSGF2=2
SET BACK="2^PSGOE92"
SET PSGOEEND=1
+7 NEW PSGX,ARRAY
DO LIST^DIC(53.4502,","_PSJSYSP_",",,"I",,,,,,,"ARRAY")
SET PSGX=+ARRAY("DILIST",0)
+8 ; PSJ*5*317 - If PSJ PADE OE BALANCES parameter is YES, PADE balances should display as identifier.
+9 ; Flag indicating PADE drug lookup was done, don't do drug lookup twice - PSJ*5*317
NEW PSJPADLK
SET PSJPADLK=0
+10 IF $$GET^XPAR("SYS","PSJ PADE OE BALANCES")
Begin DoDot:1
+11 NEW DA,DIC,DIE,DR,DIR,PSJLOC,PSJDRG,PSJDDC,PSJORD,DFN,PSJORCL,PSJCLNK,PSJCLND
SET PSJCLND=""
+12 ; If clinic order, quit if clinic location is not linked to PADE
+13 IF $GET(PSGORD)["P"
SET PSJCLND=$$GET1^DIQ(53.1,+$GET(PSGORD),113,"I")_"^"_$$GET1^DIQ(53.1,+$GET(PSGORD),126,"I")
IF 1
+14 IF '$TEST
IF $GET(PSGORD)["U"
SET PSJCLND=$$GET1^DIQ(55.06,+$GET(PSGORD)_","_+$GET(PSGP),130,"I")_"^"_$$GET1^DIQ(55.06,+$GET(PSGORD)_","_+$GET(PSGP),131,"I")
IF 1
+15 IF '$TEST
IF $GET(PSGORD)["V"
SET PSJCLND=$$GET1^DIQ(55.01,+$GET(PSGORD)_","_+$GET(PSGP),136,"I")_"^"_$$GET1^DIQ(55.01,+$GET(PSGORD)_","_+$GET(PSGP),139,"I")
+16 SET PSJORCL=$SELECT(PSJCLND&$PIECE(PSJCLND,"^",2):+PSJCLND_"C",1:"")
+17 IF PSJORCL
SET PSJCLNK=$$PADECL^PSJPAD50(+$GET(PSJORCL))
if 'PSJCLNK
QUIT
+18 IF '$GET(PSJCLNK)
if '$$PADEWD^PSJPAD50(+$GET(VAIN(4)))
QUIT
+19 SET DFN=$GET(PSGP)
SET PSJORD=$GET(PSGORD)
+20 NEW ARRAY
DO LIST^DIC(53.4502,","_PSJSYSP_",",,"I",,,,,,,"ARRAY")
+21 FOR I=1:1
if '$DATA(ARRAY("DILIST",2,I))
QUIT
SET PSJDDC=ARRAY("DILIST",2,I)
SET PSJDRG(PSJDDC)=$$GET1^DIQ(53.4502,PSJDDC_","_PSJSYSP,.01,"I")
+22 SET PSJLOC=$SELECT($GET(PSJORD)["U":+$$GET1^DIQ(55.06,+PSJORD_","_DFN,130,"I")_"C",$GET(PSJORD)["P":+$$GET1^DIQ(53.1,+$GET(PSGORD),113,"I")_"C",1:"")
+23 if 'PSJLOC
SET PSJLOC=+$GET(VAIN(4))
IF '$GET(PSJLOC)
Begin DoDot:2
+24 NEW VAIN
DO INP^VADPT
SET PSJLOC=$GET(VAIN(4))
End DoDot:2
+25 SET PSJPADLK=1
+26 DO READDD^PSJPAD50(.PSJDRG,$GET(PSGPDRG),PSJLOC,PSJORD,$GET(PSGORD))
End DoDot:1
+27 ; PSJ*5*317 - If PSJ PADE OE BALANCES parameter is NO, PADE balances should NOT display as identifer.
+28 IF '$GET(PSJPADLK)
NEW DA,DIE,DR
SET DIE="^PS(53.45,"
SET DA=PSJSYSP
SET DR=2
SET DR(2,53.4502)=".02//1;.03"
DO ^DIE
+29 IF '$GET(ARRAY("DILIST",0))
WRITE $CHAR(7),!!,"WARNING: This order must have at least one dispense drug before pharmacy can",!?9,"verify it!",!
SET MSG=1
+30 ;* Perform allergy/adv. reaction order checks
DO DDOC^PSGOE82(PSGX)
+31 NEW PSJDOSE
+32 DO DOSECHK^PSJDOSE
+33 ;PSJ*5*449 Display 0 unit Per Dose warning
+34 IF +$GET(PSJDSFLG0)
DO DSPWARN0^PSJDOSE
+35 ; PSJ*5*237 - Check PSGOEEF(109) to prevent infinite loop
IF +$GET(PSJDSFLG)
DO DSPWARN^PSJDOSE
if $GET(PSGOEEF(109))=""
SET PSGOEEF(109)=1
+36 ;PSJ*5*449 pause moved here from PSJDOSE
+37 IF PSJDSFLG0!+$GET(PSJDSFLG)
DO PAUSE^VALM1
+38 ; PSJ*5*215 - If Dispense Drug(s) changed, make entry in Activity Log.
+39 ; Compare the edited dispense drug information in ^PS(53.45 to the active
+40 ; order dispense drug information in ^PS(55.
+41 SET (PSJDDTMP,PSJDD55,PSJDTMP1,PSJDD551)=""
+42 NEW ARRAY
DO LIST^DIC(53.4502,","_PSJSYSP_",",.02,"I",,,,,,,"ARRAY")
+43 FOR I=1:1
if '$DATA(ARRAY("DILIST",2,I))
QUIT
SET PSJDDTMP=ARRAY("DILIST",2,I)
Begin DoDot:1
+44 SET PSJDDTMP(PSJDDTMP)=ARRAY("DILIST",1,I)_"^"_ARRAY("DILIST","ID",I,.02)
+45 SET PSJDTMP1="Disp Drug: "_"("_$PIECE($GET(PSJDDTMP(PSJDDTMP)),"^",1)_") "_$$GET1^DIQ(50,$PIECE($GET(PSJDDTMP(PSJDDTMP)),"^",1),.01)_" Units: "_$PIECE($GET(PSJDDTMP(PSJDDTMP)),"^",2)_" "
End DoDot:1
+46 NEW ARR1
DO LIST^DIC(55.07,","_+ON_","_DFN_",",.02,"I",,,,,,,"ARR1")
+47 FOR I=1:1
if '$DATA(ARR1("DILIST",2,I))
QUIT
SET PSJDD55=ARR1("DILIST",2,I)
Begin DoDot:1
+48 SET PSJDD55(PSJDD55)=ARR1("DILIST",1,I)_"^"_ARR1("DILIST","ID",I,.02)
+49 SET PSJDD551="Disp Drug: "_"("_$PIECE($GET(PSJDD55(PSJDD55)),"^",1)_") "_$$GET1^DIQ(50,$PIECE($GET(PSJDD55(PSJDD55)),"^",1),.01)_" Units: "_$PIECE($GET(PSJDD55(PSJDD55)),"^",2)_" "
End DoDot:1
+50 ; If the two temporary strings PSJDTMP1 and PSJDD551 do not match each other exactly
+51 ; then an edit has been made to the Dispense Drug Field. Make a new entry in
+52 ; the Activity Log for this order.
+53 IF PSJDTMP1'=PSJDD551
DO NEWUDAL^PSGAL5(DFN,+ON,6000,"Dispense Drug",PSJDD551)
+54 KILL PSGOEEND,PSJDDTMP,PSJDTMP1,PSJDD55,PSJDD551
GOTO DONE
+55 ;
15 ; comments
+1 IF $GET(PSJORD)
IF $GET(PSGP)
IF $$COMPLEX^PSJOE(PSGP,PSJORD)
SET PSGOEE=0
Begin DoDot:1
+2 WRITE !!?5,"Comments may not be edited for active complex orders."
DO PAUSE^VALM1
End DoDot:1
GOTO DONE
+3 SET MSG=0
SET PSGF2=15
SET BACK="15^PSGOE92"
SET DA=PSJSYSP
SET DR=1
SET DIE="^PS(53.45,"
DO ^DIE
WRITE !
GOTO DONE
+4 ;
72 ; provider comments
+1 ;
DONE ;
+1 IF PSGOEE
if 'PSGOEEF(PSGF2)
GOTO @BACK
SET PSGOEE=PSGOEEF(PSGF2)
+2 KILL F,F0,PSGF2,F3,PSG,SDT
QUIT
+3 ;
ENFF ; up-arrow to another field
+1 SET Y=-1
IF '$DATA(PSGOEEF)
WRITE $CHAR(7)," ??"
QUIT
+2 SET X=$EXTRACT(X,2,99)
IF X=+X
SET Y=$SELECT($DATA(PSGOEEF(X)):X,1:-1)
WRITE " "
if Y>0
WRITE $$CODES2^PSIVUTL(53.1,X)
if Y'>0
WRITE $CHAR(7),"??"
QUIT
+3 KILL DIC
SET DIC="^DD(53.1,"
SET DIC(0)="QEM"
SET DIC("S")="I $D(PSGOEEF(+Y))"
DO ^DIC
KILL DIC
SET Y=+Y
if Y>0
SET Y=$PIECE($TEXT(@("F"_Y)),";",3)
QUIT
+4 ;
DEL ; delete entry
+1 WRITE !?3,"SURE YOU WANT TO DELETE"
SET %=0
DO YN^DICN
IF %'=1
WRITE $CHAR(7)," <NOTHING DELETED>"
+2 QUIT
+3 ;
YN ; yes/no as a set of codes
+1 IF X'?.U
FOR Y=1:1:$LENGTH(X)
IF $EXTRACT(X,Y)?1L
SET X=$EXTRACT(X,1,Y-1)_$CHAR($ASCII(X,Y)-32)_$EXTRACT(X,Y+1,$LENGTH(X))
+2 FOR Y="NO","YES"
IF $PIECE(Y,X)=""
WRITE $PIECE(Y,X,2)
QUIT
+3 QUIT
+4 ;
F101 ;;101^PSGOE9
F109 ;;109^PSGOE9
F3 ;;3^PSGOE9
F7 ;;7^PSGOE9
PSGF26 ;;26^PSGOE9
F41 ;;41^PSGOE91
F8 ;;8^PSGOE91
F10 ;;10^PSGOE91
F34 ;;34^PSGOE91
F1 ;;1^PSGOE92
F5 ;;5^PSGOE92
PSGF2 ;;2^PSGOE92
