BGP3D91.m

BGP3D91 ; IHS/CMI/LAB - calc measures 29 Apr 2010 7:38 PM 14 Nov 2006 5:02 PM 12 Nov 2009 11:03 AM 07 Apr 2010 7:00 AM ;

 ;;13.0;IHS CLINICAL REPORTING;**1**;NOV 20, 2012;Build 7

 ;

EOST ;

 NEW BGPOXV,BGPD,BGPN

 K BGPOXV

 I 'BGPACTUP S BGPSTOP=1 Q  ;no active user pop

 I BGPAGEB<18 S BGPSTOP=1 Q  ;don't process this measure, pt under 18

 S BGPD1=0

 S BGPN1=0,BGPVALUE=""

 D TIAFIB(DFN,BGPBDATE,BGPEDATE,.BGPOXV)

 ;now evaluate result

 S BGPD1=BGPOXV("DENOM")

 I 'BGPD1 S BGPSTOP=1 Q

 S BGPN1=$P(BGPOXV(0),U,1)

 S BGPN2=$P(BGPOXV(0),U,2)

 S BGPN3=$P(BGPOXV(0),U,3)

 S BGPD="",BGPN=""

 S C=0 F  S C=$O(BGPOXV(C)) Q:C'=+C  D

 .S BGPN=$S(BGPN="":"Visit: ",1:BGPN_"; ")

 .S BGPN=BGPN_$P(BGPOXV(C),U,1)_" THERAPY: "_$P($P(BGPOXV(C),U,2)," ",2,99)

 .Q

 ;

 S BGPVALUE="UP"_"|||"_BGPN

 Q

 ;

TIAFIB(P,BDATE,EDATE,BGPR) ;EP

 NEW A,X,V,BGPG,G,C,T,B,E,BGPX,BGPV,BGPD

 K BGPR,BGPG,BGPX

 S BGPR="",BGPR(0)=""

 S X=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")

 I '$D(BGPG(1)) S BGPR("DENOM")=0 Q

 ;now go through and get rid of H and CHS

 S T=$O(^ATXAX("B","BGP TIA DXS",0))

 S A=0 F  S A=$O(BGPG(A)) Q:A'=+A  D

 .S V=$P(BGPG(A),U,5)

 .I '$D(^AUPNVSIT(V,0)) K BGPG(A) Q

 .I $P(^AUPNVSIT(V,0),U,3)="C" K BGPG(A) Q

 .I $P(^AUPNVSIT(V,0),U,7)'="H" K BGPG(A) Q

 .S X=0,G=0,E=0,B=0 F  S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X  D

 ..S C=$P($G(^AUPNVPOV(X,0)),U)

 ..Q:C=""

 ..I $$ICD^ATXCHK(C,T,9) S G=1,$P(BGPG(A),U,15)=$$VAL^XBDIQ1(9000010.07,X,.01)

 ..I $$ICD^ATXCHK(C,$O(^ATXAX("B","BGP ATRIAL FIBRILLATION DXS",0)),9) S E=1

 .I G,E S B=1  ;have both

 .I 'B K BGPG(A)  ;no tia diagnosis

 I '$D(BGPG) S BGPR("DENOM")=0 Q

 ;reorder the diagnoses by visit date

 S A=0 F  S A=$O(BGPG(A)) Q:A'=+A  S V=$P(BGPG(A),U,5),D=$P($P($G(^AUPNVSIT(V,0)),U),"."),BGPX(D,V)=BGPG(A)

 ;now get the first one

 S BGPD=0,BGPC=0 F  S BGPD=$O(BGPX(BGPD)) Q:BGPD'=+BGPD  D

 .S BGPV=0 F  S BGPV=$O(BGPX(BGPD,BGPV)) Q:BGPV'=+BGPV  D

 ..S BGPC=BGPC+1,BGPR(BGPC)=BGPC_") "_$$DATE^BGP2UTL(BGPD)_" POV "_$P(BGPX(BGPD,BGPV),U,15)_" + POV 427.31"  ;set denominator

 ..S G=$$ANTICOAG(P,$$FMADD^XLFDT(BGPD,-365),$$DSCHDATE^APCLV(BGPV),BGPD)  ; any ANTICOAG?

 ..S $P(BGPR(BGPC),U,2)=BGPC_") "_$P(G,U,1)  ;set numerator column

 ..S $P(BGPR(0),U,$P(G,U,2))=$P(BGPR(0),U,$P(G,U,2))+1

 S BGPR("DENOM")=BGPC

 Q

