BGP4D91 ; 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 ;
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
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^BGP4UTL2(C,T,9) S G=1,$P(BGPG(A),U,15)=$$VAL^XBDIQ1(9000010.07,X,.01)
..I $$ICD^BGP4UTL2(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^BGP4UTL(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^BGP4UTL(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"
I $$VAPI^BGP4D81(I,$O(^ATXAX("B","BGP CMS WARFARIN VAPI",0))) 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^BGP4UTL2(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^BGP4UTL2(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"
;
BGP4D91 ; 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 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+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^BGP4UTL2(C,T,9)
SET G=1
SET $PIECE(BGPG(A),U,15)=$$VAL^XBDIQ1(9000010.07,X,.01)
+17 IF $$ICD^BGP4UTL2(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^BGP4UTL(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^BGP4UTL(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 IF $$VAPI^BGP4D81(I,$ORDER(^ATXAX("B","BGP CMS WARFARIN VAPI",0)))
QUIT "1^WARF"
+17 QUIT ""
+18 ;
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^BGP4UTL2(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"
+19 QUIT
End DoDot:1
+20 IF BGPG]""
QUIT BGPG
+21 ;now check v tran
+22 SET T=$ORDER(^ATXAX("B","BGP CMS ABG CPTS",0))
+23 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X!(BGPG]"")
QUIT
Begin DoDot:1
+24 IF '$DATA(^AUPNVTC(X,0))
QUIT
+25 SET C=$PIECE(^AUPNVTC(X,0),U,7)
+26 IF C=""
QUIT
+27 IF '$$ICD^BGP4UTL2(C,T,1)
QUIT
+28 SET BGPG=$$DATE^BGP2UTL(BGPD)_" O2 SAT: CPT "_$PIECE($$CPT^ICPTCOD(C),U,2)_"^1"
+29 QUIT
End DoDot:1
+30 IF BGPG]""
QUIT BGPG
+31 ;now check for lab tests
+32 SET T=$ORDER(^ATXAX("B","BGP CMS ABG LOINC",0))
+33 SET BGPLT=$ORDER(^ATXLAB("B","BGP CMS ABG TESTS",0))
+34 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AD",V,X))
IF X'=+X!(BGPG]"")
QUIT
Begin DoDot:1
+35 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+36 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPG=$$DATE^BGP2UTL(BGPD)_" O2 SAT: LAB "_$$VAL^XBDIQ1(9000010.09,X,.01)_"^1"
QUIT
+37 IF 'T
QUIT
+38 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+39 IF '$$LOINC^BGP2D21(J,T)
QUIT
+40 SET BGPG=$$DATE^BGP2UTL(BGPD)_" O2 SAT: LAB "_$$VAL^XBDIQ1(9000010.09,X,.01)_"^1"
QUIT
End DoDot:1
+41 IF BGPG]""
QUIT BGPG
+42 QUIT $$DATE^BGP2UTL(BGPD)_" None^3"
+43 ;
