BGP5C2 ; IHS/CMI/LAB - calc CMS indicators 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^BGP5UTL($P($P(BGPVSIT0,U),"."))_"-"_$$DATE^BGP5UTL($$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"
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("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$P(^DPT(DFN,0),U),DFN,BGPVSIT))
S ^XTMP("BGP5C1",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("BGP5C1",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^BGP5UTL($P($P(BGPVSIT0,U),"."))_"-"_$$DATE^BGP5UTL($$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("BGP5C1",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("BGP5C1",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("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,1,"Other Discharge POVs:",C)=I,$E(^(C),9)=N
.Q
EF ;
S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,2,"Ejection Fraction?")=""
K BGPDATA
D LVF(DFN,DT,.BGPDATA)
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,2,"Ejection Fraction?",X)=BGPDATA(X)
.Q
LVSD ;
S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,3,"LVSD?")=""
K BGPDATA
D LVSD1(DFN,DT,.BGPDATA)
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,3,"LVSD?",X)=BGPDATA(X)
.Q
ACEIALG ;
S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,4,"ACEI or ARB Allergy?")=""
K BGPDATA
D ACEIALG1^BGP5C11(DFN,$$DSCH(BGPVINP),.BGPDATA) ;return text of ACEI allergy if found
I $D(BGPDATA) S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,4,"ACEI or ARB Allergy?")=""
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,4,"ACEI or ARB Allergy?",X)=BGPDATA(X)
ACEICONT ;
S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,5,"Other ACEI or ARB Exclusion?")=""
K BGPDATA
D ACEICON1^BGP5C11(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),BGPVSIT,.BGPDATA)
I $D(BGPDATA) S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,5,"Other ACEI or ARB Exclusion?")=""
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,5,"Other ACEI or ARB Exclusion?",X)=BGPDATA(X)
ACEIRX ;
S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,6,"ACEI or ARB Rx Status?")=""
K BGPDATA
D ACEIRX1^BGP5C11(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPDATA)
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,6,"ACEI or ARB Rx Status?",X)=BGPDATA(X)
D EN^BGP5C12
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^BGP5UTL($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^BGP5UTL(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(^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^BGP5UTL(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^BGP5UTL($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^BGP5UTL(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^BGP5UTL($P(BGPG(X),U))_" value: "_N
.Q
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
BGP5C2 ; IHS/CMI/LAB - calc CMS indicators 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^BGP5UTL($PIECE($PIECE(BGPVSIT0,U),"."))_"-"_$$DATE^BGP5UTL($$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 SET Z=$$VAL^XBDIQ1(9000010.02,BGPVINP,.06)
+9 SET $PIECE(BGPX,U,7)=Z
+10 IF $$TRANS(BGPVINP)
IF 'BGPSKIP
SET BGPX="*"_BGPX
SET BGPSKIP=1
SET BGPZ(2)="transferred out"
+11 IF $$DSCH(BGPVINP)=$PIECE($PIECE(BGPVSIT,U),".")
IF 'BGPSKIP
SET BGPX="*"_BGPX
SET BGPSKIP=1
SET BGPZ(3)="discharged on date of arrival"
+12 ;patient expired on any day other than day of arrival
IF $$EXPIRED(BGPVINP)
IF 'BGPSKIP
SET BGPX="*"_BGPX
SET BGPSKIP=1
SET BGPZ(4)="deceased"
+13 IF $$AMA(BGPVINP)
IF 'BGPSKIP
SET BGPX="*"_BGPX
SET BGPSKIP=1
SET BGPZ(5)="left AMA on day other than arrival date"
+14 SET Z=$$VAL^XBDIQ1(9000010.02,BGPVINP,.07)
+15 SET $PIECE(BGPX,U,8)=Z
+16 IF $DATA(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT))
QUIT
+17 ;a hit on list 1
SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT)=BGPX
+18 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)
+19 IF $DATA(BGPZ1)
SET BGPZ1="Exclusions: "_BGPZ1
SET $PIECE(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT),U,12)=BGPZ1
+20 SET BGPCOUNT("L1",BGPIND)=$GET(BGPCOUNT("L1",BGPIND))+1
+21 ;set up second list after applying exclusions
+22 IF BGPSKIP
QUIT
+23 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),"."))
+24 SET $PIECE(BGPX,U,5)=$$DATE^BGP5UTL($PIECE($PIECE(BGPVSIT0,U),"."))_"-"_$$DATE^BGP5UTL($$DSCH(BGPVINP))
+25 SET $PIECE(BGPX,U,6)=$$PRIMPOV^APCLV(BGPVSIT,"C")_" "_$$PRIMPOV^APCLV(BGPVSIT,"N")
+26 SET $PIECE(BGPX,U,7)=$$VAL^XBDIQ1(9000010.02,BGPVINP,.06)
+27 SET $PIECE(BGPX,U,8)=$$VAL^XBDIQ1(9000010.02,BGPVINP,.07)
+28 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT)=BGPX
+29 SET BGPCOUNT("L2",BGPIND)=$GET(BGPCOUNT("L2",BGPIND))+1
+30 ;get other povs
+31 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,1,"Other Discharge POVs:")=""
+32 SET (X,C)=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",BGPVSIT,X))
IF X'=+X
QUIT
Begin DoDot:1
+33 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+34 IF $PIECE(^AUPNVPOV(X,0),U,12)="P"
QUIT
+35 SET I=$PIECE(^AUPNVPOV(X,0),U)
SET I=$PIECE($$ICDDX^ICDCODE(I),U,2)
+36 SET N=$$VAL^XBDIQ1(9000010.07,X,.04)
SET N=$$UP^XLFSTR(N)
+37 SET C=C+1
+38 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,1,"Other Discharge POVs:",C)=I
SET $EXTRACT(^(C),9)=N
+39 QUIT
End DoDot:1
EF ;
+1 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,2,"Ejection Fraction?")=""
+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("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,2,"Ejection Fraction?",X)=BGPDATA(X)
+6 QUIT
End DoDot:1
LVSD ;
+1 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,3,"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("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,3,"LVSD?",X)=BGPDATA(X)
+6 QUIT
End DoDot:1
ACEIALG ;
+1 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,4,"ACEI or ARB Allergy?")=""
+2 KILL BGPDATA
+3 ;return text of ACEI allergy if found
DO ACEIALG1^BGP5C11(DFN,$$DSCH(BGPVINP),.BGPDATA)
+4 IF $DATA(BGPDATA)
SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,4,"ACEI or ARB Allergy?")=""
+5 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,4,"ACEI or ARB Allergy?",X)=BGPDATA(X)
End DoDot:1
ACEICONT ;
+1 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,5,"Other ACEI or ARB Exclusion?")=""
+2 KILL BGPDATA
+3 DO ACEICON1^BGP5C11(DFN,$PIECE($PIECE(BGPVSIT0,U),"."),$$DSCH(BGPVINP),BGPVSIT,.BGPDATA)
+4 IF $DATA(BGPDATA)
SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,5,"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("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,5,"Other ACEI or ARB Exclusion?",X)=BGPDATA(X)
End DoDot:1
ACEIRX ;
+1 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,6,"ACEI or ARB Rx Status?")=""
+2 KILL BGPDATA
+3 DO ACEIRX1^BGP5C11(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("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,6,"ACEI or ARB Rx Status?",X)=BGPDATA(X)
End DoDot:1
+6 DO EN^BGP5C12
+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^BGP5UTL($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^BGP5UTL(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(^AUPNVPRC(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^BGP5UTL(V)_" ["_Y_"] "_$PIECE($$CPT^ICPTCOD(I),U,3)
End DoDot:2
End DoDot:1
+11 ;now check rcis referrals
+12 SET X=0
FOR
SET X=$ORDER(^BMCREF("D",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+13 SET I=$PIECE($GET(^BMCREF(X,0)),U,12)
+14 IF I=""
QUIT
+15 IF '$DATA(^BMCTDXC(I))
QUIT
+16 IF $PIECE(^BMCTDXC(I,0),U)'="CARDIOVASCULAR DISORDERS"
QUIT
+17 SET C=$PIECE($GET(^BMCREF(X,0)),U,13)
+18 IF C=""
QUIT
+19 IF '$DATA(^BMCTSVC(C))
QUIT
+20 SET V=$PIECE(^BMCTSVC(C,0),U)
+21 IF '$$CPTC(V)
QUIT
+22 SET BGPC=BGPC+1
SET BGPY(BGPC)="RCIS REFERRAL: "_$$DATE^BGP5UTL($PIECE(^BMCREF(X,0),U))_" ICD CAT: "_$PIECE(^BMCTDXC(I,0),U)_" CPT CAT: "_V
End DoDot:1
+23 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^BGP5UTL(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^BGP5UTL($PIECE(BGPG(X),U))_" value: "_N
+20 QUIT
End DoDot:1
+21 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
