Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ECXMTL

ECXMTL.m

Go to the documentation of this file. 
  1. ECXMTL ;ALB/JAP - DSS Mental Health Extract ; 8/17/07 9:52am
  1.  ;;3.0;DSS EXTRACTS;**24,30,33,39,46,49,71,82,84,92,105,120,127**;Dec 22, 1997;Build 36
  1.  ;
  1. BEG ;entry point from option
  1.  D SETUP I ECFILE="" Q
  1.  D ^ECXTRAC,^ECXKILL
  1.  Q
  1.  ;
  1. START ;entry point from tasked job
  1.  S QFLG=0
  1.  ;get first record #
  1.  S EC7=$O(^ECX(ECFILE,999999999),-1)
  1.  ;call mh/dss api for extract record creation
  1.  ;variables ecfile,ecxym,ecinst,ecsd,eced passed in by taskmanager
  1.  S ECXSEQ=EC7,ECXECX=$P(EC23,U,2),ECXERR=0
  1.  ;call mh api to create extract records
  1.  S X="YSDSS" X ^%ZOSF("TEST") I '$T S QFLG=1 Q
  1.  D UPD^YSDSS(ECFILE,.ECXSEQ,ECXYM,ECXECX,ECINST,ECSD,ECED,.ECXERR)
  1.  Q:ECXERR
  1.  Q:QFLG
  1.  ;if no error, continue
  1.  D UPDATE
  1.  Q
  1.  ;
  1. UPDATE ;add non-mh data to each record created by mh api
  1.  N ECXADT,JJ,ECXNPRFI
  1.  S EC7=EC7+1
  1.  F JJ=EC7:1:ECXSEQ Q:QFLG  D
  1.  .Q:'$D(^ECX(ECFILE,JJ,0))
  1.  .S ECXDFN=$P(^ECX(ECFILE,JJ,0),U,5),ECXDATE=$P(^ECX(ECFILE,JJ,0),U,9),ECXPRV=$P(^ECX(ECFILE,JJ,0),U,18)
  1.  .S ECXSCNUM=$P(^ECX(ECFILE,JJ,0),U,23),ECXSCNAM=$P(^ECX(ECFILE,JJ,0),U,24)
  1.  .D PAT(ECXDFN,ECXDATE)
  1.  .S (ECXPRCLS,ECPRNPI,ECXDIV,ECXPDIV)="" I ECXPRV D PROV(.ECXPRV,ECXDATE)
  1.  .S ECXDSSI=""
  1.  .I ECXLOGIC>2003 D
  1.  ..I "^18^23^24^41^65^94^108^"[("^"_ECXTS_"^") S ECXDSSI=$$TSMAP^ECXUTL4(ECXTS)
  1.  .;
  1.  .;- Observation patient indicator (YES/NO)
  1.  .S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXDSSI)
  1.  .;
  1.  .;- set national patient record flag if exist
  1.  .D NPRF^ECXUTL5
  1.  .;
  1.  .;- If no encounter number don't file record
  1.  .S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC=""
  1.  .S ECD=ECXDATE,ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM)
  1.  .;adjust scale name & scale number
  1.  .S ECXSCNAM=$E(ECXSCNAM,1,10)
  1.  .I ECXSCNUM]"",ECXSCNUM'=+ECXSCNUM S ECXSCNUM=+$E(ECXSCNUM,2,99)
  1.  .N ECXDEPT S ECXDEPT="" ;dss department use postponed S ECXDEPT=$$MTL^ECXDEPT(ECXDIV,ECXSCNAM,ECINST) ;p-46 line added
  1.  .;Set division to external value if extract is for FY05 or higher
  1.  .D FILE
  1.  Q
  1.  ;
  1. PAT(ECXDFN,ECXDATE) ;determine in/outpatient status, demographics, primary care
  1.  N OK
  1.  S (ECXADT,ECXPNM,ECXSSN,ECXMPI)=""
  1.  K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;3;5;",.ECXPAT)
  1.  S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
  1.  S ECXDOB=ECXPAT("DOB")
  1.  ;agent orange status
  1.  S ECXAST=ECXPAT("AO STAT")
  1.  ;- Purple Heart Indicator, Period of Service, Agent Orange Location
  1.  S ECXPHI=$G(ECXPAT("PHI")),ECXPOS=ECXPAT("POS"),ECXAOL=ECXPAT("AOL")
  1.  I $$ENROLLM^ECXUTL2(ECXDFN)
  1.  ;Combat Veteran Status
  1.  S X3=$$CVEDT^ECXUTL5(ECXDFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT))
  1.  ; - Head and Neck Cancer Indicator
  1.  S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
  1.  ; - Race and Ethnicity
  1.  S ECXETH=ECXPAT("ETHNIC")
  1.  S ECXRC1=ECXPAT("RACE1")
  1.  ;get primary care data
  1.  S X=$$PRIMARY^ECXUTL2(ECXDFN,ECXDATE),ECPTTM=$P(X,U)
  1.  S ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
  1.  S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
  1.  ;get inpatient data
  1.  S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3)
  1.  S ECXA=$P(X,U),(ECXADT,ECXADMDT)=$P($P(X,U,4),"."),ECXDCDT=$P($P(X,U,6),".")
  1.  S ECXWPRV=$P(X,U,7),ECXATT=$P(X,U,8)
  1.  S ECWPRNPI=$$NPI^XUSNPI("Individual_ID",ECXWPRV,ECXDATE)
  1.  S:+ECWPRNPI'>0 ECWPRNPI="" S ECWPRNPI=$P(ECWPRNPI,U)
  1.  S ECATTNPI=$$NPI^XUSNPI("Individual_ID",ECXATT,ECXDATE)
  1.  S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U)
  1.  ;Get ward provider and attending phy person classes
  1.  S ECXWPRPC=$P(X,U,11),ECXATTPC=$P(X,U,12)
  1.  I ECXADMDT S ECXADMDT=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM)
  1.  I ECXDCDT S ECXDCDT=$$ECXDATE^ECXUTL(ECXDCDT,ECXYM)
  1.  Q
  1.  ;
  1. PROV(ECXPRV,ECXDATE) ;get provider data
  1.  N INST,DGIEN,ARR,DIC,DR,DA,DIQ
  1.  S ECXPRCLS=$$PRVCLASS^ECXUTL(ECXPRV,ECXDATE)
  1.  S ECPRNPI=$$NPI^XUSNPI("Individual_ID",ECXPRV,ECXDATE)
  1.  S:+ECPRNPI'>0 ECPRNPI="" S ECPRNPI=$P(ECPRNPI,U)
  1.  ;get division identifier using provider
  1.  S (ECXDIV,ECXPDIV)=""
  1.  S IEN=0 F  D  Q:'IEN  Q:'INST  Q:ECXDIV
  1.  .;get pointer to file #4 from provider record
  1.  .I '$D(^VA(200,ECXPRV,0)) Q
  1.  .S IEN=$O(^VA(200,ECXPRV,2,IEN))
  1.  .Q:'IEN
  1.  .S DIC="^VA(200,",DR="16",DA=ECXPRV
  1.  .S DR(200.02)=".01",DA(200.02)=IEN,DIQ="ARR",DIQ(0)="I"
  1.  .D EN^DIQ1
  1.  .S INST=$G(ARR(200.02,IEN,.01,"I"))
  1.  .Q:'INST
  1.  .;get production division
  1.  .S ECXPDIV=$$RADDIV^ECXDEPT(INST) ;p-46 line added
  1.  .;get medical center division
  1.  .S DGIEN=$O(^DG(40.8,"AD",INST,0)) I DGIEN D
  1.  ..S ECXDIV=$P($G(^ECX(727.3,DGIEN,0)),U,2)
  1.  S ECXPRV="2"_ECXPRV
  1.  Q
  1.  ;
  1. FILE ;file record in #727.812
  1.  ;node0
  1.  ;facility^dfn^ssn ECXSSN^name ECXPNM^i/o status ECXA^
  1.  ;day ECXDATE^division ECXDIV^admit date ECXADMDT^
  1.  ;d/c date ECXDCDT^dss id ECXDSSI^pc team ECPTTM^pc provider ECPTPR^
  1.  ;placeholder^pc prov person class ECCLAS^
  1.  ;provider ECXPRV^placeholder^prov person class ECXPRCLS^
  1.  ;test name ECXSCNAM(?)^test ien ECXSCNUM(?)^scale number^scale name^
  1.  ;test score^scale score^attend phys^ward provider
  1.  ;node1
  1.  ;mpi^assoc pc provider^placeholder^
  1.  ;assoc pc prov person class^asi class^asi special^asi encounter date^
  1.  ;purple heart ind.^dom prrtp & saartp ind.^enrollment cat^
  1.  ;enrollment stat^enrollment prior^period of serv.^obs. pat ind.^
  1.  ;encounter num^agent orange loc^dob^production division^dss
  1.  ;department ECXDEPT^head & neck canc. indi.^ethnicity^race1^^
  1.  ;enrollment prior ECXPRIOR_enrollment subgroup
  1.  ;ECXSBGRP^enrollee user ECXUESTA^division ECXDIV^patient type
  1.  ;ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^
  1.  ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI
  1.  ;attending phy person class ECXATTPC^ward provider person class 
  1.  ;ECXWPRPC^^agent orange status ECXAST^asso prov npi ECASNPI^att phy
  1.  ;npi ECATTNPI^primary care prov npi ECPTNPI^provider npi ECPRNPI^ward
  1.  ;provider npi ECWPRNPI
  1.  N DA,DIK,STR
  1.  I $P(^ECX(ECFILE,JJ,0),U,21)="ASI" S $P(^ECX(ECFILE,JJ,1),U,7)=ECXDATE
  1.  S $P(^ECX(ECFILE,JJ,0),U,6,9)=ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE
  1.  S STR=$S(ECXLOGIC<2005:ECXDIV,1:"")_U_ECXADMDT_U_ECXDCDT_U_ECXDSSI_U_ECPTTM_U_ECPTPR_U
  1.  S STR=STR_U_ECCLAS,$P(^ECX(ECFILE,JJ,0),U,10,17)=STR,STR=""
  1.  S $P(^ECX(ECFILE,JJ,0),U,18,20)=ECXPRV_U_U_ECXPRCLS
  1.  S $P(^ECX(ECFILE,JJ,0),U,23,24)=ECXSCNUM_U_ECXSCNAM
  1.  S $P(^ECX(ECFILE,JJ,0),U,27,29)=ECXATT_U_ECXWPRV_U
  1.  I '$D(^ECX(ECFILE,JJ,1)) S ^ECX(727.812,JJ,1)="^^^^^"
  1.  S $P(^ECX(ECFILE,JJ,1),U,1,4)=ECXMPI_U_ECASPR_U_U_ECCLAS2
  1.  S STR=ECXPHI_U_ECXDOM_U_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U
  1.  S STR=STR_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXDOB_U_ECXPDIV_U_ECXDEPT_U
  1.  S STR=STR_ECXHNCI_U_ECXETH_U_ECXRC1_U
  1.  I ECXLOGIC>2004 S STR=STR_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXDIV_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
  1.  I ECXLOGIC>2005 S STR=STR_U_ECXATTPC_U_ECXWPRPC
  1.  S $P(^ECX(ECFILE,JJ,1),U,8,22)=STR
  1.  I ECXLOGIC>2006 S $P(^ECX(ECFILE,JJ,1),U,34)=ECXAST_U
  1.  I ECXLOGIC>2007 S $P(^ECX(ECFILE,JJ,1),U,35)=ECASNPI_U_ECATTNPI_U_ECPTNPI_U D
  1.  . S ^ECX(ECFILE,JJ,2)=ECPRNPI_U_ECWPRNPI
  1.  S DA=JJ,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
  1.  S ECRN=ECRN+1
  1.  I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
  1.  Q
  1.  ;
  1. SETUP ;Set required input for ECXTRAC
  1.  S ECHEAD="MTL"
  1.  D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
  1.  Q
  1.  ;
  1. QUE ;Entry point for the background requeuing handled by ECXTAUTO.
  1.  D SETUP,QUE^ECXTAUTO,^ECXKILL
  1.  Q