BGP8D72.m

BGP8D72 ; IHS/CMI/LAB - measure 31 ;

 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

 ;

IHEDCHM ;EP

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0

 I BGPAGEB<18 S BGPSTOP=1 Q

 I BGPAGEB>75 S BGPSTOP=1 Q

 I 'BGPACTUP S BGPSTOP=1 Q

 S BGPAMI=$$AMIO(DFN,BGPBDATE,BGPEDATE) I '$P(BGPAMI,U) S BGPSTOP=1 Q

 I BGPACTUP S BGPD2=1

 I BGPACTCL S BGPD1=1

 I BGPRTYPE=3,'BGPD1 S BGPSTOP=1 Q

 S BGPLDL=$$LDL^BGP8D2(DFN,BGPBDATE,BGPEDATE,$S(BGPRTYPE=3:1,1:""))

 I $P(BGPLDL,U)=1 S BGPN1=1

 I $P(BGPLDL,U,3)]"",BGPRTYPE'=3 D

 .S V=$P(BGPLDL,U,3)

 .I V["CPT" S:V["3048F" BGPN2=1 S:V["G9271" BGPN2=1 Q

 .S V=+V

 .I 'V Q

 .I V]"",+V'>99 S BGPN2=1

 .I +V>99,+V<131 S BGPN3=1

 .I +V>130 S BGPN4=1

 I $P(BGPLDL,U,3)]"",BGPRTYPE=3 D

 .S V=$P(BGPLDL,U,3)

 .I V["CPT" S:V["3048F" BGPN2=1 S:V["G9271" BGPN2=1 Q

 .S V=+V

 .I 'V Q

 .I V]"",+V<100 S BGPN2=1

 S BGPXPHV=$P(BGPLDL,U,3)

 S V=$S(BGPRTYPE=3:"",1:"UP")_$S(BGPD1:",AC",1:"")_"|||"

 I $P(BGPLDL,U) S V=V_$$DATE^BGP8UTL($P(BGPLDL,U,2))_" LDL: "_$P(BGPLDL,U,3)

 S BGPVALUE=V

 K V,BGPAMI,BGPLDL,D

 K ^TMP($J)

 Q

CHOL(P,BDATE,EDATE) ;

 K BGPG

 S (Q,R,S,M,N,O,B,D,E,L,G)=""

 S R=$O(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0))

 S N=$O(^ATXAX("B","BGP TOTAL CHOLESTEROL LOINC",0))

 S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(G]"")  D

 .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(G]"")  D

 ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(G]"")  D

 ...Q:'$D(^AUPNVLAB(X,0))

 ...I R,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(R,21,"B",$P(^AUPNVLAB(X,0),U))) S G=(9999999-D)_"^CHOL"_"^"_$P(^AUPNVLAB(X,0),U,4) Q

 ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""

 ...I $$LOINC(J,N) S G=(9999999-D)_"^CHOL LOINC"_"^"_$P(^AUPNVLAB(X,0),U,4) Q

 ...Q

 I G]"" Q G

 S E=+$$CODEN^ICPTCOD(82465),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^CPT 82465"

 S E=+$$CODEN^ICPTCOD(82465),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^TRAN 82465"

 Q ""

LOINC(A,B) ;

 NEW %

 S %=$P($G(^LAB(95.3,A,9999999)),U,2)

 I %]"",$D(^ATXAX(B,21,"B",%)) Q 1

 S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)

 I $D(^ATXAX(B,21,"B",%)) Q 1

 Q ""

