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

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

initial load of WorldVistAEHR
File size: 7.0 KB
RevLine 
[613]1DGRUUTL1 ;ALB/GRR - RAI/MDS UTILITY ROUTINE
2 ;;5.3;Registration;**190,312,328,373,434,430,464**;Aug 13, 1993
3EN ;Process each division for routing
4 N DGRDIV,DGDIV ;New all variables used
5 K HLL ;Kill HLL which is used for an array
6 S DGDIV=$$ENGET^DGRUGMFU()
7 D ENMFU^DGRUDYN("MFU",DGDIV) ;Do API which gets subscriber(s) for the division
8 Q
9 ;
10LOCTRAN(DGPV1) ;TRANSLATE WARD AND ROOM-BED
11 N DGCW,DGPW,DGPR,DGPB,DGW,DGR,DGB,DGPL,DGLOC,DGI,DGCRB,DGPRB ;modified p-373
12 S DGLOC=$P(DGPV1,HL("FS"),4),DGPLOC=$P(DGPV1,HL("FS"),7)
13 S DGW=$P(DGLOC,$E(HL("ECH"))),DGR=$P(DGLOC,$E(HL("ECH")),2),DGB=$P(DGLOC,$E(HL("ECH")),3)
14 S DGPWN=$P(DGPLOC,$E(HL("ECH"))),DGPR=$P(DGPLOC,$E(HL("ECH")),2),DGPB=$P(DGPLOC,$E(HL("ECH")),3)
15 N DGETYPE S DGETYPE=$P($G(@DGARRAY@(1)),HL("FS"),2) G:DGETYPE="" LOCEX
16 ;
17 I DGETYPE="A01" D
18 .S DGCW=$P($G(DGPMA),"^",6),(DGPW,DGPWN,DGPR,DGPB)=""
19 .S DGCRB=$P($G(DGPMA),"^",7),DGPRB=""
20 ;
21 I DGETYPE="A02" D
22 .S DGCW=$P($G(DGPMA),"^",6),DGPW=$P($G(DGPMVI(5)),"^")
23 .S DGCRB=$P($G(DGPMA),"^",7),DGPRB=$P($G(DGPMVI(6)),"^")
24 .I $G(DGBS)=1 D ;p-464 BED SWITCH
25 ..S DGPWN=DGW,DGPW=DGCW,DGPRBN=$P($G(DGPMVI(6)),"^",2) ;p-464
26 ..S DGPR=$P(DGPRBN,"-",1),DGPB=$P(DGPRBN,"-",2) ;p-464
27 .I DGPW=""!(DGPRB="") S DGPW=DGCW,DGPRB=DGCRB
28 ;
29 I DGETYPE="A03" D
30 .I $G(DGXFR0)]"" D
31 ..S (DGCW,DGPW)=$P(DGXFR0,"^",6)
32 ..S (DGCRB,DGPRB)=$P(DGXFR0,"^",7)
33 .I $G(DGPMAN)]"" D
34 ..S (DGCW,DGPW)=$P(DGPMAN,"^",6)
35 ..S (DGCRB,DGPRB)=$P(DGPMAN,"^",7)
36 .I $G(DGPMVI(5))]"" D
37 ..S (DGCW,DGPW)=$P($G(DGPMVI(5)),"^")
38 ..S (DGCRB,DGPRB)=$P($G(DGPMVI(6)),"^")
39 .I $G(DGMOVE)=47 D ;p-430
40 ..S (DGCW,DGPW)=$P($G(DGRU(17,4)),"^") ;p-430
41 ..S (DGCRB,DGPRB)=$P($G(DGRU(17,4)),"^",2) ;p-430
42 ;
43 I DGETYPE="A08" D
44 .N VAIP D IN5^VADPT
45 .S DGCW=+$G(VAIP(5)),DGPW=+$G(VAIP(15,4))
46 .S DGCRB=+$G(VAIP(6)),DGPRB=""
47 .N DGMIEN S DGMIEN=+$G(VAIP(15)) I DGMIEN>0 S DGPRB=$$GET1^DIQ(405,DGMIEN,.07,"I") K DGMIEN
48 ;
49 I DGETYPE="A11" D
50 .S (DGCW,DGPW)=$P($G(DGPMVI(5)),"^")
51 .S (DGCRB,DGPRB)=$P($G(DGPMVI(6)),"^")
52 ;
53 I DGETYPE="A12" D
54 .S (DGCW,DGPW)=$P($G(DGPM0),"^",6),DGPWN=DGW
55 .S (DGCRB,DGPRB)=$P($G(DGPM0),"^",7),DGPR=DGR,DGPB=DGB
56 ;
57 I DGETYPE="A13" D
58 .S (DGCW,DGPW)=$P($G(DGPM0),"^",6),DGPWN=DGW
59 .S (DGCRB,DGPRB)=$P($G(DGPM0),"^",7),DGPR=DGR,DGPB=DGB
60 ;
61 I DGETYPE="A21" D ;modified p-373
62 .I $G(DGPMVI(5))]"" D Q
63 ..S (DGCW,DGPW)=$P($G(DGPMVI(5)),"^")
64 ..S (DGCRB,DGPRB)=$P($G(DGPMVI(6)),"^")
65 .I $G(DGPMA)]"" D ;p-434
66 ..S (DGCW,DGPW)=$P(DGPMA,"^",6) ;p-434
67 ..S (DGCRB,DGPRB)=$P(DGPMA,"^",7) ;p-434
68 .I $G(DGPMAN)]"" D
69 ..S DGCW=$P($G(DGPMA),"^",6),DGPW=$P($G(DGPMAN),"^",6)
70 ..S DGCRB=$P($G(DGPMA),"^",7),DGPRB=$P($G(DGPMAN),"^",7)
71 I DGETYPE="A22" D ;added p-373
72 .I $G(TRSNODE)]"" D Q ;added p-373
73 ..S DGCW=$P($G(TRSNODE),"^",6),DGPW=$P($G(TRSNODE),"^",6) ;added p-373
74 ..S DGCRB=$P($G(TRSNODE),"^",7),DGPRB=$P($G(TRSNODE),"^",7) ;added p-373
75 .I $P($G(DGPMVI(5)),"^")]""&($P($G(DGPMVI(6)),"^")]"") D Q ;added p-373,p-430
76 ..S (DGCW,DGPW)=$P($G(DGPMVI(5)),"^") ;added p-373
77 ..S (DGCRB,DGPRB)=$P($G(DGPMVI(6)),"^") ;added p-373
78 .I $D(VAFH(2,DGMIEN,"A")) D ;added p-373
79 ..S (DGCW,DGPW)=$P(VAFH(2,DGMIEN,"A"),"^",6) ;added p-373
80 ..S (DGCRB,DGPRB)=$P(VAFH(2,DGMIEN,"A"),"^",7) ;added p-373
81SKIP1 ;
82 S DGNW=$$WARDTRAN(DGCW,DGW)
83 S DGNRB=$$RBTRAN(DGCRB,DGR_"-"_DGB)
84 S DGNPW=$$WARDTRAN(DGPW,DGPWN)
85 S DGNPRB=$$RBTRAN(DGPRB,DGPR_"-"_DGPB)
86 S DGNLOC=$S(DGLOC="":"",1:DGNW_$E(HL("ECH"))_$P(DGNRB,"-")_$E(HL("ECH"))_$P(DGNRB,"-",2)),DGNPLOC=$S(DGNPW="":"",1:DGNPW_$E(HL("ECH"))_$P(DGNPRB,"-")_$E(HL("ECH"))_$P(DGNPRB,"-",2))
87 S $P(DGPV1,HL("FS"),4)=DGNLOC,$P(DGPV1,HL("FS"),7)=DGNPLOC
88LOCEX Q DGPV1
89 ;
90WARDTRAN(DGWIEN,DGWNAM) ;
91 I DGWNAM=""!(DGWNAM=HLQ)!(DGWIEN="") Q DGWNAM
92 S DGCI=$O(^DGRU(46.12,"B",DGWIEN,0)) I DGCI="" Q DGWNAM
93 S DGTNW=$$GET1^DIQ(46.12,DGCI,.02,"I")
94 Q DGTNW
95RBTRAN(DGRBIEN,DGRBNAM) ;
96 I DGRBNAM=""!(DGRBNAM[HLQ)!(DGRBIEN="") Q DGRBNAM
97 S DGCI=$O(^DGRU(46.13,"B",DGRBIEN,0)) I DGCI="" Q DGRBNAM
98 S DGRB=$$GET1^DIQ(46.13,DGCI,.02,"I")
99 Q DGRB
100 ;
101DOCTOR(X) ;DETERMINE IF NEW PERSON A PHYSICIAN ;added 1/12/2000
102 Q 0 ;always flag as non-physician, no need to send these anymore
103 S DGPCN=$$GET1^DIQ(7,X,.01,"I")
104 Q DGPCN["PHYSICIAN"
105 ;
106IN1(DFN) ;CREATE IN1 SEGMENT
107 N DGADT,DGREC,VAIP
108 D IN5^VADPT
109 S DGADT=$S(VAIP(13,1)]"":+$P(VAIP(13,1),"^"),1:"") I DGADT]"" S DGADT=DGADT\1,DGADT=$$HLDATE^HLFNC(DGADT)
110 S DGREC="IN1"_HL("FS")_HL("FS")_HL("FS")_"VA"_HL("FS")_"VETERANS ADMINISTRATION"
111 S $P(DGREC,HL("FS"),13)=DGADT
112 Q DGREC
113 ;
114CALCDT(DFN,DGMIEN) ;CALCULATE FUTURE DISCHARGE DATE
115 N DGOIEN,DGOLDD,DGDT,DGHDT
116 S Z=$O(^DGPM("ATID2",DFN,0)),DGOIEN=$O(^DGPM("ATID2",DFN,Z,DGMIEN))
117 S DGOLDD=$$GET1^DIQ(405,DGOIEN,.01,"I")
118 S X1=DGOLDD,X2=30 D C^%DTC S DGDT=X,DGHDT=$$HLDATE^HLFNC(DGDT)
119 Q DGHDT
120 ;
121ENTS ;USED TO REVIEW HL7 MESSAGES FOR TROUBLE SHOOTING
122 N DA,X,ZZ,ZX
123 N DIC,Y S DIC=771,DIC(0)="MX",X="DGRU RAI EVENTS" D ^DIC S ZX=+Y
124 I Y<0 W !,"The 'DGRU RAI EVENTS' entry in file 771 missing!" Q
125 S DA=999999999999
126 D PRIOR(.DA)
127RD2 S DIR(0)="F^1:1",DIR("A")="(U)p or (D)own" D ^DIR K DIR
128 I X="U" D PRIOR(.DA) G RD2
129 I X="D" D NEXT(.DA) G RD2
130 Q
131 ;
132PRIOR(DA) ;
133 F S DA=$O(^HL(772,DA),-1) Q:DA="" I $P($G(^HL(772,DA,0)),"^",2)=ZX D Q
134 .S DGHMID=$P(^HL(772,DA,0),"^",8),DGMESS=$O(^HLMA("B",DGHMID,0)) Q:DGMESS=""
135 .W !,"Message ID: ",$P($G(^HLMA(+DGMESS,0)),"^",2)
136 .S ZZ=0 F S ZZ=$O(^HL(772,DA,"IN",ZZ)) Q:ZZ'>0 W !,^(ZZ,0)
137 I DA="" W "...At the Top.." S DA=9999999999
138 Q
139NEXT(DA) ;
140 F S DA=$O(^HL(772,DA)) Q:DA'>0 I $P($G(^HL(772,DA,0)),"^",2)=ZX D Q
141 .S DGHMID=$P(^HL(772,DA,0),"^",8),DGMESS=$O(^HLMA("B",DGHMID,0)) Q:DGMESS=""
142 .W !,"Message ID: ",$P($G(^HLMA(+DGMESS,0)),"^",2)
143 .S ZZ=0 F S ZZ=$O(^HL(772,DA,"IN",ZZ)) Q:ZZ'>0 W !,^(ZZ,0)
144 I DA'>0 W "...Bottomed out.." S DA=99999999999
145 Q
146 ;
147GETDIV(X) ;GET DIVISION FOR SPECIFIED WARD
148 ;
149 ;X = Ward IEN
150 Q:$G(X)="" -1
151 S X=$$GET1^DIQ(42,X,.015,"I")
152 Q X
153 ;
154CKADMIT(DFN) ;CHECH IF INTEGRATED SITE FOR ORIGINAL ADMIT DATE
155 N DGASIH,DGINTEG,DGZDT,DGNDT,DGPMDA,DGQ
156 S (DGZDT,DGNDT)=""
157 S DGQ=0
158 F S DGZDT=$O(^DGPM("APTT1",DFN,DGZDT),-1) Q:DGZDT="" D Q:DGQ=1
159 .S DGPMDA=$O(^DGPM("APTT1",DFN,DGZDT,0))
160 .S DGASIH=$$GET1^DIQ(405,DGPMDA,.22,"I")
161 .Q:DGASIH>0
162 .S DGNDT=$$GET1^DIQ(405,DGPMDA,300,"I"),DGQ=1
163 Q DGNDT
164 ;
165FLLTCM(DFN) ;
166 ;Find last movement before patient goes ASIH
167 N DGLASTA,DGLASTT,DGTIEN,DGLTCA,DGLTCIEN ;p-430
168 S DGTIEN="" ;p-430
169 G:DFN="" QUIT ;p-430
170 ;If not inpatient, was ASIH to other facility. Get transfer movement
171 I '$D(^DPT(DFN,.1)) S DGTIEN=$O(^DGPM("APTT2",DFN,DGTIEN),-1),DGTIEN=$O(^DGPM("APTT2",DFN,DGTIEN,0)) G QUIT
172 ;
173 ;Get last Admision
174 S DGLASTA=$O(^DGPM("APTT1",DFN,""),-1) ;p-430
175 ;
176 ;Quit if last admit not to ASIH (date length less than 15 characters)
177 G:DGLASTA=""!($L(DGLASTA)'=15) QUIT ;p-430
178 ;
179 ;Get LTC admit ien
180 S DGLTCA=$O(^DGPM("APTT1",DFN,DGLASTA),-1) ;p-430
181 G:DGLTCA="" QUIT ;p-430
182 S DGLTCIEN=$O(^DGPM("APTT1",DFN,DGLTCA,0)) ;p-430
183 ;
184 ;Look for last transfer before ASIH admit
185 S DGLASTT=$E(DGLASTA,1,14)_"1" ;p-430
186 S DGTIEN=$O(^DGPM("APTT2",DFN,DGLASTT),-1) ;p-430
187 ;
188 ;If no transfers use admit movement
189 I DGTIEN="" S DGTIEN=DGLTCIEN G QUIT ;p-430
190 S DGTIEN=$O(^DGPM("APTT2",DFN,DGTIEN,0)) ;p-430
191 I $P(^DGPM(DGTIEN,0),"^",14)'=DGLTCIEN S DGTIEN=DGLTCIEN G QUIT ;p-430
192QUIT Q DGTIEN
193 ;
Note: See TracBrowser for help on using the repository browser.