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