ANTICOAG(P,BDATE,EDATE,BGPAD) ;EP - was there ANTICOAG

 NEW BGPD,X,N,E,Y,T,D,C,BGPLT,L,J,BGPG,S

 K BGPG S Y="BGPG(",X=P_"^ALL MED;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 S X=0,G="" F  S X=$O(BGPG(X)) Q:X'=+X!(G]"")  D

 .S N=+$P(BGPG(X),U,4)  ;ien of v med

 .S C=$$ANTIDRUG(N)  ;not one of the drugs

 .Q:'$P(C,U)

 .;c=1^category of drug

 .I $P(^AUPNVMED(N,0),U,8)]"",$P(^AUPNVMED(N,0),U,8)'>EDATE Q  ;discontinued before discharge date

 .S S=$P(^AUPNVMED(N,0),U,7)

 .I $P($P(^AUPNVSIT($P(^AUPNVMED(N,0),U,3),0),U),".")=EDATE S G=$$DATE^BGP3UTL(EDATE)_" MET: "_$P(C,U,2)_"^1"  ;PRESCRIBED ON DISCHARGE DATE

 .S V=$P(^AUPNVMED(N,0),U,3)

 .S V=$P($P(^AUPNVSIT(V,0),U),".")

 .I $$FMADD^XLFDT(V,S)<EDATE Q  ;not valid through discharge date

 .S G=$$DATE^BGP3UTL(V)_" MET: "_$P(C,U,2)_"^1"

 I G]"" Q G

 Q "NOT MET: NO THERAPY^3"

 ;

ANTIDRUG(N) ;

 NEW G,T,I

 I '$D(^AUPNVMED(N,0)) Q 0

 I $$UP^XLFSTR($P($G(^AUPNVMED(N,11)),U))["RETURNED TO STOCK" Q 0

 S I=$P($G(^AUPNVMED(N,0)),U)

 I 'I Q 0

 S G=0

 S T=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))

 I T,$D(^ATXAX(T,21,"B",I)) Q "1^ASA"

 S T=$O(^ATXAX("B","BGP CMS WARFARIN MEDS",0))

 I T,$D(^ATXAX(T,21,"B",I)) Q "1^WARF"

 S T=$O(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))

 I T,$D(^ATXAX(T,21,"B",I)) Q "1^ANTI-PLT"

 S G=$P(^PSDRUG(I,0),U,2)

 I G="BL700" Q "1^ANTI-PLT"

 I $P(^PSDRUG(I,0),U)["WARFARIN" Q "1^WARF"

 Q ""

 ;

EOOX ;

 NEW BGPOXV,BGPD,BGPN

 I 'BGPACTUP S BGPSTOP=1 Q  ;no active user pop

 I BGPAGEB<18 S BGPSTOP=1 Q  ;don't process this measure, pt under 18

 S BGPD1=0  ;Number of pneumonia visits

 S BGPN1=0,BGPVALUE=""

 K BGPOXV

 D PNEUOX(DFN,BGPBDATE,BGPEDATE,.BGPOXV)

 ;now evaluate result

 S BGPD1=BGPOXV("DENOM") ;number of pneumonia visits

 I 'BGPD1 S BGPSTOP=1 Q  ;no pneumonia visits

 S BGPN1=$P(BGPOXV(0),U,1)

 S BGPN2=$P(BGPOXV(0),U,2)

 S BGPN3=$P(BGPOXV(0),U,3)

 S BGPD="",BGPN=""

 S C=0 F  S C=$O(BGPOXV(C)) Q:C'=+C  D

 .S BGPD=BGPD_$S(BGPD]"":"; ",1:"")_$P(BGPOXV(C),U)

 .S BGPN=BGPN_$S(BGPN]"":"; ",1:"")_$P(BGPOXV(C),U,2)

 ;

 S BGPVALUE="UP,"_BGPD_"||| "_BGPN

 Q

 ;

