source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXRAD.m@ 814

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

revised back to 6/30/08 version

File size: 5.8 KB
Line 
1ECXRAD ;ALB/JAP,BIR/PDW,PTD-Extract for Radiology ; 6/23/06 6:52am
2 ;;3.0;DSS EXTRACTS;**11,8,13,16,24,33,39,46,71,84,92**;Dec 22, 1997;Build 30
3BEG ;entry point from option
4 D SETUP I ECFILE="" Q
5 D ^ECXTRAC,^ECXKILL
6 Q
7 ;
8START ;start rad extract
9 S QFLG=0
10 K ECXDD D FIELD^DID(70.03,14,,"SPECIFIER","ECXDD") S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
11 S ECXDFN="",ECDT=ECSD-.1,ECED1=ECED+.3
12 F S ECDT=$O(^RADPT("AR",ECDT)) Q:ECDT>ECED1!(ECDT'>0) D Q:QFLG
13 .S ECXDFN=""
14 .F S ECXDFN=$O(^RADPT("AR",ECDT,ECXDFN)) Q:ECXDFN="" I '$D(^TMP("ECL",$J,ECXDFN)) D GET Q:QFLG
15 K ^TMP("ECL",$J)
16 Q
17 ;
18GET ;get data
19 N ECXIEN,X,SUB,TYPE,ECDOCPC,ECXIS,ECXISPC,ECXPRCL,ECXCSC
20 S ^TMP("ECL",$J,ECXDFN)=""
21 ;with dfn get all exams within date range
22 S ECXMDT=ECSD-.1
23 F S ECXMDT=$O(^RADPT(ECXDFN,"DT","B",ECXMDT)) Q:((ECXMDT>ECED1)!(ECXMDT="")) D Q:QFLG
24 .S ECXMDA=$O(^RADPT(ECXDFN,"DT","B",ECXMDT,"")) Q:ECXMDA=""
25 .S ECXIEN=+$P($G(^RADPT(ECXDFN,"DT",ECXMDA,"P",1,0)),U,11)
26 .S ECTM=$$ECXTIME^ECXUTL(ECXMDT) S:ECTM>235959 ECTM=235959
27 .S ECXDAY=$$ECXDATE^ECXUTL(ECXMDT,ECXYM)
28 .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXMDT,"."),"1;3",.ECXPAT)
29 .Q:'OK
30 .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
31 .;get emergency response indicator (FEMA)
32 .S ECXERI=ECXPAT("ERI")
33 .S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXMDT,"."),ECPROF)
34 .S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
35 .S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
36 .S X=$$INP^ECXUTL2(ECXDFN,ECXMDT),ECXA=$P(X,U),ECXMN=$P(X,U,2)
37 .S ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4)
38 .;
39 .;- Observation patient indicator (YES/NO)
40 .S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
41 .;for dfn & date get exam(s) ien
42 .S ECXMDA=""
43 .F S ECXMDA=$O(^RADPT(ECXDFN,"DT","B",ECXMDT,ECXMDA)) Q:+ECXMDA=0 D
44 ..S ECXDIV=$P(^RADPT(ECXDFN,"DT",ECXMDA,0),U,3),ECLOC=$P(^(0),U,4),ECTY=$P(^(0),U,2)
45 ..;
46 ..;- Ordering stop code (based on imaging location)
47 ..S ECXORDST=$$GET1^DIQ(40.7,$$GET1^DIQ(79.1,$G(ECLOC),22,"I"),1)
48 ..;
49 ..;- Get ordering date using Imaging Order ptr to #75.1 in subfile 70.03
50 ..S ECXIEN=+$P($G(^RADPT(ECXDFN,"DT",ECXMDA,"P",1,0)),U,11)
51 ..S ECXORDDT=$$ECXDATE^ECXUTL($P($G(^RAO(75.1,ECXIEN,0)),U,16),ECXYM)
52 ..;
53 ..;- If no encounter number don't file record
54 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXMDT,ECXTS,ECXOBS,ECHEAD,ECTY,) Q:ECXENC=""
55 ..;procedures and modifiers for specific exam (case numbers)
56 ..;ward/clinic,service,provider,diagnostic code
57 ..S ECCN=0
58 ..F S ECCN=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN)) Q:ECCN'>0 D
59 ...S ECCA=^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,0)
60 ...S ECXW=$P(ECCA,U,6),ECXW=$P($G(^DIC(42,+ECXW,44)),U)
61 ...S:ECXW="" ECXW=$P(ECCA,U,8)
62 ...S (ECXDSSD,ECXDSSP)=""
63 ...S ECS=$P(ECCA,U,7),ECDOC=ECPROF_$P(ECCA,U,14),ECDOCNPI="",ECDI=$P(ECCA,U,13),ECDOCPC=$$PRVCLASS^ECXUTL($P(ECCA,U,14),ECDT)
64 ...S ECPRO=$P(ECCA,U,2),ECSTAT=$P($G(^RA(72,+$P(ECCA,U,3),0)),U,3)
65 ...;get the primary interpreting staff and the person class DBIA #65
66 ...S ECXIS=$P(ECCA,U,15),ECXISPC=$$PRVCLASS^ECXUTL(ECXIS,ECDT)
67 ...;prefix interpreting radiologist with a "2" if not null
68 ...S ECXIS=$S(ECXIS:"2"_ECXIS,1:"")
69 ...;get the principal clinic ien DBIA #65
70 ...S ECXPRCL=$P(ECCA,U,8)
71 ...;get the clinic stop code from file #44
72 ...S ECXCSC=$$GET1^DIQ(40.7,$$GET1^DIQ(44,ECXPRCL,8,"I"),1)
73 ...Q:'ECPRO
74 ...Q:+ECSTAT=0
75 ...;get CPT code & modifiers
76 ...S ECPT=+$P($G(^RAMIS(71,+ECPRO,0)),U,9),ECXCMOD=""
77 ...;quit if this is a 'parent' procedure
78 ...S TYPE=$P($G(^RAMIS(71,+ECPRO,0)),U,6)
79 ...Q:((ECPT=0)&(TYPE="P"))
80 ...;if site is using radiology with cpt modifiers then get them
81 ...K ARR,ERR D FIELD^DID(70.03,135,,"LABEL","ARR","ERR")
82 ...I $D(ARR("LABEL")) D
83 ....K ARR,ERR D FIELD^DID(70.03,135,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR")
84 ....Q:$D(ERR("DIERR"))
85 ....S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";") S ECMOD=0
86 ....Q:'$D(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB))
87 ....F S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB,ECMOD)) Q:ECMOD'>0 S ECXCMOD=ECXCMOD_$P(^(ECMOD,0),U)_";"
88 ...S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD)
89 ...;get procedure radiology modifiers
90 ...S ECMOD=0,ECMODS=""
91 ...F S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,"M",ECMOD)) Q:ECMOD'>0 S ECMODS=ECMODS_$P(^(ECMOD,0),U)_";"
92 ...S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;p-46
93 ...D FILE
94 Q
95 ;
96FILE ;file record
97 ;node0
98 ;rad div^dfn^ssn^name^in/out (ECXA)^day^cpt code^procedure^img loc^ward^
99 ;ser^diag code^req physician^modifiers^mov #^treat spec^time^
100 ;imaging type^primary care team^primary care provider
101 ;node1
102 ;mpi^dss dept^req physician npi^pc provider npi^pc prov person class^
103 ;assoc pc provider^assoc pc prov person class^assoc pc prov npi^dom^
104 ;observ pat ind^encounter num^ord stop code^ord date^division^
105 ;dss product ECXDSSP^requesting provider person class ECDOCPC^interp-
106 ;reting radiologist ECXIS^interpreting radiologist pc ECXISPC^princi-
107 ;pal clinic ECXPRCL^clinc stop code ECXCSC^emergency response indicator
108 ;(FEMA) ECXERI
109 N DA,DIK
110 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
111 S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
112 S ECODE=ECODE_ECXDAY_U_ECXCPT_U_ECPRO_U_ECLOC_U_ECXW_U_ECS_U_ECDI_U
113 S ECODE=ECODE_ECDOC_U_ECMODS_U_ECXMN_U_ECXTS_U_ECTM_U_ECTY_U_ECPTTM_U
114 S ECODE=ECODE_ECPTPR_U
115 S ECODE1=ECXMPI_U_ECXDSSD_U_ECDOCNPI_U_ECPTNPI_U_ECCLAS_U_ECASPR_U
116 S ECODE1=ECODE1_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDST_U
117 S ECODE1=ECODE1_ECXORDDT_U_ECXPDIV_U
118 I ECXLOGIC>2004 S ECODE1=ECODE1_ECXDSSP_U_ECDOCPC
119 I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXIS_U_ECXISPC_U_ECXPRCL_U_ECXCSC
120 I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI
121 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
122 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
123 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
124 Q
125 ;
126SETUP ;Set required input for ECXTRAC
127 S ECHEAD="RAD"
128 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
129 Q
Note: See TracBrowser for help on using the repository browser.