Routine: BGPMUH05

BGPMUH05 ;IHS/MSC/MGH - MI measure NQF0437-STK-4 ;02-Mar-2011 16:05;MGH

 ;;11.0;IHS CLINICAL REPORTING;**4**;JAN 06, 2011;Build 84

 ;ED meaningful use hospital measured

ENTRY ;PEP  Stroke Measure 4 - tPA therapy within 3hrs

 N START,END,BGPIEN,DFN,BGPVST,BGPISDX,BGPHSDX,BGPAGEE,BGPIPROB,BGPHPROB,STROKE,EXC,NUM,BGPDIS

 N BGPER,BGPADTMI,BDPDD,LKW

 ;Start by finding all admissions during the reporting period

 S START=BGPBDATE

 S END=BGPEDATE_".2359"

 F  S START=$O(^DGPM("B",START)) Q:START=""!(START>END)  D

 .S BGPIEN="" F  S BGPIEN=$O(^DGPM("B",START,BGPIEN)) Q:BGPIEN=""  D

 ..Q:$P($G(^DGPM(BGPIEN,0)),U,2)'=1    ;Only include admissions

 ..S DFN=$P($G(^DGPM(BGPIEN,0)),U,3)

 ..S BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)

 ..Q:DFN=""

 ..S BGPACTUP=$$ACTUPAP^BGPMUEHD(DFN,BGPBDATE,BGPEDATE,BGPBEN)

 ..I 'BGPACTUP,'$G(BGPXPXPX),'$G(BGPIISO) Q

 ..S BGPVST=$P($G(^DGPM(BGPIEN,0)),U,27)  ;Get the visit

 ..Q:BGPVST=""

 ..S BGPDIS=$P($G(^DGPM(BGPIEN,0)),U,17)  ;Don't use if pt is still an inpt

 ..Q:BGPDIS=""

 ..;Check for a diagnosis of stroke

 ..S STROKE=0,EXC=0,NUM=0

 ..S BGPISDX=$$VSTPOVA^BGPMUUT3(DFN,BGPVST,"BGPMU ISCHEMIC STROKE DX")

 ..;S BGPIPROB=$$PLTAX^BGPMUUT1(DFN,"BGPMU ISCHEMIC STROKE DX","A")

 ..;Pt must have both a POV of stoke and it must be an active problem

 ..;I +BGPISDX&(+BGPIPROB) S STROKE=1

 ..I +BGPISDX S STROKE=1

 ..I +STROKE D

 ...;Get the admit time & discharge times

 ...S BGPADMIT=$P($G(^DGPM(BGPIEN,0)),U,1)

 ...S BGPDD=$P($G(^DGPM(BGPDIS,0)),U,1)

 ...;See if there is an ER visit prior to admission

 ...S BGPER=$$ER(DFN,BGPADMIT)

 ...S EXC=$$EXCLUDE(DFN,BGPIEN,BGPVST,BGPDIS)

 ...;Find the date/time of last known well

 ...S LKW=$$WELL(DFN,BGPER,BGPADMIT,BGPDD)

 ...I LKW=0 S EXC="1^LKW"

 ...;If no exclusions see if they had tPA given in correct time frame

 ...I EXC="" S NUM=$$NUMER(DFN,LKW)

 ...;Now add it all up

 ...D TOTAL(BGPIEN)