PNEUOX(P,BDATE,EDATE,BGPR) ;EP

 NEW A,B,C,D,E,F,G,BGPG,BGPX,BGPD,BGPV,BGPC

 K BGPG,BGPR

 S BGPR="",BGPR(0)=""

 S X=P_"^ALL DX [BGP CMS PNEUMONIA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")

 I '$D(BGPG(1)) S BGPR("DENOM")=0 Q

 ;now go through and get rid of CHS or service category not A, O, S

 S A=0 F  S A=$O(BGPG(A)) Q:A'=+A  D

 .S V=$P(BGPG(A),U,5)

 .I '$D(^AUPNVSIT(V,0)) K BGPG(A)

 .I $P(^AUPNVSIT(V,0),U,3)="C" K BGPG(A)

 .I "AOS"'[$P(^AUPNVSIT(V,0),U,7) K BGPG(A)

 I '$D(BGPG) S BGPR("DENOM")=0 Q  ;got rid of them all

 ;reorder the diagnoses by visit date

 S A=0 F  S A=$O(BGPG(A)) Q:A'=+A  S V=$P(BGPG(A),U,5),D=$P($P($G(^AUPNVSIT(V,0)),U),"."),BGPX(D,V)=BGPG(A)

 ;now get the first one

 S BGPD=0,BGPC=0 F  S BGPD=$O(BGPX(BGPD)) Q:BGPD'=+BGPD  D

 .S BGPV=0 F  S BGPV=$O(BGPX(BGPD,BGPV)) Q:BGPV'=+BGPV  D

 ..S BGPC=BGPC+1,BGPR(BGPC)=BGPC_") "_$$DATE^BGP2UTL(BGPD)_" "_$P(BGPX(BGPD,BGPV),U,2)  ;set denominator

 ..S G=$$OXSAT(BGPV)  ; any o2 saturation on this visit?

 ..S $P(BGPR(BGPC),U,2)=BGPC_") "_$P(G,U,1)  ;set numerator column

 ..S $P(BGPR(0),U,$P(G,U,2))=$P(BGPR(0),U,$P(G,U,2))+1

 ..;now delete out all visits that are <46 days difference and all other visits on the same day

 ..S V=BGPV F  S V=$O(BGPX(BGPD,V)) Q:V'=+V  K BGPX(BGPD,V)

 ..S D=BGPD,V=BGPV F  S D=$O(BGPX(D)) Q:D'=+D  D

 ...S V=0 F  S V=$O(BGPX(D,V)) Q:V'=+V  I $$FMDIFF^XLFDT(D,BGPD)<46 K BGPX(D,V)

 S BGPR("DENOM")=BGPC

 Q

 ;

