BLRDPT3 ; IHS/DIR/FJE - PATIENT VARIABLES ;
;;5.2;BLR;;NOV 01, 1997
;
;;MAS VERSION 5.0;
;Inpatient variables [Version 5.0 and above]
6 ;
D NOW^%DTC S (NOW,VAX("DAT"))=%,NOWI=9999999.999999-%
;
I $D(VAIP("E")),$D(^DGPM(+VAIP("E"),0)) S VAX("DT")=+^(0),E=+VAIP("E") G GO ;Specific Entry
;
I $D(VAIP("D")),"^l^L^"[("^"_$E(VAIP("D"))_"^") D LAST G GO:E,Q
;
S VAX=$S($D(VAIP("D")):VAIP("D"),$D(VAINDT):VAINDT,1:0)
I VAX S:VAX?7N!(VAX?7N1".".N) VAX("DT")=VAX I '$D(VAX("DT")) G Q ;Invalid Entry
;
S:'$D(VAX("DT")) VAX("DT")=NOW
I VAX("DT")=VAX("DAT") S E=$S($D(^DPT(DFN,.102)):+^(.102),1:0),E=$S($D(^DGPM(E,0)):E,1:0) G GO:E D LODGER G GO:E D ASIHOF G GO:E,Q ;Current IP
;
;Find Past Movement
S VAX=+$O(^DGPM("APID",DFN,9999999.999999-VAX("DT"))) I 'VAX D LODGER G GO:E,Q
S VAX=+$O(^DGPM("APID",DFN,VAX,0)) I '$D(^DGPM(VAX,0)) D LODGER G GO:E,Q
S VAZ=^DGPM(VAX,0) D OK G GO:E D LODGER G GO:E,Q
;
GO S:'$D(VAX("DT")) VAX("DT")=NOW D ^BLRDPT31 ; setting of VAX("DT") can be removed??
;
Q K NOW,NOWI,VAX,VAZ,VAZ2,E,VACC,VAQ,VANN,VASET,^UTILITY("BLRDPTZ",$J,DFN) D KVAR^BLRDPT30 Q
;
OK S E=0,VAZ2="^"_(+$P(VAZ,"^",18))_"^"
I "^13^41^46^"[VAZ2 D OK1 Q:'VAX G OK
I "^42^"[VAZ2 D 42 I 'Y D OK1 Q:'VAX G OK
I "^47^"[VAZ2 D 47 I 'Y D OK1 Q:'VAX G OK
I $D(VAX("DT")),$P(VAZ,"^",2)=3,VAZ'>VAX("DT") Q
S E=+VAX Q
;
OK1 S VAX=+$O(^DGPM("APID",DFN,9999999.9999999-(VAZ+($P(VAZ,"^",22)/10000000)))),VAX=+$O(^(VAX,0))
I VAX,$D(^DGPM(VAX,0)) S VAZ=^(0)
Q
;
LAST ;
S VAX=+$O(^DGPM("APID",DFN,NOWI)),E=0
I $D(VAIP("L")) D LLDCHK G LASTQ:E
S VAX=+$O(^DGPM("APID",DFN,VAX,0)) I $D(^DGPM(VAX,0)) S VAZ=^(0) D OK
LASTQ S VAX("DT")=NOW
Q
;
LODGER ;
S E=0 G LODGERQ:'$D(VAIP("L"))
I VAX("DT")=VAX("DAT") S VAX=$S($D(^DPT(DFN,.107)):^(.107),1:"") G LODGERQ:VAX']"" S E=$S($D(^DPT("LD",VAX,DFN)):+^(DFN),1:0) G LODGERQ
;
S VAX=$O(^DGPM("ATID4",DFN,9999999.999999-VAX("DT"))) S:VAX E=+$O(^DGPM("ATID4",DFN,VAX,0))
I E S E=$S($D(^DGPM(E,0)):E,1:0) I E,$D(^DGPM(+$P(^(0),"^",17),0)),^(0)'>VAX("DT") S E=0
LODGERQ Q
;
LLDCHK ; -- last lodger mvt checking ; build array of inverse dates and chk
N IDT S IDT(VAX)=0
S IDT=+$O(^DGPM("ATID4",DFN,NOWI)) S:IDT IDT(IDT)=+$O(^(IDT,0))
S IDT=+$O(^DGPM("ATID5",DFN,NOWI)) S:IDT IDT(IDT)=+$O(^(IDT,0))
S IDT=+$O(IDT(0)) I IDT S E=IDT(IDT),E=$S($D(^DGPM(E,0)):E,1:0)
Q
;
CHK ;
G VAR^BLRDPT30
;
ASIHOF ; -- is last mvt asih oth fac
S E=0,VAX=$S('$O(^DGPM("APID",DFN,NOWI)):"",1:$O(^DGPM("APID",DFN,$O(^(NOWI)),0)))
I VAX,$D(^DGPM(VAX,0)),"^43^45^"[("^"_$P(^(0),"^",18)_"^") S E=VAX
Q
;
42 ; -- check to see if this mvt can be used; for 'while asih' d/c category
; If Y returned high then mvt is good
;
I VAZ'<VAX("DAT") S Y=0 G Q42 ; not a real d/c yet
I $P(VAZ,"^",22)=2 S Y=0 G Q42 ; nhcu d/c assoicated w/asih d/c (seq #2)
D SCAN
Q42 Q
;
SCAN ; -- determine is d/c while in other fac(Y=1 returned if so.)
;
N VAID,VACA,M S Y=0,VAID=9999999.999999-VAZ,VACA=+$P(VAZ,"^",14)
F VAID=VAID:0 S VAID=$O(^DGPM("APMV",DFN,VACA,VAID)) Q:'VAID I $D(^DGPM(+$O(^(VAID,0)),0)) S M=$P(^(0),"^",18) I "^13^44^43^45^"[("^"_M_"^") S Y=$S(M=43!(M=45):1,1:0) Q
Q
;
47 ; -- check to see if d/c from nhcu while asih in other fac
; If y returned high then mvt is good.
D SCAN Q
;
; 13 = to asih (vah) (xfr)|44 = resume asih in parent facility (xfr)
; 41 = from asih (d/c)|45 = change asih location(other fac)(xfr)
; 42 = while asih (d/c)|46 = continues asih (other fac) (d/c)
; 43 = to asih(other fac)(xfr)|47 = discharge from nhcu while asih (d/c)
BLRDPT3 ; IHS/DIR/FJE - PATIENT VARIABLES ;
+1 ;;5.2;BLR;;NOV 01, 1997
+2 ;
+3 ;;MAS VERSION 5.0;
+4 ;Inpatient variables [Version 5.0 and above]
6 ;
+1 DO NOW^%DTC
SET (NOW,VAX("DAT"))=%
SET NOWI=9999999.999999-%
+2 ;
+3 ;Specific Entry
IF $DATA(VAIP("E"))
IF $DATA(^DGPM(+VAIP("E"),0))
SET VAX("DT")=+^(0)
SET E=+VAIP("E")
GOTO GO
+4 ;
+5 IF $DATA(VAIP("D"))
IF "^l^L^"[("^"_$EXTRACT(VAIP("D"))_"^")
DO LAST
IF E
GOTO GO
GOTO Q
+6 ;
+7 SET VAX=$SELECT($DATA(VAIP("D")):VAIP("D"),$DATA(VAINDT):VAINDT,1:0)
+8 ;Invalid Entry
IF VAX
IF VAX?7N!(VAX?7N1".".N)
SET VAX("DT")=VAX
IF '$DATA(VAX("DT"))
GOTO Q
+9 ;
+10 IF '$DATA(VAX("DT"))
SET VAX("DT")=NOW
+11 ;Current IP
IF VAX("DT")=VAX("DAT")
SET E=$SELECT($DATA(^DPT(DFN,.102)):+^(.102),1:0)
SET E=$SELECT($DATA(^DGPM(E,0)):E,1:0)
IF E
GOTO GO
DO LODGER
IF E
GOTO GO
DO ASIHOF
IF E
GOTO GO
GOTO Q
+12 ;
+13 ;Find Past Movement
+14 SET VAX=+$ORDER(^DGPM("APID",DFN,9999999.999999-VAX("DT")))
IF 'VAX
DO LODGER
IF E
GOTO GO
GOTO Q
+15 SET VAX=+$ORDER(^DGPM("APID",DFN,VAX,0))
IF '$DATA(^DGPM(VAX,0))
DO LODGER
IF E
GOTO GO
GOTO Q
+16 SET VAZ=^DGPM(VAX,0)
DO OK
IF E
GOTO GO
DO LODGER
IF E
GOTO GO
GOTO Q
+17 ;
GO ; setting of VAX("DT") can be removed??
IF '$DATA(VAX("DT"))
SET VAX("DT")=NOW
DO ^BLRDPT31
+1 ;
Q KILL NOW,NOWI,VAX,VAZ,VAZ2,E,VACC,VAQ,VANN,VASET,^UTILITY("BLRDPTZ",$JOB,DFN)
DO KVAR^BLRDPT30
QUIT
+1 ;
OK SET E=0
SET VAZ2="^"_(+$PIECE(VAZ,"^",18))_"^"
+1 IF "^13^41^46^"[VAZ2
DO OK1
IF 'VAX
QUIT
GOTO OK
+2 IF "^42^"[VAZ2
DO 42
IF 'Y
DO OK1
IF 'VAX
QUIT
GOTO OK
+3 IF "^47^"[VAZ2
DO 47
IF 'Y
DO OK1
IF 'VAX
QUIT
GOTO OK
+4 IF $DATA(VAX("DT"))
IF $PIECE(VAZ,"^",2)=3
IF VAZ'>VAX("DT")
QUIT
+5 SET E=+VAX
QUIT
+6 ;
OK1 SET VAX=+$ORDER(^DGPM("APID",DFN,9999999.9999999-(VAZ+($PIECE(VAZ,"^",22)/10000000))))
SET VAX=+$ORDER(^(VAX,0))
+1 IF VAX
IF $DATA(^DGPM(VAX,0))
SET VAZ=^(0)
+2 QUIT
+3 ;
LAST ;
+1 SET VAX=+$ORDER(^DGPM("APID",DFN,NOWI))
SET E=0
+2 IF $DATA(VAIP("L"))
DO LLDCHK
IF E
GOTO LASTQ
+3 SET VAX=+$ORDER(^DGPM("APID",DFN,VAX,0))
IF $DATA(^DGPM(VAX,0))
SET VAZ=^(0)
DO OK
LASTQ SET VAX("DT")=NOW
+1 QUIT
+2 ;
LODGER ;
+1 SET E=0
IF '$DATA(VAIP("L"))
GOTO LODGERQ
+2 IF VAX("DT")=VAX("DAT")
SET VAX=$SELECT($DATA(^DPT(DFN,.107)):^(.107),1:"")
IF VAX']""
GOTO LODGERQ
SET E=$SELECT($DATA(^DPT("LD",VAX,DFN)):+^(DFN),1:0)
GOTO LODGERQ
+3 ;
+4 SET VAX=$ORDER(^DGPM("ATID4",DFN,9999999.999999-VAX("DT")))
IF VAX
SET E=+$ORDER(^DGPM("ATID4",DFN,VAX,0))
+5 IF E
SET E=$SELECT($DATA(^DGPM(E,0)):E,1:0)
IF E
IF $DATA(^DGPM(+$PIECE(^(0),"^",17),0))
IF ^(0)'>VAX("DT")
SET E=0
LODGERQ QUIT
+1 ;
LLDCHK ; -- last lodger mvt checking ; build array of inverse dates and chk
+1 NEW IDT
SET IDT(VAX)=0
+2 SET IDT=+$ORDER(^DGPM("ATID4",DFN,NOWI))
IF IDT
SET IDT(IDT)=+$ORDER(^(IDT,0))
+3 SET IDT=+$ORDER(^DGPM("ATID5",DFN,NOWI))
IF IDT
SET IDT(IDT)=+$ORDER(^(IDT,0))
+4 SET IDT=+$ORDER(IDT(0))
IF IDT
SET E=IDT(IDT)
SET E=$SELECT($DATA(^DGPM(E,0)):E,1:0)
+5 QUIT
+6 ;
CHK ;
+1 GOTO VAR^BLRDPT30
+2 ;
ASIHOF ; -- is last mvt asih oth fac
+1 SET E=0
SET VAX=$SELECT('$ORDER(^DGPM("APID",DFN,NOWI)):"",1:$ORDER(^DGPM("APID",DFN,$ORDER(^(NOWI)),0)))
+2 IF VAX
IF $DATA(^DGPM(VAX,0))
IF "^43^45^"[("^"_$PIECE(^(0),"^",18)_"^")
SET E=VAX
+3 QUIT
+4 ;
42 ; -- check to see if this mvt can be used; for 'while asih' d/c category
+1 ; If Y returned high then mvt is good
+2 ;
+3 ; not a real d/c yet
IF VAZ'<VAX("DAT")
SET Y=0
GOTO Q42
+4 ; nhcu d/c assoicated w/asih d/c (seq #2)
IF $PIECE(VAZ,"^",22)=2
SET Y=0
GOTO Q42
+5 DO SCAN
Q42 QUIT
+1 ;
SCAN ; -- determine is d/c while in other fac(Y=1 returned if so.)
+1 ;
+2 NEW VAID,VACA,M
SET Y=0
SET VAID=9999999.999999-VAZ
SET VACA=+$PIECE(VAZ,"^",14)
+3 FOR VAID=VAID:0
SET VAID=$ORDER(^DGPM("APMV",DFN,VACA,VAID))
IF 'VAID
QUIT
IF $DATA(^DGPM(+$ORDER(^(VAID,0)),0))
SET M=$PIECE(^(0),"^",18)
IF "^13^44^43^45^"[("^"_M_"^")
SET Y=$SELECT(M=43!(M=45):1,1:0)
QUIT
+4 QUIT
+5 ;
47 ; -- check to see if d/c from nhcu while asih in other fac
+1 ; If y returned high then mvt is good.
+2 DO SCAN
QUIT
+3 ;
+4 ; 13 = to asih (vah) (xfr)|44 = resume asih in parent facility (xfr)
+5 ; 41 = from asih (d/c)|45 = change asih location(other fac)(xfr)
+6 ; 42 = while asih (d/c)|46 = continues asih (other fac) (d/c)
+7 ; 43 = to asih(other fac)(xfr)|47 = discharge from nhcu while asih (d/c)
