ECXMOV ;ALB/JAP,BIR/DMA,PTD-Transfer and Discharge Extract ;Mar 03, 2023@17:01:12
;;3.0;DSS EXTRACTS;**8,24,33,39,41,42,46,65,84,107,105,128,127,161,166,170,173,174,184,187**;Dec 22, 1997;Build 163
;
; Reference to DEM^VADPT in ICR #10061
; Reference to ^DGPM in ICR #1865
; Reference to $$LJ^XLFSTR in ICR #10104
; Reference to $$FMTE^XLFDT in ICR #10103
; Reference to ^XMD in ICR #10113
; Reference to ^XMB("NETNAME") in ICR #1131
; Reference to ^TMP supported by SACC 2.3.2.5.1
; Reference to ^DIC(42 in ICR #1848
;
BEG ;entry point from option
D SETUP I ECFILE="" Q
D ^ECXTRAC,^ECXKILL
Q
;
START ; start package specific extract
N ECXDSC,W,WTO,X1,X2,X,ECXDPRPC,ECXDAPPC,ECDIS,YEARMON,REC,VAL ;173
N ECXSTANO ;tjl 166
K ^TMP($J,"ASIH") ;170 Keeps track of ASIH other facility records that need to be created
K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
S ECED=ECED+.3,QFLG=0,YEARMON=$P(EC23,U) ;173 Set yearmon to extract year and month
;187 - Begins. In the following lines, removed the check of QFLG to bypass records that had no admission date/time
F ECM=2,3 S ECARG="ATT"_ECM,ECD=ECSD1 D ;Q:QFLG
.F S ECD=$O(^DGPM(ECARG,ECD)),ECDA=0 Q:('ECD)!(ECD>ECED) D ;Q:QFLG
..F S ECDA=$O(^DGPM(ECARG,ECD,ECDA)) Q:'ECDA D GET ;Q:QFLG
S ECDA=0 F S ECDA=$O(^TMP($J,"ASIH",ECDA)) Q:'+ECDA S ECM=3 D DISASIH ; Q:QFLG
;187 - Ends
S REC=0 F S REC=$O(^XTMP("ECXMOV",YEARMON,REC)) Q:'+REC S VAL=$$NEEDADR^ECXUTL6("TRAN",REC,"MOV") I +VAL S ECDA=$P(VAL,U,2) S ECM=3 D DISASIH ;173 Review patients that were still on ASIH last month
I $D(^TMP($J,"ECXMOVMM")) D SENDMSG ;187
D CLEAN ;173
K ^TMP($J,"ASIH") ;170
Q
;
GET ;170 Moved record creation to be under "GET"
N NEEDREC ;170
N ECXNMPI,ECXCERN,ECXSIGI ;184
Q:'$D(^DGPM(ECDA,0)) S EC=^(0)
S ECXDFN=+$P(EC,U,3),ECMT=$P(EC,U,18),ECXDATE=ECD
K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;",.ECXPAT)
I 'OK D SETTMP("INVALID SSN",ECDA,ECD,ECXDFN,"") K ECXPAT Q ;187 Bypass records with BAD SSN.
S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),(ECXNMPI,ECXMPI)=ECXPAT("MPI") ;184 Added ECXNMPI
S ECXSIGI=ECXPAT("SIGI") ;184 Self Identified Gender
S ECTM=$$ECXTIME^ECXUTL(ECD)
S WTO=$P(EC,U,6),ECXWTO=$P($G(^DIC(42,+WTO,44)),U)
;
;reset EC to admission movement and hold discharge movement ECX*128
;187 Begins
;S ECCA=$P(EC,U,14),EC=$G(^DGPM(ECCA,0)),ECA=$P(EC,U) I EC="" D MAIL(ECDA) S QFLG=1 Q
S ECCA=$P(EC,U,14),EC=$G(^DGPM(ECCA,0)),ECA=$P(EC,U) I EC="" D SETTMP("MISSING ADMISSION RECORD",ECDA,ECD,ECXDFN,ECXSSN) Q
I ECMT="" D SETTMP("MISSING MOVEMENT TYPE",ECDA,ECD,ECXDFN,ECXSSN) Q ;187 Missing Movement Type.
;187 Ends
;
;if date of previous xfer movement is greater than admit date,
;then reset EC to that previous xfer movement
S ECDL=9999999.9999999-ECD,ECDL=+$O(^DGPM("ATID2",ECXDFN,ECDL))
S ECDAL=+$O(^DGPM("ATID2",ECXDFN,ECDL,0))
I $D(^DGPM(ECDAL,0)),$P(^(0),U)>$P(EC,U) S EC=^(0)
;
I ECM=2 D
.I $$ISASIH^ECXUTL6(ECDA,ECM) S NEEDREC=$$NEEDADR^ECXUTL6("TRAN",ECDA,"MOV") I +NEEDREC S ^TMP($J,"ASIH",$P(NEEDREC,U,2))="" ;170 If it's an ASIH record and we need a discharge record, store it for later
.;if transact=Transfer,ECD (time)=ASIH (7chars) and >0,set ECXDATE
.;to Admit DT/time before calling funct to get in/out stat & TS
.I $L($P(ECD,".",2))=7,+$E($P(ECD,".",2),7)>0 S ECXDATE=ECA
.S W=$P(EC,U,6)
;
I ECM=3 D
.I $$ISASIH^ECXUTL6(ECDA,ECM) S NEEDREC=$$NEEDADR^ECXUTL6("DIS",ECDA,"MOV") I +NEEDREC S ^TMP($J,"ASIH",$P(NEEDREC,U,2))="" ;170 If patient is discharged and we need an ASIH discharge record, store it for later
.;subtract 1 second from dischg DT so IN5^VADPT call (in ECXUTL2
.;API) will pick up discharge movmement record
.S ECXDATE=$$FMADD^XLFDT(ECXDATE,,,,-1)
.;set losing ward to ward at discharge
.N WARD S WARD=$$GET1^DIQ(405,ECDA,200)
.I WARD'="" S W=+$O(^DIC(42,"B",WARD,0))
;
;-Gets inpat/outpat status, DOM, Treating Spec (TS)
S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3)
;
S (ECXWRD,ECXFAC,ECXDSSD,ECXSTANO)=""
I W'="" D
.S ECXWRD=$P($G(^DIC(42,W,44)),U),ECXFAC=$P($G(^DIC(42,W,0)),U,11)
.S ECXDSSD=$P($G(^ECX(727.4,W,0)),U,2)
.S ECXSTANO=$$GETDIV^ECXDEPT(ECXFAC) ;tjl 166 - Set Patient Division based on gaining/losing ward
S ECDI=$S(ECM=2:"",1:$$ECXDATE^ECXUTL(ECD,ECXYM))
S X1=ECD,X2=$P(EC,U) D ^%DTC S ECXLOS=X
;
;- Get discharge PC Team, Primary and Assoc Primary Provider
S (ECXDPCT,ECXDPR,ECXDAPR,ECXDPRPC,ECXDAPPC)=""
I ECM=3 D
.S ECXDSC=$$PRIMARY^ECXUTL2(ECXDFN,ECD)
.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)
.S ECDAPRNP=$P(ECXDSC,U,7),ECDPRNPI=$P(ECXDSC,U,4)
;
;Get production division ;p-46
N ECXPDIV S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;p-46
;- Observation patient indicator (YES/NO)
S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
;
; ******* - PATCH 127, ADD PATCAT CODE ********
S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
;- If no encounter number, don't file record
S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECA,,ECXTS,ECXOBS,ECHEAD,,)
I ECXTS S ECXTS=$S(ECM=3:$$GET1^DIQ(42.4,ECXTS_",",7),1:"") ;174 If T.S. found and it's a discharge mvmt, set ECXTS to PTF code for T.S.
D:ECXENC'="" FILE
Q
;
FILE ;file the extract record
;node0
;fac ECXFAC^dfn ECXDFN^ssn ECXSSN^name ECXPNM^in/out ECXA^
;day (ECD)^^adm date (ECA)^disc date ECDI^mov # ECDA^
;placehold type ECM^losing ward ECXWARD^treating spec PTF code (ECXTS)^los ECXLOS^^
;movement type ECMT^mov time ECTM^gaining ward ECXWTO^
;adm time (ECA)^^^
;node1
;mpi ECXMPI^placeholder ECXDSSD^dom ECXDOM^observ pat ind ECXOBS^
;encounter num ECXENC^disch prim prov ECXDPR^disch PC team ECXDPCT^
;disch assoc prim prov ECXDAPR^production division ECXPDIV
;^disch prov person class ECXDPRPC^disch assoc prov pe-
;rson person class^disch assoc pc prov npi ECDAPRNP^discharge pc provider npi ECDPRNPI
;^ Patient Division ECXSTANO
;node2
;Placehold CERNER
;node3
;new MPI ECXNMPI^ Self Identified Gender ECXSIGI
N DA,DIK
I ECXLOGIC>2022 S ECXMPI="" ;184 - field retired
S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
S ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_U
S ECODE=ECODE_$$ECXDATE^ECXUTL(ECA,ECXYM)_U_ECDI_U_ECDA_U_$S(ECXLOGIC>2019:"",1:ECM)_U_ECXWRD_U_$S(ECXLOGIC>2019:ECXTS,1:"") ;174 Add treating specialty PTF value and remove type
S ECODE=ECODE_U_ECXLOS_U_U_ECMT_U_ECTM_U_ECXWTO_U
S ECODE=ECODE_$$ECXTIME^ECXUTL(ECA)_U_U_U
S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXDPR_U
S ECODE1=ECODE1_ECXDPCT_U_ECXDAPR_U_ECXPDIV ;p-46 added ECXPDIV
I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXDPRPC_U_ECXDAPPC
I ECXLOGIC>2007 S ECODE1=ECODE1_U_$G(ECDAPRNP)_U_$G(ECDPRNPI)
I ECXLOGIC>2010 S ECODE1=ECODE1_U_ECXPATCAT ;P-127 ADDED PATCAT
I ECXLOGIC>2017 S ECODE1=ECODE1_U_ECXSTANO_U ;tjl 166 ,184 - Added "^"
I ECXLOGIC>2022 S ECODE2=$G(ECXCERN)_U,ECODE3=ECXNMPI_U_ECXSIGI ;184 - Added NMPI, SIGI
S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1 ;184 Move the record count to below
S ^ECX(ECFILE,EC7,2)=$G(ECODE2),^ECX(ECFILE,EC7,3)=$G(ECODE3) ;184
S ECRN=ECRN+1 ;184 - Move record count from above
S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
Q
;
SETUP ;Set required input for ECXTRAC
S ECHEAD="MOV"
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
MAIL(ECXDA) ;
; Created to send a message pointing to a bad record ECX*128
; Input - ECXDA is the PATIENT MOVEMENT (#405) record number for the discharge that has no admission
; associated with it. ECX*128
N XMSUB,XMTEXT,XMY,MSGTEXT,LINENUM
;;Setup necessary variables to send the message
S XMSUB="Movement Record Error - Please Fix"
S XMTEXT="MSGTEXT("
S XMY("G.DSS-MOVS@"_^XMB("NETNAME"))=""
;;Create the message to be sent
S LINENUM=1
S MSGTEXT(LINENUM)="The Transfer and Discharge Extract did not complete due to the error below"
S LINENUM=LINENUM+1,MSGTEXT(LINENUM)="",LINENUM=LINENUM+1
S MSGTEXT(LINENUM)="Discharge movement record "_ECXDA_" does not have an admission movement associated with it."
S LINENUM=LINENUM+1,MSGTEXT(LINENUM)="",LINENUM=LINENUM+1
S MSGTEXT(LINENUM)="This record needs to be fixed and the extract needs to be run again."
S LINENUM=LINENUM+1,MSGTEXT(LINENUM)=""
D ^XMD
Q
;
DISASIH ;170 Section added to create a discharge ASIH other facility record
N OK,EC,ECXPAT,WTO,ECXWTO,X,ECA,ECD,WARD,ECXFAC,ECXDSSD,ECXSTANO,ECXPDIV,ECXOBS,ECXPATCAT,ECXENC,ECDI,ECCXLOS,ECXDPCT,ECXDPR,ECXDAPR,ECXDPRPC,ECXDAPPC,ECXDSC,ECDAPRNP,ECDPRNPI,ECM,ECMT
N ECTM,ECXA,ECXDFN,ECXDOM,ECXLOS,ECXMPI,ECXPNM,ECXSSN,ECXTS,ECXWRD
N ECXNMPI,ECXCERN,ECXSIGI ;184
Q:'$D(^DGPM(ECDA,0)) S EC=^(0)
S ECXDFN=+$P(EC,U,3),ECMT=$P(EC,U,18),ECXDATE=$P(EC,U)
S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;",.ECXPAT) ;Q:'OK 187 - Bad records, don't quit. Save the record and send MM at the end
I 'OK D SETTMP("INVALD SSN",ECDA,ECD,ECXDFN,"") Q ;187
S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),(ECXNMPI,ECXMPI)=ECXPAT("MPI") ;184 Added ECXNMPI
S ECXSIGI=ECXPAT("SIGI") ;184 Self Identified Gender
S X=$$INP^ECXUTL2(ECXDFN,$$FMADD^XLFDT(ECXDATE,,,,-1))
S ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3),ECXA=$P(X,U)
S ECA=$P(X,U,4)
S ECD=$P(X,U,6)
S ECDI=$$ECXDATE^ECXUTL(ECD,ECXYM)
S ECM=3
S ECMT=$P(EC,U,18)
I ECMT="" D SETTMP("MISSING MOVEMENT TYPE",ECDA,ECA,ECXDFN,ECXSSN) Q ;187 Missing Movement Type
S ECTM=$$ECXTIME^ECXUTL(ECD)
S (ECXWRD,WTO,ECXWTO,WARD,ECXFAC,ECXDSSD,ECXSTANO,ECXLOS,ECXDPCT,ECXDPR,ECXDAPR,ECXDPRPC,ECXDAPPC,ECXDSC,ECDAPRNP,ECDPRNPI)=""
S ECXWRD=$$GET1^DIQ(405,ECDA,200)
S:ECXWRD'="" ECXWRD=+$O(^DIC(42,"B",ECXWRD,0)) ;Gets ward at discharge
S:ECXWRD="" ECXWRD=$P(EC,U,6) ;Gets ward from transfer
I ECXWRD'="" S ECXFAC=$P($G(^DIC(42,ECXWRD,0)),U,11) S ECXWRD="" ;Get facility based on ward, reset ward to null
S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC)
S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECA,,ECXTS,ECXOBS,ECHEAD,,)
S ECXA="A"
S ECXTS="" ;174 Field will be null if discharge is ASIH OTHER FACILITY type
D:ECXENC'="" FILE
Q
;
CLEAN ;173 Retain the six most recent sets of entries for ASIH review
N DATE,CNT,NUM
S (DATE,CNT)=0
F S DATE=$O(^XTMP("ECXMOV",DATE)) Q:'+DATE S CNT=CNT+1
F NUM=CNT:-1:7 S DATE=$O(^XTMP("ECXMOV",0)) Q:DATE="" K ^XTMP("ECXMOV",DATE) ;Maintain list at a maximum of six groupings/months
S ^XTMP("ECXMOV",0)=$$FMADD^XLFDT(DT,365)_"^"_DT_"^"_"List of ASIH movements without a corresponding return movement" ;Set XTMP zero node as required
Q
;
SETTMP(ERRMSG,ECDA,ECDATE,DFN,SSN) ;187 Set TMP global for MM messages
N ECMOVDT,VADM,ECXSSN,PTNAME
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")
I SSN="" S SSN=$P(VADM(2),U),ERRMSG="INVALID SSN"
S ^TMP($J,"ECXMOVMM",ERRMSG,DFN,ECDA)=VADM(1)_U_SSN_U_ECMOVDT_U_ECDA
Q
;
SENDMSG ; Added for patch 187. SEND MM messages
N ERRMSG,ECMSG,ECDFN,ECSSN,ECSTR,ECDA,I,J,XMY,XMDUZ,XMSUB,XMTEXT
I '$D(^TMP($J,"ECXMOVMM")) 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)="The DSS-"_ECPACK_" Extract (#"_$P(EC23,U,2)_") process for "_ECSDN_" through "_ECEDN
S ECMSG(2,0)="contains the records in the MOVEMENT file (#405) that were not extracted"
S ECMSG(3,0)="due to missing information."
S ECMSG(4,0)=""
S ERRMSG="",J=0
F I=1:1 S ERRMSG=$O(^TMP($J,"ECXMOVMM",ERRMSG)) Q:ERRMSG="" D
. S ECMSG(5*I+J,0)="*** "_ERRMSG_" ***",J=J+1
. S ECMSG(5*I+J,0)="Patient Name SSN MOVEMENT DATE/TIME RECORD #",J=J+1
. S ECMSG(5*I+J,0)="-------------------------------------------------------------------------------",J=J+1
. S ECDFN=""
. F J=J:1 S ECDFN=$O(^TMP($J,"ECXMOVMM",ERRMSG,ECDFN)) Q:ECDFN="" D
.. S ECDA=0
.. F S ECDA=$O(^TMP($J,"ECXMOVMM",ERRMSG,ECDFN,ECDA)) Q:ECDA="" D
... S ECSTR=^TMP($J,"ECXMOVMM",ERRMSG,ECDFN,ECDA)
... 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 J=J+1,ECMSG(5*I+J,0)=""
S XMTEXT="ECMSG("
D ^XMD
K ^TMP($J,"ECXMOVMM")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXMOV 12675 printed Dec 13, 2024@01:53:03 Page 2
ECXMOV ;ALB/JAP,BIR/DMA,PTD-Transfer and Discharge Extract ;Mar 03, 2023@17:01:12
+1 ;;3.0;DSS EXTRACTS;**8,24,33,39,41,42,46,65,84,107,105,128,127,161,166,170,173,174,184,187**;Dec 22, 1997;Build 163
+2 ;
+3 ; Reference to DEM^VADPT in ICR #10061
+4 ; Reference to ^DGPM in ICR #1865
+5 ; Reference to $$LJ^XLFSTR in ICR #10104
+6 ; Reference to $$FMTE^XLFDT in ICR #10103
+7 ; Reference to ^XMD in ICR #10113
+8 ; Reference to ^XMB("NETNAME") in ICR #1131
+9 ; Reference to ^TMP supported by SACC 2.3.2.5.1
+10 ; Reference to ^DIC(42 in ICR #1848
+11 ;
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 ;173
NEW ECXDSC,W,WTO,X1,X2,X,ECXDPRPC,ECXDAPPC,ECDIS,YEARMON,REC,VAL
+2 ;tjl 166
NEW ECXSTANO
+3 ;170 Keeps track of ASIH other facility records that need to be created
KILL ^TMP($JOB,"ASIH")
+4 KILL ECXDD
DO FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
+5 SET ECPRO=$EXTRACT(+$PIECE(ECXDD("SPECIFIER"),"P",2))
KILL ECXDD
+6 ;173 Set yearmon to extract year and month
SET ECED=ECED+.3
SET QFLG=0
SET YEARMON=$PIECE(EC23,U)
+7 ;187 - Begins. In the following lines, removed the check of QFLG to bypass records that had no admission date/time
+8 ;Q:QFLG
FOR ECM=2,3
SET ECARG="ATT"_ECM
SET ECD=ECSD1
Begin DoDot:1
+9 ;Q:QFLG
FOR
SET ECD=$ORDER(^DGPM(ECARG,ECD))
SET ECDA=0
if ('ECD)!(ECD>ECED)
QUIT
Begin DoDot:2
+10 ;Q:QFLG
FOR
SET ECDA=$ORDER(^DGPM(ECARG,ECD,ECDA))
if 'ECDA
QUIT
DO GET
End DoDot:2
End DoDot:1
+11 ; Q:QFLG
SET ECDA=0
FOR
SET ECDA=$ORDER(^TMP($JOB,"ASIH",ECDA))
if '+ECDA
QUIT
SET ECM=3
DO DISASIH
+12 ;187 - Ends
+13 ;173 Review patients that were still on ASIH last month
SET REC=0
FOR
SET REC=$ORDER(^XTMP("ECXMOV",YEARMON,REC))
if '+REC
QUIT
SET VAL=$$NEEDADR^ECXUTL6("TRAN",REC,"MOV")
IF +VAL
SET ECDA=$PIECE(VAL,U,2)
SET ECM=3
DO DISASIH
+14 ;187
IF $DATA(^TMP($JOB,"ECXMOVMM"))
DO SENDMSG
+15 ;173
DO CLEAN
+16 ;170
KILL ^TMP($JOB,"ASIH")
+17 QUIT
+18 ;
GET ;170 Moved record creation to be under "GET"
+1 ;170
NEW NEEDREC
+2 ;184
NEW ECXNMPI,ECXCERN,ECXSIGI
+3 if '$DATA(^DGPM(ECDA,0))
QUIT
SET EC=^(0)
+4 SET ECXDFN=+$PIECE(EC,U,3)
SET ECMT=$PIECE(EC,U,18)
SET ECXDATE=ECD
+5 KILL ECXPAT
SET OK=$$PAT^ECXUTL3(ECXDFN,$PIECE(ECXDATE,"."),"1;",.ECXPAT)
+6 ;187 Bypass records with BAD SSN.
IF 'OK
DO SETTMP("INVALID SSN",ECDA,ECD,ECXDFN,"")
KILL ECXPAT
QUIT
+7 ;184 Added ECXNMPI
SET ECXPNM=ECXPAT("NAME")
SET ECXSSN=ECXPAT("SSN")
SET (ECXNMPI,ECXMPI)=ECXPAT("MPI")
+8 ;184 Self Identified Gender
SET ECXSIGI=ECXPAT("SIGI")
+9 SET ECTM=$$ECXTIME^ECXUTL(ECD)
+10 SET WTO=$PIECE(EC,U,6)
SET ECXWTO=$PIECE($GET(^DIC(42,+WTO,44)),U)
+11 ;
+12 ;reset EC to admission movement and hold discharge movement ECX*128
+13 ;187 Begins
+14 ;S ECCA=$P(EC,U,14),EC=$G(^DGPM(ECCA,0)),ECA=$P(EC,U) I EC="" D MAIL(ECDA) S QFLG=1 Q
+15 SET ECCA=$PIECE(EC,U,14)
SET EC=$GET(^DGPM(ECCA,0))
SET ECA=$PIECE(EC,U)
IF EC=""
DO SETTMP("MISSING ADMISSION RECORD",ECDA,ECD,ECXDFN,ECXSSN)
QUIT
+16 ;187 Missing Movement Type.
IF ECMT=""
DO SETTMP("MISSING MOVEMENT TYPE",ECDA,ECD,ECXDFN,ECXSSN)
QUIT
+17 ;187 Ends
+18 ;
+19 ;if date of previous xfer movement is greater than admit date,
+20 ;then reset EC to that previous xfer movement
+21 SET ECDL=9999999.9999999-ECD
SET ECDL=+$ORDER(^DGPM("ATID2",ECXDFN,ECDL))
+22 SET ECDAL=+$ORDER(^DGPM("ATID2",ECXDFN,ECDL,0))
+23 IF $DATA(^DGPM(ECDAL,0))
IF $PIECE(^(0),U)>$PIECE(EC,U)
SET EC=^(0)
+24 ;
+25 IF ECM=2
Begin DoDot:1
+26 ;170 If it's an ASIH record and we need a discharge record, store it for later
IF $$ISASIH^ECXUTL6(ECDA,ECM)
SET NEEDREC=$$NEEDADR^ECXUTL6("TRAN",ECDA,"MOV")
IF +NEEDREC
SET ^TMP($JOB,"ASIH",$PIECE(NEEDREC,U,2))=""
+27 ;if transact=Transfer,ECD (time)=ASIH (7chars) and >0,set ECXDATE
+28 ;to Admit DT/time before calling funct to get in/out stat & TS
+29 IF $LENGTH($PIECE(ECD,".",2))=7
IF +$EXTRACT($PIECE(ECD,".",2),7)>0
SET ECXDATE=ECA
+30 SET W=$PIECE(EC,U,6)
End DoDot:1
+31 ;
+32 IF ECM=3
Begin DoDot:1
+33 ;170 If patient is discharged and we need an ASIH discharge record, store it for later
IF $$ISASIH^ECXUTL6(ECDA,ECM)
SET NEEDREC=$$NEEDADR^ECXUTL6("DIS",ECDA,"MOV")
IF +NEEDREC
SET ^TMP($JOB,"ASIH",$PIECE(NEEDREC,U,2))=""
+34 ;subtract 1 second from dischg DT so IN5^VADPT call (in ECXUTL2
+35 ;API) will pick up discharge movmement record
+36 SET ECXDATE=$$FMADD^XLFDT(ECXDATE,,,,-1)
+37 ;set losing ward to ward at discharge
+38 NEW WARD
SET WARD=$$GET1^DIQ(405,ECDA,200)
+39 IF WARD'=""
SET W=+$ORDER(^DIC(42,"B",WARD,0))
End DoDot:1
+40 ;
+41 ;-Gets inpat/outpat status, DOM, Treating Spec (TS)
+42 SET X=$$INP^ECXUTL2(ECXDFN,ECXDATE)
SET ECXA=$PIECE(X,U)
SET ECXDOM=$PIECE(X,U,10)
SET ECXTS=$PIECE(X,U,3)
+43 ;
+44 SET (ECXWRD,ECXFAC,ECXDSSD,ECXSTANO)=""
+45 IF W'=""
Begin DoDot:1
+46 SET ECXWRD=$PIECE($GET(^DIC(42,W,44)),U)
SET ECXFAC=$PIECE($GET(^DIC(42,W,0)),U,11)
+47 SET ECXDSSD=$PIECE($GET(^ECX(727.4,W,0)),U,2)
+48 ;tjl 166 - Set Patient Division based on gaining/losing ward
SET ECXSTANO=$$GETDIV^ECXDEPT(ECXFAC)
End DoDot:1
+49 SET ECDI=$SELECT(ECM=2:"",1:$$ECXDATE^ECXUTL(ECD,ECXYM))
+50 SET X1=ECD
SET X2=$PIECE(EC,U)
DO ^%DTC
SET ECXLOS=X
+51 ;
+52 ;- Get discharge PC Team, Primary and Assoc Primary Provider
+53 SET (ECXDPCT,ECXDPR,ECXDAPR,ECXDPRPC,ECXDAPPC)=""
+54 IF ECM=3
Begin DoDot:1
+55 SET ECXDSC=$$PRIMARY^ECXUTL2(ECXDFN,ECD)
+56 SET ECXDPCT=$PIECE(ECXDSC,U)
SET ECXDPR=$PIECE(ECXDSC,U,2)
SET ECXDAPR=$PIECE(ECXDSC,U,5)
SET ECXDPRPC=$PIECE(ECXDSC,U,3)
SET ECXDAPPC=$PIECE(ECXDSC,U,6)
+57 SET ECDAPRNP=$PIECE(ECXDSC,U,7)
SET ECDPRNPI=$PIECE(ECXDSC,U,4)
End DoDot:1
+58 ;
+59 ;Get production division ;p-46
+60 ;p-46
NEW ECXPDIV
SET ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC)
+61 ;- Observation patient indicator (YES/NO)
+62 SET ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+63 ;
+64 ; ******* - PATCH 127, ADD PATCAT CODE ********
+65 SET ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
+66 ;- If no encounter number, don't file record
+67 SET ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECA,,ECXTS,ECXOBS,ECHEAD,,)
+68 ;174 If T.S. found and it's a discharge mvmt, set ECXTS to PTF code for T.S.
IF ECXTS
SET ECXTS=$SELECT(ECM=3:$$GET1^DIQ(42.4,ECXTS_",",7),1:"")
+69 if ECXENC'=""
DO FILE
+70 QUIT
+71 ;
FILE ;file the extract record
+1 ;node0
+2 ;fac ECXFAC^dfn ECXDFN^ssn ECXSSN^name ECXPNM^in/out ECXA^
+3 ;day (ECD)^^adm date (ECA)^disc date ECDI^mov # ECDA^
+4 ;placehold type ECM^losing ward ECXWARD^treating spec PTF code (ECXTS)^los ECXLOS^^
+5 ;movement type ECMT^mov time ECTM^gaining ward ECXWTO^
+6 ;adm time (ECA)^^^
+7 ;node1
+8 ;mpi ECXMPI^placeholder ECXDSSD^dom ECXDOM^observ pat ind ECXOBS^
+9 ;encounter num ECXENC^disch prim prov ECXDPR^disch PC team ECXDPCT^
+10 ;disch assoc prim prov ECXDAPR^production division ECXPDIV
+11 ;^disch prov person class ECXDPRPC^disch assoc prov pe-
+12 ;rson person class^disch assoc pc prov npi ECDAPRNP^discharge pc provider npi ECDPRNPI
+13 ;^ Patient Division ECXSTANO
+14 ;node2
+15 ;Placehold CERNER
+16 ;node3
+17 ;new MPI ECXNMPI^ Self Identified Gender ECXSIGI
+18 NEW DA,DIK
+19 ;184 - field retired
IF ECXLOGIC>2022
SET ECXMPI=""
+20 SET EC7=$ORDER(^ECX(ECFILE,999999999),-1)
SET EC7=EC7+1
+21 SET ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+22 SET ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_U
+23 ;174 Add treating specialty PTF value and remove type
SET ECODE=ECODE_$$ECXDATE^ECXUTL(ECA,ECXYM)_U_ECDI_U_ECDA_U_$SELECT(ECXLOGIC>2019:"",1:ECM)_U_ECXWRD_U_$SELECT(ECXLOGIC>2019:ECXTS,1:"")
+24 SET ECODE=ECODE_U_ECXLOS_U_U_ECMT_U_ECTM_U_ECXWTO_U
+25 SET ECODE=ECODE_$$ECXTIME^ECXUTL(ECA)_U_U_U
+26 SET ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXDPR_U
+27 ;p-46 added ECXPDIV
SET ECODE1=ECODE1_ECXDPCT_U_ECXDAPR_U_ECXPDIV
+28 IF ECXLOGIC>2005
SET ECODE1=ECODE1_U_ECXDPRPC_U_ECXDAPPC
+29 IF ECXLOGIC>2007
SET ECODE1=ECODE1_U_$GET(ECDAPRNP)_U_$GET(ECDPRNPI)
+30 ;P-127 ADDED PATCAT
IF ECXLOGIC>2010
SET ECODE1=ECODE1_U_ECXPATCAT
+31 ;tjl 166 ,184 - Added "^"
IF ECXLOGIC>2017
SET ECODE1=ECODE1_U_ECXSTANO_U
+32 ;184 - Added NMPI, SIGI
IF ECXLOGIC>2022
SET ECODE2=$GET(ECXCERN)_U
SET ECODE3=ECXNMPI_U_ECXSIGI
+33 ;184 Move the record count to below
SET ^ECX(ECFILE,EC7,0)=ECODE
SET ^ECX(ECFILE,EC7,1)=ECODE1
+34 ;184
SET ^ECX(ECFILE,EC7,2)=$GET(ECODE2)
SET ^ECX(ECFILE,EC7,3)=$GET(ECODE3)
+35 ;184 - Move record count from above
SET ECRN=ECRN+1
+36 SET DA=EC7
SET DIK="^ECX("_ECFILE_","
DO IX1^DIK
KILL DIK,DA
+37 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET QFLG=1
+38 QUIT
+39 ;
SETUP ;Set required input for ECXTRAC
+1 SET ECHEAD="MOV"
+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
QUIT
MAIL(ECXDA) ;
+1 ; Created to send a message pointing to a bad record ECX*128
+2 ; Input - ECXDA is the PATIENT MOVEMENT (#405) record number for the discharge that has no admission
+3 ; associated with it. ECX*128
+4 NEW XMSUB,XMTEXT,XMY,MSGTEXT,LINENUM
+5 ;;Setup necessary variables to send the message
+6 SET XMSUB="Movement Record Error - Please Fix"
+7 SET XMTEXT="MSGTEXT("
+8 SET XMY("G.DSS-MOVS@"_^XMB("NETNAME"))=""
+9 ;;Create the message to be sent
+10 SET LINENUM=1
+11 SET MSGTEXT(LINENUM)="The Transfer and Discharge Extract did not complete due to the error below"
+12 SET LINENUM=LINENUM+1
SET MSGTEXT(LINENUM)=""
SET LINENUM=LINENUM+1
+13 SET MSGTEXT(LINENUM)="Discharge movement record "_ECXDA_" does not have an admission movement associated with it."
+14 SET LINENUM=LINENUM+1
SET MSGTEXT(LINENUM)=""
SET LINENUM=LINENUM+1
+15 SET MSGTEXT(LINENUM)="This record needs to be fixed and the extract needs to be run again."
+16 SET LINENUM=LINENUM+1
SET MSGTEXT(LINENUM)=""
+17 DO ^XMD
+18 QUIT
+19 ;
DISASIH ;170 Section added to create a discharge ASIH other facility record
+1 NEW OK,EC,ECXPAT,WTO,ECXWTO,X,ECA,ECD,WARD,ECXFAC,ECXDSSD,ECXSTANO,ECXPDIV,ECXOBS,ECXPATCAT,ECXENC,ECDI,ECCXLOS,ECXDPCT,ECXDPR,ECXDAPR,ECXDPRPC,ECXDAPPC,ECXDSC,ECDAPRNP,ECDPRNPI,ECM,ECMT
+2 NEW ECTM,ECXA,ECXDFN,ECXDOM,ECXLOS,ECXMPI,ECXPNM,ECXSSN,ECXTS,ECXWRD
+3 ;184
NEW ECXNMPI,ECXCERN,ECXSIGI
+4 if '$DATA(^DGPM(ECDA,0))
QUIT
SET EC=^(0)
+5 SET ECXDFN=+$PIECE(EC,U,3)
SET ECMT=$PIECE(EC,U,18)
SET ECXDATE=$PIECE(EC,U)
+6 ;Q:'OK 187 - Bad records, don't quit. Save the record and send MM at the end
SET OK=$$PAT^ECXUTL3(ECXDFN,$PIECE(ECXDATE,"."),"1;",.ECXPAT)
+7 ;187
IF 'OK
DO SETTMP("INVALD SSN",ECDA,ECD,ECXDFN,"")
QUIT
+8 ;184 Added ECXNMPI
SET ECXPNM=ECXPAT("NAME")
SET ECXSSN=ECXPAT("SSN")
SET (ECXNMPI,ECXMPI)=ECXPAT("MPI")
+9 ;184 Self Identified Gender
SET ECXSIGI=ECXPAT("SIGI")
+10 SET X=$$INP^ECXUTL2(ECXDFN,$$FMADD^XLFDT(ECXDATE,,,,-1))
+11 SET ECXDOM=$PIECE(X,U,10)
SET ECXTS=$PIECE(X,U,3)
SET ECXA=$PIECE(X,U)
+12 SET ECA=$PIECE(X,U,4)
+13 SET ECD=$PIECE(X,U,6)
+14 SET ECDI=$$ECXDATE^ECXUTL(ECD,ECXYM)
+15 SET ECM=3
+16 SET ECMT=$PIECE(EC,U,18)
+17 ;187 Missing Movement Type
IF ECMT=""
DO SETTMP("MISSING MOVEMENT TYPE",ECDA,ECA,ECXDFN,ECXSSN)
QUIT
+18 SET ECTM=$$ECXTIME^ECXUTL(ECD)
+19 SET (ECXWRD,WTO,ECXWTO,WARD,ECXFAC,ECXDSSD,ECXSTANO,ECXLOS,ECXDPCT,ECXDPR,ECXDAPR,ECXDPRPC,ECXDAPPC,ECXDSC,ECDAPRNP,ECDPRNPI)=""
+20 SET ECXWRD=$$GET1^DIQ(405,ECDA,200)
+21 ;Gets ward at discharge
if ECXWRD'=""
SET ECXWRD=+$ORDER(^DIC(42,"B",ECXWRD,0))
+22 ;Gets ward from transfer
if ECXWRD=""
SET ECXWRD=$PIECE(EC,U,6)
+23 ;Get facility based on ward, reset ward to null
IF ECXWRD'=""
SET ECXFAC=$PIECE($GET(^DIC(42,ECXWRD,0)),U,11)
SET ECXWRD=""
+24 SET ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC)
+25 SET ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+26 SET ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
+27 SET ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECA,,ECXTS,ECXOBS,ECHEAD,,)
+28 SET ECXA="A"
+29 ;174 Field will be null if discharge is ASIH OTHER FACILITY type
SET ECXTS=""
+30 if ECXENC'=""
DO FILE
+31 QUIT
+32 ;
CLEAN ;173 Retain the six most recent sets of entries for ASIH review
+1 NEW DATE,CNT,NUM
+2 SET (DATE,CNT)=0
+3 FOR
SET DATE=$ORDER(^XTMP("ECXMOV",DATE))
if '+DATE
QUIT
SET CNT=CNT+1
+4 ;Maintain list at a maximum of six groupings/months
FOR NUM=CNT:-1:7
SET DATE=$ORDER(^XTMP("ECXMOV",0))
if DATE=""
QUIT
KILL ^XTMP("ECXMOV",DATE)
+5 ;Set XTMP zero node as required
SET ^XTMP("ECXMOV",0)=$$FMADD^XLFDT(DT,365)_"^"_DT_"^"_"List of ASIH movements without a corresponding return movement"
+6 QUIT
+7 ;
SETTMP(ERRMSG,ECDA,ECDATE,DFN,SSN) ;187 Set TMP global for MM messages
+1 NEW ECMOVDT,VADM,ECXSSN,PTNAME
+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 IF SSN=""
SET SSN=$PIECE(VADM(2),U)
SET ERRMSG="INVALID SSN"
+7 SET ^TMP($JOB,"ECXMOVMM",ERRMSG,DFN,ECDA)=VADM(1)_U_SSN_U_ECMOVDT_U_ECDA
+8 QUIT
+9 ;
SENDMSG ; Added for patch 187. SEND MM messages
+1 NEW ERRMSG,ECMSG,ECDFN,ECSSN,ECSTR,ECDA,I,J,XMY,XMDUZ,XMSUB,XMTEXT
+2 IF '$DATA(^TMP($JOB,"ECXMOVMM"))
QUIT
+3 SET XMSUB="RECORDS NOT PROCESSED in DSS-"_ECPACK_" Extract (#"_$PIECE(EC23,U,2)_")"
+4 KILL XMY
SET XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
SET XMDUZ="DSS SYSTEM"
+5 SET ECMSG(1,0)="The DSS-"_ECPACK_" Extract (#"_$PIECE(EC23,U,2)_") process for "_ECSDN_" through "_ECEDN
+6 SET ECMSG(2,0)="contains the records in the MOVEMENT file (#405) that were not extracted"
+7 SET ECMSG(3,0)="due to missing information."
+8 SET ECMSG(4,0)=""
+9 SET ERRMSG=""
SET J=0
+10 FOR I=1:1
SET ERRMSG=$ORDER(^TMP($JOB,"ECXMOVMM",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)="Patient Name SSN MOVEMENT DATE/TIME RECORD #"
SET J=J+1
+13 SET ECMSG(5*I+J,0)="-------------------------------------------------------------------------------"
SET J=J+1
+14 SET ECDFN=""
+15 FOR J=J:1
SET ECDFN=$ORDER(^TMP($JOB,"ECXMOVMM",ERRMSG,ECDFN))
if ECDFN=""
QUIT
Begin DoDot:2
+16 SET ECDA=0
+17 FOR
SET ECDA=$ORDER(^TMP($JOB,"ECXMOVMM",ERRMSG,ECDFN,ECDA))
if ECDA=""
QUIT
Begin DoDot:3
+18 SET ECSTR=^TMP($JOB,"ECXMOVMM",ERRMSG,ECDFN,ECDA)
+19 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
End DoDot:3
End DoDot:2
+20 SET J=J+1
SET ECMSG(5*I+J,0)=""
End DoDot:1
+21 SET XMTEXT="ECMSG("
+22 DO ^XMD
+23 KILL ^TMP($JOB,"ECXMOVMM")
+24 QUIT
