source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXADM.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: 7.4 KB
RevLine 
[613]1ECXADM ;ALB/JAP,BIR/DMA,CML,PTD-Admissions Extract ; 10/15/07 12:14pm
2 ;;3.0;DSS EXTRACTS;**1,4,11,8,13,24,33,39,46,71,84,92,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 S QFLG=0
10 S ECED=ECED+.3,ECD=ECSD1
11 F S ECD=$O(^DGPM("ATT1",ECD)),ECDA=0 Q:('ECD)!(ECD>ECED) D
12 .F S ECDA=$O(^DGPM("ATT1",ECD,ECDA)) Q:ECDA="" D
13 ..I $D(^DGPM(ECDA,0)) D
14 ...S EC=^DGPM(ECDA,0),ECXDFN=$P(EC,U,3) D GET
15 Q
16 ;
17GET ;gather extract data
18 N ADM,W,X,ECXNPRFI,ECXATTPC,ECXPRVPC,ECXEST
19 ;patient demographics
20 S ECXERR=0 D PAT(ECXDFN,ECD,.ECXERR)
21 Q:ECXERR
22 I $$ENROLLM^ECXUTL2(ECXDFN)
23 S ECXFAC=$P($G(^DIC(42,+$P(EC,U,6),0)),U,11)
24 S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;Get production division
25 ;admission data
26 S ELGA=$P($G(^DIC(8,+$P(EC,U,20),0)),U,9)
27 I ELGA S ELGA=$$ELIG^ECXUTL3(ELGA,ECXSVC)
28 S (ECDRG,ECDIA,ECXSADM)="",ECPTF=+$P(EC,U,16) I ECPTF,$D(^DGPT(ECPTF,"M")) D PTF
29 ;get encounter classification
30 S (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC)="",ECXVISIT=$P(EC,U,27)
31 I ECXVISIT'="" D
32 .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q
33 .S ECXAO=$G(ECXVIST("AO")),ECXIR=$G(ECXVIST("IR"))
34 .S ECXMIL=$G(ECXVIST("MST")),ECXHNC=$G(ECXVIST("HNC"))
35 .S ECXECE=$G(ECXVIST("PGE"))
36 ;use movement record date & time
37 S ADM=$$INP^ECXUTL2(ECXDFN,ECD)
38 S ECXA=$P(ADM,U),ECXMN=$P(ADM,U,2),ECXSPC=$P(ADM,U,3)
39 S (ECXADMDT,ECXDATE)=$P(ADM,U,4)
40 ;if movement# doesn't match cross-ref ien, then quit
41 Q:ECXMN'=ECDA
42 S ECTM=$$ECXTIME^ECXUTL(ECXDATE)
43 S ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM)
44 S W=$P(ADM,U,9)
45 S ECXWRD=$P(W,";",1),ECXFAC=$P(W,";",2),ECXDSSD=$P(W,";",3)
46 S ECXPRV=$P(ADM,U,7),ECXPRNPI="",ECXATT=$P(ADM,U,8),ECXATNPI=""
47 S ECXDOM=$P(ADM,U,10),ECXATTPC=$P(ADM,U,12),ECXPRVPC=$P(ADM,U,11)
48 N ECXUSRTN
49 S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$E(ECXATT,2,$L(ECXATT)),ECD)
50 S:+ECXUSRTN'>0 ECXUSRTN=""
51 S ECATTNPI=$P(ECXUSRTN,U)
52 S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$E(ECXPRV,2,$L(ECXPRV)),ECD)
53 S:+ECXUSRTN'>0 ECXUSRTN=""
54 S ECPWNPI=$P(ECXUSRTN,U)
55 ;
56 ;- Observation patient indicator (YES/NO)
57 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXSPC)
58 ;
59 ;- Patient Type
60 S ECXPTYPE=$$TYPE^ECXUTL5(ECXDFN)
61 ;
62 ;- If null encounter number, don't file record
63 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,,ECXSPC,ECXOBS,ECHEAD,,)
64 D:ECXENC'="" FILE
65 Q
66 ;
67PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographic data
68 N OK,X
69 K ECXPAT
70 S ECXDATE=$P(ECXDATE,".")
71 S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;2;3;4;5",.ECXPAT)
72 I 'OK S ECXERR=1 K ECXPAT Q
73 S ECXSSN=ECXPAT("SSN")
74 S ECXPNM=ECXPAT("NAME")
75 S ECXMPI=ECXPAT("MPI")
76 S ECXSEX=ECXPAT("SEX")
77 S ECXDOB=ECXPAT("DOB")
78 S ECXELIG=ECXPAT("ELIG")
79 S ECXVET=ECXPAT("VET")
80 S ECXVNS=ECXPAT("VIETNAM")
81 S ECXPOS=ECXPAT("POS")
82 S ECXMNS=ECXPAT("MEANS")
83 S ECXRACE=ECXPAT("RACE")
84 S ECXRELG=ECXPAT("RELIGION")
85 S ECXEMP=ECXPAT("EMPLOY")
86 S ECXMAR=ECXPAT("MARITAL")
87 S ECXPST=ECXPAT("POW STAT")
88 S ECXPLOC=ECXPAT("POW LOC")
89 S ECXRST=ECXPAT("IR STAT")
90 S ECXAST=ECXPAT("AO STAT")
91 S ECXMST=ECXPAT("MST STAT")
92 S ECXSTATE=ECXPAT("STATE")
93 S ECXCNTY=ECXPAT("COUNTY")
94 S ECXZIP=ECXPAT("ZIP")
95 S ECXENRL=ECXPAT("ENROLL LOC")
96 S ECXSVC=ECXPAT("SC%")
97 S ECXPHI=ECXPAT("PHI")
98 S ECXHI=+$$INSUR^IBBAPI(ECXDFN,ECXDATE)
99 S ECXEST=ECXPAT("EC STAT")
100 ;
101 ;-OEF/OIF Data
102 S ECXOEF=ECXPAT("ECXOEF")
103 S ECXOEFDT=ECXPAT("ECXOEFDT")
104 ;
105 ;- Agent Orange location
106 S ECXAOL=ECXPAT("AOL")
107 ;
108 ; - Head and Neck Cancer Indicator
109 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
110 ; - Race and Ethnicity
111 S ECXETH=ECXPAT("ETHNIC")
112 S ECXRC1=ECXPAT("RACE1")
113 ;
114 ;get primary care data
115 S X=$$PRIMARY^ECXUTL2(ECXDFN,ECXDATE)
116 S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
117 S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
118 ;get combat veteran data
119 I $$CVEDT^ECXUTL5(ECXDFN,ECD)
120 ;get national patient record flag if exist
121 D NPRF^ECXUTL5
122 ;get emergency response indicator (FEMA)
123 S ECXERI=ECXPAT("ERI")
124 Q
125 ;
126PTF ; get admitting DRG, diagnosis, source of admission from PTF
127 ;use number for DRG and .01 for diagnosis
128 N EC,EC1,ECX
129 S EC=1 I $D(^DGPT(ECPTF,"M",2,0)) S EC=2
130 S EC1=+$P(^DGPT(ECPTF,"M",EC,0),U,5)
131 S ECDRG=$P($G(^DGPT(ECPTF,"M",EC,"P")),U)
132 S ECDIA=$P($G(^ICD9(EC1,0)),U)
133 S ECX=+$P($G(^DGPT(ECPTF,101)),U),ECXSADM=$P($G(^DIC(45.1,ECX,0)),U,11)
134 Q
135 ;
136FILE ;file the extract record
137 ;node0
138 ;facility^dfn^ssn^name^in/out^day^primary care team^sex^dob^
139 ;religion^employment status^health ins^state^county^zip^
140 ;eligibility^vet^vietnam^agent orange^radiation^pow^
141 ;period of service^means test^marital status^
142 ;ward^treating specialty^attending physician^mov #^DRG^diagnosis^
143 ;time^primary care provider^race^primary ward provider
144 ;node1
145 ;mpi^dss dept^attending npi^pc provider npi^ward provider npi^
146 ;admission elig^mst status^^sharing payor^
147 ;sharing insurance^enrollment location^
148 ;pc prov person class^assoc pc provider^assoc pc prov person class^
149 ;assoc pc prov npi^dom^enrollment cat^enrollment stat^enrollment
150 ;priority^purple heart ind.^obs pat ind^encounter num^agent orange
151 ;loc^production div^pow loc^source of admission^head & neck canc. ind
152 ;^ethnicity^race1^enrollment priority_sub group^user enrollee^patient
153 ;type^combat vet elig^combat vet elig end date^enc cv eligible^
154 ;national patient record flag ECXNPRFI^att phy person class ECXATTPC
155 ;^primary ward provider person class ECXPRVPC^environ contamin ECXEST
156 ;^emergency response indicator(FEMA) ECXERI^agent orange indic ECXAO
157 ;^environ contam ECXECE^encoun head/neck ECXHNC^encoun MST ECXMIL^rad
158 ;encoun ECXIR^ OEF/OIF ECXOEF^ OEF/OIF return date ECXOEFDT
159 ;^associate pc provider npi ECASNPI^attending physician npi ECATNPI^
160 ;primary care provider npi ECPTNPI^primary ward provider npi ECPWNPI
161 ;
162 ;Convert specialty to PTF Code
163 ;
164 N ECXDATA
165 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPC,.ECXDATA)
166 S ECXSPC=$G(ECXDATA(7))
167 ;
168 N DA,DIK
169 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
170 S ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE_U
171 S ECODE=ECODE_ECPTTM_U_ECXSEX_U_ECXDOB_U_ECXRELG_U
172 S ECODE=ECODE_ECXEMP_U_ECXHI_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U
173 S ECODE=ECODE_ECXELIG_U_ECXVET_U_ECXVNS_U_ECXAST_U_ECXRST_U_ECXPST_U
174 S ECODE=ECODE_ECXPOS_U_ECXMNS_U_ECXMAR_U
175 S ECODE=ECODE_ECXWRD_U_ECXSPC_U_ECXATT_U_ECDA_U_ECDRG_U_ECDIA_U
176 S ECODE=ECODE_ECTM_U_ECPTPR_U_ECXRACE_U_ECXPRV_U
177 S ECODE1=ECXMPI_U_ECXDSSD_U_""_U_""_U_""_U_ELGA_U
178 S ECODE1=ECODE1_ECXMST_U_U_U_U_ECXENRL_U_ECCLAS_U
179 S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_U_ECXDOM_U_ECXCAT_U
180 S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U
181 S ECODE1=ECODE1_ECXPDIV_U_ECXPLOC_U_ECXSADM_U_ECXHNCI_U_ECXETH_U
182 S ECODE1=ECODE1_ECXRC1
183 I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
184 I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXATTPC_U_ECXPRVPC_U_ECXEST
185 I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U
186 I ECXLOGIC>2007 S ECODE2=ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECATTNPI_U_ECPTNPI_U_ECPWNPI
187 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2)
188 S ECRN=ECRN+1
189 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
190 Q
191 ;
192SETUP ;Set required input for ECXTRAC.
193 S ECHEAD="ADM"
194 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
195 Q
196 ;
197LOCAL ; to extract nightly for local use not to be transmitted to TSI
198 ; should be queued with a 1D frequency
199 D SETUP,^ECXTLOCL,^ECXKILL Q
200 ;
201QUE ; entry point for the background requeuing handled by ECXTAUTO
202 D SETUP,QUE^ECXTAUTO,^ECXKILL Q
203 ;
Note: See TracBrowser for help on using the repository browser.