source: FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXRAD.m@ 922

ECXRAD ;ALB/JAP,BIR/PDW,PTD-Extract for Radiology ; 5/30/2007
 ;;3.0;DSS EXTRACTS;**11,8,13,16,24,33,39,46,71,84,92,105**;Dec 22, 1997;Build 70
BEG ;entry point from option
 D SETUP I ECFILE="" Q
 D ^ECXTRAC,^ECXKILL
 Q
 ;
START ;start rad extract
 S QFLG=0
 K ECXDD D FIELD^DID(70.03,14,,"SPECIFIER","ECXDD") S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
 S ECXDFN="",ECDT=ECSD-.1,ECED1=ECED+.3
 F  S ECDT=$O(^RADPT("AR",ECDT)) Q:ECDT>ECED1!(ECDT'>0)  D  Q:QFLG
 .S ECXDFN=""
 .F  S ECXDFN=$O(^RADPT("AR",ECDT,ECXDFN)) Q:ECXDFN=""  I '$D(^TMP("ECL",$J,ECXDFN)) D GET Q:QFLG
 K ^TMP("ECL",$J)
 Q
 ;
GET ;get data
 N ECXIEN,X,SUB,TYPE,ECDOCPC,ECXIS,ECXISPC,ECXPRCL,ECXCSC,ECXUSRTN
 S ^TMP("ECL",$J,ECXDFN)=""
 ;with dfn get all exams within date range
 S ECXMDT=ECSD-.1
 F  S ECXMDT=$O(^RADPT(ECXDFN,"DT","B",ECXMDT)) Q:((ECXMDT>ECED1)!(ECXMDT=""))  D  Q:QFLG
 .S ECXMDA=$O(^RADPT(ECXDFN,"DT","B",ECXMDT,"")) Q:ECXMDA=""
 .S ECXIEN=+$P($G(^RADPT(ECXDFN,"DT",ECXMDA,"P",1,0)),U,11)
 .S ECTM=$$ECXTIME^ECXUTL(ECXMDT) S:ECTM>235959 ECTM=235959
 .S ECXDAY=$$ECXDATE^ECXUTL(ECXMDT,ECXYM)
 .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXMDT,"."),"1;3",.ECXPAT)
 .Q:'OK
 .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
 .;get emergency response indicator (FEMA)
 .S ECXERI=ECXPAT("ERI")
 .S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXMDT,"."),ECPROF)
 .S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
 .S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
 .S X=$$INP^ECXUTL2(ECXDFN,ECXMDT),ECXA=$P(X,U),ECXMN=$P(X,U,2)
 .S ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4)
 .;
 .;- Observation patient indicator (YES/NO)
 .S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
 .;for dfn & date get exam(s) ien
 .S ECXMDA=""
 .F  S ECXMDA=$O(^RADPT(ECXDFN,"DT","B",ECXMDT,ECXMDA)) Q:+ECXMDA=0  D
 ..S ECXDIV=$P(^RADPT(ECXDFN,"DT",ECXMDA,0),U,3),ECLOC=$P(^(0),U,4),ECTY=$P(^(0),U,2)
 ..;
 ..;- Ordering stop code (based on imaging location)
 ..S ECXORDST=$$GET1^DIQ(40.7,$$GET1^DIQ(79.1,$G(ECLOC),22,"I"),1)
 ..;
 ..;- Get ordering date using Imaging Order ptr to #75.1 in subfile 70.03
 ..S ECXIEN=+$P($G(^RADPT(ECXDFN,"DT",ECXMDA,"P",1,0)),U,11)
 ..S ECXORDDT=$$ECXDATE^ECXUTL($P($G(^RAO(75.1,ECXIEN,0)),U,16),ECXYM)
 ..;
 ..;- If no encounter number don't file record
 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXMDT,ECXTS,ECXOBS,ECHEAD,ECTY,) Q:ECXENC=""
 ..;procedures and modifiers for specific exam (case numbers)
 ..;ward/clinic,service,provider,diagnostic code
 ..S ECCN=0
 ..F  S ECCN=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN)) Q:ECCN'>0  D
 ...S ECCA=^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,0)
 ...S ECXW=$P(ECCA,U,6),ECXW=$P($G(^DIC(42,+ECXW,44)),U)
 ...S:ECXW="" ECXW=$P(ECCA,U,8)
 ...S ECDOCNPI=$$NPI^XUSNPI("Individual_ID",$P(ECCA,U,14),ECDT)
 ...S:+ECDOCNPI'>0 ECDOCNPI="" S ECDOCNPI=$P(ECDOCNPI,U)
 ...S (ECXDSSD,ECXDSSP)=""
 ...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)
 ...S ECPRO=$P(ECCA,U,2),ECSTAT=$P($G(^RA(72,+$P(ECCA,U,3),0)),U,3)
 ...;get the primary interpreting staff and the person class DBIA #65
 ...S ECXIS=$P(ECCA,U,15),ECXISPC=$$PRVCLASS^ECXUTL(ECXIS,ECDT)
 ...S ECISNPI=$$NPI^XUSNPI("Individual_ID",ECXIS,ECDT)
 ...S:+ECISNPI'>0 ECISNPI="" S ECISNPI=$P(ECISNPI,U)
 ...;prefix interpreting radiologist with a "2" if not null
 ...S ECXIS=$S(ECXIS:"2"_ECXIS,1:"")
 ...;get the principal clinic ien DBIA #65
 ...S ECXPRCL=$P(ECCA,U,8)
 ...;get the clinic stop code from file #44
 ...S ECXCSC=$$GET1^DIQ(40.7,$$GET1^DIQ(44,ECXPRCL,8,"I"),1)
 ...Q:'ECPRO 
 ...Q:+ECSTAT=0
 ...;get CPT code & modifiers
 ...S ECPT=+$P($G(^RAMIS(71,+ECPRO,0)),U,9),ECXCMOD=""
 ...;quit if this is a 'parent' procedure
 ...S TYPE=$P($G(^RAMIS(71,+ECPRO,0)),U,6)
 ...Q:((ECPT=0)&(TYPE="P"))
 ...;if site is using radiology with cpt modifiers then get them
 ...K ARR,ERR D FIELD^DID(70.03,135,,"LABEL","ARR","ERR")
 ...I $D(ARR("LABEL")) D
 ....K ARR,ERR D FIELD^DID(70.03,135,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR")
 ....Q:$D(ERR("DIERR"))
 ....S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";") S ECMOD=0
 ....Q:'$D(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB))
 ....F  S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB,ECMOD)) Q:ECMOD'>0  S ECXCMOD=ECXCMOD_$P(^(ECMOD,0),U)_";"
 ...S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD)
 ...;get procedure radiology modifiers
 ...S ECMOD=0,ECMODS=""
 ...F  S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,"M",ECMOD)) Q:ECMOD'>0  S ECMODS=ECMODS_$P(^(ECMOD,0),U)_";"
 ...S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;p-46
 ...D FILE
 Q
 ;
