BGP1CU3 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM 04 May 2010 2:38 PM ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
ERBC(P,BDATE,EDATE,BGPY) ;EP - did patient have an er visit from bdate to edate without a DX in taxonomy T?
NEW BGPG,A,B,E,G,X,I,BGPC,BGPB
K BGPG,BGPY
S BGPC=0
S A="BGPG(",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(BGPG(1)) Q
S X=0,(G,E)="" F S X=$O(BGPG(X)) Q:X'=+X S V=$P(BGPG(X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:$$CLINIC^APCLV(V,"C")'=30
.K BGPB
.D BC(V,.BGPB)
.I '$D(BGPB) Q
.S BGPC=BGPC+1,BGPY(BGPC)="ER Visit: "_$$DATE^BGP1UTL($P(BGPG(X),U))
Q
;
BC(V,BGPZ) ;any blood culture tests on visit V
;now check cpts/tran codes for 87040, 87103
NEW BGPC,BGPLT,C1,Z,T,B,D,E,C
S BGPC=0
S Z=0 F S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z D
.Q:'$D(^AUPNVCPT(Z,0))
.S C1=$$VAL^XBDIQ1(9000010.18,Z,.01)
.I C1'=87040,C1'=87103 Q
.S BGPC=BGPC+1,BGPZ(BGPC)="CPT code: "_C1
.Q
;tran codes
S Z=0 F S Z=$O(^AUPNVTC("AD",V,Z)) Q:Z'=+Z D
.Q:'$D(^AUPNVTC(Z,0))
.S C1=$$VAL^XBDIQ1(9000010.33,Z,.07)
.I C1'=87040,C1'=87103 Q
.S BGPC=BGPC+1,BGPZ(BGPC)="TRAN CODE CPT code: "_C1
.Q
S T=$O(^ATXAX("B","BGP CMS BLOOD CULTURE PROC",0))
S Z=0 F S Z=$O(^AUPNVPRC("AD",V,Z)) Q:Z'=+Z D
.Q:'$D(^AUPNVPRC(Z,0))
.S C1=$$VAL^XBDIQ1(9000010.08,Z,.01)
.S C=$$VALI^XBDIQ1(9000010.08,Z,.01)
.I '$$ICD^ATXCHK(C,T,0) Q
.S BGPC=BGPC+1,BGPZ(BGPC)="Procedure code: "_C1
.Q
S Z=0 F S Z=$O(^AUPNVPOV("AD",V,Z)) Q:Z'=+Z D
.Q:'$D(^AUPNVPOV(Z,0))
.S C1=$$VAL^XBDIQ1(9000010.07,Z,.01)
.I C1'="790.7" Q
.S BGPC=BGPC+1,BGPZ(BGPC)="POV code: "_C1
.Q
S T=$O(^ATXAX("B","BGP BLOOD CULTURE LOINC",0))
S BGPLT=$O(^ATXLAB("B","BGP CMS BLOOD CULTURE",0))
S A=0 F S A=$O(^AUPNVLAB("AD",V,A)) Q:A'=+A D
.Q:'$D(^AUPNVLAB(A,0))
.I $$VAL^XBDIQ1(9000010.09,A,.01)="BLOOD CULTURE" D Q
..S BGPC=BGPC+1,BGPZ(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" value: "_$P(^AUPNVLAB(A,0),U,4) Q
..I BGPLT,$P(^AUPNVLAB(A,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(A,0),U))) S BGPC=BGPC+1,BGPZ(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" value: "_$P(^AUPNVLAB(A,0),U,4) Q
..Q:'T
..S J=$P($G(^AUPNVLAB(A,11)),U,13) Q:J=""
..Q:'$$LOINC^BGP1D21(J,T)
..S BGPC=BGPC+1,BGPZ(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" value: "_$P(^AUPNVLAB(A,0),U,4)
..Q
S A=0 F S A=$O(^AUPNVMIC("AD",V,A)) Q:A'=+A D
.Q:'$D(^AUPNVMIC(A,0))
.I $$VAL^XBDIQ1(9000010.25,A,.01)="BLOOD CULTURE" D Q
..S BGPC=BGPC+1,BGPZ(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$P(^AUPNVMIC(A,0),U,7) Q
..I BGPLT,$P(^AUPNVMIC(A,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVMIC(A,0),U))) D
...S BGPC=BGPC+1,BGPZ(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$P(^AUPNVMIC(A,0),U,7) Q
..Q:'T
..S J=$P($G(^AUPNVMIC(A,11)),U,13) Q:J=""
..Q:'$$LOINC^BGP1D21(J,T)
..S BGPC=BGPC+1,BGPZ(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" "_$$DATE^BGP1UTL($P(BGPG(X),U))_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$P(^AUPNVMIC(A,0),U,7)
Q
ERBCP(P,BD,ED,BGPY) ;EP
NEW BGPG,BGPC
K BGPG,BGPY
S BGPC=0
S A="BGPG(",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED),E=$$START1^APCLDF(B,A)
I '$D(BGPG(1)) Q
S (X,G)=0 F S X=$O(BGPG(X)) Q:X'=+X S V=$P(BGPG(X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:$$CLINIC^APCLV(V,"C")'=30
.S BGPC=BGPC+1,BGPY(BGPC)="ER Visit: "_$$DATE^BGP1UTL($P($P(^AUPNVSIT(V,0),U),"."))
.S BGPC=BGPC+1,BGPY(BGPC)="ER Diagnoses: "
.S A=0 F S A=$O(^AUPNVPOV("AD",V,A)) Q:A'=+A D
..S BGPC=BGPC+1,BGPY(BGPC)=" "_$$VAL^XBDIQ1(9000010.07,A,.01)_" "_$$VAL^XBDIQ1(9000010.07,A,.04)
.S BGPC=BGPC+1,BGPY(BGPC)="Blood Culture: "
.;now check cpts/tran codes for 87040, 87103
.S Z=0 F S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z D
..Q:'$D(^AUPNVCPT(Z,0))
..S C1=$$VAL^XBDIQ1(9000010.18,Z,.01)
..I C1'=87040,C1'=87103 Q
..S BGPC=BGPC+1,BGPY(BGPC)="CPT code: "_C1
..Q
.;tran codes
.S Z=0 F S Z=$O(^AUPNVTC("AD",V,Z)) Q:Z'=+Z D
..Q:'$D(^AUPNVTC(Z,0))
..S C1=$$VAL^XBDIQ1(9000010.33,Z,.07)
..I C1'=87040,C1'=87103 Q
..S BGPC=BGPC+1,BGPY(BGPC)="TRAN CODE CPT code: "_C1
..Q
.;procedures
.S T=$O(^ATXAX("B","BGP CMS BLOOD CULTURE PROC",0))
.S Z=0 F S Z=$O(^AUPNVPRC("AD",V,Z)) Q:Z'=+Z D
..Q:'$D(^AUPNVPRC(Z,0))
..S C1=$$VAL^XBDIQ1(9000010.08,Z,.01)
..S C=$$VALI^XBDIQ1(9000010.08,Z,.01)
..I '$$ICD^ATXCHK(C,T,0) Q
..S BGPC=BGPC+1,BGPY(BGPC)="Procedure code: "_C1
.;pov
.S Z=0 F S Z=$O(^AUPNVPOV("AD",V,Z)) Q:Z'=+Z D
..Q:'$D(^AUPNVPOV(Z,0))
..S C1=$$VAL^XBDIQ1(9000010.07,Z,.01)
..I C1'="790.7" Q
..S BGPC=BGPC+1,BGPY(BGPC)="POV code: "_C1
.;labs
.S T=$O(^ATXAX("B","BGP BLOOD CULTURE LOINC",0))
.S BGPLT=$O(^ATXLAB("B","BGP CMS BLOOD CULTURE",0))
.S B=9999999-$P($P(^AUPNVSIT(V,0),U),"."),E=9999999-$P($P(^AUPNVSIT(V,0),U),".") 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 A=0 F S A=$O(^AUPNVLAB("AE",P,D,L,A)) Q:A'=+A D
....Q:'$D(^AUPNVLAB(A,0))
....I $$VAL^XBDIQ1(9000010.09,A,.01)="BLOOD CULTURE" D Q
.....S BGPC=BGPC+1,BGPY(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" "_$$DATE^BGP1UTL($P(BGPG(X),U))_" value: "_$P(^AUPNVLAB(A,0),U,4) Q
....I BGPLT,$P(^AUPNVLAB(A,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(A,0),U))) S BGPC=BGPC+1,BGPY(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" "_$$DATE^BGP1UTL($P(BGPG(X),U))_" value: "_$P(^AUPNVLAB(A,0),U,4) Q
....Q:'T
....S J=$P($G(^AUPNVLAB(A,11)),U,13) Q:J=""
....Q:'$$LOINC^BGP1D21(J,T)
....S BGPC=BGPC+1,BGPY(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" "_$$DATE^BGP1UTL($P(BGPG(X),U))_" value: "_$P(^AUPNVLAB(A,0),U,4)
....Q
.;micro
.S B=9999999-$P($P(^AUPNVSIT(V,0),U),"."),E=9999999-$P($P(^AUPNVSIT(V,0),U),".") S D=E-1 F S D=$O(^AUPNVMIC("AE",P,D)) Q:D'=+D!(D>B) D
..S L=0 F S L=$O(^AUPNVMIC("AE",P,D,L)) Q:L'=+L D
...S A=0 F S A=$O(^AUPNVMIC("AE",P,D,L,A)) Q:A'=+A D
....Q:'$D(^AUPNVMIC(A,0))
....I $$VAL^XBDIQ1(9000010.25,A,.01)="BLOOD CULTURE" D Q
.....S BGPC=BGPC+1,BGPY(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" "_$$DATE^BGP1UTL($P(BGPG(X),U))_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$P(^AUPNVMIC(A,0),U,7) Q
....I BGPLT,$P(^AUPNVMIC(A,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVMIC(A,0),U))) D
.....S BGPC=BGPC+1,BGPY(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" "_$$DATE^BGP1UTL($P(BGPG(X),U))_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$P(^AUPNVMIC(A,0),U,7) Q
....Q:'T
....S J=$P($G(^AUPNVMIC(A,11)),U,13) Q:J=""
....Q:'$$LOINC^BGP1D21(J,T)
....S BGPC=BGPC+1,BGPY(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" "_$$DATE^BGP1UTL($P(BGPG(X),U))_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$P(^AUPNVMIC(A,0),U,7)
....Q
Q
;
ANTIRX(P,BDATE,EDATE,BGPY,EXP) ;EP
NEW BGPG,BGPC,X,Y,Z,E,BD,ED
S BGPC=0
S EXP=$G(EXP)
D GETMEDS^BGP1CU(P,BDATE,EDATE,"BGP CMS ANTIBIOTIC MEDS","BGP CMS ANTIBIOTIC MEDS NDC","BGP CMS ANTIBIOTICS MEDS CLASS",EXP,"","",0,1)
I $G(BGPY)]"" S BGPC=BGPC+1,BGPY(BGPC)=BGPY
S X=$$CPTI^BGP1DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8012"))
I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8012: "_$$DATE^BGP1UTL($P(X,U,2))
S X=$$TRANI^BGP1DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8012"))
I X S BGPC=BGPC+1,BGPY(BGPC)="TRAN CODE CPT code G8012: "_$$DATE^BGP1UTL($P(X,U,2))
;now see if any procedures
S X=0 F S X=$O(^AUPNVPRC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVPRC(X,0))
.S I=$P($G(^AUPNVPRC(X,0)),U) Q:'I
.S Y=$P($$ICDOP^ICDCODE(I),U,2)
.I Y=99.21 D
..S V=$P(^AUPNVPRC(X,0),U,3)
..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
..I V>EDATE Q
..I V<BDATE Q
..S BGPC=BGPC+1,BGPY(BGPC)="ANTIBIOTIC PROCEDURE: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
K BGPG
D IVUD^BGP1CU1(P,BDATE,EDATE,"BGP CMS ANTIBIOTIC MEDS",.BGPG,"BGP CMS ANTIBIOTIC MEDS NDC","BGP CMS ANTIBIOTICS MEDS CLASS")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=0 F S Y=$O(BGPG(X,Y)) Q:Y'=+Y S BGPC=BGPC+1,BGPY(BGPC)=BGPG(X,Y)
Q
LVS(P,EDATE,BGPY,ADMDT) ;EP -does patient have LVS EVALUATION
NEW ED,BD,BGPG,BGPC,X,Y,Z,N,I,T
;BGPD is discharge date
S BGPC=0 K BGPY
CEFMEAS ;now get all measurements CEF
K BGPG S Y="BGPG(",X=P_"^ALL MEAS CEF;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(DFN))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.Q:$P($G(^AUPNVMSR(Y,2)),U,1)
.S N=$P(^AUPNVMSR(Y,0),U,4)
.S BGPC=BGPC+1,BGPY(BGPC)="MEASUREMENT CEF: "_$$DATE^BGP1UTL($P(BGPG(X),U))_" value: "_N
.Q
CEFPROC ;now see if any procedures
S X=0 F S X=$O(^AUPNVPRC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVPRC(X,0))
.S I=$P($G(^AUPNVPRC(X,0)),U) Q:'I
.S Y=$P($$ICDOP^ICDCODE(I),U,2)
.S T="",T=$O(^ATXAX("B","BGP CMS EJECTION FRACTION PROC",0))
.I $$ICD^ATXCHK(I,T,0) D
..S V=$P(^AUPNVPRC(X,0),U,3)
..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
..I V>EDATE Q ;after discharge
..S BGPC=BGPC+1,BGPY(BGPC)="CEF PROCEDURE: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
CEFCPT ;now get all cpts
S X=0 F S X=$O(^AUPNVCPT("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVCPT(X,0))
.S I=$P($G(^AUPNVCPT(X,0)),U) Q:'I
.S Y=$P($$CPT^ICPTCOD(I),U,2)
.S T="",T=$O(^ATXAX("B","BGP CMS EJECTION FRACTION CPTS",0))
.I $$ICD^ATXCHK(I,T,1) D
..S V=$P(^AUPNVCPT(X,0),U,3)
..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
..I V>EDATE Q ;after discharge
..S BGPC=BGPC+1,BGPY(BGPC)="CEF CPT: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$P($$CPT^ICPTCOD(I,V),U,3)
S X=0 F S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVTC(X,0))
.S I=$P($G(^AUPNVTC(X,0)),U,7) Q:'I
.S Y=$P($$CPT^ICPTCOD(I),U,2)
.Q:Y=""
.S T="",T=$O(^ATXAX("B","BGP CMS EJECTION FRACTION CPTS",0))
.I $$ICD^ATXCHK(I,T,1) D
..S V=$P(^AUPNVTC(X,0),U,3)
..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
..I V>EDATE Q ;after discharge
..S BGPC=BGPC+1,BGPY(BGPC)="CEF TRAN CODE CPT: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$P($$CPT^ICPTCOD(I,V),U,3)
;now check rcis referrals
S X=0 F S X=$O(^BMCREF("D",P,X)) Q:X'=+X D
.S I=$P($G(^BMCREF(X,0)),U,12)
.Q:I=""
.Q:'$D(^BMCTDXC(I))
.Q:$P(^BMCTDXC(I,0),U)'="CARDIOVASCULAR DISORDERS"
.S C=$P($G(^BMCREF(X,0)),U,13)
.Q:C=""
.Q:'$D(^BMCTSVC(C))
.S V=$P(^BMCTSVC(C,0),U)
.Q:'$$CPTC(V)
.S D=$P(^BMCREF(X,0),U)
.Q:$P(D,".")>EDATE
.Q:$P(D,".")<ADMDT
.S BGPC=BGPC+1,BGPY(BGPC)="RCIS REFERRAL: "_$$DATE^BGP1UTL($P(^BMCREF(X,0),U))_" ICD CAT: "_$P(^BMCTDXC(I,0),U)_" CPT CAT: "_V
;now check for new "assumptions"
;ECHOCARDIOGRAM
S X=0 F S X=$O(^AUPNVPRC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVPRC(X,0))
.S I=$P($G(^AUPNVPRC(X,0)),U) Q:'I
.S Y=$P($$ICDOP^ICDCODE(I),U,2)
.S T="",T=$O(^ATXAX("B","BGP CMS ECHOCARDIOGRAM PROCS",0))
.I 'T W BGPBOMB
.I $$ICD^ATXCHK(I,T,0) D
..S V=$P(^AUPNVPRC(X,0),U,3)
..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
..I V>EDATE Q ;after discharge
..S BGPC=BGPC+1,BGPY(BGPC)="ECHOCARDIOGRAM PROCEDURE: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
;NUCLEAR MEDICINE
S X=0 F S X=$O(^AUPNVPRC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVPRC(X,0))
.S I=$P($G(^AUPNVPRC(X,0)),U) Q:'I
.S Y=$P($$ICDOP^ICDCODE(I),U,2)
.S T="",T=$O(^ATXAX("B","BGP CMS NUCLEAR MEDICINE PROCS",0))
.I 'T W BGPBOMB
.I $$ICD^ATXCHK(I,T,0) D
..S V=$P(^AUPNVPRC(X,0),U,3)
..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
..I V>EDATE Q ;after discharge
..S BGPC=BGPC+1,BGPY(BGPC)="NUCLEAR MEDICINE PROCEDURE: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
;CARDIAC CATH
S X=0 F S X=$O(^AUPNVPRC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVPRC(X,0))
.S I=$P($G(^AUPNVPRC(X,0)),U) Q:'I
.S Y=$P($$ICDOP^ICDCODE(I),U,2)
.S T="",T=$O(^ATXAX("B","BGP CMS CARDIAC CATH/LV PROCS",0))
.I 'T W BGPBOMB
.I $$ICD^ATXCHK(I,T,0) D
..S V=$P(^AUPNVPRC(X,0),U,3)
..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
..I V>EDATE Q ;after discharge
..S BGPC=BGPC+1,BGPY(BGPC)="CARDIAC CATHETERIZATION PROCEDURE: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
Q
CPTC(Z) ;
I Z="EVALUATION AND/OR MANAGEMENT" Q 1
I Z="NONSURGICAL PROCEDURES" Q 1
I Z="DIAGNOSTIC IMAGING" Q 1
Q 0
;
BGP1CU3 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM 04 May 2010 2:38 PM ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
ERBC(P,BDATE,EDATE,BGPY) ;EP - did patient have an er visit from bdate to edate without a DX in taxonomy T?
+1 NEW BGPG,A,B,E,G,X,I,BGPC,BGPB
+2 KILL BGPG,BGPY
+3 SET BGPC=0
+4 SET A="BGPG("
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+5 IF '$DATA(BGPG(1))
QUIT
+6 SET X=0
SET (G,E)=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET V=$PIECE(BGPG(X),U,5)
Begin DoDot:1
+7 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+8 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+9 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 IF $$CLINIC^APCLV(V,"C")'=30
QUIT
+11 KILL BGPB
+12 DO BC(V,.BGPB)
+13 IF '$DATA(BGPB)
QUIT
+14 SET BGPC=BGPC+1
SET BGPY(BGPC)="ER Visit: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))
End DoDot:1
+15 QUIT
+16 ;
BC(V,BGPZ) ;any blood culture tests on visit V
+1 ;now check cpts/tran codes for 87040, 87103
+2 NEW BGPC,BGPLT,C1,Z,T,B,D,E,C
+3 SET BGPC=0
+4 SET Z=0
FOR
SET Z=$ORDER(^AUPNVCPT("AD",V,Z))
IF Z'=+Z
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNVCPT(Z,0))
QUIT
+6 SET C1=$$VAL^XBDIQ1(9000010.18,Z,.01)
+7 IF C1'=87040
IF C1'=87103
QUIT
+8 SET BGPC=BGPC+1
SET BGPZ(BGPC)="CPT code: "_C1
+9 QUIT
End DoDot:1
+10 ;tran codes
+11 SET Z=0
FOR
SET Z=$ORDER(^AUPNVTC("AD",V,Z))
IF Z'=+Z
QUIT
Begin DoDot:1
+12 IF '$DATA(^AUPNVTC(Z,0))
QUIT
+13 SET C1=$$VAL^XBDIQ1(9000010.33,Z,.07)
+14 IF C1'=87040
IF C1'=87103
QUIT
+15 SET BGPC=BGPC+1
SET BGPZ(BGPC)="TRAN CODE CPT code: "_C1
+16 QUIT
End DoDot:1
+17 SET T=$ORDER(^ATXAX("B","BGP CMS BLOOD CULTURE PROC",0))
+18 SET Z=0
FOR
SET Z=$ORDER(^AUPNVPRC("AD",V,Z))
IF Z'=+Z
QUIT
Begin DoDot:1
+19 IF '$DATA(^AUPNVPRC(Z,0))
QUIT
+20 SET C1=$$VAL^XBDIQ1(9000010.08,Z,.01)
+21 SET C=$$VALI^XBDIQ1(9000010.08,Z,.01)
+22 IF '$$ICD^ATXCHK(C,T,0)
QUIT
+23 SET BGPC=BGPC+1
SET BGPZ(BGPC)="Procedure code: "_C1
+24 QUIT
End DoDot:1
+25 SET Z=0
FOR
SET Z=$ORDER(^AUPNVPOV("AD",V,Z))
IF Z'=+Z
QUIT
Begin DoDot:1
+26 IF '$DATA(^AUPNVPOV(Z,0))
QUIT
+27 SET C1=$$VAL^XBDIQ1(9000010.07,Z,.01)
+28 IF C1'="790.7"
QUIT
+29 SET BGPC=BGPC+1
SET BGPZ(BGPC)="POV code: "_C1
+30 QUIT
End DoDot:1
+31 SET T=$ORDER(^ATXAX("B","BGP BLOOD CULTURE LOINC",0))
+32 SET BGPLT=$ORDER(^ATXLAB("B","BGP CMS BLOOD CULTURE",0))
+33 SET A=0
FOR
SET A=$ORDER(^AUPNVLAB("AD",V,A))
IF A'=+A
QUIT
Begin DoDot:1
+34 IF '$DATA(^AUPNVLAB(A,0))
QUIT
+35 IF $$VAL^XBDIQ1(9000010.09,A,.01)="BLOOD CULTURE"
Begin DoDot:2
+36 SET BGPC=BGPC+1
SET BGPZ(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" value: "_$PIECE(^AUPNVLAB(A,0),U,4)
QUIT
+37 IF BGPLT
IF $PIECE(^AUPNVLAB(A,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(A,0),U)))
SET BGPC=BGPC+1
SET BGPZ(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" value: "_$PIECE(^AUPNVLAB(A,0),U,4)
QUIT
+38 IF 'T
QUIT
+39 SET J=$PIECE($GET(^AUPNVLAB(A,11)),U,13)
IF J=""
QUIT
+40 IF '$$LOINC^BGP1D21(J,T)
QUIT
+41 SET BGPC=BGPC+1
SET BGPZ(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" value: "_$PIECE(^AUPNVLAB(A,0),U,4)
+42 QUIT
End DoDot:2
QUIT
End DoDot:1
+43 SET A=0
FOR
SET A=$ORDER(^AUPNVMIC("AD",V,A))
IF A'=+A
QUIT
Begin DoDot:1
+44 IF '$DATA(^AUPNVMIC(A,0))
QUIT
+45 IF $$VAL^XBDIQ1(9000010.25,A,.01)="BLOOD CULTURE"
Begin DoDot:2
+46 SET BGPC=BGPC+1
SET BGPZ(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$PIECE(^AUPNVMIC(A,0),U,7)
QUIT
+47 IF BGPLT
IF $PIECE(^AUPNVMIC(A,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVMIC(A,0),U)))
Begin DoDot:3
+48 SET BGPC=BGPC+1
SET BGPZ(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$PIECE(^AUPNVMIC(A,0),U,7)
QUIT
End DoDot:3
+49 IF 'T
QUIT
+50 SET J=$PIECE($GET(^AUPNVMIC(A,11)),U,13)
IF J=""
QUIT
+51 IF '$$LOINC^BGP1D21(J,T)
QUIT
+52 SET BGPC=BGPC+1
SET BGPZ(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$PIECE(^AUPNVMIC(A,0),U,7)
End DoDot:2
QUIT
End DoDot:1
+53 QUIT
ERBCP(P,BD,ED,BGPY) ;EP
+1 NEW BGPG,BGPC
+2 KILL BGPG,BGPY
+3 SET BGPC=0
+4 SET A="BGPG("
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED)
SET E=$$START1^APCLDF(B,A)
+5 IF '$DATA(BGPG(1))
QUIT
+6 SET (X,G)=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET V=$PIECE(BGPG(X),U,5)
Begin DoDot:1
+7 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+8 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+9 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 IF $$CLINIC^APCLV(V,"C")'=30
QUIT
+11 SET BGPC=BGPC+1
SET BGPY(BGPC)="ER Visit: "_$$DATE^BGP1UTL($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
+12 SET BGPC=BGPC+1
SET BGPY(BGPC)="ER Diagnoses: "
+13 SET A=0
FOR
SET A=$ORDER(^AUPNVPOV("AD",V,A))
IF A'=+A
QUIT
Begin DoDot:2
+14 SET BGPC=BGPC+1
SET BGPY(BGPC)=" "_$$VAL^XBDIQ1(9000010.07,A,.01)_" "_$$VAL^XBDIQ1(9000010.07,A,.04)
End DoDot:2
+15 SET BGPC=BGPC+1
SET BGPY(BGPC)="Blood Culture: "
+16 ;now check cpts/tran codes for 87040, 87103
+17 SET Z=0
FOR
SET Z=$ORDER(^AUPNVCPT("AD",V,Z))
IF Z'=+Z
QUIT
Begin DoDot:2
+18 IF '$DATA(^AUPNVCPT(Z,0))
QUIT
+19 SET C1=$$VAL^XBDIQ1(9000010.18,Z,.01)
+20 IF C1'=87040
IF C1'=87103
QUIT
+21 SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT code: "_C1
+22 QUIT
End DoDot:2
+23 ;tran codes
+24 SET Z=0
FOR
SET Z=$ORDER(^AUPNVTC("AD",V,Z))
IF Z'=+Z
QUIT
Begin DoDot:2
+25 IF '$DATA(^AUPNVTC(Z,0))
QUIT
+26 SET C1=$$VAL^XBDIQ1(9000010.33,Z,.07)
+27 IF C1'=87040
IF C1'=87103
QUIT
+28 SET BGPC=BGPC+1
SET BGPY(BGPC)="TRAN CODE CPT code: "_C1
+29 QUIT
End DoDot:2
+30 ;procedures
+31 SET T=$ORDER(^ATXAX("B","BGP CMS BLOOD CULTURE PROC",0))
+32 SET Z=0
FOR
SET Z=$ORDER(^AUPNVPRC("AD",V,Z))
IF Z'=+Z
QUIT
Begin DoDot:2
+33 IF '$DATA(^AUPNVPRC(Z,0))
QUIT
+34 SET C1=$$VAL^XBDIQ1(9000010.08,Z,.01)
+35 SET C=$$VALI^XBDIQ1(9000010.08,Z,.01)
+36 IF '$$ICD^ATXCHK(C,T,0)
QUIT
+37 SET BGPC=BGPC+1
SET BGPY(BGPC)="Procedure code: "_C1
End DoDot:2
+38 ;pov
+39 SET Z=0
FOR
SET Z=$ORDER(^AUPNVPOV("AD",V,Z))
IF Z'=+Z
QUIT
Begin DoDot:2
+40 IF '$DATA(^AUPNVPOV(Z,0))
QUIT
+41 SET C1=$$VAL^XBDIQ1(9000010.07,Z,.01)
+42 IF C1'="790.7"
QUIT
+43 SET BGPC=BGPC+1
SET BGPY(BGPC)="POV code: "_C1
End DoDot:2
+44 ;labs
+45 SET T=$ORDER(^ATXAX("B","BGP BLOOD CULTURE LOINC",0))
+46 SET BGPLT=$ORDER(^ATXLAB("B","BGP CMS BLOOD CULTURE",0))
+47 SET B=9999999-$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET E=9999999-$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:2
+48 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:3
+49 SET A=0
FOR
SET A=$ORDER(^AUPNVLAB("AE",P,D,L,A))
IF A'=+A
QUIT
Begin DoDot:4
+50 IF '$DATA(^AUPNVLAB(A,0))
QUIT
+51 IF $$VAL^XBDIQ1(9000010.09,A,.01)="BLOOD CULTURE"
Begin DoDot:5
+52 SET BGPC=BGPC+1
SET BGPY(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" value: "_$PIECE(^AUPNVLAB(A,0),U,4)
QUIT
End DoDot:5
QUIT
+53 IF BGPLT
IF $PIECE(^AUPNVLAB(A,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(A,0),U)))
SET BGPC=BGPC+1
SET BGPY(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" value: "_$PIECE(^AUPNVLAB(A,0),U,4)
QUIT
+54 IF 'T
QUIT
+55 SET J=$PIECE($GET(^AUPNVLAB(A,11)),U,13)
IF J=""
QUIT
+56 IF '$$LOINC^BGP1D21(J,T)
QUIT
+57 SET BGPC=BGPC+1
SET BGPY(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" value: "_$PIECE(^AUPNVLAB(A,0),U,4)
+58 QUIT
End DoDot:4
End DoDot:3
End DoDot:2
+59 ;micro
+60 SET B=9999999-$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET E=9999999-$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET D=E-1
FOR
SET D=$ORDER(^AUPNVMIC("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:2
+61 SET L=0
FOR
SET L=$ORDER(^AUPNVMIC("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:3
+62 SET A=0
FOR
SET A=$ORDER(^AUPNVMIC("AE",P,D,L,A))
IF A'=+A
QUIT
Begin DoDot:4
+63 IF '$DATA(^AUPNVMIC(A,0))
QUIT
+64 IF $$VAL^XBDIQ1(9000010.25,A,.01)="BLOOD CULTURE"
Begin DoDot:5
+65 SET BGPC=BGPC+1
SET BGPY(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$PIECE(^AUPNVMIC(A,0),U,7)
QUIT
End DoDot:5
QUIT
+66 IF BGPLT
IF $PIECE(^AUPNVMIC(A,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVMIC(A,0),U)))
Begin DoDot:5
+67 SET BGPC=BGPC+1
SET BGPY(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$PIECE(^AUPNVMIC(A,0),U,7)
QUIT
End DoDot:5
+68 IF 'T
QUIT
+69 SET J=$PIECE($GET(^AUPNVMIC(A,11)),U,13)
IF J=""
QUIT
+70 IF '$$LOINC^BGP1D21(J,T)
QUIT
+71 SET BGPC=BGPC+1
SET BGPY(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$PIECE(^AUPNVMIC(A,0),U,7)
+72 QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+73 QUIT
+74 ;
ANTIRX(P,BDATE,EDATE,BGPY,EXP) ;EP
+1 NEW BGPG,BGPC,X,Y,Z,E,BD,ED
+2 SET BGPC=0
+3 SET EXP=$GET(EXP)
+4 DO GETMEDS^BGP1CU(P,BDATE,EDATE,"BGP CMS ANTIBIOTIC MEDS","BGP CMS ANTIBIOTIC MEDS NDC","BGP CMS ANTIBIOTICS MEDS CLASS",EXP,"","",0,1)
+5 IF $GET(BGPY)]""
SET BGPC=BGPC+1
SET BGPY(BGPC)=BGPY
+6 SET X=$$CPTI^BGP1DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8012"))
+7 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT code G8012: "_$$DATE^BGP1UTL($PIECE(X,U,2))
+8 SET X=$$TRANI^BGP1DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8012"))
+9 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="TRAN CODE CPT code G8012: "_$$DATE^BGP1UTL($PIECE(X,U,2))
+10 ;now see if any procedures
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+12 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+13 SET I=$PIECE($GET(^AUPNVPRC(X,0)),U)
IF 'I
QUIT
+14 SET Y=$PIECE($$ICDOP^ICDCODE(I),U,2)
+15 IF Y=99.21
Begin DoDot:2
+16 SET V=$PIECE(^AUPNVPRC(X,0),U,3)
+17 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+18 IF V>EDATE
QUIT
+19 IF V<BDATE
QUIT
+20 SET BGPC=BGPC+1
SET BGPY(BGPC)="ANTIBIOTIC PROCEDURE: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
End DoDot:2
End DoDot:1
+21 KILL BGPG
+22 DO IVUD^BGP1CU1(P,BDATE,EDATE,"BGP CMS ANTIBIOTIC MEDS",.BGPG,"BGP CMS ANTIBIOTIC MEDS NDC","BGP CMS ANTIBIOTICS MEDS CLASS")
+23 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(BGPG(X,Y))
IF Y'=+Y
QUIT
SET BGPC=BGPC+1
SET BGPY(BGPC)=BGPG(X,Y)
+24 QUIT
LVS(P,EDATE,BGPY,ADMDT) ;EP -does patient have LVS EVALUATION
+1 NEW ED,BD,BGPG,BGPC,X,Y,Z,N,I,T
+2 ;BGPD is discharge date
+3 SET BGPC=0
KILL BGPY
CEFMEAS ;now get all measurements CEF
+1 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL MEAS CEF;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(DFN))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+2 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+3 IF $PIECE($GET(^AUPNVMSR(Y,2)),U,1)
QUIT
+4 SET N=$PIECE(^AUPNVMSR(Y,0),U,4)
+5 SET BGPC=BGPC+1
SET BGPY(BGPC)="MEASUREMENT CEF: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" value: "_N
+6 QUIT
End DoDot:1
CEFPROC ;now see if any procedures
+1 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+3 SET I=$PIECE($GET(^AUPNVPRC(X,0)),U)
IF 'I
QUIT
+4 SET Y=$PIECE($$ICDOP^ICDCODE(I),U,2)
+5 SET T=""
SET T=$ORDER(^ATXAX("B","BGP CMS EJECTION FRACTION PROC",0))
+6 IF $$ICD^ATXCHK(I,T,0)
Begin DoDot:2
+7 SET V=$PIECE(^AUPNVPRC(X,0),U,3)
+8 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+9 ;after discharge
IF V>EDATE
QUIT
+10 SET BGPC=BGPC+1
SET BGPY(BGPC)="CEF PROCEDURE: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
End DoDot:2
End DoDot:1
CEFCPT ;now get all cpts
+1 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+3 SET I=$PIECE($GET(^AUPNVCPT(X,0)),U)
IF 'I
QUIT
+4 SET Y=$PIECE($$CPT^ICPTCOD(I),U,2)
+5 SET T=""
SET T=$ORDER(^ATXAX("B","BGP CMS EJECTION FRACTION CPTS",0))
+6 IF $$ICD^ATXCHK(I,T,1)
Begin DoDot:2
+7 SET V=$PIECE(^AUPNVCPT(X,0),U,3)
+8 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+9 ;after discharge
IF V>EDATE
QUIT
+10 SET BGPC=BGPC+1
SET BGPY(BGPC)="CEF CPT: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$PIECE($$CPT^ICPTCOD(I,V),U,3)
End DoDot:2
End DoDot:1
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+12 IF '$DATA(^AUPNVTC(X,0))
QUIT
+13 SET I=$PIECE($GET(^AUPNVTC(X,0)),U,7)
IF 'I
QUIT
+14 SET Y=$PIECE($$CPT^ICPTCOD(I),U,2)
+15 IF Y=""
QUIT
+16 SET T=""
SET T=$ORDER(^ATXAX("B","BGP CMS EJECTION FRACTION CPTS",0))
+17 IF $$ICD^ATXCHK(I,T,1)
Begin DoDot:2
+18 SET V=$PIECE(^AUPNVTC(X,0),U,3)
+19 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+20 ;after discharge
IF V>EDATE
QUIT
+21 SET BGPC=BGPC+1
SET BGPY(BGPC)="CEF TRAN CODE CPT: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$PIECE($$CPT^ICPTCOD(I,V),U,3)
End DoDot:2
End DoDot:1
+22 ;now check rcis referrals
+23 SET X=0
FOR
SET X=$ORDER(^BMCREF("D",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+24 SET I=$PIECE($GET(^BMCREF(X,0)),U,12)
+25 IF I=""
QUIT
+26 IF '$DATA(^BMCTDXC(I))
QUIT
+27 IF $PIECE(^BMCTDXC(I,0),U)'="CARDIOVASCULAR DISORDERS"
QUIT
+28 SET C=$PIECE($GET(^BMCREF(X,0)),U,13)
+29 IF C=""
QUIT
+30 IF '$DATA(^BMCTSVC(C))
QUIT
+31 SET V=$PIECE(^BMCTSVC(C,0),U)
+32 IF '$$CPTC(V)
QUIT
+33 SET D=$PIECE(^BMCREF(X,0),U)
+34 IF $PIECE(D,".")>EDATE
QUIT
+35 IF $PIECE(D,".")<ADMDT
QUIT
+36 SET BGPC=BGPC+1
SET BGPY(BGPC)="RCIS REFERRAL: "_$$DATE^BGP1UTL($PIECE(^BMCREF(X,0),U))_" ICD CAT: "_$PIECE(^BMCTDXC(I,0),U)_" CPT CAT: "_V
End DoDot:1
+37 ;now check for new "assumptions"
+38 ;ECHOCARDIOGRAM
+39 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+40 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+41 SET I=$PIECE($GET(^AUPNVPRC(X,0)),U)
IF 'I
QUIT
+42 SET Y=$PIECE($$ICDOP^ICDCODE(I),U,2)
+43 SET T=""
SET T=$ORDER(^ATXAX("B","BGP CMS ECHOCARDIOGRAM PROCS",0))
+44 IF 'T
WRITE BGPBOMB
+45 IF $$ICD^ATXCHK(I,T,0)
Begin DoDot:2
+46 SET V=$PIECE(^AUPNVPRC(X,0),U,3)
+47 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+48 ;after discharge
IF V>EDATE
QUIT
+49 SET BGPC=BGPC+1
SET BGPY(BGPC)="ECHOCARDIOGRAM PROCEDURE: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
End DoDot:2
End DoDot:1
+50 ;NUCLEAR MEDICINE
+51 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+52 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+53 SET I=$PIECE($GET(^AUPNVPRC(X,0)),U)
IF 'I
QUIT
+54 SET Y=$PIECE($$ICDOP^ICDCODE(I),U,2)
+55 SET T=""
SET T=$ORDER(^ATXAX("B","BGP CMS NUCLEAR MEDICINE PROCS",0))
+56 IF 'T
WRITE BGPBOMB
+57 IF $$ICD^ATXCHK(I,T,0)
Begin DoDot:2
+58 SET V=$PIECE(^AUPNVPRC(X,0),U,3)
+59 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+60 ;after discharge
IF V>EDATE
QUIT
+61 SET BGPC=BGPC+1
SET BGPY(BGPC)="NUCLEAR MEDICINE PROCEDURE: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
End DoDot:2
End DoDot:1
+62 ;CARDIAC CATH
+63 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+64 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+65 SET I=$PIECE($GET(^AUPNVPRC(X,0)),U)
IF 'I
QUIT
+66 SET Y=$PIECE($$ICDOP^ICDCODE(I),U,2)
+67 SET T=""
SET T=$ORDER(^ATXAX("B","BGP CMS CARDIAC CATH/LV PROCS",0))
+68 IF 'T
WRITE BGPBOMB
+69 IF $$ICD^ATXCHK(I,T,0)
Begin DoDot:2
+70 SET V=$PIECE(^AUPNVPRC(X,0),U,3)
+71 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+72 ;after discharge
IF V>EDATE
QUIT
+73 SET BGPC=BGPC+1
SET BGPY(BGPC)="CARDIAC CATHETERIZATION PROCEDURE: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
End DoDot:2
End DoDot:1
+74 QUIT
CPTC(Z) ;
+1 IF Z="EVALUATION AND/OR MANAGEMENT"
QUIT 1
+2 IF Z="NONSURGICAL PROCEDURES"
QUIT 1
+3 IF Z="DIAGNOSTIC IMAGING"
QUIT 1
+4 QUIT 0
+5 ;
