Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP0CU3

BGP0CU3.m

Go to the documentation of this file.
BGP0CU3 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM 04 May 2009 2:38 PM ;
 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
 ;
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^BGP0UTL($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^BGP0D21(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^BGP0D21(J,T)
 ..S BGPC=BGPC+1,BGPZ(BGPC)="  MICRO:  "_$$VAL^XBDIQ1(9000010.25,A,.01)_"  "_$$DATE^BGP0UTL($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^BGP0UTL($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^BGP0UTL($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^BGP0UTL($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^BGP0D21(J,T)
 ....S BGPC=BGPC+1,BGPY(BGPC)="  LAB:  "_$$VAL^XBDIQ1(9000010.09,A,.01)_"  "_$$DATE^BGP0UTL($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^BGP0UTL($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^BGP0UTL($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^BGP0D21(J,T)
 ....S BGPC=BGPC+1,BGPY(BGPC)="  MICRO:  "_$$VAL^XBDIQ1(9000010.25,A,.01)_"  "_$$DATE^BGP0UTL($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^BGP0CU(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^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8012"))
 I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8012: "_$$DATE^BGP0UTL($P(X,U,2))
 S X=$$TRANI^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8012"))
 I X S BGPC=BGPC+1,BGPY(BGPC)="TRAN CODE CPT code G8012: "_$$DATE^BGP0UTL($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^BGP0UTL(V)_"  ["_Y_"]  "_$$VAL^XBDIQ1(9000010.08,X,.04)
 K BGPG
 D IVUD^BGP0CU1(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^BGP0UTL($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^BGP0UTL(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^BGP0UTL(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^BGP0UTL(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^BGP0UTL($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^BGP0UTL(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^BGP0UTL(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^BGP0UTL(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
 ;