OXSAT(V) ;was there ox sat at the visit

 ;get all O2 measurements on or after admission date

 NEW BGPD,X,N,E,Y,T,D,C,BGPLT,L,J,BGPG,M,M1

 S BGPG=""

 S BGPD=$P($P(^AUPNVSIT(V,0),U),".")

 ;K BGPG S Y="BGPG(",X=P_"^ALL MEAS O2;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED) S E=$$START1^APCLDF(X,Y)

 S X=0 F  S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X!(BGPG]"")  I $$VAL^XBDIQ1(9000010.01,X,.01)="O2" S BGPG=$$DATE^BGP2UTL(BGPD)_" O2 MEAS^1"

 I BGPG]"" Q BGPG

 ;now check for cpts

 S T=$O(^ATXAX("B","BGP CMS ABG CPTS",0))

 S X=0 F  S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(BGPG]"")  D

 .Q:'$D(^AUPNVCPT(X,0))

 .S C=$P(^AUPNVCPT(X,0),U)

 .Q:'$$ICD^ATXCHK(C,T,1)

 .S M=$$VAL^XBDIQ1(9000010.18,X,.08)

 .S M1=$$VAL^XBDIQ1(9000010.18,X,.09)

 .I $P(^ICPT(C,0),U)="3028F",(M="1P"!(M="2P")!(M="3P")!(M="4P")!(M="8P")) Q  ;3028f and has modifier

 .I $P(^ICPT(C,0),U)="3028F",(M1="1P"!(M="2P")!(M="3P")!(M="4P")!(M="8P")) Q  ;3028f and has modifier

 .S BGPG=$$DATE^BGP2UTL(BGPD)_" O2 SAT: CPT "_$P($$CPT^ICPTCOD(C),U,2)_"^1"

 .Q

 I BGPG]"" Q BGPG

 ;now check v tran

 S T=$O(^ATXAX("B","BGP CMS ABG CPTS",0))

 S X=0 F  S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X!(BGPG]"")  D

 .Q:'$D(^AUPNVTC(X,0))

 .S C=$P(^AUPNVTC(X,0),U,7)

 .Q:C=""

 .Q:'$$ICD^ATXCHK(C,T,1)

 .S BGPG=$$DATE^BGP2UTL(BGPD)_" O2 SAT: CPT "_$P($$CPT^ICPTCOD(C),U,2)_"^1"

 .Q

 I BGPG]"" Q BGPG

 ;now check for lab tests

 S T=$O(^ATXAX("B","BGP CMS ABG LOINC",0))

 S BGPLT=$O(^ATXLAB("B","BGP CMS ABG TESTS",0))

 S X=0 F  S X=$O(^AUPNVLAB("AD",V,X)) Q:X'=+X!(BGPG]"")  D

 .Q:'$D(^AUPNVLAB(X,0))

 .I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPG=$$DATE^BGP2UTL(BGPD)_" O2 SAT: LAB "_$$VAL^XBDIQ1(9000010.09,X,.01)_"^1" Q

 .Q:'T

 .S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""

 .Q:'$$LOINC^BGP2D21(J,T)

 .S BGPG=$$DATE^BGP2UTL(BGPD)_" O2 SAT: LAB "_$$VAL^XBDIQ1(9000010.09,X,.01)_"^1" Q

 I BGPG]"" Q BGPG

 Q $$DATE^BGP2UTL(BGPD)_" None^3"

 ;

BGP3D91   ; IHS/CMI/LAB - calc measures 29 Apr 2010 7:38 PM 14 Nov 2006 5:02 PM 12 Nov 2009 11:03 AM 07 Apr 2010 7:00 AM ;

 +1       ;;13.0;IHS CLINICAL REPORTING;**1**;NOV 20, 2012;Build 7

 +2       ;

EOST      ;

 +1        NEW BGPOXV,BGPD,BGPN

 +2        KILL BGPOXV

 +3       ;no active user pop

           IF 'BGPACTUP

               SET BGPSTOP=1

               QUIT 

 +4       ;don't process this measure, pt under 18

           IF BGPAGEB<18

               SET BGPSTOP=1

               QUIT 

 +5        SET BGPD1=0

 +6        SET BGPN1=0

           SET BGPVALUE=""

 +7        DO TIAFIB(DFN,BGPBDATE,BGPEDATE,.BGPOXV)

 +8       ;now evaluate result

 +9        SET BGPD1=BGPOXV("DENOM")

 +10       IF 'BGPD1

               SET BGPSTOP=1

               QUIT 

 +11       SET BGPN1=$PIECE(BGPOXV(0),U,1)

 +12       SET BGPN2=$PIECE(BGPOXV(0),U,2)

 +13       SET BGPN3=$PIECE(BGPOXV(0),U,3)

 +14       SET BGPD=""

           SET BGPN=""

 +15       SET C=0

           FOR 

               SET C=$ORDER(BGPOXV(C))

               IF C'=+C

                   QUIT 

               Begin DoDot:1

 +16               SET BGPN=$SELECT(BGPN="":"Visit: ",1:BGPN_"; ")

 +17               SET BGPN=BGPN_$PIECE(BGPOXV(C),U,1)_" THERAPY: "_$PIECE($PIECE(BGPOXV(C),U,2)," ",2,99)

 +18               QUIT 

               End DoDot:1

 +19      ;

 +20       SET BGPVALUE="UP"_"|||"_BGPN

 +21       QUIT 

 +22      ;

