source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL2.m@ 789

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

revised back to 6/30/08 version

File size: 9.3 KB
Line 
1ECXUTL2 ;ALB/JAP - Utilities for DSS Extracts (cont.) ; 11/2/06 9:03am
2 ;;3.0;DSS EXTRACTS;**8,13,23,24,33,35,39,46,71,84,92**;Dec 22, 1997;Build 30
3 ;
4ECXDEF(ECXHEAD,ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER) ;variables specific to extract from file #727.1
5 ; input
6 ; ECXHEAD = extract header code
7 ; all other formal list parameters passed by reference
8 ; output
9 ; ECXPACK = type field (#7)
10 ; ECXGRP = group field (#9)
11 ; ECXFILE = file number field (#1)
12 ; ECXRTN = routine field (#4)
13 ; ECXPIECE= running piece field (#11)
14 ; ECXVER = dss version
15 ;
16 N ECXIEN,ECXARR,DIC,DA,DR,DIQ
17 S (ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER)="",ECXIEN=0
18 S ECXIEN=+$O(^ECX(727.1,"C",ECXHEAD,ECXIEN))
19 I ECXIEN=0 D Q
20 .D MES^XPDUTL(" ")
21 .D MES^XPDUTL(" It appears that you may have a problem with File #727.1 --")
22 .D MES^XPDUTL(" ")
23 .D MES^XPDUTL(" The "_ECHEAD_" Extract is not properly defined.")
24 .D MES^XPDUTL(" ")
25 .D MES^XPDUTL(" Contact National VISTA Support for further assistance.")
26 .D MES^XPDUTL(" ")
27 .I $E(IOST)="C" D
28 ..S SS=22-$Y F JJ=1:1:SS W !
29 ..S DIR(0)="E" W ! D ^DIR K DIR
30 .W !!
31 S DIC="^ECX(727.1,",DA=ECXIEN,DR=".01;1;4;7;9;11",DIQ="ECXARR"
32 D EN^DIQ1
33 S ECXPACK=ECXARR(727.1,ECXIEN,7)
34 ;if this is an inactive extract type, skip it
35 I ECXPACK["Inactive" D Q
36 .D MES^XPDUTL(" ")
37 .D MES^XPDUTL(" The "_ECHEAD_" Extract is no longer active/valid.")
38 .D MES^XPDUTL(" ")
39 .D MES^XPDUTL(" Contact National VISTA Support for further assistance.")
40 .D MES^XPDUTL(" ")
41 .I $E(IOST)="C" D
42 ..S SS=22-$Y F JJ=1:1:SS W !
43 ..S DIR(0)="E" W ! D ^DIR K DIR
44 .W !!
45 S ECXGRP=ECXARR(727.1,ECXIEN,9)
46 S ECXFILE=ECXARR(727.1,ECXIEN,1)
47 S ECXRTN="START^"_ECXARR(727.1,ECXIEN,4)
48 S ECXPIECE=ECXARR(727.1,ECXIEN,11)
49 ;version of dss/tsi in Austin as specified by btso
50 S ECXVER=7
51 Q
52 ;
53PATDEM(DFN,DT1,PAR,FLG) ; determine patient information
54 ; DFN =
55 ; DT =
56 ; PAR =
57 ; FLG =
58 N DT2,PAT,OK,X
59 D KPATDEM
60 S FLG=$G(FLG),PAR=$S($D(PAR):PAR,1:"1;2;3;4;5;"),DT2=$P(DT1,".")
61 Q:'$$PAT^ECXUTL3(DFN,DT2,PAR,.PAT) 0
62 S ECXMPI=PAT("MPI")
63 I PAR["1" D
64 .S ECXSSN=PAT("SSN"),ECXPNM=PAT("NAME"),ECXDOB=PAT("DOB")
65 .S ECXSEX=PAT("SEX"),ECXREL=PAT("RELIGION"),ECXRACE=PAT("RACE")
66 .S ECXMAR=PAT("MARITAL")
67 .S ECXETH=PAT("ETHNIC"),ECXRC1=PAT("RACE1")
68 I PAR["2" D
69 .S ECXCNTY=PAT("COUNTY"),ECXSTATE=PAT("STATE"),ECXZIP=PAT("ZIP")
70 I PAR["3" D
71 .S ECXPOS=PAT("POS"),ECSC=PAT("SC STAT"),ECXSVC=PAT("SC%")
72 .S ECXVET=PAT("VET"),ECXMEAN=PAT("MEANS"),ECXELIG=PAT("ELIG")
73 .S ECXENRL=PAT("ENROLL LOC")
74 .S ECXERI=PAT("ERI")
75 I PAR["4" S ECXEMP=PAT("EMPLOY")
76 I PAR["5" D
77 .S ECXVIET=PAT("VIETNAM"),ECXAST=PAT("AO STAT"),ECXRST=PAT("IR STAT")
78 .S ECXEST=PAT("EC STAT"),ECXPST=PAT("POW STAT"),ECXPLOC=PAT("POW LOC")
79 .S ECXPHI=PAT("PHI"),ECXMST=PAT("MST STAT"),ECXAOL=PAT("AOL")
80 I PAR["6" D
81 .S (ECXPAYOR,ECXSAI)="" D VISN19(DFN,.ECXPAYOR,.ECXSAI)
82 I FLG'[3 D
83 .S X=$$PRIMARY(DFN,DT2),ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3)
84 .S ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6)
85 .S ECASNPI=$P(X,U,7)
86 I FLG'[2 D
87 .S ECXINP=$$INP^ECXUTL2(DFN,DT1),ECXA=$P(ECXINP,U),ECXMN=$P(ECXINP,U,2)
88 .S ECXTS=$P(ECXINP,U,3),ECXDOM=$P(ECXINP,U,10),ECXADMDT=$P(ECXINP,U,4)
89 I FLG'[1 S X=$$ENROLLM(DFN)
90 Q 1
91 ;
92KPATDEM ;
93 K ECXADMDT,ECAO,ECASNPI,ECASPR,ECCLAS,ECCLAS2,ECENV,ECPTNPI,ECPTPR,ECPTTM
94 K ECRE,ECSC,ECXA,ECXAST,ECXCAT,ECXCNTY,ECXEST,ECXENRL,ECXDOB
95 K ECXDOM,ECXELIG,ECXINP,ECXMPI,ECXMN,ECXNM,ECXPHI,ECXPLOC,ECXMEAN,ECXMST
96 K ECXPAYOR,ECXPNM,ECXPOS,ECXPRIOR,ECXPST,ECXRACE,ECXREL,ECXRST,ECXSAI
97 K ECXSEX,ECXSSN,ECXSTAT,ECXSTATE,ECXSVC,ECXTS,ECXVIET,ECXZIP,VA,VAERR
98 K ECXSBGRP
99 Q
100 ;
101ENROLLM(DFN,RNDT) ;determines enrollment status, category, priority
102 ;and user enrollee status
103 ; input
104 ; DFN = IEN from Patient file (Required)
105 ; RNDT = Extract Run Date
106 ; output
107 ; ECXSTAT = Enrollment status
108 ; ECXPRIOR = Enrollment priority
109 ; ECXCAT = Enrollment priority
110 ; ECXSBGRP = Enrollment subgroup
111 ; ECXUESTA = User enrollee
112 ; return value 0 if no data found, 1 if data found
113 ;
114 N CAT,PRIOR,STAT,X,X1,X2,X3,ENRIEN,ENR,FL,SBGRP
115 S (ECXCAT,ECXPRIOR,ECXSTAT,ECXSBGRP,ECXEUSTA)=""
116 I $G(DFN)="" Q 0
117 ;User enrollee status, if current or future date set to 'U'
118 ;DBIA #3989
119 S ECXUESTA=$S($$UESTAT^EASUER(DFN):"U",1:"")
120 ;Patient type
121 S ECXPTYPE=$$TYPE^ECXUTL5(DFN)
122 ;Combat Veteran Status DBIA #4156
123 S X3=$$CVEDT^ECXUTL5(DFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT))
124 ;enrollment priority DBIA
125 S STAT=$$STATUS^DGENA(DFN),PRIOR=$$PRIORITY^DGENA(DFN)
126 S CAT=$$CATEGORY^DGENA4(DFN,STAT),SBGRP=$$ENRSBGRP^DGENA4(DFN)
127 ;find current enrollment when status=2 or 19
128 I "^2^19^"[("^"_STAT_"^") S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") Q 1
129 ;find previous enrollment
130 S ENRIEN=$$FINDCUR^DGENA(DFN) I ENRIEN="" Q 0
131 I $G(RNDT)="" D NOW^%DTC S RNDT=X
132 S RNDT=($E(RNDT,1,3)-1)_$E(RNDT,4,7),FL=0
133 F S ENRIEN=$$FINDPRI^DGENA(ENRIEN) Q:'ENRIEN D Q:FL
134 . S ENR=$$GET^DGENA(ENRIEN,.ENR)
135 . I "^2^19^"[("^"_ENR("STATUS")_"^"),ENR("EFFDATE")>RNDT D
136 . . S ECXSTAT=ENR("STATUS"),ECXPRIOR=PRIOR,FL=1
137 . . S ECXCAT=$$CATEGORY^DGENA4(DFN,ECXSTAT)
138 . . S ECXSBGRP=$$ENRSBGRP^DGENA4(DFN)
139 . . S ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"")
140 I FL Q 1
141 ;no enrollment status found =2 or 19
142 S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"")
143 Q 1
144 ;
145PRIMARY(ECXDFN,ECXDATE,ECXPREFX) ;determine patient's pc team and pc provider
146 ; input
147 ; ECXDFN = file #2 ien (required)
148 ; ECXDATE = date of interest (required)
149 ; ECXPREFX = prefix for provider data (optional)
150 ; defaults to "2" if not specified otherwise
151 ; output
152 ; ECXPRIME = pc team ien^prefix_pc provider ien^pc provider person class^pc provider npi
153 ; ^prefix_assoc pc provider ien^assoc pc provider person class^assoc pc provider npi
154 ;
155 N ECPTTM,ECPTPR,ECCLAS,ECPRIME,ECASPR,ECCLAS2
156 S:'$D(ECXPREFX) ECXPREFX=2 S:(+ECXPREFX=0) ECXPREFX=2
157 ;get pc team data
158 S ECPTTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDATE) S:ECPTTM=0 ECPTTM=""
159 ;get primary pc provider data
160 S ECPTPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDATE)
161 S ECCLAS="" I ECPTPR>0 S ECCLAS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE)
162 S:ECPTPR=0 ECPTPR="" S:ECPTPR]"" ECPTPR=ECXPREFX_ECPTPR
163 S ECPTNPI=""
164 ;assoc pc provider call ok if routine scapmca from patch177 is present
165 S ECASPR=""
166 S X="SCAPMCA" X ^%ZOSF("TEST") I $T D
167 .S ECASPR=+$$OUTPTAP^SDUTL3(ECXDFN,ECXDATE)
168 S ECCLAS2="" I ECASPR>0 S ECCLAS2=$$PRVCLASS^ECXUTL(ECASPR,ECXDATE)
169 S:ECASPR=0 ECASPR="" S:ECASPR]"" ECASPR=ECXPREFX_ECASPR
170 S ECASNPI=""
171 ;assemble
172 S ECXPRIME=ECPTTM_U_ECPTPR_U_ECCLAS_U_ECPTNPI_U_ECASPR_U_ECCLAS2_U_ECASNPI
173 Q ECXPRIME
174 ;
175INP(ECXDFN,ECXDATE) ; check for inpatient status
176 ; input
177 ; ECXDFN = file #2 ien (required)
178 ; ECXDATE = date of interest (required)
179 ; output
180 ; ECXINP = patient status^movment # (file #405 ien)
181 ; current treat. spec. (file #42.4 ien)^admission date/time^
182 ; current ward (file #42 ien)^discharge date/time^
183 ; ward provider^attending phys.^ward (file #44 ien);facility
184 ; (file #40.8 ien);dss dept^dom
185 ; where patient status = I for inpatient
186 ; = O for outpatient
187 ;
188 N DFN,DSSDEPT,ECA,ECADM,ECMN,ECTS,ECWARD,ECDC,ECXINP,ECXPRO
189 N ECXATP,ECXDD,ECXDOM,ECXPROF,ECXPWP,ECXWW,FAC,VAIP,WRD,ECXPWPPC
190 N ECXATPPC
191 D FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
192 S ECXPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
193 ;
194 ;- Inpat/outpat indicator (ECA) initially set to "O" (outpatient)
195 S DFN=ECXDFN,ECA="O"
196 S (DSSDEPT,ECMN,ECTS,ECADM,ECWARD,ECDC,ECXATP,ECXPWP,ECXWW,WRD,FAC,ECXPWPPC,ECXATPPC)=""
197 S VAIP("D")=ECXDATE D IN5^VADPT
198 S ECMN=$G(VAIP(1))
199 I ECMN D
200 .S ECTS=+$P($G(^DIC(45.7,+VAIP(8),0)),U,2) S:ECTS=0 ECTS=""
201 .;
202 .;- Get inpat/outpat indicator
203 .S ECA=$$INOUTP^ECXUTL4(ECTS)
204 .S ECADM=+$G(VAIP(13,1)) S:ECADM=0 ECADM=""
205 .S ECWARD=+$G(VAIP(5)) S:ECWARD=0 ECWARD=""
206 .I ECWARD D
207 ..S WRD=+$P($G(^DIC(42,+ECWARD,44)),U)
208 ..S FAC=$P($G(^DIC(42,+ECWARD,0)),U,11)
209 ..S DSSDEPT=$P($G(^ECX(727.4,ECWARD,0)),U,2)
210 .S ECXWW=WRD_";"_FAC_";"_DSSDEPT,ECDC=+$G(VAIP(17,1)) S:ECDC=0 ECDC=""
211 .S ECXPWP=+VAIP(7) S:ECXPWP=0 ECXPWP=""
212 .S ECXATP=+VAIP(18) S:ECXATP=0 ECXATP=""
213 .S ECXPWPPC=$$PRVCLASS^ECXUTL(ECXPWP,ECADM)
214 .S ECXATPPC=$$PRVCLASS^ECXUTL(ECXATP,ECADM)
215 .;prefix file #200 iens
216 .S:ECXPWP ECXPWP=ECXPROF_ECXPWP S:ECXATP ECXATP=ECXPROF_ECXATP
217 S ECXDOM=$P($G(^ECX(727.831,+ECTS,0)),U,2)
218 S ECXINP=ECA_U_ECMN_U_ECTS_U_ECADM_U_ECWARD_U_ECDC_U_ECXPWP_U_ECXATP_U_ECXWW_U_ECXDOM_U_ECXPWPPC_U_ECXATPPC
219 Q ECXINP
220 ;
221VISN19(ECXDFN,ECXPAYOR,ECXSAI) ;visn 19 sharing agreement data
222 ; input ECXDFN = patient file ien
223 ; output ECXPAYOR, ECXSAI (passed by reference)
224 ;
225 N JJ,ALIAS,INSUR,DIC,DIQ,DA,DR,ECXARY,ECXERR,ECXDA
226 S (ECXPAYOR,ECXSAI)=""
227 D GETS^DIQ(2,ECXDFN,"1*,","I","ECXARY","ECXERR")
228 I $D(ECXERR) Q
229 S JJ=0 F S JJ=$O(ECXARY(2.01,JJ)) Q:JJ="" D I ECXPAYOR]"" Q
230 . S ALIAS=$G(ECXARY(2.01,JJ,.01,"I"))
231 . S ECXPAYOR=$S(ALIAS="SHARING AGREEMENT":"A",ALIAS="TRICARE":"B",ALIAS="CAT C":"C",ALIAS="CATEGORY C":"C",ALIAS="CHAMPVA":"D",ALIAS="CHAMPUS":"E",1:"")
232 . W !,$G(CNT)+1
233 . W !,"The value of ECXPAYOR is: ",ECXPAYOR
234 ;K ECXARY,ECXERR
235 I ECXPAYOR]"" D GETS^DIQ(2,ECXDFN,".3121*,","I","ECXARY","ECXERR") D
236 . W !,"This is a test"
237 . I $D(ECXERR) Q
238 . S JJ=0,ECXDA=$O(ECXARY(2.312,JJ)) I ECXDA="" Q
239 . S DA=$G(ECXARY(2.312,ECXDA,.01,"I")) I DA="" Q
240 . S INSUR=$$GET1^DIQ(36,DA,".01","I","","ECXERR")
241 . I '$D(ECXERR) S ECXSAI=$E(ECXARY(2.312,ECXDA,.01,"I"),1,11)
242 Q
Note: See TracBrowser for help on using the repository browser.