Changeset 623 for WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXTRT.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXTRT.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXTRT.m
r613 r623 1 ECXTRT ;ALB/JAP,BIR/DMA,CML,PTD-Treating Specialty Change Extract ; 10/17/07 3:48pm 2 ;;3.0;DSS EXTRACTS;**1,8,17,24,33,35,39,46,49,84,107,105**;Dec 22, 1997;Build 70 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ; start package specific extract 9 N LOC,SPC,TRT,WRD 10 S QFLG=0 11 K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") 12 S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD 13 K ^TMP($J,"ECXTMP") S TRT=0 14 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 15 S ECED=ECED+.3,ECD=ECSD1 16 ;loop through type 6 movements to get treating specialty and provider changes 17 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 18 .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG 19 ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6) 20 ..; 21 ..;- Call sets ECXA (In/Out indicator) 22 ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD1,"1;",13) 23 ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U) 24 ..;skip the record if its the admission treat. spec. change for this episode of care 25 ..Q:ECXADM=$P(EC,U,24) 26 ..S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD="" 27 ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC) 28 ..;get data for current (new) ts movement 29 ..S ECD1=9999999.9999999-ECXMVD1 30 ..D FINDLOC(ECD1,.LOC,.ECXSPCN,.ECXPRVN,.ECXATTN,.ECXMOVN,.ECXTRTN) 31 ..Q:ECXSPCN="" 32 ..S ECD2=$O(LOC(ECD1)) Q:ECD2="" 33 ..S ECXMVD2=9999999.9999999-ECD2 34 ..;get data for previous (losing) ts movement 35 ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL) 36 ..;if ts has changed, find los on losing ts 37 ..D:ECXTRTL'=ECXTRTN PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS) 38 ..;whether ts has changed or not, see if primary provider has changed 39 ..;don't bother if there's no data on current primary provider or no change in provider 40 ..D:(ECXPRVN'="")&(ECXPRVN'=ECXPRVL) PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP) 41 ..;whether ts has changed or not, see if attending physician has changed 42 ..;don't bother if there's no data on current attending physician or no change in attending 43 ..D:(ECXATTN'="")&(ECXATTN'=ECXATTL) PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA) 44 ..S ECXDATE=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1) 45 ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT),ECXDCDT="" 46 ..;- Production Division 47 ..S ECXPDIV="" 48 ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD)) 49 ..; 50 ..;- Observation patient indicator (YES/NO) 51 ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 52 ..; 53 ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule) 54 ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I" 55 ..; 56 ..;- Get providers person classes 57 .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT) 58 .. S ECATLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTL,2,999),ECXADT) 59 .. S:+ECATLNPI'>0 ECATLNPI="" S ECATLNPI=$P(ECATLNPI,U) 60 .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT) 61 .. S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVN,2,999),ECXADT) 62 .. S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U) 63 .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT) 64 .. S ECATTNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTN,2,999),ECXADT) 65 .. S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U) 66 .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT) 67 .. S ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVL,2,999),ECXADT) 68 .. S:+ECPRLNPI'>0 ECPRLNPI="" S ECPRLNPI=$P(ECPRLNPI,U) 69 ..; 70 ..;- If no encounter number, don't file record 71 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,) 72 ..D:ECXENC'="" FILE^ECXTRT2 73 ;for nhcu episodes with intervening asih stays, the los calculated here is not accurate, 74 ;but it never has been; this is best solution within current extract framework; 75 ;at discharge the los calculated for nhcu episodes will be the los since admission w/o asih los subtracted; 76 ; 77 ;loop through discharges to get last treating specialty 78 S ECD=ECSD1 79 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 80 .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG 81 ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6) 82 ..S (ECXDATE,ECXDCDT)=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1) 83 ..I ECXDCDT'>0 S ECXDCDT="" 84 ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U,1) 85 ..S (ECXTRTN,ECXSPCN,ECXPRVN,ECXATTN)="" S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD="" 86 ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC) 87 ..S ECD1=9999999.9999999-ECXMVD1 88 ..;get ts change just before d/c 89 ..S ECD2=$O(LOC(ECD1)),ECXMVD2=9999999.9999999-ECD2 90 ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL) 91 ..; 92 ..;- Call sets ECXA (In/Out indicator) using date before discharge 93 ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD2,"1;",13) 94 ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT) 95 ..;if closest ts change is admission ts, cant go back any further 96 ..S TRT=$O(LOC(ECD2,0)),REC=$O(LOC(ECD2,TRT,0)) 97 ..I REC=ECXADM D 98 ...S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOS=X 99 ...I ECXPRVL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSP=X 100 ...I ECXATTL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSA=X 101 ..;otherwise, need to find when change to last ts occurred 102 ..I REC'=ECXADM D 103 ...D PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS) 104 ...D PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP) 105 ...D PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA) 106 ..S:ECXLOS>9999 ECXLOS=9999 S:ECXLOSA>9999 ECXLOSA=9999 107 ..S:ECXLOSP>9999 ECXLOSP=9999 108 ..;- Production Division 109 ..S ECXPDIV="" 110 ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD)) 111 ..; 112 ..;- Observation patient indicator (YES/NO) 113 ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 114 ..; 115 ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule) 116 ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I" 117 ..; 118 ..;- Get providers person classes 119 .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT) 120 .. S ECATLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTL,2,999),ECXADT) 121 .. S:+ECATLNPI'>0 ECATLNPI="" S ECATLNPI=$P(ECATLNPI,U) 122 .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT) 123 .. S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVN,2,999),ECXADT) 124 .. S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U) 125 .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT) 126 .. S ECATTNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTN,2,999),ECXADT) 127 .. S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U) 128 .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT) 129 .. S ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVL,2,999),ECXADT) 130 .. S:+ECPRLNPI'>0 ECPRLNPI="" S ECPRLNPI=$P(ECPRLNPI,U) 131 ..; 132 ..;- If no encounter number don't file record 133 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,) 134 ..D:ECXENC'="" FILE^ECXTRT2 135 D KPATDEM^ECXUTL2 136 Q 137 ; 138 NPDIV(WRD) ;National Production Division 139 N DIV 140 S DIV=$$GET1^DIQ(42,WRD,.015,"I") 141 Q $S(DIV="":"",1:$$GETDIV^ECXDEPT(DIV)) 142 ; 143 SETLOC(ECXDFN,ECXADM,ECXPRO,ECXLOC) ;setup the local array from the ATS index 144 ; output 145 ; ECXLOC = local array (passed by reference) 146 ; 147 N SUB3,SUB4,SUB5,SPC,PRV,ATT,MOV 148 S SUB3=0 149 F S SUB3=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3)) Q:SUB3="" D 150 .S (SUB4,SUB5)=0 151 .S SUB4=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4)) 152 .S SUB5=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4,SUB5)) 153 .S ECXLOC(SUB3,SUB4,SUB5)="",SPC=$G(^TMP($J,"ECXTMP",SUB4)) 154 .S DATA=$G(^DGPM(SUB5,0)),PRV=$P(DATA,U,8),ATT=$P(DATA,U,19) 155 .S MOV=$P(DATA,U,14) 156 .S:PRV]"" PRV=ECXPRO_PRV S:ATT]"" ATT=ECXPRO_ATT 157 .S ECXLOC(SUB3,SUB4,SUB5)=SPC_U_PRV_U_ATT_U_MOV 158 Q 159 ; 160 FINDLOC(ECXTSD,ECXLOC,ECXSPC,ECXPRV,ECXATT,ECXMOV,ECXTRT) ;find local array node for current ts movement 161 ; input 162 ; ECXTSD = inverse date/time for current ts movement; required 163 ; ECXLOC = local array; passed by reference; required 164 ; output; data from record contained in MOVE 165 ; ECXSPC = piece 1 of LOC (passed by reference) 166 ; ECXPRV = piece 2 of LOC concatenated to PRO (passed by reference) 167 ; ECXATT = piece 3 of LOC concatenated to PRO (passed by reference) 168 ; ECXMOV = piece 4 of LOC (passed by reference) 169 ; ECXTRT = pointer to file #45.7 170 ; 171 N SUB3,SUB4,SUB5,LOC 172 S (ECXSPC,ECXPRV,ECXATT,ECXMOV)="" 173 S SUB3=ECXTSD 174 I $D(ECXLOC(SUB3)) D 175 .S SUB4=$O(ECXLOC(SUB3,0)),SUB5=$O(ECXLOC(SUB3,SUB4,0)) 176 .S LOC=ECXLOC(SUB3,SUB4,SUB5),ECXTRT=SUB4,ECXSPC=$P(LOC,U) 177 .S ECXPRV=$P(LOC,U,2),ECXATT=$P(LOC,U,3),ECXMOV=$P(LOC,U,4) 178 Q 179 ; 180 SETUP ;Set required input for ECXTRAC 181 S ECHEAD="TRT" 182 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 183 Q 184 ; 185 QUE ; entry point for the background requeuing handled by ECXTAUTO 186 D SETUP,QUE^ECXTAUTO,^ECXKILL 187 Q 1 ECXTRT ;ALB/JAP,BIR/DMA,CML,PTD-Treating Specialty Change Extract ; 04/12/2007 2 ;;3.0;DSS EXTRACTS;**1,8,17,24,33,35,39,46,49,84,107**;Dec 22, 1997;Build 9 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ; start package specific extract 9 N LOC,SPC,TRT,WRD 10 S QFLG=0 11 K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") 12 S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD 13 K ^TMP($J,"ECXTMP") S TRT=0 14 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 15 S ECED=ECED+.3,ECD=ECSD1 16 ;loop through type 6 movements to get treating specialty and provider changes 17 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 18 .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG 19 ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6) 20 ..; 21 ..;- Call sets ECXA (In/Out indicator) 22 ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD1,"1;",13) 23 ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U) 24 ..;skip the record if its the admission treat. spec. change for this episode of care 25 ..Q:ECXADM=$P(EC,U,24) 26 ..S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD="" 27 ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC) 28 ..;get data for current (new) ts movement 29 ..S ECD1=9999999.9999999-ECXMVD1 30 ..D FINDLOC(ECD1,.LOC,.ECXSPCN,.ECXPRVN,.ECXATTN,.ECXMOVN,.ECXTRTN) 31 ..Q:ECXSPCN="" 32 ..S ECD2=$O(LOC(ECD1)) Q:ECD2="" 33 ..S ECXMVD2=9999999.9999999-ECD2 34 ..;get data for previous (losing) ts movement 35 ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL) 36 ..;if ts has changed, find los on losing ts 37 ..D:ECXTRTL'=ECXTRTN PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS) 38 ..;whether ts has changed or not, see if primary provider has changed 39 ..;dont bother if there's no data on current primary provider or no change in provider 40 ..D:(ECXPRVN'="")&(ECXPRVN'=ECXPRVL) PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP) 41 ..;whether ts has changed or not, see if attending physician has changed 42 ..;dont bother if theres no data on current attending physician or no change in attending 43 ..D:(ECXATTN'="")&(ECXATTN'=ECXATTL) PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA) 44 ..S ECXDATE=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1) 45 ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT),ECXDCDT="" 46 ..;- Production Division 47 ..S ECXPDIV="" 48 ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD)) 49 ..S (ECXALNPI,ECXANNPI,ECXPLNPI,ECXPNNPI)="" 50 ..; 51 ..;- Observation patient indicator (YES/NO) 52 ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 53 ..; 54 ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule) 55 ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I" 56 ..; 57 ..;- Get providers person classes 58 .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT) 59 .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT) 60 .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT) 61 .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT) 62 ..; 63 ..;- If no encounter number, don't file record 64 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,) 65 ..D:ECXENC'="" FILE 66 ;for nhcu episodes with intervening asih stays, the los calculated here is not accurate, 67 ;but it never has been; this is best solution within current extract framework; 68 ;at discharge the los calculated for nhcu apisodes will be the los since admission w/o asih los subtracted; 69 ; 70 ;loop through discharges to get last treating specialty 71 S ECD=ECSD1 72 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 73 .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG 74 ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6) 75 ..S (ECXDATE,ECXDCDT)=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1) 76 ..I ECXDCDT'>0 S ECXDCDT="" 77 ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U,1) 78 ..S (ECXTRTN,ECXSPCN,ECXPRVN,ECXATTN)="" S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD="" 79 ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC) 80 ..S ECD1=9999999.9999999-ECXMVD1 81 ..;get ts change just before d/c 82 ..S ECD2=$O(LOC(ECD1)),ECXMVD2=9999999.9999999-ECD2 83 ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL) 84 ..; 85 ..;- Call sets ECXA (In/Out indicator) using date before discharge 86 ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD2,"1;",13) 87 ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT) 88 ..;if closest ts change is admission ts, cant go back any further 89 ..S TRT=$O(LOC(ECD2,0)),REC=$O(LOC(ECD2,TRT,0)) 90 ..I REC=ECXADM D 91 ...S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOS=X 92 ...I ECXPRVL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSP=X 93 ...I ECXATTL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSA=X 94 ..;otherwise, need to find when change to last ts occurred 95 ..I REC'=ECXADM D 96 ...D PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS) 97 ...D PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP) 98 ...D PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA) 99 ..S:ECXLOS>9999 ECXLOS=9999 S:ECXLOSA>9999 ECXLOSA=9999 100 ..S:ECXLOSP>9999 ECXLOSP=9999 101 ..;- Production Division 102 ..S ECXPDIV="" 103 ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD)) 104 ..S (ECXALNPI,ECXANNPI,ECXPLNPI,ECXPNNPI)="" 105 ..; 106 ..;- Observation patient indicator (YES/NO) 107 ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 108 ..; 109 ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule) 110 ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I" 111 ..; 112 ..;- Get providers person classes 113 .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT) 114 .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT) 115 .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT) 116 .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT) 117 ..; 118 ..;- If no encounter number don't file record 119 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,) 120 ..D:ECXENC'="" FILE 121 D KPATDEM^ECXUTL2 122 Q 123 ; 124 NPDIV(WRD) ;National Production Division 125 N DIV 126 S DIV=$$GET1^DIQ(42,WRD,.015,"I") 127 Q $S(DIV="":"",1:$$GETDIV^ECXDEPT(DIV)) 128 ; 129 SETLOC(ECXDFN,ECXADM,ECXPRO,ECXLOC) ;setup the local array from the ATS index 130 ; output 131 ; ECXLOC = local array (passed by reference) 132 ; 133 N SUB3,SUB4,SUB5,SPC,PRV,ATT,MOV 134 S SUB3=0 135 F S SUB3=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3)) Q:SUB3="" D 136 .S (SUB4,SUB5)=0 137 .S SUB4=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4)) 138 .S SUB5=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4,SUB5)) 139 .S ECXLOC(SUB3,SUB4,SUB5)="",SPC=$G(^TMP($J,"ECXTMP",SUB4)) 140 .S DATA=$G(^DGPM(SUB5,0)),PRV=$P(DATA,U,8),ATT=$P(DATA,U,19) 141 .S MOV=$P(DATA,U,14) 142 .S:PRV]"" PRV=ECXPRO_PRV S:ATT]"" ATT=ECXPRO_ATT 143 .S ECXLOC(SUB3,SUB4,SUB5)=SPC_U_PRV_U_ATT_U_MOV 144 Q 145 ; 146 FINDLOC(ECXTSD,ECXLOC,ECXSPC,ECXPRV,ECXATT,ECXMOV,ECXTRT) ;find local array node for current ts movement 147 ; input 148 ; ECXTSD = inverse date/time for current ts movement; required 149 ; ECXLOC = local array; passed by reference; required 150 ; output; data from record contained in MOVE 151 ; ECXSPC = piece 1 of LOC (passed by reference) 152 ; ECXPRV = piece 2 of LOC concatenated to PRO (passed by reference) 153 ; ECXATT = piece 3 of LOC concatenated to PRO (passed by reference) 154 ; ECXMOV = piece 4 of LOC (passed by reference) 155 ; ECXTRT = pointer to file #45.7 156 ; 157 N SUB3,SUB4,SUB5,LOC 158 S (ECXSPC,ECXPRV,ECXATT,ECXMOV)="" 159 S SUB3=ECXTSD 160 I $D(ECXLOC(SUB3)) D 161 .S SUB4=$O(ECXLOC(SUB3,0)),SUB5=$O(ECXLOC(SUB3,SUB4,0)) 162 .S LOC=ECXLOC(SUB3,SUB4,SUB5),ECXTRT=SUB4,ECXSPC=$P(LOC,U) 163 .S ECXPRV=$P(LOC,U,2),ECXATT=$P(LOC,U,3),ECXMOV=$P(LOC,U,4) 164 Q 165 ; 166 FILE ;file the extract record 167 ;node0 168 ;^dfn^ssn^name^i/o (ECXA)^date^product^adm date^d/c date^ 169 ;mov#^type^new ts^losing ts^losing ts los^ 170 ;losing attending^movement type^time^adm time^new provider^ 171 ;new attending^losing provider 172 ;node1 173 ;mpi^dss dept^losing attending npi^new provider npi^new attending npi^ 174 ;losing provider npi^losing attending los^losing provider los^dom^ 175 ;observ pat ind^encounter num 176 ; 177 ;convert specialties to PTF Codes for transmission 178 ; 179 N ECXDATA 180 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPCN,.ECXDATA) 181 S ECXSPCN=$G(ECXDATA(7)) 182 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPCL,.ECXDATA) 183 S ECXSPCL=$G(ECXDATA(7)) 184 ;done 185 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 186 S ECODE=EC7_U_EC23_U_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE_U_U 187 S ECODE=ECODE_ECXADMDT_U_ECXDCDT_U_ECDA_U_6_U_ECXSPCN_U_ECXSPCL_U 188 S ECODE=ECODE_ECXLOS_U_ECXATTL_U_ECMT_U_ECXTIME_U_ECXADMTM_U_ECXPRVN_U 189 S ECODE=ECODE_ECXATTN_U_ECXPRVL_U 190 S ECODE1=ECXMPI_U_ECXDSSD_U_ECXALNPI_U_ECXPNNPI_U_ECXANNPI_U_ECXPLNPI_U 191 S ECODE1=ECODE1_ECXLOSA_U_ECXLOSP_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXPDIV 192 I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXATLPC_U_ECXPRNPC_U_ECXATNPC_U_ECXPRLPC 193 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 194 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 195 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 196 Q 197 ; 198 SETUP ;Set required input for ECXTRAC 199 S ECHEAD="TRT" 200 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 201 Q 202 ; 203 QUE ; entry point for the background requeuing handled by ECXTAUTO 204 D SETUP,QUE^ECXTAUTO,^ECXKILL 205 Q
Note:
See TracChangeset
for help on using the changeset viewer.