TIAFIB(P,BDATE,EDATE,BGPR) ;EP

 +1        NEW A,X,V,BGPG,G,C,T,B,E,BGPX,BGPV,BGPD

 +2        KILL BGPR,BGPG,BGPX

 +3        SET BGPR=""

           SET BGPR(0)=""

 +4        SET X=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)

           SET E=$$START1^APCLDF(X,"BGPG(")

 +5        IF '$DATA(BGPG(1))

               SET BGPR("DENOM")=0

               QUIT 

 +6       ;now go through and get rid of H and CHS

 +7        SET T=$ORDER(^ATXAX("B","BGP TIA DXS",0))

 +8        SET A=0

           FOR 

               SET A=$ORDER(BGPG(A))

               IF A'=+A

                   QUIT 

               Begin DoDot:1

 +9                SET V=$PIECE(BGPG(A),U,5)

 +10               IF '$DATA(^AUPNVSIT(V,0))

                       KILL BGPG(A)

                       QUIT 

 +11               IF $PIECE(^AUPNVSIT(V,0),U,3)="C"

                       KILL BGPG(A)

                       QUIT 

 +12               IF $PIECE(^AUPNVSIT(V,0),U,7)'="H"

                       KILL BGPG(A)

                       QUIT 

 +13               SET X=0

                   SET G=0

                   SET E=0

                   SET B=0

                   FOR 

                       SET X=$ORDER(^AUPNVPOV("AD",V,X))

                       IF X'=+X

                           QUIT 

                       Begin DoDot:2

 +14                       SET C=$PIECE($GET(^AUPNVPOV(X,0)),U)

 +15                       IF C=""

                               QUIT 

 +16                       IF $$ICD^ATXCHK(C,T,9)

                               SET G=1

                               SET $PIECE(BGPG(A),U,15)=$$VAL^XBDIQ1(9000010.07,X,.01)

 +17                       IF $$ICD^ATXCHK(C,$ORDER(^ATXAX("B","BGP ATRIAL FIBRILLATION DXS",0)),9)

                               SET E=1

                       End DoDot:2

 +18      ;have both

                   IF G

                       IF E

                           SET B=1

 +19      ;no tia diagnosis

                   IF 'B

                       KILL BGPG(A)

               End DoDot:1

 +20       IF '$DATA(BGPG)

               SET BGPR("DENOM")=0

               QUIT 

 +21      ;reorder the diagnoses by visit date

 +22       SET A=0

           FOR 

               SET A=$ORDER(BGPG(A))

               IF A'=+A

                   QUIT 

               SET V=$PIECE(BGPG(A),U,5)

               SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")

               SET BGPX(D,V)=BGPG(A)

 +23      ;now get the first one

 +24       SET BGPD=0

           SET BGPC=0

           FOR 

               SET BGPD=$ORDER(BGPX(BGPD))

               IF BGPD'=+BGPD

                   QUIT 

               Begin DoDot:1

 +25               SET BGPV=0

                   FOR 

                       SET BGPV=$ORDER(BGPX(BGPD,BGPV))

                       IF BGPV'=+BGPV

                           QUIT 

                       Begin DoDot:2

 +26      ;set denominator

                           SET BGPC=BGPC+1

                           SET BGPR(BGPC)=BGPC_") "_$$DATE^BGP2UTL(BGPD)_" POV "_$PIECE(BGPX(BGPD,BGPV),U,15)_" + POV 427.31"

 +27      ; any ANTICOAG?

                           SET G=$$ANTICOAG(P,$$FMADD^XLFDT(BGPD,-365),$$DSCHDATE^APCLV(BGPV),BGPD)

 +28      ;set numerator column

                           SET $PIECE(BGPR(BGPC),U,2)=BGPC_") "_$PIECE(G,U,1)

 +29                       SET $PIECE(BGPR(0),U,$PIECE(G,U,2))=$PIECE(BGPR(0),U,$PIECE(G,U,2))+1

                       End DoDot:2

               End DoDot:1

 +30       SET BGPR("DENOM")=BGPC

 +31       QUIT 