TOTAL(BGPIEN) ;add up the totals

 N PTCNT,EXCCT,DENCT,NUMCT,TOTALS,DATE,NOTCT

 S TOTALS=$G(^TMP("BGPMU0437",$J,BGPMUTF,"TOT"))

 S DENCT=+$G(^TMP("BGPMU0437",$J,BGPMUTF,"DEN"))

 S NUMCT=+$G(^TMP("BGPMU0437",$J,BGPMUTF,"NUM"))

 S EXCCT=+$G(^TMP("BGPMU0437",$J,BGPMUTF,"EXC"))

 S NOTCT=+$G(^TMP("BGPMU0437",$J,BGPMUTF,"NOT"))

 S PTCNT=TOTALS

 S PTCNT=PTCNT+1

 S DATE=$$DATE^BGPMUUTL($P($G(^DGPM(BGPIEN,0)),U,1))

 S DENCT=DENCT+1 S ^TMP("BGPMU0437",$J,BGPMUTF,"DEN")=DENCT

 I EXC'="" D

 .S EXCCT=EXCCT+1 S ^TMP("BGPMU0437",$J,BGPMUTF,"EXC")=EXCCT

 .I BGPMUTF="C" S ^TMP("BGPMU0437",$J,"PAT",BGPMUTF,"EXC",PTCNT)=DFN_U_DATE_U_$P(EXC,U,2)

 I EXC="" D

 .I +NUM=1 D

 ..S NUMCT=NUMCT+1 S ^TMP("BGPMU0437",$J,BGPMUTF,"NUM")=NUMCT

 ..S ^TMP("BGPMU0437",$J,"PAT",BGPMUTF,"NUM",PTCNT)=DFN_U_DATE_U_$P(NUM,U,3)_U_$P(NUM,U,2)

 .I +NUM=0 D

 ..S ^TMP("BGPMU0437",$J,"PAT",BGPMUTF,"NOT",PTCNT)=DFN_U_DATE_U_$P(NUM,U,3)_U_$P(NUM,U,2)

 ..S NOTCT=NOTCT+1 S ^TMP("BGPMU0437",$J,BGPMUTF,"NOT")=NOTCT

 S ^TMP("BGPMU0437",$J,BGPMUTF,"TOT")=PTCNT

 S BGPICARE("MU.STK.0437.1",BGPMUTF,DFN)=1_U_+$G(NUM)_U_+EXC_U_DATE_";"_$P($G(NUM),U,3)_";"_$P(EXC,U,2)

EXCLUDE(DFN,BGPIEN,BGPVST,BGPDIS) ;See if there are exclusions

 N REASON,BGPLOS,BGPHOS,BGPCLIN,BGPECI,DTYPE1,DTYPE2,BGPALL,BGPREF,NOXTHROM,NODTHROM,NOPTHROM

 S REASON=""

 I BGPAGEE<18 S REASON="1^AGE" Q REASON

 ;Check for LOS

 S BGPLOS=$$LOS^BGPMUH08(BGPIEN,BGPDIS)

 I BGPLOS>120 S REASON="1^LOS" Q REASON

 ;Check for clinical trial

 S BGPCLIN=$$TRIAL^BGPMUH08(DFN,BGPVST)

 I +BGPCLIN S REASON=BGPCLIN Q REASON

 ;Check for elective carotid intervention procedure

 S BGPECI=$$ELECTIVE^BGPMUH08(DFN,BGPVST,BGPIEN)

 I +BGPECI S REASON=BGPECI Q REASON

 ;Check for refusals

 S BGPREF=$$REF(DFN,BGPVST,BGPDIS)

 I +BGPREF S REASON=BGPREF Q REASON

 ;Check for reasons not initiated

 ;  Check for CPT procedure within the past 180 days

 S BGPDISDT=$P($P($G(^DGPM(BGPDIS,0)),U,1),".",1)

 S BGPDD180=$$FMADD^XLFDT(BGPDISDT,-180)

 S NOXTHROM=$$CPT^BGPMUUT1(DFN,BGPDD180,BGPDISDT,"BGPMU WARFARIN THERAPY CPT")

 I +NOXTHROM S REASON=NOXTHROM Q REASON

 ;  Check for POV within the past 180 days

 S NODTHROM=$$LASTDX^BGPMUUT2(DFN,BGPDD180,BGPDISDT,"BGPMU WARFARIN THERAPY ICD")

 I +NODTHROM S REASON=NODTHROM Q REASON

 ;  Check for Problem doc'd within the past 180 days

 S NOPTHROM=$$PLTAX^BGPMUUT1(DFN,"BGPMU WARFARIN THERAPY ICD","C")

 I +NOPTHROM D

 .S PDATE=$P(NOPTHROM,U,3)

 .I PDATE>BGPDD180 S REASON=1_U_$P(NOPTHROM,U,2)_" "_$$DATE^BGPMUUTL($P(NOPTHROM,U,3))

 Q REASON

