PSIVACT ;BIR/PR,MLM-UPDATE ORDER STATUS AFTER PATIENT SELECTION ;16 Jul 98 / 12:51 PM
;;5.0; INPATIENT MEDICATIONS ;**15,38,58,110**;16 DEC 97
;
; Reference to ^PS(55 is supported by DBIA 2191
;
ENNA ; Inpatient entry point.
D:$D(XRTL) T0^%ZOSV
D NOW^%DTC S PSFDT=%,PS=0 D L D:'$G(PSIVRD) PEND
I $D(XRT0) S XRTN="PSIVACT" D T1^%ZOSV
Q
;
ENNB ; Ask profile type, gather orders.
D NOW^%DTC S PSFDT=%,PS=0 K ^TMP("PSIV",$J),^TMP("PSJPRO",$J)
S PSIVNV=$S(+PSJSYSU=1:"ANIV",+PSJSYSU=3:"APIV",1:"")
;D @P("PT") D:PSIVNV]"" NVACT D:'$G(PSIVRD) PEND
D @P("PT") D:'$G(PSIVRD) PEND
I P("PT")="L",$D(XRT0) S XRTN="PSIVACT" D T1^%ZOSV
Q
;
L ; Long profile
S:'$D(PSJSYSU) PSJSYSU=""
F ON=0:0 K Y S ON=$O(^PS(55,DFN,"IV",+ON)) Q:'ON D SETP
Q
;
S ; Short profile.
F PSIVDT=PSFDT:0 S PSIVDT=$O(^PS(55,DFN,"IV","AIS",PSIVDT)) Q:'PSIVDT F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",PSIVDT,+ON)) Q:'ON S ON=ON_"V",P(17)=$P($G(^PS(55,DFN,"IV",+ON,0)),U,17) D ACTO
I +PSJSYSU=3 S PSIVNV="APIV" D NVACT K PSIVNV
Q
;
NVACT ; Non-verified but have active status
NEW ON
F ON=0:0 S ON=$O(^PS(55,PSIVNV,DFN,ON)) Q:'ON D
. I $P($G(^PS(55,DFN,"IV",ON,0)),U,17)="E",($P($G(^(.2)),U,4)="D") S ^TMP("PSIV",$J,"A",9999999999-ON)=""
Q
;
PEND ; Get pending and non-verified orders from 53.1
N PSJCOM,PSJCOM1 S (PSJCOM,PSJCOM1)=0
F ON=0:0 S ON=$O(^PS(53.1,"AS","P",DFN,ON)) Q:'ON D S PSJCOM1=PSJCOM
. NEW X S X=$P($G(^PS(53.1,ON,.2)),U,4),X=$S(X="S":1,X="A":2,X="R":3,X="P":4,1:5)
. S PSJCOM=$P($G(^PS(53.1,ON,.2)),U,8) I PSJCOM Q:'$$COMCHK^PSJO1(PSJCOM,2) Q:PSJCOM=PSJCOM1
. I $G(^PS(53.1,ON,0)),$P(^PS(53.1,ON,0),U,4)'="U" S ^TMP("PSIV",$J,$S('PSJCOM:"P",1:"PD"),X_9999999999-ON)=""
F ON=0:0 S ON=$O(^PS(53.1,"AS","N",DFN,ON)) Q:'ON D S PSJCOM1=PSJCOM
. NEW X S X=$P($G(^PS(53.1,ON,.2)),U,4),X=$S(X="S":1,X="A":2,X="R":3,X="P":4,1:5)
. S PSJCOM=$P($G(^PS(53.1,ON,.2)),U,8) I PSJCOM Q:'$$COMCHK^PSJO1(PSJCOM,2) Q:PSJCOM=PSJCOM1
. I $G(^PS(53.1,ON,0)),$P(^PS(53.1,ON,0),U,4)'="U" S ^TMP("PSIV",$J,$S('PSJCOM:"N",1:"ND"),X_9999999999-ON)=""
.; S:$P(^PS(53.1,ON,0),U,4)'="U" ^TMP("PSIV",$J,"P",X_9999999999-ON)=""
;
QUIT ; Kill and exit.
K PSIVCWD,PSIVFLAG,PSIVWD,PSDFN,PSON1,PSFDT,YHOLD,JJ,XHOLD
Q
;
SETP ; Get partial P array,
S ON=ON_"V",Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,17,21 S P(X)=$P(Y,U,X)
S P(2)=+P(2),P(3)=+P(3) S Y(P(2))="",Y(P(3))=""
I P(2),P(3),P(17)'="P" D CHK
Q
;
CHK ; Check if order is active or expired and save accordingly.
S PS=PS+1 I P(17)="H" S ^TMP("PSIV",$J,"A",9999999999-ON)="" Q
I $O(Y(PSFDT))=P(3) D ACTO Q
I $O(Y(PSFDT))="" D NACTO Q
S:"ARO"[P(17) ^TMP("PSIV",$J,"A",9999999999-ON)="" S:"ED"[P(17) ^TMP("PSIV",$J,"X",9999999999-ON)="" S:"E"[P(17) PSIVREA="A",$P(^PS(55,DFN,"IV",+ON,0),U,17)="A",PS("A",9999999999-ON)=""
Q
;
ACTO ; Active orders
I "AE"[P(17) S ^TMP("PSIV",$J,"A",9999999999-ON)="" S:P(17)="E" $P(^PS(55,DFN,"IV",+ON,0),U,17)="A" Q
I "HOR"[P(17) S ^TMP("PSIV",$J,"A",9999999999-ON)="" Q
I "D"[P(17) S ^TMP("PSIV",$J,"X",9999999999-ON)=""
Q
;
NACTO ; Inactive orders
;I "AER"[P(17) S ^TMP("PSIV",$J,"X",9999999999-ON)="" I "AR"[P(17) S $P(^PS(55,DFN,"IV",+ON,0),U,17)="E" D EXPIR^PSIVOE Q
I "AER"[P(17) D
. Q:$P(^PS(55,DFN,"IV",+ON,0),U,3)=""
. I +PSJSYSU=3,($P($G(^PS(55,DFN,"IV",+ON,.2)),U,4)="D"),'+$P($G(^(4)),U,4) S ^TMP("PSIV",$J,"A",9999999999-ON)="" Q
. S ^TMP("PSIV",$J,"X",9999999999-ON)=""
I "AR"[P(17) S $P(^PS(55,DFN,"IV",+ON,0),U,17)="E" D EXPIR^PSIVOE
I "OD"[P(17) S ^TMP("PSIV",$J,"X",9999999999-ON)=""
Q
;
DCOR ; Auto-cancel IV orders
;NEED TO NEW VARIABLES LATER.
NEW DA,DIR,DG,ON,ON55,P,PSIVAC,PSIVACT,PSIVLN,PSIVREA,PSIVRES,PSGALO,PSGP,PSJDCDT,PSJIVDCF,PSJIVON,PSJIVORF,PSJORF,VA,VADM,VAERR
S PSGP=DFN,PSIVRES="Auto DC due to Surgery Package"
D NOW^%DTC S PSJDCDT=+%
D ENIV^PSJADT0
Q
PSIVACT ;BIR/PR,MLM-UPDATE ORDER STATUS AFTER PATIENT SELECTION ;16 Jul 98 / 12:51 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**15,38,58,110**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191
+4 ;
ENNA ; Inpatient entry point.
+1 IF $DATA(XRTL)
DO T0^%ZOSV
+2 DO NOW^%DTC
SET PSFDT=%
SET PS=0
DO L
IF '$GET(PSIVRD)
DO PEND
+3 IF $DATA(XRT0)
SET XRTN="PSIVACT"
DO T1^%ZOSV
+4 QUIT
+5 ;
ENNB ; Ask profile type, gather orders.
+1 DO NOW^%DTC
SET PSFDT=%
SET PS=0
KILL ^TMP("PSIV",$JOB),^TMP("PSJPRO",$JOB)
+2 SET PSIVNV=$SELECT(+PSJSYSU=1:"ANIV",+PSJSYSU=3:"APIV",1:"")
+3 ;D @P("PT") D:PSIVNV]"" NVACT D:'$G(PSIVRD) PEND
+4 DO @P("PT")
IF '$GET(PSIVRD)
DO PEND
+5 IF P("PT")="L"
IF $DATA(XRT0)
SET XRTN="PSIVACT"
DO T1^%ZOSV
+6 QUIT
+7 ;
L ; Long profile
+1 IF '$DATA(PSJSYSU)
SET PSJSYSU=""
+2 FOR ON=0:0
KILL Y
SET ON=$ORDER(^PS(55,DFN,"IV",+ON))
IF 'ON
QUIT
DO SETP
+3 QUIT
+4 ;
S ; Short profile.
+1 FOR PSIVDT=PSFDT:0
SET PSIVDT=$ORDER(^PS(55,DFN,"IV","AIS",PSIVDT))
IF 'PSIVDT
QUIT
FOR ON=0:0
SET ON=$ORDER(^PS(55,DFN,"IV","AIS",PSIVDT,+ON))
IF 'ON
QUIT
SET ON=ON_"V"
SET P(17)=$PIECE($GET(^PS(55,DFN,"IV",+ON,0)),U,17)
DO ACTO
+2 IF +PSJSYSU=3
SET PSIVNV="APIV"
DO NVACT
KILL PSIVNV
+3 QUIT
+4 ;
NVACT ; Non-verified but have active status
+1 NEW ON
+2 FOR ON=0:0
SET ON=$ORDER(^PS(55,PSIVNV,DFN,ON))
IF 'ON
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^PS(55,DFN,"IV",ON,0)),U,17)="E"
IF ($PIECE($GET(^(.2)),U,4)="D")
SET ^TMP("PSIV",$JOB,"A",9999999999-ON)=""
End DoDot:1
+4 QUIT
+5 ;
PEND ; Get pending and non-verified orders from 53.1
+1 NEW PSJCOM,PSJCOM1
SET (PSJCOM,PSJCOM1)=0
+2 FOR ON=0:0
SET ON=$ORDER(^PS(53.1,"AS","P",DFN,ON))
IF 'ON
QUIT
Begin DoDot:1
+3 NEW X
SET X=$PIECE($GET(^PS(53.1,ON,.2)),U,4)
SET X=$SELECT(X="S":1,X="A":2,X="R":3,X="P":4,1:5)
+4 SET PSJCOM=$PIECE($GET(^PS(53.1,ON,.2)),U,8)
IF PSJCOM
IF '$$COMCHK^PSJO1(PSJCOM,2)
QUIT
IF PSJCOM=PSJCOM1
QUIT
+5 IF $GET(^PS(53.1,ON,0))
IF $PIECE(^PS(53.1,ON,0),U,4)'="U"
SET ^TMP("PSIV",$JOB,$SELECT('PSJCOM:"P",1:"PD"),X_9999999999-ON)=""
End DoDot:1
SET PSJCOM1=PSJCOM
+6 FOR ON=0:0
SET ON=$ORDER(^PS(53.1,"AS","N",DFN,ON))
IF 'ON
QUIT
Begin DoDot:1
+7 NEW X
SET X=$PIECE($GET(^PS(53.1,ON,.2)),U,4)
SET X=$SELECT(X="S":1,X="A":2,X="R":3,X="P":4,1:5)
+8 SET PSJCOM=$PIECE($GET(^PS(53.1,ON,.2)),U,8)
IF PSJCOM
IF '$$COMCHK^PSJO1(PSJCOM,2)
QUIT
IF PSJCOM=PSJCOM1
QUIT
+9 IF $GET(^PS(53.1,ON,0))
IF $PIECE(^PS(53.1,ON,0),U,4)'="U"
SET ^TMP("PSIV",$JOB,$SELECT('PSJCOM:"N",1:"ND"),X_9999999999-ON)=""
+10 ; S:$P(^PS(53.1,ON,0),U,4)'="U" ^TMP("PSIV",$J,"P",X_9999999999-ON)=""
End DoDot:1
SET PSJCOM1=PSJCOM
+11 ;
QUIT ; Kill and exit.
+1 KILL PSIVCWD,PSIVFLAG,PSIVWD,PSDFN,PSON1,PSFDT,YHOLD,JJ,XHOLD
+2 QUIT
+3 ;
SETP ; Get partial P array,
+1 SET ON=ON_"V"
SET Y=$GET(^PS(55,DFN,"IV",+ON,0))
FOR X=2,3,17,21
SET P(X)=$PIECE(Y,U,X)
+2 SET P(2)=+P(2)
SET P(3)=+P(3)
SET Y(P(2))=""
SET Y(P(3))=""
+3 IF P(2)
IF P(3)
IF P(17)'="P"
DO CHK
+4 QUIT
+5 ;
CHK ; Check if order is active or expired and save accordingly.
+1 SET PS=PS+1
IF P(17)="H"
SET ^TMP("PSIV",$JOB,"A",9999999999-ON)=""
QUIT
+2 IF $ORDER(Y(PSFDT))=P(3)
DO ACTO
QUIT
+3 IF $ORDER(Y(PSFDT))=""
DO NACTO
QUIT
+4 IF "ARO"[P(17)
SET ^TMP("PSIV",$JOB,"A",9999999999-ON)=""
IF "ED"[P(17)
SET ^TMP("PSIV",$JOB,"X",9999999999-ON)=""
IF "E"[P(17)
SET PSIVREA="A"
SET $PIECE(^PS(55,DFN,"IV",+ON,0),U,17)="A"
SET PS("A",9999999999-ON)=""
+5 QUIT
+6 ;
ACTO ; Active orders
+1 IF "AE"[P(17)
SET ^TMP("PSIV",$JOB,"A",9999999999-ON)=""
IF P(17)="E"
SET $PIECE(^PS(55,DFN,"IV",+ON,0),U,17)="A"
QUIT
+2 IF "HOR"[P(17)
SET ^TMP("PSIV",$JOB,"A",9999999999-ON)=""
QUIT
+3 IF "D"[P(17)
SET ^TMP("PSIV",$JOB,"X",9999999999-ON)=""
+4 QUIT
+5 ;
NACTO ; Inactive orders
+1 ;I "AER"[P(17) S ^TMP("PSIV",$J,"X",9999999999-ON)="" I "AR"[P(17) S $P(^PS(55,DFN,"IV",+ON,0),U,17)="E" D EXPIR^PSIVOE Q
+2 IF "AER"[P(17)
Begin DoDot:1
+3 IF $PIECE(^PS(55,DFN,"IV",+ON,0),U,3)=""
QUIT
+4 IF +PSJSYSU=3
IF ($PIECE($GET(^PS(55,DFN,"IV",+ON,.2)),U,4)="D")
IF '+$PIECE($GET(^(4)),U,4)
SET ^TMP("PSIV",$JOB,"A",9999999999-ON)=""
QUIT
+5 SET ^TMP("PSIV",$JOB,"X",9999999999-ON)=""
End DoDot:1
+6 IF "AR"[P(17)
SET $PIECE(^PS(55,DFN,"IV",+ON,0),U,17)="E"
DO EXPIR^PSIVOE
+7 IF "OD"[P(17)
SET ^TMP("PSIV",$JOB,"X",9999999999-ON)=""
+8 QUIT
+9 ;
DCOR ; Auto-cancel IV orders
+1 ;NEED TO NEW VARIABLES LATER.
+2 NEW DA,DIR,DG,ON,ON55,P,PSIVAC,PSIVACT,PSIVLN,PSIVREA,PSIVRES,PSGALO,PSGP,PSJDCDT,PSJIVDCF,PSJIVON,PSJIVORF,PSJORF,VA,VADM,VAERR
+3 SET PSGP=DFN
SET PSIVRES="Auto DC due to Surgery Package"
+4 DO NOW^%DTC
SET PSJDCDT=+%
+5 DO ENIV^PSJADT0
+6 QUIT