ANTICOAG(P,BDATE,EDATE,BGPAD) ;EP - was there ANTICOAG

 +1        NEW BGPD,X,N,E,Y,T,D,C,BGPLT,L,J,BGPG,S

 +2        KILL BGPG

           SET Y="BGPG("

           SET X=P_"^ALL MED;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)

           SET E=$$START1^APCLDF(X,Y)

 +3        SET X=0

           SET G=""

           FOR 

               SET X=$ORDER(BGPG(X))

               IF X'=+X!(G]"")

                   QUIT 

               Begin DoDot:1

 +4       ;ien of v med

                   SET N=+$PIECE(BGPG(X),U,4)

 +5       ;not one of the drugs

                   SET C=$$ANTIDRUG(N)

 +6                IF '$PIECE(C,U)

                       QUIT 

 +7       ;c=1^category of drug

 +8       ;discontinued before discharge date

                   IF $PIECE(^AUPNVMED(N,0),U,8)]""

                       IF $PIECE(^AUPNVMED(N,0),U,8)'>EDATE

                           QUIT 

 +9                SET S=$PIECE(^AUPNVMED(N,0),U,7)

 +10      ;PRESCRIBED ON DISCHARGE DATE

                   IF $PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(N,0),U,3),0),U),".")=EDATE

                       SET G=$$DATE^BGP3UTL(EDATE)_" MET: "_$PIECE(C,U,2)_"^1"

 +11               SET V=$PIECE(^AUPNVMED(N,0),U,3)

 +12               SET V=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")

 +13      ;not valid through discharge date

                   IF $$FMADD^XLFDT(V,S)<EDATE

                       QUIT 

 +14               SET G=$$DATE^BGP3UTL(V)_" MET: "_$PIECE(C,U,2)_"^1"

               End DoDot:1

 +15       IF G]""

               QUIT G

 +16       QUIT "NOT MET: NO THERAPY^3"

 +17      ;

