Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ECXUSUR1

ECXUSUR1.m

Go to the documentation of this file.
  1. ECXUSUR1 ;ALB/TJL-Surgery Pre-Extract Unusual Volume Report ;6/15/17 15:44
  1. ;;3.0;DSS EXTRACTS;**49,71,105,111,128,148,161,166,184,185,187**;Dec 22, 1997;Build 163
  1. ;
  1. ; Reference to ^SRF in ICR #103
  1. ; Reference to ^SRO(137.45 in ICR #1855
  1. ; Reference to ^DG(40.8,"AD" in ICR #2817
  1. ; Reference to $$FMDIFF^XLFDT in ICR #10103
  1. ; Reference to ^TMP supported by SACC 2.3.2.5.1
  1. ; Reference to ^DIC(45.3 in ICR #218
  1. ;
  1. EN ;
  1. N ECHEAD,COUNT,TIMEDIF,ECXPROC
  1. S ECHEAD="SUR"
  1. S (COUNT,QFLG)=0,ECED=ECED+.3,ECD=ECSD1
  1. F S ECD=$O(^SRF("AC",ECD)) Q:('ECD)!(ECD>ECED)!(QFLG) D
  1. .S ECD0=0
  1. .F S ECD0=$O(^SRF("AC",ECD,ECD0)) Q:'ECD0 D
  1. ..I $D(^SRF(ECD0,0)) S ECXDFN=+$P(^(0),U,1) D STUFF Q:QFLG
  1. Q
  1. ;
  1. STUFF ;gather data
  1. N J,DATA1,DATA2,DATAOP,ECXNONL,ECXSTOP,DATAPA ;161
  1. N ECXPDIV,ECDIV ;184
  1. N ECNTIME,ECSA,ECSAPC,ECXPA,ECXPAPC,DATA3 ;187
  1. N ECXPDVNM,PRODVSTR,DIQ,DR,DA,DIC,INST,ECXDIV,ECDIVIEN ;185
  1. S ECXPDIV="" ;184
  1. S ECXDATE=ECD,ECXERR=0,ECXQ=""
  1. Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXDATE,"1;2;3;5;")
  1. S EC0=^SRF(ECD0,0)
  1. S DATA1=$S($D(^SRF(ECD0,.1)):^(.1),1:"")
  1. S DATA2=$S($D(^SRF(ECD0,.2)):^(.2),1:"")
  1. S DATAOP=$S($D(^SRF(ECD0,"OP")):^("OP"),1:"")
  1. S DATAPA=$S($D(^SRF(ECD0,1.1)):^(1.1),1:"")
  1. S DATA3=$S($D(^SRF(ECD0,.3)):^(.3),1:"") ;187
  1. S ECSA=$P(DATA3,U,4) ;187
  1. S ECXPA=$P(DATA3,U) ;187
  1. S ECSAPC=$$PRVCLASS^ECXUTL(ECSA,ECXDATE) ;187
  1. S ECXPAPC=$$PRVCLASS^ECXUTL(ECXPA,ECXDATE) ;187
  1. S ECNO=$G(^SRF(ECD0,"NON"))
  1. S ECDIV=$S($D(^SRF(ECD0,8)):^(8),1:"") ;184
  1. ;S ECXPDIV=$$RADDIV^ECXDEPT(ECDIV) ;184 - Production Division; 185
  1. S ECDIVIEN=$O(^DG(40.8,"AD",ECDIV,0)) ;185
  1. S DIC="^DG(40.8,",DR=".01;1",DIQ(0)="I",DIQ="ECXDIV",DA=ECDIVIEN K ECXDIV D EN^DIQ1 ;185 - Get Division Number and Name
  1. S ECXPDIV=ECXDIV(40.8,ECDIVIEN,1,"I") ;185
  1. S ECXPDVNM=ECXDIV(40.8,ECDIVIEN,.01,"I") ;185
  1. S PRODVSTR=ECXPDIV_"~"_ECXPDVNM ;185
  1. ;get data
  1. S ECSS=$P($G(^SRO(137.45,+$P(EC0,U,4),0)),U,2)
  1. S ECSS=$$RJ^XLFSTR($P($G(^DIC(45.3,+ECSS,0)),U),3,0)
  1. S:ECSS="000" ECSS="999"
  1. ;look for non-OR
  1. S (ECNT,ECNL,ECXNONL,ECXSTOP)=""
  1. I $P(ECNO,U)="Y" D
  1. .S A1=$P(ECNO,U,5)
  1. .S A2=$P(ECNO,U,4)
  1. .S (TIME,ECNT)=$$CHKTM(A2,A1) ;161
  1. .I A1&(A2)&(TIME="") D TIME ;161
  1. .S ECXNONL=+$P(ECNO,U,2)
  1. .S ECNL=$P($G(^ECX(728.44,ECXNONL,0)),U,9)
  1. .I ECNL="" S ECNL="UNKNOWN"
  1. .;
  1. .; Get DSS Stop Code to use in encounter number
  1. .S ECXSTOP=$P($G(^ECX(728.44,ECXNONL,0)),U,4)
  1. ;
  1. ;retrieving anesthesia times first, then operation and patient
  1. ;times, then storing in following order:
  1. ;ecode0="recovery room time^pt hold area time^or clean time^patient
  1. ;time^operation time^anesthesia time
  1. S ECODE0=""
  1. S ECNTIME="" ;187
  1. F J="2,3","10,12","13,14","15,10","1,4" D ;187 Anesthesia time is calculated last
  1. .S A2=$P(DATA2,U,$P(J,","))
  1. .S A1=$P(DATA2,U,$P(J,",",2))
  1. .S TIME=$$CHKTM(A2,A1) ;161
  1. .I +J=1 D ANTIME^ECXSURG S:TIME="" TIME="NO TIMES" ;187
  1. .I A1&(A2)&(TIME="") D TIMEDIF(A1,A2) D ;161
  1. ..I +J'=2 D TIME
  1. ..I +J=10 S ECNTIME=TIME ;187
  1. ..I +J=2 D ;-Operation Time
  1. ...S TIME=$TR($J(TIMEDIF,4,0)," ")
  1. ...;I TIME<0 S TIME="###"
  1. .S ECODE0=TIME_U_ECODE0 K TIME
  1. S ECODE0=$P(ECODE0,U,2,5)_U_$P(ECODE0,U)_U ;187
  1. ;retrieve recovery room (PACU) time
  1. S A2=$P($G(DATAPA),U,7)
  1. S A1=$P($G(DATAPA),U,8)
  1. S TIME=$$CHKTM(A2,A1) ;161
  1. I A1&(A2)&(TIME="") D TIME ;161
  1. S ECODE0=TIME_U_ECODE0 K TIME
  1. ;Place the NON-OR PROCEDURE into the operation time for the report ECX*128
  1. I ECNL]"" S $P(ECODE0,U,5)=ECNT
  1. ;
  1. ;- Was surgery cancelled/aborted
  1. S ECCAN=$P($G(^SRF(ECD0,30)),U)
  1. I +ECCAN S ECCAN=$$CANC^ECXUTL4(ECNL,$P(DATA2,U,10))
  1. ;
  1. I ECXFLAG D FILE Q
  1. N PIECE,FILE
  1. S FILE="NO"
  1. F PIECE=1,2,3,4,5,6 D
  1. . I $P(ECODE0,U,PIECE)>ECTHLD S FILE="YES"
  1. . I $P(ECODE0,U,PIECE)<0 S FILE="YES"
  1. ;
  1. I FILE="YES" D FILE Q:ECXERR
  1. Q
  1. ;
  1. FILE ; Store unusual records for display later
  1. N OK,SURPAT,SURNAME,SURSSN,SURDT,VOL
  1. S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECD,"."),"1;",.SURPAT)
  1. I 'OK Q
  1. S SURNAME=SURPAT("NAME")
  1. S SURSSN=SURPAT("SSN")
  1. S SURDT=$E(ECXDATE,4,5)_"/"_$E(ECXDATE,6,7)_"/"_$E(ECXDATE,2,3)
  1. ;
  1. ; Observation Patient Indicator (yes/no)
  1. S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECNL)
  1. ;
  1. ; Principal Procedure
  1. S ECXPROC=$S('$G(ECXPORT):$E($P(DATAOP,U),1,15),1:$P(DATAOP,U)) ;161 Report full procedure if exporting
  1. ;
  1. ; If no encounter number don't file record
  1. S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC=""
  1. ;
  1. S VOL=$P(ECODE0,U)
  1. I $P(ECODE0,U,2)>VOL S VOL=$P(ECODE0,U,2)
  1. I $P(ECODE0,U,3)>VOL S VOL=$P(ECODE0,U,3)
  1. ;S ^TMP($J,-VOL,-ECD0)=SURNAME_U_SURSSN_U_SURDT_U_ECD0_U_ECXENC_U_ECODE0_U_ECXPROC_U_ECCAN_U_ECXPDIV ;184 Added ECXPDIV
  1. S ^TMP($J,PRODVSTR,-VOL,-ECD0)=SURNAME_U_$S(ECXPORT:SURSSN,1:$E(SURSSN,6,9))_U_SURDT_U_ECD0_U_ECXENC_U_ECODE0_U_ECXPROC_U_ECCAN ;184 Added ECXPDIV,185 Replaced ECXPDIV with PRODVSTR
  1. S COUNT=COUNT+1
  1. I COUNT#100=0 I $$S^ZTLOAD S (ZTSTOP,ECXERR)=1 ;166 Changed ZSTOP to ZTSTOP
  1. Q
  1. ;
  1. TIME ; given date/time get increment
  1. N CON
  1. S CON=$P($G(^SRF(ECD0,"CON")),U)
  1. D TIMEDIF(A1,A2)
  1. I 'CON D
  1. .S TIME=$J($TR($J(TIMEDIF,4,0)," "),2,1)
  1. .S:TIME>"99.0" TIME="99.0"
  1. I CON D
  1. .S TIME=$J(($TR($J(TIMEDIF,4,0)," ")/2),2,1)
  1. .S:TIME>"99.5" TIME="99.5"
  1. ;S:TIME<0 TIME="###"
  1. Q
  1. ;
  1. TIMEDIF(START,FINISH) ; Set values to be compared, in seconds
  1. ;
  1. S TIMEDIF=$$FMDIFF^XLFDT(START,FINISH,2)/900
  1. I (TIMEDIF>0)&(TIMEDIF<.5) S TIMEDIF=.5
  1. Q
  1. ;
  1. CHKTM(ST,END) ;161 Identify any incorrect or missing times
  1. Q $S('ST&('END):"NO TIMES",'ST:"NO BEG TM",'END:"NO END TM",ST>END:"CHECK TM",1:"")
  1. ;
  1. EXIT S ECXERR=1 Q