REF(DFN,BGPVST,BGPDIS) ;Find refuals for this medication

 N ENDDT,X1,X2,X,MED,BGPEVT,DISDT

 S MED=0

 S BGPEVT=$P($G(^AUPNVSIT(BGPVST,0)),U,1)

 S DISDT=$P($G(^DGPM(BGPDIS,0)),U,1)

 S ENDDT=$$FMADD^XLFDT(DISDT,+1)

 S TAX="BGPMU TPA NDC CODES"

 S MED=$$MEDREF^BGPMUUT2(DFN,BGPEVT,ENDDT,TAX)

 Q MED

NUMER(DFN,LKW) ;Check to see if pt is in the numerator

 N TAX,MEDDTE,ENDDT,TPA,MEDIEN,STATUS,DRUG,DISPENSE

 S TPA=0

 S MEDDTE=$P(LKW,U,2)                     ;Start time is last known well

 S ENDDT=$$FMADD^XLFDT(MEDDTE,+1)    ;Don't search more than 24hrs

 F  S MEDDTE=$O(^PSB(53.79,"AADT",DFN,MEDDTE)) Q:'+MEDDTE!(MEDDTE>ENDDT)!(+TPA)  D

 .S MEDIEN="" F  S MEDIEN=$O(^PSB(53.79,"AADT",DFN,MEDDTE,MEDIEN)) Q:'+MEDIEN!(+TPA)  D

 ..S STATUS=$P($G(^PSB(53.79,MEDIEN,0)),U,9)

 ..I STATUS="G"!(STATUS="I")!(STATUS="C") D         ;Drug given

 ...S TIME=$$FMDIFF^XLFDT(MEDDTE,$P(LKW,U,2),1)     ;Lapsed time in seconds

 ...I (TIME\60)<180 D

 ....S DISPENSE=0 F  S DISPENSE=$O(^PSB(53.79,MEDIEN,.5,DISPENSE)) Q:'+DISPENSE!(+TPA)  D

 .....S DRUG=$G(^PSB(53.79,MEDIEN,.5,DISPENSE,0))

 .....S DRUG=$P(DRUG,U,1)

 .....S TAX="BGPMU TPA NDC CODES"

 .....S TPA=$$NDC^BGPMUUT4(DRUG,TAX)

 .....S:+TPA $P(TPA,U,3)=BGPDD

 Q TPA

ER(DFN,BGPADMIT,BGPVST) ;Find ER admit time since TPA is often given in the ER

 N VST,IEN,FOUND,ERDTE,NEW

 S FOUND=0,VST=0

 S IEN="" F  S IEN=$O(^AMERVSIT("AC",DFN,IEN),-1) Q:IEN=""!(+FOUND)  D

 .S ERDTE=$P($G(^AMERVSIT(IEN,0)),U,1)

 .S NEW=$$FMADD^XLFDT(BGPADMIT,-1)

 .I ERDTE>NEW&(ERDTE<BGPADMIT) S FOUND=1,VST=ERDTE

 Q VST

WELL(DFN,BGPER,BGPADMIT,BGPDD) ;Find is pt has a last known well

 N IEN,MSR,MTYP,LKW,CNT,TIME,X1,INVD

 S LKW="",CNT=0

 S MTYP="" S MTYP=$O(^AUTTMSR("B","LKW",MTYP))

 Q:MTYP="" 0

 S INVD="" F  S INVD=$O(^AUPNVMSR("AE",DFN,MTYP,INVD)) Q:INVD=""!(+CNT)  D

 .S MSR="" F  S MSR=$O(^AUPNVMSR("AE",DFN,MTYP,INVD,MSR)) Q:MSR=""!(+CNT)  D

 ..I $P($G(^AUPNVMSR(MSR,0)),U,1)=MTYP D

 ...S TIME=$P($G(^AUPNVMSR(MSR,12)),U,1)

 ...Q:TIME>BGPDD

 ...S X1=$$FMDIFF^XLFDT(BGPER,TIME,2) I (X1\60)<120 S CNT=1_U_TIME_"^ER" Q

 ...S X1=$$FMDIFF^XLFDT(BGPADMIT,TIME,2) I (X1\60)<120 S CNT=1_U_TIME_"^AD" Q

 ...I TIME>BGPADMIT S CNT=1_U_TIME_"^IN"

 Q CNT

