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

BGP2CU3.m

Go to the documentation of this file. 
  1. BGP2CU3 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM 04 May 2010 2:38 PM ;
  1.  ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
  1.  ;
  1. 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
  1.  K BGPG,BGPY
  1.  S BGPC=0
  1.  S A="BGPG(",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
  1.  I '$D(BGPG(1)) Q
  1.  S X=0,(G,E)="" F  S X=$O(BGPG(X)) Q:X'=+X  S V=$P(BGPG(X),U,5) D
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .Q:$$CLINIC^APCLV(V,"C")'=30
  1.  .K BGPB
  1.  .D BC(V,.BGPB)
  1.  .I '$D(BGPB) Q
  1.  .S BGPC=BGPC+1,BGPY(BGPC)="ER Visit: "_$$DATE^BGP2UTL($P(BGPG(X),U))
  1.  Q
  1.  ;
  1. BC(V,BGPZ) ;any blood culture tests on visit V
  1.  ;now check cpts/tran codes for 87040, 87103
  1.  NEW BGPC,BGPLT,C1,Z,T,B,D,E,C
  1.  S BGPC=0
  1.  S Z=0 F  S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z  D
  1.  .Q:'$D(^AUPNVCPT(Z,0))
  1.  .S C1=$$VAL^XBDIQ1(9000010.18,Z,.01)
  1.  .I C1'=87040,C1'=87103 Q
  1.  .S BGPC=BGPC+1,BGPZ(BGPC)="CPT code: "_C1
  1.  .Q
  1.  ;tran codes
  1.  S Z=0 F  S Z=$O(^AUPNVTC("AD",V,Z)) Q:Z'=+Z  D
  1.  .Q:'$D(^AUPNVTC(Z,0))
  1.  .S C1=$$VAL^XBDIQ1(9000010.33,Z,.07)
  1.  .I C1'=87040,C1'=87103 Q
  1.  .S BGPC=BGPC+1,BGPZ(BGPC)="TRAN CODE CPT code: "_C1
  1.  .Q
  1.  S T=$O(^ATXAX("B","BGP CMS BLOOD CULTURE PROC",0))
  1.  S Z=0 F  S Z=$O(^AUPNVPRC("AD",V,Z)) Q:Z'=+Z  D
  1.  .Q:'$D(^AUPNVPRC(Z,0))
  1.  .S C1=$$VAL^XBDIQ1(9000010.08,Z,.01)
  1.  .S C=$$VALI^XBDIQ1(9000010.08,Z,.01)
  1.  .I '$$ICD^ATXCHK(C,T,0) Q
  1.  .S BGPC=BGPC+1,BGPZ(BGPC)="Procedure code: "_C1
  1.  .Q
  1.  S Z=0 F  S Z=$O(^AUPNVPOV("AD",V,Z)) Q:Z'=+Z  D
  1.  .Q:'$D(^AUPNVPOV(Z,0))
  1.  .S C1=$$VAL^XBDIQ1(9000010.07,Z,.01)
  1.  .I C1'="790.7" Q
  1.  .S BGPC=BGPC+1,BGPZ(BGPC)="POV code: "_C1
  1.  .Q
  1.  S T=$O(^ATXAX("B","BGP BLOOD CULTURE LOINC",0))
  1.  S BGPLT=$O(^ATXLAB("B","BGP CMS BLOOD CULTURE",0))
  1.  S A=0 F  S A=$O(^AUPNVLAB("AD",V,A)) Q:A'=+A  D
  1.  .Q:'$D(^AUPNVLAB(A,0))
  1.  .I $$VAL^XBDIQ1(9000010.09,A,.01)="BLOOD CULTURE" D  Q
  1.  ..S BGPC=BGPC+1,BGPZ(BGPC)="  LAB:  "_$$VAL^XBDIQ1(9000010.09,A,.01)_"  value: "_$P(^AUPNVLAB(A,0),U,4) Q
  1.  ..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
  1.  ..Q:'T
  1.  ..S J=$P($G(^AUPNVLAB(A,11)),U,13) Q:J=""
  1.  ..Q:'$$LOINC^BGP2D21(J,T)
  1.  ..S BGPC=BGPC+1,BGPZ(BGPC)="  LAB:  "_$$VAL^XBDIQ1(9000010.09,A,.01)_"  value: "_$P(^AUPNVLAB(A,0),U,4)
  1.  ..Q
  1.  S A=0 F  S A=$O(^AUPNVMIC("AD",V,A)) Q:A'=+A  D
  1.  .Q:'$D(^AUPNVMIC(A,0))
  1.  .I $$VAL^XBDIQ1(9000010.25,A,.01)="BLOOD CULTURE" D  Q
  1.  ..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
  1.  ..I BGPLT,$P(^AUPNVMIC(A,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVMIC(A,0),U))) D
  1.  ...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
  1.  ..Q:'T
  1.  ..S J=$P($G(^AUPNVMIC(A,11)),U,13) Q:J=""
  1.  ..Q:'$$LOINC^BGP2D21(J,T)
  1.  ..S BGPC=BGPC+1,BGPZ(BGPC)="  MICRO:  "_$$VAL^XBDIQ1(9000010.25,A,.01)_"  "_$$DATE^BGP2UTL($P(BGPG(X),U))_"  value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$P(^AUPNVMIC(A,0),U,7)
  1.  Q
  1. ERBCP(P,BD,ED,BGPY) ;EP
  1.  NEW BGPG,BGPC
  1.  K BGPG,BGPY
  1.  S BGPC=0
  1.  S A="BGPG(",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED),E=$$START1^APCLDF(B,A)
  1.  I '$D(BGPG(1)) Q
  1.  S (X,G)=0 F  S X=$O(BGPG(X)) Q:X'=+X  S V=$P(BGPG(X),U,5) D
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .Q:$$CLINIC^APCLV(V,"C")'=30
  1.  .S BGPC=BGPC+1,BGPY(BGPC)="ER Visit: "_$$DATE^BGP2UTL($P($P(^AUPNVSIT(V,0),U),"."))
  1.  .S BGPC=BGPC+1,BGPY(BGPC)="ER Diagnoses: "
  1.  .S A=0 F  S A=$O(^AUPNVPOV("AD",V,A)) Q:A'=+A  D
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)="  "_$$VAL^XBDIQ1(9000010.07,A,.01)_"  "_$$VAL^XBDIQ1(9000010.07,A,.04)
  1.  .S BGPC=BGPC+1,BGPY(BGPC)="Blood Culture: "
  1.  .;now check cpts/tran codes for 87040, 87103
  1.  .S Z=0 F  S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z  D
  1.  ..Q:'$D(^AUPNVCPT(Z,0))
  1.  ..S C1=$$VAL^XBDIQ1(9000010.18,Z,.01)
  1.  ..I C1'=87040,C1'=87103 Q
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)="CPT code: "_C1
  1.  ..Q
  1.  .;tran codes
  1.  .S Z=0 F  S Z=$O(^AUPNVTC("AD",V,Z)) Q:Z'=+Z  D
  1.  ..Q:'$D(^AUPNVTC(Z,0))
  1.  ..S C1=$$VAL^XBDIQ1(9000010.33,Z,.07)
  1.  ..I C1'=87040,C1'=87103 Q
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)="TRAN CODE CPT code: "_C1
  1.  ..Q
  1.  .;procedures
  1.  .S T=$O(^ATXAX("B","BGP CMS BLOOD CULTURE PROC",0))
  1.  .S Z=0 F  S Z=$O(^AUPNVPRC("AD",V,Z)) Q:Z'=+Z  D
  1.  ..Q:'$D(^AUPNVPRC(Z,0))
  1.  ..S C1=$$VAL^XBDIQ1(9000010.08,Z,.01)
  1.  ..S C=$$VALI^XBDIQ1(9000010.08,Z,.01)
  1.  ..I '$$ICD^ATXCHK(C,T,0) Q
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)="Procedure code: "_C1
  1.  .;pov
  1.  .S Z=0 F  S Z=$O(^AUPNVPOV("AD",V,Z)) Q:Z'=+Z  D
  1.  ..Q:'$D(^AUPNVPOV(Z,0))
  1.  ..S C1=$$VAL^XBDIQ1(9000010.07,Z,.01)
  1.  ..I C1'="790.7" Q
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)="POV code: "_C1
  1.  .;labs
  1.  .S T=$O(^ATXAX("B","BGP BLOOD CULTURE LOINC",0))
  1.  .S BGPLT=$O(^ATXLAB("B","BGP CMS BLOOD CULTURE",0))
  1.  .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
  1.  ..S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L  D
  1.  ...S A=0 F  S A=$O(^AUPNVLAB("AE",P,D,L,A)) Q:A'=+A  D
  1.  ....Q:'$D(^AUPNVLAB(A,0))
  1.  ....I $$VAL^XBDIQ1(9000010.09,A,.01)="BLOOD CULTURE" D  Q
  1.  .....S BGPC=BGPC+1,BGPY(BGPC)="  LAB:  "_$$VAL^XBDIQ1(9000010.09,A,.01)_"  "_$$DATE^BGP2UTL($P(BGPG(X),U))_"  value: "_$P(^AUPNVLAB(A,0),U,4) Q
  1.  ....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^BGP2UTL($P(BGPG(X),U))_"  value: "_$P(^AUPNVLAB(A,0),U,4) Q
  1.  ....Q:'T
  1.  ....S J=$P($G(^AUPNVLAB(A,11)),U,13) Q:J=""
  1.  ....Q:'$$LOINC^BGP2D21(J,T)
  1.  ....S BGPC=BGPC+1,BGPY(BGPC)="  LAB:  "_$$VAL^XBDIQ1(9000010.09,A,.01)_"  "_$$DATE^BGP2UTL($P(BGPG(X),U))_"  value: "_$P(^AUPNVLAB(A,0),U,4)
  1.  ....Q
  1.  .;micro
  1.  .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
  1.  ..S L=0 F  S L=$O(^AUPNVMIC("AE",P,D,L)) Q:L'=+L  D
  1.  ...S A=0 F  S A=$O(^AUPNVMIC("AE",P,D,L,A)) Q:A'=+A  D
  1.  ....Q:'$D(^AUPNVMIC(A,0))
  1.  ....I $$VAL^XBDIQ1(9000010.25,A,.01)="BLOOD CULTURE" D  Q
  1.  .....S BGPC=BGPC+1,BGPY(BGPC)="  MICRO:  "_$$VAL^XBDIQ1(9000010.25,A,.01)_"  "_$$DATE^BGP2UTL($P(BGPG(X),U))_"  value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$P(^AUPNVMIC(A,0),U,7) Q
  1.  ....I BGPLT,$P(^AUPNVMIC(A,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVMIC(A,0),U))) D
  1.  .....S BGPC=BGPC+1,BGPY(BGPC)="  MICRO:  "_$$VAL^XBDIQ1(9000010.25,A,.01)_"  "_$$DATE^BGP2UTL($P(BGPG(X),U))_"  value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$P(^AUPNVMIC(A,0),U,7) Q
  1.  ....Q:'T
  1.  ....S J=$P($G(^AUPNVMIC(A,11)),U,13) Q:J=""
  1.  ....Q:'$$LOINC^BGP2D21(J,T)
  1.  ....S BGPC=BGPC+1,BGPY(BGPC)="  MICRO:  "_$$VAL^XBDIQ1(9000010.25,A,.01)_"  "_$$DATE^BGP2UTL($P(BGPG(X),U))_"  value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$P(^AUPNVMIC(A,0),U,7)
  1.  ....Q
  1.  Q
  1.  ;
  1. ANTIRX(P,BDATE,EDATE,BGPY,EXP) ;EP
  1.  NEW BGPG,BGPC,X,Y,Z,E,BD,ED
  1.  S BGPC=0
  1.  S EXP=$G(EXP)
  1.  D GETMEDS^BGP2CU(P,BDATE,EDATE,"BGP CMS ANTIBIOTIC MEDS","BGP CMS ANTIBIOTIC MEDS NDC","BGP CMS ANTIBIOTICS MEDS CLASS",EXP,"","",0,1)
  1.  I $G(BGPY)]"" S BGPC=BGPC+1,BGPY(BGPC)=BGPY
  1.  S X=$$CPTI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8012"))
  1.  I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8012: "_$$DATE^BGP2UTL($P(X,U,2))
  1.  S X=$$TRANI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8012"))
  1.  I X S BGPC=BGPC+1,BGPY(BGPC)="TRAN CODE CPT code G8012: "_$$DATE^BGP2UTL($P(X,U,2))
  1.  ;now see if any procedures
  1.  S X=0 F  S X=$O(^AUPNVPRC("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVPRC(X,0))
  1.  .S I=$P($G(^AUPNVPRC(X,0)),U) Q:'I
  1.  .S Y=$P($$ICDOP^ICDCODE(I),U,2)
  1.  .I Y=99.21 D
  1.  ..S V=$P(^AUPNVPRC(X,0),U,3)
  1.  ..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  ..I V>EDATE Q
  1.  ..I V<BDATE Q
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)="ANTIBIOTIC PROCEDURE:  "_$$DATE^BGP2UTL(V)_"  ["_Y_"]  "_$$VAL^XBDIQ1(9000010.08,X,.04)
  1.  K BGPG
  1.  D IVUD^BGP2CU1(P,BDATE,EDATE,"BGP CMS ANTIBIOTIC MEDS",.BGPG,"BGP CMS ANTIBIOTIC MEDS NDC","BGP CMS ANTIBIOTICS MEDS CLASS")
  1.  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)
  1.  Q
  1. LVS(P,EDATE,BGPY,ADMDT) ;EP -does patient have LVS EVALUATION
  1.  NEW ED,BD,BGPG,BGPC,X,Y,Z,N,I,T
  1.  ;BGPD is discharge date
  1.  S BGPC=0 K BGPY
  1. CEFMEAS ;now get all measurements CEF
  1.  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)
  1.  S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  S Y=+$P(BGPG(X),U,4) D
  1.  .Q:$P($G(^AUPNVMSR(Y,2)),U,1)
  1.  .S N=$P(^AUPNVMSR(Y,0),U,4)
  1.  .S BGPC=BGPC+1,BGPY(BGPC)="MEASUREMENT CEF:  "_$$DATE^BGP2UTL($P(BGPG(X),U))_"  value: "_N
  1.  .Q
  1. CEFPROC ;now see if any procedures
  1.  S X=0 F  S X=$O(^AUPNVPRC("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVPRC(X,0))
  1.  .S I=$P($G(^AUPNVPRC(X,0)),U) Q:'I
  1.  .S Y=$P($$ICDOP^ICDCODE(I),U,2)
  1.  .S T="",T=$O(^ATXAX("B","BGP CMS EJECTION FRACTION PROC",0))
  1.  .I $$ICD^ATXCHK(I,T,0) D
  1.  ..S V=$P(^AUPNVPRC(X,0),U,3)
  1.  ..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  ..I V>EDATE Q  ;after discharge
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)="CEF PROCEDURE:  "_$$DATE^BGP2UTL(V)_"  ["_Y_"]  "_$$VAL^XBDIQ1(9000010.08,X,.04)
  1. CEFCPT ;now get all cpts
  1.  S X=0 F  S X=$O(^AUPNVCPT("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVCPT(X,0))
  1.  .S I=$P($G(^AUPNVCPT(X,0)),U) Q:'I
  1.  .S Y=$P($$CPT^ICPTCOD(I),U,2)
  1.  .S T="",T=$O(^ATXAX("B","BGP CMS EJECTION FRACTION CPTS",0))
  1.  .I $$ICD^ATXCHK(I,T,1) D
  1.  ..S V=$P(^AUPNVCPT(X,0),U,3)
  1.  ..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  ..I V>EDATE Q  ;after discharge
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)="CEF CPT:  "_$$DATE^BGP2UTL(V)_"  ["_Y_"]  "_$P($$CPT^ICPTCOD(I,V),U,3)
  1.  S X=0 F  S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVTC(X,0))
  1.  .S I=$P($G(^AUPNVTC(X,0)),U,7) Q:'I
  1.  .S Y=$P($$CPT^ICPTCOD(I),U,2)
  1.  .Q:Y=""
  1.  .S T="",T=$O(^ATXAX("B","BGP CMS EJECTION FRACTION CPTS",0))
  1.  .I $$ICD^ATXCHK(I,T,1) D
  1.  ..S V=$P(^AUPNVTC(X,0),U,3)
  1.  ..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  ..I V>EDATE Q  ;after discharge
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)="CEF TRAN CODE CPT:  "_$$DATE^BGP2UTL(V)_"  ["_Y_"]  "_$P($$CPT^ICPTCOD(I,V),U,3)
  1.  ;now check rcis Referrals
  1.  S X=0 F  S X=$O(^BMCREF("D",P,X)) Q:X'=+X  D
  1.  .S I=$P($G(^BMCREF(X,0)),U,12)
  1.  .Q:I=""
  1.  .Q:'$D(^BMCTDXC(I))
  1.  .Q:$P(^BMCTDXC(I,0),U)'="CARDIOVASCULAR DISORDERS"
  1.  .S C=$P($G(^BMCREF(X,0)),U,13)
  1.  .Q:C=""
  1.  .Q:'$D(^BMCTSVC(C))
  1.  .S V=$P(^BMCTSVC(C,0),U)
  1.  .Q:'$$CPTC(V)
  1.  .S D=$P(^BMCREF(X,0),U)
  1.  .Q:$P(D,".")>EDATE
  1.  .Q:$P(D,".")<ADMDT
  1.  .S BGPC=BGPC+1,BGPY(BGPC)="RCIS REFERRAL:  "_$$DATE^BGP2UTL($P(^BMCREF(X,0),U))_"  ICD CAT: "_$P(^BMCTDXC(I,0),U)_"  CPT CAT: "_V
  1.  ;now check for new "assumptions"
  1.  ;ECHOCARDIOGRAM
  1.  S X=0 F  S X=$O(^AUPNVPRC("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVPRC(X,0))
  1.  .S I=$P($G(^AUPNVPRC(X,0)),U) Q:'I
  1.  .S Y=$P($$ICDOP^ICDCODE(I),U,2)
  1.  .S T="",T=$O(^ATXAX("B","BGP CMS ECHOCARDIOGRAM PROCS",0))
  1.  .I 'T W BGPBOMB
  1.  .I $$ICD^ATXCHK(I,T,0) D
  1.  ..S V=$P(^AUPNVPRC(X,0),U,3)
  1.  ..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  ..I V>EDATE Q  ;after discharge
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)="ECHOCARDIOGRAM PROCEDURE:  "_$$DATE^BGP2UTL(V)_"  ["_Y_"]  "_$$VAL^XBDIQ1(9000010.08,X,.04)
  1.  ;NUCLEAR MEDICINE
  1.  S X=0 F  S X=$O(^AUPNVPRC("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVPRC(X,0))
  1.  .S I=$P($G(^AUPNVPRC(X,0)),U) Q:'I
  1.  .S Y=$P($$ICDOP^ICDCODE(I),U,2)
  1.  .S T="",T=$O(^ATXAX("B","BGP CMS NUCLEAR MEDICINE PROCS",0))
  1.  .I 'T W BGPBOMB
  1.  .I $$ICD^ATXCHK(I,T,0) D
  1.  ..S V=$P(^AUPNVPRC(X,0),U,3)
  1.  ..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  ..I V>EDATE Q  ;after discharge
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)="NUCLEAR MEDICINE PROCEDURE:  "_$$DATE^BGP2UTL(V)_"  ["_Y_"]  "_$$VAL^XBDIQ1(9000010.08,X,.04)
  1.  ;CARDIAC CATH
  1.  S X=0 F  S X=$O(^AUPNVPRC("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVPRC(X,0))
  1.  .S I=$P($G(^AUPNVPRC(X,0)),U) Q:'I
  1.  .S Y=$P($$ICDOP^ICDCODE(I),U,2)
  1.  .S T="",T=$O(^ATXAX("B","BGP CMS CARDIAC CATH/LV PROCS",0))
  1.  .I 'T W BGPBOMB
  1.  .I $$ICD^ATXCHK(I,T,0) D
  1.  ..S V=$P(^AUPNVPRC(X,0),U,3)
  1.  ..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  ..I V>EDATE Q  ;after discharge
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)="CARDIAC CATHETERIZATION PROCEDURE:  "_$$DATE^BGP2UTL(V)_"  ["_Y_"]  "_$$VAL^XBDIQ1(9000010.08,X,.04)
  1.  Q
  1. CPTC(Z) ;
  1.  I Z="EVALUATION AND/OR MANAGEMENT" Q 1
  1.  I Z="NONSURGICAL PROCEDURES" Q 1
  1.  I Z="DIAGNOSTIC IMAGING" Q 1
  1.  Q 0
  1.  ;