PSGOENG ;BIR/CML-MARK ORDER AS 'NOT TO BE GIVEN' ;22 SEP 97 / 1:33 PM
;;5.0;INPATIENT MEDICATIONS;**58,440**;16 DEC 97;Build 1
;
; Reference to ^PS(55 is supported by DBIA 2191.
;
; PSJ*5.0*440 - Changed the evaluation of the order status as it was allowing
; Renewal orders to be marked as "Not to be Given". Also cleaned
; up header lines 1 and 2 which were throwing XINDEX errors.
;
I +$G(PSJORD)'>0 W !!," Option only available on Order View screens." H 2 G OUT
I $G(PSJORD)["V" W !," Can't mark IV orders as NOT TO BE GIVEN!" H 2 G OUT
N PSJRPH S PSJRPH=$D(^XUSEC("PSJU MGR",DUZ))!($D(^XUSEC("PSJ RPHARM",DUZ)))
I 'PSJRPH W !," Only pharmacists can mark orders Not To Be Given" H 2 G OUT
; PSJ*440 - Next line - The 'R' in 'DR' was allowing Renewals to pass through
; I PSJORD["P"!("D_E_DE_DR"'[$P($G(^PS(55,PSGP,5,+PSJORD,0)),"^",9)) D H 2 G OUT ; PSJ*440
N PSJSTS S PSJSTS=$E($P($G(^PS(55,PSGP,5,+PSJORD,0)),"^",9),1) ; PSJ*440
I PSJORD["P"!((PSJSTS'="D")&(PSJSTS'="E")) D H 2 G OUT ; PSJ*440
.W !," Only Discontinued or Expired orders may be marked as Not To Be Given."
I $P($G(^PS(55,PSGP,5,+PSJORD,.2)),U,4)="D",'$P($G(^(4)),"^",3) D H 2 G OUT
.W !,"Orders with a priority of done and not verified by a pharmacist may not",!,"be marked as Not To Be Given."
F W !!,"DO YOU WANT TO MARK THIS ORDER AS 'NOT TO BE GIVEN'" S %=2 D YN^DICN Q:% W !!,"If you answer 'YES', this order will be marked as 'NOT TO BE GIVEN'. Orders",!,"so marked cannot be renewed, reinstated, or copied."
I %=1 D
.S $P(^PS(55,PSGP,5,+PSJORD,0),"^",22)=1,PSGACT=$P(PSGACT,"N")_$P(PSGACT,"N",2),PSGOENG=1,DA(1)=PSGP,DA=+PSJORD,PSGAL("C")=23000 D ^PSGAL5 S:PSGACT["R" PSGACT=$P(PSGACT,"R")_$P(PSGACT,"R",2)
.;I ($P($G(^PS(55,PSGP,5,+PSJORD,0)),"^",21)) D EN1^PSJHL2(PSGP,"XX",PSJORD,"NOT TO BE GIVEN") K DA,PSGAL
E W " No Change made."
OUT S VALMBCK="R"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOENG 1972 printed Oct 16, 2024@18:03:06 Page 2
PSGOENG ;BIR/CML-MARK ORDER AS 'NOT TO BE GIVEN' ;22 SEP 97 / 1:33 PM
+1 ;;5.0;INPATIENT MEDICATIONS;**58,440**;16 DEC 97;Build 1
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191.
+4 ;
+5 ; PSJ*5.0*440 - Changed the evaluation of the order status as it was allowing
+6 ; Renewal orders to be marked as "Not to be Given". Also cleaned
+7 ; up header lines 1 and 2 which were throwing XINDEX errors.
+8 ;
+9 IF +$GET(PSJORD)'>0
WRITE !!," Option only available on Order View screens."
HANG 2
GOTO OUT
+10 IF $GET(PSJORD)["V"
WRITE !," Can't mark IV orders as NOT TO BE GIVEN!"
HANG 2
GOTO OUT
+11 NEW PSJRPH
SET PSJRPH=$DATA(^XUSEC("PSJU MGR",DUZ))!($DATA(^XUSEC("PSJ RPHARM",DUZ)))
+12 IF 'PSJRPH
WRITE !," Only pharmacists can mark orders Not To Be Given"
HANG 2
GOTO OUT
+13 ; PSJ*440 - Next line - The 'R' in 'DR' was allowing Renewals to pass through
+14 ; I PSJORD["P"!("D_E_DE_DR"'[$P($G(^PS(55,PSGP,5,+PSJORD,0)),"^",9)) D H 2 G OUT ; PSJ*440
+15 ; PSJ*440
NEW PSJSTS
SET PSJSTS=$EXTRACT($PIECE($GET(^PS(55,PSGP,5,+PSJORD,0)),"^",9),1)
+16 ; PSJ*440
IF PSJORD["P"!((PSJSTS'="D")&(PSJSTS'="E"))
Begin DoDot:1
+17 WRITE !," Only Discontinued or Expired orders may be marked as Not To Be Given."
End DoDot:1
HANG 2
GOTO OUT
+18 IF $PIECE($GET(^PS(55,PSGP,5,+PSJORD,.2)),U,4)="D"
IF '$PIECE($GET(^(4)),"^",3)
Begin DoDot:1
+19 WRITE !,"Orders with a priority of done and not verified by a pharmacist may not",!,"be marked as Not To Be Given."
End DoDot:1
HANG 2
GOTO OUT
+20 FOR
WRITE !!,"DO YOU WANT TO MARK THIS ORDER AS 'NOT TO BE GIVEN'"
SET %=2
DO YN^DICN
if %
QUIT
WRITE !!,"If you answer 'YES', this order will be marked as 'NOT TO BE GIVEN'. Orders",!,"so marked cannot be renewed, reinstated, or copied."
+21 IF %=1
Begin DoDot:1
+22 SET $PIECE(^PS(55,PSGP,5,+PSJORD,0),"^",22)=1
SET PSGACT=$PIECE(PSGACT,"N")_$PIECE(PSGACT,"N",2)
SET PSGOENG=1
SET DA(1)=PSGP
SET DA=+PSJORD
SET PSGAL("C")=23000
DO ^PSGAL5
if PSGACT["R"
SET PSGACT=$PIECE(PSGACT,"R")_$PIECE(PSGACT,"R",2)
+23 ;I ($P($G(^PS(55,PSGP,5,+PSJORD,0)),"^",21)) D EN1^PSJHL2(PSGP,"XX",PSJORD,"NOT TO BE GIVEN") K DA,PSGAL
End DoDot:1
+24 IF '$TEST
WRITE " No Change made."
OUT SET VALMBCK="R"
+1 QUIT