AMIO(P,BDATE,EDATE) ;

 NEW BGPG

 K BGPG

 S Y="BGPG("

 S X=P_"^LAST DX [BGP AMI DXS (HEDIS);DURING "_$$FMADD^XLFDT(BDATE,-365)_"-"_$$FMADD^XLFDT(BDATE,-1) S E=$$START1^APCLDF(X,Y)

 I $D(BGPG(1)) Q 1_U_"AMI DX"

 ;

 S BGPG=$$LASTPRC^BGP8UTL1(P,"BGP CABG PROCS",$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-1))

 I $P(BGPG,U) Q 1_U_"CABG PROC"

 ;

 S BGPG=$$CPT^BGP8DU(P,$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-1),$O(^ATXAX("B","BGP CABG CPTS",0)),6)

 I $P(BGPG,U) Q 1_U_"CABG CPT"

 S BGPG=$$TRAN^BGP8DU(P,$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-1),$O(^ATXAX("B","BGP CABG CPTS",0)),6)

 I $P(BGPG,U) Q 1_U_"CABG TRAN"

 S BGPG=$$LASTDX^BGP8UTL1(P,"BGP CABG DXS",$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-1))

 I $P(BGPG,U) Q 1_U_"CABG POV "_$P(BGPG,U,2)

 ;

 S BGPG=$$LASTPRC^BGP8UTL1(P,"BGP PCI CM PROCS",$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-1))

 I $P(BGPG,U) Q 1_U_"PCI PROC"

 ;

 S BGPG=$$CPT^BGP8DU(P,$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-1),$O(^ATXAX("B","BGP PCI CPTS",0)),6)

 I $P(BGPG,U) Q 1_U_"PCI CPT"

 S BGPG=$$TRAN^BGP8DU(P,$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-1),$O(^ATXAX("B","BGP PCI CPTS",0)),6)

 I $P(BGPG,U) Q 1_U_"PCI TRAN"

 S BGPG=$$LASTDX^BGP8UTL1(P,"BGP PCI DXS",$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-1))

 I $P(BGPG,U) Q 1_U_"PCI POV "_$P(BGPG,U,2)

 ;

 S BGPG(1)=$$LASTDX^BGP8UTL1(P,"BGP IVD DXS",BDATE,EDATE)

 S BGPG(2)=$$LASTDX^BGP8UTL1(P,"BGP IVD DXS",$$FMADD^XLFDT(BDATE,-365),BDATE)

 I $P(BGPG(1),U),$P(BGPG(2),U) Q 1_U_"IVD DXS"

 Q ""

AMI(P,BDATE,EDATE) ;

 ;

 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

 S T=$O(^ATXAX("B","BGP AMI DXS (HEDIS)",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:"AOSH"'[$P(^AUPNVSIT(V,0),U,7)

 .S H=0

 .I $P(^AUPNVSIT(V,0),U,7)="H" S H=$O(^AUPNVINP("AD",V,0)) D  Q:'B

 ..S B=0

 ..I 'H Q

 ..Q:$$AMA(H)  ;ama

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

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

 .I D 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

 ;

AMIH(P,BDATE,EDATE) ;

 ;look for any H with AMI 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 AMI IND 30",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"

 .S H=0

 .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(H)

 ..Q:$$TRANS(H)

 ..Q:$$EXPIRED(H)

 ..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^BGP8UTL2(%,T,9) S D=1

 .I D 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

READM(P,D,PV) ;EP

 S ED=$$FMADD^XLFDT(D,7),G=0

 S X=0,V=0 F  S X=$O(^AUPNVSIT("AAH",P,X)) Q:X'=+X  D

 .S V=0 F  S V=$O(^AUPNVSIT("AAH",P,X,V)) Q:V'=+V  D

 ..Q:PV=V

 ..S E=$P($P($G(^AUPNVSIT(V,0)),U),".")

 ..Q:E<D

 ..Q:E>ED

 ..S G=1

 Q G

AMA(H) ;EP

 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

EXPIRED(H) ;EP

 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),".")

TRANS(H) ;EP

 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

BETAALG1(P,BGPD) ;EP - Beta Blocker allergy

 S BGPC=0

