source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXTRT.m@ 619

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

initial load of WorldVistAEHR
File size: 8.5 KB
RevLine 
[613]1ECXTRT ;ALB/JAP,BIR/DMA,CML,PTD-Treating Specialty Change Extract ; 10/17/07 3:48pm
2 ;;3.0;DSS EXTRACTS;**1,8,17,24,33,35,39,46,49,84,107,105**;Dec 22, 1997;Build 70
3BEG ;entry point from option
4 D SETUP I ECFILE="" Q
5 D ^ECXTRAC,^ECXKILL
6 Q
7 ;
8START ; start package specific extract
9 N LOC,SPC,TRT,WRD
10 S QFLG=0
11 K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
12 S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
13 K ^TMP($J,"ECXTMP") S TRT=0
14 F S TRT=$O(^DIC(45.7,TRT)) Q:+TRT=0 S SPC=$P(^DIC(45.7,TRT,0),U,2),^TMP($J,"ECXTMP",TRT)=SPC
15 S ECED=ECED+.3,ECD=ECSD1
16 ;loop through type 6 movements to get treating specialty and provider changes
17 F S ECD=$O(^DGPM("ATT6",ECD)),ECDA=0 Q:('ECD)!(ECD>ECED)!(QFLG) F S ECDA=$O(^DGPM("ATT6",ECD,ECDA)) Q:'ECDA D Q:QFLG
18 .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG
19 ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6)
20 ..;
21 ..;- Call sets ECXA (In/Out indicator)
22 ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD1,"1;",13)
23 ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U)
24 ..;skip the record if its the admission treat. spec. change for this episode of care
25 ..Q:ECXADM=$P(EC,U,24)
26 ..S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD=""
27 ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC)
28 ..;get data for current (new) ts movement
29 ..S ECD1=9999999.9999999-ECXMVD1
30 ..D FINDLOC(ECD1,.LOC,.ECXSPCN,.ECXPRVN,.ECXATTN,.ECXMOVN,.ECXTRTN)
31 ..Q:ECXSPCN=""
32 ..S ECD2=$O(LOC(ECD1)) Q:ECD2=""
33 ..S ECXMVD2=9999999.9999999-ECD2
34 ..;get data for previous (losing) ts movement
35 ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL)
36 ..;if ts has changed, find los on losing ts
37 ..D:ECXTRTL'=ECXTRTN PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS)
38 ..;whether ts has changed or not, see if primary provider has changed
39 ..;don't bother if there's no data on current primary provider or no change in provider
40 ..D:(ECXPRVN'="")&(ECXPRVN'=ECXPRVL) PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP)
41 ..;whether ts has changed or not, see if attending physician has changed
42 ..;don't bother if there's no data on current attending physician or no change in attending
43 ..D:(ECXATTN'="")&(ECXATTN'=ECXATTL) PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA)
44 ..S ECXDATE=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1)
45 ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT),ECXDCDT=""
46 ..;- Production Division
47 ..S ECXPDIV=""
48 ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD))
49 ..;
50 ..;- Observation patient indicator (YES/NO)
51 ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
52 ..;
53 ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule)
54 ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I"
55 ..;
56 ..;- Get providers person classes
57 .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT)
58 .. S ECATLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTL,2,999),ECXADT)
59 .. S:+ECATLNPI'>0 ECATLNPI="" S ECATLNPI=$P(ECATLNPI,U)
60 .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT)
61 .. S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVN,2,999),ECXADT)
62 .. S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U)
63 .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT)
64 .. S ECATTNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTN,2,999),ECXADT)
65 .. S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U)
66 .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT)
67 .. S ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVL,2,999),ECXADT)
68 .. S:+ECPRLNPI'>0 ECPRLNPI="" S ECPRLNPI=$P(ECPRLNPI,U)
69 ..;
70 ..;- If no encounter number, don't file record
71 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,)
72 ..D:ECXENC'="" FILE^ECXTRT2
73 ;for nhcu episodes with intervening asih stays, the los calculated here is not accurate,
74 ;but it never has been; this is best solution within current extract framework;
75 ;at discharge the los calculated for nhcu episodes will be the los since admission w/o asih los subtracted;
76 ;
77 ;loop through discharges to get last treating specialty
78 S ECD=ECSD1
79 F S ECD=$O(^DGPM("ATT3",ECD)),ECDA=0 Q:'ECD Q:ECD>ECED F S ECDA=$O(^DGPM("ATT3",ECD,ECDA)) Q:'ECDA D Q:QFLG
80 .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG
81 ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6)
82 ..S (ECXDATE,ECXDCDT)=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1)
83 ..I ECXDCDT'>0 S ECXDCDT=""
84 ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U,1)
85 ..S (ECXTRTN,ECXSPCN,ECXPRVN,ECXATTN)="" S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD=""
86 ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC)
87 ..S ECD1=9999999.9999999-ECXMVD1
88 ..;get ts change just before d/c
89 ..S ECD2=$O(LOC(ECD1)),ECXMVD2=9999999.9999999-ECD2
90 ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL)
91 ..;
92 ..;- Call sets ECXA (In/Out indicator) using date before discharge
93 ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD2,"1;",13)
94 ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT)
95 ..;if closest ts change is admission ts, cant go back any further
96 ..S TRT=$O(LOC(ECD2,0)),REC=$O(LOC(ECD2,TRT,0))
97 ..I REC=ECXADM D
98 ...S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOS=X
99 ...I ECXPRVL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSP=X
100 ...I ECXATTL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSA=X
101 ..;otherwise, need to find when change to last ts occurred
102 ..I REC'=ECXADM D
103 ...D PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS)
104 ...D PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP)
105 ...D PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA)
106 ..S:ECXLOS>9999 ECXLOS=9999 S:ECXLOSA>9999 ECXLOSA=9999
107 ..S:ECXLOSP>9999 ECXLOSP=9999
108 ..;- Production Division
109 ..S ECXPDIV=""
110 ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD))
111 ..;
112 ..;- Observation patient indicator (YES/NO)
113 ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
114 ..;
115 ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule)
116 ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I"
117 ..;
118 ..;- Get providers person classes
119 .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT)
120 .. S ECATLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTL,2,999),ECXADT)
121 .. S:+ECATLNPI'>0 ECATLNPI="" S ECATLNPI=$P(ECATLNPI,U)
122 .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT)
123 .. S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVN,2,999),ECXADT)
124 .. S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U)
125 .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT)
126 .. S ECATTNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTN,2,999),ECXADT)
127 .. S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U)
128 .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT)
129 .. S ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVL,2,999),ECXADT)
130 .. S:+ECPRLNPI'>0 ECPRLNPI="" S ECPRLNPI=$P(ECPRLNPI,U)
131 ..;
132 ..;- If no encounter number don't file record
133 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,)
134 ..D:ECXENC'="" FILE^ECXTRT2
135 D KPATDEM^ECXUTL2
136 Q
137 ;
138NPDIV(WRD) ;National Production Division
139 N DIV
140 S DIV=$$GET1^DIQ(42,WRD,.015,"I")
141 Q $S(DIV="":"",1:$$GETDIV^ECXDEPT(DIV))
142 ;
143SETLOC(ECXDFN,ECXADM,ECXPRO,ECXLOC) ;setup the local array from the ATS index
144 ; output
145 ; ECXLOC = local array (passed by reference)
146 ;
147 N SUB3,SUB4,SUB5,SPC,PRV,ATT,MOV
148 S SUB3=0
149 F S SUB3=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3)) Q:SUB3="" D
150 .S (SUB4,SUB5)=0
151 .S SUB4=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4))
152 .S SUB5=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4,SUB5))
153 .S ECXLOC(SUB3,SUB4,SUB5)="",SPC=$G(^TMP($J,"ECXTMP",SUB4))
154 .S DATA=$G(^DGPM(SUB5,0)),PRV=$P(DATA,U,8),ATT=$P(DATA,U,19)
155 .S MOV=$P(DATA,U,14)
156 .S:PRV]"" PRV=ECXPRO_PRV S:ATT]"" ATT=ECXPRO_ATT
157 .S ECXLOC(SUB3,SUB4,SUB5)=SPC_U_PRV_U_ATT_U_MOV
158 Q
159 ;
160FINDLOC(ECXTSD,ECXLOC,ECXSPC,ECXPRV,ECXATT,ECXMOV,ECXTRT) ;find local array node for current ts movement
161 ; input
162 ; ECXTSD = inverse date/time for current ts movement; required
163 ; ECXLOC = local array; passed by reference; required
164 ; output; data from record contained in MOVE
165 ; ECXSPC = piece 1 of LOC (passed by reference)
166 ; ECXPRV = piece 2 of LOC concatenated to PRO (passed by reference)
167 ; ECXATT = piece 3 of LOC concatenated to PRO (passed by reference)
168 ; ECXMOV = piece 4 of LOC (passed by reference)
169 ; ECXTRT = pointer to file #45.7
170 ;
171 N SUB3,SUB4,SUB5,LOC
172 S (ECXSPC,ECXPRV,ECXATT,ECXMOV)=""
173 S SUB3=ECXTSD
174 I $D(ECXLOC(SUB3)) D
175 .S SUB4=$O(ECXLOC(SUB3,0)),SUB5=$O(ECXLOC(SUB3,SUB4,0))
176 .S LOC=ECXLOC(SUB3,SUB4,SUB5),ECXTRT=SUB4,ECXSPC=$P(LOC,U)
177 .S ECXPRV=$P(LOC,U,2),ECXATT=$P(LOC,U,3),ECXMOV=$P(LOC,U,4)
178 Q
179 ;
180SETUP ;Set required input for ECXTRAC
181 S ECHEAD="TRT"
182 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
183 Q
184 ;
185QUE ; entry point for the background requeuing handled by ECXTAUTO
186 D SETUP,QUE^ECXTAUTO,^ECXKILL
187 Q
Note: See TracBrowser for help on using the repository browser.