source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXMTL.m@ 1005

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

revised back to 6/30/08 version

File size: 6.4 KB
Line 
1ECXMTL ;ALB/JAP - DSS Mental Health Extract ; 9/11/06 11:07am
2 ;;3.0;DSS EXTRACTS;**24,30,33,39,46,49,71,82,84,92**;Dec 22, 1997;Build 30
3 ;
4BEG ;entry point from option
5 D SETUP I ECFILE="" Q
6 D ^ECXTRAC,^ECXKILL
7 Q
8 ;
9START ;entry point from tasked job
10 S QFLG=0
11 ;get first record #
12 S EC7=$O(^ECX(ECFILE,999999999),-1)
13 ;call mh/dss api for extract record creation
14 ;variables ecfile,ecxym,ecinst,ecsd,eced passed in by taskmanager
15 S ECXSEQ=EC7,ECXECX=$P(EC23,U,2),ECXERR=0
16 ;call mh api to create extract records
17 S X="YSDSS" X ^%ZOSF("TEST") I '$T S QFLG=1 Q
18 D UPD^YSDSS(ECFILE,.ECXSEQ,ECXYM,ECXECX,ECINST,ECSD,ECED,.ECXERR)
19 Q:ECXERR
20 Q:QFLG
21 ;if no error, continue
22 D UPDATE
23 Q
24 ;
25UPDATE ;add non-mh data to each record created by mh api
26 N ECXADT,JJ,ECXNPRFI
27 S EC7=EC7+1
28 F JJ=EC7:1:ECXSEQ Q:QFLG D
29 .Q:'$D(^ECX(ECFILE,JJ,0))
30 .S ECXDFN=$P(^ECX(ECFILE,JJ,0),U,5),ECXDATE=$P(^ECX(ECFILE,JJ,0),U,9),ECXPRV=$P(^ECX(ECFILE,JJ,0),U,18)
31 .S ECXSCNUM=$P(^ECX(ECFILE,JJ,0),U,23),ECXSCNAM=$P(^ECX(ECFILE,JJ,0),U,24)
32 .D PAT(ECXDFN,ECXDATE)
33 .S (ECXPRCLS,ECXPRNPI,ECXDIV,ECXPDIV)="" I ECXPRV D PROV(.ECXPRV,ECXDATE)
34 .S ECXDSSI=""
35 .I ECXLOGIC>2003 D
36 ..I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECXDSSI=$$TSMAP^ECXUTL4(ECXTS)
37 .;
38 .;- Observation patient indicator (YES/NO)
39 .S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXDSSI)
40 .;
41 .;- set national patient record flag if exist
42 .D NPRF^ECXUTL5
43 .;
44 .;- If no encounter number don't file record
45 .S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC=""
46 .S ECD=ECXDATE,ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM)
47 .;adjust scale name & scale number
48 .S ECXSCNAM=$E(ECXSCNAM,1,10)
49 .I ECXSCNUM]"",ECXSCNUM'=+ECXSCNUM S ECXSCNUM=+$E(ECXSCNUM,2,99)
50 .N ECXDEPT S ECXDEPT="" ;dss department use postponed S ECXDEPT=$$MTL^ECXDEPT(ECXDIV,ECXSCNAM,ECINST) ;p-46 line added
51 .;Set division to external value if extract is for FY05 or higher
52 .D FILE
53 Q
54 ;
55PAT(ECXDFN,ECXDATE) ;determine in/outpatient status, demographics, primary care
56 N OK
57 S (ECXADT,ECXPNM,ECXSSN,ECXMPI)=""
58 K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;3;5;",.ECXPAT)
59 S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
60 S ECXDOB=ECXPAT("DOB")
61 ;agent orange status
62 S ECXAST=ECXPAT("AO STAT")
63 ;- Purple Heart Indicator, Period of Service, Agent Orange Location
64 S ECXPHI=$G(ECXPAT("PHI")),ECXPOS=ECXPAT("POS"),ECXAOL=ECXPAT("AOL")
65 I $$ENROLLM^ECXUTL2(ECXDFN)
66 ;Combat Veteran Status
67 S X3=$$CVEDT^ECXUTL5(ECXDFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT))
68 ; - Head and Neck Cancer Indicator
69 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
70 ; - Race and Ethnicity
71 S ECXETH=ECXPAT("ETHNIC")
72 S ECXRC1=ECXPAT("RACE1")
73 ;get primary care data
74 S X=$$PRIMARY^ECXUTL2(ECXDFN,ECXDATE),ECPTTM=$P(X,U)
75 S ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
76 S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
77 ;get inpatient data
78 S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3)
79 S ECXA=$P(X,U),(ECXADT,ECXADMDT)=$P($P(X,U,4),"."),ECXDCDT=$P($P(X,U,6),".")
80 S ECXWPRV=$P(X,U,7),ECXATT=$P(X,U,8)
81 ;Get ward provider and attending phy person classes
82 S ECXWPRPC=$P(X,U,11),ECXATTPC=$P(X,U,12)
83 I ECXADMDT S ECXADMDT=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM)
84 I ECXDCDT S ECXDCDT=$$ECXDATE^ECXUTL(ECXDCDT,ECXYM)
85 Q
86 ;
87PROV(ECXPRV,ECXDATE) ;get provider data
88 N INST,DGIEN,ARR,DIC,DR,DA,DIQ
89 S ECXPRCLS=$$PRVCLASS^ECXUTL(ECXPRV,ECXDATE)
90 S ECXPRNPI=""
91 ;get division identifier using provider
92 S (ECXDIV,ECXPDIV)=""
93 S IEN=0 F D Q:'IEN Q:'INST Q:ECXDIV
94 .;get pointer to file #4 from provider record
95 .I '$D(^VA(200,ECXPRV,0)) Q
96 .S IEN=$O(^VA(200,ECXPRV,2,IEN))
97 .Q:'IEN
98 .S DIC="^VA(200,",DR="16",DA=ECXPRV
99 .S DR(200.02)=".01",DA(200.02)=IEN,DIQ="ARR",DIQ(0)="I"
100 .D EN^DIQ1
101 .S INST=$G(ARR(200.02,IEN,.01,"I"))
102 .Q:'INST
103 .;get production division
104 .S ECXPDIV=$$RADDIV^ECXDEPT(INST) ;p-46 line added
105 .;get medical center division
106 .S DGIEN=$O(^DG(40.8,"AD",INST,0)) I DGIEN D
107 ..S ECXDIV=$P($G(^ECX(727.3,DGIEN,0)),U,2)
108 S ECXPRV="2"_ECXPRV
109 Q
110 ;
111FILE ;file record in #727.812
112 ;node0
113 ;facility^dfn^ssn ECXSSN^name ECXPNM^i/o status ECXA^
114 ;day ECXDATE^division ECXDIV^admit date ECXADMDT^
115 ;d/c date ECXDCDT^dss id ECXDSSI^pc team ECPTTM^pc provider ECPTPR^
116 ;pc provider npi ECPTNPI^pc prov person class ECCLAS^
117 ;provider ECXPRV^provider npi ECXPRNPI^prov person class ECXPRCLS^
118 ;test name ECXSCNAM(?)^test ien ECXSCNUM(?)^scale number^scale name^
119 ;test score^scale score^attend phys^ward provider
120 ;node1
121 ;mpi^assoc pc provider^assoc pc provider npi^
122 ;assoc pc prov person class^asi class^asi special^asi encounter date^
123 ;purple heart ind.^dom prrtp & saartp ind.^enrollment cat^
124 ;enrollment stat^enrollment prior^period of serv.^obs. pat ind.^
125 ;encounter num^agent orange loc^dob^production division^dss
126 ;department ECXDEPT^head & neck canc. indi.^ethnicity^race1^^
127 ;enrollment prior ECXPRIOR_enrollment subgroup
128 ;ECXSBGRP^enrollee user ECXUESTA^division ECXDIV^patient type
129 ;ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^
130 ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI
131 ;attending phy person class ECXATTPC^ward provider person class
132 ;ECXWPRPC^^agent orange status ECXAST
133 N DA,DIK,STR
134 I $P(^ECX(ECFILE,JJ,0),U,21)="ASI" S $P(^ECX(ECFILE,JJ,1),U,7)=ECXDATE
135 S $P(^ECX(ECFILE,JJ,0),U,6,9)=ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE
136 S STR=$S(ECXLOGIC<2005:ECXDIV,1:"")_U_ECXADMDT_U_ECXDCDT_U_ECXDSSI_U_ECPTTM_U_ECPTPR_U
137 S STR=STR_ECPTNPI_U_ECCLAS,$P(^ECX(ECFILE,JJ,0),U,10,17)=STR,STR=""
138 S $P(^ECX(ECFILE,JJ,0),U,18,20)=ECXPRV_U_ECXPRNPI_U_ECXPRCLS
139 S $P(^ECX(ECFILE,JJ,0),U,23,24)=ECXSCNUM_U_ECXSCNAM
140 S $P(^ECX(ECFILE,JJ,0),U,27,29)=ECXATT_U_ECXWPRV_U
141 I '$D(^ECX(ECFILE,JJ,1)) S ^ECX(727.812,JJ,1)="^^^^^"
142 S $P(^ECX(ECFILE,JJ,1),U,1,4)=ECXMPI_U_ECASPR_U_ECASNPI_U_ECCLAS2
143 S STR=ECXPHI_U_ECXDOM_U_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U
144 S STR=STR_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXDOB_U_ECXPDIV_U_ECXDEPT_U
145 S STR=STR_ECXHNCI_U_ECXETH_U_ECXRC1_U
146 I ECXLOGIC>2004 S STR=STR_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXDIV_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
147 I ECXLOGIC>2005 S STR=STR_U_ECXATTPC_U_ECXWPRPC
148 S $P(^ECX(ECFILE,JJ,1),U,8,22)=STR
149 I ECXLOGIC>2006 S $P(^ECX(ECFILE,JJ,1),U,34)=ECXAST
150 S DA=JJ,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
151 S ECRN=ECRN+1
152 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
153 Q
154 ;
155SETUP ;Set required input for ECXTRAC
156 S ECHEAD="MTL"
157 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
158 Q
159 ;
160QUE ;Entry point for the background requeuing handled by ECXTAUTO.
161 D SETUP,QUE^ECXTAUTO,^ECXKILL
162 Q
Note: See TracBrowser for help on using the repository browser.