ECXEC ;ALB/JAP,BIR/JLP,PTD-DSS Event Capture Extract ;5/31/19 11:28
;;3.0;DSS EXTRACTS;**11,8,13,24,27,33,39,46,49,71,89,92,105,120,127,132,136,144,149,154,161,166,170,173,174,181,184**;Dec 22, 1997;Build 124
;
; Reference to DEM^VADPT in ICR #10061
; Reference to ^TMP($J) in SACC 2.3.2.5.1
;
BEG ;entry point from option
I '$D(^ECH) W !,"Event Capture is not initialized",!! Q
D SETUP I ECFILE="" Q
D ^ECXTRAC,^ECXKILL
Q
START ;begin EC extract
N X,Y,ECDCM,ECXNPRFI,ECXVIET,ECX4CHAR ; 144 national 4char code
N ECXICD10P,ECXICD101,ECXICD102,ECXICD103,ECXICD104,LATE,EFY ;166,170
S EFY=$$FISCAL^ECXUTL1(ECED) ;170 Determine extract fiscal year based on ending date of extract
S ECED=ECED+.3,ECLL=0
K ^TMP("EC",$J)
K ^TMP($J,"ECXECM") ;181
F S ECLL=$O(^ECH("AC1",ECLL)),ECD=ECSD-.1 Q:'ECLL D
.F S ECD=$O(^ECH("AC1",ECLL,ECD)),ECDA=0 Q:(ECD>ECED)!('ECD) D
..F S ECDA=$O(^ECH("AC1",ECLL,ECD,ECDA)) Q:'ECDA D UPDATE
;166 Done processing by date, now find any "late" state home records
S ECDA=0,LATE=1 F S ECDA=$O(^XTMP("ECEFPAT",ECDA)) Q:'+ECDA D
.I $G(^XTMP("ECEFPAT",ECDA))=1 Q ;Record already counted in "regular" process
.I '$D(^ECH(ECDA,0)) Q ;Record in table but not in file
.I $P($G(^ECH(ECDA,0)),U,3)>ECED Q ;Record has a procedure date/time after end date of extract so we'll skip it
.I $$FISCAL^ECXUTL1($P($G(^ECH(ECDA,0)),U,3))<EFY S ^XTMP("ECEFPAT",ECDA)=3 Q ;170 If the fiscal year associated with the procedure date is from a previous fiscal year, skip and set for deletion
.D UPDATE ;process record
D CLEAN ;166 extract completed, clear out ^XTMP records
I $D(^TMP($J,"ECXECM")) D EN^ECXEC1 ;181 - Send messages for records with NO DSS Units
Q
;
UPDATE ;sets record and updates counters
N ECXESC,ECXECL,ECXCLST,ECXRES1,ECXRES2,ECXRES3,ECPNM,ECDSSE,ROOT ;149,154
N ECXTEMPW,ECXTEMPD,ECXSTANO,ECXASIH,ECXSVH ;166,170,174
N ECXCERN,ECXNMPI,ECXSIGI ;184
S (ECXESC,ECXECL,ECXCLST,ECXRES1,ECXRES2,ECXRES3,ECXCERN)="" ;144;184 - Added ECXCERN
S ECCH=^ECH(ECDA,0),ECL=$P(ECCH,U,4),ECXDFN=$P(ECCH,U,2)
S ECXPDIV=$$RADDIV^ECXDEPT(ECL) ;Get production division from file 4
S ECDT=$P(ECCH,U,3),ECM=$P(ECCH,U,6),ECC=$P(ECCH,U,8)
S ECTM=$$ECXTIME^ECXUTL(ECDT),ECP=$P(ECCH,U,9) ;154 Moved line to be in front of call to ECXUTL2
I $P(ECP,";",2)[725 S ECPNM=$$GET1^DIQ(725,+ECP,1) ;154 Get procedure name
Q:'$$PATDEM^ECXUTL2(ECXDFN,ECDT,"1;3;5;")
Q:ECP']""
D:ECP[";" ;181 - Moved these lines from below to be in front of calling SETTMP
.S ECP=$S(ECP["ICPT":$P(^ICPT(+ECP,0),U)_"01",ECP<90000:$P(^EC(725,+ECP,0),U,2)_"N",1:$P(^EC(725,+ECP,0),U,2)_"L"),ECC=$S(ECC:ECC,1:"")
S ECXSTANO=ECXPDIV ;166 tjl - Set default Patient Division
I ECXA="I",$D(^DGPM(ECXMN,0)) D ;166 tjl - Set Patient Division 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 ECO=$P(ECCH,U,12),ECV=$P(ECCH,U,10),ECDU=$P(ECCH,U,7)
I ECDU="" D SETTMP Q ;181 - if DSS Unit is missing set global for mail message
S ECXUNIT=$G(^ECD(ECDU,0)),ECCS=+$P(ECXUNIT,U,4),ECDCM=$P(ECXUNIT,U,5)
S ECXDSSP="",ECXDSSD=$E(ECDCM,1,10),ECUSTOP=$P(ECXUNIT,U,10),ECUPCE=$P(ECXUNIT,U,14)
S ICD9=$P($G(^ECH(ECDA,"P")),U,2) ;154
S (ECXICD9,ECXICD10P,ECX4CHAR)="" I ICD9'="" S ECXICD10P=$$CODEC^ICDEX(80,ICD9) ;144,154,161
F I=1:1:4 S @("ECXICD9"_I)=""
F I=1:1:4 S @("ECXICD10"_I)=""
S (CNT,I)=0
F S CNT=$O(^ECH(ECDA,"DX",CNT)) Q:'CNT D Q:I>3
.S ICD9=$P($G(^ECH(ECDA,"DX",CNT,0)),U) D:ICD9'=""
..S I=I+1,@("ECXICD10"_I)=$$CODEC^ICDEX(80,ICD9) ;154,161
;derivation of dss identifier depends on whether dss unit is
;set to send data to pce
S ECAC=$P($G(ECCH),U,19) S:ECAC=0 ECAC="" ;144 Change value to null if value from event capture patient file is 0
S ECX4CHAR=$$RJ^XLFSTR($$GET1^DIQ(728.44,+ECAC,7,"E"),4,0) ; 144,154 use the assoc clinic to get 4char code, default to 0000 if non-existent
;if this is a record that 'goes to pce', then get the dss identifier
;from the clinic stop codes
S (ECAC1S,ECAC2S)="000"
I ECUPCE="A"!(ECUPCE="O"&(ECXA="O"))!(ECUPCE="OOS") D ;173 Add "OOS" units
.D:+ECAC
..S ECAC1=$P($G(^SC(+ECAC,0)),U,7),ECAC2=$P($G(^(0)),U,18)
..I 'ECAC2 S ECAC2S="000"
..I 'ECAC1 S (ECAC1S,ECAC2S)="000" Q
..S ECAC1S=$P($G(^DIC(40.7,+ECAC1,0)),U,2)
..S ECAC2S=$P($G(^DIC(40.7,+ECAC2,0)),U,2)
..S ECAC1S=$$RJ^XLFSTR(ECAC1S,3,0),ECAC2S=$$RJ^XLFSTR(ECAC2S,3,0)
.S:'ECAC (ECAC1S,ECAC2S)="000"
;if this record doesn't go to pce, then get the dss identifier
;from the dss unit
I ECUPCE=""!(ECUPCE="N")!(ECUPCE="O"&(ECXA="I")) D
.S ECAC1S=$$RJ^XLFSTR($P($G(^DIC(40.7,+ECUSTOP,0)),U,2),3,0) ;154
.S ECAC2S=$$RJ^XLFSTR($P($G(^DIC(40.7,+$P(ECXUNIT,U,13),0)),U,2),3,0) ;154
.S ECX4CHAR=$$RJ^XLFSTR($$GET1^DIQ(728.441,+$P(ECXUNIT,U,15),.01,"E"),4,0) ;154
S ECDSS=ECAC1S_ECAC2S
I ECXLOGIC>2003 I "^18^23^24^41^65^94^108^"[("^"_ECXTS_"^") S ECDSS=$$TSMAP^ECXUTL4(ECXTS)
S ECXDIV=""
;
;- Ord Div, Contrct St/End Dates, Contrct Type placeholders for FY2002
S (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)=""
;setup provider(s) as'2'_ien
S (ECU1A,ECU2A,ECU3A,ECU1NPI,ECU2NPI,ECU3NPI,ECXPPC1,ECXPPC2,ECXPPC3,ECU1,ECU2,ECU3,ECU4,ECU5,ECU6,ECU7)="" ;144 CVW
S (ECU4A,ECU5A,ECU6A,ECU7A,ECU4NPI,ECU5NPI,ECU6NPI,ECU7NPI,ECXPPC4,ECXPPC5,ECXPPC6,ECXPPC7)="" ;144
K ECXPRV S ECXPROV=$$GETPRV^ECPRVMUT(ECDA,.ECXPRV) I ECXPROV Q
F I=1:1:7 S Y=$O(ECXPRV("")) I Y'="" S @("ECU"_I)=+ECXPRV(Y) K ECXPRV(Y)
S:$L(ECU1) ECXPPC1=$$PRVCLASS^ECXUTL(ECU1,ECDT),ECU1A="2"_$P(ECU1,";")
S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU1,ECDT)
S:+ECXUSRTN'>0 ECXUSRTN="" S ECU1NPI=$P(ECXUSRTN,U)
S:$L(ECU2) ECXPPC2=$$PRVCLASS^ECXUTL(ECU2,ECDT),ECU2A="2"_$P(ECU2,";")
S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU2,ECDT)
S:+ECXUSRTN'>0 ECXUSRTN="" S ECU2NPI=$P(ECXUSRTN,U)
S:$L(ECU3) ECXPPC3=$$PRVCLASS^ECXUTL(ECU3,ECDT),ECU3A="2"_$P(ECU3,";")
S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU3,ECDT)
S:+ECXUSRTN'>0 ECXUSRTN="" S ECU3NPI=$P(ECXUSRTN,U)
S:$L(ECU4) ECXPPC4=$$PRVCLASS^ECXUTL(ECU4,ECDT),ECU4A="2"_$P(ECU4,";")
S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU4,ECDT)
S:+ECXUSRTN'>0 ECXUSRTN="" S ECU4NPI=$P(ECXUSRTN,U)
S:$L(ECU5) ECXPPC5=$$PRVCLASS^ECXUTL(ECU5,ECDT),ECU5A="2"_$P(ECU5,";")
S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU5,ECDT)
S:+ECXUSRTN'>0 ECXUSRTN="" S ECU5NPI=$P(ECXUSRTN,U)
;144 add 2 more providers, prov per class, prov npi cvw
S:$L(ECU6) ECXPPC6=$$PRVCLASS^ECXUTL(ECU6,ECDT),ECU6A="2"_$P(ECU6,";")
S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU6,ECDT)
S:+ECXUSRTN'>0 ECXUSRTN="" S ECU6NPI=$P(ECXUSRTN,U)
S:$L(ECU7) ECXPPC7=$$PRVCLASS^ECXUTL(ECU7,ECDT),ECU7A="2"_$P(ECU7,";")
S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU7,ECDT)
S:+ECXUSRTN'>0 ECXUSRTN="" S ECU7NPI=$P(ECXUSRTN,U)
;change for version 2 where ECP is a variable pointer and we want to
;expand it category = category or null if stored as 0
;D:ECP[";" ;181 - Moved to begin of UPDATE
;.S ECP=$S(ECP["ICPT":$P(^ICPT(+ECP,0),U)_"01",ECP<90000:$P(^EC(725,+ECP,0),U,2)_"N",1:$P(^EC(725,+ECP,0),U,2)_"L"),ECC=$S(ECC:ECC,1:"")
;pick up EC to PCE data from "P" in File 721
S ECPCE=$G(^ECH(ECDA,"P")),ECPCE1=$P(ECPCE,U),ECPCE2=$P(ECPCE,U,2)
S ECPCE7=$S($P(ECPCE,U,7)=1:"Y",1:"N")
S ECXRES1=$$GET1^DIQ(720.5,$P($G(^ECH(ECDA,0)),U,23),.01,"E") ;149 Proc Reason 1
S ECXRES2=$$GET1^DIQ(720.5,$P($G(^ECH(ECDA,0)),U,24),.01,"E") ;149 Proc Reason 2
S ECXRES3=$$GET1^DIQ(720.5,$P($G(^ECH(ECDA,1)),U,1),.01,"E") ;149 Proc Reason 3
S ECXCMOD=""
I $D(^ECH(ECDA,"MOD")) D
.S MOD=0,M=""
.F S MOD=$O(^ECH(ECDA,"MOD",MOD)) Q:'MOD S M=$P(^(MOD,0),U) D
..I M S ECXCMOD=ECXCMOD_M_";"
.K MOD,M
S:ECP?1.N ECP=$$CPT^ECXUTL3($E(ECP,1,5),"",ECV)
S ECXCPT=$$CPT^ECXUTL3(ECPCE1,ECXCMOD,ECV)
;
;- Observation Patient Indicator (YES/NO)
S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS)
;
;- CNH status (YES/NO)
S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN)
;
;- encounter classification
S (ECXAO,ECXECE,ECXHNC,ECXMIL,ECXIR,ECXSHAD)="",ECXVISIT=$P(ECCH,U,21)
I ECXVISIT'="" D
.D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q
.S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE")),ECXSHAD=$G(ECXVIST("SHAD"))
.S ECXHNC=$G(ECXVIST("HNC")),ECXMIL=$G(ECXVIST("MST")),ECXIR=$G(ECXVIST("IR"))
.S ECXECL=$G(ECXVIST("ENCCL")),ECXESC=$G(ECXVIST("ENCSC")) ;144
; - Head and Neck Cancer Indicator
S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
; - PROJ 112/SHAD Indicator
S ECXSHADI=$$SHAD^ECXUTL4(ECXDFN)
; ******* - PATCH 127, ADD PATCAT CODE
S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
;
; - Get national patient record flag Indicator if exist
D NPRF^ECXUTL5
;
S ECXSVH=$P($G(^ECH(ECDA,2)),U,5) ;174 Set state veteran home name from field in the EVENT CAPTURE PATIENT file
; - If no encounter number don't file record
S ECDSSE=$S(ECAC1S<101!(ECAC1S>999):"ECS",1:ECAC1S)_ECAC2S ;154 If stop code is invalid set it to ECS for encounter number creation
I ECXLOGIC>2018 D ;170 If procedure is in range, change specific patient data for record
.I "^CH103^CH104^CH105^CH106^CH107^CH108^CH109^"[("^"_$G(ECPNM)_"^") S ECXSSN="000123457",ECXPNM="ZZCH",ECXA="O" ;If specific Chaplain codes, use fake name and SSN and set to outpatient
S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSSE,ECCS) ;154 Send ECDSSE for encounter number creation
I $G(ECXASIH) S ECXA="A" ;170
D:ECXENC'="" FILE
I $D(^XTMP("ECEFPAT",ECDA)) S ^XTMP("ECEFPAT",ECDA)=$S($G(LATE):2,1:1) ;166 If this record was entered through the state home spreadsheet then mark it with 1 if within date range or 2 if "late"
Q
;
FILE ;file record in #727.815
;node0
;ecode=inst ECL^dfn ECXDFN^ssn ECXSSN^name ECXPNM^i/o status ECXA^day^
;DSS unit ECDU^category ECC^procedure ECP^volume ECV^
;cost center ECCS^ordering sec ECO^section ECM^
;provider ECU1A^prov per cls ECXPPC1^prov 2 ECU2A^prov#2 per cls ECXPPC2
;^prov 3 ECU3A^prov#3 per cls ECXPPC3^^mov # ECXMN^treat spec ECXTS
;^time ECTM^Placehold primary care team ECPTTM^Placehold primary care provider ECPTPR
;^pce cpt code (ECXCPT)^Placeholder ECXICD9^Placeholder ECXICD91^
;Placeholder ECXICD92^Placeholder ECXICD93^Placeholder ECXICD94^
;agent orange ECXAST^radiation exposure ECXRST^
;environmental contaminants ECXEST^service connected ECPTPR^sent to pce
;ECPCE7^^dss identifier ECDSS^placeholder
;node1
;mpi ECXMPI^placeholder ECXDSSD^PLACEHOLDER
;placeholder^placeholder^placeholder^
;placeholder^Placehold pc prov person class ECCLAS^
;Placehold assoc pc prov ECASPR^Placehold assoc pc prov person class ECCLAS2^
;placeholder^
;divison ECXDIV^mst status ECXMST^dom ECXDOM^date of birth ECXDOB^
;enrollment category ECXCAT^ enrollment status ECXSTAT^enrollment
;priority ECXPRIOR^period of service ECXPOS^purple heart indicator
;ECXPHI^observ pat ind ECXOBS^encounter num ECXENC^
;ao loc ECXAOL^ord div ECXODIV^contr st dt ECXCSDT^
;contr end dt ECXCEDT^contr typ ECXCTYP^CNH stat ECXCNH^
;production division ECXPDIV^eligibility ECXELIG^
;head & neck cancer ind. ECXHNCI^Placehold ethnicity ECXETH^Placehold race1 ECXRC1
;enrollment location ECXENRL^^enrollment priority
;ECXPRIOR_enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient
;type ECXPTYPE^combat vet elig ECXCVE
;NODE 2
;combat vet elig end date ECXCVEDT
;enc cv eligible ECXCVENC^national patient record flag
;ECXNPRFI^emerg response indic(FEMA) ECXERI^agent orange indic ECXAO^
;environ contam ECXECE^head/neck cancer ECXHNC^encntr mst ECXMIL
;^radiation ECXIR^OEF/OIF ECXOEF^OEF/OIF return date ECXOEFDT
;^Placehold associate pc provider npi ECASNPI^Placehold primary care provider npi ECPTNPI^
;provider npi ECU1NPI^provider #2 ECU2NPI^provider #3 ECU3NPI^
;shad status ECXSHADI^shad encounter ECXSHAD^patcat ECXPATCAT^
;prov #4 ECU4A^prov #4 pc ECXPPC4^prov #4 ECXU4NPI^prov #5 ECU5A^
;prov #5 pc ECXPPC5^prov #5 ECXU5NPI^
;primary ICD-10 code ECXICD10P^Secondary ICD-10 Code #1 ECXICD101^
;Secondary ICD-10 Code #2 ECXICD102^Secondary ICD-10 Code #3 ECXICD103^
;Secondary ICD-10 Code #4 ECXICD104
;NODE 3
;Encounter SC ECXESC^Vietnam Status ECXVIET^
;Provider #6 ECU6A^ Prov #6 PC ECXPPC6^Prov #6 NPI ECU6NPI^Provider #7 ECU7A^ Prov #7 PC ECXPPC7^Prov #7 NPI ECU7NPI
;National 4CHAR code ECX4CHAR^NULL^Camp Lejeune Status ECXCLST^Encounter Camp Lejeune ECXECL
;Reason #1 (ECXRES1) ^ Reason #2 (ECXRES2) ^ Reason #3 (ECXRES3) ^ Combat Service Indicator (ECXSVCI) ^ Combat Service Location (ECXSVCL)
;Clinic IEN (ECAC) 154
;^ Patient Division (ECXSTANO) 166^State Home Name (ECXSVH) 174^PlaceHold CERNER (ECXCERN)^New MPI (ECXNMPI)^Self Identified Gender (ECXSIGI) ; 184
;
;convert specialty to PTF Code for transmission
N ECXDATA
S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA)
S ECXTS=$G(ECXDATA(7))
;done
N DA,DIK
S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
I ECXLOGIC>2018 D ;170 Changes related to FY19
.S (ECXETH,ECXRC1)="" ;170 Ethnicity and Race 1 fields will now be null
.S (ECPTTM,ECPTPR,ECCLAS,ECASPR,ECCLAS2,ECASNPI,ECPTNPI)="" ;170 PCMM-related fields will be null
I ECXLOGIC>2022 S ECXNMPI=ECXMPI,ECXMPI="" ;184 Field retired: MPI, Added New field:NMPI
S ECODE=EC7_U_EC23_U_ECL_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
S ECODE=ECODE_$$ECXDATE^ECXUTL(ECDT,ECXYM)_U_ECDU_U_ECC_U
S ECODE=ECODE_ECP_U_ECV_U_ECCS_U_ECO_U_ECM_U_ECU1A_U_ECXPPC1_U
S ECODE=ECODE_ECU2A_U_ECXPPC2_U_ECU3A_U_ECXPPC3_U_U_ECXMN_U
S ECODE=ECODE_ECXTS_U_ECTM_U
S ECODE=ECODE_ECPTTM_U_ECPTPR_U_ECXCPT_U_ECXICD9_U
S ECODE=ECODE_ECXICD91_U_ECXICD92_U_ECXICD93_U
S ECODE=ECODE_ECXICD94_U_ECXAST_U_ECXRST_U_ECXEST_U
S ECODE=ECODE_ECSC_U_ECPCE7_U_U_ECDSS_U_U
S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_U_ECCLAS_U
S ECODE1=ECODE1_U_ECASPR_U_ECCLAS2_U_U_ECXDIV_U
S ECODE1=ECODE1_ECXMST_U_ECXDOM_U_ECXDOB_U_ECXCAT_U_ECXSTAT_U
S ECODE1=ECODE1_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U
S ECODE1=ECODE1_ECXODIV_U_ECXCSDT_U_ECXCEDT_U_ECXCTYP_U_ECXCNH_U_ECXPDIV_U
S ECODE1=ECODE1_ECXELIG_U_ECXHNCI_U_ECXETH_U_ECXRC1
I ECXLOGIC>2003 S ECODE1=ECODE1_U_ECXENRL_U
I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U
I ECXLOGIC>2004 S ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U
I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_ECU1NPI_U_ECU2NPI_U_ECU3NPI
; PATCAT added
I ECXLOGIC>2010 S ECODE2=ECODE2_U_ECXSHADI_U_ECXSHAD_U_ECXPATCAT
I ECXLOGIC>2011 S ECODE2=ECODE2_U_ECU4A_U_ECXPPC4_U_ECU4NPI_U_ECU5A_U_ECXPPC5_U_ECU5NPI
I ECXLOGIC>2012 S ECODE2=ECODE2_U_ECXICD10P_U_ECXICD101_U_ECXICD102_U_ECXICD103_U_ECXICD104_U
I ECXLOGIC>2013 S ECODE3=ECXESC_U_ECXVIET_U_ECU6A_U_ECXPPC6_U_ECU6NPI_U_ECU7A_U_ECXPPC7_U_ECU7NPI_U_ECX4CHAR_U_$S(ECXLOGIC>2015:"",1:ECAC)_U_ECXCLST_U_ECXECL ; 154
I ECXLOGIC>2014 S ECODE3=ECODE3_U_ECXRES1_U_ECXRES2_U_ECXRES3_U_ECXSVCI_U_ECXSVCL ;149
I ECXLOGIC>2015 S ECODE3=ECODE3_U_ECAC ;154 MOVED CLINIC IEN
I ECXLOGIC>2017 S ECODE3=ECODE3_U_ECXSTANO ;166
I ECXLOGIC>2019 S ECODE3=ECODE3_U_ECXSVH ;174
I ECXLOGIC>2022 S ECODE3=ECODE3_U_ECXCERN_U_ECXNMPI_U_ECXSIGI ;184
S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),^ECX(ECFILE,EC7,3)=$G(ECODE3),ECRN=ECRN+1 ;144
S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
I $D(ZTQUEUED),$$S^%ZTLOAD
Q
;
SETUP ;Set required input for ECXTRAC
N OUT
S ECHEAD="ECS",OUT=0
D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
Q:($G(ECXQQ))
W @IOF,!,"Setting up for ",ECPACK," DSS Extract -",!
W !," Reminder: A maintenance option, ECS Extract Unusual Volume Report, may"
W !," assist in identifying problematic data. It should be run before the"
W !," Event Capture Extract is performed.",!
D PAUSE^ECXTRAC
I OUT S ECFILE=""
Q
;
QUE ; entry point for the background requeuing handled by ECXTAUTO
N ECXQQ
S ECXQQ=1 D SETUP,QUE^ECXTAUTO,^ECXKILL Q
;
CLEAN ;166 Section added to clean out table when extract finishes
N RECNO
S RECNO=0 F S RECNO=$O(^XTMP("ECEFPAT",RECNO)) Q:'+RECNO D
.I $G(^XTMP("ECEFPAT",RECNO))'="" K ^XTMP("ECEFPAT",RECNO) ;If record was counted, delete entry from table
Q
;
SETTMP ;181 - Set global TMP for Mail Message
N ECXNODSS,PNAME,SSN,DFN,ECDTEX,VADM
S DFN=ECXDFN D DEM^VADPT ; ICR #10061
S ECDTEX=$$ECXDATE^ECXUTL(ECDT,ECXYM)
S ECDTEX=$E(ECDTEX,5,6)_"/"_$E(ECDTEX,7,8)_"/"_$E(ECDTEX,1,4)
I '$D(^TMP($J,"ECXECM","NODSS")) S ^TMP($J,"ECXECM","NODSS")=0
S ECXNODSS=^TMP($J,"ECXECM","NODSS")+1
S ^TMP($J,"ECXECM","NODSS",ECXNODSS,0)=$J($E(VADM(1),1,25),25)_" ("_$P(VADM(2),U,2)_") "_$J($G(ECP),12)_" "_$J(ECDTEX,12)_" "_$$ECXTIMEX^ECXUTL(ECTM)
S ^TMP($J,"ECXECM","NODSS")=ECXNODSS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXEC 16934 printed Apr 09, 2024@20:59:09 Page 2
ECXEC ;ALB/JAP,BIR/JLP,PTD-DSS Event Capture Extract ;5/31/19 11:28
+1 ;;3.0;DSS EXTRACTS;**11,8,13,24,27,33,39,46,49,71,89,92,105,120,127,132,136,144,149,154,161,166,170,173,174,181,184**;Dec 22, 1997;Build 124
+2 ;
+3 ; Reference to DEM^VADPT in ICR #10061
+4 ; Reference to ^TMP($J) in SACC 2.3.2.5.1
+5 ;
BEG ;entry point from option
+1 IF '$DATA(^ECH)
WRITE !,"Event Capture is not initialized",!!
QUIT
+2 DO SETUP
IF ECFILE=""
QUIT
+3 DO ^ECXTRAC
DO ^ECXKILL
+4 QUIT
START ;begin EC extract
+1 ; 144 national 4char code
NEW X,Y,ECDCM,ECXNPRFI,ECXVIET,ECX4CHAR
+2 ;166,170
NEW ECXICD10P,ECXICD101,ECXICD102,ECXICD103,ECXICD104,LATE,EFY
+3 ;170 Determine extract fiscal year based on ending date of extract
SET EFY=$$FISCAL^ECXUTL1(ECED)
+4 SET ECED=ECED+.3
SET ECLL=0
+5 KILL ^TMP("EC",$JOB)
+6 ;181
KILL ^TMP($JOB,"ECXECM")
+7 FOR
SET ECLL=$ORDER(^ECH("AC1",ECLL))
SET ECD=ECSD-.1
if 'ECLL
QUIT
Begin DoDot:1
+8 FOR
SET ECD=$ORDER(^ECH("AC1",ECLL,ECD))
SET ECDA=0
if (ECD>ECED)!('ECD)
QUIT
Begin DoDot:2
+9 FOR
SET ECDA=$ORDER(^ECH("AC1",ECLL,ECD,ECDA))
if 'ECDA
QUIT
DO UPDATE
End DoDot:2
End DoDot:1
+10 ;166 Done processing by date, now find any "late" state home records
+11 SET ECDA=0
SET LATE=1
FOR
SET ECDA=$ORDER(^XTMP("ECEFPAT",ECDA))
if '+ECDA
QUIT
Begin DoDot:1
+12 ;Record already counted in "regular" process
IF $GET(^XTMP("ECEFPAT",ECDA))=1
QUIT
+13 ;Record in table but not in file
IF '$DATA(^ECH(ECDA,0))
QUIT
+14 ;Record has a procedure date/time after end date of extract so we'll skip it
IF $PIECE($GET(^ECH(ECDA,0)),U,3)>ECED
QUIT
+15 ;170 If the fiscal year associated with the procedure date is from a previous fiscal year, skip and set for deletion
IF $$FISCAL^ECXUTL1($PIECE($GET(^ECH(ECDA,0)),U,3))<EFY
SET ^XTMP("ECEFPAT",ECDA)=3
QUIT
+16 ;process record
DO UPDATE
End DoDot:1
+17 ;166 extract completed, clear out ^XTMP records
DO CLEAN
+18 ;181 - Send messages for records with NO DSS Units
IF $DATA(^TMP($JOB,"ECXECM"))
DO EN^ECXEC1
+19 QUIT
+20 ;
UPDATE ;sets record and updates counters
+1 ;149,154
NEW ECXESC,ECXECL,ECXCLST,ECXRES1,ECXRES2,ECXRES3,ECPNM,ECDSSE,ROOT
+2 ;166,170,174
NEW ECXTEMPW,ECXTEMPD,ECXSTANO,ECXASIH,ECXSVH
+3 ;184
NEW ECXCERN,ECXNMPI,ECXSIGI
+4 ;144;184 - Added ECXCERN
SET (ECXESC,ECXECL,ECXCLST,ECXRES1,ECXRES2,ECXRES3,ECXCERN)=""
+5 SET ECCH=^ECH(ECDA,0)
SET ECL=$PIECE(ECCH,U,4)
SET ECXDFN=$PIECE(ECCH,U,2)
+6 ;Get production division from file 4
SET ECXPDIV=$$RADDIV^ECXDEPT(ECL)
+7 SET ECDT=$PIECE(ECCH,U,3)
SET ECM=$PIECE(ECCH,U,6)
SET ECC=$PIECE(ECCH,U,8)
+8 ;154 Moved line to be in front of call to ECXUTL2
SET ECTM=$$ECXTIME^ECXUTL(ECDT)
SET ECP=$PIECE(ECCH,U,9)
+9 ;154 Get procedure name
IF $PIECE(ECP,";",2)[725
SET ECPNM=$$GET1^DIQ(725,+ECP,1)
+10 if '$$PATDEM^ECXUTL2(ECXDFN,ECDT,"1;3;5;")
QUIT
+11 if ECP']""
QUIT
+12 ;181 - Moved these lines from below to be in front of calling SETTMP
if ECP[";"
Begin DoDot:1
+13 SET ECP=$SELECT(ECP["ICPT":$PIECE(^ICPT(+ECP,0),U)_"01",ECP<90000:$PIECE(^EC(725,+ECP,0),U,2)_"N",1:$PIECE(^EC(725,+ECP,0),U,2)_"L")
SET ECC=$SELECT(ECC:ECC,1:"")
End DoDot:1
+14 ;166 tjl - Set default Patient Division
SET ECXSTANO=ECXPDIV
+15 ;166 tjl - Set Patient Division for inpatients based on Patient Movement record
IF ECXA="I"
IF $DATA(^DGPM(ECXMN,0))
Begin DoDot:1
+16 SET ECXTEMPW=$PIECE($GET(^DGPM(ECXMN,0)),U,6)
+17 SET ECXTEMPD=$PIECE($GET(^DIC(42,+ECXTEMPW,0)),U,11)
+18 SET ECXSTANO=$$GETDIV^ECXDEPT(ECXTEMPD)
End DoDot:1
+19 SET ECO=$PIECE(ECCH,U,12)
SET ECV=$PIECE(ECCH,U,10)
SET ECDU=$PIECE(ECCH,U,7)
+20 ;181 - if DSS Unit is missing set global for mail message
IF ECDU=""
DO SETTMP
QUIT
+21 SET ECXUNIT=$GET(^ECD(ECDU,0))
SET ECCS=+$PIECE(ECXUNIT,U,4)
SET ECDCM=$PIECE(ECXUNIT,U,5)
+22 SET ECXDSSP=""
SET ECXDSSD=$EXTRACT(ECDCM,1,10)
SET ECUSTOP=$PIECE(ECXUNIT,U,10)
SET ECUPCE=$PIECE(ECXUNIT,U,14)
+23 ;154
SET ICD9=$PIECE($GET(^ECH(ECDA,"P")),U,2)
+24 ;144,154,161
SET (ECXICD9,ECXICD10P,ECX4CHAR)=""
IF ICD9'=""
SET ECXICD10P=$$CODEC^ICDEX(80,ICD9)
+25 FOR I=1:1:4
SET @("ECXICD9"_I)=""
+26 FOR I=1:1:4
SET @("ECXICD10"_I)=""
+27 SET (CNT,I)=0
+28 FOR
SET CNT=$ORDER(^ECH(ECDA,"DX",CNT))
if 'CNT
QUIT
Begin DoDot:1
+29 SET ICD9=$PIECE($GET(^ECH(ECDA,"DX",CNT,0)),U)
if ICD9'=""
Begin DoDot:2
+30 ;154,161
SET I=I+1
SET @("ECXICD10"_I)=$$CODEC^ICDEX(80,ICD9)
End DoDot:2
End DoDot:1
if I>3
QUIT
+31 ;derivation of dss identifier depends on whether dss unit is
+32 ;set to send data to pce
+33 ;144 Change value to null if value from event capture patient file is 0
SET ECAC=$PIECE($GET(ECCH),U,19)
if ECAC=0
SET ECAC=""
+34 ; 144,154 use the assoc clinic to get 4char code, default to 0000 if non-existent
SET ECX4CHAR=$$RJ^XLFSTR($$GET1^DIQ(728.44,+ECAC,7,"E"),4,0)
+35 ;if this is a record that 'goes to pce', then get the dss identifier
+36 ;from the clinic stop codes
+37 SET (ECAC1S,ECAC2S)="000"
+38 ;173 Add "OOS" units
IF ECUPCE="A"!(ECUPCE="O"&(ECXA="O"))!(ECUPCE="OOS")
Begin DoDot:1
+39 if +ECAC
Begin DoDot:2
+40 SET ECAC1=$PIECE($GET(^SC(+ECAC,0)),U,7)
SET ECAC2=$PIECE($GET(^(0)),U,18)
+41 IF 'ECAC2
SET ECAC2S="000"
+42 IF 'ECAC1
SET (ECAC1S,ECAC2S)="000"
QUIT
+43 SET ECAC1S=$PIECE($GET(^DIC(40.7,+ECAC1,0)),U,2)
+44 SET ECAC2S=$PIECE($GET(^DIC(40.7,+ECAC2,0)),U,2)
+45 SET ECAC1S=$$RJ^XLFSTR(ECAC1S,3,0)
SET ECAC2S=$$RJ^XLFSTR(ECAC2S,3,0)
End DoDot:2
+46 if 'ECAC
SET (ECAC1S,ECAC2S)="000"
End DoDot:1
+47 ;if this record doesn't go to pce, then get the dss identifier
+48 ;from the dss unit
+49 IF ECUPCE=""!(ECUPCE="N")!(ECUPCE="O"&(ECXA="I"))
Begin DoDot:1
+50 ;154
SET ECAC1S=$$RJ^XLFSTR($PIECE($GET(^DIC(40.7,+ECUSTOP,0)),U,2),3,0)
+51 ;154
SET ECAC2S=$$RJ^XLFSTR($PIECE($GET(^DIC(40.7,+$PIECE(ECXUNIT,U,13),0)),U,2),3,0)
+52 ;154
SET ECX4CHAR=$$RJ^XLFSTR($$GET1^DIQ(728.441,+$PIECE(ECXUNIT,U,15),.01,"E"),4,0)
End DoDot:1
+53 SET ECDSS=ECAC1S_ECAC2S
+54 IF ECXLOGIC>2003
IF "^18^23^24^41^65^94^108^"[("^"_ECXTS_"^")
SET ECDSS=$$TSMAP^ECXUTL4(ECXTS)
+55 SET ECXDIV=""
+56 ;
+57 ;- Ord Div, Contrct St/End Dates, Contrct Type placeholders for FY2002
+58 SET (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)=""
+59 ;setup provider(s) as'2'_ien
+60 ;144 CVW
SET (ECU1A,ECU2A,ECU3A,ECU1NPI,ECU2NPI,ECU3NPI,ECXPPC1,ECXPPC2,ECXPPC3,ECU1,ECU2,ECU3,ECU4,ECU5,ECU6,ECU7)=""
+61 ;144
SET (ECU4A,ECU5A,ECU6A,ECU7A,ECU4NPI,ECU5NPI,ECU6NPI,ECU7NPI,ECXPPC4,ECXPPC5,ECXPPC6,ECXPPC7)=""
+62 KILL ECXPRV
SET ECXPROV=$$GETPRV^ECPRVMUT(ECDA,.ECXPRV)
IF ECXPROV
QUIT
+63 FOR I=1:1:7
SET Y=$ORDER(ECXPRV(""))
IF Y'=""
SET @("ECU"_I)=+ECXPRV(Y)
KILL ECXPRV(Y)
+64 if $LENGTH(ECU1)
SET ECXPPC1=$$PRVCLASS^ECXUTL(ECU1,ECDT)
SET ECU1A="2"_$PIECE(ECU1,";")
+65 SET ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU1,ECDT)
+66 if +ECXUSRTN'>0
SET ECXUSRTN=""
SET ECU1NPI=$PIECE(ECXUSRTN,U)
+67 if $LENGTH(ECU2)
SET ECXPPC2=$$PRVCLASS^ECXUTL(ECU2,ECDT)
SET ECU2A="2"_$PIECE(ECU2,";")
+68 SET ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU2,ECDT)
+69 if +ECXUSRTN'>0
SET ECXUSRTN=""
SET ECU2NPI=$PIECE(ECXUSRTN,U)
+70 if $LENGTH(ECU3)
SET ECXPPC3=$$PRVCLASS^ECXUTL(ECU3,ECDT)
SET ECU3A="2"_$PIECE(ECU3,";")
+71 SET ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU3,ECDT)
+72 if +ECXUSRTN'>0
SET ECXUSRTN=""
SET ECU3NPI=$PIECE(ECXUSRTN,U)
+73 if $LENGTH(ECU4)
SET ECXPPC4=$$PRVCLASS^ECXUTL(ECU4,ECDT)
SET ECU4A="2"_$PIECE(ECU4,";")
+74 SET ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU4,ECDT)
+75 if +ECXUSRTN'>0
SET ECXUSRTN=""
SET ECU4NPI=$PIECE(ECXUSRTN,U)
+76 if $LENGTH(ECU5)
SET ECXPPC5=$$PRVCLASS^ECXUTL(ECU5,ECDT)
SET ECU5A="2"_$PIECE(ECU5,";")
+77 SET ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU5,ECDT)
+78 if +ECXUSRTN'>0
SET ECXUSRTN=""
SET ECU5NPI=$PIECE(ECXUSRTN,U)
+79 ;144 add 2 more providers, prov per class, prov npi cvw
+80 if $LENGTH(ECU6)
SET ECXPPC6=$$PRVCLASS^ECXUTL(ECU6,ECDT)
SET ECU6A="2"_$PIECE(ECU6,";")
+81 SET ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU6,ECDT)
+82 if +ECXUSRTN'>0
SET ECXUSRTN=""
SET ECU6NPI=$PIECE(ECXUSRTN,U)
+83 if $LENGTH(ECU7)
SET ECXPPC7=$$PRVCLASS^ECXUTL(ECU7,ECDT)
SET ECU7A="2"_$PIECE(ECU7,";")
+84 SET ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU7,ECDT)
+85 if +ECXUSRTN'>0
SET ECXUSRTN=""
SET ECU7NPI=$PIECE(ECXUSRTN,U)
+86 ;change for version 2 where ECP is a variable pointer and we want to
+87 ;expand it category = category or null if stored as 0
+88 ;D:ECP[";" ;181 - Moved to begin of UPDATE
+89 ;.S ECP=$S(ECP["ICPT":$P(^ICPT(+ECP,0),U)_"01",ECP<90000:$P(^EC(725,+ECP,0),U,2)_"N",1:$P(^EC(725,+ECP,0),U,2)_"L"),ECC=$S(ECC:ECC,1:"")
+90 ;pick up EC to PCE data from "P" in File 721
+91 SET ECPCE=$GET(^ECH(ECDA,"P"))
SET ECPCE1=$PIECE(ECPCE,U)
SET ECPCE2=$PIECE(ECPCE,U,2)
+92 SET ECPCE7=$SELECT($PIECE(ECPCE,U,7)=1:"Y",1:"N")
+93 ;149 Proc Reason 1
SET ECXRES1=$$GET1^DIQ(720.5,$PIECE($GET(^ECH(ECDA,0)),U,23),.01,"E")
+94 ;149 Proc Reason 2
SET ECXRES2=$$GET1^DIQ(720.5,$PIECE($GET(^ECH(ECDA,0)),U,24),.01,"E")
+95 ;149 Proc Reason 3
SET ECXRES3=$$GET1^DIQ(720.5,$PIECE($GET(^ECH(ECDA,1)),U,1),.01,"E")
+96 SET ECXCMOD=""
+97 IF $DATA(^ECH(ECDA,"MOD"))
Begin DoDot:1
+98 SET MOD=0
SET M=""
+99 FOR
SET MOD=$ORDER(^ECH(ECDA,"MOD",MOD))
if 'MOD
QUIT
SET M=$PIECE(^(MOD,0),U)
Begin DoDot:2
+100 IF M
SET ECXCMOD=ECXCMOD_M_";"
End DoDot:2
+101 KILL MOD,M
End DoDot:1
+102 if ECP?1.N
SET ECP=$$CPT^ECXUTL3($EXTRACT(ECP,1,5),"",ECV)
+103 SET ECXCPT=$$CPT^ECXUTL3(ECPCE1,ECXCMOD,ECV)
+104 ;
+105 ;- Observation Patient Indicator (YES/NO)
+106 SET ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS)
+107 ;
+108 ;- CNH status (YES/NO)
+109 SET ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN)
+110 ;
+111 ;- encounter classification
+112 SET (ECXAO,ECXECE,ECXHNC,ECXMIL,ECXIR,ECXSHAD)=""
SET ECXVISIT=$PIECE(ECCH,U,21)
+113 IF ECXVISIT'=""
Begin DoDot:1
+114 DO VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR)
IF ECXERR
KILL ECXERR
QUIT
+115 SET ECXAO=$GET(ECXVIST("AO"))
SET ECXECE=$GET(ECXVIST("PGE"))
SET ECXSHAD=$GET(ECXVIST("SHAD"))
+116 SET ECXHNC=$GET(ECXVIST("HNC"))
SET ECXMIL=$GET(ECXVIST("MST"))
SET ECXIR=$GET(ECXVIST("IR"))
+117 ;144
SET ECXECL=$GET(ECXVIST("ENCCL"))
SET ECXESC=$GET(ECXVIST("ENCSC"))
End DoDot:1
+118 ; - Head and Neck Cancer Indicator
+119 SET ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
+120 ; - PROJ 112/SHAD Indicator
+121 SET ECXSHADI=$$SHAD^ECXUTL4(ECXDFN)
+122 ; ******* - PATCH 127, ADD PATCAT CODE
+123 SET ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
+124 ;
+125 ; - Get national patient record flag Indicator if exist
+126 DO NPRF^ECXUTL5
+127 ;
+128 ;174 Set state veteran home name from field in the EVENT CAPTURE PATIENT file
SET ECXSVH=$PIECE($GET(^ECH(ECDA,2)),U,5)
+129 ; - If no encounter number don't file record
+130 ;154 If stop code is invalid set it to ECS for encounter number creation
SET ECDSSE=$SELECT(ECAC1S<101!(ECAC1S>999):"ECS",1:ECAC1S)_ECAC2S
+131 ;170 If procedure is in range, change specific patient data for record
IF ECXLOGIC>2018
Begin DoDot:1
+132 ;If specific Chaplain codes, use fake name and SSN and set to outpatient
IF "^CH103^CH104^CH105^CH106^CH107^CH108^CH109^"[("^"_$GET(ECPNM)_"^")
SET ECXSSN="000123457"
SET ECXPNM="ZZCH"
SET ECXA="O"
End DoDot:1
+133 ;154 Send ECDSSE for encounter number creation
SET ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSSE,ECCS)
+134 ;170
IF $GET(ECXASIH)
SET ECXA="A"
+135 if ECXENC'=""
DO FILE
+136 ;166 If this record was entered through the state home spreadsheet then mark it with 1 if within date range or 2 if "late"
IF $DATA(^XTMP("ECEFPAT",ECDA))
SET ^XTMP("ECEFPAT",ECDA)=$SELECT($GET(LATE):2,1:1)
+137 QUIT
+138 ;
FILE ;file record in #727.815
+1 ;node0
+2 ;ecode=inst ECL^dfn ECXDFN^ssn ECXSSN^name ECXPNM^i/o status ECXA^day^
+3 ;DSS unit ECDU^category ECC^procedure ECP^volume ECV^
+4 ;cost center ECCS^ordering sec ECO^section ECM^
+5 ;provider ECU1A^prov per cls ECXPPC1^prov 2 ECU2A^prov#2 per cls ECXPPC2
+6 ;^prov 3 ECU3A^prov#3 per cls ECXPPC3^^mov # ECXMN^treat spec ECXTS
+7 ;^time ECTM^Placehold primary care team ECPTTM^Placehold primary care provider ECPTPR
+8 ;^pce cpt code (ECXCPT)^Placeholder ECXICD9^Placeholder ECXICD91^
+9 ;Placeholder ECXICD92^Placeholder ECXICD93^Placeholder ECXICD94^
+10 ;agent orange ECXAST^radiation exposure ECXRST^
+11 ;environmental contaminants ECXEST^service connected ECPTPR^sent to pce
+12 ;ECPCE7^^dss identifier ECDSS^placeholder
+13 ;node1
+14 ;mpi ECXMPI^placeholder ECXDSSD^PLACEHOLDER
+15 ;placeholder^placeholder^placeholder^
+16 ;placeholder^Placehold pc prov person class ECCLAS^
+17 ;Placehold assoc pc prov ECASPR^Placehold assoc pc prov person class ECCLAS2^
+18 ;placeholder^
+19 ;divison ECXDIV^mst status ECXMST^dom ECXDOM^date of birth ECXDOB^
+20 ;enrollment category ECXCAT^ enrollment status ECXSTAT^enrollment
+21 ;priority ECXPRIOR^period of service ECXPOS^purple heart indicator
+22 ;ECXPHI^observ pat ind ECXOBS^encounter num ECXENC^
+23 ;ao loc ECXAOL^ord div ECXODIV^contr st dt ECXCSDT^
+24 ;contr end dt ECXCEDT^contr typ ECXCTYP^CNH stat ECXCNH^
+25 ;production division ECXPDIV^eligibility ECXELIG^
+26 ;head & neck cancer ind. ECXHNCI^Placehold ethnicity ECXETH^Placehold race1 ECXRC1
+27 ;enrollment location ECXENRL^^enrollment priority
+28 ;ECXPRIOR_enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient
+29 ;type ECXPTYPE^combat vet elig ECXCVE
+30 ;NODE 2
+31 ;combat vet elig end date ECXCVEDT
+32 ;enc cv eligible ECXCVENC^national patient record flag
+33 ;ECXNPRFI^emerg response indic(FEMA) ECXERI^agent orange indic ECXAO^
+34 ;environ contam ECXECE^head/neck cancer ECXHNC^encntr mst ECXMIL
+35 ;^radiation ECXIR^OEF/OIF ECXOEF^OEF/OIF return date ECXOEFDT
+36 ;^Placehold associate pc provider npi ECASNPI^Placehold primary care provider npi ECPTNPI^
+37 ;provider npi ECU1NPI^provider #2 ECU2NPI^provider #3 ECU3NPI^
+38 ;shad status ECXSHADI^shad encounter ECXSHAD^patcat ECXPATCAT^
+39 ;prov #4 ECU4A^prov #4 pc ECXPPC4^prov #4 ECXU4NPI^prov #5 ECU5A^
+40 ;prov #5 pc ECXPPC5^prov #5 ECXU5NPI^
+41 ;primary ICD-10 code ECXICD10P^Secondary ICD-10 Code #1 ECXICD101^
+42 ;Secondary ICD-10 Code #2 ECXICD102^Secondary ICD-10 Code #3 ECXICD103^
+43 ;Secondary ICD-10 Code #4 ECXICD104
+44 ;NODE 3
+45 ;Encounter SC ECXESC^Vietnam Status ECXVIET^
+46 ;Provider #6 ECU6A^ Prov #6 PC ECXPPC6^Prov #6 NPI ECU6NPI^Provider #7 ECU7A^ Prov #7 PC ECXPPC7^Prov #7 NPI ECU7NPI
+47 ;National 4CHAR code ECX4CHAR^NULL^Camp Lejeune Status ECXCLST^Encounter Camp Lejeune ECXECL
+48 ;Reason #1 (ECXRES1) ^ Reason #2 (ECXRES2) ^ Reason #3 (ECXRES3) ^ Combat Service Indicator (ECXSVCI) ^ Combat Service Location (ECXSVCL)
+49 ;Clinic IEN (ECAC) 154
+50 ;^ Patient Division (ECXSTANO) 166^State Home Name (ECXSVH) 174^PlaceHold CERNER (ECXCERN)^New MPI (ECXNMPI)^Self Identified Gender (ECXSIGI) ; 184
+51 ;
+52 ;convert specialty to PTF Code for transmission
+53 NEW ECXDATA
+54 SET ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA)
+55 SET ECXTS=$GET(ECXDATA(7))
+56 ;done
+57 NEW DA,DIK
+58 SET EC7=$ORDER(^ECX(ECFILE,999999999),-1)
SET EC7=EC7+1
+59 ;170 Changes related to FY19
IF ECXLOGIC>2018
Begin DoDot:1
+60 ;170 Ethnicity and Race 1 fields will now be null
SET (ECXETH,ECXRC1)=""
+61 ;170 PCMM-related fields will be null
SET (ECPTTM,ECPTPR,ECCLAS,ECASPR,ECCLAS2,ECASNPI,ECPTNPI)=""
End DoDot:1
+62 ;184 Field retired: MPI, Added New field:NMPI
IF ECXLOGIC>2022
SET ECXNMPI=ECXMPI
SET ECXMPI=""
+63 SET ECODE=EC7_U_EC23_U_ECL_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+64 SET ECODE=ECODE_$$ECXDATE^ECXUTL(ECDT,ECXYM)_U_ECDU_U_ECC_U
+65 SET ECODE=ECODE_ECP_U_ECV_U_ECCS_U_ECO_U_ECM_U_ECU1A_U_ECXPPC1_U
+66 SET ECODE=ECODE_ECU2A_U_ECXPPC2_U_ECU3A_U_ECXPPC3_U_U_ECXMN_U
+67 SET ECODE=ECODE_ECXTS_U_ECTM_U
+68 SET ECODE=ECODE_ECPTTM_U_ECPTPR_U_ECXCPT_U_ECXICD9_U
+69 SET ECODE=ECODE_ECXICD91_U_ECXICD92_U_ECXICD93_U
+70 SET ECODE=ECODE_ECXICD94_U_ECXAST_U_ECXRST_U_ECXEST_U
+71 SET ECODE=ECODE_ECSC_U_ECPCE7_U_U_ECDSS_U_U
+72 SET ECODE1=ECXMPI_U_ECXDSSD_U_U_U_U_ECCLAS_U
+73 SET ECODE1=ECODE1_U_ECASPR_U_ECCLAS2_U_U_ECXDIV_U
+74 SET ECODE1=ECODE1_ECXMST_U_ECXDOM_U_ECXDOB_U_ECXCAT_U_ECXSTAT_U
+75 SET ECODE1=ECODE1_$SELECT(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U
+76 SET ECODE1=ECODE1_ECXODIV_U_ECXCSDT_U_ECXCEDT_U_ECXCTYP_U_ECXCNH_U_ECXPDIV_U
+77 SET ECODE1=ECODE1_ECXELIG_U_ECXHNCI_U_ECXETH_U_ECXRC1
+78 IF ECXLOGIC>2003
SET ECODE1=ECODE1_U_ECXENRL_U
+79 IF ECXLOGIC>2004
SET ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U
+80 IF ECXLOGIC>2004
SET ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
+81 IF ECXLOGIC>2006
SET ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U
+82 IF ECXLOGIC>2007
SET ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_ECU1NPI_U_ECU2NPI_U_ECU3NPI
+83 ; PATCAT added
+84 IF ECXLOGIC>2010
SET ECODE2=ECODE2_U_ECXSHADI_U_ECXSHAD_U_ECXPATCAT
+85 IF ECXLOGIC>2011
SET ECODE2=ECODE2_U_ECU4A_U_ECXPPC4_U_ECU4NPI_U_ECU5A_U_ECXPPC5_U_ECU5NPI
+86 IF ECXLOGIC>2012
SET ECODE2=ECODE2_U_ECXICD10P_U_ECXICD101_U_ECXICD102_U_ECXICD103_U_ECXICD104_U
+87 ; 154
IF ECXLOGIC>2013
SET ECODE3=ECXESC_U_ECXVIET_U_ECU6A_U_ECXPPC6_U_ECU6NPI_U_ECU7A_U_ECXPPC7_U_ECU7NPI_U_ECX4CHAR_U_$SELECT(ECXLOGIC>2015:"",1:ECAC)_U_ECXCLST_U_ECXECL
+88 ;149
IF ECXLOGIC>2014
SET ECODE3=ECODE3_U_ECXRES1_U_ECXRES2_U_ECXRES3_U_ECXSVCI_U_ECXSVCL
+89 ;154 MOVED CLINIC IEN
IF ECXLOGIC>2015
SET ECODE3=ECODE3_U_ECAC
+90 ;166
IF ECXLOGIC>2017
SET ECODE3=ECODE3_U_ECXSTANO
+91 ;174
IF ECXLOGIC>2019
SET ECODE3=ECODE3_U_ECXSVH
+92 ;184
IF ECXLOGIC>2022
SET ECODE3=ECODE3_U_ECXCERN_U_ECXNMPI_U_ECXSIGI
+93 ;144
SET ^ECX(ECFILE,EC7,0)=ECODE
SET ^ECX(ECFILE,EC7,1)=ECODE1
SET ^ECX(ECFILE,EC7,2)=$GET(ECODE2)
SET ^ECX(ECFILE,EC7,3)=$GET(ECODE3)
SET ECRN=ECRN+1
+94 SET DA=EC7
SET DIK="^ECX("_ECFILE_","
DO IX1^DIK
KILL DIK,DA
+95 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
+96 QUIT
+97 ;
SETUP ;Set required input for ECXTRAC
+1 NEW OUT
+2 SET ECHEAD="ECS"
SET OUT=0
+3 DO ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+4 if ($GET(ECXQQ))
QUIT
+5 WRITE @IOF,!,"Setting up for ",ECPACK," DSS Extract -",!
+6 WRITE !," Reminder: A maintenance option, ECS Extract Unusual Volume Report, may"
+7 WRITE !," assist in identifying problematic data. It should be run before the"
+8 WRITE !," Event Capture Extract is performed.",!
+9 DO PAUSE^ECXTRAC
+10 IF OUT
SET ECFILE=""
+11 QUIT
+12 ;
QUE ; entry point for the background requeuing handled by ECXTAUTO
+1 NEW ECXQQ
+2 SET ECXQQ=1
DO SETUP
DO QUE^ECXTAUTO
DO ^ECXKILL
QUIT
+3 ;
CLEAN ;166 Section added to clean out table when extract finishes
+1 NEW RECNO
+2 SET RECNO=0
FOR
SET RECNO=$ORDER(^XTMP("ECEFPAT",RECNO))
if '+RECNO
QUIT
Begin DoDot:1
+3 ;If record was counted, delete entry from table
IF $GET(^XTMP("ECEFPAT",RECNO))'=""
KILL ^XTMP("ECEFPAT",RECNO)
End DoDot:1
+4 QUIT
+5 ;
SETTMP ;181 - Set global TMP for Mail Message
+1 NEW ECXNODSS,PNAME,SSN,DFN,ECDTEX,VADM
+2 ; ICR #10061
SET DFN=ECXDFN
DO DEM^VADPT
+3 SET ECDTEX=$$ECXDATE^ECXUTL(ECDT,ECXYM)
+4 SET ECDTEX=$EXTRACT(ECDTEX,5,6)_"/"_$EXTRACT(ECDTEX,7,8)_"/"_$EXTRACT(ECDTEX,1,4)
+5 IF '$DATA(^TMP($JOB,"ECXECM","NODSS"))
SET ^TMP($JOB,"ECXECM","NODSS")=0
+6 SET ECXNODSS=^TMP($JOB,"ECXECM","NODSS")+1
+7 SET ^TMP($JOB,"ECXECM","NODSS",ECXNODSS,0)=$JUSTIFY($EXTRACT(VADM(1),1,25),25)_" ("_$PIECE(VADM(2),U,2)_") "_$JUSTIFY($GET(ECP),12)_" "_$JUSTIFY(ECDTEX,12)_" "_$$ECXTIMEX^ECXUTL(ECTM)
+8 SET ^TMP($JOB,"ECXECM","NODSS")=ECXNODSS
+9 QUIT
