PSJLIFN ;BIR/MV-IV FINISH USING LM ;13 Jan 98 / 11:32 AM
;;5.0; INPATIENT MEDICATIONS ;**1,29,34,37,42,47,50,56,94,80,116,110**;16 DEC 97
;
; Reference to ^PS(51.2 is supported by DBIA #2178.
; Reference to ^PS(52.6 supported by DBIA #1231.
; Reference to ^PS(52.7 supported by DBIA #2173.
; Reference to ^PSDRUG( is supported by DBIA #2192.
; Reference to ^PSOORDRG is supported by DBIA #2190.
; Reference to ^%DT is supported by DBIA #10003.
; Reference to ^VALM is supported by DBIA #10118.
; Reference to ^VALM1 is supported by DBIA #10116.
; Reference to RE^VALM4 is supported by DBIA #10120.
;
EN ; Display order with numbers.
L +^PS(53.1,+PSJORD):1 I '$T W !,$C(7),$C(7),"This order is being edited by another user. Try later." D PAUSE^VALM1 Q
D PENDING K PSJREN
L -^PS(53.1,+PSJORD)
Q
PENDING ; Process pending order.
;* PSIVFN1 is use so it will dipslay the AC/Edit screen
;* instead of go to the "IS this O.K." prompt
;* PSIVACEP only when accept the order. Original screen won't redisp.
;* PSJLMX is defined in WRTDRG^PSIVUTL and it was being call in PSJLIVMD & PSJLIVFD
;* to count # of AD/SOL
NEW PSIVFN1,PSIVACEP,PSJLMX,PSIVOI
S PSIVAC="CF" S (P("PON"),ON)=+PSJORD_"P",DFN=PSGP
S PSIVUP=+$$GTPCI^PSIVUTL D GT531^PSIVORFA(DFN,ON)
D:'$D(P("OT")) GTOT^PSIVUTL(P(4))
NEW PSJL
N PSIVNUM,PSJSTAR S PSIVNUM=1
Q:ON'=PSJORD
I $G(PSJLYN)]"" Q:ON'=PSJLYN
S PSJMAI=ON
I P("OT")="I" D Q
. S PSJSTAR="(5)^(7)^(9)^(10)"
. D EN^VALM("PSJ LM IV INPT PENDING") ;; ^PSJLIVMD
S PSJSTAR="(1)^(2)^(3)^(5)^(7)^(9)"
D GTDATA D EN^VALM("PSJ LM IV PENDING") ;; ^PSJLIVFD
K PSJMAI Q
;
DISPLAY ;
S PSGACT=""
S VALMSG="Press Return to continue"
D:$E(P("OT"))="I" EN^VALM("PSJ LM IV INPT DISPLAY")
D:$E(P("OT"))'="I" EN^VALM("PSJ LM IV DISPLAY")
K PSJDISP
S:'$G(PSJHIS) VALMBCK=""
Q
GTDATA ;
;* D:P(4)="" 53^PSIVORC1 Q:P(4)="" S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3)
S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3)
I 'P(2) D
.I P("RES")="R" S PSJREN=1
.D ENT^PSIVCAL K %DT S X=P(2),%DT="RTX" D ^%DT S P(2)=+Y
I 'P(3) D ENSTOP^PSIVCAL K %DT S X=P(3),%DT="RTX" D ^%DT S P(3)=+Y
I 'P("MR") S P("MR")=$O(^PS(51.2,"B","INTRAVENOUS",0))_"^IV"
Q
FINISH ; Prompt for missing data
;* Ord chk for Inpat. pending only. Pend renew should not be checked.
;* PSIVOCON needed so this order will be excluded from the order
;* list(ORDCHK^PSJLMUT1)
;* PSGORQF defined means cancel the order due to order check.
;Q:'$$LS^PSSLOCK(DFN,PSJORD)
N PSJCOM S PSJCOM=+$P($G(^PS(53.1,+PSJORD,.2)),"^",8)
K PSJIVBD,PSGRDTX
N FIL,PSIVS,DRGOC,PSIVXD,DRGTMP,PSIVOCON,PSGORQF,ON55,NSFF S NSFF=1
S (ON,PSIVOCON,ON55,PSGORD)=PSJORD Q:PSJORD'=PSJMAI I $G(PSJLYN)]"" Q:PSJORD'=PSJLYN
D UDVARS^PSJLIORD
I $G(PSJPROT)=3,'$$ENIVUD^PSGOEF1(PSJORD) K NSFF Q
D HOLDHDR^PSJOE
; force the display of the second screen if CPRS order checks exist
I $O(^PS(53.1,+PSJORD,12,0))!$O(^PS(53.1,+PSJORD,10,0)) D
.Q:$G(PSJLMX)=1 ;no second screen to display
.S VALMBG=16 D RE^VALM4,PAUSE^VALM1 S VALMBG=1
S P("OPI")=$$ENPC^PSJUTL("V",+PSIVUP,60,P("OPI"))
;I $E(P("OT"))="I" D GTDATA Q:P(4)=""
;I $E(P("OT"))="I",'$D(DRG("AD")),('$D(DRG("SOL"))) D
I $G(P("RES"))'="R" D 53^PSIVORC1
I $G(P(4))]"",$G(P(15))]"",$G(P(9))]"",$$SCHREQ^PSJLIVFD(.P) D
. N PSGS0XT,X,PSJNSS S PSJNSS=1,X=P(9),PSGS0XT=P(15) D Q2^PSGS0
I P(4)="" D RE^VALM4 Q
I $E(P("OT"))="I" D GTDATA D
. I '$D(DRG("AD")),('$D(DRG("SOL"))) S DNE=0 D GTIVDRG^PSIVORC2 S P(3)="" D ENSTOP^PSIVCAL
. D ORDCHK
S VALMBG=1
I $E(P("OT"))="F" S DNE=0 D ORDCHK I $G(PSGORQF) D RE^VALM4 Q
I $D(PSGORQF) S VALMBCK="R",P(4)="" K DRG Q
S PSIVOK="1^3^10^25^26^39^57^58^59^63^64" D CKFLDS^PSIVORC1 D:EDIT]"" EDIT^PSIVEDT
I $G(DONE) S VALMBCK="R" Q
D COMPLTE^PSIVORC1
S:$G(PSIVACEP) VALMBCK="Q"
I $G(PSGORQF) S VALMBG=1 D RE^VALM4
K NSFF
Q
ORDCHK ;* Do order check for Inpatient Meds IV.
; PSGORQF is defined (CONT^PSGSICHK) if not log an intervention
K PSGORQF
NEW DRGOC
D OCORD Q:$G(PSGORQF)
;D GTIVDRG^PSIVORC2 S P(3)="" D ENSTOP^PSIVCAL
ORDCHKA ;* Do order check agaist existing orders on the profile
F PSIVAS="AD","SOL" Q:$G(PSGORQF) S FIL=$S(PSIVAS="AD":52.6,1:52.7) D
. F PSIVX=0:0 S PSIVX=$O(DRG(PSIVAS,PSIVX)) Q:'PSIVX!($G(PSGORQF)) D
.. S DRGTMP=DRG(PSIVAS,PSIVX)
.. ;* Do only 1 duplicate warning when order has >1 of the same additive
.. Q:$D(PSJADTMP(+DRGTMP))
.. D ORDERCHK^PSIVEDRG(PSGP,ON,$D(DRGOC(ON)))
.. S DRGOC(ON,PSIVAS,PSIVX)=DRG(PSIVAS,PSIVX)
.. S PSJADTMP(+DRGTMP)=""
K PSJADTMP
Q
OCORD ;* Do order check for each drug against the drugs within the order.
NEW X,Y,DDRUG,PSIVX,PSJAD,PSJSOL,TMPDRG
D SAVEDRG^PSIVEDRG(.TMPDRG,.DRG)
; Find the corresponding DD for the additive within the order
F X=0:0 S X=$O(DRG("AD",X)) Q:'X D
. S DDRUG=$P($G(^PS(52.6,+DRG("AD",X),0)),U,2)
. S:+DDRUG (DDRUG(DDRUG),PSJAD(DDRUG))=$D(DDRUG(DDRUG))+1
;
; Find the corresponding DD for the solution
;
F X=0:0 S X=$O(DRG("SOL",X)) Q:'X D
. S DDRUG=$P($G(^PS(52.7,+DRG("SOL",X),0)),U,2)
. S:+DDRUG (DDRUG(DDRUG),PSJSOL(DDRUG))=$D(DDRUG(DDRUG))+1
;
; Loop thru each additive to check for DD,DI & DC against the
; order's dispense drugs
;
NEW PSJDFN,INTERVEN S INTERVEN=""
S PSJDFN=DFN ;DFN will be killed when call ^PSOORDRG
F PSIVX=0:0 S PSIVX=$O(PSJAD(PSIVX)) Q:'PSIVX D
. K DDRUG(PSIVX) D DRGCHK^PSOORDRG(PSJDFN,PSIVX,.DDRUG)
. I PSJAD(PSIVX)>1 S ^TMP($J,"DD",1,0)=PSIVX_U_$P($G(^PSDRUG(PSIVX,0)),U)_"^^"_ON_";I"
. NEW TYPE F TYPE="DD","DI","DC" D ORDCHK^PSJLIFNI(PSJDFN,TYPE)
F PSIVX=0:0 S PSIVX=$O(PSJSOL(PSIVX)) Q:'PSIVX D
. K DDRUG(PSIVX) D DRGCHK^PSOORDRG(PSJDFN,PSIVX,.DDRUG)
. NEW TYPE F TYPE="DI" D ORDCHK^PSJLIFNI(PSJDFN,TYPE)
S DFN=PSJDFN
D SAVEDRG^PSIVEDRG(.DRG,.TMPDRG)
Q
PSJLIFN ;BIR/MV-IV FINISH USING LM ;13 Jan 98 / 11:32 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**1,29,34,37,42,47,50,56,94,80,116,110**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(51.2 is supported by DBIA #2178.
+4 ; Reference to ^PS(52.6 supported by DBIA #1231.
+5 ; Reference to ^PS(52.7 supported by DBIA #2173.
+6 ; Reference to ^PSDRUG( is supported by DBIA #2192.
+7 ; Reference to ^PSOORDRG is supported by DBIA #2190.
+8 ; Reference to ^%DT is supported by DBIA #10003.
+9 ; Reference to ^VALM is supported by DBIA #10118.
+10 ; Reference to ^VALM1 is supported by DBIA #10116.
+11 ; Reference to RE^VALM4 is supported by DBIA #10120.
+12 ;
EN ; Display order with numbers.
+1 LOCK +^PS(53.1,+PSJORD):1
IF '$TEST
WRITE !,$CHAR(7),$CHAR(7),"This order is being edited by another user. Try later."
DO PAUSE^VALM1
QUIT
+2 DO PENDING
KILL PSJREN
+3 LOCK -^PS(53.1,+PSJORD)
+4 QUIT
PENDING ; Process pending order.
+1 ;* PSIVFN1 is use so it will dipslay the AC/Edit screen
+2 ;* instead of go to the "IS this O.K." prompt
+3 ;* PSIVACEP only when accept the order. Original screen won't redisp.
+4 ;* PSJLMX is defined in WRTDRG^PSIVUTL and it was being call in PSJLIVMD & PSJLIVFD
+5 ;* to count # of AD/SOL
+6 NEW PSIVFN1,PSIVACEP,PSJLMX,PSIVOI
+7 SET PSIVAC="CF"
SET (P("PON"),ON)=+PSJORD_"P"
SET DFN=PSGP
+8 SET PSIVUP=+$$GTPCI^PSIVUTL
DO GT531^PSIVORFA(DFN,ON)
+9 IF '$DATA(P("OT"))
DO GTOT^PSIVUTL(P(4))
+10 NEW PSJL
+11 NEW PSIVNUM,PSJSTAR
SET PSIVNUM=1
+12 IF ON'=PSJORD
QUIT
+13 IF $GET(PSJLYN)]""
IF ON'=PSJLYN
QUIT
+14 SET PSJMAI=ON
+15 IF P("OT")="I"
Begin DoDot:1
+16 SET PSJSTAR="(5)^(7)^(9)^(10)"
+17 ;; ^PSJLIVMD
DO EN^VALM("PSJ LM IV INPT PENDING")
End DoDot:1
QUIT
+18 SET PSJSTAR="(1)^(2)^(3)^(5)^(7)^(9)"
+19 ;; ^PSJLIVFD
DO GTDATA
DO EN^VALM("PSJ LM IV PENDING")
+20 KILL PSJMAI
QUIT
+21 ;
DISPLAY ;
+1 SET PSGACT=""
+2 SET VALMSG="Press Return to continue"
+3 IF $EXTRACT(P("OT"))="I"
DO EN^VALM("PSJ LM IV INPT DISPLAY")
+4 IF $EXTRACT(P("OT"))'="I"
DO EN^VALM("PSJ LM IV DISPLAY")
+5 KILL PSJDISP
+6 IF '$GET(PSJHIS)
SET VALMBCK=""
+7 QUIT
GTDATA ;
+1 ;* D:P(4)="" 53^PSIVORC1 Q:P(4)="" S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3)
+2 SET P("DTYP")=$SELECT(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3)
+3 IF 'P(2)
Begin DoDot:1
+4 IF P("RES")="R"
SET PSJREN=1
+5 DO ENT^PSIVCAL
KILL %DT
SET X=P(2)
SET %DT="RTX"
DO ^%DT
SET P(2)=+Y
End DoDot:1
+6 IF 'P(3)
DO ENSTOP^PSIVCAL
KILL %DT
SET X=P(3)
SET %DT="RTX"
DO ^%DT
SET P(3)=+Y
+7 IF 'P("MR")
SET P("MR")=$ORDER(^PS(51.2,"B","INTRAVENOUS",0))_"^IV"
+8 QUIT
FINISH ; Prompt for missing data
+1 ;* Ord chk for Inpat. pending only. Pend renew should not be checked.
+2 ;* PSIVOCON needed so this order will be excluded from the order
+3 ;* list(ORDCHK^PSJLMUT1)
+4 ;* PSGORQF defined means cancel the order due to order check.
+5 ;Q:'$$LS^PSSLOCK(DFN,PSJORD)
+6 NEW PSJCOM
SET PSJCOM=+$PIECE($GET(^PS(53.1,+PSJORD,.2)),"^",8)
+7 KILL PSJIVBD,PSGRDTX
+8 NEW FIL,PSIVS,DRGOC,PSIVXD,DRGTMP,PSIVOCON,PSGORQF,ON55,NSFF
SET NSFF=1
+9 SET (ON,PSIVOCON,ON55,PSGORD)=PSJORD
IF PSJORD'=PSJMAI
QUIT
IF $GET(PSJLYN)]""
IF PSJORD'=PSJLYN
QUIT
+10 DO UDVARS^PSJLIORD
+11 IF $GET(PSJPROT)=3
IF '$$ENIVUD^PSGOEF1(PSJORD)
KILL NSFF
QUIT
+12 DO HOLDHDR^PSJOE
+13 ; force the display of the second screen if CPRS order checks exist
+14 IF $ORDER(^PS(53.1,+PSJORD,12,0))!$ORDER(^PS(53.1,+PSJORD,10,0))
Begin DoDot:1
+15 ;no second screen to display
IF $GET(PSJLMX)=1
QUIT
+16 SET VALMBG=16
DO RE^VALM4
DO PAUSE^VALM1
SET VALMBG=1
End DoDot:1
+17 SET P("OPI")=$$ENPC^PSJUTL("V",+PSIVUP,60,P("OPI"))
+18 ;I $E(P("OT"))="I" D GTDATA Q:P(4)=""
+19 ;I $E(P("OT"))="I",'$D(DRG("AD")),('$D(DRG("SOL"))) D
+20 IF $GET(P("RES"))'="R"
DO 53^PSIVORC1
+21 IF $GET(P(4))]""
IF $GET(P(15))]""
IF $GET(P(9))]""
IF $$SCHREQ^PSJLIVFD(.P)
Begin DoDot:1
+22 NEW PSGS0XT,X,PSJNSS
SET PSJNSS=1
SET X=P(9)
SET PSGS0XT=P(15)
DO Q2^PSGS0
End DoDot:1
+23 IF P(4)=""
DO RE^VALM4
QUIT
+24 IF $EXTRACT(P("OT"))="I"
DO GTDATA
Begin DoDot:1
+25 IF '$DATA(DRG("AD"))
IF ('$DATA(DRG("SOL")))
SET DNE=0
DO GTIVDRG^PSIVORC2
SET P(3)=""
DO ENSTOP^PSIVCAL
+26 DO ORDCHK
End DoDot:1
+27 SET VALMBG=1
+28 IF $EXTRACT(P("OT"))="F"
SET DNE=0
DO ORDCHK
IF $GET(PSGORQF)
DO RE^VALM4
QUIT
+29 IF $DATA(PSGORQF)
SET VALMBCK="R"
SET P(4)=""
KILL DRG
QUIT
+30 SET PSIVOK="1^3^10^25^26^39^57^58^59^63^64"
DO CKFLDS^PSIVORC1
IF EDIT]""
DO EDIT^PSIVEDT
+31 IF $GET(DONE)
SET VALMBCK="R"
QUIT
+32 DO COMPLTE^PSIVORC1
+33 IF $GET(PSIVACEP)
SET VALMBCK="Q"
+34 IF $GET(PSGORQF)
SET VALMBG=1
DO RE^VALM4
+35 KILL NSFF
+36 QUIT
ORDCHK ;* Do order check for Inpatient Meds IV.
+1 ; PSGORQF is defined (CONT^PSGSICHK) if not log an intervention
+2 KILL PSGORQF
+3 NEW DRGOC
+4 DO OCORD
IF $GET(PSGORQF)
QUIT
+5 ;D GTIVDRG^PSIVORC2 S P(3)="" D ENSTOP^PSIVCAL
ORDCHKA ;* Do order check agaist existing orders on the profile
+1 FOR PSIVAS="AD","SOL"
IF $GET(PSGORQF)
QUIT
SET FIL=$SELECT(PSIVAS="AD":52.6,1:52.7)
Begin DoDot:1
+2 FOR PSIVX=0:0
SET PSIVX=$ORDER(DRG(PSIVAS,PSIVX))
IF 'PSIVX!($GET(PSGORQF))
QUIT
Begin DoDot:2
+3 SET DRGTMP=DRG(PSIVAS,PSIVX)
+4 ;* Do only 1 duplicate warning when order has >1 of the same additive
+5 IF $DATA(PSJADTMP(+DRGTMP))
QUIT
+6 DO ORDERCHK^PSIVEDRG(PSGP,ON,$DATA(DRGOC(ON)))
+7 SET DRGOC(ON,PSIVAS,PSIVX)=DRG(PSIVAS,PSIVX)
+8 SET PSJADTMP(+DRGTMP)=""
End DoDot:2
End DoDot:1
+9 KILL PSJADTMP
+10 QUIT
OCORD ;* Do order check for each drug against the drugs within the order.
+1 NEW X,Y,DDRUG,PSIVX,PSJAD,PSJSOL,TMPDRG
+2 DO SAVEDRG^PSIVEDRG(.TMPDRG,.DRG)
+3 ; Find the corresponding DD for the additive within the order
+4 FOR X=0:0
SET X=$ORDER(DRG("AD",X))
IF 'X
QUIT
Begin DoDot:1
+5 SET DDRUG=$PIECE($GET(^PS(52.6,+DRG("AD",X),0)),U,2)
+6 IF +DDRUG
SET (DDRUG(DDRUG),PSJAD(DDRUG))=$DATA(DDRUG(DDRUG))+1
End DoDot:1
+7 ;
+8 ; Find the corresponding DD for the solution
+9 ;
+10 FOR X=0:0
SET X=$ORDER(DRG("SOL",X))
IF 'X
QUIT
Begin DoDot:1
+11 SET DDRUG=$PIECE($GET(^PS(52.7,+DRG("SOL",X),0)),U,2)
+12 IF +DDRUG
SET (DDRUG(DDRUG),PSJSOL(DDRUG))=$DATA(DDRUG(DDRUG))+1
End DoDot:1
+13 ;
+14 ; Loop thru each additive to check for DD,DI & DC against the
+15 ; order's dispense drugs
+16 ;
+17 NEW PSJDFN,INTERVEN
SET INTERVEN=""
+18 ;DFN will be killed when call ^PSOORDRG
SET PSJDFN=DFN
+19 FOR PSIVX=0:0
SET PSIVX=$ORDER(PSJAD(PSIVX))
IF 'PSIVX
QUIT
Begin DoDot:1
+20 KILL DDRUG(PSIVX)
DO DRGCHK^PSOORDRG(PSJDFN,PSIVX,.DDRUG)
+21 IF PSJAD(PSIVX)>1
SET ^TMP($JOB,"DD",1,0)=PSIVX_U_$PIECE($GET(^PSDRUG(PSIVX,0)),U)_"^^"_ON_";I"
+22 NEW TYPE
FOR TYPE="DD","DI","DC"
DO ORDCHK^PSJLIFNI(PSJDFN,TYPE)
End DoDot:1
+23 FOR PSIVX=0:0
SET PSIVX=$ORDER(PSJSOL(PSIVX))
IF 'PSIVX
QUIT
Begin DoDot:1
+24 KILL DDRUG(PSIVX)
DO DRGCHK^PSOORDRG(PSJDFN,PSIVX,.DDRUG)
+25 NEW TYPE
FOR TYPE="DI"
DO ORDCHK^PSJLIFNI(PSJDFN,TYPE)
End DoDot:1
+26 SET DFN=PSJDFN
+27 DO SAVEDRG^PSIVEDRG(.DRG,.TMPDRG)
+28 QUIT