BETAPOV ;

 K BGPG,BGPY S Y="BGPG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$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=$$VAL^XBDIQ1(9000010.07,Y,.04) S N=$$UP^XLFSTR(N)

 .I N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP8UTL($P(BGPG(X),U))_" ADR POV  "_$P(BGPG(X),U,2)_"" Q

 .S T=$O(^ATXAX("B","BGP ADV EFF CARD RHYTH",0))

 .S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^BGP8UTL2(Z,T,9) S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP8UTL($P(BGPG(X),U))_" ADR POV ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP8UTL2(Z),U,2)_"]" Q

 .S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^BGP8UTL2(Z,T,9) S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP8UTL($P(BGPG(X),U))_" ADR POV ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP8UTL2(Z),U,2)_"]" Q

 .S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^BGP8UTL2(Z,T,9) S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP8UTL($P(BGPG(X),U))_" ADR POV ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP8UTL2(Z),U,2)_"]" Q

 .Q

 I BGPC>0 Q 1_U_BGPY(BGPC)

 K BGPG S BGPC=0 S Y="BGPG(",X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;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=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)

 .I N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP8UTL($P(BGPG(X),U))_" ADR POV "_$P(BGPG(X),U,2)_"  "

 I BGPC>0 Q 1_U_BGPY(BGPC)

 ;check problem list

 S BGPC=0

 S T="",T=$O(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))

 S X=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X  D

 .S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($$ICDDX^BGP8UTL2(I),U,2)

 .S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)

 .Q:$P(^AUPNPROB(X,0),U,8)>BGPD

 .Q:$P(^AUPNPROB(X,0),U,12)="D"

 .;Q:$P(^AUPNPROB(X,0),U,12)="I"

 .I $$ICD^BGP8UTL2(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP8UTL2(I,T,9)),N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP8UTL($P(^AUPNPROB(X,0),U,8))_" ADR Problem List  "_Y_"  " Q

 .S S=$$VAL^XBDIQ1(9000011,X,80001)

 .I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP ADR BETA BLOCKER",S)) S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP8UTL($P(^AUPNPROB(X,0),U,8))_" ADR Problem List  "_S_"  " Q

 .Q

 I BGPC>0 Q 1_U_BGPY(BGPC)

 ;allergy tracking

 S BGPC=0

 S X=0 F  S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X  D

 .Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>BGPD  ;entered after end date

 .S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)

 .I N["BETA BLOCK" S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP8UTL($P(^GMR(120.8,X,0),U,4))_" ADR ALLERGY TRACKING "_N

 I BGPC>0 Q 1_U_BGPY(BGPC)

 Q 0

BGP8D72   ; IHS/CMI/LAB - measure 31 ;

 +1       ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

 +2       ;

IHEDCHM   ;EP

 +1        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0

 +2        IF BGPAGEB<18

               SET BGPSTOP=1

               QUIT 

 +3        IF BGPAGEB>75

               SET BGPSTOP=1

               QUIT 

 +4        IF 'BGPACTUP

               SET BGPSTOP=1

               QUIT 

 +5        SET BGPAMI=$$AMIO(DFN,BGPBDATE,BGPEDATE)

           IF '$PIECE(BGPAMI,U)

               SET BGPSTOP=1

               QUIT 

 +6        IF BGPACTUP

               SET BGPD2=1

 +7        IF BGPACTCL

               SET BGPD1=1

 +8        IF BGPRTYPE=3

               IF 'BGPD1

                   SET BGPSTOP=1

                   QUIT 

 +9        SET BGPLDL=$$LDL^BGP8D2(DFN,BGPBDATE,BGPEDATE,$SELECT(BGPRTYPE=3:1,1:""))

 +10       IF $PIECE(BGPLDL,U)=1

               SET BGPN1=1

 +11       IF $PIECE(BGPLDL,U,3)]""

               IF BGPRTYPE'=3

                   Begin DoDot:1

 +12                   SET V=$PIECE(BGPLDL,U,3)

 +13                   IF V["CPT"

                           IF V["3048F"

                               SET BGPN2=1

                           IF V["G9271"

                               SET BGPN2=1

                           QUIT 

 +14                   SET V=+V

 +15                   IF 'V

                           QUIT 

 +16                   IF V]""

                           IF +V'>99

                               SET BGPN2=1

 +17                   IF +V>99

                           IF +V<131

                               SET BGPN3=1

 +18                   IF +V>130

                           SET BGPN4=1

                   End DoDot:1

 +19       IF $PIECE(BGPLDL,U,3)]""

               IF BGPRTYPE=3

                   Begin DoDot:1

 +20                   SET V=$PIECE(BGPLDL,U,3)

 +21                   IF V["CPT"

                           IF V["3048F"

                               SET BGPN2=1

                           IF V["G9271"

                               SET BGPN2=1

                           QUIT 

 +22                   SET V=+V

 +23                   IF 'V

                           QUIT 

 +24                   IF V]""

                           IF +V<100

                               SET BGPN2=1

                   End DoDot:1

 +25       SET BGPXPHV=$PIECE(BGPLDL,U,3)

 +26       SET V=$SELECT(BGPRTYPE=3:"",1:"UP")_$SELECT(BGPD1:",AC",1:"")_"|||"

 +27       IF $PIECE(BGPLDL,U)

               SET V=V_$$DATE^BGP8UTL($PIECE(BGPLDL,U,2))_" LDL: "_$PIECE(BGPLDL,U,3)

 +28       SET BGPVALUE=V

 +29       KILL V,BGPAMI,BGPLDL,D

 +30       KILL ^TMP($JOB)

 +31       QUIT 

CHOL(P,BDATE,EDATE) ;

 +1        KILL BGPG

 +2        SET (Q,R,S,M,N,O,B,D,E,L,G)=""

 +3        SET R=$ORDER(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0))

 +4        SET N=$ORDER(^ATXAX("B","BGP TOTAL CHOLESTEROL LOINC",0))

 +5        SET B=9999999-BDATE

           SET E=9999999-EDATE

           SET D=E-1

           FOR 

               SET D=$ORDER(^AUPNVLAB("AE",P,D))

               IF D'=+D!(D>B)!(G]"")

                   QUIT 

               Begin DoDot:1

 +6                SET L=0

                   FOR 

                       SET L=$ORDER(^AUPNVLAB("AE",P,D,L))

                       IF L'=+L!(G]"")

                           QUIT 

                       Begin DoDot:2

 +7                        SET X=0

                           FOR 

                               SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))

                               IF X'=+X!(G]"")

                                   QUIT 

                               Begin DoDot:3

 +8                                IF '$DATA(^AUPNVLAB(X,0))

                                       QUIT 

 +9                                IF R

                                       IF $PIECE(^AUPNVLAB(X,0),U)

                                           IF $DATA(^ATXLAB(R,21,"B",$PIECE(^AUPNVLAB(X,0),U)))

                                               SET G=(9999999-D)_"^CHOL"_"^"_$PIECE(^AUPNVLAB(X,0),U,4)

                                               QUIT 

 +10                               SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)

                                   IF J=""

                                       QUIT 

 +11                               IF $$LOINC(J,N)

                                       SET G=(9999999-D)_"^CHOL LOINC"_"^"_$PIECE(^AUPNVLAB(X,0),U,4)

                                       QUIT 

 +12                               QUIT 

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +13       IF G]""

               QUIT G

 +14       SET E=+$$CODEN^ICPTCOD(82465)

           SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^CPT 82465"

 +15       SET E=+$$CODEN^ICPTCOD(82465)

           SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^TRAN 82465"

 +16       QUIT ""