BGPMUH05  ;IHS/MSC/MGH - MI measure NQF0437-STK-4 ;02-Mar-2011 16:05;MGH

 +1       ;;11.0;IHS CLINICAL REPORTING;**4**;JAN 06, 2011;Build 84

 +2       ;ED meaningful use hospital measured

ENTRY     ;PEP  Stroke Measure 4 - tPA therapy within 3hrs

 +1        NEW START,END,BGPIEN,DFN,BGPVST,BGPISDX,BGPHSDX,BGPAGEE,BGPIPROB,BGPHPROB,STROKE,EXC,NUM,BGPDIS

 +2        NEW BGPER,BGPADTMI,BDPDD,LKW

 +3       ;Start by finding all admissions during the reporting period

 +4        SET START=BGPBDATE

 +5        SET END=BGPEDATE_".2359"

 +6        FOR

               SET START=$ORDER(^DGPM("B",START))

               IF START=""!(START>END)

                   QUIT

               Begin DoDot:1

 +7                SET BGPIEN=""

FOR

                       SET BGPIEN=$ORDER(^DGPM("B",START,BGPIEN))

                       IF BGPIEN=""

                           QUIT

                       Begin DoDot:2

 +8       ;Only include admissions

                           IF $PIECE($GET(^DGPM(BGPIEN,0)),U,2)'=1

                               QUIT

 +9                        SET DFN=$PIECE($GET(^DGPM(BGPIEN,0)),U,3)

 +10                       SET BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)

 +11                       IF DFN=""

                               QUIT

 +12                       SET BGPACTUP=$$ACTUPAP^BGPMUEHD(DFN,BGPBDATE,BGPEDATE,BGPBEN)

 +13                       IF 'BGPACTUP

                               IF '$GET(BGPXPXPX)

                                   IF '$GET(BGPIISO)

                                       QUIT

 +14      ;Get the visit

                           SET BGPVST=$PIECE($GET(^DGPM(BGPIEN,0)),U,27)

 +15                       IF BGPVST=""

                               QUIT

 +16      ;Don't use if pt is still an inpt

                           SET BGPDIS=$PIECE($GET(^DGPM(BGPIEN,0)),U,17)

 +17                       IF BGPDIS=""

                               QUIT

 +18      ;Check for a diagnosis of stroke

 +19                       SET STROKE=0

                           SET EXC=0

                           SET NUM=0

 +20                       SET BGPISDX=$$VSTPOVA^BGPMUUT3(DFN,BGPVST,"BGPMU ISCHEMIC STROKE DX")

 +21      ;S BGPIPROB=$$PLTAX^BGPMUUT1(DFN,"BGPMU ISCHEMIC STROKE DX","A")

 +22      ;Pt must have both a POV of stoke and it must be an active problem

 +23      ;I +BGPISDX&(+BGPIPROB) S STROKE=1

 +24                       IF +BGPISDX

                               SET STROKE=1

 +25                       IF +STROKE

                               Begin DoDot:3

 +26      ;Get the admit time & discharge times

 +27                               SET BGPADMIT=$PIECE($GET(^DGPM(BGPIEN,0)),U,1)

 +28                               SET BGPDD=$PIECE($GET(^DGPM(BGPDIS,0)),U,1)

 +29      ;See if there is an ER visit prior to admission

 +30                               SET BGPER=$$ER(DFN,BGPADMIT)

 +31                               SET EXC=$$EXCLUDE(DFN,BGPIEN,BGPVST,BGPDIS)

 +32      ;Find the date/time of last known well

 +33                               SET LKW=$$WELL(DFN,BGPER,BGPADMIT,BGPDD)

 +34                               IF LKW=0

                                       SET EXC="1^LKW"

 +35      ;If no exclusions see if they had tPA given in correct time frame

 +36                               IF EXC=""

                                       SET NUM=$$NUMER(DFN,LKW)

 +37      ;Now add it all up

 +38                               DO TOTAL(BGPIEN)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +39       QUIT

