- 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 Mar 13, 2025@21:07:12 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
