ECXRAD ;ALB/JAP,BIR/PDW,PTD-Extract for Radiology ;2/6/19 12:54
;;3.0;DSS EXTRACTS;**11,8,13,16,24,33,39,46,71,84,92,105,120,127,136,144,149,153,154,161,166,170,174,184**;Dec 22, 1997;Build 124
;
; Reference to ^RAMIS in ICR #502
; Reference to ^RARPT in ICR #6041
;
BEG ;entry point from option
D SETUP I ECFILE="" Q
D ^ECXTRAC,^ECXKILL
Q
;
START ;start rad extract
N ECDT,ECINED,ECINSD,ECXDA,QFLG ;149,166
S QFLG=0
K ECXDD D FIELD^DID(70.03,14,,"SPECIFIER","ECXDD") S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
S ECDT=ECSD ;166
S ECINED=9999999.9999-ECDT,ECINSD=9999999-ECED ;149,166
F S ECINSD=$O(^RARPT("AA",ECINSD)) Q:ECINSD>ECINED!(ECINSD="") D Q:QFLG ;149
.S ECXDA="" F S ECXDA=$O(^RARPT("AA",ECINSD,ECXDA)) Q:ECXDA="" D GETCASE Q:QFLG ;149
Q
;
GETCASE ;Find all cases associated with the verified report and store in extract
;149 Section added in this patch
N CASE,ECXDFN,DATE,ECXMDA,ECXMDT,OCIEN,ECCN,TAB ;153
S CASE=$P($G(^RARPT(ECXDA,0)),U) Q:CASE=""
S TAB=$S($L(CASE,"-")=3:"ADC1",1:"ADC") ;153 Set xref table to use based on use of site accession numbering
S ECXDFN=$P($G(^RARPT(ECXDA,0)),U,2) Q:ECXDFN=""
I $D(^RADPT(TAB,CASE,ECXDFN)) D ;153
.S ECXMDA=$O(^RADPT(TAB,CASE,ECXDFN,0)) Q:'+ECXMDA ;153
.S ECCN=$O(^RADPT(TAB,CASE,ECXDFN,ECXMDA,0)) Q:'+ECCN ;153
.S ECXMDT=$P($G(^RADPT(ECXDFN,"DT",ECXMDA,0)),U) ;Exam date/time
.D GET
S OCIEN=0 F S OCIEN=$O(^RARPT(ECXDA,1,OCIEN)) Q:'+OCIEN D
.S CASE=$P($G(^RARPT(ECXDA,1,OCIEN,0)),U) Q:'+CASE
.S TAB=$S($L(CASE,"-")=3:"ADC1",1:"ADC") ;153 Set xref table to use based on use of site accession numbering
.I $D(^RADPT(TAB,CASE,ECXDFN)) D ;153
..S ECXMDA=$O(^RADPT(TAB,CASE,ECXDFN,0)) Q:'+ECXMDA ;153
..S ECCN=$O(^RADPT(TAB,CASE,ECXDFN,ECXMDA,0)) Q:'+ECCN ;153
..S ECXMDT=$P($G(^RADPT(ECXDFN,"DT",ECXMDA,0)),U) ;Exam date/time
..D GET
Q
;
GET ;get data
;149 All code in GET has been modified so that it's no longer at block structure level as that's no longer needed
N ECXIEN,X,SUB,TYPE,ECDOCPC,ECXIS,ECXISPC,ECXPRCL,ECXCSC,ECXUSRTN,ECXCM,ECSTAT,ECXMVDT ;136,154
N ECXESC,ECXECL,ECXCLST,VISIT,ECXVIST,ECXERR ;144
N ECXTEMPW,ECXTEMPD,ECXSTANO,ECXASIH ;166 tjl,170
N ECXCASE,ECXNMPI,ECXCERN,ECXPRCNM,ECXSIGI ;184
S ECXCERN="" ;184
S ECTM=$$ECXTIME^ECXUTL(ECXMDT) S:ECTM>235959 ECTM=235959
S ECXDAY=$$ECXDATE^ECXUTL(ECXMDT,ECXYM)
S ECXMVDT=$$ECXDATE^ECXUTL($P($G(^RARPT(ECXDA,0)),U,7),ECXYM) ;154 Get exam verification date and convert to YYYYMMDD format
K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXMDT,"."),"1;3;5",.ECXPAT) ;154 Added service information (5) to list
Q:'OK
S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),(ECXMPI,ECXNMPI)=ECXPAT("MPI") ;184 - Added ECXNMPI
S ECXSIGI=ECXPAT("SIGI") ;184
S ECXCLST=ECXPAT("CL STAT") ;144
;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),ECXASIH=$P(X,U,14) ;170
;
;- Observation patient indicator (YES/NO)
S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
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",ECCN,0)),U,11) ;149 Changed 1 to ECCN so that imaging location comes from actual exam, not only first exam
S ECXORDDT=$$ECXDATE^ECXUTL($P($G(^RAO(75.1,ECXIEN,0)),U,16),ECXYM)
;
;******* - PATCH 127, ADD PATCAT CODE ********
S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
;- 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 ECCA=^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,0)
S (ECXESC,ECXECL)="" ;144
S VISIT=$P(ECCA,U,27) ;144
I VISIT D VISIT^ECXSCX1(ECXDFN,VISIT,.ECXVIST,.ECXERR) I 'ECXERR S ECXESC=$G(ECXVIST("ENCSC")),ECXECL=$G(ECXVIST("ENCCL")) ;144
S ECXCM=$P(ECCA,U,26) S ECXCM=$S("^0^1^2^3^"[("^"_ECXCM_"^"):ECXCM,1:"") ;136 - Get Credit Method and validate that it's a number between 0 and 3 otherwise set it to null
I ECXCM=2 Q ;149 No longer collect records with credit method set to 2
S ECXW=$P(ECCA,U,6),ECXW=$P($G(^DIC(42,+ECXW,44)),U)
S:ECXW="" ECXW=$P(ECCA,U,8)
;166 tjl - Set Patient Division (ECXSTANO) field
N TEMPIEN S TEMPIEN=$$GET1^DIQ(44,+ECXW,3.5,"I")
S ECXSTANO=$$GETDIV^ECXDEPT(TEMPIEN) ; Set default (and outpatient) value based on ward
I ECXA="I",$D(^DGPM(ECXMN,0)) D ;Set value for inpatients based on Patient Movement record
. S ECXTEMPW=$P($G(^DGPM(ECXMN,0)),U,6)
. S ECXTEMPD=$P($G(^DIC(42,+ECXTEMPW,0)),U,11)
. S ECXSTANO=$$GETDIV^ECXDEPT(ECXTEMPD)
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 ECXCASE=$P(ECCA,U) ;184 - Case Number
S ECPRO=$P(ECCA,U,2),ECSTAT=$P($G(^RA(72,+$P(ECCA,U,3),0)),U,3)
S ECXPRCNM=$$GET1^DIQ(71,ECPRO,.01) ;184 Added Procedure Name, ICR#502
;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
I $G(ECXASIH) S ECXA="A" ;170
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^Placehold primary care team^Placehold primary care provider
;node1
;mpi^placeholder^placeholder^placeholder^Placehold pc prov person class^
;Placehold assoc pc provider^assoc pc prov person class^placeholder^dom^
;observ pat ind^encounter num^ord stop code^ord date^division^
;PLACEHOLD 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^Placehold assoc pc provider npi^interpreting rad npi^Placehold pc provider npi^req physician npi^Patient Category (PATCAT) ECXPATCAT^Credit Method ECXCM
;NODE2
;PLACEHOLD Encounter SC ECXESC^Camp Lejeune Status ECXCLST^PLACEHOLD Encounter Camp Lejeune ECXECL^Exam verification date ECXMVDT
;^Patient Division (ECXSTANO) ;166 tjl
;NODE3 ;184
;PLACEHOLD CERNER (ECXCERN)^
;NODE4 ;184
;Case number (CASE)^Procedure Name (ECXPRCNM)^New MPI (ECXNMPI)^Self Identified Gender (ECXSIGI)
;
;convert specialty to PTF Code for transmission
N ECXDATA,ECXTSC
S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA)
S ECXTSC=$G(ECXDATA(7))
;done
N DA,DIK
S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
I ECXLOGIC>2018 S (ECPTTM,ECPTPR,ECCLAS,ECASPR,ECCLAS2,ECASNPI,ECPTNPI)="" ;170 PCMM-related fields will be null
I ECXLOGIC>2022 S ECXMPI="" ;184 - field retired
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_ECXTSC_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
I ECXLOGIC>2010 S ECODE1=ECODE1_U_ECXPATCAT ;127 PATCAT
I ECXLOGIC>2012 S ECODE1=ECODE1_U_ECXCM_U ;136 Credit Method 144 End of node needs an ^
I ECXLOGIC>2013 S ECODE2=$S(ECXLOGIC>2019:"",1:ECXESC)_U_ECXCLST_U_$S(ECXLOGIC>2019:"",1:ECXECL) ;144/174 - TJL - Encounter Service Connected and Encounter Camp Lejeune null in FY20
I ECXLOGIC>2015 S ECODE2=ECODE2_U_ECXMVDT ;154 Add verification date
I ECXLOGIC>2017 S ECODE2=ECODE2_U_ECXSTANO_U ;166 tjl ,184 - Added "^"
I ECXLOGIC>2022 S ECODE3=$G(ECXCERN)_U,ECODE4=ECXCASE_U_ECXPRCNM_U_ECXNMPI_U_ECXSIGI ;184
S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2) ;144,184 - Move record count to below
S ^ECX(ECFILE,EC7,3)=$G(ECODE3),^ECX(ECFILE,EC7,4)=$G(ECODE4) ;184
S ECRN=ECRN+1 ;184 - Move record count from above
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXRAD 10336 printed Apr 09, 2024@20:56:20 Page 2
ECXRAD ;ALB/JAP,BIR/PDW,PTD-Extract for Radiology ;2/6/19 12:54
+1 ;;3.0;DSS EXTRACTS;**11,8,13,16,24,33,39,46,71,84,92,105,120,127,136,144,149,153,154,161,166,170,174,184**;Dec 22, 1997;Build 124
+2 ;
+3 ; Reference to ^RAMIS in ICR #502
+4 ; Reference to ^RARPT in ICR #6041
+5 ;
BEG ;entry point from option
+1 DO SETUP
IF ECFILE=""
QUIT
+2 DO ^ECXTRAC
DO ^ECXKILL
+3 QUIT
+4 ;
START ;start rad extract
+1 ;149,166
NEW ECDT,ECINED,ECINSD,ECXDA,QFLG
+2 SET QFLG=0
+3 KILL ECXDD
DO FIELD^DID(70.03,14,,"SPECIFIER","ECXDD")
SET ECPROF=$EXTRACT(+$PIECE(ECXDD("SPECIFIER"),"P",2))
KILL ECXDD
+4 ;166
SET ECDT=ECSD
+5 ;149,166
SET ECINED=9999999.9999-ECDT
SET ECINSD=9999999-ECED
+6 ;149
FOR
SET ECINSD=$ORDER(^RARPT("AA",ECINSD))
if ECINSD>ECINED!(ECINSD="")
QUIT
Begin DoDot:1
+7 ;149
SET ECXDA=""
FOR
SET ECXDA=$ORDER(^RARPT("AA",ECINSD,ECXDA))
if ECXDA=""
QUIT
DO GETCASE
if QFLG
QUIT
End DoDot:1
if QFLG
QUIT
+8 QUIT
+9 ;
GETCASE ;Find all cases associated with the verified report and store in extract
+1 ;149 Section added in this patch
+2 ;153
NEW CASE,ECXDFN,DATE,ECXMDA,ECXMDT,OCIEN,ECCN,TAB
+3 SET CASE=$PIECE($GET(^RARPT(ECXDA,0)),U)
if CASE=""
QUIT
+4 ;153 Set xref table to use based on use of site accession numbering
SET TAB=$SELECT($LENGTH(CASE,"-")=3:"ADC1",1:"ADC")
+5 SET ECXDFN=$PIECE($GET(^RARPT(ECXDA,0)),U,2)
if ECXDFN=""
QUIT
+6 ;153
IF $DATA(^RADPT(TAB,CASE,ECXDFN))
Begin DoDot:1
+7 ;153
SET ECXMDA=$ORDER(^RADPT(TAB,CASE,ECXDFN,0))
if '+ECXMDA
QUIT
+8 ;153
SET ECCN=$ORDER(^RADPT(TAB,CASE,ECXDFN,ECXMDA,0))
if '+ECCN
QUIT
+9 ;Exam date/time
SET ECXMDT=$PIECE($GET(^RADPT(ECXDFN,"DT",ECXMDA,0)),U)
+10 DO GET
End DoDot:1
+11 SET OCIEN=0
FOR
SET OCIEN=$ORDER(^RARPT(ECXDA,1,OCIEN))
if '+OCIEN
QUIT
Begin DoDot:1
+12 SET CASE=$PIECE($GET(^RARPT(ECXDA,1,OCIEN,0)),U)
if '+CASE
QUIT
+13 ;153 Set xref table to use based on use of site accession numbering
SET TAB=$SELECT($LENGTH(CASE,"-")=3:"ADC1",1:"ADC")
+14 ;153
IF $DATA(^RADPT(TAB,CASE,ECXDFN))
Begin DoDot:2
+15 ;153
SET ECXMDA=$ORDER(^RADPT(TAB,CASE,ECXDFN,0))
if '+ECXMDA
QUIT
+16 ;153
SET ECCN=$ORDER(^RADPT(TAB,CASE,ECXDFN,ECXMDA,0))
if '+ECCN
QUIT
+17 ;Exam date/time
SET ECXMDT=$PIECE($GET(^RADPT(ECXDFN,"DT",ECXMDA,0)),U)
+18 DO GET
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
GET ;get data
+1 ;149 All code in GET has been modified so that it's no longer at block structure level as that's no longer needed
+2 ;136,154
NEW ECXIEN,X,SUB,TYPE,ECDOCPC,ECXIS,ECXISPC,ECXPRCL,ECXCSC,ECXUSRTN,ECXCM,ECSTAT,ECXMVDT
+3 ;144
NEW ECXESC,ECXECL,ECXCLST,VISIT,ECXVIST,ECXERR
+4 ;166 tjl,170
NEW ECXTEMPW,ECXTEMPD,ECXSTANO,ECXASIH
+5 ;184
NEW ECXCASE,ECXNMPI,ECXCERN,ECXPRCNM,ECXSIGI
+6 ;184
SET ECXCERN=""
+7 SET ECTM=$$ECXTIME^ECXUTL(ECXMDT)
if ECTM>235959
SET ECTM=235959
+8 SET ECXDAY=$$ECXDATE^ECXUTL(ECXMDT,ECXYM)
+9 ;154 Get exam verification date and convert to YYYYMMDD format
SET ECXMVDT=$$ECXDATE^ECXUTL($PIECE($GET(^RARPT(ECXDA,0)),U,7),ECXYM)
+10 ;154 Added service information (5) to list
KILL ECXPAT
SET OK=$$PAT^ECXUTL3(ECXDFN,$PIECE(ECXMDT,"."),"1;3;5",.ECXPAT)
+11 if 'OK
QUIT
+12 ;184 - Added ECXNMPI
SET ECXPNM=ECXPAT("NAME")
SET ECXSSN=ECXPAT("SSN")
SET (ECXMPI,ECXNMPI)=ECXPAT("MPI")
+13 ;184
SET ECXSIGI=ECXPAT("SIGI")
+14 ;144
SET ECXCLST=ECXPAT("CL STAT")
+15 ;get emergency response indicator (FEMA)
+16 SET ECXERI=ECXPAT("ERI")
+17 SET X=$$PRIMARY^ECXUTL2(ECXDFN,$PIECE(ECXMDT,"."),ECPROF)
+18 SET ECPTTM=$PIECE(X,U,1)
SET ECPTPR=$PIECE(X,U,2)
SET ECCLAS=$PIECE(X,U,3)
SET ECPTNPI=$PIECE(X,U,4)
+19 SET ECASPR=$PIECE(X,U,5)
SET ECCLAS2=$PIECE(X,U,6)
SET ECASNPI=$PIECE(X,U,7)
+20 SET X=$$INP^ECXUTL2(ECXDFN,ECXMDT)
SET ECXA=$PIECE(X,U)
SET ECXMN=$PIECE(X,U,2)
+21 ;170
SET ECXTS=$PIECE(X,U,3)
SET ECXDOM=$PIECE(X,U,10)
SET ECXADMDT=$PIECE(X,U,4)
SET ECXASIH=$PIECE(X,U,14)
+22 ;
+23 ;- Observation patient indicator (YES/NO)
+24 SET ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+25 SET ECXDIV=$PIECE(^RADPT(ECXDFN,"DT",ECXMDA,0),U,3)
SET ECLOC=$PIECE(^(0),U,4)
SET ECTY=$PIECE(^(0),U,2)
+26 ;
+27 ;- Ordering stop code (based on imaging location)
+28 SET ECXORDST=$$GET1^DIQ(40.7,$$GET1^DIQ(79.1,$GET(ECLOC),22,"I"),1)
+29 ;
+30 ;- Get ordering date using Imaging Order ptr to #75.1 in subfile 70.03
+31 ;149 Changed 1 to ECCN so that imaging location comes from actual exam, not only first exam
SET ECXIEN=+$PIECE($GET(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,0)),U,11)
+32 SET ECXORDDT=$$ECXDATE^ECXUTL($PIECE($GET(^RAO(75.1,ECXIEN,0)),U,16),ECXYM)
+33 ;
+34 ;******* - PATCH 127, ADD PATCAT CODE ********
+35 SET ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
+36 ;- If no encounter number don't file record
+37 SET ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXMDT,ECXTS,ECXOBS,ECHEAD,ECTY,)
if ECXENC=""
QUIT
+38 ;procedures and modifiers for specific exam (case numbers)
+39 ;ward/clinic,service,provider,diagnostic code
+40 SET ECCA=^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,0)
+41 ;144
SET (ECXESC,ECXECL)=""
+42 ;144
SET VISIT=$PIECE(ECCA,U,27)
+43 ;144
IF VISIT
DO VISIT^ECXSCX1(ECXDFN,VISIT,.ECXVIST,.ECXERR)
IF 'ECXERR
SET ECXESC=$GET(ECXVIST("ENCSC"))
SET ECXECL=$GET(ECXVIST("ENCCL"))
+44 ;136 - Get Credit Method and validate that it's a number between 0 and 3 otherwise set it to null
SET ECXCM=$PIECE(ECCA,U,26)
SET ECXCM=$SELECT("^0^1^2^3^"[("^"_ECXCM_"^"):ECXCM,1:"")
+45 ;149 No longer collect records with credit method set to 2
IF ECXCM=2
QUIT
+46 SET ECXW=$PIECE(ECCA,U,6)
SET ECXW=$PIECE($GET(^DIC(42,+ECXW,44)),U)
+47 if ECXW=""
SET ECXW=$PIECE(ECCA,U,8)
+48 ;166 tjl - Set Patient Division (ECXSTANO) field
+49 NEW TEMPIEN
SET TEMPIEN=$$GET1^DIQ(44,+ECXW,3.5,"I")
+50 ; Set default (and outpatient) value based on ward
SET ECXSTANO=$$GETDIV^ECXDEPT(TEMPIEN)
+51 ;Set value for inpatients based on Patient Movement record
IF ECXA="I"
IF $DATA(^DGPM(ECXMN,0))
Begin DoDot:1
+52 SET ECXTEMPW=$PIECE($GET(^DGPM(ECXMN,0)),U,6)
+53 SET ECXTEMPD=$PIECE($GET(^DIC(42,+ECXTEMPW,0)),U,11)
+54 SET ECXSTANO=$$GETDIV^ECXDEPT(ECXTEMPD)
End DoDot:1
+55 SET ECDOCNPI=$$NPI^XUSNPI("Individual_ID",$PIECE(ECCA,U,14),ECDT)
+56 if +ECDOCNPI'>0
SET ECDOCNPI=""
SET ECDOCNPI=$PIECE(ECDOCNPI,U)
+57 SET (ECXDSSD,ECXDSSP)=""
+58 SET ECS=$PIECE(ECCA,U,7)
SET ECDOC=ECPROF_$PIECE(ECCA,U,14)
SET ECDI=$PIECE(ECCA,U,13)
SET ECDOCPC=$$PRVCLASS^ECXUTL($PIECE(ECCA,U,14),ECDT)
+59 ;184 - Case Number
SET ECXCASE=$PIECE(ECCA,U)
+60 SET ECPRO=$PIECE(ECCA,U,2)
SET ECSTAT=$PIECE($GET(^RA(72,+$PIECE(ECCA,U,3),0)),U,3)
+61 ;184 Added Procedure Name, ICR#502
SET ECXPRCNM=$$GET1^DIQ(71,ECPRO,.01)
+62 ;get the primary interpreting staff and the person class DBIA #65
+63 SET ECXIS=$PIECE(ECCA,U,15)
SET ECXISPC=$$PRVCLASS^ECXUTL(ECXIS,ECDT)
+64 SET ECISNPI=$$NPI^XUSNPI("Individual_ID",ECXIS,ECDT)
+65 if +ECISNPI'>0
SET ECISNPI=""
SET ECISNPI=$PIECE(ECISNPI,U)
+66 ;prefix interpreting radiologist with a "2" if not null
+67 SET ECXIS=$SELECT(ECXIS:"2"_ECXIS,1:"")
+68 ;get the principal clinic ien DBIA #65
+69 SET ECXPRCL=$PIECE(ECCA,U,8)
+70 ;get the clinic stop code from file #44
+71 SET ECXCSC=$$GET1^DIQ(40.7,$$GET1^DIQ(44,ECXPRCL,8,"I"),1)
+72 if 'ECPRO
QUIT
+73 if +ECSTAT=0
QUIT
+74 ;get CPT code & modifiers
+75 SET ECPT=+$PIECE($GET(^RAMIS(71,+ECPRO,0)),U,9)
SET ECXCMOD=""
+76 ;quit if this is a 'parent' procedure
+77 SET TYPE=$PIECE($GET(^RAMIS(71,+ECPRO,0)),U,6)
+78 if ((ECPT=0)&(TYPE="P"))
QUIT
+79 ;if site is using radiology with cpt modifiers then get them
+80 KILL ARR,ERR
DO FIELD^DID(70.03,135,,"LABEL","ARR","ERR")
+81 IF $DATA(ARR("LABEL"))
Begin DoDot:1
+82 KILL ARR,ERR
DO FIELD^DID(70.03,135,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR")
+83 if $DATA(ERR("DIERR"))
QUIT
+84 SET SUB=$PIECE(ARR("GLOBAL SUBSCRIPT LOCATION"),";")
SET ECMOD=0
+85 if '$DATA(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB))
QUIT
+86 FOR
SET ECMOD=$ORDER(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB,ECMOD))
if ECMOD'>0
QUIT
SET ECXCMOD=ECXCMOD_$PIECE(^(ECMOD,0),U)_";"
End DoDot:1
+87 SET ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD)
+88 ;get procedure radiology modifiers
+89 SET ECMOD=0
SET ECMODS=""
+90 FOR
SET ECMOD=$ORDER(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,"M",ECMOD))
if ECMOD'>0
QUIT
SET ECMODS=ECMODS_$PIECE(^(ECMOD,0),U)_";"
+91 ;p-46
SET ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV)
+92 ;170
IF $GET(ECXASIH)
SET ECXA="A"
+93 DO FILE
+94 QUIT
+95 ;
FILE ;file record
+1 ;node0
+2 ;rad div^dfn^ssn^name^in/out (ECXA)^day^cpt code^procedure^img loc^ward^
+3 ;ser^diag code^req physician^modifiers^mov #^treat spec^time^
+4 ;imaging type^Placehold primary care team^Placehold primary care provider
+5 ;node1
+6 ;mpi^placeholder^placeholder^placeholder^Placehold pc prov person class^
+7 ;Placehold assoc pc provider^assoc pc prov person class^placeholder^dom^
+8 ;observ pat ind^encounter num^ord stop code^ord date^division^
+9 ;PLACEHOLD dss product ECXDSSP^requesting provider person class ECDOCPC^interp-
+10 ;reting radiologist ECXIS^interpreting radiologist pc ECXISPC^princi-
+11 ;pal clinic ECXPRCL^clinc stop code ECXCSC^emergency response indicator
+12 ;(FEMA) ECXERI^Placehold assoc pc provider npi^interpreting rad npi^Placehold pc provider npi^req physician npi^Patient Category (PATCAT) ECXPATCAT^Credit Method ECXCM
+13 ;NODE2
+14 ;PLACEHOLD Encounter SC ECXESC^Camp Lejeune Status ECXCLST^PLACEHOLD Encounter Camp Lejeune ECXECL^Exam verification date ECXMVDT
+15 ;^Patient Division (ECXSTANO) ;166 tjl
+16 ;NODE3 ;184
+17 ;PLACEHOLD CERNER (ECXCERN)^
+18 ;NODE4 ;184
+19 ;Case number (CASE)^Procedure Name (ECXPRCNM)^New MPI (ECXNMPI)^Self Identified Gender (ECXSIGI)
+20 ;
+21 ;convert specialty to PTF Code for transmission
+22 NEW ECXDATA,ECXTSC
+23 SET ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA)
+24 SET ECXTSC=$GET(ECXDATA(7))
+25 ;done
+26 NEW DA,DIK
+27 SET EC7=$ORDER(^ECX(ECFILE,999999999),-1)
SET EC7=EC7+1
+28 ;170 PCMM-related fields will be null
IF ECXLOGIC>2018
SET (ECPTTM,ECPTPR,ECCLAS,ECASPR,ECCLAS2,ECASNPI,ECPTNPI)=""
+29 ;184 - field retired
IF ECXLOGIC>2022
SET ECXMPI=""
+30 SET ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+31 SET ECODE=ECODE_ECXDAY_U_ECXCPT_U_ECPRO_U_ECLOC_U_ECXW_U_ECS_U_ECDI_U
+32 SET ECODE=ECODE_ECDOC_U_ECMODS_U_ECXMN_U_ECXTSC_U_ECTM_U_ECTY_U_ECPTTM_U
+33 SET ECODE=ECODE_ECPTPR_U
+34 SET ECODE1=ECXMPI_U_ECXDSSD_U_U_U_ECCLAS_U_ECASPR_U
+35 SET ECODE1=ECODE1_ECCLAS2_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDST_U
+36 SET ECODE1=ECODE1_ECXORDDT_U_ECXPDIV_U
+37 IF ECXLOGIC>2004
SET ECODE1=ECODE1_ECXDSSP_U_ECDOCPC
+38 IF ECXLOGIC>2005
SET ECODE1=ECODE1_U_ECXIS_U_ECXISPC_U_ECXPRCL_U_ECXCSC
+39 IF ECXLOGIC>2006
SET ECODE1=ECODE1_U_ECXERI
+40 IF ECXLOGIC>2007
SET ECODE1=ECODE1_U_ECASNPI_U_ECISNPI_U_ECPTNPI_U_ECDOCNPI
+41 ;127 PATCAT
IF ECXLOGIC>2010
SET ECODE1=ECODE1_U_ECXPATCAT
+42 ;136 Credit Method 144 End of node needs an ^
IF ECXLOGIC>2012
SET ECODE1=ECODE1_U_ECXCM_U
+43 ;144/174 - TJL - Encounter Service Connected and Encounter Camp Lejeune null in FY20
IF ECXLOGIC>2013
SET ECODE2=$SELECT(ECXLOGIC>2019:"",1:ECXESC)_U_ECXCLST_U_$SELECT(ECXLOGIC>2019:"",1:ECXECL)
+44 ;154 Add verification date
IF ECXLOGIC>2015
SET ECODE2=ECODE2_U_ECXMVDT
+45 ;166 tjl ,184 - Added "^"
IF ECXLOGIC>2017
SET ECODE2=ECODE2_U_ECXSTANO_U
+46 ;184
IF ECXLOGIC>2022
SET ECODE3=$GET(ECXCERN)_U
SET ECODE4=ECXCASE_U_ECXPRCNM_U_ECXNMPI_U_ECXSIGI
+47 ;144,184 - Move record count to below
SET ^ECX(ECFILE,EC7,0)=ECODE
SET ^ECX(ECFILE,EC7,1)=ECODE1
SET ^ECX(ECFILE,EC7,2)=$GET(ECODE2)
+48 ;184
SET ^ECX(ECFILE,EC7,3)=$GET(ECODE3)
SET ^ECX(ECFILE,EC7,4)=$GET(ECODE4)
+49 ;184 - Move record count from above
SET ECRN=ECRN+1
+50 SET DA=EC7
SET DIK="^ECX("_ECFILE_","
DO IX1^DIK
KILL DIK,DA
+51 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET QFLG=1
+52 QUIT
+53 ;
SETUP ;Set required input for ECXTRAC
+1 SET ECHEAD="RAD"
+2 DO ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+3 QUIT
