BGP0D87 ; IHS/CMI/LAB - measure calc ;
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
IHFL ;EP - heart failure/LVS
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
I 'BGPACTUP S BGPSTOP=1 Q
I 'BGPACTCL S BGPSTOP=1 Q ;must be active clinical
;I BGPAGEB<18 S BGPSTOP=1 Q ;18 and older
S BGPHHF=$$HFADM(DFN,BGPBDATE,BGPEDATE)
I 'BGPHHF S BGPSTOP=1 Q ;no hosp stay for heart failure
S BGPAD=$P(BGPHHF,U,2)
I $$AGE^AUPNPAT(DFN,BGPAD)<18 S BGPSTOP=1 Q ;less than 18 on admission date
S BGPD1=1
S BGPDD=$P(BGPHHF,U,4)
S BGPNV=$$LSV(DFN,$$FMADD^XLFDT(BGPDD,-365),BGPDD,BGPAD)
S BGPN1=+BGPNV
S BGPVALUE=$S(BGPD1:"AC",1:"")_"|||"_"Admission: "_$$DATE^BGP0UTL($P(BGPHHF,U,2))_" LVS: "_$S(BGPN1:$P(BGPNV,U,3)_" "_$P(BGPNV,U,4)_" "_$P(BGPNV,U,5),1:" NOT DOCUMENTED")
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPAD,BGPDD,BGPNV,BGPHHF
Q
HFADM(P,BDATE,EDATE) ;
;look for any H with HF discharge dx
K ^TMP($J,"A"),G
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 0 ;no HOSP
S T=$O(^ATXAX("B","BGP HEART FAILURE DXS",0))
S (BGPX,G,M,D,E)=0 F S BGPX=$O(^TMP($J,"A",BGPX)) Q:BGPX'=+BGPX S V=$P(^TMP($J,"A",BGPX),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:$P(^AUPNVSIT(V,0),U,7)'="H"
.;Q:$P(^AUPNVSIT(V,0),U,6)'=DUZ(2)
.;Q:"CV"[$P(^AUPNVSIT(V,0),U,3)
.S H=$O(^AUPNVINP("AD",V,0)) D Q:'B
..S B=0
..I 'H Q
..Q:$P($P(^AUPNVINP(H,0),U),".")>EDATE
..Q:$$AMA^BGP0D72(H) ;ama
..Q:$$TRANS^BGP0D72(H) ;transferred
..Q:$$EXPIRED^BGP0D72(H) ;died
..S B=1
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) I $D(^AUPNVPOV(Y,0)) S %=$P(^AUPNVPOV(Y,0),U) I $$ICD^ATXCHK(%,T,9) S D=1
.I D D
..;skip the hospital admission if there is a dx of V66.7
..S (A,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(A) I $D(^AUPNVPOV(Y,0)) S %=$$VAL^XBDIQ1(9000010.07,Y,.01) I %="V66.7" S A=1
..Q:A
..;skip if there was a LVAD/heart transplant procedure adm date to discharge date
..S A=$$LASTPRC^BGP0UTL1(P,"BGP CRS LVAD/HEART TRANS PROC",$P($P(^AUPNVSIT(V,0),U),"."),$P($P(^AUPNVINP(H,0),U),"."))
..I A Q ;has procedure type
..S G=G+1,G($P($P(^AUPNVSIT(V,0),U),"."))=V ;got one visit
I 'G Q G
S D=$O(G(0)),V=G(D),H=$O(^AUPNVINP("AD",V,0))
Q 1_U_$O(G(0))_U_V_U_$S(H:$P($P(^AUPNVINP(H,0),U),"."),1:"")_U_H
;
LSV(P,BDATE,EDATE,ADMDATE) ;
NEW BGPG
S BGPG=""
S BGPG=$$CEFMEAS(P,BDATE,EDATE)
I BGPG Q BGPG
S BGPG=$$LASTPRC^BGP0UTL1(P,"BGP CMS EJECTION FRACTION PROC",BDATE,EDATE)
I BGPG Q 1_"^"_$P(BGPG,U,3)_"^"_$$DATE^BGP0UTL($P(BGPG,U,3))_"^"_"Procedure: "_$P(BGPG,U,2)_"^^"_9000010.08_"^"_$P(BGPG,U,5)_"^"_$P(^AUPNVPRC($P(BGPG,U,5),0),U,3)
S BGPG=$$CPT^BGP0DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CMS EJECTION FRACTION CPTS",0)),6)
I BGPG Q 1_"^"_$P(BGPG,U,2)_"^"_$$DATE^BGP0UTL($P(BGPG,U,2))_"^"_"CPT: "_$P(BGPG,U,3)_"^^"_9000010.18_"^"_$P(BGPG,U,4)_"^"_$P(^AUPNVCPT($P(BGPG,U,4),0),U,3)
S BGPG=$$RCIS^BGP0UTL2(P,ADMDATE,EDATE,"CARDIOVASCULAR DISORDERS","EVALUATION AND/OR MANAGEMENT;NON-SURGICAL PROCEDURES;DIAGNOSTIC IMAGING")
I BGPG Q BGPG
S BGPG=$$LASTPRC^BGP0UTL1(P,"BGP CMS ECHOCARDIOGRAM PROCS",BDATE,EDATE)
I BGPG Q 1_"^"_$P(BGPG,U,3)_"^"_$$DATE^BGP0UTL($P(BGPG,U,3))_"^"_"Procedure: "_$P(BGPG,U,2)_"^^"_9000010.08_"^"_$P(BGPG,U,5)_"^"_$P(^AUPNVPRC($P(BGPG,U,5),0),U,3)
S BGPG=$$LASTPRC^BGP0UTL1(P,"BGP CMS NUCLEAR MEDICINE PROCS",BDATE,EDATE)
I BGPG Q 1_"^"_$P(BGPG,U,3)_"^"_$$DATE^BGP0UTL($P(BGPG,U,3))_"^"_"Procedure: "_$P(BGPG,U,2)_"^^"_9000010.08_"^"_$P(BGPG,U,5)_"^"_$P(^AUPNVPRC($P(BGPG,U,5),0),U,3)
S BGPG=$$LASTPRC^BGP0UTL1(P,"BGP CMS CARDIAC CATH/LV PROCS",BDATE,EDATE)
I BGPG Q 1_"^"_$P(BGPG,U,3)_"^"_$$DATE^BGP0UTL($P(BGPG,U,3))_"^"_"Procedure: "_$P(BGPG,U,2)_"^^"_9000010.08_"^"_$P(BGPG,U,5)_"^"_$P(^AUPNVPRC($P(BGPG,U,5),0),U,3)
Q BGPG
;
CEFMEAS(P,BDATE,EDATE) ;
NEW %,X,Y,BGPX,E
K BGPX
S %="",Y="BGPX("
S X=P_"^LAST MEAS CEF;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I $D(BGPX(1)) Q 1_"^"_$P(BGPX(1),U)_"^"_$$DATE^BGP0UTL($P(BGPX(1),U))_"^"_"CEF Measurement"_"^"_$P(BGPX(1),U,2)_"^"_9000010.01_"^"_+$P(BGPX(1),U,4)_"^"_$P(BGPX(1),U,5)
Q ""
BGP0D87 ; IHS/CMI/LAB - measure calc ;
+1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
+2 ;
IHFL ;EP - heart failure/LVS
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+3 ;must be active clinical
IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+4 ;I BGPAGEB<18 S BGPSTOP=1 Q ;18 and older
+5 SET BGPHHF=$$HFADM(DFN,BGPBDATE,BGPEDATE)
+6 ;no hosp stay for heart failure
IF 'BGPHHF
SET BGPSTOP=1
QUIT
+7 SET BGPAD=$PIECE(BGPHHF,U,2)
+8 ;less than 18 on admission date
IF $$AGE^AUPNPAT(DFN,BGPAD)<18
SET BGPSTOP=1
QUIT
+9 SET BGPD1=1
+10 SET BGPDD=$PIECE(BGPHHF,U,4)
+11 SET BGPNV=$$LSV(DFN,$$FMADD^XLFDT(BGPDD,-365),BGPDD,BGPAD)
+12 SET BGPN1=+BGPNV
+13 SET BGPVALUE=$SELECT(BGPD1:"AC",1:"")_"|||"_"Admission: "_$$DATE^BGP0UTL($PIECE(BGPHHF,U,2))_" LVS: "_$SELECT(BGPN1:$PIECE(BGPNV,U,3)_" "_$PIECE(BGPNV,U,4)_" "_$PIECE(BGPNV,U,5),1:" NOT DOCUMENTED")
+14 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPAD,BGPDD,BGPNV,BGPHHF
+15 QUIT
HFADM(P,BDATE,EDATE) ;
+1 ;look for any H with HF discharge dx
+2 KILL ^TMP($JOB,"A"),G
+3 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+4 ;no HOSP
IF '$DATA(^TMP($JOB,"A",1))
QUIT 0
+5 SET T=$ORDER(^ATXAX("B","BGP HEART FAILURE DXS",0))
+6 SET (BGPX,G,M,D,E)=0
FOR
SET BGPX=$ORDER(^TMP($JOB,"A",BGPX))
IF BGPX'=+BGPX
QUIT
SET V=$PIECE(^TMP($JOB,"A",BGPX),U,5)
Begin DoDot:1
+7 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+8 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+9 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 IF $PIECE(^AUPNVSIT(V,0),U,7)'="H"
QUIT
+11 ;Q:$P(^AUPNVSIT(V,0),U,6)'=DUZ(2)
+12 ;Q:"CV"[$P(^AUPNVSIT(V,0),U,3)
+13 SET H=$ORDER(^AUPNVINP("AD",V,0))
Begin DoDot:2
+14 SET B=0
+15 IF 'H
QUIT
+16 IF $PIECE($PIECE(^AUPNVINP(H,0),U),".")>EDATE
QUIT
+17 ;ama
IF $$AMA^BGP0D72(H)
QUIT
+18 ;transferred
IF $$TRANS^BGP0D72(H)
QUIT
+19 ;died
IF $$EXPIRED^BGP0D72(H)
QUIT
+20 SET B=1
End DoDot:2
IF 'B
QUIT
+21 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(D)
QUIT
IF $DATA(^AUPNVPOV(Y,0))
SET %=$PIECE(^AUPNVPOV(Y,0),U)
IF $$ICD^ATXCHK(%,T,9)
SET D=1
+22 IF D
Begin DoDot:2
+23 ;skip the hospital admission if there is a dx of V66.7
+24 SET (A,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(A)
QUIT
IF $DATA(^AUPNVPOV(Y,0))
SET %=$$VAL^XBDIQ1(9000010.07,Y,.01)
IF %="V66.7"
SET A=1
+25 IF A
QUIT
+26 ;skip if there was a LVAD/heart transplant procedure adm date to discharge date
+27 SET A=$$LASTPRC^BGP0UTL1(P,"BGP CRS LVAD/HEART TRANS PROC",$PIECE($PIECE(^AUPNVSIT(V,0),U),"."),$PIECE($PIECE(^AUPNVINP(H,0),U),"."))
+28 ;has procedure type
IF A
QUIT
+29 ;got one visit
SET G=G+1
SET G($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))=V
End DoDot:2
End DoDot:1
+30 IF 'G
QUIT G
+31 SET D=$ORDER(G(0))
SET V=G(D)
SET H=$ORDER(^AUPNVINP("AD",V,0))
+32 QUIT 1_U_$ORDER(G(0))_U_V_U_$SELECT(H:$PIECE($PIECE(^AUPNVINP(H,0),U),"."),1:"")_U_H
+33 ;
LSV(P,BDATE,EDATE,ADMDATE) ;
+1 NEW BGPG
+2 SET BGPG=""
+3 SET BGPG=$$CEFMEAS(P,BDATE,EDATE)
+4 IF BGPG
QUIT BGPG
+5 SET BGPG=$$LASTPRC^BGP0UTL1(P,"BGP CMS EJECTION FRACTION PROC",BDATE,EDATE)
+6 IF BGPG
QUIT 1_"^"_$PIECE(BGPG,U,3)_"^"_$$DATE^BGP0UTL($PIECE(BGPG,U,3))_"^"_"Procedure: "_$PIECE(BGPG,U,2)_"^^"_9000010.08_"^"_$PIECE(BGPG,U,5)_"^"_$PIECE(^AUPNVPRC($PIECE(BGPG,U,5),0),U,3)
+7 SET BGPG=$$CPT^BGP0DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP CMS EJECTION FRACTION CPTS",0)),6)
+8 IF BGPG
QUIT 1_"^"_$PIECE(BGPG,U,2)_"^"_$$DATE^BGP0UTL($PIECE(BGPG,U,2))_"^"_"CPT: "_$PIECE(BGPG,U,3)_"^^"_9000010.18_"^"_$PIECE(BGPG,U,4)_"^"_$PIECE(^AUPNVCPT($PIECE(BGPG,U,4),0),U,3)
+9 SET BGPG=$$RCIS^BGP0UTL2(P,ADMDATE,EDATE,"CARDIOVASCULAR DISORDERS","EVALUATION AND/OR MANAGEMENT;NON-SURGICAL PROCEDURES;DIAGNOSTIC IMAGING")
+10 IF BGPG
QUIT BGPG
+11 SET BGPG=$$LASTPRC^BGP0UTL1(P,"BGP CMS ECHOCARDIOGRAM PROCS",BDATE,EDATE)
+12 IF BGPG
QUIT 1_"^"_$PIECE(BGPG,U,3)_"^"_$$DATE^BGP0UTL($PIECE(BGPG,U,3))_"^"_"Procedure: "_$PIECE(BGPG,U,2)_"^^"_9000010.08_"^"_$PIECE(BGPG,U,5)_"^"_$PIECE(^AUPNVPRC($PIECE(BGPG,U,5),0),U,3)
+13 SET BGPG=$$LASTPRC^BGP0UTL1(P,"BGP CMS NUCLEAR MEDICINE PROCS",BDATE,EDATE)
+14 IF BGPG
QUIT 1_"^"_$PIECE(BGPG,U,3)_"^"_$$DATE^BGP0UTL($PIECE(BGPG,U,3))_"^"_"Procedure: "_$PIECE(BGPG,U,2)_"^^"_9000010.08_"^"_$PIECE(BGPG,U,5)_"^"_$PIECE(^AUPNVPRC($PIECE(BGPG,U,5),0),U,3)
+15 SET BGPG=$$LASTPRC^BGP0UTL1(P,"BGP CMS CARDIAC CATH/LV PROCS",BDATE,EDATE)
+16 IF BGPG
QUIT 1_"^"_$PIECE(BGPG,U,3)_"^"_$$DATE^BGP0UTL($PIECE(BGPG,U,3))_"^"_"Procedure: "_$PIECE(BGPG,U,2)_"^^"_9000010.08_"^"_$PIECE(BGPG,U,5)_"^"_$PIECE(^AUPNVPRC($PIECE(BGPG,U,5),0),U,3)
+17 QUIT BGPG
+18 ;
CEFMEAS(P,BDATE,EDATE) ;
+1 NEW %,X,Y,BGPX,E
+2 KILL BGPX
+3 SET %=""
SET Y="BGPX("
+4 SET X=P_"^LAST MEAS CEF;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+5 IF $DATA(BGPX(1))
QUIT 1_"^"_$PIECE(BGPX(1),U)_"^"_$$DATE^BGP0UTL($PIECE(BGPX(1),U))_"^"_"CEF Measurement"_"^"_$PIECE(BGPX(1),U,2)_"^"_9000010.01_"^"_+$PIECE(BGPX(1),U,4)_"^"_$PIECE(BGPX(1),U,5)
+6 QUIT ""