ANTIDRUG(N) ;

 +1        NEW G,T,I

 +2        IF '$DATA(^AUPNVMED(N,0))

               QUIT 0

 +3        IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(N,11)),U))["RETURNED TO STOCK"

               QUIT 0

 +4        SET I=$PIECE($GET(^AUPNVMED(N,0)),U)

 +5        IF 'I

               QUIT 0

 +6        SET G=0

 +7        SET T=$ORDER(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))

 +8        IF T

               IF $DATA(^ATXAX(T,21,"B",I))

                   QUIT "1^ASA"

 +9        SET T=$ORDER(^ATXAX("B","BGP CMS WARFARIN MEDS",0))

 +10       IF T

               IF $DATA(^ATXAX(T,21,"B",I))

                   QUIT "1^WARF"

 +11       SET T=$ORDER(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))

 +12       IF T

               IF $DATA(^ATXAX(T,21,"B",I))

                   QUIT "1^ANTI-PLT"

 +13       SET G=$PIECE(^PSDRUG(I,0),U,2)

 +14       IF G="BL700"

               QUIT "1^ANTI-PLT"

 +15       IF $PIECE(^PSDRUG(I,0),U)["WARFARIN"

               QUIT "1^WARF"

 +16       QUIT ""

 +17      ;

EOOX      ;

 +1        NEW BGPOXV,BGPD,BGPN

 +2       ;no active user pop

           IF 'BGPACTUP

               SET BGPSTOP=1

               QUIT 

 +3       ;don't process this measure, pt under 18

           IF BGPAGEB<18

               SET BGPSTOP=1

               QUIT 

 +4       ;Number of pneumonia visits

           SET BGPD1=0

 +5        SET BGPN1=0

           SET BGPVALUE=""

 +6        KILL BGPOXV

 +7        DO PNEUOX(DFN,BGPBDATE,BGPEDATE,.BGPOXV)

 +8       ;now evaluate result

 +9       ;number of pneumonia visits

           SET BGPD1=BGPOXV("DENOM")

 +10      ;no pneumonia visits

           IF 'BGPD1

               SET BGPSTOP=1

               QUIT 

 +11       SET BGPN1=$PIECE(BGPOXV(0),U,1)

 +12       SET BGPN2=$PIECE(BGPOXV(0),U,2)

 +13       SET BGPN3=$PIECE(BGPOXV(0),U,3)

 +14       SET BGPD=""

           SET BGPN=""

 +15       SET C=0

           FOR 

               SET C=$ORDER(BGPOXV(C))

               IF C'=+C

                   QUIT 

               Begin DoDot:1

 +16               SET BGPD=BGPD_$SELECT(BGPD]"":"; ",1:"")_$PIECE(BGPOXV(C),U)

 +17               SET BGPN=BGPN_$SELECT(BGPN]"":"; ",1:"")_$PIECE(BGPOXV(C),U,2)

               End DoDot:1

 +18      ;

 +19       SET BGPVALUE="UP,"_BGPD_"||| "_BGPN

 +20       QUIT 

 +21      ;

PNEUOX(P,BDATE,EDATE,BGPR) ;EP

 +1        NEW A,B,C,D,E,F,G,BGPG,BGPX,BGPD,BGPV,BGPC

 +2        KILL BGPG,BGPR

 +3        SET BGPR=""

           SET BGPR(0)=""

 +4        SET X=P_"^ALL DX [BGP CMS PNEUMONIA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)

           SET E=$$START1^APCLDF(X,"BGPG(")

 +5        IF '$DATA(BGPG(1))

               SET BGPR("DENOM")=0

               QUIT 

 +6       ;now go through and get rid of CHS or service category not A, O, S

 +7        SET A=0

           FOR 

               SET A=$ORDER(BGPG(A))

               IF A'=+A

                   QUIT 

               Begin DoDot:1

 +8                SET V=$PIECE(BGPG(A),U,5)

 +9                IF '$DATA(^AUPNVSIT(V,0))

                       KILL BGPG(A)

 +10               IF $PIECE(^AUPNVSIT(V,0),U,3)="C"

                       KILL BGPG(A)

 +11               IF "AOS"'[$PIECE(^AUPNVSIT(V,0),U,7)

                       KILL BGPG(A)

               End DoDot:1

 +12      ;got rid of them all

           IF '$DATA(BGPG)

               SET BGPR("DENOM")=0

               QUIT 

 +13      ;reorder the diagnoses by visit date

 +14       SET A=0

           FOR 

               SET A=$ORDER(BGPG(A))

               IF A'=+A

                   QUIT 

               SET V=$PIECE(BGPG(A),U,5)

               SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")

               SET BGPX(D,V)=BGPG(A)

 +15      ;now get the first one

 +16       SET BGPD=0

           SET BGPC=0

           FOR 

               SET BGPD=$ORDER(BGPX(BGPD))

               IF BGPD'=+BGPD

                   QUIT 

               Begin DoDot:1

 +17               SET BGPV=0

                   FOR 

                       SET BGPV=$ORDER(BGPX(BGPD,BGPV))

                       IF BGPV'=+BGPV

                           QUIT 

                       Begin DoDot:2

 +18      ;set denominator

                           SET BGPC=BGPC+1

                           SET BGPR(BGPC)=BGPC_") "_$$DATE^BGP2UTL(BGPD)_" "_$PIECE(BGPX(BGPD,BGPV),U,2)

 +19      ; any o2 saturation on this visit?

                           SET G=$$OXSAT(BGPV)

 +20      ;set numerator column

                           SET $PIECE(BGPR(BGPC),U,2)=BGPC_") "_$PIECE(G,U,1)

 +21                       SET $PIECE(BGPR(0),U,$PIECE(G,U,2))=$PIECE(BGPR(0),U,$PIECE(G,U,2))+1

 +22      ;now delete out all visits that are <46 days difference and all other visits on the same day

 +23                       SET V=BGPV

                           FOR 

                               SET V=$ORDER(BGPX(BGPD,V))

                               IF V'=+V

                                   QUIT 

                               KILL BGPX(BGPD,V)

 +24                       SET D=BGPD

                           SET V=BGPV

                           FOR 

                               SET D=$ORDER(BGPX(D))

                               IF D'=+D

                                   QUIT 

                               Begin DoDot:3

 +25                               SET V=0

                                   FOR 

                                       SET V=$ORDER(BGPX(D,V))

                                       IF V'=+V

                                           QUIT 

                                       IF $$FMDIFF^XLFDT(D,BGPD)<46

                                           KILL BGPX(D,V)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +26       SET BGPR("DENOM")=BGPC

 +27       QUIT 

 +28      ;

