Routine: BGP4D87

BGP4D87 ; IHS/CMI/LAB - measure calc ; 01 Nov 2013  2:35 PM

 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114

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^BGP4UTL($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

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^BGP4D72(H)  ;ama

 ..Q:$$TRANS^BGP4D72(H)  ;transferred

 ..Q:$$EXPIRED^BGP4D72(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^BGP4UTL2(%,T,9) S D=1

 .I D D

 ..;skip the hospital admission if there is a dx of PALLITATIVE

 ..S (A,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(A)  I $D(^AUPNVPOV(Y,0)) S %=$$VALI^XBDIQ1(9000010.07,Y,.01) I $$ICD^BGP4UTL2(%,$O(^ATXAX("B","BGP PALLIATIVE CARE DXS",0)),9) S A=1

 ..Q:A

 ..;skip if there was a LVAD/heart transplant procedure adm date to discharge date

 ..S A=$$LASTPRC^BGP4UTL1(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^BGP4UTL1(P,"BGP CMS EJECTION FRACTION PROC",BDATE,EDATE)

 I BGPG Q 1_"^"_$P(BGPG,U,3)_"^"_$$DATE^BGP4UTL($P(BGPG,U,3))_"^"_"Proc "_$P(BGPG,U,2)_"^^"_9000010.08_"^"_$P(BGPG,U,5)_"^"_$P(^AUPNVPRC($P(BGPG,U,5),0),U,3)

 S BGPG=$$CPT^BGP4DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CMS EJECTION FRACTION CPTS",0)),6)

 I BGPG Q 1_"^"_$P(BGPG,U,2)_"^"_$$DATE^BGP4UTL($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^BGP4UTL2(P,ADMDATE,EDATE,"CARDIOVASCULAR DISORDERS","EVALUATION AND/OR MANAGEMENT;NON-SURGICAL PROCEDURES;DIAGNOSTIC IMAGING")

 I BGPG Q BGPG

 S BGPG=$$LASTPRC^BGP4UTL1(P,"BGP CMS ECHOCARDIOGRAM PROCS",BDATE,EDATE)

 I BGPG Q 1_"^"_$P(BGPG,U,3)_"^"_$$DATE^BGP4UTL($P(BGPG,U,3))_"^"_"Proc "_$P(BGPG,U,2)_"^^"_9000010.08_"^"_$P(BGPG,U,5)_"^"_$P(^AUPNVPRC($P(BGPG,U,5),0),U,3)

 S BGPG=$$LASTPRC^BGP4UTL1(P,"BGP CMS NUCLEAR MEDICINE PROCS",BDATE,EDATE)

 I BGPG Q 1_"^"_$P(BGPG,U,3)_"^"_$$DATE^BGP4UTL($P(BGPG,U,3))_"^"_"Proc "_$P(BGPG,U,2)_"^^"_9000010.08_"^"_$P(BGPG,U,5)_"^"_$P(^AUPNVPRC($P(BGPG,U,5),0),U,3)

 S BGPG=$$LASTPRC^BGP4UTL1(P,"BGP CMS CARDIAC CATH/LV PROCS",BDATE,EDATE)

 I BGPG Q 1_"^"_$P(BGPG,U,3)_"^"_$$DATE^BGP4UTL($P(BGPG,U,3))_"^"_"Proc "_$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^BGP4UTL($P(BGPX(1),U))_"^"_"Meas CEF"_"^"_$P(BGPX(1),U,2)_"^"_9000010.01_"^"_+$P(BGPX(1),U,4)_"^"_$P(BGPX(1),U,5)

 Q ""

BGP4D87   ; IHS/CMI/LAB - measure calc ; 01 Nov 2013  2:35 PM

 +1       ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114

 +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^BGP4UTL($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^BGP4D72(H)

                           QUIT

 +18      ;transferred

                       IF $$TRANS^BGP4D72(H)

                           QUIT

 +19      ;died

                       IF $$EXPIRED^BGP4D72(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^BGP4UTL2(%,T,9)

                               SET D=1

 +22               IF D

                       Begin DoDot:2

 +23      ;skip the hospital admission if there is a dx of PALLITATIVE

 +24                       SET (A,Y)=0

FOR

                               SET Y=$ORDER(^AUPNVPOV("AD",V,Y))

                               IF Y'=+Y!(A)

                                   QUIT

                               IF $DATA(^AUPNVPOV(Y,0))

                                   SET %=$$VALI^XBDIQ1(9000010.07,Y,.01)

                                   IF $$ICD^BGP4UTL2(%,$ORDER(^ATXAX("B","BGP PALLIATIVE CARE DXS",0)),9)

                                       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^BGP4UTL1(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^BGP4UTL1(P,"BGP CMS EJECTION FRACTION PROC",BDATE,EDATE)

 +6        IF BGPG

               QUIT 1_"^"_$PIECE(BGPG,U,3)_"^"_$$DATE^BGP4UTL($PIECE(BGPG,U,3))_"^"_"Proc "_$PIECE(BGPG,U,2)_"^^"_9000010.08_"^"_$PIECE(BGPG,U,5)_"^"_$PIECE(^AUPNVPRC($PIECE(BGPG,U,5),0),U,3)

 +7        SET BGPG=$$CPT^BGP4DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP CMS EJECTION FRACTION CPTS",0)),6)

 +8        IF BGPG

               QUIT 1_"^"_$PIECE(BGPG,U,2)_"^"_$$DATE^BGP4UTL($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^BGP4UTL2(P,ADMDATE,EDATE,"CARDIOVASCULAR DISORDERS","EVALUATION AND/OR MANAGEMENT;NON-SURGICAL PROCEDURES;DIAGNOSTIC IMAGING")

 +10       IF BGPG

               QUIT BGPG

 +11       SET BGPG=$$LASTPRC^BGP4UTL1(P,"BGP CMS ECHOCARDIOGRAM PROCS",BDATE,EDATE)

 +12       IF BGPG

               QUIT 1_"^"_$PIECE(BGPG,U,3)_"^"_$$DATE^BGP4UTL($PIECE(BGPG,U,3))_"^"_"Proc "_$PIECE(BGPG,U,2)_"^^"_9000010.08_"^"_$PIECE(BGPG,U,5)_"^"_$PIECE(^AUPNVPRC($PIECE(BGPG,U,5),0),U,3)

 +13       SET BGPG=$$LASTPRC^BGP4UTL1(P,"BGP CMS NUCLEAR MEDICINE PROCS",BDATE,EDATE)

 +14       IF BGPG

               QUIT 1_"^"_$PIECE(BGPG,U,3)_"^"_$$DATE^BGP4UTL($PIECE(BGPG,U,3))_"^"_"Proc "_$PIECE(BGPG,U,2)_"^^"_9000010.08_"^"_$PIECE(BGPG,U,5)_"^"_$PIECE(^AUPNVPRC($PIECE(BGPG,U,5),0),U,3)

 +15       SET BGPG=$$LASTPRC^BGP4UTL1(P,"BGP CMS CARDIAC CATH/LV PROCS",BDATE,EDATE)

 +16       IF BGPG

               QUIT 1_"^"_$PIECE(BGPG,U,3)_"^"_$$DATE^BGP4UTL($PIECE(BGPG,U,3))_"^"_"Proc "_$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^BGP4UTL($PIECE(BGPX(1),U))_"^"_"Meas CEF"_"^"_$PIECE(BGPX(1),U,2)_"^"_9000010.01_"^"_+$PIECE(BGPX(1),U,4)_"^"_$PIECE(BGPX(1),U,5)

 +6        QUIT ""

BGP4D87.m