PSJOE0 ;BIR/CML3-INPATIENT PROFILE AND ORDER ENTRY ;17 SEP 97 / 1:41 PM
;;5.0; INPATIENT MEDICATIONS ;**47,56,110,133,162**;16 DEC 97
;
; Reference to ^PS(51.2 is supported by DBIA 2178.
; Reference to ^PS(55 is supported by DBIA 2191.
; Reference to ^VA(200 is supported by DBIA 10060.
; Reference to ^DIR is supported by DBIA 10026.
;
START ; print orders
W:X]"" $P("^PROFILE",X,2) D ENL^PSJO3 G:PSJOL="^" DONE Q:PSJOL="N" K PSJPR S PSGOEAV=0,PSJNARC=1 D ^PSJO I 'PSJON Q
;
ENVW ; ask user to select or view any of the orders shown
S (PSGONC,PSGONR,PSGONV)=0,PSGLMT=PSJON S:$D(PSJPRF) PSGPRF=1 D ENASR^PSGON K PSGPRF
;G:X="^" DONE I X]"" S PSGOEA=""
G:X["^" DONE I X]"" S PSGOEA=""
K PSJDLW
I F PSJOE=1:1:PSGODDD S PSGOE=PSJOE F PSJOE1=1:1:$L(PSGODDD(PSJOE),",")-1 S PSJOE2=$P(PSGODDD(PSJOE),",",PSJOE1),(PSGORD,PSJORD)=^TMP("PSJON",$J,PSJOE2) G:$D(PSJDLW) DONE D
.I PSJORD=+PSJORD N PSJO,PSJO1 S PSJO=PSJORD,PSJO1=0 F S PSJO1=$O(^PS(53.1,"ACX",PSJO,PSJO1)) Q:'PSJO1 Q:PSGOEA["^" Q:$D(PSJDLW) S PSJORD=PSJO1_"P" D GODO S PSJORD=""
.Q:PSJORD="" Q:PSGOEA["^"
.D GODO Q:PSGOEA["^"
Q
;
LMNEW(PSGP,PSJPROT) ;Entry point for new order entry from listman.
; PSGP = DFN
; PSJPROT=1:UD ONLY; 2:IV ONLY; 3:BOTH
;
;S VALM("BM")=9 D CKNEW
D CKNEW N PSJUDPRF S PSJNEWOE=1
S PSGPTS=PSJPTS,PSGOEAV=$P(PSJSYSP0,U,9)&PSJSYSU,PSGOEDMR=$O(^PS(51.2,"B","ORAL",0)),PSGOEPR=$S($D(^PS(55,PSGP,5.1)):$P(^(5.1),"^",2),1:0),PSJORQF=0,PSJOEPF=""
I PSGOEPR>0,$D(^VA(200,+PSGOEPR,"PS")) S PSGOEPR=$S('$P(^("PS"),"^",4):PSGOEPR,($P(^("PS"),"^",4)<DT):0,1:PSGOEPR)
S:'PSGOEPR PSGOEPR=PSJPTSP
;* F PSJOE=0:0 Q:PSJORQF D:PSJPCAF&(PSJPROT'=2) EN^PSJOE1 K PSGEFN,PSGOEF I PSJPROT>1,(+PSJSYSU=3) D ENIN^PSIVORE
;F PSJOE=0:0 Q:PSJORQF D:PSJPCAF&(PSJPROT'=2) EN^PSJOE1 K PSGEFN,PSGOEF I PSJPROT>1 D ENIN^PSIVORE
; line below fixes bug in line above - infinite loop when selecting New Order in Unit Dose OE for Outpatient.
F PSJOE=0:0 Q:PSJORQF!('(PSJPCAF&(PSJPROT'=2))&(PSJPROT'>1)) D:PSJPCAF&(PSJPROT'=2) EN^PSJOE1 K PSGEFN,PSGOEF I PSJPROT>1 D ENIN^PSIVORE
Q
;
DONE ;
K PSG,PSGDL,PSGDLS,PSGDO,PSGDRG,PSGDRGN,PSGFD,PSGHSM,PSGMR,PSGMRN,PSGNEDFD,PSGNEFD,PSGNESD,PSGOES,PSGOPR,PSGORD,PSGOROE1,PSGPR,PSGPRN,PSGS0XT,PSGS0Y,PSGSCH,PSGSD,PSGSI,PSGSM,PSGST,PSGSTN,PSGUD,PSGX,PSJDLW,PSJLM,PSJNARC,PSIVAC
K P,PSGEFN,PSGOEEF
Q
;
CKNEW ;
K CF,CHK,OD,PSGLMT,PSGODDD,PSGOEA,PSGON,PSGONC,PSGONR,PSGONV,PSGORD,PSJCOM,PSJOE1,PSJOE2 Q:$D(PSJPRF)
I $P(PSJPDD,"^",3) W !!?2,"Patient is shown as deceased. You may not enter orders for this patient." D CONT Q
I 'PSJPCAF W !!,"(NOTE: You cannot enter Unit Dose orders for this patient.)" D CONT
Q
;
CONT ;
K DIR S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR
Q
;
GODO ;Display selected order.
S PSIVAC="C" I $S(PSJORD["V":1,PSJORD["P":$P($G(^PS(53.1,+PSJORD,0)),"^",4)="F",1:0) D @$S($D(PSJPRP):"ENINP^PSIVOPT(DFN,PSJORD)",1:"ENIN^PSIVOPT") G GODO1
I '$D(PSJPRP),(PSJORD["P"),($P($G(^PS(53.1,+PSJORD,0)),U,4)="I") D ASKTYP Q:$D(DIRUT) I Y="I" D ENIN^PSIVOPT G GODO1
S PSGORD=PSJORD D EN2^PSGVW,^PSGOE1:'$D(PSJPRF)
GODO1 ;
I $D(PSJPRP),'PSJPR K DIR S DIR(0)="E" D ^DIR K DIR S:$D(DUOUT)!$D(DTOUT) PSJDLW=1 Q:$D(PSJDLW) W:$Y @IOF
Q
;
ASKTYP ; Ask if completing as IV or UD.
Q
W !! D PIV^PSIVUTL(+PSJORD_"P")
I $G(PSJPDD) S DIR(0)="E" D ^DIR S Y="I" Q
W ! K DIR S DIR(0)="SOA^U:Unit Dose;I:IV Medication",DIR("A")="Do you wish to complete this as an IV or Unit Dose order (I/U)? ",DIR("?")="^D PENDIU^PSJO3" D ^DIR
Q
;
OLDCOM(DFN,PSJORD) ;
Q:$$COMPLEX^PSJOE(DFN,PSJORD)
N DURFLG S DURFLG=$S($G(PSJORD)["P":$G(^PS(53.1,+PSJORD,2.5)),$G(PSJORD)["V":$G(^PS(55,DFN,"IV",+PSJORD,2.5)),1:$G(^PS(55,DFN,5,+PSJORD,2.5))) I $P(DURFLG,"^",2)]"" D
. D CLEAR^VALM1 W !!!!!?21," * WARNING * "
. W !!!?5,"The following order contains a Requested Duration"
. W !?12,"and may be part of a complex dose!"
. W !!," Review the entire profile to determine appropriate action(s).",!!!!!!! D PAUSE^VALM1
. D CLEAR^VALM1 W !!!!!?21," * WARNING * "
. W !!!?5,"The following order contains a Requested Duration"
. W !?12,"and may be part of a complex dose!"
. W !!," Review the entire profile to determine appropriate action(s).",!!!!!!! D PAUSE^VALM1
Q
AM ;
W !!?2,"Enter a 'Y' (or press the RETURN key) to enter new INPATIENT orders for this",!,"patient. Enter an 'N' (or an '^') if there are no new orders for this patient."
W:'PSJPCAF !!?2,"PLEASE NOTE: The patient selected is NOT shown as currently admitted.",!,"Therefore, you cannot enter Unit Dose orders for this patient. (You can enter",!,"IV orders.)" Q
PSJOE0 ;BIR/CML3-INPATIENT PROFILE AND ORDER ENTRY ;17 SEP 97 / 1:41 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**47,56,110,133,162**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(51.2 is supported by DBIA 2178.
+4 ; Reference to ^PS(55 is supported by DBIA 2191.
+5 ; Reference to ^VA(200 is supported by DBIA 10060.
+6 ; Reference to ^DIR is supported by DBIA 10026.
+7 ;
START ; print orders
+1 IF X]""
WRITE $PIECE("^PROFILE",X,2)
DO ENL^PSJO3
IF PSJOL="^"
GOTO DONE
IF PSJOL="N"
QUIT
KILL PSJPR
SET PSGOEAV=0
SET PSJNARC=1
DO ^PSJO
IF 'PSJON
QUIT
+2 ;
ENVW ; ask user to select or view any of the orders shown
+1 SET (PSGONC,PSGONR,PSGONV)=0
SET PSGLMT=PSJON
IF $DATA(PSJPRF)
SET PSGPRF=1
DO ENASR^PSGON
KILL PSGPRF
+2 ;G:X="^" DONE I X]"" S PSGOEA=""
+3 IF X["^"
GOTO DONE
IF X]""
SET PSGOEA=""
+4 KILL PSJDLW
+5 IF $TEST
FOR PSJOE=1:1:PSGODDD
SET PSGOE=PSJOE
FOR PSJOE1=1:1:$LENGTH(PSGODDD(PSJOE),",")-1
SET PSJOE2=$PIECE(PSGODDD(PSJOE),",",PSJOE1)
SET (PSGORD,PSJORD)=^TMP("PSJON",$JOB,PSJOE2)
IF $DATA(PSJDLW)
GOTO DONE
Begin DoDot:1
+6 IF PSJORD=+PSJORD
NEW PSJO,PSJO1
SET PSJO=PSJORD
SET PSJO1=0
FOR
SET PSJO1=$ORDER(^PS(53.1,"ACX",PSJO,PSJO1))
IF 'PSJO1
QUIT
IF PSGOEA["^"
QUIT
IF $DATA(PSJDLW)
QUIT
SET PSJORD=PSJO1_"P"
DO GODO
SET PSJORD=""
+7 IF PSJORD=""
QUIT
IF PSGOEA["^"
QUIT
+8 DO GODO
IF PSGOEA["^"
QUIT
End DoDot:1
+9 QUIT
+10 ;
LMNEW(PSGP,PSJPROT) ;Entry point for new order entry from listman.
+1 ; PSGP = DFN
+2 ; PSJPROT=1:UD ONLY; 2:IV ONLY; 3:BOTH
+3 ;
+4 ;S VALM("BM")=9 D CKNEW
+5 DO CKNEW
NEW PSJUDPRF
SET PSJNEWOE=1
+6 SET PSGPTS=PSJPTS
SET PSGOEAV=$PIECE(PSJSYSP0,U,9)&PSJSYSU
SET PSGOEDMR=$ORDER(^PS(51.2,"B","ORAL",0))
SET PSGOEPR=$SELECT($DATA(^PS(55,PSGP,5.1)):$PIECE(^(5.1),"^",2),1:0)
SET PSJORQF=0
SET PSJOEPF=""
+7 IF PSGOEPR>0
IF $DATA(^VA(200,+PSGOEPR,"PS"))
SET PSGOEPR=$SELECT('$PIECE(^("PS"),"^",4):PSGOEPR,($PIECE(^("PS"),"^",4)<DT):0,1:PSGOEPR)
+8 IF 'PSGOEPR
SET PSGOEPR=PSJPTSP
+9 ;* F PSJOE=0:0 Q:PSJORQF D:PSJPCAF&(PSJPROT'=2) EN^PSJOE1 K PSGEFN,PSGOEF I PSJPROT>1,(+PSJSYSU=3) D ENIN^PSIVORE
+10 ;F PSJOE=0:0 Q:PSJORQF D:PSJPCAF&(PSJPROT'=2) EN^PSJOE1 K PSGEFN,PSGOEF I PSJPROT>1 D ENIN^PSIVORE
+11 ; line below fixes bug in line above - infinite loop when selecting New Order in Unit Dose OE for Outpatient.
+12 FOR PSJOE=0:0
IF PSJORQF!('(PSJPCAF&(PSJPROT'=2))&(PSJPROT'>1))
QUIT
IF PSJPCAF&(PSJPROT'=2)
DO EN^PSJOE1
KILL PSGEFN,PSGOEF
IF PSJPROT>1
DO ENIN^PSIVORE
+13 QUIT
+14 ;
DONE ;
+1 KILL PSG,PSGDL,PSGDLS,PSGDO,PSGDRG,PSGDRGN,PSGFD,PSGHSM,PSGMR,PSGMRN,PSGNEDFD,PSGNEFD,PSGNESD,PSGOES,PSGOPR,PSGORD,PSGOROE1,PSGPR,PSGPRN,PSGS0XT,PSGS0Y,PSGSCH,PSGSD,PSGSI,PSGSM,PSGST,PSGSTN,PSGUD,PSGX,PSJDLW,PSJLM,PSJNARC,PSIVAC
+2 KILL P,PSGEFN,PSGOEEF
+3 QUIT
+4 ;
CKNEW ;
+1 KILL CF,CHK,OD,PSGLMT,PSGODDD,PSGOEA,PSGON,PSGONC,PSGONR,PSGONV,PSGORD,PSJCOM,PSJOE1,PSJOE2
IF $DATA(PSJPRF)
QUIT
+2 IF $PIECE(PSJPDD,"^",3)
WRITE !!?2,"Patient is shown as deceased. You may not enter orders for this patient."
DO CONT
QUIT
+3 IF 'PSJPCAF
WRITE !!,"(NOTE: You cannot enter Unit Dose orders for this patient.)"
DO CONT
+4 QUIT
+5 ;
CONT ;
+1 KILL DIR
SET DIR(0)="EA"
SET DIR("A")="Press Return to continue..."
DO ^DIR
+2 QUIT
+3 ;
GODO ;Display selected order.
+1 SET PSIVAC="C"
IF $SELECT(PSJORD["V":1,PSJORD["P":$PIECE($GET(^PS(53.1,+PSJORD,0)),"^",4)="F",1:0)
DO @$SELECT($DATA(PSJPRP):"ENINP^PSIVOPT(DFN,PSJORD)",1:"ENIN^PSIVOPT")
GOTO GODO1
+2 IF '$DATA(PSJPRP)
IF (PSJORD["P")
IF ($PIECE($GET(^PS(53.1,+PSJORD,0)),U,4)="I")
DO ASKTYP
IF $DATA(DIRUT)
QUIT
IF Y="I"
DO ENIN^PSIVOPT
GOTO GODO1
+3 SET PSGORD=PSJORD
DO EN2^PSGVW
IF '$DATA(PSJPRF)
DO ^PSGOE1
GODO1 ;
+1 IF $DATA(PSJPRP)
IF 'PSJPR
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)!$DATA(DTOUT)
SET PSJDLW=1
IF $DATA(PSJDLW)
QUIT
IF $Y
WRITE @IOF
+2 QUIT
+3 ;
ASKTYP ; Ask if completing as IV or UD.
+1 QUIT
+2 WRITE !!
DO PIV^PSIVUTL(+PSJORD_"P")
+3 IF $GET(PSJPDD)
SET DIR(0)="E"
DO ^DIR
SET Y="I"
QUIT
+4 WRITE !
KILL DIR
SET DIR(0)="SOA^U:Unit Dose;I:IV Medication"
SET DIR("A")="Do you wish to complete this as an IV or Unit Dose order (I/U)? "
SET DIR("?")="^D PENDIU^PSJO3"
DO ^DIR
+5 QUIT
+6 ;
OLDCOM(DFN,PSJORD) ;
+1 IF $$COMPLEX^PSJOE(DFN,PSJORD)
QUIT
+2 NEW DURFLG
SET DURFLG=$SELECT($GET(PSJORD)["P":$GET(^PS(53.1,+PSJORD,2.5)),$GET(PSJORD)["V":$GET(^PS(55,DFN,"IV",+PSJORD,2.5)),1:$GET(^PS(55,DFN,5,+PSJORD,2.5)))
IF $PIECE(DURFLG,"^",2)]""
Begin DoDot:1
+3 DO CLEAR^VALM1
WRITE !!!!!?21," * WARNING * "
+4 WRITE !!!?5,"The following order contains a Requested Duration"
+5 WRITE !?12,"and may be part of a complex dose!"
+6 WRITE !!," Review the entire profile to determine appropriate action(s).",!!!!!!!
DO PAUSE^VALM1
+7 DO CLEAR^VALM1
WRITE !!!!!?21," * WARNING * "
+8 WRITE !!!?5,"The following order contains a Requested Duration"
+9 WRITE !?12,"and may be part of a complex dose!"
+10 WRITE !!," Review the entire profile to determine appropriate action(s).",!!!!!!!
DO PAUSE^VALM1
End DoDot:1
+11 QUIT
AM ;
+1 WRITE !!?2,"Enter a 'Y' (or press the RETURN key) to enter new INPATIENT orders for this",!,"patient. Enter an 'N' (or an '^') if there are no new orders for this patient."
+2 IF 'PSJPCAF
WRITE !!?2,"PLEASE NOTE: The patient selected is NOT shown as currently admitted.",!,"Therefore, you cannot enter Unit Dose orders for this patient. (You can enter",!,"IV orders.)"
QUIT
