- 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 Feb 18, 2025@23:20:31 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