source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT3.m@ 1611

VADPT3 ;ALB/MRL - PATIENT VARIABLES [IN5]; 12 DEC 1988 ; 7/22/03 5:00pm
 ;;5.3;Registration;**532,749**;Aug 13, 1993;Build 10
 ;Inpatient variables [Version 5.0 and above]
6 ;
 S (NOW,VAX("DAT"))=$$NOW^XLFDT,NOWI=9999999.999999-NOW
 ;
 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 ^VADPT31 ; setting of VAX("DT") can be removed??
 ;
Q K NOW,NOWI,VAX,VAZ,VAZ2,E,VACC,VAQ,VANN,VASET,^UTILITY("VADPTZ",$J,DFN) D KVAR^VADPT30 Q
 ;
OK N VAADT,VADDT,VAQUIT
 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
 ;DG*5.3*532
 ;Check for out-of-order disch. recs caused by same day adm./disch.
 ;where disch. date < adm. date because disch. date had no time
 I +VAZ<2890000,$D(VAX("DT")),$P(VAZ,"^",2)'=3 S VAQUIT=0 D  Q:VAQUIT
 .S VAADT=$P(VAZ,"^",14) Q:'VAADT
 .S VADDT=$P($G(^DGPM(VAADT,0)),"^",17) Q:'VADDT
 .S VADDT=$P($G(^DGPM(VADDT,0)),"^",14) I $P(VADDT,".",2)="",VADDT=$P(VAADT,"."),VAZ'>VAX("DT") S VAQUIT=1
 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 ; returns last movement for patient
 ; called by bed control and pt inquiry
 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^VADPT30
 ;
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)