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

Last change on this file since 1259 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version

File size: 4.0 KB
Line 
1VADPT3 ;ALB/MRL - PATIENT VARIABLES [IN5]; 12 DEC 1988 ; 7/22/03 5:00pm
2 ;;5.3;Registration;**532**;Aug 13, 1993
3 ;Inpatient variables [Version 5.0 and above]
46 ;
5 D NOW^%DTC S (NOW,VAX("DAT"))=%,NOWI=9999999.999999-%
6 ;
7 I $D(VAIP("E")),$D(^DGPM(+VAIP("E"),0)) S VAX("DT")=+^(0),E=+VAIP("E") G GO ;Specific Entry
8 ;
9 I $D(VAIP("D")),"^l^L^"[("^"_$E(VAIP("D"))_"^") D LAST G GO:E,Q
10 ;
11 S VAX=$S($D(VAIP("D")):VAIP("D"),$D(VAINDT):VAINDT,1:0)
12 I VAX S:VAX?7N!(VAX?7N1".".N) VAX("DT")=VAX I '$D(VAX("DT")) G Q ;Invalid Entry
13 ;
14 S:'$D(VAX("DT")) VAX("DT")=NOW
15 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
16 ;
17 ;Find Past Movement
18 S VAX=+$O(^DGPM("APID",DFN,9999999.999999-VAX("DT"))) I 'VAX D LODGER G GO:E,Q
19 S VAX=+$O(^DGPM("APID",DFN,VAX,0)) I '$D(^DGPM(VAX,0)) D LODGER G GO:E,Q
20 S VAZ=^DGPM(VAX,0) D OK G GO:E D LODGER G GO:E,Q
21 ;
22GO S:'$D(VAX("DT")) VAX("DT")=NOW D ^VADPT31 ; setting of VAX("DT") can be removed??
23 ;
24Q K NOW,NOWI,VAX,VAZ,VAZ2,E,VACC,VAQ,VANN,VASET,^UTILITY("VADPTZ",$J,DFN) D KVAR^VADPT30 Q
25 ;
26OK N VAADT,VADDT,VAQUIT
27 S E=0,VAZ2="^"_(+$P(VAZ,"^",18))_"^"
28 I "^13^41^46^"[VAZ2 D OK1 Q:'VAX G OK
29 I "^42^"[VAZ2 D 42 I 'Y D OK1 Q:'VAX G OK
30 I "^47^"[VAZ2 D 47 I 'Y D OK1 Q:'VAX G OK
31 I $D(VAX("DT")),$P(VAZ,"^",2)=3,VAZ'>VAX("DT") Q
32 ;DG*5.3*532
33 ;Check for out-of-order disch. recs caused by same day adm./disch.
34 ;where disch. date < adm. date because disch. date had no time
35 I +VAZ<2890000,$D(VAX("DT")),$P(VAZ,"^",2)'=3 S VAQUIT=0 D Q:VAQUIT
36 .S VAADT=$P(VAZ,"^",14) Q:'VAADT
37 .S VADDT=$P($G(^DGPM(VAADT,0)),"^",17) Q:'VADDT
38 .S VADDT=$P($G(^DGPM(VADDT,0)),"^",14) I $P(VADDT,".",2)="",VADDT=$P(VAADT,"."),VAZ'>VAX("DT") S VAQUIT=1
39 S E=+VAX Q
40 ;
41OK1 S VAX=+$O(^DGPM("APID",DFN,9999999.9999999-(VAZ+($P(VAZ,"^",22)/10000000)))),VAX=+$O(^(VAX,0))
42 I VAX,$D(^DGPM(VAX,0)) S VAZ=^(0)
43 Q
44 ;
45LAST ; returns last movement for patient
46 ; called by bed control and pt inquiry
47 S VAX=+$O(^DGPM("APID",DFN,NOWI)),E=0
48 I $D(VAIP("L")) D LLDCHK G LASTQ:E
49 S VAX=+$O(^DGPM("APID",DFN,VAX,0)) I $D(^DGPM(VAX,0)) S VAZ=^(0) D OK
50LASTQ S VAX("DT")=NOW
51 Q
52 ;
53LODGER ;
54 S E=0 G LODGERQ:'$D(VAIP("L"))
55 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
56 ;
57 S VAX=$O(^DGPM("ATID4",DFN,9999999.999999-VAX("DT"))) S:VAX E=+$O(^DGPM("ATID4",DFN,VAX,0))
58 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
59LODGERQ Q
60 ;
61LLDCHK ; -- last lodger mvt checking ; build array of inverse dates and chk
62 N IDT S IDT(VAX)=0
63 S IDT=+$O(^DGPM("ATID4",DFN,NOWI)) S:IDT IDT(IDT)=+$O(^(IDT,0))
64 S IDT=+$O(^DGPM("ATID5",DFN,NOWI)) S:IDT IDT(IDT)=+$O(^(IDT,0))
65 S IDT=+$O(IDT(0)) I IDT S E=IDT(IDT),E=$S($D(^DGPM(E,0)):E,1:0)
66 Q
67 ;
68CHK ;
69 G VAR^VADPT30
70 ;
71ASIHOF ; -- is last mvt asih oth fac
72 S E=0,VAX=$S('$O(^DGPM("APID",DFN,NOWI)):"",1:$O(^DGPM("APID",DFN,$O(^(NOWI)),0)))
73 I VAX,$D(^DGPM(VAX,0)),"^43^45^"[("^"_$P(^(0),"^",18)_"^") S E=VAX
74 Q
75 ;
7642 ; -- check to see if this mvt can be used; for 'while asih' d/c category
77 ; If Y returned high then mvt is good
78 ;
79 I VAZ'<VAX("DAT") S Y=0 G Q42 ; not a real d/c yet
80 I $P(VAZ,"^",22)=2 S Y=0 G Q42 ; nhcu d/c assoicated w/asih d/c (seq #2)
81 D SCAN
82Q42 Q
83 ;
84SCAN ; -- determine is d/c while in other fac(Y=1 returned if so.)
85 ;
86 N VAID,VACA,M S Y=0,VAID=9999999.999999-VAZ,VACA=+$P(VAZ,"^",14)
87 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
88 Q
89 ;
9047 ; -- check to see if d/c from nhcu while asih in other fac
91 ; If y returned high then mvt is good.
92 D SCAN Q
93 ;
94 ; 13 = to asih (vah) (xfr)|44 = resume asih in parent facility (xfr)
95 ; 41 = from asih (d/c)|45 = change asih location(other fac)(xfr)
96 ; 42 = while asih (d/c)|46 = continues asih (other fac) (d/c)
97 ; 43 = to asih(other fac)(xfr)|47 = discharge from nhcu while asih (d/c)
Note: See TracBrowser for help on using the repository browser.