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

ECXTRT.m

Go to the documentation of this file.
  1. ECXTRT ;ALB/JAP,BIR/DMA,CML,PTD-Treating Specialty Change Extract ;6/29/18 14:57
  1. ;;3.0;DSS EXTRACTS;**1,8,17,24,33,35,39,46,49,84,107,105,127,161,166,170,184,190**;Dec 22, 1997;Build 36
  1. BEG ;entry point from option
  1. D SETUP I ECFILE="" Q
  1. D ^ECXTRAC,^ECXKILL
  1. Q
  1. ;
  1. START ; start package specific extract
  1. N LOC,SPC,TRT,WRD,ECATLNPI,ECPRLNPI,ECXADMTM,ECXATLPC,ECXATNPC,ECXDCDT,ECXPRLPC,ECXPRNPC,ECXMOVL,ECXMOVN,ECXMVD1,ECXMVD2,ECXTIME,REC ;161,166
  1. N ECXDWARD,TEMPPDIV,ECXASIH ;166 tjl,170
  1. N ECXDCTM,ECD1,ECD2,ECPRO ;190
  1. S QFLG=0
  1. K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
  1. S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
  1. K ^TMP($J,"ECXTMP"),^TMP($J,"ECXTRTMM") S TRT=0 ;190 - Clear Mailman Message tmp global
  1. F S TRT=$O(^DIC(45.7,TRT)) Q:+TRT=0 S SPC=$P(^DIC(45.7,TRT,0),U,2),^TMP($J,"ECXTMP",TRT)=SPC
  1. S ECED=ECED+.3,ECD=ECSD1
  1. ;loop through type 6 movements to get treating specialty and provider changes
  1. F S ECD=$O(^DGPM("ATT6",ECD)),ECDA=0 Q:('ECD)!(ECD>ECED)!(QFLG) F S ECDA=$O(^DGPM("ATT6",ECD,ECDA)) Q:'ECDA D Q:QFLG
  1. .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG
  1. ..S ECXMVD1=$P(EC,U) ; ,WRD=$P(EC,U,6) 166 tjl
  1. ..N ECXNMPI,ECXCERN,ECXSIGI ;184
  1. ..;
  1. ..;- Call sets ECXA (In/Out indicator)
  1. ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD1,"1;",13)
  1. ..S ECXNMPI=ECXMPI ;184
  1. ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U)
  1. ..;skip the record if its the admission treat. spec. change for this episode of care
  1. ..Q:ECXADM=$P(EC,U,24)
  1. ..S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD=""
  1. ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC)
  1. ..;get data for current (new) ts movement
  1. ..S ECD1=9999999.9999999-ECXMVD1
  1. ..I '+ECXMVD1 D SETTMP("MISSING MOVEMENT DATE",ECDA,ECXMVD1,ECXDFN,ECXADM) Q ;190 - if missing movement date, log error and skip record
  1. ..D FINDLOC(ECD1,.LOC,.ECXSPCN,.ECXPRVN,.ECXATTN,.ECXMOVN,.ECXTRTN)
  1. ..Q:ECXSPCN=""
  1. ..S ECD2=$O(LOC(ECD1)) Q:ECD2=""
  1. ..S ECXMVD2=9999999.9999999-ECD2
  1. ..;get data for previous (losing) ts movement
  1. ..I '+ECD2 D SETTMP("MISSING PREVIOUS TS MOVEMENT DATE/TIME",ECDA,ECXMVD1,ECXDFN,ECXADM) Q ;190 - if missing previous ts movement date, log error and skip record
  1. ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL)
  1. ..;if ts has changed, find los on losing ts
  1. ..D:ECXTRTL'=ECXTRTN PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS)
  1. ..;whether ts has changed or not, see if primary provider has changed
  1. ..;don't bother if there's no data on current primary provider or no change in provider
  1. ..D:(ECXPRVN'="")&(ECXPRVN'=ECXPRVL) PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP)
  1. ..;whether ts has changed or not, see if attending physician has changed
  1. ..;don't bother if there's no data on current attending physician or no change in attending
  1. ..D:(ECXATTN'="")&(ECXATTN'=ECXATTL) PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA)
  1. ..S ECXDATE=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1)
  1. ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT),ECXDCDT="",ECXDCTM="" ;190
  1. ..;- Production Division
  1. ..S ECXPDIV=""
  1. ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD))
  1. ..;
  1. ..;- Observation patient indicator (YES/NO)
  1. ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
  1. ..;
  1. ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule)
  1. ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I"
  1. ..; ******* - PATCH 127, ADD PATCAT CODE ********
  1. ..S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
  1. ..;
  1. ..;- Get providers person classes
  1. .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT)
  1. .. S ECATLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTL,2,999),ECXADT)
  1. .. S:+ECATLNPI'>0 ECATLNPI="" S ECATLNPI=$P(ECATLNPI,U)
  1. .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT)
  1. .. S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVN,2,999),ECXADT)
  1. .. S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U)
  1. .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT)
  1. .. S ECATTNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTN,2,999),ECXADT)
  1. .. S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U)
  1. .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT)
  1. .. S ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVL,2,999),ECXADT)
  1. .. S:+ECPRLNPI'>0 ECPRLNPI="" S ECPRLNPI=$P(ECPRLNPI,U)
  1. ..;
  1. ..;- If no encounter number, don't file record
  1. ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,)
  1. ..I $G(ECXASIH) S ECXA="A" ;170
  1. ..D:ECXENC'="" FILE^ECXTRT2
  1. ;for nhcu episodes with intervening asih stays, the los calculated here is not accurate,
  1. ;but it never has been; this is best solution within current extract framework;
  1. ;at discharge the los calculated for nhcu episodes will be the los since admission w/o asih los subtracted;
  1. ;
  1. ;loop through discharges to get last treating specialty
  1. S ECD=ECSD1
  1. F S ECD=$O(^DGPM("ATT3",ECD)),ECDA=0 Q:'ECD Q:ECD>ECED F S ECDA=$O(^DGPM("ATT3",ECD,ECDA)) Q:'ECDA D Q:QFLG
  1. .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG
  1. ..S ECXMVD1=$P(EC,U) ;WRD=$P(EC,U,6) 166 tjl
  1. ..S (ECXDATE,ECXDCDT)=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),(ECXTIME,ECXDCTM)=$$ECXTIME^ECXUTL(ECXMVD1) ;190
  1. ..I ECXDCDT'>0 S ECXDCDT=""
  1. ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U,1)
  1. ..S (ECXTRTN,ECXSPCN,ECXPRVN,ECXATTN)="" S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD=""
  1. ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC)
  1. ..S ECD1=9999999.9999999-ECXMVD1
  1. ..;get ts change just before d/c
  1. ..S ECD2=$O(LOC(ECD1)),ECXMVD2=9999999.9999999-ECD2
  1. ..I '+ECD2 D SETTMP("MISSING PREVIOUS TS MOVEMENT DATE",ECDA,ECXMVD1,ECXDFN,ECXADM) Q ;190 - if missing previous ts movement date, log error and skip record
  1. ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL)
  1. ..;
  1. ..;- Call sets ECXA (In/Out indicator) using date before discharge
  1. ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD2,"1;",13)
  1. ..S ECXNMPI=ECXMPI ;184
  1. ..S WRD=$P($G(ECXDWARD),U) ;166 tjl - Set Production Division Code based on Ward at Discharge
  1. ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT)
  1. ..;if closest ts change is admission ts, cant go back any further
  1. ..S TRT=$O(LOC(ECD2,0)),REC=$O(LOC(ECD2,TRT,0))
  1. ..I REC=ECXADM D
  1. ...S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOS=X
  1. ...I ECXPRVL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSP=X
  1. ...I ECXATTL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSA=X
  1. ..;otherwise, need to find when change to last ts occurred
  1. ..I REC'=ECXADM D
  1. ...D PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS)
  1. ...D PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP)
  1. ...D PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA)
  1. ..S:ECXLOS>9999 ECXLOS=9999 S:ECXLOSA>9999 ECXLOSA=9999
  1. ..S:ECXLOSP>9999 ECXLOSP=9999
  1. ..;- Production Division
  1. ..S ECXPDIV=""
  1. ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD))
  1. ..;
  1. ..;- Observation patient indicator (YES/NO)
  1. ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
  1. ..;
  1. ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule)
  1. ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I"
  1. ..; ******* - PATCH 127, ADD PATCAT CODE ********
  1. ..S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
  1. ..;
  1. ..;- Get providers person classes
  1. .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT)
  1. .. S ECATLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTL,2,999),ECXADT)
  1. .. S:+ECATLNPI'>0 ECATLNPI="" S ECATLNPI=$P(ECATLNPI,U)
  1. .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT)
  1. .. S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVN,2,999),ECXADT)
  1. .. S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U)
  1. .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT)
  1. .. S ECATTNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTN,2,999),ECXADT)
  1. .. S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U)
  1. .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT)
  1. .. S ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVL,2,999),ECXADT)
  1. .. S:+ECPRLNPI'>0 ECPRLNPI="" S ECPRLNPI=$P(ECPRLNPI,U)
  1. ..;
  1. ..;- If no encounter number don't file record
  1. ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,)
  1. ..I $G(ECXASIH) S ECXA="A" ;170
  1. ..D:ECXENC'="" FILE^ECXTRT2
  1. I $D(^TMP($J,"ECXTRTMM")) D SENDMSG
  1. D KPATDEM^ECXUTL2
  1. Q
  1. ;
  1. NPDIV(WRD) ;National Production Division
  1. N DIV
  1. S DIV=$$GET1^DIQ(42,WRD,.015,"I")
  1. Q $S(DIV="":"",1:$$GETDIV^ECXDEPT(DIV))
  1. ;
  1. SETLOC(ECXDFN,ECXADM,ECXPRO,ECXLOC) ;setup the local array from the ATS index
  1. ; output
  1. ; ECXLOC = local array (passed by reference)
  1. ;
  1. N SUB3,SUB4,SUB5,SPC,PRV,ATT,MOV
  1. S SUB3=0
  1. F S SUB3=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3)) Q:SUB3="" D
  1. .S (SUB4,SUB5)=0
  1. .S SUB4=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4))
  1. .S SUB5=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4,SUB5))
  1. .S ECXLOC(SUB3,SUB4,SUB5)="",SPC=$G(^TMP($J,"ECXTMP",SUB4))
  1. .S DATA=$G(^DGPM(SUB5,0)),PRV=$P(DATA,U,8),ATT=$P(DATA,U,19)
  1. .S MOV=$P(DATA,U,14)
  1. .S:PRV]"" PRV=ECXPRO_PRV S:ATT]"" ATT=ECXPRO_ATT
  1. .S ECXLOC(SUB3,SUB4,SUB5)=SPC_U_PRV_U_ATT_U_MOV
  1. Q
  1. ;
  1. FINDLOC(ECXTSD,ECXLOC,ECXSPC,ECXPRV,ECXATT,ECXMOV,ECXTRT) ;find local array node for current ts movement
  1. ; input
  1. ; ECXTSD = inverse date/time for current ts movement; required
  1. ; ECXLOC = local array; passed by reference; required
  1. ; output; data from record contained in MOVE
  1. ; ECXSPC = piece 1 of LOC (passed by reference)
  1. ; ECXPRV = piece 2 of LOC concatenated to PRO (passed by reference)
  1. ; ECXATT = piece 3 of LOC concatenated to PRO (passed by reference)
  1. ; ECXMOV = piece 4 of LOC (passed by reference)
  1. ; ECXTRT = pointer to file #45.7
  1. ;
  1. N SUB3,SUB4,SUB5,LOC
  1. S (ECXSPC,ECXPRV,ECXATT,ECXMOV)=""
  1. S SUB3=ECXTSD
  1. I $D(ECXLOC(SUB3)) D
  1. .S SUB4=$O(ECXLOC(SUB3,0)),SUB5=$O(ECXLOC(SUB3,SUB4,0))
  1. .S LOC=ECXLOC(SUB3,SUB4,SUB5),ECXTRT=SUB4,ECXSPC=$P(LOC,U)
  1. .S ECXPRV=$P(LOC,U,2),ECXATT=$P(LOC,U,3),ECXMOV=$P(LOC,U,4)
  1. Q
  1. ;
  1. SETUP ;Set required input for ECXTRAC
  1. S ECHEAD="TRT"
  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
  1. SETTMP(ERRMSG,ECDA,ECDATE,DFN,ECADM) ;190 Set TMP global for MM messages
  1. N ECMOVDT,VADM,ECXSSN,PTNAME,ECADMDT,ECDIS,ECDISDT
  1. S PTNAME=$$GET1^DIQ(2,DFN,.01,"I")
  1. I PTNAME["ZZ" Q ;don't include test patients
  1. D DEM^VADPT
  1. S ECMOVDT=$$FMTE^XLFDT(ECDATE,"2M")
  1. S SSN=$P(VADM(2),U)
  1. S ECADMDT=$$GET1^DIQ(405,ECADM_",",.01,"I"),ECDIS=$$GET1^DIQ(405,ECADM_",",.17,"I")
  1. ; If we couldn't get the discharge date from the admission movement and this *is* the discharge movement
  1. ; then use this movement's date
  1. I '+ECDIS,$$GET1^DIQ(405,ECDA_",",.02,"I")=3 S ECDIS=ECDA
  1. S ECDISDT=$$GET1^DIQ(405,ECDIS_",",.01,"I")
  1. S ECADMDT=$$FMTE^XLFDT(ECADMDT,"2M"),ECDISDT=$$FMTE^XLFDT(ECDISDT,"2M")
  1. S ^TMP($J,"ECXTRTMM",ERRMSG,DFN,ECDA)=VADM(1)_U_SSN_U_ECMOVDT_U_ECDA_U_ECADMDT_U_ECDISDT
  1. Q
  1. ;
  1. SENDMSG ;190 Send error MM messages
  1. N ERRMSG,ECMSG,ECDFN,ECSSN,ECSTR,ECDA,I,J,XMY,XMDUZ,XMSUB,XMTEXT
  1. I '$D(^TMP($J,"ECXTRTMM")) Q
  1. S XMSUB="RECORDS NOT PROCESSED in DSS-"_ECPACK_" Extract" ; (#"_$P(EC23,U,2)_")"
  1. K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="",XMDUZ="DSS SYSTEM"
  1. S ECMSG(1,0)="Because of missing information in the PATIENT MOVEMENT file (#405), the"
  1. S ECMSG(2,0)="following records were not included in the DSS-TREATING SPECIALTY CHANGE"
  1. S ECMSG(3,0)="EXTRACT (#"_$P(EC23,U,2)_") for the dates from "_ECSDN_" to "_ECEDN_"."
  1. S ECMSG(4,0)=""
  1. S ERRMSG="",J=0
  1. F I=1:1 S ERRMSG=$O(^TMP($J,"ECXTRTMM",ERRMSG)) Q:ERRMSG="" D
  1. . S ECMSG(5*I+J,0)="*** "_ERRMSG_" ***",J=J+1
  1. . S ECMSG(5*I+J,0)=" MOVEMENT",J=J+1
  1. . S ECMSG(5*I+J,0)="PATIENT NAME SSN MOVEMENT DATE/TIME IEN",J=J+1
  1. . S ECMSG(5*I+J,0)=" ADMISSION DATE/TIME DISCHARGE DATE/TIME ",J=J+1
  1. . S ECMSG(5*I+J,0)="-------------------------------------------------------------------------------",J=J+1
  1. . S ECDFN=""
  1. . F J=J:1 S ECDFN=$O(^TMP($J,"ECXTRTMM",ERRMSG,ECDFN)) Q:ECDFN="" D
  1. .. S ECDA=0
  1. .. F S ECDA=$O(^TMP($J,"ECXTRTMM",ERRMSG,ECDFN,ECDA)) Q:ECDA="" D
  1. ... S ECSTR=^TMP($J,"ECXTRTMM",ERRMSG,ECDFN,ECDA) S (ACADM,ECDIS)=""
  1. ... S ECADM=$$GET1^DIQ(405,ECDA_",",.16),ECDIS=$$GET1^DIQ(405,ECDA_",",.17)
  1. ... S ECMSG(5*I+J,0)=$$LJ^XLFSTR($P(ECSTR,U),30)_" "_$$LJ^XLFSTR($P(ECSTR,U,2),11)_" "_$$LJ^XLFSTR($P(ECSTR,U,3),20)_" "_$$LJ^XLFSTR(ECDA,12),J=J+1
  1. ... S ECMSG(5*I+J,0)=" "_$$LJ^XLFSTR($P(ECSTR,U,5),30)_" "_$$LJ^XLFSTR($P(ECSTR,U,6),30),J=J+1
  1. . S J=J+1,ECMSG(5*I+J,0)=""
  1. S XMTEXT="ECMSG("
  1. D ^XMD
  1. K ^TMP($J,"ECXTRTMM")
  1. Q