PSJLIFN ;BIR/MV - IV FINISH USING LM ;Jun 17, 2020@15:43:29
;;5.0;INPATIENT MEDICATIONS ;**1,29,34,37,42,47,50,56,94,80,116,110,181,261,252,313,333,256,380,399**;16 DEC 97;Build 64
;
; 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
NEW PSJOCFG
S PSJOCFG="FN IV"
D PENDING K PSJREN,PSJOCFG
L -^PS(53.1,+PSJORD)
Q
PENDING ; Process pending order.
;* PSIVFN1 is used so it will display 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,PSJOCCHK,PSJFNDS
K PSJIVBD ;This variable was left over from the new backdoor order entry.
; PSJOCCHK is set so if EDIT was use instead of FN to finish order the OC is triggered
S PSJOCCHK=1
;* PSJFNDS is set so dosing is trigger during finishing without changes to the add/sol
S PSJFNDS=1
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 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,PSIVEDIT,PSJOLDNM,PSIVCAL
S PSJCOM=+$P($G(^PS(53.1,+PSJORD,.2)),"^",8)
K PSJIVBD,PSGRDTX,PSIVEDIT
N FIL,PSIVS,DRGOC,PSIVXD,DRGTMP,PSIVOCON,PSGORQF,ON55,NSFF K PSGORQF S NSFF=1
S (ON,PSIVOCON,ON55,PSGORD)=PSJORD D GTDRG^PSIVORFA 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
;PRE UAT group requested to not show the second screen since FDB OC has more text and provider override reason appears after 2nd screen
; 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 Q:$G(PSGORQF)
. ;*** PSJ*5*256
. S PSJOLDNM("ORD_SCHD")=P(9)
. I $$CHKSCHD^PSJMISC2(.PSJOLDNM,$S($G(P("RES"))="R":"R",1:"")) S PSGORQF=1,VALMBCK="R" Q
. S:$G(PSJOLDNM("NEW_SCHD"))]"" P(9)=PSJOLDNM("NEW_SCHD")
. N PSGS0XT,X,PSJNSS S PSJNSS=1,X=P(9),PSGS0XT=P(15) D Q2^PSGS0
. I ON["P",$G(PSJOLDNM("NEW_SCHD"))]"" D
..I $G(PSGS0Y)]"",$G(P(11))]"",(PSGS0Y'=PSJOLDNM("NEW_SCHD")) D
...W $C(7),!!,"PLEASE NOTE: This order's admin times (",P(11),") do not match the times"
...W !?13," for this administration schedule (",PSJOLDNM("NEW_SCHD"),")",!
...D PAUSE^VALM1
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
S VALMBG=1
I $E(P("OT"))="F" S DNE=0 I $G(PSGORQF) D RE^VALM4 Q
I $G(PSGORQF) S VALMBCK="R",P(4)="" K DRG Q
; Will prompt users to choose Dispense IV Additive when more than one are available for the Orderable Item
N PSJQUIT S PSJQUIT=0 D MULTADDS I $G(PSJQUIT) S VALMBCK="R" Q
S PSIVEDIT=""
S PSIVOK="1^3^10^25^26^39^57^58^59^63^64" D CKFLDS^PSIVORC1 I EDIT]"" D EDIT^PSIVEDT
;S PSIVOK="1^3^10^25^26^39^57^58^59^63^64" D CKFLDS^PSIVORC1 I EDIT]"" S PSIVEDIT=EDIT D EDIT^PSIVEDT
;I $G(EDIT)="" D OC^PSIVOC D:'$G(PSGORQF) IN^PSJOCDS($G(ON),"IV","") Q:$G(PSGORQF)
I $D(PSIVEDIT) D OC^PSIVOC
;PSJ*5*261 - Remedy #490875 PSPO 2040
D ENSTOP^PSIVCAL
;D:'$G(PSGORQF) IN^PSJOCDS($G(ON),"IV","")
;If quit then restore DRG( to pre-edit state
I $G(PSGORQF) D GT531^PSIVORFA(DFN,ON) Q
I $G(DONE) S VALMBCK="R" Q
;* PSJFNDS is set so dosing is trigger during finishing without changes to the add/sol
;S PSJFNDS=1
D COMPLTE^PSIVORC1
S:$G(PSIVACEP) VALMBCK="Q"
;Reset PSJFNDS so if FN again, the dosing check is triggered.
S:'$G(PSIVACEP) PSJFNDS=1
I $G(PSGORQF) S VALMBG=1 D RE^VALM4
K NSFF
Q
;
MULTADDS ; If there are multiple IV Additives per Orderable Item, it will prompt for selection
N TMPDRG
S PSJQUIT=0
I $O(DRG("AD",0)) D I PSJQUIT D SAVEDRG^PSIVEDRG(.DRG,.TMPDRG) Q
. D SAVEDRG^PSIVEDRG(.TMPDRG,.DRG)
. N PSIDX,OI,IVLIST
. F PSIDX=1:1 Q:'$D(DRG("AD",PSIDX)) D I PSJQUIT Q
. . S OI=$P(DRG("AD",PSIDX),"^",6) I 'OI Q
. . K IVLIST D IVADDCNT(OI,.IVLIST) I $O(IVLIST(""),-1)'>1 Q
. . W !!,"More than one dispense IV Additives are available for:"
. . W !,"Orderable Item: ",$$GET1^DIQ(50.7,OI,.01)
. . W !," Ordered Dose: ",$P(DRG("AD",PSIDX),"^",3)
. . W !!,"Please select the correct dispense IV Additive below for this order:"
. . N DIR,IVADD,IVCNT,X,Y,DIRUT,DUOUT
. . S DIR("?")="Please select the correct dispense IV Additive below for this order:"
. . F IVCNT=1:1 Q:'$D(IVLIST(IVCNT)) D I PSJQUIT Q
. . . S IVADD=IVLIST(IVCNT)
. . . S X=" "_IVCNT_" "_$$GET1^DIQ(52.6,IVADD,.01)
. . . S $E(X,45)="Additive Strength: "_$S($$GET1^DIQ(52.6,IVADD,19)'="":$$GET1^DIQ(52.6,IVADD,19)_" "_$$GET1^DIQ(52.6,IVADD,2),1:"N/A")
. . . S DIR("A",IVCNT)=X
. . S DIR("A")="Select (1 - "_(IVCNT-1)_"): "
. . S DIR(0)="LA^1:"_(IVCNT-1) D ^DIR I $D(DUOUT)!$D(DIRUT) S PSJQUIT=1 Q
. . I (Y>0) D
. . . S $P(DRG("AD",PSIDX),"^",1,2)=+IVLIST(+Y)_"^"_$$GET1^DIQ(52.6,+IVLIST(+Y),.01)
. W !
Q
;
ORDCHK ;* Do order check for Inpatient Meds IV.
; PSGORQF is defined (CONT^PSGSICHK) if not log an intervention
; No longer use after PSJ*5*181
K PSGORQF
Q
;NEW DRGOC
;D OCORD Q:$G(PSGORQF)
;D GTIVDRG^PSIVORC2 S P(3)="" D ENSTOP^PSIVCAL
ORDCHKA ;* Do order check against existing orders on the profile
;No longer use as of PSJ*5*181
Q
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.
;OCORD was called by ORDCHK. This entry point is no longer use as of PSJ*5*181
Q
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
;
IVADDCNT(OI,IVLIST) ; Returns the number of IV Addtives Associated to the OI and Marked for IV Order Dialog
;Input: OI - PHARMACY ORDERABLE ITEM file (#50.7) IEN
;Output: $$IVADDCNT - Number of IV Additives linked to the Orderable Item
; IVLIST(IV_IEN) - List of IV Additives linked to the Orderable Item
N IVADD,IVADDCNT
S IVADDCNT=0,IVADD=""
F S IVADD=$O(^PS(52.6,"AOI",OI,IVADD)) Q:'IVADD D
. ; Not Used in the IV Order Dialog
. I '$$GET1^DIQ(52.6,IVADD,17,"I") Q
. ; Other IV Solution is INACTIVE
. I $$GET1^DIQ(52.6,IVADD,12,"I"),($$GET1^DIQ(52.6,IVADD,12,"I")'>DT) Q
. ; Other IV Dispense Drug
. S IVADDCNT=IVADDCNT+1,IVLIST(IVADDCNT)=IVADD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJLIFN 9982 printed Mar 13, 2025@21:12:12 Page 2
PSJLIFN ;BIR/MV - IV FINISH USING LM ;Jun 17, 2020@15:43:29
+1 ;;5.0;INPATIENT MEDICATIONS ;**1,29,34,37,42,47,50,56,94,80,116,110,181,261,252,313,333,256,380,399**;16 DEC 97;Build 64
+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 NEW PSJOCFG
+3 SET PSJOCFG="FN IV"
+4 DO PENDING
KILL PSJREN,PSJOCFG
+5 LOCK -^PS(53.1,+PSJORD)
+6 QUIT
PENDING ; Process pending order.
+1 ;* PSIVFN1 is used so it will display 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,PSJOCCHK,PSJFNDS
+7 ;This variable was left over from the new backdoor order entry.
KILL PSJIVBD
+8 ; PSJOCCHK is set so if EDIT was use instead of FN to finish order the OC is triggered
+9 SET PSJOCCHK=1
+10 ;* PSJFNDS is set so dosing is trigger during finishing without changes to the add/sol
+11 SET PSJFNDS=1
+12 SET PSIVAC="CF"
SET (P("PON"),ON)=+PSJORD_"P"
SET DFN=PSGP
+13 SET PSIVUP=+$$GTPCI^PSIVUTL
DO GT531^PSIVORFA(DFN,ON)
+14 if '$DATA(P("OT"))
DO GTOT^PSIVUTL(P(4))
+15 NEW PSJL
+16 NEW PSIVNUM,PSJSTAR
SET PSIVNUM=1
+17 if ON'=PSJORD
QUIT
+18 IF $GET(PSJLYN)]""
if ON'=PSJLYN
QUIT
+19 SET PSJMAI=ON
+20 IF P("OT")="I"
Begin DoDot:1
+21 SET PSJSTAR="(5)^(7)^(9)^(10)"
+22 ;; ^PSJLIVMD
DO EN^VALM("PSJ LM IV INPT PENDING")
End DoDot:1
QUIT
+23 SET PSJSTAR="(1)^(2)^(3)^(5)^(7)^(9)"
+24 ;; ^PSJLIVFD
DO GTDATA
DO EN^VALM("PSJ LM IV PENDING")
+25 KILL PSJMAI
QUIT
+26 ;
DISPLAY ;
+1 SET VALMSG="Press Return to continue"
+2 if $EXTRACT(P("OT"))="I"
DO EN^VALM("PSJ LM IV INPT DISPLAY")
+3 if $EXTRACT(P("OT"))'="I"
DO EN^VALM("PSJ LM IV DISPLAY")
+4 KILL PSJDISP
+5 if '$GET(PSJHIS)
SET VALMBCK=""
+6 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,PSIVEDIT,PSJOLDNM,PSIVCAL
+7 SET PSJCOM=+$PIECE($GET(^PS(53.1,+PSJORD,.2)),"^",8)
+8 KILL PSJIVBD,PSGRDTX,PSIVEDIT
+9 NEW FIL,PSIVS,DRGOC,PSIVXD,DRGTMP,PSIVOCON,PSGORQF,ON55,NSFF
KILL PSGORQF
SET NSFF=1
+10 SET (ON,PSIVOCON,ON55,PSGORD)=PSJORD
DO GTDRG^PSIVORFA
if PSJORD'=PSJMAI
QUIT
IF $GET(PSJLYN)]""
if PSJORD'=PSJLYN
QUIT
+11 DO UDVARS^PSJLIORD
+12 IF $GET(PSJPROT)=3
IF '$$ENIVUD^PSGOEF1(PSJORD)
KILL NSFF
QUIT
+13 DO HOLDHDR^PSJOE
+14 ;PRE UAT group requested to not show the second screen since FDB OC has more text and provider override reason appears after 2nd screen
+15 ; force the display of the second screen if CPRS order checks exist
+16 ;I $O(^PS(53.1,+PSJORD,12,0))!$O(^PS(53.1,+PSJORD,10,0)) D
+17 ;.Q:$G(PSJLMX)=1 ;no second screen to display
+18 ;.S VALMBG=16 D RE^VALM4,PAUSE^VALM1 S VALMBG=1
+19 SET P("OPI")=$$ENPC^PSJUTL("V",+PSIVUP,60,P("OPI"))
+20 ;I $E(P("OT"))="I" D GTDATA Q:P(4)=""
+21 ;I $E(P("OT"))="I",'$D(DRG("AD")),('$D(DRG("SOL"))) D
+22 IF $GET(P("RES"))'="R"
DO 53^PSIVORC1
+23 IF $GET(P(4))]""
IF $GET(P(15))]""
IF $GET(P(9))]""
IF $$SCHREQ^PSJLIVFD(.P)
Begin DoDot:1
+24 ;*** PSJ*5*256
+25 SET PSJOLDNM("ORD_SCHD")=P(9)
+26 IF $$CHKSCHD^PSJMISC2(.PSJOLDNM,$SELECT($GET(P("RES"))="R":"R",1:""))
SET PSGORQF=1
SET VALMBCK="R"
QUIT
+27 if $GET(PSJOLDNM("NEW_SCHD"))]""
SET P(9)=PSJOLDNM("NEW_SCHD")
+28 NEW PSGS0XT,X,PSJNSS
SET PSJNSS=1
SET X=P(9)
SET PSGS0XT=P(15)
DO Q2^PSGS0
+29 IF ON["P"
IF $GET(PSJOLDNM("NEW_SCHD"))]""
Begin DoDot:2
+30 IF $GET(PSGS0Y)]""
IF $GET(P(11))]""
IF (PSGS0Y'=PSJOLDNM("NEW_SCHD"))
Begin DoDot:3
+31 WRITE $CHAR(7),!!,"PLEASE NOTE: This order's admin times (",P(11),") do not match the times"
+32 WRITE !?13," for this administration schedule (",PSJOLDNM("NEW_SCHD"),")",!
+33 DO PAUSE^VALM1
End DoDot:3
End DoDot:2
End DoDot:1
if $GET(PSGORQF)
QUIT
+34 IF P(4)=""
DO RE^VALM4
QUIT
+35 IF $EXTRACT(P("OT"))="I"
DO GTDATA
Begin DoDot:1
+36 IF '$DATA(DRG("AD"))
IF ('$DATA(DRG("SOL")))
SET DNE=0
DO GTIVDRG^PSIVORC2
SET P(3)=""
DO ENSTOP^PSIVCAL
End DoDot:1
+37 SET VALMBG=1
+38 IF $EXTRACT(P("OT"))="F"
SET DNE=0
IF $GET(PSGORQF)
DO RE^VALM4
QUIT
+39 IF $GET(PSGORQF)
SET VALMBCK="R"
SET P(4)=""
KILL DRG
QUIT
+40 ; Will prompt users to choose Dispense IV Additive when more than one are available for the Orderable Item
+41 NEW PSJQUIT
SET PSJQUIT=0
DO MULTADDS
IF $GET(PSJQUIT)
SET VALMBCK="R"
QUIT
+42 SET PSIVEDIT=""
+43 SET PSIVOK="1^3^10^25^26^39^57^58^59^63^64"
DO CKFLDS^PSIVORC1
IF EDIT]""
DO EDIT^PSIVEDT
+44 ;S PSIVOK="1^3^10^25^26^39^57^58^59^63^64" D CKFLDS^PSIVORC1 I EDIT]"" S PSIVEDIT=EDIT D EDIT^PSIVEDT
+45 ;I $G(EDIT)="" D OC^PSIVOC D:'$G(PSGORQF) IN^PSJOCDS($G(ON),"IV","") Q:$G(PSGORQF)
+46 IF $DATA(PSIVEDIT)
DO OC^PSIVOC
+47 ;PSJ*5*261 - Remedy #490875 PSPO 2040
+48 DO ENSTOP^PSIVCAL
+49 ;D:'$G(PSGORQF) IN^PSJOCDS($G(ON),"IV","")
+50 ;If quit then restore DRG( to pre-edit state
+51 IF $GET(PSGORQF)
DO GT531^PSIVORFA(DFN,ON)
QUIT
+52 IF $GET(DONE)
SET VALMBCK="R"
QUIT
+53 ;* PSJFNDS is set so dosing is trigger during finishing without changes to the add/sol
+54 ;S PSJFNDS=1
+55 DO COMPLTE^PSIVORC1
+56 if $GET(PSIVACEP)
SET VALMBCK="Q"
+57 ;Reset PSJFNDS so if FN again, the dosing check is triggered.
+58 if '$GET(PSIVACEP)
SET PSJFNDS=1
+59 IF $GET(PSGORQF)
SET VALMBG=1
DO RE^VALM4
+60 KILL NSFF
+61 QUIT
+62 ;
MULTADDS ; If there are multiple IV Additives per Orderable Item, it will prompt for selection
+1 NEW TMPDRG
+2 SET PSJQUIT=0
+3 IF $ORDER(DRG("AD",0))
Begin DoDot:1
+4 DO SAVEDRG^PSIVEDRG(.TMPDRG,.DRG)
+5 NEW PSIDX,OI,IVLIST
+6 FOR PSIDX=1:1
if '$DATA(DRG("AD",PSIDX))
QUIT
Begin DoDot:2
+7 SET OI=$PIECE(DRG("AD",PSIDX),"^",6)
IF 'OI
QUIT
+8 KILL IVLIST
DO IVADDCNT(OI,.IVLIST)
IF $ORDER(IVLIST(""),-1)'>1
QUIT
+9 WRITE !!,"More than one dispense IV Additives are available for:"
+10 WRITE !,"Orderable Item: ",$$GET1^DIQ(50.7,OI,.01)
+11 WRITE !," Ordered Dose: ",$PIECE(DRG("AD",PSIDX),"^",3)
+12 WRITE !!,"Please select the correct dispense IV Additive below for this order:"
+13 NEW DIR,IVADD,IVCNT,X,Y,DIRUT,DUOUT
+14 SET DIR("?")="Please select the correct dispense IV Additive below for this order:"
+15 FOR IVCNT=1:1
if '$DATA(IVLIST(IVCNT))
QUIT
Begin DoDot:3
+16 SET IVADD=IVLIST(IVCNT)
+17 SET X=" "_IVCNT_" "_$$GET1^DIQ(52.6,IVADD,.01)
+18 SET $EXTRACT(X,45)="Additive Strength: "_$SELECT($$GET1^DIQ(52.6,IVADD,19)'="":$$GET1^DIQ(52.6,IVADD,19)_" "_$$GET1^DIQ(52.6,IVADD,2),1:"N/A")
+19 SET DIR("A",IVCNT)=X
End DoDot:3
IF PSJQUIT
QUIT
+20 SET DIR("A")="Select (1 - "_(IVCNT-1)_"): "
+21 SET DIR(0)="LA^1:"_(IVCNT-1)
DO ^DIR
IF $DATA(DUOUT)!$DATA(DIRUT)
SET PSJQUIT=1
QUIT
+22 IF (Y>0)
Begin DoDot:3
+23 SET $PIECE(DRG("AD",PSIDX),"^",1,2)=+IVLIST(+Y)_"^"_$$GET1^DIQ(52.6,+IVLIST(+Y),.01)
End DoDot:3
End DoDot:2
IF PSJQUIT
QUIT
+24 WRITE !
End DoDot:1
IF PSJQUIT
DO SAVEDRG^PSIVEDRG(.DRG,.TMPDRG)
QUIT
+25 QUIT
+26 ;
ORDCHK ;* Do order check for Inpatient Meds IV.
+1 ; PSGORQF is defined (CONT^PSGSICHK) if not log an intervention
+2 ; No longer use after PSJ*5*181
+3 KILL PSGORQF
+4 QUIT
+5 ;NEW DRGOC
+6 ;D OCORD Q:$G(PSGORQF)
+7 ;D GTIVDRG^PSIVORC2 S P(3)="" D ENSTOP^PSIVCAL
ORDCHKA ;* Do order check against existing orders on the profile
+1 ;No longer use as of PSJ*5*181
+2 QUIT
+3 FOR PSIVAS="AD","SOL"
if $GET(PSGORQF)
QUIT
SET FIL=$SELECT(PSIVAS="AD":52.6,1:52.7)
Begin DoDot:1
+4 FOR PSIVX=0:0
SET PSIVX=$ORDER(DRG(PSIVAS,PSIVX))
if 'PSIVX!($GET(PSGORQF))
QUIT
Begin DoDot:2
+5 SET DRGTMP=DRG(PSIVAS,PSIVX)
+6 ;* Do only 1 duplicate warning when order has >1 of the same additive
+7 if $DATA(PSJADTMP(+DRGTMP))
QUIT
+8 DO ORDERCHK^PSIVEDRG(PSGP,ON,$DATA(DRGOC(ON)))
+9 SET DRGOC(ON,PSIVAS,PSIVX)=DRG(PSIVAS,PSIVX)
+10 SET PSJADTMP(+DRGTMP)=""
End DoDot:2
End DoDot:1
+11 KILL PSJADTMP
+12 QUIT
OCORD ;* Do order check for each drug against the drugs within the order.
+1 ;OCORD was called by ORDCHK. This entry point is no longer use as of PSJ*5*181
+2 QUIT
+3 NEW X,Y,DDRUG,PSIVX,PSJAD,PSJSOL,TMPDRG
+4 DO SAVEDRG^PSIVEDRG(.TMPDRG,.DRG)
+5 ; Find the corresponding DD for the additive within the order
+6 FOR X=0:0
SET X=$ORDER(DRG("AD",X))
if 'X
QUIT
Begin DoDot:1
+7 SET DDRUG=$PIECE($GET(^PS(52.6,+DRG("AD",X),0)),U,2)
+8 if +DDRUG
SET (DDRUG(DDRUG),PSJAD(DDRUG))=$DATA(DDRUG(DDRUG))+1
End DoDot:1
+9 ;
+10 ; Find the corresponding DD for the solution
+11 ;
+12 FOR X=0:0
SET X=$ORDER(DRG("SOL",X))
if 'X
QUIT
Begin DoDot:1
+13 SET DDRUG=$PIECE($GET(^PS(52.7,+DRG("SOL",X),0)),U,2)
+14 if +DDRUG
SET (DDRUG(DDRUG),PSJSOL(DDRUG))=$DATA(DDRUG(DDRUG))+1
End DoDot:1
+15 ;
+16 ; Loop thru each additive to check for DD,DI & DC against the
+17 ; order's dispense drugs
+18 ;
+19 NEW PSJDFN,INTERVEN
SET INTERVEN=""
+20 ;DFN will be killed when call ^PSOORDRG
SET PSJDFN=DFN
+21 FOR PSIVX=0:0
SET PSIVX=$ORDER(PSJAD(PSIVX))
if 'PSIVX
QUIT
Begin DoDot:1
+22 KILL DDRUG(PSIVX)
DO DRGCHK^PSOORDRG(PSJDFN,PSIVX,.DDRUG)
+23 IF PSJAD(PSIVX)>1
SET ^TMP($JOB,"DD",1,0)=PSIVX_U_$PIECE($GET(^PSDRUG(PSIVX,0)),U)_"^^"_ON_";I"
+24 NEW TYPE
FOR TYPE="DD","DI","DC"
DO ORDCHK^PSJLIFNI(PSJDFN,TYPE)
End DoDot:1
+25 FOR PSIVX=0:0
SET PSIVX=$ORDER(PSJSOL(PSIVX))
if 'PSIVX
QUIT
Begin DoDot:1
+26 KILL DDRUG(PSIVX)
DO DRGCHK^PSOORDRG(PSJDFN,PSIVX,.DDRUG)
+27 NEW TYPE
FOR TYPE="DI"
DO ORDCHK^PSJLIFNI(PSJDFN,TYPE)
End DoDot:1
+28 SET DFN=PSJDFN
+29 DO SAVEDRG^PSIVEDRG(.DRG,.TMPDRG)
+30 QUIT
+31 ;
IVADDCNT(OI,IVLIST) ; Returns the number of IV Addtives Associated to the OI and Marked for IV Order Dialog
+1 ;Input: OI - PHARMACY ORDERABLE ITEM file (#50.7) IEN
+2 ;Output: $$IVADDCNT - Number of IV Additives linked to the Orderable Item
+3 ; IVLIST(IV_IEN) - List of IV Additives linked to the Orderable Item
+4 NEW IVADD,IVADDCNT
+5 SET IVADDCNT=0
SET IVADD=""
+6 FOR
SET IVADD=$ORDER(^PS(52.6,"AOI",OI,IVADD))
if 'IVADD
QUIT
Begin DoDot:1
+7 ; Not Used in the IV Order Dialog
+8 IF '$$GET1^DIQ(52.6,IVADD,17,"I")
QUIT
+9 ; Other IV Solution is INACTIVE
+10 IF $$GET1^DIQ(52.6,IVADD,12,"I")
IF ($$GET1^DIQ(52.6,IVADD,12,"I")'>DT)
QUIT
+11 ; Other IV Dispense Drug
+12 SET IVADDCNT=IVADDCNT+1
SET IVLIST(IVADDCNT)=IVADD
End DoDot:1
+13 QUIT
