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

BGP9C2X.m

Go to the documentation of this file. 
  1. BGP9C2X ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM ;
  1.  ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
  1.  ;
  1. HF ;
  1.  ;was there an AMI pov on this visit
  1.  Q:'$$HFDX(BGPVSIT)
  1.  S BGPX=$P(^DPT(DFN,0),U)_U_$$HRN^AUPNPAT(DFN,DUZ(2))_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,$P($P(BGPVSIT0,U),"."))
  1.  S $P(BGPX,U,5)=$$DATE^BGP9UTL($P($P(BGPVSIT0,U),"."))_"-"_$$DATE^BGP9UTL($$DSCH(BGPVINP))
  1.  S $P(BGPX,U,6)=$$PRIMPOV^APCLV(BGPVSIT,"C")_"  "_$$PRIMPOV^APCLV(BGPVSIT,"N")
  1.  S BGPSKIP=0 K BGPZ
  1.  I $$AGE^AUPNPAT(DFN,$P($P(BGPVSIT0,U),"."))<18 S BGPX="*"_BGPX,BGPSKIP=1,BGPZ(1)="under 18 yrs of age"
  1.  I $$LVADEX(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP)) S BGPX="*"_BGPX,BGPSKIP=1,BGPZ(1)="LVAD"
  1.  S Z=$$VAL^XBDIQ1(9000010.02,BGPVINP,.06)
  1.  S $P(BGPX,U,7)=Z
  1.  ;I $$TRANS(BGPVINP) S:'BGPSKIP BGPX="*"_BGPX S BGPSKIP=1,BGPZ(2)="transferred out"
  1.  ;I $$DSCH(BGPVINP)=$P($P(BGPVSIT,U),".") S:'BGPSKIP BGPX="*"_BGPX S BGPSKIP=1,BGPZ(3)="discharged on date of arrival"
  1.  ;I $$EXPIRED(BGPVINP) S:'BGPSKIP BGPX="*"_BGPX S BGPSKIP=1,BGPZ(4)="deceased" ;patient expired on any day other than day of arrival
  1.  ;I $$AMA(BGPVINP) S:'BGPSKIP BGPX="*"_BGPX S BGPSKIP=1,BGPZ(5)="left AMA on day other than arrival date"
  1.  S Z=$$VAL^XBDIQ1(9000010.02,BGPVINP,.07)
  1.  S $P(BGPX,U,8)=Z
  1.  Q:$D(^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$P(^DPT(DFN,0),U),DFN,BGPVSIT))
  1.  S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$P(^DPT(DFN,0),U),DFN,BGPVSIT)=BGPX  ;a hit on list 1
  1.  K BGPZ1 I $D(BGPZ) S X=0 F  S X=$O(BGPZ(X)) Q:X'=+X  S:$G(BGPZ1)]"" BGPZ1=BGPZ1_", " S BGPZ1=$G(BGPZ1)_BGPZ(X)
  1.  I $D(BGPZ1) S BGPZ1="Exclusions: "_BGPZ1 S $P(^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$P(^DPT(DFN,0),U),DFN,BGPVSIT),U,12)=BGPZ1
  1.  S BGPCOUNT("L1",BGPIND)=$G(BGPCOUNT("L1",BGPIND))+1
  1.  ;set up second list after applying exclusions
  1.  Q:BGPSKIP
  1.  S BGPX=$P(^DPT(DFN,0),U)_U_$$HRN^AUPNPAT(DFN,DUZ(2))_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,$P($P(BGPVSIT0,U),"."))
  1.  S $P(BGPX,U,5)=$$DATE^BGP9UTL($P($P(BGPVSIT0,U),"."))_"-"_$$DATE^BGP9UTL($$DSCH(BGPVINP))
  1.  S $P(BGPX,U,6)=$$PRIMPOV^APCLV(BGPVSIT,"C")_"  "_$$PRIMPOV^APCLV(BGPVSIT,"N")
  1.  S $P(BGPX,U,7)=$$VAL^XBDIQ1(9000010.02,BGPVINP,.06)
  1.  S $P(BGPX,U,8)=$$VAL^XBDIQ1(9000010.02,BGPVINP,.07)
  1.  S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT)=BGPX
  1.  S BGPCOUNT("L2",BGPIND)=$G(BGPCOUNT("L2",BGPIND))+1
  1.  ;get other povs
  1.  S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,1,"Other Discharge POVs:")=""
  1.  S (X,C)=0 F  S X=$O(^AUPNVPOV("AD",BGPVSIT,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVPOV(X,0))
  1.  .Q:$P(^AUPNVPOV(X,0),U,12)="P"
  1.  .S I=$P(^AUPNVPOV(X,0),U),I=$P($$ICDDX^ICDCODE(I),U,2)
  1.  .S N=$$VAL^XBDIQ1(9000010.07,X,.04),N=$$UP^XLFSTR(N)
  1.  .S C=C+1
  1.  .S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,1,"Other Discharge POVs:",C)=I,$E(^(C),9)=N
  1.  .Q
  1. LVAD ;
  1.  ;S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,2,"LVAD?")=""
  1.  ;K BGPDATA
  1.  ;D LVAD1(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPDATA)
  1.  ;S X=0 F  S X=$O(BGPDATA(X)) Q:X'=+X  D
  1.  ;.S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,2,"LVAD?",X)=BGPDATA(X)
  1.  ;.Q
  1. EF ;
  1.  S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,3,"LVS Evaluation?")=""
  1.  K BGPDATA
  1.  D LVF(DFN,DT,.BGPDATA)
  1.  S X=0 F  S X=$O(BGPDATA(X)) Q:X'=+X  D
  1.  .S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,3,"LVS Evaluation?",X)=BGPDATA(X)
  1.  .Q
  1. LVSD ;
  1.  S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,4,"LVSD?")=""
  1.  K BGPDATA
  1.  D LVSD1(DFN,DT,.BGPDATA)
  1.  S X=0 F  S X=$O(BGPDATA(X)) Q:X'=+X  D
  1.  .S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,4,"LVSD?",X)=BGPDATA(X)
  1.  .Q
  1. ACEIALG ;
  1.  S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,5,"ACEI or ARB Allergy?")=""
  1.  K BGPDATA
  1.  D ACEIALG1^BGP9C11(DFN,$$DSCH(BGPVINP),.BGPDATA) ;return text of ACEI allergy if found
  1.  I $D(BGPDATA) S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,5,"ACEI or ARB Allergy?")=""
  1.  S X=0 F  S X=$O(BGPDATA(X)) Q:X'=+X  D
  1.  .S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,5,"ACEI or ARB Allergy?",X)=BGPDATA(X)
  1. ACEICONT ;
  1.  S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,6,"Other ACEI or ARB Exclusion?")=""
  1.  K BGPDATA
  1.  D ACEICON1^BGP9C11(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),BGPVSIT,.BGPDATA)
  1.  I $D(BGPDATA) S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,6,"Other ACEI or ARB Exclusion?")=""
  1.  S X=0 F  S X=$O(BGPDATA(X)) Q:X'=+X  D
  1.  .S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,6,"Other ACEI or ARB Exclusion?",X)=BGPDATA(X)
  1. ACEIRX ;
  1.  S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,7,"ACEI or ARB Rx Status?")=""
  1.  K BGPDATA
  1.  D ACEIRX1^BGP9C11(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPDATA)
  1.  S X=0 F  S X=$O(BGPDATA(X)) Q:X'=+X  D
  1.  .S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,7,"ACEI or ARB Rx Status?",X)=BGPDATA(X)
  1. SMOKER ;EP
  1.  S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,8,"Smoker?")=""
  1.  K BGPASAAL
  1.  D SMOKER1^BGP9C12(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPASAAL)
  1.  S X=0 F  S X=$O(BGPASAAL(X)) Q:X'=+X  D
  1.  .S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,8,"Smoker?",X)=BGPASAAL(X)
  1. CESS ;
  1.  S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,9,"Smoking Cessation Advice/Counseling Status?")=""
  1.  K BGPASAAL
  1.  D CESS1^BGP9C12(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPASAAL)
  1.  S X=0 F  S X=$O(BGPASAAL(X)) Q:X'=+X  D
  1.  .S ^XTMP("BGP9C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,9,"Smoking Cessation Advice/Counseling Status?",X)=BGPASAAL(X)
  1.  D EN^BGP9C12
  1.  Q
  1. LVF(P,BGPD,BGPY) ;does patient have LVSD
  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(BGPD) 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.  .S N=$P(^AUPNVMSR(Y,0),U,4)
  1.  .S BGPC=BGPC+1,BGPY(BGPC)="MEASUREMENT CEF:  "_$$DATE^BGP9UTL($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>BGPD Q  ;after discharge
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)="CEF PROCEDURE:  "_$$DATE^BGP9UTL(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>BGPD Q  ;after discharge
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)="CEF CPT:  "_$$DATE^BGP9UTL(V)_"  ["_Y_"]  "_$P($$CPT^ICPTCOD(I),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>BGPD Q  ;after discharge
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)="CEF TRAN CODE CPT:  "_$$DATE^BGP9UTL(V)_"  ["_Y_"]  "_$P($$CPT^ICPTCOD(I),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 BGPC=BGPC+1,BGPY(BGPC)="RCIS REFERRAL:  "_$$DATE^BGP9UTL($P(^BMCREF(X,0),U))_"  ICD CAT: "_$P(^BMCTDXC(I,0),U)_"  CPT CAT: "_V
  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. LVSD1(P,BGPD,BGPY) ;
  1.  NEW X,Y,I,T,V,BGPC
  1.  S BGPC=0
  1.  S X=0 F  S X=$O(^AUPNVPOV("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVPOV(X,0))
  1.  .S I=$P($G(^AUPNVPOV(X,0)),U) Q:'I
  1.  .S Y=$P($$ICDDX^ICDCODE(I),U,2)
  1.  .S T=$O(^ATXAX("B","BGP CMS LVSD DXS",0))
  1.  .Q:'$$ICD^ATXCHK(I,T,9)
  1.  .S V=$P(^AUPNVPOV(X,0),U,3)
  1.  .S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  .I V>BGPD Q  ;after discharge
  1.  .S BGPC=BGPC+1,BGPY(BGPC)="POV:  "_$$DATE^BGP9UTL(V)_"  ["_Y_"]  "_$$VAL^XBDIQ1(9000010.07,X,.04)
  1.  .Q
  1.  ;now get all measurements CEF
  1.  K BGPG S Y="BGPG(",X=P_"^ALL MEAS CEF;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(DFN))_"-"_$$FMTE^XLFDT(BGPD) 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.  .S N=$P(^AUPNVMSR(Y,0),U,4)
  1.  .Q:N>39
  1.  .S BGPC=BGPC+1,BGPY(BGPC)="MEASUREMENT CEF:  "_$$DATE^BGP9UTL($P(BGPG(X),U))_"  value: "_N
  1.  .Q
  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.  .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>BGPD Q  ;after discharge
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)="CEF PROCEDURE:  "_$$DATE^BGP9UTL(V)_"  ["_Y_"]  "_$$VAL^XBDIQ1(9000010.08,X,.04)
  1.  ;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(^AUPNVPRC(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>BGPD Q  ;after discharge
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)="CEF CPT:  "_$$DATE^BGP9UTL(V)_"  ["_Y_"]  "_$P($$CPT^ICPTCOD(I),U,3)
  1.  Q
  1. AMA(H) ;
  1.  S X=$P(^AUPNVINP(H,0),U,6)
  1.  I X="" Q 0
  1.  S X=$P($G(^DG(405.1,X,"IHS")),U,1)
  1.  I X=3 Q 1
  1.  Q 0
  1. HFDX(V) ;
  1.  S C=$$PRIMPOV^APCLV(V,"I")
  1.  I C="" Q 0 ;no primary dx
  1.  S T=$O(^ATXAX("B","BGP CMS HEART FAILURE DXS",0))
  1.  I 'T Q
  1.  Q $$ICD^ATXCHK(C,T,9)
  1. EXPIRED(H) ;
  1.  S X=$P(^AUPNVINP(H,0),U,6)
  1.  I X="" Q 0
  1.  S X=$P($G(^DG(405.1,X,"IHS")),U,1)
  1.  I X=4!(X=5)!(X=6)!(X=7) Q 1
  1.  Q 0
  1. DSCH(H) ;
  1.  Q $P($P(^AUPNVINP(H,0),U),".")
  1. TRANSIN(H) ;
  1.  S X=$P(^AUPNVINP(H,0),U,7)
  1.  I X="" Q 0
  1.  S X=$P($G(^DG(405.1,X,"IHS")),U,1)
  1.  I X=2!(X=3) Q 1
  1.  Q 0
  1. TRANS(H) ;
  1.  S X=$P(^AUPNVINP(H,0),U,6)
  1.  I X="" Q 0
  1.  S X=$P($G(^DG(405.1,X,"IHS")),U,1)
  1.  I X=2 Q 1
  1.  Q 0
  1. LVADEX(P,BD,ED) ;
  1.  S X=$$LASTPRC^BGP9UTL1(P,"BGP LVAD/HEART TRANSPLANT PROC",BD,ED)
  1.  Q +X
  1.  ;
  1. LVAD1(P,BD,ED,BGPY) ;
  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 LVAD/HEART TRANSPLANT 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>ED Q  ;after discharge
  1.  ..I V<BD Q  ;before admission
  1.  ..S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP9UTL(V)_"  ["_Y_"]  "_$$VAL^XBDIQ1(9000010.08,X,.04)
  1.  ..Q
  1.  .Q
  1.  Q
  1. SMOKER1(P,BGPA,BGPD,BGPY) ;
  1.  K BGPY S BGPC=0
  1.  NEW BGPTOB,BGPDX,BGPDENT
  1.  S BGPTOB=$$TOBACCO^BGP9D7(P,$$FMADD^XLFDT(BGPA,-365),BGPA)
  1.  I BGPTOB["CURRENT SMOKER" S BGPC=BGPC+1,BGPY(BGPC)="Yes, Health Factor: "_$P(BGPTOB,U)_" on "_$P(BGPTOB,U,2)
  1.  S BGPDX=$$DX^BGP9D7(P,$$FMADD^XLFDT(BGPA,-365),BGPA)
  1.  I BGPDX]"",$P(BGPDX,U)'="305.13" S BGPC=BGPC+1,BGPY(BGPC)="Yes, Diagnosis: "_$P(BGPDX,U)_" on "_$$DATE^BGP9UTL($P(BGPDX,U,2))
  1.  S BGPDENT=$$DENT^BGP9D7(P,$$FMADD^XLFDT(BGPA,-365),BGPA)
  1.  I BGPDENT]"" S BGPC=BGPC+1,BGPY(BGPC)="Yes, "_$P(BGPDENT,U)_" on "_$$DATE^BGP9UTL($P(BGPDENT,U,2))
  1.  Q
  1. CESS1(P,BDATE,EDATE,BGPY) ;
  1.  K BGPY S BGPC=0
  1.  S Y="BGPALLED("
  1.  S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I $D(BGPALLED(1)) S %="" D
  1.  .S (X,D)=0,%="",T="" F  S X=$O(BGPALLED(X)) Q:X'=+X  D
  1.  ..S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
  1.  ..Q:'T
  1.  ..Q:'$D(^AUTTEDT(T,0))
  1.  ..S T=$P(^AUTTEDT(T,0),U,2)
  1.  ..I $P(T,"-")="TO" S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP9UTL($P(BGPALLED(X),U))_" Topic: "_T Q
  1.  ..I $P(T,"-",2)="TO" S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP9UTL($P(BGPALLED(X),U))_" Topic: "_T Q
  1.  ..I $P(T,"-",2)="SHS" S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP9UTL($P(BGPALLED(X),U))_" Topic: "_T Q
  1.  K ^TMP($J,"A")
  1.  S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
  1.  I '$D(^TMP($J,"A",1)) Q ""
  1.  S X=0,G="" F  S X=$O(^TMP($J,"A",X)) Q:X'=+X  S V=$P(^TMP($J,"A",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.  .S B=$$CLINIC^APCLV(V,"C")
  1.  .I B=94 S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP9UTL($P($P(^AUPNVSIT(V,0),U),"."))_" Clinic 94 visit" Q
  1.  .S Z=0 F  S Z=$O(^AUPNVDEN("AD",V,Z)) Q:Z'=+Z  S B=$P($G(^AUPNVDEN(Z,0)),U) I B S B=$P($G(^AUTTADA(B,0)),U) I B=1320 S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP9UTL($P($P(^AUPNVSIT(V,0),U),"."))_" ADA 1320"
  1.  .Q
  1.  I $D(BGPY) Q
  1.  ;now check all refusals of these education topics
  1.  S G="",X=0 F  S X=$O(^AUPNPREF("AA",P,9999999.09,X)) Q:X=""  D
  1.  .S D=0 F  S D=$O(^AUPNPREF("AA",P,9999999.09,X,D)) Q:D=""!(G]"")  D
  1.  ..S I=0 F  S I=$O(^AUPNPREF("AA",P,9999999.09,X,D,I)) Q:I'=+I!(G]"")  D
  1.  ...S Z=$P($G(^AUPNPREF(I,0)),U,3)
  1.  ...Q:Z=""
  1.  ...I Z<BDATE Q
  1.  ...I Z>EDATE Q
  1.  ...S Y=$P($G(^AUTTEDT(X,0)),U,2)
  1.  ...I $P(Y,"-")="TO"!($P(Y,"-",2)="TO")!($P(Y,"-",2)="SHS") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP9UTL(Z)_" refusal of Topic: "_Y
  1.  Q