OXSAT(V)  ;was there ox sat at the visit

 +1       ;get all O2 measurements on or after admission date

 +2        NEW BGPD,X,N,E,Y,T,D,C,BGPLT,L,J,BGPG,M,M1

 +3        SET BGPG=""

 +4        SET BGPD=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")

 +5       ;K BGPG S Y="BGPG(",X=P_"^ALL MEAS O2;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED) S E=$$START1^APCLDF(X,Y)

 +6        SET X=0

           FOR 

               SET X=$ORDER(^AUPNVMSR("AD",V,X))

               IF X'=+X!(BGPG]"")

                   QUIT 

               IF $$VAL^XBDIQ1(9000010.01,X,.01)="O2"

                   SET BGPG=$$DATE^BGP2UTL(BGPD)_" O2 MEAS^1"

 +7        IF BGPG]""

               QUIT BGPG

 +8       ;now check for cpts

 +9        SET T=$ORDER(^ATXAX("B","BGP CMS ABG CPTS",0))

 +10       SET X=0

           FOR 

               SET X=$ORDER(^AUPNVCPT("AD",V,X))

               IF X'=+X!(BGPG]"")

                   QUIT 

               Begin DoDot:1

 +11               IF '$DATA(^AUPNVCPT(X,0))

                       QUIT 

 +12               SET C=$PIECE(^AUPNVCPT(X,0),U)

 +13               IF '$$ICD^ATXCHK(C,T,1)

                       QUIT 

 +14               SET M=$$VAL^XBDIQ1(9000010.18,X,.08)

 +15               SET M1=$$VAL^XBDIQ1(9000010.18,X,.09)

 +16      ;3028f and has modifier

                   IF $PIECE(^ICPT(C,0),U)="3028F"

                       IF (M="1P"!(M="2P")!(M="3P")!(M="4P")!(M="8P"))

                           QUIT 

 +17      ;3028f and has modifier

                   IF $PIECE(^ICPT(C,0),U)="3028F"

                       IF (M1="1P"!(M="2P")!(M="3P")!(M="4P")!(M="8P"))

                           QUIT 

 +18               SET BGPG=$$DATE^BGP2UTL(BGPD)_" O2 SAT: CPT "_$PIECE($$CPT^ICPTCOD(C),U,2)_"^1"