PSGOE0 ;BIR/CML3-PROFILE AND ORDER ENTRY ;25 SEP 97 / 7:42 AM
;;5.0;INPATIENT MEDICATIONS;**110,315**;16 DEC 97;Build 73
;;Per VHA Directive 2004-038, this routine should not be modified.
; Reference to ^PS(55 is supported by DBIA #2191.
; Reference to ^PS(51.2 is supported by DBIA# 2178.
;
START ; print orders
W:X]"" $P("^PROFILE",X,2) D ENL^PSGOU G:PSGOL="^" DONE G:PSGOL="N" ASK K PSGPR S PSGOEAV=0,PSJNARC=1,PSJOPC="UD" D ^PSGO I 'PSGON G ASK
;
ENVO ; view/act on orders
S PSGLMT=PSGON D ENASR^PSGON G:"^"[X ASK G:X["^^" DONE
I X="D" D EN^PSGOECS G:'$D(X) ENVO S X="^PROFILE" G START
I X="R" D EN^PSGOERS G:'$D(X) ENVO S X="^PROFILE" G START
I X="V" D EN^PSGOEVS G:'$D(X) ENVO S X="^PROFILE" G START
I X="F" D EN^PSGOESF G:'$D(X) ENVO S X="^PROFILE" G START
I PSGODDD S PSGOEA=""
I F PSGOE=1:1:PSGODDD F PSGOE1=1:1:$L(PSGODDD(PSGOE),",")-1 S PSGOE2=$P(PSGODDD(PSGOE),",",PSGOE1) D EN1^PSGVW K CONT D Q:'$D(PSGODDD)!($G(PSGOEA)["^")
.Q:$G(PSGOEA)["^" I $D(PSGPRF) W !!,"Press RETURN to continue: " R CONT:DTIME W @IOF S:CONT["^" PSGOEA="^"
.D ^PSGOE1:'$D(PSGPRF) Q:$G(PSGOEA)["^" I $D(PSGPRF),PSGORD["N",'$D(CONT) K DIR S DIR(0)="E" W ! D ^DIR Q:X["^"!$D(DIRUT)
;
;
ASK ; new orders entered here
K ^TMP("PSJON",$J),DIR,DIROUT,DIRUT,DRGI,DTOUT,DUOUT,PRI,PSGLMT,PSGODDD,PSGOE1,PSGOE2,PSGOEA,PSGOEE,PSGON,PSGONC,PSGONF,PSGONR,PSGONV Q:$D(PSGPRF) K PSGCANFL,PSGOL Q:'PSJPCAF
F W !!,"New order(s) for ",$P(PSGP(0),"^"),"? Y// " R X:DTIME W:'$T $C(7) S:'$T X="^" S:X="" X="Y" G:$P("^PROFILE",X)=""&(X'="^") START Q:"^YyNn"[X D:X?1."?" AM W:X'?1."?" $C(7)," ??"
W:"Nn"[X " (NO)" G:"^Nn"[X DONE W " (YES)"
I '$P(PSJSYSU,";",2) S PR=$P($G(^PS(55,PSGP,5.1)),"^",2) I PR D
.S X=$G(^VA(200,PR,"PS")) I $S('X:1,'$P(X,"^",4):0,1:DT'>$P(X,"^",4)) D:'$D(^PS(55,PSGP,0)) ENSET0^PSGNE3(PSGP) S $P(^PS(55,PSGP,5.1),"^",2)="",PR=""
S PSGOEAV=$P(PSJSYSP0,"^",9)&PSJSYSU,PSGOEDMR=$O(^PS(51.2,"B","ORAL",0)),PSGOEPR=$S($P(PSJSYSU,";",2):DUZ,1:PR) S:'PSGOEPR PSGOEPR=PSJPTSP
;
DRG ;
D ^PSGOE7 G:Y<0 DONE G:$P("^PROFILE",X)="" START I X?1"S."1.E D ^PSGOES G DRG
W ! D ^PSGOE3:$P(PSJSYSP0,"^",12),^PSGOE4:'$P(PSJSYSP0,"^",12) K PSGOEE,PSGOEOS D:$D(Y) ^PSGOETO G DRG
;
DONE ;
K DIR,DIROUT,DIRUT,DTOUT,DUOUT,PSG,PSGDL,PSGDLS,PSGDO,PSGDRG,PSGDRGN,PSGFD,PSGHSM,PSGMR,PSGMRN,PSGNEDFD,PSGNEFD,PSGNESD,PSGNEWDT
K PSGOEPR,PSGOES,PSGOPR,PSGORD,PSGOROE1,PSGPR,PSGPRN,PSGS0XT,PSGS0Y,PSGSCH,PSGSD,PSGSI,PSGSM,PSGST,PSGSTN,PSGUD,PSGX,PSJNARC,PSJOPC
K PSGRF,PSGRMV,PSGRMVT,PSGDUR,ND2P1 ;*315
Q
;
AM ;
W !!?2,"Answer 'YES' (or press the RETURN key) to enter new UNIT DOSE orders for this",!,"patient. Answer 'NO' (or '^') if there are no new orders for this patient." Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOE0 2722 printed Nov 22, 2024@17:11:53 Page 2
PSGOE0 ;BIR/CML3-PROFILE AND ORDER ENTRY ;25 SEP 97 / 7:42 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**110,315**;16 DEC 97;Build 73
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Reference to ^PS(55 is supported by DBIA #2191.
+4 ; Reference to ^PS(51.2 is supported by DBIA# 2178.
+5 ;
START ; print orders
+1 if X]""
WRITE $PIECE("^PROFILE",X,2)
DO ENL^PSGOU
if PSGOL="^"
GOTO DONE
if PSGOL="N"
GOTO ASK
KILL PSGPR
SET PSGOEAV=0
SET PSJNARC=1
SET PSJOPC="UD"
DO ^PSGO
IF 'PSGON
GOTO ASK
+2 ;
ENVO ; view/act on orders
+1 SET PSGLMT=PSGON
DO ENASR^PSGON
if "^"[X
GOTO ASK
if X["^^"
GOTO DONE
+2 IF X="D"
DO EN^PSGOECS
if '$DATA(X)
GOTO ENVO
SET X="^PROFILE"
GOTO START
+3 IF X="R"
DO EN^PSGOERS
if '$DATA(X)
GOTO ENVO
SET X="^PROFILE"
GOTO START
+4 IF X="V"
DO EN^PSGOEVS
if '$DATA(X)
GOTO ENVO
SET X="^PROFILE"
GOTO START
+5 IF X="F"
DO EN^PSGOESF
if '$DATA(X)
GOTO ENVO
SET X="^PROFILE"
GOTO START
+6 IF PSGODDD
SET PSGOEA=""
+7 IF $TEST
FOR PSGOE=1:1:PSGODDD
FOR PSGOE1=1:1:$LENGTH(PSGODDD(PSGOE),",")-1
SET PSGOE2=$PIECE(PSGODDD(PSGOE),",",PSGOE1)
DO EN1^PSGVW
KILL CONT
Begin DoDot:1
+8 if $GET(PSGOEA)["^"
QUIT
IF $DATA(PSGPRF)
WRITE !!,"Press RETURN to continue: "
READ CONT:DTIME
WRITE @IOF
if CONT["^"
SET PSGOEA="^"
+9 if '$DATA(PSGPRF)
DO ^PSGOE1
if $GET(PSGOEA)["^"
QUIT
IF $DATA(PSGPRF)
IF PSGORD["N"
IF '$DATA(CONT)
KILL DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
if X["^"!$DATA(DIRUT)
QUIT
End DoDot:1
if '$DATA(PSGODDD)!($GET(PSGOEA)["^")
QUIT
+10 ;
+11 ;
ASK ; new orders entered here
+1 KILL ^TMP("PSJON",$JOB),DIR,DIROUT,DIRUT,DRGI,DTOUT,DUOUT,PRI,PSGLMT,PSGODDD,PSGOE1,PSGOE2,PSGOEA,PSGOEE,PSGON,PSGONC,PSGONF,PSGONR,PSGONV
if $DATA(PSGPRF)
QUIT
KILL PSGCANFL,PSGOL
if 'PSJPCAF
QUIT
+2 FOR
WRITE !!,"New order(s) for ",$PIECE(PSGP(0),"^"),"? Y// "
READ X:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET X="^"
if X=""
SET X="Y"
if $PIECE("^PROFILE",X)=""&(X'="^")
GOTO START
if "^YyNn"[X
QUIT
if X?1."?"
DO AM
if X'?1."?"
WRITE $CHAR(7)," ??"
+3 if "Nn"[X
WRITE " (NO)"
if "^Nn"[X
GOTO DONE
WRITE " (YES)"
+4 IF '$PIECE(PSJSYSU,";",2)
SET PR=$PIECE($GET(^PS(55,PSGP,5.1)),"^",2)
IF PR
Begin DoDot:1
+5 SET X=$GET(^VA(200,PR,"PS"))
IF $SELECT('X:1,'$PIECE(X,"^",4):0,1:DT'>$PIECE(X,"^",4))
if '$DATA(^PS(55,PSGP,0))
DO ENSET0^PSGNE3(PSGP)
SET $PIECE(^PS(55,PSGP,5.1),"^",2)=""
SET PR=""
End DoDot:1
+6 SET PSGOEAV=$PIECE(PSJSYSP0,"^",9)&PSJSYSU
SET PSGOEDMR=$ORDER(^PS(51.2,"B","ORAL",0))
SET PSGOEPR=$SELECT($PIECE(PSJSYSU,";",2):DUZ,1:PR)
if 'PSGOEPR
SET PSGOEPR=PSJPTSP
+7 ;
DRG ;
+1 DO ^PSGOE7
if Y<0
GOTO DONE
if $PIECE("^PROFILE",X)=""
GOTO START
IF X?1"S."1.E
DO ^PSGOES
GOTO DRG
+2 WRITE !
if $PIECE(PSJSYSP0,"^",12)
DO ^PSGOE3
if '$PIECE(PSJSYSP0,"^",12)
DO ^PSGOE4
KILL PSGOEE,PSGOEOS
if $DATA(Y)
DO ^PSGOETO
GOTO DRG
+3 ;
DONE ;
+1 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT,PSG,PSGDL,PSGDLS,PSGDO,PSGDRG,PSGDRGN,PSGFD,PSGHSM,PSGMR,PSGMRN,PSGNEDFD,PSGNEFD,PSGNESD,PSGNEWDT
+2 KILL PSGOEPR,PSGOES,PSGOPR,PSGORD,PSGOROE1,PSGPR,PSGPRN,PSGS0XT,PSGS0Y,PSGSCH,PSGSD,PSGSI,PSGSM,PSGST,PSGSTN,PSGUD,PSGX,PSJNARC,PSJOPC
+3 ;*315
KILL PSGRF,PSGRMV,PSGRMVT,PSGDUR,ND2P1
+4 QUIT
+5 ;
AM ;
+1 WRITE !!?2,"Answer 'YES' (or press the RETURN key) to enter new UNIT DOSE orders for this",!,"patient. Answer 'NO' (or '^') if there are no new orders for this patient."
QUIT
