ECXTRT ;ALB/JAP,BIR/DMA,CML,PTD-Treating Specialty Change Extract ;6/29/18 14:57
;;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
BEG ;entry point from option
D SETUP I ECFILE="" Q
D ^ECXTRAC,^ECXKILL
Q
;
START ; start package specific extract
N LOC,SPC,TRT,WRD,ECATLNPI,ECPRLNPI,ECXADMTM,ECXATLPC,ECXATNPC,ECXDCDT,ECXPRLPC,ECXPRNPC,ECXMOVL,ECXMOVN,ECXMVD1,ECXMVD2,ECXTIME,REC ;161,166
N ECXDWARD,TEMPPDIV,ECXASIH ;166 tjl,170
N ECXDCTM,ECD1,ECD2,ECPRO ;190
S QFLG=0
K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
K ^TMP($J,"ECXTMP"),^TMP($J,"ECXTRTMM") S TRT=0 ;190 - Clear Mailman Message tmp global
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
S ECED=ECED+.3,ECD=ECSD1
;loop through type 6 movements to get treating specialty and provider changes
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
.I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG
..S ECXMVD1=$P(EC,U) ; ,WRD=$P(EC,U,6) 166 tjl
..N ECXNMPI,ECXCERN,ECXSIGI ;184
..;
..;- Call sets ECXA (In/Out indicator)
..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD1,"1;",13)
..S ECXNMPI=ECXMPI ;184
..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U)
..;skip the record if its the admission treat. spec. change for this episode of care
..Q:ECXADM=$P(EC,U,24)
..S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD=""
..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC)
..;get data for current (new) ts movement
..S ECD1=9999999.9999999-ECXMVD1
..I '+ECXMVD1 D SETTMP("MISSING MOVEMENT DATE",ECDA,ECXMVD1,ECXDFN,ECXADM) Q ;190 - if missing movement date, log error and skip record
..D FINDLOC(ECD1,.LOC,.ECXSPCN,.ECXPRVN,.ECXATTN,.ECXMOVN,.ECXTRTN)
..Q:ECXSPCN=""
..S ECD2=$O(LOC(ECD1)) Q:ECD2=""
..S ECXMVD2=9999999.9999999-ECD2
..;get data for previous (losing) ts movement
..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
..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL)
..;if ts has changed, find los on losing ts
..D:ECXTRTL'=ECXTRTN PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS)
..;whether ts has changed or not, see if primary provider has changed
..;don't bother if there's no data on current primary provider or no change in provider
..D:(ECXPRVN'="")&(ECXPRVN'=ECXPRVL) PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP)
..;whether ts has changed or not, see if attending physician has changed
..;don't bother if there's no data on current attending physician or no change in attending
..D:(ECXATTN'="")&(ECXATTN'=ECXATTL) PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA)
..S ECXDATE=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1)
..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT),ECXDCDT="",ECXDCTM="" ;190
..;- Production Division
..S ECXPDIV=""
..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD))
..;
..;- Observation patient indicator (YES/NO)
..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
..;
..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule)
..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I"
..; ******* - PATCH 127, ADD PATCAT CODE ********
..S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
..;
..;- Get providers person classes
.. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT)
.. S ECATLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTL,2,999),ECXADT)
.. S:+ECATLNPI'>0 ECATLNPI="" S ECATLNPI=$P(ECATLNPI,U)
.. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT)
.. S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVN,2,999),ECXADT)
.. S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U)
.. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT)
.. S ECATTNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTN,2,999),ECXADT)
.. S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U)
.. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT)
.. S ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVL,2,999),ECXADT)
.. S:+ECPRLNPI'>0 ECPRLNPI="" S ECPRLNPI=$P(ECPRLNPI,U)
..;
..;- If no encounter number, don't file record
..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,)
..I $G(ECXASIH) S ECXA="A" ;170
..D:ECXENC'="" FILE^ECXTRT2
;for nhcu episodes with intervening asih stays, the los calculated here is not accurate,
;but it never has been; this is best solution within current extract framework;
;at discharge the los calculated for nhcu episodes will be the los since admission w/o asih los subtracted;
;
;loop through discharges to get last treating specialty
S ECD=ECSD1
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
.I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG
..S ECXMVD1=$P(EC,U) ;WRD=$P(EC,U,6) 166 tjl
..S (ECXDATE,ECXDCDT)=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),(ECXTIME,ECXDCTM)=$$ECXTIME^ECXUTL(ECXMVD1) ;190
..I ECXDCDT'>0 S ECXDCDT=""
..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U,1)
..S (ECXTRTN,ECXSPCN,ECXPRVN,ECXATTN)="" S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD=""
..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC)
..S ECD1=9999999.9999999-ECXMVD1
..;get ts change just before d/c
..S ECD2=$O(LOC(ECD1)),ECXMVD2=9999999.9999999-ECD2
..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
..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL)
..;
..;- Call sets ECXA (In/Out indicator) using date before discharge
..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD2,"1;",13)
..S ECXNMPI=ECXMPI ;184
..S WRD=$P($G(ECXDWARD),U) ;166 tjl - Set Production Division Code based on Ward at Discharge
..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT)
..;if closest ts change is admission ts, cant go back any further
..S TRT=$O(LOC(ECD2,0)),REC=$O(LOC(ECD2,TRT,0))
..I REC=ECXADM D
...S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOS=X
...I ECXPRVL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSP=X
...I ECXATTL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSA=X
..;otherwise, need to find when change to last ts occurred
..I REC'=ECXADM D
...D PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS)
...D PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP)
...D PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA)
..S:ECXLOS>9999 ECXLOS=9999 S:ECXLOSA>9999 ECXLOSA=9999
..S:ECXLOSP>9999 ECXLOSP=9999
..;- Production Division
..S ECXPDIV=""
..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD))
..;
..;- Observation patient indicator (YES/NO)
..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
..;
..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule)
..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I"
..; ******* - PATCH 127, ADD PATCAT CODE ********
..S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
..;
..;- Get providers person classes
.. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT)
.. S ECATLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTL,2,999),ECXADT)
.. S:+ECATLNPI'>0 ECATLNPI="" S ECATLNPI=$P(ECATLNPI,U)
.. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT)
.. S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVN,2,999),ECXADT)
.. S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U)
.. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT)
.. S ECATTNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTN,2,999),ECXADT)
.. S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U)
.. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT)
.. S ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVL,2,999),ECXADT)
.. S:+ECPRLNPI'>0 ECPRLNPI="" S ECPRLNPI=$P(ECPRLNPI,U)
..;
..;- If no encounter number don't file record
..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,)
..I $G(ECXASIH) S ECXA="A" ;170
..D:ECXENC'="" FILE^ECXTRT2
I $D(^TMP($J,"ECXTRTMM")) D SENDMSG
D KPATDEM^ECXUTL2
Q
;
NPDIV(WRD) ;National Production Division
N DIV
S DIV=$$GET1^DIQ(42,WRD,.015,"I")
Q $S(DIV="":"",1:$$GETDIV^ECXDEPT(DIV))
;
SETLOC(ECXDFN,ECXADM,ECXPRO,ECXLOC) ;setup the local array from the ATS index
; output
; ECXLOC = local array (passed by reference)
;
N SUB3,SUB4,SUB5,SPC,PRV,ATT,MOV
S SUB3=0
F S SUB3=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3)) Q:SUB3="" D
.S (SUB4,SUB5)=0
.S SUB4=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4))
.S SUB5=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4,SUB5))
.S ECXLOC(SUB3,SUB4,SUB5)="",SPC=$G(^TMP($J,"ECXTMP",SUB4))
.S DATA=$G(^DGPM(SUB5,0)),PRV=$P(DATA,U,8),ATT=$P(DATA,U,19)
.S MOV=$P(DATA,U,14)
.S:PRV]"" PRV=ECXPRO_PRV S:ATT]"" ATT=ECXPRO_ATT
.S ECXLOC(SUB3,SUB4,SUB5)=SPC_U_PRV_U_ATT_U_MOV
Q
;
FINDLOC(ECXTSD,ECXLOC,ECXSPC,ECXPRV,ECXATT,ECXMOV,ECXTRT) ;find local array node for current ts movement
; input
; ECXTSD = inverse date/time for current ts movement; required
; ECXLOC = local array; passed by reference; required
; output; data from record contained in MOVE
; ECXSPC = piece 1 of LOC (passed by reference)
; ECXPRV = piece 2 of LOC concatenated to PRO (passed by reference)
; ECXATT = piece 3 of LOC concatenated to PRO (passed by reference)
; ECXMOV = piece 4 of LOC (passed by reference)
; ECXTRT = pointer to file #45.7
;
N SUB3,SUB4,SUB5,LOC
S (ECXSPC,ECXPRV,ECXATT,ECXMOV)=""
S SUB3=ECXTSD
I $D(ECXLOC(SUB3)) D
.S SUB4=$O(ECXLOC(SUB3,0)),SUB5=$O(ECXLOC(SUB3,SUB4,0))
.S LOC=ECXLOC(SUB3,SUB4,SUB5),ECXTRT=SUB4,ECXSPC=$P(LOC,U)
.S ECXPRV=$P(LOC,U,2),ECXATT=$P(LOC,U,3),ECXMOV=$P(LOC,U,4)
Q
;
SETUP ;Set required input for ECXTRAC
S ECHEAD="TRT"
D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
Q
;
QUE ; entry point for the background requeuing handled by ECXTAUTO
D SETUP,QUE^ECXTAUTO,^ECXKILL
Q
SETTMP(ERRMSG,ECDA,ECDATE,DFN,ECADM) ;190 Set TMP global for MM messages
N ECMOVDT,VADM,ECXSSN,PTNAME,ECADMDT,ECDIS,ECDISDT
S PTNAME=$$GET1^DIQ(2,DFN,.01,"I")
I PTNAME["ZZ" Q ;don't include test patients
D DEM^VADPT
S ECMOVDT=$$FMTE^XLFDT(ECDATE,"2M")
S SSN=$P(VADM(2),U)
S ECADMDT=$$GET1^DIQ(405,ECADM_",",.01,"I"),ECDIS=$$GET1^DIQ(405,ECADM_",",.17,"I")
; If we couldn't get the discharge date from the admission movement and this *is* the discharge movement
; then use this movement's date
I '+ECDIS,$$GET1^DIQ(405,ECDA_",",.02,"I")=3 S ECDIS=ECDA
S ECDISDT=$$GET1^DIQ(405,ECDIS_",",.01,"I")
S ECADMDT=$$FMTE^XLFDT(ECADMDT,"2M"),ECDISDT=$$FMTE^XLFDT(ECDISDT,"2M")
S ^TMP($J,"ECXTRTMM",ERRMSG,DFN,ECDA)=VADM(1)_U_SSN_U_ECMOVDT_U_ECDA_U_ECADMDT_U_ECDISDT
Q
;
SENDMSG ;190 Send error MM messages
N ERRMSG,ECMSG,ECDFN,ECSSN,ECSTR,ECDA,I,J,XMY,XMDUZ,XMSUB,XMTEXT
I '$D(^TMP($J,"ECXTRTMM")) Q
S XMSUB="RECORDS NOT PROCESSED in DSS-"_ECPACK_" Extract" ; (#"_$P(EC23,U,2)_")"
K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="",XMDUZ="DSS SYSTEM"
S ECMSG(1,0)="Because of missing information in the PATIENT MOVEMENT file (#405), the"
S ECMSG(2,0)="following records were not included in the DSS-TREATING SPECIALTY CHANGE"
S ECMSG(3,0)="EXTRACT (#"_$P(EC23,U,2)_") for the dates from "_ECSDN_" to "_ECEDN_"."
S ECMSG(4,0)=""
S ERRMSG="",J=0
F I=1:1 S ERRMSG=$O(^TMP($J,"ECXTRTMM",ERRMSG)) Q:ERRMSG="" D
. S ECMSG(5*I+J,0)="*** "_ERRMSG_" ***",J=J+1
. S ECMSG(5*I+J,0)=" MOVEMENT",J=J+1
. S ECMSG(5*I+J,0)="PATIENT NAME SSN MOVEMENT DATE/TIME IEN",J=J+1
. S ECMSG(5*I+J,0)=" ADMISSION DATE/TIME DISCHARGE DATE/TIME ",J=J+1
. S ECMSG(5*I+J,0)="-------------------------------------------------------------------------------",J=J+1
. S ECDFN=""
. F J=J:1 S ECDFN=$O(^TMP($J,"ECXTRTMM",ERRMSG,ECDFN)) Q:ECDFN="" D
.. S ECDA=0
.. F S ECDA=$O(^TMP($J,"ECXTRTMM",ERRMSG,ECDFN,ECDA)) Q:ECDA="" D
... S ECSTR=^TMP($J,"ECXTRTMM",ERRMSG,ECDFN,ECDA) S (ACADM,ECDIS)=""
... S ECADM=$$GET1^DIQ(405,ECDA_",",.16),ECDIS=$$GET1^DIQ(405,ECDA_",",.17)
... 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
... S ECMSG(5*I+J,0)=" "_$$LJ^XLFSTR($P(ECSTR,U,5),30)_" "_$$LJ^XLFSTR($P(ECSTR,U,6),30),J=J+1
. S J=J+1,ECMSG(5*I+J,0)=""
S XMTEXT="ECMSG("
D ^XMD
K ^TMP($J,"ECXTRTMM")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXTRT 12736 printed Dec 13, 2024@01:54:07 Page 2
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
BEG ;entry point from option
+1 DO SETUP
IF ECFILE=""
QUIT
+2 DO ^ECXTRAC
DO ^ECXKILL
+3 QUIT
+4 ;
START ; start package specific extract
+1 ;161,166
NEW LOC,SPC,TRT,WRD,ECATLNPI,ECPRLNPI,ECXADMTM,ECXATLPC,ECXATNPC,ECXDCDT,ECXPRLPC,ECXPRNPC,ECXMOVL,ECXMOVN,ECXMVD1,ECXMVD2,ECXTIME,REC
+2 ;166 tjl,170
NEW ECXDWARD,TEMPPDIV,ECXASIH
+3 ;190
NEW ECXDCTM,ECD1,ECD2,ECPRO
+4 SET QFLG=0
+5 KILL ECXDD
DO FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
+6 SET ECPRO=$EXTRACT(+$PIECE(ECXDD("SPECIFIER"),"P",2))
KILL ECXDD
+7 ;190 - Clear Mailman Message tmp global
KILL ^TMP($JOB,"ECXTMP"),^TMP($JOB,"ECXTRTMM")
SET TRT=0
+8 FOR
SET TRT=$ORDER(^DIC(45.7,TRT))
if +TRT=0
QUIT
SET SPC=$PIECE(^DIC(45.7,TRT,0),U,2)
SET ^TMP($JOB,"ECXTMP",TRT)=SPC
+9 SET ECED=ECED+.3
SET ECD=ECSD1
+10 ;loop through type 6 movements to get treating specialty and provider changes
+11 FOR
SET ECD=$ORDER(^DGPM("ATT6",ECD))
SET ECDA=0
if ('ECD)!(ECD>ECED)!(QFLG)
QUIT
FOR
SET ECDA=$ORDER(^DGPM("ATT6",ECD,ECDA))
if 'ECDA
QUIT
Begin DoDot:1
+12 IF $DATA(^DGPM(ECDA,0))
SET EC=^(0)
SET ECXDFN=+$PIECE(EC,U,3)
Begin DoDot:2
+13 ; ,WRD=$P(EC,U,6) 166 tjl
SET ECXMVD1=$PIECE(EC,U)
+14 ;184
NEW ECXNMPI,ECXCERN,ECXSIGI
+15 ;
+16 ;- Call sets ECXA (In/Out indicator)
+17 if '$$PATDEM^ECXUTL2(ECXDFN,ECXMVD1,"1;",13)
QUIT
+18 ;184
SET ECXNMPI=ECXMPI
+19 SET ECMT=$PIECE(EC,U,18)
SET ECXADM=$PIECE(EC,U,14)
SET ECXADT=$PIECE($GET(^DGPM(ECXADM,0)),U)
+20 ;skip the record if its the admission treat. spec. change for this episode of care
+21 if ECXADM=$PIECE(EC,U,24)
QUIT
+22 SET (ECXLOS,ECXLOSA,ECXLOSP)=""
SET ECXDSSD=""
+23 KILL LOC
DO SETLOC(ECXDFN,ECXADM,ECPRO,.LOC)
+24 ;get data for current (new) ts movement
+25 SET ECD1=9999999.9999999-ECXMVD1
+26 ;190 - if missing movement date, log error and skip record
IF '+ECXMVD1
DO SETTMP("MISSING MOVEMENT DATE",ECDA,ECXMVD1,ECXDFN,ECXADM)
QUIT
+27 DO FINDLOC(ECD1,.LOC,.ECXSPCN,.ECXPRVN,.ECXATTN,.ECXMOVN,.ECXTRTN)
+28 if ECXSPCN=""
QUIT
+29 SET ECD2=$ORDER(LOC(ECD1))
if ECD2=""
QUIT
+30 SET ECXMVD2=9999999.9999999-ECD2
+31 ;get data for previous (losing) ts movement
+32 ;190 - if missing previous ts movement date, log error and skip record
IF '+ECD2
DO SETTMP("MISSING PREVIOUS TS MOVEMENT DATE/TIME",ECDA,ECXMVD1,ECXDFN,ECXADM)
QUIT
+33 DO FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL)
+34 ;if ts has changed, find los on losing ts
+35 if ECXTRTL'=ECXTRTN
DO PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS)
+36 ;whether ts has changed or not, see if primary provider has changed
+37 ;don't bother if there's no data on current primary provider or no change in provider
+38 if (ECXPRVN'="")&(ECXPRVN'=ECXPRVL)
DO PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP)
+39 ;whether ts has changed or not, see if attending physician has changed
+40 ;don't bother if there's no data on current attending physician or no change in attending
+41 if (ECXATTN'="")&(ECXATTN'=ECXATTL)
DO PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA)
+42 SET ECXDATE=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM)
SET ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1)
+43 ;190
SET ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM)
SET ECXADMTM=$$ECXTIME^ECXUTL(ECXADT)
SET ECXDCDT=""
SET ECXDCTM=""
+44 ;- Production Division
+45 SET ECXPDIV=""
+46 IF ECXLOGIC>2003
SET ECXPDIV=$SELECT(WRD="":"",1:$$NPDIV(WRD))
+47 ;
+48 ;- Observation patient indicator (YES/NO)
+49 SET ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+50 ;
+51 ;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule)
+52 IF ECXA="O"&(ECXOBS="NO")&(ECXMVD1)
SET ECXA="I"
+53 ; ******* - PATCH 127, ADD PATCAT CODE ********
+54 SET ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
+55 ;
+56 ;- Get providers person classes
+57 SET ECXATLPC=$$PRVCLASS^ECXUTL($EXTRACT(ECXATTL,2,999),ECXADT)
+58 SET ECATLNPI=$$NPI^XUSNPI("Individual_ID",$EXTRACT(ECXATTL,2,999),ECXADT)
+59 if +ECATLNPI'>0
SET ECATLNPI=""
SET ECATLNPI=$PIECE(ECATLNPI,U)
+60 SET ECXPRNPC=$$PRVCLASS^ECXUTL($EXTRACT(ECXPRVN,2,999),ECXADT)
+61 SET ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$EXTRACT(ECXPRVN,2,999),ECXADT)
+62 if +ECPRVNPI'>0
SET ECPRVNPI=""
SET ECPRVNPI=$PIECE(ECPRVNPI,U)
+63 SET ECXATNPC=$$PRVCLASS^ECXUTL($EXTRACT(ECXATTN,2,999),ECXADT)
+64 SET ECATTNPI=$$NPI^XUSNPI("Individual_ID",$EXTRACT(ECXATTN,2,999),ECXADT)
+65 if +ECATTNPI'>0
SET ECATTNPI=""
SET ECATTNPI=$PIECE(ECATTNPI,U)
+66 SET ECXPRLPC=$$PRVCLASS^ECXUTL($EXTRACT(ECXPRVL,2,999),ECXADT)
+67 SET ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$EXTRACT(ECXPRVL,2,999),ECXADT)
+68 if +ECPRLNPI'>0
SET ECPRLNPI=""
SET ECPRLNPI=$PIECE(ECPRLNPI,U)
+69 ;
+70 ;- If no encounter number, don't file record
+71 SET ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,)
+72 ;170
IF $GET(ECXASIH)
SET ECXA="A"
+73 if ECXENC'=""
DO FILE^ECXTRT2
End DoDot:2
if QFLG
QUIT
End DoDot:1
if QFLG
QUIT
+74 ;for nhcu episodes with intervening asih stays, the los calculated here is not accurate,
+75 ;but it never has been; this is best solution within current extract framework;
+76 ;at discharge the los calculated for nhcu episodes will be the los since admission w/o asih los subtracted;
+77 ;
+78 ;loop through discharges to get last treating specialty
+79 SET ECD=ECSD1
+80 FOR
SET ECD=$ORDER(^DGPM("ATT3",ECD))
SET ECDA=0
if 'ECD
QUIT
if ECD>ECED
QUIT
FOR
SET ECDA=$ORDER(^DGPM("ATT3",ECD,ECDA))
if 'ECDA
QUIT
Begin DoDot:1
+81 IF $DATA(^DGPM(ECDA,0))
SET EC=^(0)
SET ECXDFN=+$PIECE(EC,U,3)
Begin DoDot:2
+82 ;WRD=$P(EC,U,6) 166 tjl
SET ECXMVD1=$PIECE(EC,U)
+83 ;190
SET (ECXDATE,ECXDCDT)=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM)
SET (ECXTIME,ECXDCTM)=$$ECXTIME^ECXUTL(ECXMVD1)
+84 IF ECXDCDT'>0
SET ECXDCDT=""
+85 SET ECMT=$PIECE(EC,U,18)
SET ECXADM=$PIECE(EC,U,14)
SET ECXADT=$PIECE($GET(^DGPM(ECXADM,0)),U,1)
+86 SET (ECXTRTN,ECXSPCN,ECXPRVN,ECXATTN)=""
SET (ECXLOS,ECXLOSA,ECXLOSP)=""
SET ECXDSSD=""
+87 KILL LOC
DO SETLOC(ECXDFN,ECXADM,ECPRO,.LOC)
+88 SET ECD1=9999999.9999999-ECXMVD1
+89 ;get ts change just before d/c
+90 SET ECD2=$ORDER(LOC(ECD1))
SET ECXMVD2=9999999.9999999-ECD2
+91 ;190 - if missing previous ts movement date, log error and skip record
IF '+ECD2
DO SETTMP("MISSING PREVIOUS TS MOVEMENT DATE",ECDA,ECXMVD1,ECXDFN,ECXADM)
QUIT
+92 DO FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL)
+93 ;
+94 ;- Call sets ECXA (In/Out indicator) using date before discharge
+95 if '$$PATDEM^ECXUTL2(ECXDFN,ECXMVD2,"1;",13)
QUIT
+96 ;184
SET ECXNMPI=ECXMPI
+97 ;166 tjl - Set Production Division Code based on Ward at Discharge
SET WRD=$PIECE($GET(ECXDWARD),U)
+98 SET ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM)
SET ECXADMTM=$$ECXTIME^ECXUTL(ECXADT)
+99 ;if closest ts change is admission ts, cant go back any further
+100 SET TRT=$ORDER(LOC(ECD2,0))
SET REC=$ORDER(LOC(ECD2,TRT,0))
+101 IF REC=ECXADM
Begin DoDot:3
+102 SET X1=ECXMVD1
SET X2=ECXMVD2
DO ^%DTC
SET ECXLOS=X
+103 IF ECXPRVL'=""
SET X1=ECXMVD1
SET X2=ECXMVD2
DO ^%DTC
SET ECXLOSP=X
+104 IF ECXATTL'=""
SET X1=ECXMVD1
SET X2=ECXMVD2
DO ^%DTC
SET ECXLOSA=X
End DoDot:3
+105 ;otherwise, need to find when change to last ts occurred
+106 IF REC'=ECXADM
Begin DoDot:3
+107 DO PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS)
+108 DO PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP)
+109 DO PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA)
End DoDot:3
+110 if ECXLOS>9999
SET ECXLOS=9999
if ECXLOSA>9999
SET ECXLOSA=9999
+111 if ECXLOSP>9999
SET ECXLOSP=9999
+112 ;- Production Division
+113 SET ECXPDIV=""
+114 IF ECXLOGIC>2003
SET ECXPDIV=$SELECT(WRD="":"",1:$$NPDIV(WRD))
+115 ;
+116 ;- Observation patient indicator (YES/NO)
+117 SET ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+118 ;
+119 ;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule)
+120 IF ECXA="O"&(ECXOBS="NO")&(ECXMVD1)
SET ECXA="I"
+121 ; ******* - PATCH 127, ADD PATCAT CODE ********
+122 SET ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
+123 ;
+124 ;- Get providers person classes
+125 SET ECXATLPC=$$PRVCLASS^ECXUTL($EXTRACT(ECXATTL,2,999),ECXADT)
+126 SET ECATLNPI=$$NPI^XUSNPI("Individual_ID",$EXTRACT(ECXATTL,2,999),ECXADT)
+127 if +ECATLNPI'>0
SET ECATLNPI=""
SET ECATLNPI=$PIECE(ECATLNPI,U)
+128 SET ECXPRNPC=$$PRVCLASS^ECXUTL($EXTRACT(ECXPRVN,2,999),ECXADT)
+129 SET ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$EXTRACT(ECXPRVN,2,999),ECXADT)
+130 if +ECPRVNPI'>0
SET ECPRVNPI=""
SET ECPRVNPI=$PIECE(ECPRVNPI,U)
+131 SET ECXATNPC=$$PRVCLASS^ECXUTL($EXTRACT(ECXATTN,2,999),ECXADT)
+132 SET ECATTNPI=$$NPI^XUSNPI("Individual_ID",$EXTRACT(ECXATTN,2,999),ECXADT)
+133 if +ECATTNPI'>0
SET ECATTNPI=""
SET ECATTNPI=$PIECE(ECATTNPI,U)
+134 SET ECXPRLPC=$$PRVCLASS^ECXUTL($EXTRACT(ECXPRVL,2,999),ECXADT)
+135 SET ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$EXTRACT(ECXPRVL,2,999),ECXADT)
+136 if +ECPRLNPI'>0
SET ECPRLNPI=""
SET ECPRLNPI=$PIECE(ECPRLNPI,U)
+137 ;
+138 ;- If no encounter number don't file record
+139 SET ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,)
+140 ;170
IF $GET(ECXASIH)
SET ECXA="A"
+141 if ECXENC'=""
DO FILE^ECXTRT2
End DoDot:2
if QFLG
QUIT
End DoDot:1
if QFLG
QUIT
+142 IF $DATA(^TMP($JOB,"ECXTRTMM"))
DO SENDMSG
+143 DO KPATDEM^ECXUTL2
+144 QUIT
+145 ;
NPDIV(WRD) ;National Production Division
+1 NEW DIV
+2 SET DIV=$$GET1^DIQ(42,WRD,.015,"I")
+3 QUIT $SELECT(DIV="":"",1:$$GETDIV^ECXDEPT(DIV))
+4 ;
SETLOC(ECXDFN,ECXADM,ECXPRO,ECXLOC) ;setup the local array from the ATS index
+1 ; output
+2 ; ECXLOC = local array (passed by reference)
+3 ;
+4 NEW SUB3,SUB4,SUB5,SPC,PRV,ATT,MOV
+5 SET SUB3=0
+6 FOR
SET SUB3=$ORDER(^DGPM("ATS",ECXDFN,ECXADM,SUB3))
if SUB3=""
QUIT
Begin DoDot:1
+7 SET (SUB4,SUB5)=0
+8 SET SUB4=$ORDER(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4))
+9 SET SUB5=$ORDER(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4,SUB5))
+10 SET ECXLOC(SUB3,SUB4,SUB5)=""
SET SPC=$GET(^TMP($JOB,"ECXTMP",SUB4))
+11 SET DATA=$GET(^DGPM(SUB5,0))
SET PRV=$PIECE(DATA,U,8)
SET ATT=$PIECE(DATA,U,19)
+12 SET MOV=$PIECE(DATA,U,14)
+13 if PRV]""
SET PRV=ECXPRO_PRV
if ATT]""
SET ATT=ECXPRO_ATT
+14 SET ECXLOC(SUB3,SUB4,SUB5)=SPC_U_PRV_U_ATT_U_MOV
End DoDot:1
+15 QUIT
+16 ;
FINDLOC(ECXTSD,ECXLOC,ECXSPC,ECXPRV,ECXATT,ECXMOV,ECXTRT) ;find local array node for current ts movement
+1 ; input
+2 ; ECXTSD = inverse date/time for current ts movement; required
+3 ; ECXLOC = local array; passed by reference; required
+4 ; output; data from record contained in MOVE
+5 ; ECXSPC = piece 1 of LOC (passed by reference)
+6 ; ECXPRV = piece 2 of LOC concatenated to PRO (passed by reference)
+7 ; ECXATT = piece 3 of LOC concatenated to PRO (passed by reference)
+8 ; ECXMOV = piece 4 of LOC (passed by reference)
+9 ; ECXTRT = pointer to file #45.7
+10 ;
+11 NEW SUB3,SUB4,SUB5,LOC
+12 SET (ECXSPC,ECXPRV,ECXATT,ECXMOV)=""
+13 SET SUB3=ECXTSD
+14 IF $DATA(ECXLOC(SUB3))
Begin DoDot:1
+15 SET SUB4=$ORDER(ECXLOC(SUB3,0))
SET SUB5=$ORDER(ECXLOC(SUB3,SUB4,0))
+16 SET LOC=ECXLOC(SUB3,SUB4,SUB5)
SET ECXTRT=SUB4
SET ECXSPC=$PIECE(LOC,U)
+17 SET ECXPRV=$PIECE(LOC,U,2)
SET ECXATT=$PIECE(LOC,U,3)
SET ECXMOV=$PIECE(LOC,U,4)
End DoDot:1
+18 QUIT
+19 ;
SETUP ;Set required input for ECXTRAC
+1 SET ECHEAD="TRT"
+2 DO ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+3 QUIT
+4 ;
QUE ; entry point for the background requeuing handled by ECXTAUTO
+1 DO SETUP
DO QUE^ECXTAUTO
DO ^ECXKILL
+2 QUIT
SETTMP(ERRMSG,ECDA,ECDATE,DFN,ECADM) ;190 Set TMP global for MM messages
+1 NEW ECMOVDT,VADM,ECXSSN,PTNAME,ECADMDT,ECDIS,ECDISDT
+2 SET PTNAME=$$GET1^DIQ(2,DFN,.01,"I")
+3 ;don't include test patients
IF PTNAME["ZZ"
QUIT
+4 DO DEM^VADPT
+5 SET ECMOVDT=$$FMTE^XLFDT(ECDATE,"2M")
+6 SET SSN=$PIECE(VADM(2),U)
+7 SET ECADMDT=$$GET1^DIQ(405,ECADM_",",.01,"I")
SET ECDIS=$$GET1^DIQ(405,ECADM_",",.17,"I")
+8 ; If we couldn't get the discharge date from the admission movement and this *is* the discharge movement
+9 ; then use this movement's date
+10 IF '+ECDIS
IF $$GET1^DIQ(405,ECDA_",",.02,"I")=3
SET ECDIS=ECDA
+11 SET ECDISDT=$$GET1^DIQ(405,ECDIS_",",.01,"I")
+12 SET ECADMDT=$$FMTE^XLFDT(ECADMDT,"2M")
SET ECDISDT=$$FMTE^XLFDT(ECDISDT,"2M")
+13 SET ^TMP($JOB,"ECXTRTMM",ERRMSG,DFN,ECDA)=VADM(1)_U_SSN_U_ECMOVDT_U_ECDA_U_ECADMDT_U_ECDISDT
+14 QUIT
+15 ;
SENDMSG ;190 Send error MM messages
+1 NEW ERRMSG,ECMSG,ECDFN,ECSSN,ECSTR,ECDA,I,J,XMY,XMDUZ,XMSUB,XMTEXT
+2 IF '$DATA(^TMP($JOB,"ECXTRTMM"))
QUIT
+3 ; (#"_$P(EC23,U,2)_")"
SET XMSUB="RECORDS NOT PROCESSED in DSS-"_ECPACK_" Extract"
+4 KILL XMY
SET XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
SET XMDUZ="DSS SYSTEM"
+5 SET ECMSG(1,0)="Because of missing information in the PATIENT MOVEMENT file (#405), the"
+6 SET ECMSG(2,0)="following records were not included in the DSS-TREATING SPECIALTY CHANGE"
+7 SET ECMSG(3,0)="EXTRACT (#"_$PIECE(EC23,U,2)_") for the dates from "_ECSDN_" to "_ECEDN_"."
+8 SET ECMSG(4,0)=""
+9 SET ERRMSG=""
SET J=0
+10 FOR I=1:1
SET ERRMSG=$ORDER(^TMP($JOB,"ECXTRTMM",ERRMSG))
if ERRMSG=""
QUIT
Begin DoDot:1
+11 SET ECMSG(5*I+J,0)="*** "_ERRMSG_" ***"
SET J=J+1
+12 SET ECMSG(5*I+J,0)=" MOVEMENT"
SET J=J+1
+13 SET ECMSG(5*I+J,0)="PATIENT NAME SSN MOVEMENT DATE/TIME IEN"
SET J=J+1
+14 SET ECMSG(5*I+J,0)=" ADMISSION DATE/TIME DISCHARGE DATE/TIME "
SET J=J+1
+15 SET ECMSG(5*I+J,0)="-------------------------------------------------------------------------------"
SET J=J+1
+16 SET ECDFN=""
+17 FOR J=J:1
SET ECDFN=$ORDER(^TMP($JOB,"ECXTRTMM",ERRMSG,ECDFN))
if ECDFN=""
QUIT
Begin DoDot:2
+18 SET ECDA=0
+19 FOR
SET ECDA=$ORDER(^TMP($JOB,"ECXTRTMM",ERRMSG,ECDFN,ECDA))
if ECDA=""
QUIT
Begin DoDot:3
+20 SET ECSTR=^TMP($JOB,"ECXTRTMM",ERRMSG,ECDFN,ECDA)
SET (ACADM,ECDIS)=""
+21 SET ECADM=$$GET1^DIQ(405,ECDA_",",.16)
SET ECDIS=$$GET1^DIQ(405,ECDA_",",.17)
+22 SET ECMSG(5*I+J,0)=$$LJ^XLFSTR($PIECE(ECSTR,U),30)_" "_$$LJ^XLFSTR($PIECE(ECSTR,U,2),11)_" "_$$LJ^XLFSTR($PIECE(ECSTR,U,3),20)_" "_$$LJ^XLFSTR(ECDA,12)
SET J=J+1
+23 SET ECMSG(5*I+J,0)=" "_$$LJ^XLFSTR($PIECE(ECSTR,U,5),30)_" "_$$LJ^XLFSTR($PIECE(ECSTR,U,6),30)
SET J=J+1
End DoDot:3
End DoDot:2
+24 SET J=J+1
SET ECMSG(5*I+J,0)=""
End DoDot:1
+25 SET XMTEXT="ECMSG("
+26 DO ^XMD
+27 KILL ^TMP($JOB,"ECXTRTMM")
+28 QUIT
