PSIVORA ;BIR/MLM-MAIN DRIVER FOR IV FLUIDS - OE/RR INTERFACE ;08 JAN 97 / 2:47 PM
;;5.0;INPATIENT MEDICATIONS ;**29,41,110,134,299,374**;16 DEC 97;Build 2
;
; Reference to ^PS(55 is supported by DBIA 2191
;
EN ; Entry point called by IV Fluid protocol.
S X=ORACTION,PSIVAC="O"_$S(X=0:"N",X=1:"E",X=2:"R",X=4:"H",X=6:"D",X="8":"S",1:"") S:X'=5&(X'=7) PSIVUP=+$$GTPCI^PSIVUTL
S (PSGP,DFN)=+ORVP,PSJACNWP=1 D ^PSJAC I "578"[ORACTION D @ORACTION,DONE^PSIVORA1 Q
D ENCPP^PSIVOREN Q:'PSJIVORF!('PSJORF) D EN1,DONE^PSIVORA1
Q
;
EN1 ; Take action on existing order.
S PSJORD=$G(ORPK) I ORGY>8 D @ORGY Q
I 'ORACTION D ^PSIVORFE Q
I '$G(ORPK) W !,"INSUFFICIENT INFORMATION, CANNOT CONTINUE." S OREND=1 Q
I ORPK["V",($P($G(^PS(55,DFN,"IV",+ORPK,0)),U,17)="O") D ONCALL^PSIVORV1 Q
I ORACTION<3 S P("FRES")=$S(ORPK["V":$P($G(^PS(55,DFN,"IV",+ORPK,2)),U,9),1:$P($G(^PS(53.1,+ORPK,0)),U,27)) I P("FRES")]"" D @$S(P("FRES")="R":"ALLREN^PSIVORV1",1:"ALLED^PSIVORV1") Q
S PSJORSTS=ORSTS,PSJORIFN=ORIFN L +@$S(PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD)",1:"^PS(53.1,+PSJORD)"):1 E D LOCKERR^PSIVORA1 Q
D @ORACTION L -@$S(PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD)",1:"^PS(53.1,+PSJORD)")
Q
;
1 ; Edit an existing order.
D EDIT^PSIVORA1
Q
;
2 ; Renew
D RENEW^PSIVORA1
Q
;
3 ; Flag
Q
;
4 ; Hold
I ORSTS'=3,ORSTS'=6 W !,$C(7),"Only ACTIVE orders may be placed on HOLD." S OREND=1 Q
S PSIVREA=$S(ORSTS=6:"H",1:"U"),ON55=PSJORD,$P(^PS(55,DFN,"IV",+ON55,0),U,10)=$S(PSIVREA="H":1,1:""),Y=$G(^PS(55,DFN,"IV",+ON55,0)),P(3)=$P(Y,U,3),P(17)=$P(Y,U,17)
D NOW^%DTC I ORSTS=3,P(3)<% S P(17)="E" D UPSTAT^PSIVOPT S ORSTS=7 W $C(7)," This order has expired." Q
S XED=0,PSIVALT=2,P(17)=$S(PSIVREA="H":"H",1:"A") D UPSTAT^PSIVOPT,LOG^PSIVORAL S ORSTS=$S(PSIVREA="H":3,1:6)
Q
;
5 ; Event
N DA,DIE,DR,ON,P,PSIVACT,X
S ON=ORPK I ON["V" S X=$G(^PS(55,+ORVP,"IV",+ON,0)),P(3)=$P(X,U,3),P(17)=$P(X,U,17)
I ON'["V" S P(3)=$P($G(^PS(53.1,+ON,2)),U,4),P(17)=$P($G(^PS(53.1,+ON,0)),U,9)
Q:"AR"'[P(17) D NOW^%DTC Q:P(3)>%
I ON["V" S DR="100///E",DIE="^PS(55,"_+ORVP_",""IV"",",DA(1)=+ORVP
I ON'["V" S DR="28///E",DIE="^PS(53.1,"
S PSIVACT=1,DA=+ON D ^DIE S ORSTS=7
Q
;
6 ; Cancel - Delete pending or unreleased orders from Nonverified orders
; (53.1) and Orders (100) files.
I ORSTS=1 W $C(7),!,"This order has already been DISCONTINUED." Q
I ORSTS=7 W $C(7),!,"Expired orders cannot be DISCONTINUED." Q
I PSJORD'["V",ORSTS=11 D Q
.S P("OLDON")=$P($G(^PS(53.1,+PSJORD,0)),U,25) I P("OLDON") D
..I P("OLDON")["V",$D(^PS(55,DFN,"IV",+P("OLDON"),2)) S PSJRES=$P(^(2),U,9) S:PSJRES'="R" $P(^(2),U,6)="",$P(^(2),U,9)="" ;; D:PSJRES="R" ENBKOUT^PSJOREN(DFN,PSJORD)
..I P("OLDON")'["V",$D(^PS(53.1,+P("OLDON"),0)) S PSJRES=$P(^(0),U,27) S:PSJRES'="R" $P(^(0),U,26,27)="^" I PSJRES="R" ;; D ENBKOUT^PSJOREN(DFN,PSJORD)
.K DA,DIK S DIK="^PS(53.1,",DA=+PSJORD D ^DIK S PSGP=DFN,X="P" D ENSK^PSGAXR K DA,DIK S ORIFN=PSJORIFN,ORSTS="K" Q
;
DC ; DC order from Pharmacy complete function.
N PROVQUIT S PROVQUIT=0
I PSJORD["V",'PSJCOM N PSIVREA S ON55=PSJORD,X=$G(^PS(55,DFN,"IV",+ON55,0)),P(3)=$P(X,U,3),P(17)=$P(X,U,17),PSIVREA="D",PSIVALT=2,PSIVALCK="STOP" D D^PSIVOPT2 D:'PROVQUIT HL Q
I PSJORD["V",PSJCOM N PSIVREA S ON55=PSJORD,X=$G(^PS(55,DFN,"IV",+ON55,0)),P(3)=$P(X,U,3),P(17)=$P(X,U,17),PSIVREA="D",PSIVALT=2,PSIVALCK="STOP" D D^PSIVOPT2 Q
N DA,DR,DIE,PSJND S DA=+PSJORD,PSJND=$G(^PS(53.1,DA,0)),P("OLDON")=$P(PSJND,U,25),DIE="^PS(53.1,",DR="28///"_$S($P(PSJND,U,27)="E":"DE",1:"D") D ^DIE
D KILL531^PSJIMO1(DFN,"",+PSJORD)
D HL
Q
HL ;
Q:'$D(P("NAT"))
NEW PSJCD,PSJTX,PSJOTMP
I PSJORD["P" N PSJNOO S PSJCD="OC",PSJTX="ORDER CANCELED",PSJNOO=$G(P("NAT"))
E S PSJCD="OD",PSJTX="ORDER DISCONTINUED"
S PSJOTMP=$G(P("OT")) S P("OT")="F" D EN1^PSJHL2(DFN,PSJCD,PSJORD,PSJTX)
Q
;
7 ; Purge
N ND S ND=$S(ORPK["V":$P($G(^PS(55,+ORVP,"IV",+ORPK,0)),U,17)_U_$P($G(^(0)),U,3),1:$P($G(^PS(53.1,+ORPK,0)),U,9)_U_$P($G(^(2)),U,4))
Q:"DE"'[$P(ND,U) S X1=+$P(ND,U,2),X2=30 D C^%DTC S ND=X D NOW^%DTC Q:ND>%
I ORPK["V",$D(^PS(55,+ORVP,"IV",+ORPK,0)) S $P(^(0),U,21)=""
I ORPK'["V",$D(^PS(53.1,+ORPK,0)) S $P(^(0),U,21)=""
S ORSTS="K"
Q
;
8 ; Print
K DIR S DIR(0)="E" D ^DIR K DIR I $D(DUOUT)!'($D(ORPK)) S OREND=1 Q
S:'$G(PSIVUP) PSIVUP=+$$GTPCI^PSIVUTL S:'$D(PSIVAC) PSIVAC="OS" S (ON,ON55)=ORPK,DFN=+ORVP D @$S(ON["V":"GT55^PSIVORFB",1:"GT531^PSIVORFA("_DFN_","""_ON_""")"),ENDT^PSIVORV1
Q
;
9 ; Release order (status=incomplete in 53.1, pending in 100)
S X=ORACTION I X=4!(X=6) D @ORACTION Q
Q:"36"[ORSTS N ON,PSJORIFN S PSJORIFN=ORIFN,ON=ORPK L +^PS(53.1,+ON):1 E D LOCKERR^PSIVORA1 Q
S Y=$G(^PS(53.1,+ON,0)),P("RES")=$P(Y,U,24),P("OLDON")=$P(Y,U,25)
N DA,DIE,DR,OREND S DR="28////P",DIE="^PS(53.1,",DA=+ON D ^DIE
I P("OLDON")]"" K DA,DIE,DR S DA=P("OLDON") D
.I DA["V" S DA(1)=+ORPV,DIE="^PS(55,"_DA(1)_",""IV"",",DR="114////"_+ON_"P"_";123////"_P("RES")
.E S DIE="^PS(53.1,",DR="105////"_ON_"P"_";107////"_P("RES") I P("RES")="E",$P($G(^PS(53.1,+P("OLDON"),0)),U,9)="D" S DR=DR_";28////DE"
.S DA=+DA L +@(DIE_DA_")"):1 E D LOCKERR^PSIVORA1 Q
.D ^DIE L -@(DIE_DA_")")
L -^PS(53.1,+ON) D DONE^PSIVORA1
Q
;
10 ; Verify
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVORA 5250 printed Apr 09, 2024@21:10:11 Page 2
PSIVORA ;BIR/MLM-MAIN DRIVER FOR IV FLUIDS - OE/RR INTERFACE ;08 JAN 97 / 2:47 PM
+1 ;;5.0;INPATIENT MEDICATIONS ;**29,41,110,134,299,374**;16 DEC 97;Build 2
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191
+4 ;
EN ; Entry point called by IV Fluid protocol.
+1 SET X=ORACTION
SET PSIVAC="O"_$SELECT(X=0:"N",X=1:"E",X=2:"R",X=4:"H",X=6:"D",X="8":"S",1:"")
if X'=5&(X'=7)
SET PSIVUP=+$$GTPCI^PSIVUTL
+2 SET (PSGP,DFN)=+ORVP
SET PSJACNWP=1
DO ^PSJAC
IF "578"[ORACTION
DO @ORACTION
DO DONE^PSIVORA1
QUIT
+3 DO ENCPP^PSIVOREN
if 'PSJIVORF!('PSJORF)
QUIT
DO EN1
DO DONE^PSIVORA1
+4 QUIT
+5 ;
EN1 ; Take action on existing order.
+1 SET PSJORD=$GET(ORPK)
IF ORGY>8
DO @ORGY
QUIT
+2 IF 'ORACTION
DO ^PSIVORFE
QUIT
+3 IF '$GET(ORPK)
WRITE !,"INSUFFICIENT INFORMATION, CANNOT CONTINUE."
SET OREND=1
QUIT
+4 IF ORPK["V"
IF ($PIECE($GET(^PS(55,DFN,"IV",+ORPK,0)),U,17)="O")
DO ONCALL^PSIVORV1
QUIT
+5 IF ORACTION<3
SET P("FRES")=$SELECT(ORPK["V":$PIECE($GET(^PS(55,DFN,"IV",+ORPK,2)),U,9),1:$PIECE($GET(^PS(53.1,+ORPK,0)),U,27))
IF P("FRES")]""
DO @$SELECT(P("FRES")="R":"ALLREN^PSIVORV1",1:"ALLED^PSIVORV1")
QUIT
+6 SET PSJORSTS=ORSTS
SET PSJORIFN=ORIFN
LOCK +@$SELECT(PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD)",1:"^PS(53.1,+PSJORD)"):1
IF '$TEST
DO LOCKERR^PSIVORA1
QUIT
+7 DO @ORACTION
LOCK -@$SELECT(PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD)",1:"^PS(53.1,+PSJORD)")
+8 QUIT
+9 ;
1 ; Edit an existing order.
+1 DO EDIT^PSIVORA1
+2 QUIT
+3 ;
2 ; Renew
+1 DO RENEW^PSIVORA1
+2 QUIT
+3 ;
3 ; Flag
+1 QUIT
+2 ;
4 ; Hold
+1 IF ORSTS'=3
IF ORSTS'=6
WRITE !,$CHAR(7),"Only ACTIVE orders may be placed on HOLD."
SET OREND=1
QUIT
+2 SET PSIVREA=$SELECT(ORSTS=6:"H",1:"U")
SET ON55=PSJORD
SET $PIECE(^PS(55,DFN,"IV",+ON55,0),U,10)=$SELECT(PSIVREA="H":1,1:"")
SET Y=$GET(^PS(55,DFN,"IV",+ON55,0))
SET P(3)=$PIECE(Y,U,3)
SET P(17)=$PIECE(Y,U,17)
+3 DO NOW^%DTC
IF ORSTS=3
IF P(3)<%
SET P(17)="E"
DO UPSTAT^PSIVOPT
SET ORSTS=7
WRITE $CHAR(7)," This order has expired."
QUIT
+4 SET XED=0
SET PSIVALT=2
SET P(17)=$SELECT(PSIVREA="H":"H",1:"A")
DO UPSTAT^PSIVOPT
DO LOG^PSIVORAL
SET ORSTS=$SELECT(PSIVREA="H":3,1:6)
+5 QUIT
+6 ;
5 ; Event
+1 NEW DA,DIE,DR,ON,P,PSIVACT,X
+2 SET ON=ORPK
IF ON["V"
SET X=$GET(^PS(55,+ORVP,"IV",+ON,0))
SET P(3)=$PIECE(X,U,3)
SET P(17)=$PIECE(X,U,17)
+3 IF ON'["V"
SET P(3)=$PIECE($GET(^PS(53.1,+ON,2)),U,4)
SET P(17)=$PIECE($GET(^PS(53.1,+ON,0)),U,9)
+4 if "AR"'[P(17)
QUIT
DO NOW^%DTC
if P(3)>%
QUIT
+5 IF ON["V"
SET DR="100///E"
SET DIE="^PS(55,"_+ORVP_",""IV"","
SET DA(1)=+ORVP
+6 IF ON'["V"
SET DR="28///E"
SET DIE="^PS(53.1,"
+7 SET PSIVACT=1
SET DA=+ON
DO ^DIE
SET ORSTS=7
+8 QUIT
+9 ;
6 ; Cancel - Delete pending or unreleased orders from Nonverified orders
+1 ; (53.1) and Orders (100) files.
+2 IF ORSTS=1
WRITE $CHAR(7),!,"This order has already been DISCONTINUED."
QUIT
+3 IF ORSTS=7
WRITE $CHAR(7),!,"Expired orders cannot be DISCONTINUED."
QUIT
+4 IF PSJORD'["V"
IF ORSTS=11
Begin DoDot:1
+5 SET P("OLDON")=$PIECE($GET(^PS(53.1,+PSJORD,0)),U,25)
IF P("OLDON")
Begin DoDot:2
+6 ;; D:PSJRES="R" ENBKOUT^PSJOREN(DFN,PSJORD)
IF P("OLDON")["V"
IF $DATA(^PS(55,DFN,"IV",+P("OLDON"),2))
SET PSJRES=$PIECE(^(2),U,9)
if PSJRES'="R"
SET $PIECE(^(2),U,6)=""
SET $PIECE(^(2),U,9)=""
+7 ;; D ENBKOUT^PSJOREN(DFN,PSJORD)
IF P("OLDON")'["V"
IF $DATA(^PS(53.1,+P("OLDON"),0))
SET PSJRES=$PIECE(^(0),U,27)
if PSJRES'="R"
SET $PIECE(^(0),U,26,27)="^"
IF PSJRES="R"
End DoDot:2
+8 KILL DA,DIK
SET DIK="^PS(53.1,"
SET DA=+PSJORD
DO ^DIK
SET PSGP=DFN
SET X="P"
DO ENSK^PSGAXR
KILL DA,DIK
SET ORIFN=PSJORIFN
SET ORSTS="K"
QUIT
End DoDot:1
QUIT
+9 ;
DC ; DC order from Pharmacy complete function.
+1 NEW PROVQUIT
SET PROVQUIT=0
+2 IF PSJORD["V"
IF 'PSJCOM
NEW PSIVREA
SET ON55=PSJORD
SET X=$GET(^PS(55,DFN,"IV",+ON55,0))
SET P(3)=$PIECE(X,U,3)
SET P(17)=$PIECE(X,U,17)
SET PSIVREA="D"
SET PSIVALT=2
SET PSIVALCK="STOP"
DO D^PSIVOPT2
if 'PROVQUIT
DO HL
QUIT
+3 IF PSJORD["V"
IF PSJCOM
NEW PSIVREA
SET ON55=PSJORD
SET X=$GET(^PS(55,DFN,"IV",+ON55,0))
SET P(3)=$PIECE(X,U,3)
SET P(17)=$PIECE(X,U,17)
SET PSIVREA="D"
SET PSIVALT=2
SET PSIVALCK="STOP"
DO D^PSIVOPT2
QUIT
+4 NEW DA,DR,DIE,PSJND
SET DA=+PSJORD
SET PSJND=$GET(^PS(53.1,DA,0))
SET P("OLDON")=$PIECE(PSJND,U,25)
SET DIE="^PS(53.1,"
SET DR="28///"_$SELECT($PIECE(PSJND,U,27)="E":"DE",1:"D")
DO ^DIE
+5 DO KILL531^PSJIMO1(DFN,"",+PSJORD)
+6 DO HL
+7 QUIT
HL ;
+1 if '$DATA(P("NAT"))
QUIT
+2 NEW PSJCD,PSJTX,PSJOTMP
+3 IF PSJORD["P"
NEW PSJNOO
SET PSJCD="OC"
SET PSJTX="ORDER CANCELED"
SET PSJNOO=$GET(P("NAT"))
+4 IF '$TEST
SET PSJCD="OD"
SET PSJTX="ORDER DISCONTINUED"
+5 SET PSJOTMP=$GET(P("OT"))
SET P("OT")="F"
DO EN1^PSJHL2(DFN,PSJCD,PSJORD,PSJTX)
+6 QUIT
+7 ;
7 ; Purge
+1 NEW ND
SET ND=$SELECT(ORPK["V":$PIECE($GET(^PS(55,+ORVP,"IV",+ORPK,0)),U,17)_U_$PIECE($GET(^(0)),U,3),1:$PIECE($GET(^PS(53.1,+ORPK,0)),U,9)_U_$PIECE($GET(^(2)),U,4))
+2 if "DE"'[$PIECE(ND,U)
QUIT
SET X1=+$PIECE(ND,U,2)
SET X2=30
DO C^%DTC
SET ND=X
DO NOW^%DTC
if ND>%
QUIT
+3 IF ORPK["V"
IF $DATA(^PS(55,+ORVP,"IV",+ORPK,0))
SET $PIECE(^(0),U,21)=""
+4 IF ORPK'["V"
IF $DATA(^PS(53.1,+ORPK,0))
SET $PIECE(^(0),U,21)=""
+5 SET ORSTS="K"
+6 QUIT
+7 ;
8 ; Print
+1 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)!'($DATA(ORPK))
SET OREND=1
QUIT
+2 if '$GET(PSIVUP)
SET PSIVUP=+$$GTPCI^PSIVUTL
if '$DATA(PSIVAC)
SET PSIVAC="OS"
SET (ON,ON55)=ORPK
SET DFN=+ORVP
DO @$SELECT(ON["V":"GT55^PSIVORFB",1:"GT531^PSIVORFA("_DFN_","""_ON_""")")
DO ENDT^PSIVORV1
+3 QUIT
+4 ;
9 ; Release order (status=incomplete in 53.1, pending in 100)
+1 SET X=ORACTION
IF X=4!(X=6)
DO @ORACTION
QUIT
+2 if "36"[ORSTS
QUIT
NEW ON,PSJORIFN
SET PSJORIFN=ORIFN
SET ON=ORPK
LOCK +^PS(53.1,+ON):1
IF '$TEST
DO LOCKERR^PSIVORA1
QUIT
+3 SET Y=$GET(^PS(53.1,+ON,0))
SET P("RES")=$PIECE(Y,U,24)
SET P("OLDON")=$PIECE(Y,U,25)
+4 NEW DA,DIE,DR,OREND
SET DR="28////P"
SET DIE="^PS(53.1,"
SET DA=+ON
DO ^DIE
+5 IF P("OLDON")]""
KILL DA,DIE,DR
SET DA=P("OLDON")
Begin DoDot:1
+6 IF DA["V"
SET DA(1)=+ORPV
SET DIE="^PS(55,"_DA(1)_",""IV"","
SET DR="114////"_+ON_"P"_";123////"_P("RES")
+7 IF '$TEST
SET DIE="^PS(53.1,"
SET DR="105////"_ON_"P"_";107////"_P("RES")
IF P("RES")="E"
IF $PIECE($GET(^PS(53.1,+P("OLDON"),0)),U,9)="D"
SET DR=DR_";28////DE"
+8 SET DA=+DA
LOCK +@(DIE_DA_")"):1
IF '$TEST
DO LOCKERR^PSIVORA1
QUIT
+9 DO ^DIE
LOCK -@(DIE_DA_")")
End DoDot:1
+10 LOCK -^PS(53.1,+ON)
DO DONE^PSIVORA1
+11 QUIT
+12 ;
10 ; Verify
+1 QUIT