TOTAL(BGPIEN) ;add up the totals

 +1        NEW PTCNT,EXCCT,DENCT,NUMCT,TOTALS,DATE,NOTCT

 +2        SET TOTALS=$GET(^TMP("BGPMU0437",$JOB,BGPMUTF,"TOT"))

 +3        SET DENCT=+$GET(^TMP("BGPMU0437",$JOB,BGPMUTF,"DEN"))

 +4        SET NUMCT=+$GET(^TMP("BGPMU0437",$JOB,BGPMUTF,"NUM"))

 +5        SET EXCCT=+$GET(^TMP("BGPMU0437",$JOB,BGPMUTF,"EXC"))

 +6        SET NOTCT=+$GET(^TMP("BGPMU0437",$JOB,BGPMUTF,"NOT"))

 +7        SET PTCNT=TOTALS

 +8        SET PTCNT=PTCNT+1

 +9        SET DATE=$$DATE^BGPMUUTL($PIECE($GET(^DGPM(BGPIEN,0)),U,1))

 +10       SET DENCT=DENCT+1

           SET ^TMP("BGPMU0437",$JOB,BGPMUTF,"DEN")=DENCT

 +11       IF EXC'=""

               Begin DoDot:1

 +12               SET EXCCT=EXCCT+1

                   SET ^TMP("BGPMU0437",$JOB,BGPMUTF,"EXC")=EXCCT

 +13               IF BGPMUTF="C"

                       SET ^TMP("BGPMU0437",$JOB,"PAT",BGPMUTF,"EXC",PTCNT)=DFN_U_DATE_U_$PIECE(EXC,U,2)

               End DoDot:1

 +14       IF EXC=""

               Begin DoDot:1

 +15               IF +NUM=1

                       Begin DoDot:2

 +16                       SET NUMCT=NUMCT+1

                           SET ^TMP("BGPMU0437",$JOB,BGPMUTF,"NUM")=NUMCT

 +17                       SET ^TMP("BGPMU0437",$JOB,"PAT",BGPMUTF,"NUM",PTCNT)=DFN_U_DATE_U_$PIECE(NUM,U,3)_U_$PIECE(NUM,U,2)

                       End DoDot:2

 +18               IF +NUM=0

                       Begin DoDot:2

 +19                       SET ^TMP("BGPMU0437",$JOB,"PAT",BGPMUTF,"NOT",PTCNT)=DFN_U_DATE_U_$PIECE(NUM,U,3)_U_$PIECE(NUM,U,2)

 +20                       SET NOTCT=NOTCT+1

                           SET ^TMP("BGPMU0437",$JOB,BGPMUTF,"NOT")=NOTCT

                       End DoDot:2

               End DoDot:1

 +21       SET ^TMP("BGPMU0437",$JOB,BGPMUTF,"TOT")=PTCNT

 +22       SET BGPICARE("MU.STK.0437.1",BGPMUTF,DFN)=1_U_+$GET(NUM)_U_+EXC_U_DATE_";"_$PIECE($GET(NUM),U,3)_";"_$PIECE(EXC,U,2)

 +23       QUIT