LOINC(A,B) ;

 +1        NEW %

 +2        SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)

 +3        IF %]""

               IF $DATA(^ATXAX(B,21,"B",%))

                   QUIT 1

 +4        SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)

 +5        IF $DATA(^ATXAX(B,21,"B",%))

               QUIT 1

 +6        QUIT ""

AMIO(P,BDATE,EDATE) ;

 +1        NEW BGPG

 +2        KILL BGPG

 +3        SET Y="BGPG("

 +4        SET X=P_"^LAST DX [BGP AMI DXS (HEDIS);DURING "_$$FMADD^XLFDT(BDATE,-365)_"-"_$$FMADD^XLFDT(BDATE,-1)

           SET E=$$START1^APCLDF(X,Y)

 +5        IF $DATA(BGPG(1))

               QUIT 1_U_"AMI DX"

 +6       ;

 +7        SET BGPG=$$LASTPRC^BGP8UTL1(P,"BGP CABG PROCS",$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-1))

 +8        IF $PIECE(BGPG,U)

               QUIT 1_U_"CABG PROC"

 +9       ;

 +10       SET BGPG=$$CPT^BGP8DU(P,$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-1),$ORDER(^ATXAX("B","BGP CABG CPTS",0)),6)

 +11       IF $PIECE(BGPG,U)

               QUIT 1_U_"CABG CPT"

 +12       SET BGPG=$$TRAN^BGP8DU(P,$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-1),$ORDER(^ATXAX("B","BGP CABG CPTS",0)),6)

 +13       IF $PIECE(BGPG,U)

               QUIT 1_U_"CABG TRAN"

 +14       SET BGPG=$$LASTDX^BGP8UTL1(P,"BGP CABG DXS",$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-1))

 +15       IF $PIECE(BGPG,U)

               QUIT 1_U_"CABG POV "_$PIECE(BGPG,U,2)

 +16      ;

 +17       SET BGPG=$$LASTPRC^BGP8UTL1(P,"BGP PCI CM PROCS",$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-1))

 +18       IF $PIECE(BGPG,U)

               QUIT 1_U_"PCI PROC"

 +19      ;

 +20       SET BGPG=$$CPT^BGP8DU(P,$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-1),$ORDER(^ATXAX("B","BGP PCI CPTS",0)),6)

 +21       IF $PIECE(BGPG,U)

               QUIT 1_U_"PCI CPT"

 +22       SET BGPG=$$TRAN^BGP8DU(P,$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-1),$ORDER(^ATXAX("B","BGP PCI CPTS",0)),6)

 +23       IF $PIECE(BGPG,U)

               QUIT 1_U_"PCI TRAN"

 +24       SET BGPG=$$LASTDX^BGP8UTL1(P,"BGP PCI DXS",$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-1))

 +25       IF $PIECE(BGPG,U)

               QUIT 1_U_"PCI POV "_$PIECE(BGPG,U,2)

 +26      ;

 +27       SET BGPG(1)=$$LASTDX^BGP8UTL1(P,"BGP IVD DXS",BDATE,EDATE)

 +28       SET BGPG(2)=$$LASTDX^BGP8UTL1(P,"BGP IVD DXS",$$FMADD^XLFDT(BDATE,-365),BDATE)

 +29       IF $PIECE(BGPG(1),U)

               IF $PIECE(BGPG(2),U)

                   QUIT 1_U_"IVD DXS"

 +30       QUIT ""

