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

BGPMUH01.m

Go to the documentation of this file. 
  1. BGPMUH01 ; IHS/MSC/MGH - MI measure NQF0495&NQF0497 ED-1 ;13-May-2011 16:00;MGH
  1.  ;;11.1;IHS CLINICAL REPORTING SYSTEM;**1**;JUN 27, 2011;Build 106
  1.  ;ED meaningful use reports
  1.  ;Uses entries in the emergency room package
  1. ENTRY(RPT) ;PEP  0495 Median time admission to discharge from ED
  1.  N START,END,ERADMIT,IEN,ERDIS,DFN,ERVST,ERPRV,ERDX,EREND,ERPRIDX,DXCHK,POP,ADMIT,LIST,ADMOR
  1.  S START=BGPBDATE
  1.  S END=BGPEDATE_".2359"
  1.  ;Collect the data from the ER visit
  1.  F  S START=$O(^AMERVSIT("B",START)) Q:START=""!(START>END)  D
  1.  .S IEN="" F  S IEN=$O(^AMERVSIT("B",START,IEN)) Q:IEN=""  D
  1.  ..S ERADMIT=$P($G(^AMERVSIT(IEN,0)),U,1)
  1.  ..Q:'ERADMIT
  1.  ..S DFN=$P($G(^AMERVSIT(IEN,0)),U,2),ERVST=$P($G(^AMERVSIT(IEN,0)),U,3)
  1.  ..Q:'DFN
  1.  ..S BGPACTUP=$$ACTUPAP^BGPMUEPD(DFN,BGPBDATE,BGPEDATE,BGPBEN)
  1.  ..I 'BGPACTUP,'$G(BGPXPXPX),'$G(BGPIISO) Q
  1.  ..S ERPRV=$P($G(^AMERVSIT(IEN,0)),U,6)
  1.  ..S ERPRIDX=$P($G(^AMERVSIT(IEN,5.1)),U,2)
  1.  ..Q:'ERPRIDX
  1.  ..S ERDIS=$P($G(^AMERVSIT(IEN,6)),U,1),EREND=$P($G(^AMERVSIT(IEN,6)),U,2)
  1.  ..Q:'EREND
  1.  ..;Set the default population for count
  1.  ..S POP=1
  1.  ..;Find admission and see if it was for OBS
  1.  ..S ADMIT=$$FINDADM(DFN,ERADMIT,EREND)
  1.  ..I ADMIT D
  1.  ...I ADMIT=2 D
  1.  ....S POP=2
  1.  ....D RECSAVE(RPT,POP,.LIST,ERADMIT)
  1.  ...;Check to see if primary dx was for behavioral health
  1.  ...S DXCHK=$$CKDX(ERPRIDX)
  1.  ...I +DXCHK D
  1.  ....S POP=3    ;visits of behavioral health
  1.  ....D RECSAVE(RPT,POP,.LIST,ERADMIT)
  1.  ...;Add to default population if not behavioral health or OBS
  1.  ...I POP=1 D
  1.  ....D RECSAVE(RPT,POP,.LIST,ERADMIT)
  1.  Q
  1. FINDADM(DFN,ERADMIT,EREND) ;FIND AN ADMISSION
  1.  N ADMIT,MGVT,MVTDT,MTVED,MVTIEN,X,X1,X2,TRANS,OBS,WARD,MVTFAC,TRANS2,FAC,SPEC
  1.  N MVTED,SRC,UB
  1.  S ADMIT=0
  1.  S X1=ERADMIT,X2=1 D C^%DTC S MVTED=X
  1.  S MVTIEN="" F  S MVTIEN=$O(^DGPM("C",DFN,MVTIEN)) Q:MVTIEN=""  D
  1.  .;The movement must be an admission movement
  1.  .S MVTDT=$P($G(^DGPM(MVTIEN,0)),U,1)
  1.  .Q:MVTDT<ERADMIT!(MVTDT>MVTED)
  1.  .S TRANS=$P($G(^DGPM(MVTIEN,0)),U,2)
  1.  .I TRANS=1 D
  1.  ..S SRC=$P($G(^DGPM(MVTIEN,"IHS")),U,6)
  1.  ..Q:'SRC
  1.  ..S UB=$P($G(^AUTTASRC(SRC,0)),U,2)
  1.  ..Q:UB'=7
  1.  ..S WARD=$P($G(^DGPM(MVTIEN,0)),U,6)
  1.  ..;Quit if the ward itself is an observation ward
  1.  ..I WARD'="" D
  1.  ...S OBS=$$WARDCK(WARD)
  1.  ...S:+OBS ADMIT=2
  1.  ..;Next check for the specialty on the admission
  1.  ..S SPEC=0
  1.  ..S MVTFAC="" F  S MVTFAC=$O(^DGPM("CA",MVTIEN,MVTFAC)) Q:MVTFAC=""!(+SPEC)  D
  1.  ...S TRANS2=$P($G(^DGPM(MVTFAC,0)),U,2)
  1.  ...I TRANS2=6 D
  1.  ....S FAC=$P($G(^DGPM(MVTFAC,0)),U,9)
  1.  ....I FAC'="" D
  1.  .....S SPEC=$$SPEC(FAC)
  1.  .....S:+SPEC ADMIT=2
  1.  ..S:'ADMIT ADMIT=1
  1.  Q ADMIT
  1. CKDX(DX) ;Check for primary diagnosis of behavioral health issue
  1.  N RESULT,BGPTX,TAX
  1.  S RESULT=0
  1.  S TAX="BGPMU ED MENTAL DISORDERS"
  1.  S BGPTX=$O(^ATXAX("B",TAX,0))  ;get taxonomy ien
  1.  I BGPTX="" Q 0  ;not a valid taxonomy
  1.  S RESULT=$$ICD^ATXCHK(DX,BGPTX,9)
  1.  Q RESULT
  1.  ;Observation specialties from the Specialty (#42.4) file are:
  1.  ;
  1.  ;     18 - Neurology Observation
  1.  ;     23 - Spinal Cord Injury Observation
  1.  ;     24 - Medical Observation
  1.  ;     36 - Blind Rehab Observation
  1.  ;     41 - Rehab Medicine Observation
  1.  ;     65 - Surgical Observation
  1.  ;     94 - Psychiatric Observation
  1. WARDCK(WARD) ;ward check
  1.  N SPIFN,WSPEC
  1.  S WSPEC=0
  1.  Q:WARD="" 0
  1.  S SPIFN=$P($G(^DIC(42,WARD,0)),U,12)
  1.  Q:SPIFN="" 0
  1.  S WSPEC=$$SPEC^DGPMOBS(SPIFN)
  1.  I +WSPEC=-1 S WSPEC=0
  1.  Q WSPEC
  1. SPEC(FAC) ;specialty check
  1.  N SPIFN,FSPEC
  1.  Q:FAC="" 0
  1.  S SPIFN=$P($G(^DIC(45.7,FAC,0)),U,2)
  1.  S FSPEC=$$SPEC^DGPMOBS(SPIFN)
  1.  I +FSPEC=-1 S FSPEC=0
  1.  Q FSPEC
  1. RECSAVE(RPT,POP,LIST,ER) ;save record
  1.  I RPT=1 D
  1.  .D SAVE(.LIST,POP,ER)
  1.  I RPT=2 D
  1.  .S ADMOR=$$ORDER(DFN,ERADMIT,EREND)
  1.  .I +ADMOR D SAVE2(.LIST,POP,ER)
  1.  D TOTAL(.LIST,RPT,POP)
  1.  Q
  1. SAVE(LIST,POP,ER) ;Save the result
  1.  N TIME,X1,X2,X3,CNT,RESULT
  1.  S CNT=$G(^TMP("BGPMU0495",$J,BGPMUTF,"POP",POP,"PAT","CNT"))
  1.  S CNT=CNT+1
  1.  S X1=EREND,X2=ERADMIT,X3=2
  1.  S TIME=$$FMDIFF^XLFDT(X1,X2,X3)
  1.  S LIST("ORDERED",POP,TIME,CNT)=TIME
  1.  S LIST("POP",POP,CNT)=TIME
  1.  I POP=1 S RESULT="ED:"_(TIME/60)_" "_$$DATE^BGPMUUTL(ER) S BGPICARE("MU.ED.0495.1",BGPMUTF,CNT)=DFN_U_TIME_U_POP_U_U_RESULT
  1.  I POP=2 S RESULT="OS:"_(TIME/60)_" "_$$DATE^BGPMUUTL(ER) S BGPICARE("MU.ED.0495.2",BGPMUTF,CNT)=DFN_U_TIME_U_POP_U_U_RESULT
  1.  I POP=3 S RESULT="MD:"_(TIME/60)_" "_$$DATE^BGPMUUTL(ER) S BGPICARE("MU.ED.0495.3",BGPMUTF,CNT)=DFN_U_TIME_U_POP_U_U_RESULT
  1.  S ^TMP("BGPMU0495",$J,BGPMUTF,"POP",POP,"PAT","CNT")=CNT
  1.  S ^TMP("BGPMU0495",$J,BGPMUTF,"POP",POP,"PAT",CNT)=DFN_U_RESULT
  1.  Q
  1. SAVE2(LIST,POP,ER) ;Save the result
  1.  N TIME,X1,X2,X3,CNT,RESULT
  1.  S CNT=$G(^TMP("BGPMU0497",$J,BGPMUTF,"POP",POP,"PAT","CNT"))
  1.  S CNT=CNT+1
  1.  S X1=EREND,X2=ADMOR,X3=2
  1.  S TIME=$$FMDIFF^XLFDT(X1,X2,X3)
  1.  S LIST("ORDERED",POP,TIME,CNT)=TIME
  1.  S LIST("POP",POP,CNT)=TIME
  1.  I POP=1 S RESULT="ED:"_(TIME/60)_" "_$$DATE^BGPMUUTL(ER) S BGPICARE("MU.ED.0497.1",BGPMUTF,CNT)=DFN_U_TIME_U_POP_U_U_RESULT
  1.  I POP=2 S RESULT="MD:"_(TIME/60)_" "_$$DATE^BGPMUUTL(ER) S BGPICARE("MU.ED.0497.2",BGPMUTF,CNT)=DFN_U_TIME_U_POP_U_U_RESULT
  1.  I POP=3 S RESULT="OS:"_(TIME/60)_" "_$$DATE^BGPMUUTL(ER) S BGPICARE("MU.ED.0497.3",BGPMUTF,CNT)=DFN_U_TIME_U_POP_U_U_RESULT
  1.  S ^TMP("BGPMU0497",$J,BGPMUTF,"POP",POP,"PAT","CNT")=CNT
  1.  S ^TMP("BGPMU0497",$J,BGPMUTF,"POP",POP,"PAT",CNT)=DFN_U_RESULT
  1.  Q
  1. ORDER(DFN,START,END) ;Find the admission order
  1.  ;Admission order should be after the ER admit time and before the ER end time
  1.  N ADMIT,DISCH,PT,ORD,ORIEN,ORDIA,ORDLK,TXT,RET
  1.  S RET=""
  1.  S ADMIT=9999999-START,DISCH=9999999-END
  1.  S PT=DFN_";DPT("
  1.  S ORD=DISCH F  S ORD=$O(^OR(100,"AR",PT,ORD)) Q:ORD=""!(ORD>ADMIT)!(+RET)  D
  1.  .S ORIEN="" F  S ORIEN=$O(^OR(100,"AR",PT,ORD,ORIEN)) Q:ORIEN=""  D
  1.  ..S ORDIA=$P($G(^OR(100,ORIEN,0)),U,5)
  1.  ..S ORDLK=$P(ORDIA,";",1)
  1.  ..S TXT=$P($G(^ORD(101.41,ORDLK,0)),U,1)
  1.  ..I TXT["ADMIT" S RET=$P($G(^OR(100,ORIEN,0)),U,7)
  1.  Q RET
  1. TOTAL(LIST,RPT,POP) ;Find the median
  1.  N CNT2,MIDDLE,MID1,MID2,WHOLE,CNT,MEDIAN,OFFSET,OFFSET2,I
  1.  S MIDDLE=""
  1.  I RPT=1 D
  1.  .S CNT=$G(^TMP("BGPMU0495",$J,BGPMUTF,"POP",POP,"PAT","CNT"))
  1.  I RPT=2 D
  1.  .S CNT=$G(^TMP("BGPMU0497",$J,BGPMUTF,"POP",POP,"PAT","CNT"))
  1.  S CNT2=CNT/2
  1.  I $P(CNT2,".",2)="" D
  1.  .;EVEN number of patients - average the middle two
  1.  .S WHOLE=$P(CNT2,".",1)
  1.  .S OFFSET=0
  1.  .;;;;;;I WHOLE="" S WHOLE=0,OFFSET=$O(LIST("ORDERED",POP,OFFSET))
  1.  .I WHOLE="" S WHOLE=1
  1.  .S TIME="" F  S TIME=$O(LIST("ORDERED",POP,TIME)) Q:TIME=""!(+MIDDLE)  D
  1.  ..S PTCNT="" F  S PTCNT=$O(LIST("ORDERED",POP,TIME,PTCNT)) Q:PTCNT=""!(+MIDDLE)  D
  1.  ...S OFFSET=OFFSET+1
  1.  ...I OFFSET=WHOLE  D
  1.  ....S NXTPT=$O(LIST("ORDERED",POP,TIME,PTCNT))
  1.  ....I NXTPT'="" S (MID1,MID2)=TIME ;Two middle patients had the same time
  1.  ....E  S MID1=TIME,MID2=$O(LIST("ORDERED",POP,TIME)) ;get next time for 2nd patient
  1.  ....S MIDDLE=(MID1+MID2)/2
  1.  E  D
  1.  .;ODD number of patients - use the middle patient's time
  1.  .S WHOLE=$P(CNT2,".",1)
  1.  .S OFFSET=0
  1.  .S TIME="" F  S TIME=$O(LIST("ORDERED",POP,TIME)) Q:TIME=""!(+MIDDLE)  D
  1.  ..S PTCNT="" F  S PTCNT=$O(LIST("ORDERED",POP,TIME,PTCNT)) Q:PTCNT=""!(+MIDDLE)  D
  1.  ...S OFFSET=OFFSET+1
  1.  ...I OFFSET>WHOLE S MIDDLE=TIME
  1.  S MEDIAN=MIDDLE/60   ;get answer in minutes
  1.  I RPT=1 D
  1.  .S ^TMP("BGPMU0495",$J,BGPMUTF,"POP",POP)=MEDIAN_U_CNT
  1.  I RPT=2 D
  1.  .S ^TMP("BGPMU0497",$J,BGPMUTF,"POP",POP)=MEDIAN_U_CNT
  1.  Q
  1. ENTRY2 ;PEP  0497 Time from provider order to discharge