EXCLUDE(DFN,BGPIEN,BGPVST,BGPDIS) ;See if there are exclusions

 +1        NEW REASON,BGPLOS,BGPHOS,BGPCLIN,BGPECI,DTYPE1,DTYPE2,BGPALL,BGPREF,NOXTHROM,NODTHROM,NOPTHROM

 +2        SET REASON=""

 +3        IF BGPAGEE<18

               SET REASON="1^AGE"

               QUIT REASON

 +4       ;Check for LOS

 +5        SET BGPLOS=$$LOS^BGPMUH08(BGPIEN,BGPDIS)

 +6        IF BGPLOS>120

               SET REASON="1^LOS"

               QUIT REASON

 +7       ;Check for clinical trial

 +8        SET BGPCLIN=$$TRIAL^BGPMUH08(DFN,BGPVST)

 +9        IF +BGPCLIN

               SET REASON=BGPCLIN

               QUIT REASON

 +10      ;Check for elective carotid intervention procedure

 +11       SET BGPECI=$$ELECTIVE^BGPMUH08(DFN,BGPVST,BGPIEN)

 +12       IF +BGPECI

               SET REASON=BGPECI

               QUIT REASON

 +13      ;Check for refusals

 +14       SET BGPREF=$$REF(DFN,BGPVST,BGPDIS)

 +15       IF +BGPREF

               SET REASON=BGPREF

               QUIT REASON

 +16      ;Check for reasons not initiated

 +17      ;  Check for CPT procedure within the past 180 days

 +18       SET BGPDISDT=$PIECE($PIECE($GET(^DGPM(BGPDIS,0)),U,1),".",1)

 +19       SET BGPDD180=$$FMADD^XLFDT(BGPDISDT,-180)

 +20       SET NOXTHROM=$$CPT^BGPMUUT1(DFN,BGPDD180,BGPDISDT,"BGPMU WARFARIN THERAPY CPT")

 +21       IF +NOXTHROM

               SET REASON=NOXTHROM

               QUIT REASON

 +22      ;  Check for POV within the past 180 days

 +23       SET NODTHROM=$$LASTDX^BGPMUUT2(DFN,BGPDD180,BGPDISDT,"BGPMU WARFARIN THERAPY ICD")

 +24       IF +NODTHROM

               SET REASON=NODTHROM

               QUIT REASON

 +25      ;  Check for Problem doc'd within the past 180 days

 +26       SET NOPTHROM=$$PLTAX^BGPMUUT1(DFN,"BGPMU WARFARIN THERAPY ICD","C")

 +27       IF +NOPTHROM

               Begin DoDot:1

 +28               SET PDATE=$PIECE(NOPTHROM,U,3)

 +29               IF PDATE>BGPDD180

                       SET REASON=1_U_$PIECE(NOPTHROM,U,2)_" "_$$DATE^BGPMUUTL($PIECE(NOPTHROM,U,3))

               End DoDot:1

 +30       QUIT REASON

REF(DFN,BGPVST,BGPDIS) ;Find refuals for this medication

 +1        NEW ENDDT,X1,X2,X,MED,BGPEVT,DISDT

 +2        SET MED=0

 +3        SET BGPEVT=$PIECE($GET(^AUPNVSIT(BGPVST,0)),U,1)

 +4        SET DISDT=$PIECE($GET(^DGPM(BGPDIS,0)),U,1)

 +5        SET ENDDT=$$FMADD^XLFDT(DISDT,+1)

 +6        SET TAX="BGPMU TPA NDC CODES"

 +7        SET MED=$$MEDREF^BGPMUUT2(DFN,BGPEVT,ENDDT,TAX)

 +8        QUIT MED

NUMER(DFN,LKW) ;Check to see if pt is in the numerator

 +1        NEW TAX,MEDDTE,ENDDT,TPA,MEDIEN,STATUS,DRUG,DISPENSE

 +2        SET TPA=0

 +3       ;Start time is last known well

           SET MEDDTE=$PIECE(LKW,U,2)

 +4       ;Don't search more than 24hrs

           SET ENDDT=$$FMADD^XLFDT(MEDDTE,+1)

 +5        FOR

               SET MEDDTE=$ORDER(^PSB(53.79,"AADT",DFN,MEDDTE))

               IF '+MEDDTE!(MEDDTE>ENDDT)!(+TPA)

                   QUIT

               Begin DoDot:1

 +6                SET MEDIEN=""

