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**;Dec 22, 1997;Build 124
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
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") S TRT=0
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
..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
..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=""
..;- 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=$$ECXTIME^ECXUTL(ECXMVD1)
..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
..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
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXTRT 9534 printed Apr 09, 2024@20:58:52 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**;Dec 22, 1997;Build 124
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 SET QFLG=0
+4 KILL ECXDD
DO FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
+5 SET ECPRO=$EXTRACT(+$PIECE(ECXDD("SPECIFIER"),"P",2))
KILL ECXDD
+6 KILL ^TMP($JOB,"ECXTMP")
SET TRT=0
+7 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
+8 SET ECED=ECED+.3
SET ECD=ECSD1
+9 ;loop through type 6 movements to get treating specialty and provider changes
+10 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
+11 IF $DATA(^DGPM(ECDA,0))
SET EC=^(0)
SET ECXDFN=+$PIECE(EC,U,3)
Begin DoDot:2
+12 ; ,WRD=$P(EC,U,6) 166 tjl
SET ECXMVD1=$PIECE(EC,U)
+13 ;184
NEW ECXNMPI,ECXCERN,ECXSIGI
+14 ;
+15 ;- Call sets ECXA (In/Out indicator)
+16 if '$$PATDEM^ECXUTL2(ECXDFN,ECXMVD1,"1;",13)
QUIT
+17 ;184
SET ECXNMPI=ECXMPI
+18 SET ECMT=$PIECE(EC,U,18)
SET ECXADM=$PIECE(EC,U,14)
SET ECXADT=$PIECE($GET(^DGPM(ECXADM,0)),U)
+19 ;skip the record if its the admission treat. spec. change for this episode of care
+20 if ECXADM=$PIECE(EC,U,24)
QUIT
+21 SET (ECXLOS,ECXLOSA,ECXLOSP)=""
SET ECXDSSD=""
+22 KILL LOC
DO SETLOC(ECXDFN,ECXADM,ECPRO,.LOC)
+23 ;get data for current (new) ts movement
+24 SET ECD1=9999999.9999999-ECXMVD1
+25 DO FINDLOC(ECD1,.LOC,.ECXSPCN,.ECXPRVN,.ECXATTN,.ECXMOVN,.ECXTRTN)
+26 if ECXSPCN=""
QUIT
+27 SET ECD2=$ORDER(LOC(ECD1))
if ECD2=""
QUIT
+28 SET ECXMVD2=9999999.9999999-ECD2
+29 ;get data for previous (losing) ts movement
+30 DO FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL)
+31 ;if ts has changed, find los on losing ts
+32 if ECXTRTL'=ECXTRTN
DO PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS)
+33 ;whether ts has changed or not, see if primary provider has changed
+34 ;don't bother if there's no data on current primary provider or no change in provider
+35 if (ECXPRVN'="")&(ECXPRVN'=ECXPRVL)
DO PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP)
+36 ;whether ts has changed or not, see if attending physician has changed
+37 ;don't bother if there's no data on current attending physician or no change in attending
+38 if (ECXATTN'="")&(ECXATTN'=ECXATTL)
DO PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA)
+39 SET ECXDATE=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM)
SET ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1)
+40 SET ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM)
SET ECXADMTM=$$ECXTIME^ECXUTL(ECXADT)
SET ECXDCDT=""
+41 ;- Production Division
+42 SET ECXPDIV=""
+43 IF ECXLOGIC>2003
SET ECXPDIV=$SELECT(WRD="":"",1:$$NPDIV(WRD))
+44 ;
+45 ;- Observation patient indicator (YES/NO)
+46 SET ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+47 ;
+48 ;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule)
+49 IF ECXA="O"&(ECXOBS="NO")&(ECXMVD1)
SET ECXA="I"
+50 ; ******* - PATCH 127, ADD PATCAT CODE ********
+51 SET ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
+52 ;
+53 ;- Get providers person classes
+54 SET ECXATLPC=$$PRVCLASS^ECXUTL($EXTRACT(ECXATTL,2,999),ECXADT)
+55 SET ECATLNPI=$$NPI^XUSNPI("Individual_ID",$EXTRACT(ECXATTL,2,999),ECXADT)
+56 if +ECATLNPI'>0
SET ECATLNPI=""
SET ECATLNPI=$PIECE(ECATLNPI,U)
+57 SET ECXPRNPC=$$PRVCLASS^ECXUTL($EXTRACT(ECXPRVN,2,999),ECXADT)
+58 SET ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$EXTRACT(ECXPRVN,2,999),ECXADT)
+59 if +ECPRVNPI'>0
SET ECPRVNPI=""
SET ECPRVNPI=$PIECE(ECPRVNPI,U)
+60 SET ECXATNPC=$$PRVCLASS^ECXUTL($EXTRACT(ECXATTN,2,999),ECXADT)
+61 SET ECATTNPI=$$NPI^XUSNPI("Individual_ID",$EXTRACT(ECXATTN,2,999),ECXADT)
+62 if +ECATTNPI'>0
SET ECATTNPI=""
SET ECATTNPI=$PIECE(ECATTNPI,U)
+63 SET ECXPRLPC=$$PRVCLASS^ECXUTL($EXTRACT(ECXPRVL,2,999),ECXADT)
+64 SET ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$EXTRACT(ECXPRVL,2,999),ECXADT)
+65 if +ECPRLNPI'>0
SET ECPRLNPI=""
SET ECPRLNPI=$PIECE(ECPRLNPI,U)
+66 ;
+67 ;- If no encounter number, don't file record
+68 SET ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,)
+69 ;170
IF $GET(ECXASIH)
SET ECXA="A"
+70 if ECXENC'=""
DO FILE^ECXTRT2
End DoDot:2
if QFLG
QUIT
End DoDot:1
if QFLG
QUIT
+71 ;for nhcu episodes with intervening asih stays, the los calculated here is not accurate,
+72 ;but it never has been; this is best solution within current extract framework;
+73 ;at discharge the los calculated for nhcu episodes will be the los since admission w/o asih los subtracted;
+74 ;
+75 ;loop through discharges to get last treating specialty
+76 SET ECD=ECSD1
+77 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
+78 IF $DATA(^DGPM(ECDA,0))
SET EC=^(0)
SET ECXDFN=+$PIECE(EC,U,3)
Begin DoDot:2
+79 ;WRD=$P(EC,U,6) 166 tjl
SET ECXMVD1=$PIECE(EC,U)
+80 SET (ECXDATE,ECXDCDT)=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM)
SET ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1)
+81 IF ECXDCDT'>0
SET ECXDCDT=""
+82 SET ECMT=$PIECE(EC,U,18)
SET ECXADM=$PIECE(EC,U,14)
SET ECXADT=$PIECE($GET(^DGPM(ECXADM,0)),U,1)
+83 SET (ECXTRTN,ECXSPCN,ECXPRVN,ECXATTN)=""
SET (ECXLOS,ECXLOSA,ECXLOSP)=""
SET ECXDSSD=""
+84 KILL LOC
DO SETLOC(ECXDFN,ECXADM,ECPRO,.LOC)
+85 SET ECD1=9999999.9999999-ECXMVD1
+86 ;get ts change just before d/c
+87 SET ECD2=$ORDER(LOC(ECD1))
SET ECXMVD2=9999999.9999999-ECD2
+88 DO FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL)
+89 ;
+90 ;- Call sets ECXA (In/Out indicator) using date before discharge
+91 if '$$PATDEM^ECXUTL2(ECXDFN,ECXMVD2,"1;",13)
QUIT
+92 ;184
SET ECXNMPI=ECXMPI
+93 ;166 tjl - Set Production Division Code based on Ward at Discharge
SET WRD=$PIECE($GET(ECXDWARD),U)
+94 SET ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM)
SET ECXADMTM=$$ECXTIME^ECXUTL(ECXADT)
+95 ;if closest ts change is admission ts, cant go back any further
+96 SET TRT=$ORDER(LOC(ECD2,0))
SET REC=$ORDER(LOC(ECD2,TRT,0))
+97 IF REC=ECXADM
Begin DoDot:3
+98 SET X1=ECXMVD1
SET X2=ECXMVD2
DO ^%DTC
SET ECXLOS=X
+99 IF ECXPRVL'=""
SET X1=ECXMVD1
SET X2=ECXMVD2
DO ^%DTC
SET ECXLOSP=X
+100 IF ECXATTL'=""
SET X1=ECXMVD1
SET X2=ECXMVD2
DO ^%DTC
SET ECXLOSA=X
End DoDot:3
+101 ;otherwise, need to find when change to last ts occurred
+102 IF REC'=ECXADM
Begin DoDot:3
+103 DO PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS)
+104 DO PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP)
+105 DO PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA)
End DoDot:3
+106 if ECXLOS>9999
SET ECXLOS=9999
if ECXLOSA>9999
SET ECXLOSA=9999
+107 if ECXLOSP>9999
SET ECXLOSP=9999
+108 ;- Production Division
+109 SET ECXPDIV=""
+110 IF ECXLOGIC>2003
SET ECXPDIV=$SELECT(WRD="":"",1:$$NPDIV(WRD))
+111 ;
+112 ;- Observation patient indicator (YES/NO)
+113 SET ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+114 ;
+115 ;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule)
+116 IF ECXA="O"&(ECXOBS="NO")&(ECXMVD1)
SET ECXA="I"
+117 ; ******* - PATCH 127, ADD PATCAT CODE ********
+118 SET ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
+119 ;
+120 ;- Get providers person classes
+121 SET ECXATLPC=$$PRVCLASS^ECXUTL($EXTRACT(ECXATTL,2,999),ECXADT)
+122 SET ECATLNPI=$$NPI^XUSNPI("Individual_ID",$EXTRACT(ECXATTL,2,999),ECXADT)
+123 if +ECATLNPI'>0
SET ECATLNPI=""
SET ECATLNPI=$PIECE(ECATLNPI,U)
+124 SET ECXPRNPC=$$PRVCLASS^ECXUTL($EXTRACT(ECXPRVN,2,999),ECXADT)
+125 SET ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$EXTRACT(ECXPRVN,2,999),ECXADT)
+126 if +ECPRVNPI'>0
SET ECPRVNPI=""
SET ECPRVNPI=$PIECE(ECPRVNPI,U)
+127 SET ECXATNPC=$$PRVCLASS^ECXUTL($EXTRACT(ECXATTN,2,999),ECXADT)
+128 SET ECATTNPI=$$NPI^XUSNPI("Individual_ID",$EXTRACT(ECXATTN,2,999),ECXADT)
+129 if +ECATTNPI'>0
SET ECATTNPI=""
SET ECATTNPI=$PIECE(ECATTNPI,U)
+130 SET ECXPRLPC=$$PRVCLASS^ECXUTL($EXTRACT(ECXPRVL,2,999),ECXADT)
+131 SET ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$EXTRACT(ECXPRVL,2,999),ECXADT)
+132 if +ECPRLNPI'>0
SET ECPRLNPI=""
SET ECPRLNPI=$PIECE(ECPRLNPI,U)
+133 ;
+134 ;- If no encounter number don't file record
+135 SET ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,)
+136 ;170
IF $GET(ECXASIH)
SET ECXA="A"
+137 if ECXENC'=""
DO FILE^ECXTRT2
End DoDot:2
if QFLG
QUIT
End DoDot:1
if QFLG
QUIT
+138 DO KPATDEM^ECXUTL2
+139 QUIT
+140 ;
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
