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

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

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1DGPMDDCN ;ALB/MRL - DETERMINE INPATIENT X-REF'S; 9 FEB 89
2 ;;5.3;Registration;**54,498**;Aug 13, 1993
3 ;
41 ;
5 I $S($D(DGPMT):1,('$D(DA)#2):1,'$D(DGPMDDF):1,'$D(DGPMDDT):1,1:0) G KX
6 N DFN S DFN=+$P(^DGPM(+DA,0),"^",3) I '$D(^DPT(DFN,0)) G KX
7 I 'DGPMDDT D @("K"_+DGPMDDF) G Q
8 D INPTCK
9 I $S('VAWD:1,1:$P(VAWD,"^",2)="") D G Q
10 . N DGWD
11 . D FIND^DGPMDDLD
12 . I DGWD,($P(DGWD,"^",2)]"") D EN^DGPMDDLD Q
13 . K X
14 D @("S"_+DGPMDDF) G Q
15 ;
16KX K X
17Q D KVAR^VADPT30 K DGPMX,DGPMX1,DGFLD,DGPMDD,DGPMDDF,DGPMDDT,I Q
18 ;
19S6 ; -- ward x-ref
20 S DGFLD=.1 I $D(^DPT(DFN,.1)) S DGPMX=^(.1) K:$D(^(.105)) ^DGPM("CN",DGPMX,+^(.105)) D KILL
21 S DGPMX=$P(VAWD,"^",2),^DGPM("CN",DGPMX,+$P(^DGPM(+VAMV,0),"^",14))=""
22 D SET
23 S DGFLD=.102 I $D(^DPT(DFN,.102)) S DGPMX=^(.102) D KILL
24 S DGPMX=+VAMV D SET:DGPMX
25 S DGFLD=.105 I $D(^DPT(DFN,.105)) S DGPMX=^(.105) D KILL
26 S DGPMX=+$P(^DGPM(+VAMV,0),"^",14) D SET:DGPMX
27 Q
28 ;
29K6 ;
30 I X S W=$S($D(^DIC(42,+X,0)):$P(^(0),"^",1),1:"") I W]"" K ^DGPM("CN",W,+$P(^DGPM(DA,0),"^",14)) I $D(^DPT(DFN,.1)),^(.1)=W S DGPMX=W,DGFLD=.1 D KILL
31 K W
32 I $D(^DPT(DFN,.102)),^(.102)=DA S DGPMX=DA,DGFLD=.102 D KILL
33 I $D(^DPT(DFN,.105)),^(.105)=$P(^DGPM(DA,0),"^",14) S DGPMX=$P(^DGPM(DA,0),"^",14),DGFLD=.105 D KILL
34 Q
35 ;
36S7 ; -- room-bed x-ref
37 I $D(^DPT(DFN,.108)) S DGPMX=^(.108),DGFLD=.108 D KILL F DGPMX1=0:0 S DGPMX1=+$O(^DGPM("ARM",DGPMX,DGPMX1)) D CHK I $T K ^DGPM("ARM",DGPMX,DGPMX1) Q
38 S DGFLD=.101 I $D(^DPT(DFN,.101)) S DGPMX=^(.101) D KILL
39 S DGPMX=$P(VARM,"^",2) D SET
40 I +VARM S DGFLD=.108,DGPMX=+VARM,^DGPM("ARM",DGPMX,VAWDA)=0 D SET
41 Q
42 ;
43K7 ;
44 I $D(^DPT(DFN,.108)),X=+^(.108) S DGPMX=X I $D(^DGPM("ARM",DGPMX,DA)) K ^(DA) S DGFLD=.108 D KILL
45 I X S R=$S($D(^DG(405.4,+X,0)):$P(^(0),"^",1),1:"") I R]"",$D(^DPT(DFN,.101)),^(.101)=R S DGPMX=R,DGFLD=.101 D KILL
46 Q
47 ;
48CHK ;
49 I '$D(^DGPM(DGPMX1,0)) Q
50 I $P(^DGPM(DGPMX1,0),"^",3)=DFN Q
51 Q
52 ;
53S8 ; -- doc x-ref
54 S DGFLD=.104 I $D(^DPT(DFN,.104)) S DGPMX=+^(.104) D KILL
55 S DGPMX=+VAPP D SET:DGPMX
56 Q
57 ;
58K8 ;
59 I X,$D(^DPT(DFN,.104)),^(.104)=X S DGPMX=X,DGFLD=.104 D KILL
60 Q
61 ;
62S9 ; -- tr. spec x-ref
63 S DGFLD=.103 I $D(^DPT(DFN,.103)) S DGPMX=+^(.103) D KILL
64 S DGPMX=+VATS D SET:DGPMX
65 Q
66 ;
67K9 ;
68 I X,$D(^DPT(DFN,.103)),^(.103)=X S DGPMX=X,DGFLD=.103 D KILL
69 Q
70 ;
71S19 ; -- attend x-ref
72 S DGFLD=.1041 I $D(^DPT(DFN,.1041)) S DGPMX=+^(.1041) D KILL
73 S DGPMX=+VAAP D SET:DGPMX
74 Q
75 ;
76K19 ;
77 I X,$D(^DPT(DFN,.1041)),^(.1041)=X S DGPMX=X,DGFLD=.1041 D KILL
78 Q
79 ;
80S41 ; -- fac dir x-ref (AFD)
81 S DGFLD=.109 S DGPMX=$P($G(^DPT(DFN,.109)),"^",1) D KILL:(DGPMX'="")
82 S DGPMX=$P(VAFD,"^",1) D SET:(DGPMX'="")
83 Q
84 ;
85K41 ;
86 I X'="",$P($G(^DPT(DFN,.109)),"^",1)=X S DGPMX=X,DGFLD=.109 D KILL
87 Q
88 ;
89SET ; -- generic set x-ref logic
90 Q:DGPMX']""
91 N X,DA S DA=DFN,(^DPT(DA,DGFLD),X)=DGPMX
92 F DGIX=0:0 S DGIX=$O(^DD(2,DGFLD,1,DGIX)) Q:'DGIX X ^(DGIX,1) S X=DGPMX
93 K DGIX Q
94 ;
95KILL ; -- generic kill x-ref logic
96 Q:DGPMX']""
97 N X,DA S DA=DFN,X=DGPMX
98 F DGIX=0:0 S DGIX=$O(^DD(2,DGFLD,1,DGIX)) Q:'DGIX X ^(DGIX,2) S X=DGPMX
99 K DGIX,^DPT(DA,DGFLD) Q
100 ;
101CN ; -- set "CN" x-ref for file #2 equal to corresp adm mv
102 N DFN,VAMV0,VAMV,VAMT,VAID,DGX
103 S DGX=X D NOW^%DTC S VAID=9999999.999999-%,DFN=DA D MV^VADPT30
104 I $P(VAMV0,U,2),$P(VAMV0,U,2)'=3 S ^DPT("CN",DGX,DA)=$P(VAMV0,"^",14)
105 Q
106 ;
107RESET ; -- reset ^DPT nodes and x-refs
108 ; input: DFN
109 ;
110 ; -- kill data and x-refs
111 I $D(^DPT(DFN,.105)),$D(^(.1)),^(.1)]"" K ^DGPM("CN",^(.1),+^(.105))
112 I $D(^DPT(DFN,.108)) S DGPMX=^(.108),DGFLD=.108 D KILL F DGPMX1=0:0 S DGPMX1=+$O(^DGPM("ARM",DGPMX,DGPMX1)) D CHK I $T K ^DGPM("ARM",DGPMX,DGPMX1) Q
113 F DGFLD=.1,.101,.102,.103,.104,.1041,.105,.109 I $D(^DPT(DFN,DGFLD)) S DGPMX=^(DGFLD) D KILL
114 ; -- reset data and x-refs
115 D INPTCK
116 I $S('VAWD:1,1:$P(VAWD,"^",2)="") D G RESETQ
117 . N DGWD
118 . D FIND^DGPMDDLD
119 . I DGWD,($P(DGWD,"^",2)]"") D RESET^DGPMDDLD
120 D SETALL
121RESETQ D KVAR^VADPT30 K DGPMX,DGPMX1,DGFLD,I Q
122 ;
123SETALL D S6,S7,S8,S9,S19,S41 Q
124 ;
125XREF I $D(^DGPM(DA,0)),$P(^(0),"^",2)=4!($P(^(0),"^",2)=5) G XREF^DGPMDDLD
126 Q:$D(DGPMT)
127 I $D(^DGPM(DA,0)) N DFN S DFN=+$P(^(0),U,3) D RESET
128 Q
129 ;
130INPTCK ; check to see if patient is current inpatient
131 D NOW^%DTC S VAPRT=0,VATD=9999999.999999-%,(VACN,VAPRC)=1
132 S VA200="" D VAR^VADPT30 K VA200
133 Q
Note: See TracBrowser for help on using the repository browser.