AMI(P,BDATE,EDATE) ;

 +1       ;

 +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        IF '$DATA(^TMP($JOB,"A",1))

               QUIT 0

 +5        SET T=$ORDER(^ATXAX("B","BGP AMI DXS (HEDIS)",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 "AOSH"'[$PIECE(^AUPNVSIT(V,0),U,7)

                       QUIT 

 +11               SET H=0

 +12               IF $PIECE(^AUPNVSIT(V,0),U,7)="H"

                       SET H=$ORDER(^AUPNVINP("AD",V,0))

                       Begin DoDot:2

 +13                       SET B=0

 +14                       IF 'H

                               QUIT 

 +15      ;ama

                           IF $$AMA(H)

                               QUIT 

 +16      ;transferred

                           IF $$TRANS(H)

                               QUIT 

 +17      ;died

                           IF $$EXPIRED(H)

                               QUIT 

 +18                       SET B=1

                       End DoDot:2

                       IF 'B

                           QUIT 

 +19               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^BGP8UTL2(%,T,9)

                               SET D=1

 +20      ;got one visit

                   IF D

                       SET G=G+1

                       SET G($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))=V

               End DoDot:1

 +21       IF 'G

               QUIT G

 +22       SET D=$ORDER(G(0))

           SET V=G(D)

           SET H=$ORDER(^AUPNVINP("AD",V,0))

 +23       QUIT 1_U_$ORDER(G(0))_U_V_U_$SELECT(H:$PIECE($PIECE(^AUPNVINP(H,0),U),"."),1:"")_U_H

 +24      ;

AMIH(P,BDATE,EDATE) ;

 +1       ;look for any H with AMI discharge dx

 +2        KILL ^TMP($JOB,"A"),G

 +3        SET A="^TMP($J,""A"","