FILE ;file record
 ;node0
 ;rad div^dfn^ssn^name^in/out (ECXA)^day^cpt code^procedure^img loc^ward^
 ;ser^diag code^req physician^modifiers^mov #^treat spec^time^
 ;imaging type^primary care team^primary care provider
 ;node1
 ;mpi^dss dept^placeholder^placeholder^pc prov person class^
 ;assoc pc provider^assoc pc prov person class^placeholder^dom^
 ;observ pat ind^encounter num^ord stop code^ord date^division^
 ;dss product ECXDSSP^requesting provider person class ECDOCPC^interp-
 ;reting radiologist ECXIS^interpreting radiologist pc ECXISPC^princi-
 ;pal clinic ECXPRCL^clinc stop code ECXCSC^emergency response indicator
 ;(FEMA) ECXERI^assoc pc provider npi^interpreting rad npi^pc provider npi^req physician npi
 N DA,DIK
 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
 S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
 S ECODE=ECODE_ECXDAY_U_ECXCPT_U_ECPRO_U_ECLOC_U_ECXW_U_ECS_U_ECDI_U
 S ECODE=ECODE_ECDOC_U_ECMODS_U_ECXMN_U_ECXTS_U_ECTM_U_ECTY_U_ECPTTM_U
 S ECODE=ECODE_ECPTPR_U
 S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_ECCLAS_U_ECASPR_U
 S ECODE1=ECODE1_ECCLAS2_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDST_U
 S ECODE1=ECODE1_ECXORDDT_U_ECXPDIV_U
 I ECXLOGIC>2004 S ECODE1=ECODE1_ECXDSSP_U_ECDOCPC
 I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXIS_U_ECXISPC_U_ECXPRCL_U_ECXCSC
 I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI
 I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECASNPI_U_ECISNPI_U_ECPTNPI_U_ECDOCNPI
 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
 Q
 ;
SETUP ;Set required input for ECXTRAC
 S ECHEAD="RAD"
 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
 Q