BGP8EO1 ; IHS/CMI/LAB - calc measures 29 Apr 2008 7:38 PM 14 Nov 2006 5:02 PM 12 Nov 2007 11:03 AM ; 07 Apr 2008 7:00 AM
;;8.0;IHS CLINICAL REPORTING;**2**;MAR 12, 2008
;
EODMG1 ;EP
NEW BGPLHGB
I 'BGPDMD2 S BGPSTOP=1 Q ;don't process this measure, pt not diabetic
S BGPD1=1 ;is active diabetic
S BGPN1=0,BGPVALUE=""
S BGPLHGB=$$HGBA1C(DFN,BGPBDATE,BGPEDATE)
S BGPN1=$P(BGPLHGB,U)
S BGPVALUE="AD||| "_$P(BGPLHGB,U,2)
Q
;
;
EODMB1 ;EP
NEW BGPBP,S,DS,BGPV
I 'BGPDMD2 S BGPSTOP=1 Q ;don't process this measure, pt not diabetic
S BGPD1=1 ;is active diabetic
S BGPN1=0,BGPVALUE="",BGPV=""
S BGPBP=$$MEANBP^BGP8D2(DFN,BGPBDATE,BGPEDATE)
I BGPBP="" S BGPBP=$$BPCPT(DFN,BGPBDATE,BGPEDATE) I BGPBP]"" D G BPS
.S BGPN1=$P(BGPBP,U),BGPV=$S(BGPN1:"BP: <140/90: BP: ",1:"")_$P(BGPBP,U,2)
I BGPBP="" G BPS
S S=$P(BGPBP," ",1)
S DS=$P(S,"/",2),S=$P(S,"/",1)
I S<140&(DS<90) S BGPN1=1,BGPV="BP: <140/90: BP: "_S_"/"_DS I 1
E S BGPV="BP: "_S_"/"_DS
BPS ;
S BGPVALUE="AD||| "_BGPV
Q
;
EODML1 ;EP
NEW BGPLDL,S,DS,BGPV,BGPN3,BGPN4,BGPN5
I 'BGPDMD2 S BGPSTOP=1 Q ;don't process this measure, pt not diabetic
S BGPD1=1 ;is active diabetic
S BGPN1=0,BGPVALUE="",BGPV=""
S BGPLDL=$$LDL^BGP8D2(DFN,BGPBDATE,BGPEDATE,1)
;now evaluate result
S BGPN4=0 D CHKLDL^BGP8D2
S BGPN1=BGPN4
;
S BGPV="" I BGPLDL]"" S BGPV="LDL DONE: "_$$DATE^BGP8UTL($P(BGPLDL,U,2))_" "_$P(BGPLDL,U,3)
S BGPVALUE="AD||| "_BGPV
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
;
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 ;Number of pneumonia visits
S BGPN1=0,BGPVALUE=""
D TIAFIB(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
;
HGBA1C(P,BDATE,EDATE) ;EP
NEW BGPG,BGPT,BGPC,E,%,L,T,BGPLT,D,X,J,C,G
S BGPC=0
S G=$$CPT^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP HGBA1C CPTS",0)),5)
I G]"" S BGPC=BGPC+1,BGPT((9999999-$P(G,U,1)),BGPC)=U_"CPT "_$P(G,U,2)
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPT(D,BGPC)=$P(^AUPNVLAB(X,0),U,4)_U_"LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D2(J,T)
...S BGPC=BGPC+1,BGPT(D,BGPC)=$P(^AUPNVLAB(X,0),U,4)_U_"LAB LOINC: "_$$VAL^XBDIQ1(9000010.09,X,.01)_" "_$P(^AUPNVLAB(X,11),U,13)
...Q
; now got though and set return value of done 1 or 0^numerator 2-7^date^value
I '$D(BGPT) Q 1_U_"No documented HgbA1c" ;no tests so is hit in numerator
; now get rid of all on same day where 1 has a result and the other doesn't
S D=0,BGPC=0 F S D=$O(BGPT(D)) Q:D'=+D S C=0,G=0 F S C=$O(BGPT(D,C)) Q:C'=+C D
.I $P(BGPT(D,C),U,1)]"" S BGPC=BGPC+1
.I BGPC>0,$P(BGPT(D,C),U,1)="" K BGPT(D,C)
S D=0,G=""
S D=$O(BGPT(D))
S C=0,C=$O(BGPT(D,C))
S X=$P(BGPT(D,C),U,1)
I $$UP^XLFSTR(X)="COMMENT" Q 1_U_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP8UTL(9999999-D)_" (no result) "_X
I X="" D Q G
.S G=""
.I $P(BGPT(D,C),U,2)="CPT 3046F" S G=1_U_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP8UTL(9999999-D) Q
.I $P(BGPT(D,C),U,2)="CPT 3047F"!($P(BGPT(D,C),U,2)="CPT 3044F")!($P(BGPT(D,C),U,2)="CPT 3045F") S G=0_U_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP8UTL(9999999-D) Q
.S G=1_U_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP8UTL(9999999-D)_" (no result)" Q
S X=$$STRIP^XLFSTR(X," ") ;strip spaces
I X[">9" Q 1_U_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP8UTL(9999999-D)_" "_X
S X=$$STV(X)
I X="" Q 1_U_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP8UTL(9999999-D)_" (no result) "_X
I +X>9 Q 1_U_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP8UTL(9999999-D)_" "_X
Q 0_U_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP8UTL(9999999-D)_" result: "_X
;
STV(X) ;EP - strip all characters besides numbers and a "."
I X="" Q X
NEW A,B,L
S L=$L(X)
F B=1:1:L S A=$E(X,B) Q:A="" I A'?1N,A'?1"." S X=$$STRIP^XLFSTR(X,A) S B=B-1
Q X
;
BPCPT(P,BDATE,EDATE) ;EP
NEW S,D,C,E,BGPG,X,Y,G,T
K BGPG S Y="BGPG(",X=P_"^ALL VISIT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
;go through and get all cpt codes in the 2 taxonomies and table by date using the lowest value on that day, skip ER visits
S X=0,G="" F S X=$O(BGPG(X)) Q:X'=+X D
.S V=$P(BGPG(X),U,5) ;visit ien
.Q:'$D(^AUPNVSIT(V,0))
.Q:$$CLINIC^APCLV(V,"C")=30 ;clinic ER
.Q:'$D(^AUPNVCPT("AD",V)) ;no cpt codes
.S E=0 F S E=$O(^AUPNVCPT("AD",V,E)) Q:E'=+E D
..S C=$P($G(^AUPNVCPT(E,0)),U)
..I 'C Q
..S D=$P($P(^AUPNVSIT(V,0),U),"."),D=(9999999-D)_"."_$P(D,".",2)
..I $$ICD^ATXCHK(C,$O(^ATXAX("B","BGP SYSTOLIC BP CPTS",0)),1) D
...S Y=$P($$CPT^ICPTCOD(C),U,2)
...S:'$D(S(D)) S(D)=Y
...I +S(D)>+Y S S(D)=Y
..I $$ICD^ATXCHK(C,$O(^ATXAX("B","BGP DIASTOLIC BP CPTS",0)),1) D
...S Y=$P($$CPT^ICPTCOD(C),U,2)
...S:'$D(T(D)) T(D)=Y
...I +T(D)>+Y S T(D)=Y
I '$D(S),'$D(T) Q ""
S S=$O(S(0)) I S S S=S(S)
S D=$O(T(0)) I D S D=T(D)
I S=""!(D="") Q 0_U_S_"/"_$P(D,".")
I S="3074F",D="3078F" Q 1_U_S_"/"_$P(D,".")
I S="3074F",D="3079F" Q 1_U_S_"/"_$P(D,".")
I S="3075F",D="3078F" Q 1_U_S_"/"_$P(D,".")
I S="3075F",D="3079F" Q 1_U_S_"/"_$P(D,".")
I S="3076F",D="3078F" Q 1_U_S_"/"_$P(D,".")
I S="3076F",D="3079F" Q 1_U_S_"/"_$P(D,".")
I S="3077F",D="3080F" Q 0_U_S_"/"_$P(D,".")
Q 0_U_S_"/"_$P(D,".")
;
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 $$VAL^XBDIQ1(9000010.07,X,.01)="427.31" 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^BGP8UTL(BGPD)_" "_$P(BGPX(BGPD,BGPV),U,15)_"+427.31" ;set denominator
..S G=$$ANTICOAG^BGP8EO11(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
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^BGP8UTL(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^BGP8UTL(BGPD)_" MET O2 SAT^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^BGP8UTL(BGPD)_" MET 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^BGP8UTL(BGPD)_" MET CPT/TRAN ["_$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^BGP8UTL(BGPD)_" MET "_$$VAL^XBDIQ1(9000010.09,X,.01)_"^1" Q
.Q:'T
.S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
.Q:'$$LOINC^BGP8D21(J,T)
.S BGPG=$$DATE^BGP8UTL(BGPD)_" MET "_$$VAL^XBDIQ1(9000010.09,X,.01)_"^1" Q
I BGPG]"" Q BGPG
;now go get refusals of any of the above
;
S G=$$REFUSAL^BGP8UTL1(P,9999999.07,$O(^AUTTMSR("B","O2",0)),BGPD,BGPD)
I G Q $$DATE^BGP8UTL(BGPD)_" NOT MET REFUSAL O2 SAT^2"
;refusal of lab tests
S T=$O(^ATXLAB("B","BGP CMS ABG TESTS",0))
S L=0 F S L=$O(^ATXLAB(T,21,"B",L)) Q:L'=+L!(BGPG]"") D
.S G=$$REFUSAL^BGP8UTL1(P,60,L,BGPD,BGPD)
.I G S BGPG=$$DATE^BGP8UTL(BGPD)_" NOT MET REFUSAL LAB^2"
I BGPG]"" Q BGPG
S G=$$CPTREFT^BGP8UTL1(P,BGPD,BGPD,$O(^ATXAX("B","BGP CMS ABG CPTS",0)))
I G Q $$DATE^BGP8UTL(BGPD)_" NOT MET REFUSAL CPT^2"
Q $$DATE^BGP8UTL(BGPD)_" NOT MET; NO ASSMT^3"
;
BGP8EO1 ; IHS/CMI/LAB - calc measures 29 Apr 2008 7:38 PM 14 Nov 2006 5:02 PM 12 Nov 2007 11:03 AM ; 07 Apr 2008 7:00 AM
+1 ;;8.0;IHS CLINICAL REPORTING;**2**;MAR 12, 2008
+2 ;
EODMG1 ;EP
+1 NEW BGPLHGB
+2 ;don't process this measure, pt not diabetic
IF 'BGPDMD2
SET BGPSTOP=1
QUIT
+3 ;is active diabetic
SET BGPD1=1
+4 SET BGPN1=0
SET BGPVALUE=""
+5 SET BGPLHGB=$$HGBA1C(DFN,BGPBDATE,BGPEDATE)
+6 SET BGPN1=$PIECE(BGPLHGB,U)
+7 SET BGPVALUE="AD||| "_$PIECE(BGPLHGB,U,2)
+8 QUIT
+9 ;
+10 ;
EODMB1 ;EP
+1 NEW BGPBP,S,DS,BGPV
+2 ;don't process this measure, pt not diabetic
IF 'BGPDMD2
SET BGPSTOP=1
QUIT
+3 ;is active diabetic
SET BGPD1=1
+4 SET BGPN1=0
SET BGPVALUE=""
SET BGPV=""
+5 SET BGPBP=$$MEANBP^BGP8D2(DFN,BGPBDATE,BGPEDATE)
+6 IF BGPBP=""
SET BGPBP=$$BPCPT(DFN,BGPBDATE,BGPEDATE)
IF BGPBP]""
Begin DoDot:1
+7 SET BGPN1=$PIECE(BGPBP,U)
SET BGPV=$SELECT(BGPN1:"BP: <140/90: BP: ",1:"")_$PIECE(BGPBP,U,2)
End DoDot:1
GOTO BPS
+8 IF BGPBP=""
GOTO BPS
+9 SET S=$PIECE(BGPBP," ",1)
+10 SET DS=$PIECE(S,"/",2)
SET S=$PIECE(S,"/",1)
+11 IF S<140&(DS<90)
SET BGPN1=1
SET BGPV="BP: <140/90: BP: "_S_"/"_DS
IF 1
+12 IF '$TEST
SET BGPV="BP: "_S_"/"_DS
BPS ;
+1 SET BGPVALUE="AD||| "_BGPV
+2 QUIT
+3 ;
EODML1 ;EP
+1 NEW BGPLDL,S,DS,BGPV,BGPN3,BGPN4,BGPN5
+2 ;don't process this measure, pt not diabetic
IF 'BGPDMD2
SET BGPSTOP=1
QUIT
+3 ;is active diabetic
SET BGPD1=1
+4 SET BGPN1=0
SET BGPVALUE=""
SET BGPV=""
+5 SET BGPLDL=$$LDL^BGP8D2(DFN,BGPBDATE,BGPEDATE,1)
+6 ;now evaluate result
+7 SET BGPN4=0
DO CHKLDL^BGP8D2
+8 SET BGPN1=BGPN4
+9 ;
+10 SET BGPV=""
IF BGPLDL]""
SET BGPV="LDL DONE: "_$$DATE^BGP8UTL($PIECE(BGPLDL,U,2))_" "_$PIECE(BGPLDL,U,3)
+11 SET BGPVALUE="AD||| "_BGPV
+12 QUIT
+13 ;
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 ;
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 ;Number of pneumonia visits
SET BGPD1=0
+6 SET BGPN1=0
SET BGPVALUE=""
+7 DO TIAFIB(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 ;
HGBA1C(P,BDATE,EDATE) ;EP
+1 NEW BGPG,BGPT,BGPC,E,%,L,T,BGPLT,D,X,J,C,G
+2 SET BGPC=0
+3 SET G=$$CPT^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP HGBA1C CPTS",0)),5)
+4 IF G]""
SET BGPC=BGPC+1
SET BGPT((9999999-$PIECE(G,U,1)),BGPC)=U_"CPT "_$PIECE(G,U,2)
+5 ;now get all loinc/taxonomy tests
+6 SET T=$ORDER(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
+7 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
+8 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+9 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+11 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+12 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPT(D,BGPC)=$PIECE(^AUPNVLAB(X,0),U,4)_U_"LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01)
QUIT
+13 IF 'T
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC^BGP8D2(J,T)
QUIT
+16 SET BGPC=BGPC+1
SET BGPT(D,BGPC)=$PIECE(^AUPNVLAB(X,0),U,4)_U_"LAB LOINC: "_$$VAL^XBDIQ1(9000010.09,X,.01)_" "_$PIECE(^AUPNVLAB(X,11),U,13)
+17 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 ; now got though and set return value of done 1 or 0^numerator 2-7^date^value
+19 ;no tests so is hit in numerator
IF '$DATA(BGPT)
QUIT 1_U_"No documented HgbA1c"
+20 ; now get rid of all on same day where 1 has a result and the other doesn't
+21 SET D=0
SET BGPC=0
FOR
SET D=$ORDER(BGPT(D))
IF D'=+D
QUIT
SET C=0
SET G=0
FOR
SET C=$ORDER(BGPT(D,C))
IF C'=+C
QUIT
Begin DoDot:1
+22 IF $PIECE(BGPT(D,C),U,1)]""
SET BGPC=BGPC+1
+23 IF BGPC>0
IF $PIECE(BGPT(D,C),U,1)=""
KILL BGPT(D,C)
End DoDot:1
+24 SET D=0
SET G=""
+25 SET D=$ORDER(BGPT(D))
+26 SET C=0
SET C=$ORDER(BGPT(D,C))
+27 SET X=$PIECE(BGPT(D,C),U,1)
+28 IF $$UP^XLFSTR(X)="COMMENT"
QUIT 1_U_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP8UTL(9999999-D)_" (no result) "_X
+29 IF X=""
Begin DoDot:1
+30 SET G=""
+31 IF $PIECE(BGPT(D,C),U,2)="CPT 3046F"
SET G=1_U_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP8UTL(9999999-D)
QUIT
+32 IF $PIECE(BGPT(D,C),U,2)="CPT 3047F"!($PIECE(BGPT(D,C),U,2)="CPT 3044F")!($PIECE(BGPT(D,C),U,2)="CPT 3045F")
SET G=0_U_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP8UTL(9999999-D)
QUIT
+33 SET G=1_U_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP8UTL(9999999-D)_" (no result)"
QUIT
End DoDot:1
QUIT G
+34 ;strip spaces
SET X=$$STRIP^XLFSTR(X," ")
+35 IF X[">9"
QUIT 1_U_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP8UTL(9999999-D)_" "_X
+36 SET X=$$STV(X)
+37 IF X=""
QUIT 1_U_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP8UTL(9999999-D)_" (no result) "_X
+38 IF +X>9
QUIT 1_U_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP8UTL(9999999-D)_" "_X
+39 QUIT 0_U_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP8UTL(9999999-D)_" result: "_X
+40 ;
STV(X) ;EP - strip all characters besides numbers and a "."
+1 IF X=""
QUIT X
+2 NEW A,B,L
+3 SET L=$LENGTH(X)
+4 FOR B=1:1:L
SET A=$EXTRACT(X,B)
IF A=""
QUIT
IF A'?1N
IF A'?1"."
SET X=$$STRIP^XLFSTR(X,A)
SET B=B-1
+5 QUIT X
+6 ;
BPCPT(P,BDATE,EDATE) ;EP
+1 NEW S,D,C,E,BGPG,X,Y,G,T
+2 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL VISIT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+3 ;go through and get all cpt codes in the 2 taxonomies and table by date using the lowest value on that day, skip ER visits
+4 SET X=0
SET G=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+5 ;visit ien
SET V=$PIECE(BGPG(X),U,5)
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 ;clinic ER
IF $$CLINIC^APCLV(V,"C")=30
QUIT
+8 ;no cpt codes
IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+9 SET E=0
FOR
SET E=$ORDER(^AUPNVCPT("AD",V,E))
IF E'=+E
QUIT
Begin DoDot:2
+10 SET C=$PIECE($GET(^AUPNVCPT(E,0)),U)
+11 IF 'C
QUIT
+12 SET D=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET D=(9999999-D)_"."_$PIECE(D,".",2)
+13 IF $$ICD^ATXCHK(C,$ORDER(^ATXAX("B","BGP SYSTOLIC BP CPTS",0)),1)
Begin DoDot:3
+14 SET Y=$PIECE($$CPT^ICPTCOD(C),U,2)
+15 IF '$DATA(S(D))
SET S(D)=Y
+16 IF +S(D)>+Y
SET S(D)=Y
End DoDot:3
+17 IF $$ICD^ATXCHK(C,$ORDER(^ATXAX("B","BGP DIASTOLIC BP CPTS",0)),1)
Begin DoDot:3
+18 SET Y=$PIECE($$CPT^ICPTCOD(C),U,2)
+19 IF '$DATA(T(D))
SET T(D)=Y
+20 IF +T(D)>+Y
SET T(D)=Y
End DoDot:3
End DoDot:2
End DoDot:1
+21 IF '$DATA(S)
IF '$DATA(T)
QUIT ""
+22 SET S=$ORDER(S(0))
IF S
SET S=S(S)
+23 SET D=$ORDER(T(0))
IF D
SET D=T(D)
+24 IF S=""!(D="")
QUIT 0_U_S_"/"_$PIECE(D,".")
+25 IF S="3074F"
IF D="3078F"
QUIT 1_U_S_"/"_$PIECE(D,".")
+26 IF S="3074F"
IF D="3079F"
QUIT 1_U_S_"/"_$PIECE(D,".")
+27 IF S="3075F"
IF D="3078F"
QUIT 1_U_S_"/"_$PIECE(D,".")
+28 IF S="3075F"
IF D="3079F"
QUIT 1_U_S_"/"_$PIECE(D,".")
+29 IF S="3076F"
IF D="3078F"
QUIT 1_U_S_"/"_$PIECE(D,".")
+30 IF S="3076F"
IF D="3079F"
QUIT 1_U_S_"/"_$PIECE(D,".")
+31 IF S="3077F"
IF D="3080F"
QUIT 0_U_S_"/"_$PIECE(D,".")
+32 QUIT 0_U_S_"/"_$PIECE(D,".")
+33 ;
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 $$VAL^XBDIQ1(9000010.07,X,.01)="427.31"
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^BGP8UTL(BGPD)_" "_$PIECE(BGPX(BGPD,BGPV),U,15)_"+427.31"
+27 ; any ANTICOAG?
SET G=$$ANTICOAG^BGP8EO11(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
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^BGP8UTL(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^BGP8UTL(BGPD)_" MET O2 SAT^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^BGP8UTL(BGPD)_" MET 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^ATXCHK(C,T,1)
QUIT
+28 SET BGPG=$$DATE^BGP8UTL(BGPD)_" MET CPT/TRAN ["_$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^BGP8UTL(BGPD)_" MET "_$$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^BGP8D21(J,T)
QUIT
+40 SET BGPG=$$DATE^BGP8UTL(BGPD)_" MET "_$$VAL^XBDIQ1(9000010.09,X,.01)_"^1"
QUIT
End DoDot:1
+41 IF BGPG]""
QUIT BGPG
+42 ;now go get refusals of any of the above
+43 ;
+44 SET G=$$REFUSAL^BGP8UTL1(P,9999999.07,$ORDER(^AUTTMSR("B","O2",0)),BGPD,BGPD)
+45 IF G
QUIT $$DATE^BGP8UTL(BGPD)_" NOT MET REFUSAL O2 SAT^2"
+46 ;refusal of lab tests
+47 SET T=$ORDER(^ATXLAB("B","BGP CMS ABG TESTS",0))
+48 SET L=0
FOR
SET L=$ORDER(^ATXLAB(T,21,"B",L))
IF L'=+L!(BGPG]"")
QUIT
Begin DoDot:1
+49 SET G=$$REFUSAL^BGP8UTL1(P,60,L,BGPD,BGPD)
+50 IF G
SET BGPG=$$DATE^BGP8UTL(BGPD)_" NOT MET REFUSAL LAB^2"
End DoDot:1
+51 IF BGPG]""
QUIT BGPG
+52 SET G=$$CPTREFT^BGP8UTL1(P,BGPD,BGPD,$ORDER(^ATXAX("B","BGP CMS ABG CPTS",0)))
+53 IF G
QUIT $$DATE^BGP8UTL(BGPD)_" NOT MET REFUSAL CPT^2"
+54 QUIT $$DATE^BGP8UTL(BGPD)_" NOT MET; NO ASSMT^3"
+55 ;
