Changeset 623 for WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXMOV.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXMOV.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXMOV.m
r613 r623 1 ECXMOV ;ALB/JAP,BIR/DMA,PTD-Transfer and Discharge Extract ; 6/6/07 6:46am 2 ;;3.0;DSS EXTRACTS;**8,24,33,39,41,42,46,65,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 ECXDSC,W,WTO,X1,X2,X,ECXDPRPC,ECXDAPPC 10 K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") 11 S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD 12 S ECED=ECED+.3,QFLG=0 13 F ECM=2,3 S ECARG="ATT"_ECM,ECD=ECSD1 D Q:QFLG 14 .F S ECD=$O(^DGPM(ECARG,ECD)),ECDA=0 Q:('ECD)!(ECD>ECED) D Q:QFLG 15 ..F S ECDA=$O(^DGPM(ECARG,ECD,ECDA)) Q:'ECDA D Q:QFLG 16 ...Q:'$D(^DGPM(ECDA,0)) S EC=^(0) 17 ...S ECXDFN=+$P(EC,U,3),ECMT=$P(EC,U,18),ECXDATE=ECD 18 ...K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;",.ECXPAT) 19 ...I 'OK K ECXPAT Q 20 ...S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") 21 ...S ECTM=$$ECXTIME^ECXUTL(ECD) 22 ...S WTO=$P(EC,U,6),ECXWTO=$P($G(^DIC(42,+WTO,44)),U) 23 ...; 24 ...;reset EC to admission movement 25 ...S ECCA=$P(EC,U,14),EC=^DGPM(ECCA,0),ECA=$P(EC,U) 26 ...; 27 ...;if date of previous xfer movement is greater than admit date, 28 ...;then reset EC to that previous xfer movement 29 ...S ECDL=9999999.9999999-ECD,ECDL=+$O(^DGPM("ATID2",ECXDFN,ECDL)) 30 ...S ECDAL=+$O(^DGPM("ATID2",ECXDFN,ECDL,0)) 31 ...I $D(^DGPM(ECDAL,0)),$P(^(0),U)>$P(EC,U) S EC=^(0) 32 ...; 33 ...I ECM=2 D 34 ....;if transact=Transfer,ECD (time)=ASIH (7chars) and >0,set ECXDATE 35 ....;to Admit DT/time before calling funct to get in/out stat & TS 36 ....I $L($P(ECD,".",2))=7,+$E($P(ECD,".",2),7)>0 S ECXDATE=ECA 37 ....S W=$P(EC,U,6) 38 ...; 39 ...I ECM=3 D 40 ....;subtract 1 second from dischg DT so IN5^VADPT call (in ECXUTL2 41 ....;API) will pick up discharge movmement record 42 ....S ECXDATE=$$FMADD^XLFDT(ECXDATE,,,,-1) 43 ....;set losing ward to ward at discharge 44 ....N WARD S WARD=$$GET1^DIQ(405,ECDA,200) 45 ....I WARD'="" S W=+$O(^DIC(42,"B",WARD,0)) 46 ...; 47 ...;-Gets inpat/outpat status, DOM, Treating Spec (TS) 48 ...S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3) 49 ...; 50 ...S (ECXWRD,ECXFAC,ECXDSSD)="" 51 ...I W'="" D 52 ....S ECXWRD=$P($G(^DIC(42,W,44)),U),ECXFAC=$P($G(^DIC(42,W,0)),U,11) 53 ....S ECXDSSD=$P($G(^ECX(727.4,W,0)),U,2) 54 ...S ECDI=$S(ECM=2:"",1:$$ECXDATE^ECXUTL(ECD,ECXYM)) 55 ...S X1=ECD,X2=$P(EC,U) D ^%DTC S ECXLOS=X 56 ...; 57 ...;- Get discharge PC Team, Primary and Assoc Primary Provider 58 ...S (ECXDPCT,ECXDPR,ECXDAPR,ECXDPRPC,ECXDAPPC)="" 59 ...I ECM=3 D 60 ....S ECXDSC=$$PRIMARY^ECXUTL2(ECXDFN,ECD) 61 ....S ECXDPCT=$P(ECXDSC,U),ECXDPR=$P(ECXDSC,U,2),ECXDAPR=$P(ECXDSC,U,5),ECXDPRPC=$P(ECXDSC,U,3),ECXDAPPC=$P(ECXDSC,U,6) 62 ....S ECDAPRNP=$P(ECXDSC,U,7),ECDPRNPI=$P(ECXDSC,U,4) 63 ...; 64 ...;Get production division ;p-46 65 ...N ECXPDIV S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;p-46 66 ...;- Observation patient indicator (YES/NO) 67 ...S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 68 ...; 69 ...;- If no encounter number, don't file record 70 ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECA,,ECXTS,ECXOBS,ECHEAD,,) 71 ...D:ECXENC'="" FILE 72 Q 73 ; 74 FILE ;file the extract record 75 ;node0 76 ;fac ECXFAC^dfn ECXDFN^ssn ECXSSN^name ECXPNM^in/out ECXA^ 77 ;day (ECD)^^adm date (ECA)^disc date ECDI^mov # ECDA^ 78 ;type ECM^losing ward ECXWARD^treat spec ^los ECXLOS^^ 79 ;movement type ECMT^mov time ECTM^gaining ward ECXWTO^ 80 ;adm time (ECA)^^^ 81 ;node1 82 ;mpi ECXMPI^dss dept ECXDSSD^dom ECXDOM^observ pat ind ECXOBS^ 83 ;encounter num ECXENC^disch prim prov ECXDPR^disch PC team ECXDPCT^ 84 ;disch assoc prim prov ECXDAPR^production division ECXPDIV 85 ;^disch prov person class ECXDPRPC^disch assoc prov pe- 86 ;rson person class^disch assoc pc prov npi ECDAPRNP^discharge pc provider npi ECDPRNPI 87 N DA,DIK 88 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 89 S ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 90 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_U 91 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECA,ECXYM)_U_ECDI_U_ECDA_U_ECM_U_ECXWRD_U 92 S ECODE=ECODE_U_ECXLOS_U_U_ECMT_U_ECTM_U_ECXWTO_U 93 S ECODE=ECODE_$$ECXTIME^ECXUTL(ECA)_U_U_U 94 S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXDPR_U 95 S ECODE1=ECODE1_ECXDPCT_U_ECXDAPR_U_ECXPDIV ;p-46 added ECXPDIV 96 I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXDPRPC_U_ECXDAPPC 97 I ECXLOGIC>2007 S ECODE1=ECODE1_U_$G(ECDAPRNP)_U_$G(ECDPRNPI) 98 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 99 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 100 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 101 Q 102 ; 103 SETUP ;Set required input for ECXTRAC 104 S ECHEAD="MOV" 105 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 106 Q 107 ; 108 QUE ; entry point for the background requeuing handled by ECXTAUTO 109 D SETUP,QUE^ECXTAUTO,^ECXKILL Q 1 ECXMOV ;ALB/JAP,BIR/DMA,PTD-Transfer and Discharge Extract ; 8/19/05 9:13am 2 ;;3.0;DSS EXTRACTS;**8,24,33,39,41,42,46,65,84**;Dec 22, 1997 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 ECXDSC,W,WTO,X1,X2,X,ECXDPRPC,ECXDAPPC 10 K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") 11 S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD 12 S ECED=ECED+.3,QFLG=0 13 F ECM=2,3 S ECARG="ATT"_ECM,ECD=ECSD1 D Q:QFLG 14 .F S ECD=$O(^DGPM(ECARG,ECD)),ECDA=0 Q:('ECD)!(ECD>ECED) D Q:QFLG 15 ..F S ECDA=$O(^DGPM(ECARG,ECD,ECDA)) Q:'ECDA D Q:QFLG 16 ...Q:'$D(^DGPM(ECDA,0)) S EC=^(0) 17 ...S ECXDFN=+$P(EC,U,3),ECMT=$P(EC,U,18),ECXDATE=ECD 18 ...K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;",.ECXPAT) 19 ...I 'OK K ECXPAT Q 20 ...S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") 21 ...S ECTM=$$ECXTIME^ECXUTL(ECD) 22 ...S WTO=$P(EC,U,6),ECXWTO=$P($G(^DIC(42,+WTO,44)),U) 23 ...; 24 ...;reset EC to admission movement 25 ...S ECCA=$P(EC,U,14),EC=^DGPM(ECCA,0),ECA=$P(EC,U) 26 ...; 27 ...;if date of previous xfer movement is greater than admit date, 28 ...;then reset EC to that previous xfer movement 29 ...S ECDL=9999999.9999999-ECD,ECDL=+$O(^DGPM("ATID2",ECXDFN,ECDL)) 30 ...S ECDAL=+$O(^DGPM("ATID2",ECXDFN,ECDL,0)) 31 ...I $D(^DGPM(ECDAL,0)),$P(^(0),U)>$P(EC,U) S EC=^(0) 32 ...; 33 ...I ECM=2 D 34 ....;if transact=Transfer,ECD (time)=ASIH (7chars) and >0,set ECXDATE 35 ....;to Admit DT/time before calling funct to get in/out stat & TS 36 ....I $L($P(ECD,".",2))=7,+$E($P(ECD,".",2),7)>0 S ECXDATE=ECA 37 ....S W=$P(EC,U,6) 38 ...; 39 ...I ECM=3 D 40 ....;subtract 1 second from dischg DT so IN5^VADPT call (in ECXUTL2 41 ....;API) will pick up discharge movmement record 42 ....S ECXDATE=$$FMADD^XLFDT(ECXDATE,,,,-1) 43 ....;set losing ward to ward at discharge 44 ....N WARD S WARD=$$GET1^DIQ(405,ECDA,200) 45 ....I WARD'="" S W=+$O(^DIC(42,"B",WARD,0)) 46 ...; 47 ...;-Gets inpat/outpat status, DOM, Treating Spec (TS) 48 ...S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3) 49 ...; 50 ...S (ECXWRD,ECXFAC,ECXDSSD)="" 51 ...I W'="" D 52 ....S ECXWRD=$P($G(^DIC(42,W,44)),U),ECXFAC=$P($G(^DIC(42,W,0)),U,11) 53 ....S ECXDSSD=$P($G(^ECX(727.4,W,0)),U,2) 54 ...S ECDI=$S(ECM=2:"",1:$$ECXDATE^ECXUTL(ECD,ECXYM)) 55 ...S X1=ECD,X2=$P(EC,U) D ^%DTC S ECXLOS=X 56 ...; 57 ...;- Get discharge PC Team, Primary and Assoc Primary Provider 58 ...S (ECXDPCT,ECXDPR,ECXDAPR,ECXDPRPC,ECXDAPPC)="" 59 ...I ECM=3 D 60 ....S ECXDSC=$$PRIMARY^ECXUTL2(ECXDFN,ECD) 61 ....S ECXDPCT=$P(ECXDSC,U),ECXDPR=$P(ECXDSC,U,2),ECXDAPR=$P(ECXDSC,U,5),ECXDPRPC=$P(ECXDSC,U,3),ECXDAPPC=$P(ECXDSC,U,6) 62 ...; 63 ...;Get production division ;p-46 64 ...N ECXPDIV S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;p-46 65 ...;- Observation patient indicator (YES/NO) 66 ...S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 67 ...; 68 ...;- If no encounter number, don't file record 69 ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECA,,ECXTS,ECXOBS,ECHEAD,,) 70 ...D:ECXENC'="" FILE 71 Q 72 ; 73 FILE ;file the extract record 74 ;node0 75 ;fac ECXFAC^dfn ECXDFN^ssn ECXSSN^name ECXPNM^in/out ECXA^ 76 ;day (ECD)^^adm date (ECA)^disc date ECDI^mov # ECDA^ 77 ;type ECM^losing ward ECXWARD^treat spec ^los ECXLOS^^ 78 ;movement type ECMT^mov time ECTM^gaining ward ECXWTO^ 79 ;adm time (ECA)^^^ 80 ;node1 81 ;mpi ECXMPI^dss dept ECXDSSD^dom ECXDOM^observ pat ind ECXOBS^ 82 ;encounter num ECXENC^disch prim prov ECXDPR^disch PC team ECXDPCT^ 83 ;disch assoc prim prov ECXDAPR^production division ECXPDIV 84 ;^disch prov person class ECXDPRPC^disch assoc prov pe- 85 ;rson person class 86 N DA,DIK 87 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 88 S ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 89 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_U 90 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECA,ECXYM)_U_ECDI_U_ECDA_U_ECM_U_ECXWRD_U 91 S ECODE=ECODE_U_ECXLOS_U_U_ECMT_U_ECTM_U_ECXWTO_U 92 S ECODE=ECODE_$$ECXTIME^ECXUTL(ECA)_U_U_U 93 S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXDPR_U 94 S ECODE1=ECODE1_ECXDPCT_U_ECXDAPR_U_ECXPDIV ;p-46 added ECXPDIV 95 I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXDPRPC_U_ECXDAPPC 96 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 97 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 98 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 99 Q 100 ; 101 SETUP ;Set required input for ECXTRAC 102 S ECHEAD="MOV" 103 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 104 Q 105 ; 106 QUE ; entry point for the background requeuing handled by ECXTAUTO 107 D SETUP,QUE^ECXTAUTO,^ECXKILL Q
Note:
See TracChangeset
for help on using the changeset viewer.
