PSGOEF1 ;BIR/CML3-FINISH ORDERS ENTERED THROUGH OE/RR (CONT) ;02 Feb 2001 12:20 PM
;;5.0; INPATIENT MEDICATIONS ;**2,7,35,39,45,47,50,63,67,58,95,110,186**;16 DEC 97
;
; Reference to ^VALM1 is supported by DBIA# 10116.
; Reference to ^PS(55 is supported by DBIA 2191.
; Reference to ^PSDRUG( is supported by DBIA 2192.
; Reference to ^%DTC is supported by DBIA 10000.
; Reference to ^%RCR is supported by DBIA 10022.
; Reference to ^DIE is supported by DBIA 10018.
; Reference to ^DIR is supported by DBIA 10026.
;
UPD ;
W !!,"...accepting order..."
I PSGST="",(PSGSCH="NOW"!(PSGSCH="ONCE")) S PSGST="O"
I PSJCOM D UPD^PSJCOM Q
K DA,DR S DA=+PSGORD,DIE="^PS(53.1,",DR="28////N;4////U"_";7////"_PSGST_";10////"_PSGSD_";25////"_PSGFD
I $D(PSGSI),$P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" S ^PS(53.1,DA,6)=PSGSI
I $D(PSGSI),$P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S $P(^PS(53.1,DA,6),U)=$P(PSGSI,U) I $P(^PS(53.1,DA,6),U)="" S $P(^PS(53.1,DA,6),U,2)=""
S:PSGOEFF#2 DR=DR_";26////"_PSGSCH
I PSGSM,PSGOHSM'=PSGHSM S DR=DR_";5////"_PSGSM_";6////"_PSGHSM
D ^DIE W "."
F Q=1,3 K @(PSGOEEWF_Q_")") S %X="^PS(53.45,"_PSJSYSP_","_$S(Q=1:2,1:1)_",",%Y=PSGOEEWF_Q_"," K @(PSGOEEWF_Q_")") D %XY^%RCR W "." ;MOU-0100-30945
;;I $O(^PS(53.45,PSJSYSP,2,0)) S %X="^PS(53.45,"_PSJSYSP_",2,",%Y="^PS(53.1,"_+PSGORD_",1," D %XY^%RCR W "." S $P(^PS(53.1,+PSGORD,1,0),"^",2)=53.11
S PSGND=$G(^PS(53.1,+PSGORD,0)),X=$P(PSGND,U,24)
I $S(X="R":1,+$G(^PS(55,PSGP,5.1))>PSGDT:0,1:X'="E") S X=$G(^PS(53.1,DA,2)) D ENWALL^PSGNE3(+$P(X,U,2),+$P(X,U,4),PSGP)
I $P(PSGND,U,24)="R",$P(PSGND,U,25),PSGSD<$P($G(^PS(55,PSGP,5,+$P(PSGND,U,25),2)),U,4) D
.K DA,DR S DA(1)=PSGP,DA=+$P(PSGND,U,25),DIE="^PS(55,"_PSGP_",5,",DR="34////"_PSGFD_";25////"_$P($G(^PS(55,PSGP,5,+$P(PSGND,U,25),2)),U,4)
.D ^DIE,EN1^PSJHL2(PSGP,"XX",$P(PSGND,U,25))
S $P(^PS(53.1,+PSGORD,.2),U,2)=PSGDO,$P(^PS(53.1,+PSGORD,2),U,5)=PSGAT S:$G(PSGS0XT) $P(^(2),U,6)=PSGS0XT
I 'PSGOEAV D NEWNVAL^PSGAL5(PSGORD,$S(+PSJSYSU=3:22005,1:22000))
I PSGOEAV,+PSJSYSU=3 D VFY^PSGOEV Q
I PSGOEAV,$G(PSJRNF) D VFY^PSGOEV
Q
;
ENDRG(PSGPDRG,DRGDA) ; enter dispense drug for order w/o one
D NOW^%DTC K DRG S (DRG,Q)=0 F S Q=$O(^PSDRUG("ASP",+PSGPDRG,Q)) Q:'Q I $D(^PSDRUG(Q,0)),$P($G(^(2)),U,3)["U" S X=+$G(^("I")) I 'X!(X>%) S DRG=DRG+1,DRG(DRG)=Q_"^"_^(0)
I 'DRG W $C(7),!!,"No dispense drugs were found for this order's Orderable Item." K DIR S DIR(0)="E" D ^DIR K DIR S CHK=-1 Q
S:DRG=1 Y(0)=1
I DRG>1 D I 'Y S DRG=0,CHK=-1 Q
.W !!,"CHOOSE FROM:" F Q=1:1:DRG W !?3,$J(Q,3),". ",$P(DRG(Q),"^",2)
.N DIR S DIR(0)="LAO^1:"_DRG_U_"I X#1!(X[""."") K X",DIR("A")="Select DISPENSE DRUG(S) for this order: " S:DRG=1 DIR("B")=1 S DIR("?")="^D DRGH^PSGOEF1" W ! D ^DIR
;
I 'DRGDA S ^PS(53.45,PSJSYSP,2,0)="^53.4502P"
S DRG=Y(0) F Q1=1:1 S Q2=$P(DRG,",",Q1) Q:'Q2 D
.I '$$ENCKDD(PSGP,+DRG(Q2),Q1) S DRGDA=DRGDA+1,^PS(53.45,PSJSYSP,2,DRGDA,0)=+DRG(Q2),^PS(53.45,PSJSYSP,2,"B",+DRG(Q2),DRGDA)="",DA(1)=PSJSYSP,DA=DRGDA,DIE="^PS(53.45,"_PSJSYSP_",2,",DR=".02//1" W !!,$P(DRG(Q2),U,2) D ^DIE
.;I DRGDA=0,'$$ENCKDD(PSGP,+DRG(Q2)) S DRGDA=DRGDA+1,^PS(53.45,PSJSYSP,2,DRGDA,0)=+DRG(Q2),^PS(53.45,PSJSYSP,2,"B",+DRG(Q2),DRGDA)="",DA(1)=PSJSYSP,DA=DRGDA,DIE="^PS(53.45,"_PSJSYSP_",2,",DR=.02 W !!,$P(DRG(Q2),U,2) D ^DIE
S PSGDI=0
S:DRGDA>0 $P(^PS(53.45,PSJSYSP,2,0),"^",3,4)=DRGDA_"^"_DRGDA,CHK=0 Q
Q
;
DRGH ;
W !!?2,"This order must have at least one dispense drug before it can be completed.",!,"Select one or more items listed. For each item selected, you will be",!,"prompted for the UNITS PER DOSE for the item."
Q
ENIVUD(PSJORD) ;
;Determine if user should be prompted to transfer the order to IV.
; INPUT: PSJORD - IEN in 53.1_order location code.
; OUTPUT: 1 - Order not transferred, process as always.
; 0 - User selected to transfer order and quit upon return.
;
NEW DIR,DIRUT,PSJCOI,PSJND0,Y
S PSJND0=$G(^PS(53.1,+PSJORD,0)),PSJCOI=+$G(^PS(53.1,+PSJORD,.2))
I $P(PSJND0,U,4)="F" Q 1
D FULL^VALM1
I $S($P(PSJND0,U,24)="R":1,1:'$P(PSJND0,U,13)) Q 1
S DIR(0)="SAB^I:IV;U:UNIT DOSE",DIR("A")="COMPLETE THIS ORDER AS IV OR UNIT DOSE? ",DIR("B")=$S($P(PSJND0,U,4)="I":"IV",1:"UNIT DOSE")
S DIR("??")="^D THELP^PSGOEF1("""_$S(DIR("B")="IV":"UNIT DOSE",1:"IV")_""","_PSJCOI_")"
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT) Q 0
I Y="I" D Q 0
. I +PSJSYSU=1,'$G(PSJIRNF) W !!!!,"You need the PSJI RNFINISH key to finish this order as IV!" D PAUSE^VALM1 S VALMBCK="R" Q
. D IV^PSJLIFNI(PSJORD,PSJCOI)
I Y="U" D Q 0
. I +PSJSYSU=1,'$G(PSJRNF) W !!!!,"You need the PSJ RNFINISH key to finish this order as Unit Dose!" D PAUSE^VALM1 S VALMBCK="R" Q
. I $G(PSJITECH),($P(PSJSYSU,";",3)'=3) W !!!!,"You may not finish this order as Unit Dose!" D PAUSE^VALM1 S VALMBCK="R" Q
. D ENUD^PSGOEF1(PSJORD,PSJCOI)
Q 1
;
ENUD(PSJORD,PSGPD) ;
N PSJTUD S PSJTUD=1,DFN=$P($G(^PS(53.1,+PSJORD,0)),U,15)
K DRG,DRGOC,DRGT,DRGTMP,ERR,ON,ON55,P,PSJSTAR,PSJTIM,UL80
D DISACTIO^PSJOE(DFN,PSJORD,$G(PSJPNV)) S VALMBCK="Q"
Q
THELP(PKG,COI) ;
W !,"Choose the package this order should be completed as a IV or Unit Dose order",!
Q
;
ENCKDD(PSGP,PSJDRG,Q1) ;
N DRG
S PSGORQF=0
I Q1=1 D ENDDC^PSGSICHK(PSGP,PSJDRG) Q PSGORQF
N INTERVEN,PSJDDI,PSJIREQ,PSJRXREQ,PSJDD,PSGORQF,PSJDD
S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)="",PSJDD=PSJDRG
D IVSOL^PSGSICHK
Q $G(PSGORQF)
PSGOEF1 ;BIR/CML3-FINISH ORDERS ENTERED THROUGH OE/RR (CONT) ;02 Feb 2001 12:20 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**2,7,35,39,45,47,50,63,67,58,95,110,186**;16 DEC 97
+2 ;
+3 ; Reference to ^VALM1 is supported by DBIA# 10116.
+4 ; Reference to ^PS(55 is supported by DBIA 2191.
+5 ; Reference to ^PSDRUG( is supported by DBIA 2192.
+6 ; Reference to ^%DTC is supported by DBIA 10000.
+7 ; Reference to ^%RCR is supported by DBIA 10022.
+8 ; Reference to ^DIE is supported by DBIA 10018.
+9 ; Reference to ^DIR is supported by DBIA 10026.
+10 ;
UPD ;
+1 WRITE !!,"...accepting order..."
+2 IF PSGST=""
IF (PSGSCH="NOW"!(PSGSCH="ONCE"))
SET PSGST="O"
+3 IF PSJCOM
DO UPD^PSJCOM
QUIT
+4 KILL DA,DR
SET DA=+PSGORD
SET DIE="^PS(53.1,"
SET DR="28////N;4////U"_";7////"_PSGST_";10////"_PSGSD_";25////"_PSGFD
+5 IF $DATA(PSGSI)
IF $PIECE($GET(^PS(53.1,+PSGORD,0)),U,24)'="R"
SET ^PS(53.1,DA,6)=PSGSI
+6 IF $DATA(PSGSI)
IF $PIECE($GET(^PS(53.1,+PSGORD,0)),U,24)="R"
SET $PIECE(^PS(53.1,DA,6),U)=$PIECE(PSGSI,U)
IF $PIECE(^PS(53.1,DA,6),U)=""
SET $PIECE(^PS(53.1,DA,6),U,2)=""
+7 IF PSGOEFF#2
SET DR=DR_";26////"_PSGSCH
+8 IF PSGSM
IF PSGOHSM'=PSGHSM
SET DR=DR_";5////"_PSGSM_";6////"_PSGHSM
+9 DO ^DIE
WRITE "."
+10 ;MOU-0100-30945
FOR Q=1,3
KILL @(PSGOEEWF_Q_")")
SET %X="^PS(53.45,"_PSJSYSP_","_$SELECT(Q=1:2,1:1)_","
SET %Y=PSGOEEWF_Q_","
KILL @(PSGOEEWF_Q_")")
DO %XY^%RCR
WRITE "."
+11 ;;I $O(^PS(53.45,PSJSYSP,2,0)) S %X="^PS(53.45,"_PSJSYSP_",2,",%Y="^PS(53.1,"_+PSGORD_",1," D %XY^%RCR W "." S $P(^PS(53.1,+PSGORD,1,0),"^",2)=53.11
+12 SET PSGND=$GET(^PS(53.1,+PSGORD,0))
SET X=$PIECE(PSGND,U,24)
+13 IF $SELECT(X="R":1,+$GET(^PS(55,PSGP,5.1))>PSGDT:0,1:X'="E")
SET X=$GET(^PS(53.1,DA,2))
DO ENWALL^PSGNE3(+$PIECE(X,U,2),+$PIECE(X,U,4),PSGP)
+14 IF $PIECE(PSGND,U,24)="R"
IF $PIECE(PSGND,U,25)
IF PSGSD<$PIECE($GET(^PS(55,PSGP,5,+$PIECE(PSGND,U,25),2)),U,4)
Begin DoDot:1
+15 KILL DA,DR
SET DA(1)=PSGP
SET DA=+$PIECE(PSGND,U,25)
SET DIE="^PS(55,"_PSGP_",5,"
SET DR="34////"_PSGFD_";25////"_$PIECE($GET(^PS(55,PSGP,5,+$PIECE(PSGND,U,25),2)),U,4)
+16 DO ^DIE
DO EN1^PSJHL2(PSGP,"XX",$PIECE(PSGND,U,25))
End DoDot:1
+17 SET $PIECE(^PS(53.1,+PSGORD,.2),U,2)=PSGDO
SET $PIECE(^PS(53.1,+PSGORD,2),U,5)=PSGAT
IF $GET(PSGS0XT)
SET $PIECE(^(2),U,6)=PSGS0XT
+18 IF 'PSGOEAV
DO NEWNVAL^PSGAL5(PSGORD,$SELECT(+PSJSYSU=3:22005,1:22000))
+19 IF PSGOEAV
IF +PSJSYSU=3
DO VFY^PSGOEV
QUIT
+20 IF PSGOEAV
IF $GET(PSJRNF)
DO VFY^PSGOEV
+21 QUIT
+22 ;
ENDRG(PSGPDRG,DRGDA) ; enter dispense drug for order w/o one
+1 DO NOW^%DTC
KILL DRG
SET (DRG,Q)=0
FOR
SET Q=$ORDER(^PSDRUG("ASP",+PSGPDRG,Q))
IF 'Q
QUIT
IF $DATA(^PSDRUG(Q,0))
IF $PIECE($GET(^(2)),U,3)["U"
SET X=+$GET(^("I"))
IF 'X!(X>%)
SET DRG=DRG+1
SET DRG(DRG)=Q_"^"_^(0)
+2 IF 'DRG
WRITE $CHAR(7),!!,"No dispense drugs were found for this order's Orderable Item."
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET CHK=-1
QUIT
+3 IF DRG=1
SET Y(0)=1
+4 IF DRG>1
Begin DoDot:1
+5 WRITE !!,"CHOOSE FROM:"
FOR Q=1:1:DRG
WRITE !?3,$JUSTIFY(Q,3),". ",$PIECE(DRG(Q),"^",2)
+6 NEW DIR
SET DIR(0)="LAO^1:"_DRG_U_"I X#1!(X[""."") K X"
SET DIR("A")="Select DISPENSE DRUG(S) for this order: "
IF DRG=1
SET DIR("B")=1
SET DIR("?")="^D DRGH^PSGOEF1"
WRITE !
DO ^DIR
End DoDot:1
IF 'Y
SET DRG=0
SET CHK=-1
QUIT
+7 ;
+8 IF 'DRGDA
SET ^PS(53.45,PSJSYSP,2,0)="^53.4502P"
+9 SET DRG=Y(0)
FOR Q1=1:1
SET Q2=$PIECE(DRG,",",Q1)
IF 'Q2
QUIT
Begin DoDot:1
+10 IF '$$ENCKDD(PSGP,+DRG(Q2),Q1)
SET DRGDA=DRGDA+1
SET ^PS(53.45,PSJSYSP,2,DRGDA,0)=+DRG(Q2)
SET ^PS(53.45,PSJSYSP,2,"B",+DRG(Q2),DRGDA)=""
SET DA(1)=PSJSYSP
SET DA=DRGDA
SET DIE="^PS(53.45,"_PSJSYSP_",2,"
SET DR=".02//1"
WRITE !!,$PIECE(DRG(Q2),U,2)
DO ^DIE
+11 ;I DRGDA=0,'$$ENCKDD(PSGP,+DRG(Q2)) S DRGDA=DRGDA+1,^PS(53.45,PSJSYSP,2,DRGDA,0)=+DRG(Q2),^PS(53.45,PSJSYSP,2,"B",+DRG(Q2),DRGDA)="",DA(1)=PSJSYSP,DA=DRGDA,DIE="^PS(53.45,"_PSJSYSP_",2,",DR=.02 W !!,$P(DRG(Q2),U,2) D ^DIE
End DoDot:1
+12 SET PSGDI=0
+13 IF DRGDA>0
SET $PIECE(^PS(53.45,PSJSYSP,2,0),"^",3,4)=DRGDA_"^"_DRGDA
SET CHK=0
QUIT
+14 QUIT
+15 ;
DRGH ;
+1 WRITE !!?2,"This order must have at least one dispense drug before it can be completed.",!,"Select one or more items listed. For each item selected, you will be",!,"prompted for the UNITS PER DOSE for the item."
+2 QUIT
ENIVUD(PSJORD) ;
+1 ;Determine if user should be prompted to transfer the order to IV.
+2 ; INPUT: PSJORD - IEN in 53.1_order location code.
+3 ; OUTPUT: 1 - Order not transferred, process as always.
+4 ; 0 - User selected to transfer order and quit upon return.
+5 ;
+6 NEW DIR,DIRUT,PSJCOI,PSJND0,Y
+7 SET PSJND0=$GET(^PS(53.1,+PSJORD,0))
SET PSJCOI=+$GET(^PS(53.1,+PSJORD,.2))
+8 IF $PIECE(PSJND0,U,4)="F"
QUIT 1
+9 DO FULL^VALM1
+10 IF $SELECT($PIECE(PSJND0,U,24)="R":1,1:'$PIECE(PSJND0,U,13))
QUIT 1
+11 SET DIR(0)="SAB^I:IV;U:UNIT DOSE"
SET DIR("A")="COMPLETE THIS ORDER AS IV OR UNIT DOSE? "
SET DIR("B")=$SELECT($PIECE(PSJND0,U,4)="I":"IV",1:"UNIT DOSE")
+12 SET DIR("??")="^D THELP^PSGOEF1("""_$SELECT(DIR("B")="IV":"UNIT DOSE",1:"IV")_""","_PSJCOI_")"
+13 DO ^DIR
KILL DIR
+14 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT 0
+15 IF Y="I"
Begin DoDot:1
+16 IF +PSJSYSU=1
IF '$GET(PSJIRNF)
WRITE !!!!,"You need the PSJI RNFINISH key to finish this order as IV!"
DO PAUSE^VALM1
SET VALMBCK="R"
QUIT
+17 DO IV^PSJLIFNI(PSJORD,PSJCOI)
End DoDot:1
QUIT 0
+18 IF Y="U"
Begin DoDot:1
+19 IF +PSJSYSU=1
IF '$GET(PSJRNF)
WRITE !!!!,"You need the PSJ RNFINISH key to finish this order as Unit Dose!"
DO PAUSE^VALM1
SET VALMBCK="R"
QUIT
+20 IF $GET(PSJITECH)
IF ($PIECE(PSJSYSU,";",3)'=3)
WRITE !!!!,"You may not finish this order as Unit Dose!"
DO PAUSE^VALM1
SET VALMBCK="R"
QUIT
+21 DO ENUD^PSGOEF1(PSJORD,PSJCOI)
End DoDot:1
QUIT 0
+22 QUIT 1
+23 ;
ENUD(PSJORD,PSGPD) ;
+1 NEW PSJTUD
SET PSJTUD=1
SET DFN=$PIECE($GET(^PS(53.1,+PSJORD,0)),U,15)
+2 KILL DRG,DRGOC,DRGT,DRGTMP,ERR,ON,ON55,P,PSJSTAR,PSJTIM,UL80
+3 DO DISACTIO^PSJOE(DFN,PSJORD,$GET(PSJPNV))
SET VALMBCK="Q"
+4 QUIT
THELP(PKG,COI) ;
+1 WRITE !,"Choose the package this order should be completed as a IV or Unit Dose order",!
+2 QUIT
+3 ;
ENCKDD(PSGP,PSJDRG,Q1) ;
+1 NEW DRG
+2 SET PSGORQF=0
+3 IF Q1=1
DO ENDDC^PSGSICHK(PSGP,PSJDRG)
QUIT PSGORQF
+4 NEW INTERVEN,PSJDDI,PSJIREQ,PSJRXREQ,PSJDD,PSGORQF,PSJDD
+5 SET Y=1
SET (PSJIREQ,PSJRXREQ,INTERVEN,X)=""
SET PSJDD=PSJDRG
+6 DO IVSOL^PSGSICHK
+7 QUIT $GET(PSGORQF)
