PSIVOPT ;BIR/PR,MLM-OPTION DRIVER ;06 Aug 98 / 2:17 PM
;;5.0; INPATIENT MEDICATIONS ;**17,27,58,88,104,110,155**;16 DEC 97
;
; Reference to ^PS(55 is supported by DBIA# 2191
; Reference to ^PSDRUG is supported by DBIA# 2192
; Reference to ^PS(52.6 is supported by DBIA# 1231
; Reference to ^PS(52.7 is supported by DBIA# 2173
;
NEW PSIVLOCK S PSIVLOCK=0
;I ON["P" L +^PS(53.1,+ON):1 S:'$T PSIVLOCK=1
I ON["V" L +^PS(55,DFN,"IV",+ON55):1 S:'$T PSIVLOCK=1
I PSIVLOCK W !,$C(7),$C(7),"This order is being edited by another user. Try later." G K
;W ! L +^PS(55,DFN,"IV",+ON55):1 I '$T W !,$C(7),$C(7),"This order is being edited by another user. Try later." G K
I PSIVAC="O"!(PSIVAC="H") S PSIVAC=PSIVAC_"(DFN,ON,P(17),P(3))"
S TEX="Active order ***" I $D(UWLFLAG),UWLFLAG="1.001" S XED=0 D @PSIVAC G K
S DONE=0 F D ACT Q:DONE
;
UNLOCK ; Unlock order.
;I ON["P" L -^PS(53.1,+ON)
;E L -^PS(55,DFN,"IV",+ON55)
I ON["V" L -^PS(55,DFN,"IV",+ON55)
;
K ; Kill variables.
K %,DA,DIE,DIK,DLAYGO,DNE,DR,DRG,DRGI,DRGT,ERR,HELP,J,OD,P,P16,PSIVAL,PSIVC,PSIVLOG,PSIVNOL,PSIVOK,PSIVOPT,PSIVREA,SCRNPRO,TEX,XED
Q
ACT ; Prompt for order action.
K PSJIVBD NEW PSGFDX,PSGSDX S (PSJORD,ON)=ON55
S PSJCOM=$S(ON["V":$P($G(^PS(55,DFN,"IV",+ON,.2)),"^",8),1:$P($G(^PS(53.1,+ON,.2)),"^",8))
D:ON["V" EN^PSJLIORD(DFN,ON)
I ON["P",($P($G(^PS(53.1,+ON,0)),U,9)="N"),'PSJCOM D GT531^PSIVORFA(DFN,ON),VF^PSIVORC2 S DONE=1 Q
I ON["P",PSJCOM Q:'$$LOCK^PSJOEA(DFN,PSJCOM) N PSJO,ON,PSJORD S PSJO=0 F S PSJO=$O(^PS(53.1,"ACX",PSJCOM,PSJO)) Q:'PSJO Q:$G(Y)="Q" S (PSJORD,ON)=PSJO_"P" D
.D:($P($G(^PS(53.1,+ON,0)),U,9)="N") GT531^PSIVORFA(DFN,ON),VF^PSIVORC2
.D:($P($G(^PS(53.1,+ON,0)),U,9)="P") EN^PSJLIFN
I $G(PSJCOM) N PSJORD S PSJORD=PSJCOM D CHK^PSJOEA1
I ON'["V",'+$G(PSJCOM) D EN^PSJLIFN
S DONE=1
Q
;
CK ; Check if drugs are still valid.
F DRGT="AD","SOL" S FIL=$S(DRGT="AD":52.6,1:52.7) F DRGI=0:0 S DRGI=$O(DRG(DRGT,DRGI)) Q:'DRGI D
.S DRG=+$P(DRG(DRGT,DRGI),U),X=$G(^PS(FIL,DRG,"I")) I $S('X:0,DT<X:0,1:1)!$S('$G(^PSDRUG(+$P($G(^PS(FIL,DRG,0)),U,2),"I")):0,^("I")>DT:0,1:1) S ERR=1
Q
;
D ; Discontinue order.
D D^PSIVOPT2
Q
;
O(DFN,ON,STAT,STOP) ; On/Off Call
D NOW^%DTC I STAT="H",STOP<% D EXPIR Q
I "OA"'[STAT W !,$C(7),"Only active orders may be placed on hold." Q
S PSIVALT=1,PSIVREA=$S(STAT'="O":"O",1:"C"),(P(17),STAT)=$S(PSIVREA="O":"O",1:"A") W:PSIVREA="C" ?$X+4,$C(7),TEX
D UPSTAT,LOG^PSIVORAL D:STAT="A" CKO^PSIVCHK
Q
;
E ; Entry for Pharmacy edit
N PSJEDIT1 D E^PSIVOPT1
Q
;
R ; Renew order.
D R^PSIVOPT2
Q
;
H(DFN,ON,STAT,STOP) ; Place order on hold.
D NOW^%DTC I STAT="H" I STOP<% D EXPIR Q
I "HA"'[STAT W !,$C(7),"Only active orders may be placed on hold." Q
D NATURE^PSIVOREN I '$D(P("NAT")) W !!,"Order unchanged." Q
S PSIVALT=1,PSIVREA=$S(STAT'="H":"H",1:"U"),(P(17),STAT)=$S(PSIVREA="H":"H",1:"A") W:PSIVREA="U" ?$X+4,$C(7),TEX
D UPSTAT,LOG^PSIVORAL,HOLD^PSIVOE,ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,$S(PSIVREA="H":"H1",1:"H0")) D:STAT="A" CKO^PSIVCHK
Q
;
S ; View order.
D @$S(ON55["V":"GT55^PSIVORFB",1:"GT531^PSIVORFA("_DFN_","""_ON55_""")") W @IOF D EN^PSIVORV2
Q
;
EXPIR ; Update status of expired orders.
I STAT="H" S PSIVREA="H",P(17)="E"
S STAT="E" D UPSTAT,EXPIR^PSIVOE W $C(7)," This order has expired."
Q
;
UPSTAT ; Update orders status.
N DA,DR,DIE,PSIVACT S PSIVACT=1,DA=+ON55,DA(1)=DFN,DIE="^PS(55,"_DFN_",""IV"",",DR="100///"_P(17)_$S($G(PSIVREA)="H":";149///1",$G(PSIVREA)="U":";149///@",1:"") D ^DIE
Q
;
ENIN ; Entry for inpatient order entry/profile options.
N DFN,ON,P,PSIVAC S PSIVAC="C" I PSJORD["P" S (P("PON"),ON)=+PSJORD_"P",DFN=PSGP D SHOW1^PSIVORC Q
S (P("PON"),ON,ON55)=+PSJORD_"V",DFN=PSGP D GT55^PSIVORFB,EN^PSIVORV2,PSIVOPT:'$D(PSJPRF)
L -^PS(55,DFN,"IV",+PSJORD)
Q
;
ENARI(DFN,ON,PSGUOW,PSIVAL) ; Auto-reinstate IV orders if movement is deleted.
;Create a list of recipients beyond normal mail group
S PSGORNUM=$S($G(PSGORD):PSGORD,$G(PSJORD):PSJORD,$G(OR55):OR55,1:"")
I $G(PSGORNUM) D
.I $D(^PS(55,PSGP,"IV",+PSGORNUM,0)),$P(^PS(55,PSGP,"IV",+PSGORNUM,0),U,6)'="" S PSJSENTO($J,$P(^PS(55,PSGP,"IV",+PSGORNUM,0),U,6))="" ; Provider
.I $D(^PS(55,PSGP,"IV",+PSGORNUM,2)),$P(^PS(55,PSGP,"IV",+PSGORNUM,2),U,11)'="" S PSJSENTO($J,$P(^PS(55,PSGP,"IV",+PSGORNUM,2),U,11))="" ; Entered by
.I $D(^PS(55,PSGP,"IV",+PSGORNUM,4)),$P(^PS(55,PSGP,"IV",+PSGORNUM,4),U,1)'="" S PSJSENTO($J,$P(^PS(55,PSGP,"IV",+PSGORNUM,4),U,1))="" ; Verifying Nurse
; find pharmacist that finished the IV order
N PSJX,ENTBY S PSJX=$G(^PS(55,PSGP,"IV",+ON,"A",1,0))
I $P(PSJX,U,2)="F" S ENTBY=$$VA200($P(PSJX,U,3)) I ENTBY'="" S PSJSENTO($J,ENTBY)=""
;
I $G(PSGALO)'=18530,$G(PSGORNUM),$$IVDUPADD^PSIVOPT(PSGP,+PSGORNUM) S ^TMP("PSJNOTUNDC",$J,PSGP,+PSGORNUM_"V")="" Q
N DA,DR,DIE,DIK,PSIVREA,PSIVALCK,PSIVOPT,PSIVALT,X,Y
S X=$G(^PS(55,DFN,"IV",+ON,"ADC")) I X K ^PS(55,"ADC",X,DFN,+ON),^PS(55,DFN,"IV",+ON,"ADC")
S PSIVACT=1,DR=$S(+$P($G(^PS(55,DFN,"IV",+ON,4)),U,18)=1:"100///H",+$P($G(^PS(55,DFN,"IV",+ON,0)),U,10)=1:"100///H",1:"100///A")_";.03////"_+$P($G(^PS(55,DFN,"IV",+ON,2)),U,7)_";109///@;116///@;121///@"
S DIE="^PS(55,"_DFN_",""IV"",",DA=+ON,DA(1)=DFN
N CHKIT S CHKIT=$G(^PS(55,DFN,"IV",+ON,2)) I $P(CHKIT,U,6)["P",($P(CHKIT,U,9)="R") S DR=DR_";114///@;123///@"
D ^DIE
S ^TMP("PSJUNDC",$J,DFN,ON_"V")=""
S ON55=ON,P(17)="A",PSIVREA=$S($D(PSJUNDC):"AI",1:"I"),PSIVALCK="STOP",(PSIVOPT,PSIVALT)=1,PSIVAL=$P($G(^PS(53.3,+PSIVAL,0)),U) D LOG^PSIVORAL
;* S Y=^PS(55,DFN,"IV",+ON,0),P(3)=+$P(Y,U,3),ORIFN=$P(Y,U,21),P(12)="" D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D
S Y=^PS(55,DFN,"IV",+ON,0),P(3)=+$P(Y,U,3),P(12)="" D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D
.D EN1^PSJHL2(DFN,"SC",+ON55_"V","AUTO REINSTATED")
S PSGTOL=$S($D(PSJUNDC):3,1:2)
Q:$S('$D(PSJUNDC):0,PSGALO=18540:1,1:'$P($G(PSJSYSW0),U,15))
I $D(^PS(53.41,1,1,PSGUOW,1,DFN,1,3,1,+ON)) K DIK,DA S DIK="^PS(53.41,1,1,"_PSGUOW_",1,"_DFN_",1,3,1,",DA=+ON,DA(1)=1,DA(2)=PSGP,DA(3)=PSGUOW,DA(4)=3 D ^DIK
E K DA D ENLBL^PSIVOPT(PSGTOL,PSGUOW,DFN,3,+ON,"RE")
Q
;
ENINP(DFN,ON) ; Entry from Inpatient Profile.
N PSIVAC,ON55 S PSIVAC="PRO" D @($S(ON["V":"GT55^PSIVORFB",1:"GT531^PSIVORFA("_DFN_","""_ON_""")")),ENNH^PSIVORV2(ON)
Q
ENLBL(PSGTOL,PSGUOW,PSGP,PSGTOO,DA,RES) ;
;Queue MAR labels for IV orders.
Q:'$D(^DPT(PSGP,.1)) I '$D(PSJSYSW0) N PSJACPF,PSJACNWP S PSJACPF=11 D WP^PSJAC Q:'PSJSYSL
N P,X,Y
S X=$P(PSJSYSW0,U,2),Y=$P($G(^PS(55,PSGP,"IV",DA,0)),U,4)
S Y=$S(Y="A":4,Y="H":5,Y="C":6,1:3) I X=1!(X[Y) D NOW^%DTC S PSGDT=% D ENL^PSGVDS S ^PS(55,DFN,"IV",DA,7)=PSGDT_U_RES
Q
;
IVDUPADD(PSGP,ORDERNUM) ;
N PSJCOM
S DUPLOOP=0
S DUPFOUND=0
;Loop through the additives of order to reinstate
S PSJCOM=+$P($G(^PS(55,+PSGP,"IV",ORDERNUM,.2)),"^",8) F S DUPLOOP=$O(^PS(55,PSGP,"IV",ORDERNUM,"AD",DUPLOOP)) Q:((DUPLOOP="")!(DUPFOUND)) D
.;Get the additive code no.
.S TARGET=$P(^PS(55,PSGP,"IV",ORDERNUM,"AD",DUPLOOP,0),"^",1)
.D NOW^%DTC
.S DATELOOP=%
.;Loop through the current orders for the patient by date
.F S DATELOOP=$O(^PS(55,PSGP,"IV","AIS",DATELOOP)) Q:((DATELOOP="")!(DUPFOUND)) D
..S EXISTORD=""
..;Loop through the orders for date by order number
..F S EXISTORD=$O(^PS(55,PSGP,"IV","AIS",DATELOOP,EXISTORD)) Q:((EXISTORD="")!(DUPFOUND)) D
...;Loop through additives for the existing order
...I PSJCOM>0 Q:+$P($G(^PS(55,+PSGP,"IV",EXISTORD,.2)),"^",8)
...S EXISTADD=0
...F S EXISTADD=$O(^PS(55,PSGP,"IV",EXISTORD,"AD",EXISTADD)) Q:((EXISTADD="")!(DUPFOUND)) D
....;Extract the Additive Code number for the Order
....S MATCHADD=$P(^PS(55,PSGP,"IV",EXISTORD,"AD",EXISTADD,0),"^",1)
....;If the existing order and the order to be reinstated have the same additive code then return FOUND=TRUE
....I MATCHADD=TARGET D
.....S DUPFOUND=1
Q DUPFOUND
;
VA200(X) ;Return the IEN for the user.
; X = User name
NEW DIC,Y S DIC="^VA(200,",DIC(0)="NZ" D ^DIC
I +Y=-1 Q ""
Q $P(Y,U)
PSIVOPT ;BIR/PR,MLM-OPTION DRIVER ;06 Aug 98 / 2:17 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**17,27,58,88,104,110,155**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191
+4 ; Reference to ^PSDRUG is supported by DBIA# 2192
+5 ; Reference to ^PS(52.6 is supported by DBIA# 1231
+6 ; Reference to ^PS(52.7 is supported by DBIA# 2173
+7 ;
+8 NEW PSIVLOCK
SET PSIVLOCK=0
+9 ;I ON["P" L +^PS(53.1,+ON):1 S:'$T PSIVLOCK=1
+10 IF ON["V"
LOCK +^PS(55,DFN,"IV",+ON55):1
IF '$TEST
SET PSIVLOCK=1
+11 IF PSIVLOCK
WRITE !,$CHAR(7),$CHAR(7),"This order is being edited by another user. Try later."
GOTO K
+12 ;W ! L +^PS(55,DFN,"IV",+ON55):1 I '$T W !,$C(7),$C(7),"This order is being edited by another user. Try later." G K
+13 IF PSIVAC="O"!(PSIVAC="H")
SET PSIVAC=PSIVAC_"(DFN,ON,P(17),P(3))"
+14 SET TEX="Active order ***"
IF $DATA(UWLFLAG)
IF UWLFLAG="1.001"
SET XED=0
DO @PSIVAC
GOTO K
+15 SET DONE=0
FOR
DO ACT
IF DONE
QUIT
+16 ;
UNLOCK ; Unlock order.
+1 ;I ON["P" L -^PS(53.1,+ON)
+2 ;E L -^PS(55,DFN,"IV",+ON55)
+3 IF ON["V"
LOCK -^PS(55,DFN,"IV",+ON55)
+4 ;
K ; Kill variables.
+1 KILL %,DA,DIE,DIK,DLAYGO,DNE,DR,DRG,DRGI,DRGT,ERR,HELP,J,OD,P,P16,PSIVAL,PSIVC,PSIVLOG,PSIVNOL,PSIVOK,PSIVOPT,PSIVREA,SCRNPRO,TEX,XED
+2 QUIT
ACT ; Prompt for order action.
+1 KILL PSJIVBD
NEW PSGFDX,PSGSDX
SET (PSJORD,ON)=ON55
+2 SET PSJCOM=$SELECT(ON["V":$PIECE($GET(^PS(55,DFN,"IV",+ON,.2)),"^",8),1:$PIECE($GET(^PS(53.1,+ON,.2)),"^",8))
+3 IF ON["V"
DO EN^PSJLIORD(DFN,ON)
+4 IF ON["P"
IF ($PIECE($GET(^PS(53.1,+ON,0)),U,9)="N")
IF 'PSJCOM
DO GT531^PSIVORFA(DFN,ON)
DO VF^PSIVORC2
SET DONE=1
QUIT
+5 IF ON["P"
IF PSJCOM
IF '$$LOCK^PSJOEA(DFN,PSJCOM)
QUIT
NEW PSJO,ON,PSJORD
SET PSJO=0
FOR
SET PSJO=$ORDER(^PS(53.1,"ACX",PSJCOM,PSJO))
IF 'PSJO
QUIT
IF $GET(Y)="Q"
QUIT
SET (PSJORD,ON)=PSJO_"P"
Begin DoDot:1
+6 IF ($PIECE($GET(^PS(53.1,+ON,0)),U,9)="N")
DO GT531^PSIVORFA(DFN,ON)
DO VF^PSIVORC2
+7 IF ($PIECE($GET(^PS(53.1,+ON,0)),U,9)="P")
DO EN^PSJLIFN
End DoDot:1
+8 IF $GET(PSJCOM)
NEW PSJORD
SET PSJORD=PSJCOM
DO CHK^PSJOEA1
+9 IF ON'["V"
IF '+$GET(PSJCOM)
DO EN^PSJLIFN
+10 SET DONE=1
+11 QUIT
+12 ;
CK ; Check if drugs are still valid.
+1 FOR DRGT="AD","SOL"
SET FIL=$SELECT(DRGT="AD":52.6,1:52.7)
FOR DRGI=0:0
SET DRGI=$ORDER(DRG(DRGT,DRGI))
IF 'DRGI
QUIT
Begin DoDot:1
+2 SET DRG=+$PIECE(DRG(DRGT,DRGI),U)
SET X=$GET(^PS(FIL,DRG,"I"))
IF $SELECT('X:0,DT<X:0,1:1)!$SELECT('$GET(^PSDRUG(+$PIECE($GET(^PS(FIL,DRG,0)),U,2),"I")):0,^("I")>DT:0,1:1)
SET ERR=1
End DoDot:1
+3 QUIT
+4 ;
D ; Discontinue order.
+1 DO D^PSIVOPT2
+2 QUIT
+3 ;
O(DFN,ON,STAT,STOP) ; On/Off Call
+1 DO NOW^%DTC
IF STAT="H"
IF STOP<%
DO EXPIR
QUIT
+2 IF "OA"'[STAT
WRITE !,$CHAR(7),"Only active orders may be placed on hold."
QUIT
+3 SET PSIVALT=1
SET PSIVREA=$SELECT(STAT'="O":"O",1:"C")
SET (P(17),STAT)=$SELECT(PSIVREA="O":"O",1:"A")
IF PSIVREA="C"
WRITE ?$X+4,$CHAR(7),TEX
+4 DO UPSTAT
DO LOG^PSIVORAL
IF STAT="A"
DO CKO^PSIVCHK
+5 QUIT
+6 ;
E ; Entry for Pharmacy edit
+1 NEW PSJEDIT1
DO E^PSIVOPT1
+2 QUIT
+3 ;
R ; Renew order.
+1 DO R^PSIVOPT2
+2 QUIT
+3 ;
H(DFN,ON,STAT,STOP) ; Place order on hold.
+1 DO NOW^%DTC
IF STAT="H"
IF STOP<%
DO EXPIR
QUIT
+2 IF "HA"'[STAT
WRITE !,$CHAR(7),"Only active orders may be placed on hold."
QUIT
+3 DO NATURE^PSIVOREN
IF '$DATA(P("NAT"))
WRITE !!,"Order unchanged."
QUIT
+4 SET PSIVALT=1
SET PSIVREA=$SELECT(STAT'="H":"H",1:"U")
SET (P(17),STAT)=$SELECT(PSIVREA="H":"H",1:"A")
IF PSIVREA="U"
WRITE ?$X+4,$CHAR(7),TEX
+5 DO UPSTAT
DO LOG^PSIVORAL
DO HOLD^PSIVOE
DO ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,$SELECT(PSIVREA="H":"H1",1:"H0"))
IF STAT="A"
DO CKO^PSIVCHK
+6 QUIT
+7 ;
S ; View order.
+1 DO @$SELECT(ON55["V":"GT55^PSIVORFB",1:"GT531^PSIVORFA("_DFN_","""_ON55_""")")
WRITE @IOF
DO EN^PSIVORV2
+2 QUIT
+3 ;
EXPIR ; Update status of expired orders.
+1 IF STAT="H"
SET PSIVREA="H"
SET P(17)="E"
+2 SET STAT="E"
DO UPSTAT
DO EXPIR^PSIVOE
WRITE $CHAR(7)," This order has expired."
+3 QUIT
+4 ;
UPSTAT ; Update orders status.
+1 NEW DA,DR,DIE,PSIVACT
SET PSIVACT=1
SET DA=+ON55
SET DA(1)=DFN
SET DIE="^PS(55,"_DFN_",""IV"","
SET DR="100///"_P(17)_$SELECT($GET(PSIVREA)="H":";149///1",$GET(PSIVREA)="U":";149///@",1:"")
DO ^DIE
+2 QUIT
+3 ;
ENIN ; Entry for inpatient order entry/profile options.
+1 NEW DFN,ON,P,PSIVAC
SET PSIVAC="C"
IF PSJORD["P"
SET (P("PON"),ON)=+PSJORD_"P"
SET DFN=PSGP
DO SHOW1^PSIVORC
QUIT
+2 SET (P("PON"),ON,ON55)=+PSJORD_"V"
SET DFN=PSGP
DO GT55^PSIVORFB
DO EN^PSIVORV2
IF '$DATA(PSJPRF)
DO PSIVOPT
+3 LOCK -^PS(55,DFN,"IV",+PSJORD)
+4 QUIT
+5 ;
ENARI(DFN,ON,PSGUOW,PSIVAL) ; Auto-reinstate IV orders if movement is deleted.
+1 ;Create a list of recipients beyond normal mail group
+2 SET PSGORNUM=$SELECT($GET(PSGORD):PSGORD,$GET(PSJORD):PSJORD,$GET(OR55):OR55,1:"")
+3 IF $GET(PSGORNUM)
Begin DoDot:1
+4 ; Provider
IF $DATA(^PS(55,PSGP,"IV",+PSGORNUM,0))
IF $PIECE(^PS(55,PSGP,"IV",+PSGORNUM,0),U,6)'=""
SET PSJSENTO($JOB,$PIECE(^PS(55,PSGP,"IV",+PSGORNUM,0),U,6))=""
+5 ; Entered by
IF $DATA(^PS(55,PSGP,"IV",+PSGORNUM,2))
IF $PIECE(^PS(55,PSGP,"IV",+PSGORNUM,2),U,11)'=""
SET PSJSENTO($JOB,$PIECE(^PS(55,PSGP,"IV",+PSGORNUM,2),U,11))=""
+6 ; Verifying Nurse
IF $DATA(^PS(55,PSGP,"IV",+PSGORNUM,4))
IF $PIECE(^PS(55,PSGP,"IV",+PSGORNUM,4),U,1)'=""
SET PSJSENTO($JOB,$PIECE(^PS(55,PSGP,"IV",+PSGORNUM,4),U,1))=""
End DoDot:1
+7 ; find pharmacist that finished the IV order
+8 NEW PSJX,ENTBY
SET PSJX=$GET(^PS(55,PSGP,"IV",+ON,"A",1,0))
+9 IF $PIECE(PSJX,U,2)="F"
SET ENTBY=$$VA200($PIECE(PSJX,U,3))
IF ENTBY'=""
SET PSJSENTO($JOB,ENTBY)=""
+10 ;
+11 IF $GET(PSGALO)'=18530
IF $GET(PSGORNUM)
IF $$IVDUPADD^PSIVOPT(PSGP,+PSGORNUM)
SET ^TMP("PSJNOTUNDC",$JOB,PSGP,+PSGORNUM_"V")=""
QUIT
+12 NEW DA,DR,DIE,DIK,PSIVREA,PSIVALCK,PSIVOPT,PSIVALT,X,Y
+13 SET X=$GET(^PS(55,DFN,"IV",+ON,"ADC"))
IF X
KILL ^PS(55,"ADC",X,DFN,+ON),^PS(55,DFN,"IV",+ON,"ADC")
+14 SET PSIVACT=1
SET DR=$SELECT(+$PIECE($GET(^PS(55,DFN,"IV",+ON,4)),U,18)=1:"100///H",+$PIECE($GET(^PS(55,DFN,"IV",+ON,0)),U,10)=1:"100///H",1:"100///A")_";.03////"_+$PIECE($GET(^PS(55,DFN,"IV",+ON,2)),U,7)_";109///@;116///@;121///@"
+15 SET DIE="^PS(55,"_DFN_",""IV"","
SET DA=+ON
SET DA(1)=DFN
+16 NEW CHKIT
SET CHKIT=$GET(^PS(55,DFN,"IV",+ON,2))
IF $PIECE(CHKIT,U,6)["P"
IF ($PIECE(CHKIT,U,9)="R")
SET DR=DR_";114///@;123///@"
+17 DO ^DIE
+18 SET ^TMP("PSJUNDC",$JOB,DFN,ON_"V")=""
+19 SET ON55=ON
SET P(17)="A"
SET PSIVREA=$SELECT($DATA(PSJUNDC):"AI",1:"I")
SET PSIVALCK="STOP"
SET (PSIVOPT,PSIVALT)=1
SET PSIVAL=$PIECE($GET(^PS(53.3,+PSIVAL,0)),U)
DO LOG^PSIVORAL
+20 ;* S Y=^PS(55,DFN,"IV",+ON,0),P(3)=+$P(Y,U,3),ORIFN=$P(Y,U,21),P(12)="" D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D
+21 SET Y=^PS(55,DFN,"IV",+ON,0)
SET P(3)=+$PIECE(Y,U,3)
SET P(12)=""
IF '$DATA(PSJIVORF)
DO ORPARM^PSIVOREN
IF PSJIVORF
Begin DoDot:1
+22 DO EN1^PSJHL2(DFN,"SC",+ON55_"V","AUTO REINSTATED")
End DoDot:1
+23 SET PSGTOL=$SELECT($DATA(PSJUNDC):3,1:2)
+24 IF $SELECT('$DATA(PSJUNDC)
QUIT
+25 IF $DATA(^PS(53.41,1,1,PSGUOW,1,DFN,1,3,1,+ON))
KILL DIK,DA
SET DIK="^PS(53.41,1,1,"_PSGUOW_",1,"_DFN_",1,3,1,"
SET DA=+ON
SET DA(1)=1
SET DA(2)=PSGP
SET DA(3)=PSGUOW
SET DA(4)=3
DO ^DIK
+26 IF '$TEST
KILL DA
DO ENLBL^PSIVOPT(PSGTOL,PSGUOW,DFN,3,+ON,"RE")
+27 QUIT
+28 ;
ENINP(DFN,ON) ; Entry from Inpatient Profile.
+1 NEW PSIVAC,ON55
SET PSIVAC="PRO"
DO @($SELECT(ON["V":"GT55^PSIVORFB",1:"GT531^PSIVORFA("_DFN_","""_ON_""")"))
DO ENNH^PSIVORV2(ON)
+2 QUIT
ENLBL(PSGTOL,PSGUOW,PSGP,PSGTOO,DA,RES) ;
+1 ;Queue MAR labels for IV orders.
+2 IF '$DATA(^DPT(PSGP,.1))
QUIT
IF '$DATA(PSJSYSW0)
NEW PSJACPF,PSJACNWP
SET PSJACPF=11
DO WP^PSJAC
IF 'PSJSYSL
QUIT
+3 NEW P,X,Y
+4 SET X=$PIECE(PSJSYSW0,U,2)
SET Y=$PIECE($GET(^PS(55,PSGP,"IV",DA,0)),U,4)
+5 SET Y=$SELECT(Y="A":4,Y="H":5,Y="C":6,1:3)
IF X=1!(X[Y)
DO NOW^%DTC
SET PSGDT=%
DO ENL^PSGVDS
SET ^PS(55,DFN,"IV",DA,7)=PSGDT_U_RES
+6 QUIT
+7 ;
IVDUPADD(PSGP,ORDERNUM) ;
+1 NEW PSJCOM
+2 SET DUPLOOP=0
+3 SET DUPFOUND=0
+4 ;Loop through the additives of order to reinstate
+5 SET PSJCOM=+$PIECE($GET(^PS(55,+PSGP,"IV",ORDERNUM,.2)),"^",8)
FOR
SET DUPLOOP=$ORDER(^PS(55,PSGP,"IV",ORDERNUM,"AD",DUPLOOP))
IF ((DUPLOOP="")!(DUPFOUND))
QUIT
Begin DoDot:1
+6 ;Get the additive code no.
+7 SET TARGET=$PIECE(^PS(55,PSGP,"IV",ORDERNUM,"AD",DUPLOOP,0),"^",1)
+8 DO NOW^%DTC
+9 SET DATELOOP=%
+10 ;Loop through the current orders for the patient by date
+11 FOR
SET DATELOOP=$ORDER(^PS(55,PSGP,"IV","AIS",DATELOOP))
IF ((DATELOOP="")!(DUPFOUND))
QUIT
Begin DoDot:2
+12 SET EXISTORD=""
+13 ;Loop through the orders for date by order number
+14 FOR
SET EXISTORD=$ORDER(^PS(55,PSGP,"IV","AIS",DATELOOP,EXISTORD))
IF ((EXISTORD="")!(DUPFOUND))
QUIT
Begin DoDot:3
+15 ;Loop through additives for the existing order
+16 IF PSJCOM>0
IF +$PIECE($GET(^PS(55,+PSGP,"IV",EXISTORD,.2)),"^",8)
QUIT
+17 SET EXISTADD=0
+18 FOR
SET EXISTADD=$ORDER(^PS(55,PSGP,"IV",EXISTORD,"AD",EXISTADD))
IF ((EXISTADD="")!(DUPFOUND))
QUIT
Begin DoDot:4
+19 ;Extract the Additive Code number for the Order
+20 SET MATCHADD=$PIECE(^PS(55,PSGP,"IV",EXISTORD,"AD",EXISTADD,0),"^",1)
+21 ;If the existing order and the order to be reinstated have the same additive code then return FOUND=TRUE
+22 IF MATCHADD=TARGET
Begin DoDot:5
+23 SET DUPFOUND=1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT DUPFOUND
+25 ;
VA200(X) ;Return the IEN for the user.
+1 ; X = User name
+2 NEW DIC,Y
SET DIC="^VA(200,"
SET DIC(0)="NZ"
DO ^DIC
+3 IF +Y=-1
QUIT ""
+4 QUIT $PIECE(Y,U)
