Changeset 623 for WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXRAD.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXRAD.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXRAD.m
r613 r623 1 ECXRAD ;ALB/JAP,BIR/PDW,PTD-Extract for Radiology ; 5/30/2007 2 ;;3.0;DSS EXTRACTS;**11,8,13,16,24,33,39,46,71,84,92,105**;Dec 22, 1997;Build 70 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ;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 ; 18 GET ;get data 19 N ECXIEN,X,SUB,TYPE,ECDOCPC,ECXIS,ECXISPC,ECXPRCL,ECXCSC,ECXUSRTN 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 ECDOCNPI=$$NPI^XUSNPI("Individual_ID",$P(ECCA,U,14),ECDT) 63 ...S:+ECDOCNPI'>0 ECDOCNPI="" S ECDOCNPI=$P(ECDOCNPI,U) 64 ...S (ECXDSSD,ECXDSSP)="" 65 ...S ECS=$P(ECCA,U,7),ECDOC=ECPROF_$P(ECCA,U,14),ECDI=$P(ECCA,U,13),ECDOCPC=$$PRVCLASS^ECXUTL($P(ECCA,U,14),ECDT) 66 ...S ECPRO=$P(ECCA,U,2),ECSTAT=$P($G(^RA(72,+$P(ECCA,U,3),0)),U,3) 67 ...;get the primary interpreting staff and the person class DBIA #65 68 ...S ECXIS=$P(ECCA,U,15),ECXISPC=$$PRVCLASS^ECXUTL(ECXIS,ECDT) 69 ...S ECISNPI=$$NPI^XUSNPI("Individual_ID",ECXIS,ECDT) 70 ...S:+ECISNPI'>0 ECISNPI="" S ECISNPI=$P(ECISNPI,U) 71 ...;prefix interpreting radiologist with a "2" if not null 72 ...S ECXIS=$S(ECXIS:"2"_ECXIS,1:"") 73 ...;get the principal clinic ien DBIA #65 74 ...S ECXPRCL=$P(ECCA,U,8) 75 ...;get the clinic stop code from file #44 76 ...S ECXCSC=$$GET1^DIQ(40.7,$$GET1^DIQ(44,ECXPRCL,8,"I"),1) 77 ...Q:'ECPRO 78 ...Q:+ECSTAT=0 79 ...;get CPT code & modifiers 80 ...S ECPT=+$P($G(^RAMIS(71,+ECPRO,0)),U,9),ECXCMOD="" 81 ...;quit if this is a 'parent' procedure 82 ...S TYPE=$P($G(^RAMIS(71,+ECPRO,0)),U,6) 83 ...Q:((ECPT=0)&(TYPE="P")) 84 ...;if site is using radiology with cpt modifiers then get them 85 ...K ARR,ERR D FIELD^DID(70.03,135,,"LABEL","ARR","ERR") 86 ...I $D(ARR("LABEL")) D 87 ....K ARR,ERR D FIELD^DID(70.03,135,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR") 88 ....Q:$D(ERR("DIERR")) 89 ....S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";") S ECMOD=0 90 ....Q:'$D(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB)) 91 ....F S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB,ECMOD)) Q:ECMOD'>0 S ECXCMOD=ECXCMOD_$P(^(ECMOD,0),U)_";" 92 ...S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD) 93 ...;get procedure radiology modifiers 94 ...S ECMOD=0,ECMODS="" 95 ...F S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,"M",ECMOD)) Q:ECMOD'>0 S ECMODS=ECMODS_$P(^(ECMOD,0),U)_";" 96 ...S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;p-46 97 ...D FILE 98 Q 99 ; 100 FILE ;file record 101 ;node0 102 ;rad div^dfn^ssn^name^in/out (ECXA)^day^cpt code^procedure^img loc^ward^ 103 ;ser^diag code^req physician^modifiers^mov #^treat spec^time^ 104 ;imaging type^primary care team^primary care provider 105 ;node1 106 ;mpi^dss dept^placeholder^placeholder^pc prov person class^ 107 ;assoc pc provider^assoc pc prov person class^placeholder^dom^ 108 ;observ pat ind^encounter num^ord stop code^ord date^division^ 109 ;dss product ECXDSSP^requesting provider person class ECDOCPC^interp- 110 ;reting radiologist ECXIS^interpreting radiologist pc ECXISPC^princi- 111 ;pal clinic ECXPRCL^clinc stop code ECXCSC^emergency response indicator 112 ;(FEMA) ECXERI^assoc pc provider npi^interpreting rad npi^pc provider npi^req physician npi 113 N DA,DIK 114 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 115 S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 116 S ECODE=ECODE_ECXDAY_U_ECXCPT_U_ECPRO_U_ECLOC_U_ECXW_U_ECS_U_ECDI_U 117 S ECODE=ECODE_ECDOC_U_ECMODS_U_ECXMN_U_ECXTS_U_ECTM_U_ECTY_U_ECPTTM_U 118 S ECODE=ECODE_ECPTPR_U 119 S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_ECCLAS_U_ECASPR_U 120 S ECODE1=ECODE1_ECCLAS2_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDST_U 121 S ECODE1=ECODE1_ECXORDDT_U_ECXPDIV_U 122 I ECXLOGIC>2004 S ECODE1=ECODE1_ECXDSSP_U_ECDOCPC 123 I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXIS_U_ECXISPC_U_ECXPRCL_U_ECXCSC 124 I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI 125 I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECASNPI_U_ECISNPI_U_ECPTNPI_U_ECDOCNPI 126 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 127 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 128 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 129 Q 130 ; 131 SETUP ;Set required input for ECXTRAC 132 S ECHEAD="RAD" 133 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 134 Q 1 ECXRAD ;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 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ;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 ; 18 GET ;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 ; 96 FILE ;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 ; 126 SETUP ;Set required input for ECXTRAC 127 S ECHEAD="RAD" 128 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 129 Q
Note:
See TracChangeset
for help on using the changeset viewer.