FOR

                       SET MEDIEN=$ORDER(^PSB(53.79,"AADT",DFN,MEDDTE,MEDIEN))

                       IF '+MEDIEN!(+TPA)

                           QUIT

                       Begin DoDot:2

 +7                        SET STATUS=$PIECE($GET(^PSB(53.79,MEDIEN,0)),U,9)

 +8       ;Drug given

                           IF STATUS="G"!(STATUS="I")!(STATUS="C")

                               Begin DoDot:3

 +9       ;Lapsed time in seconds

                                   SET TIME=$$FMDIFF^XLFDT(MEDDTE,$PIECE(LKW,U,2),1)

 +10                               IF (TIME\60)<180

                                       Begin DoDot:4

 +11                                       SET DISPENSE=0

FOR

                                               SET DISPENSE=$ORDER(^PSB(53.79,MEDIEN,.5,DISPENSE))

                                               IF '+DISPENSE!(+TPA)

                                                   QUIT

                                               Begin DoDot:5

 +12                                               SET DRUG=$GET(^PSB(53.79,MEDIEN,.5,DISPENSE,0))

 +13                                               SET DRUG=$PIECE(DRUG,U,1)

 +14                                               SET TAX="BGPMU TPA NDC CODES"

 +15                                               SET TPA=$$NDC^BGPMUUT4(DRUG,TAX)

 +16                                               IF +TPA

                                                       SET $PIECE(TPA,U,3)=BGPDD

                                               End DoDot:5

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +17       QUIT TPA

ER(DFN,BGPADMIT,BGPVST) ;Find ER admit time since TPA is often given in the ER

 +1        NEW VST,IEN,FOUND,ERDTE,NEW

 +2        SET FOUND=0

           SET VST=0

 +3        SET IEN=""

FOR

               SET IEN=$ORDER(^AMERVSIT("AC",DFN,IEN),-1)

               IF IEN=""!(+FOUND)

                   QUIT

               Begin DoDot:1

 +4                SET ERDTE=$PIECE($GET(^AMERVSIT(IEN,0)),U,1)

 +5                SET NEW=$$FMADD^XLFDT(BGPADMIT,-1)

 +6                IF ERDTE>NEW&(ERDTE<BGPADMIT)

                       SET FOUND=1

                       SET VST=ERDTE

               End DoDot:1

 +7        QUIT VST

WELL(DFN,BGPER,BGPADMIT,BGPDD) ;Find is pt has a last known well

 +1        NEW IEN,MSR,MTYP,LKW,CNT,TIME,X1,INVD

 +2        SET LKW=""

           SET CNT=0

 +3        SET MTYP=""

           SET MTYP=$ORDER(^AUTTMSR("B","LKW",MTYP))

 +4        IF MTYP=""

               QUIT 0

 +5        SET INVD=""

FOR

               SET INVD=$ORDER(^AUPNVMSR("AE",DFN,MTYP,INVD))

               IF INVD=""!(+CNT)

                   QUIT

               Begin DoDot:1

 +6                SET MSR=""

FOR

                       SET MSR=$ORDER(^AUPNVMSR("AE",DFN,MTYP,INVD,MSR))

                       IF MSR=""!(+CNT)

                           QUIT

                       Begin DoDot:2

 +7                        IF $PIECE($GET(^AUPNVMSR(MSR,0)),U,1)=MTYP

                               Begin DoDot:3

 +8                                SET TIME=$PIECE($GET(^AUPNVMSR(MSR,12)),U,1)

 +9                                IF TIME>BGPDD

                                       QUIT

 +10                               SET X1=$$FMDIFF^XLFDT(BGPER,TIME,2)

                                   IF (X1\60)<120

                                       SET CNT=1_U_TIME_"^ER"

                                       QUIT

 +11                               SET X1=$$FMDIFF^XLFDT(BGPADMIT,TIME,2)

                                   IF (X1\60)<120

                                       SET CNT=1_U_TIME_"^AD"

                                       QUIT

 +12                               IF TIME>BGPADMIT

                                       SET CNT=1_U_TIME_"^IN"

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +13       QUIT CNT

BGPMUH05.m