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"","
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 AMI IND 30",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 SET H=0
+12 SET H=$ORDER(^AUPNVINP("AD",V,0))
Begin DoDot:2
+13 SET B=0
+14 IF 'H
QUIT
+15 IF $PIECE($PIECE(^AUPNVINP(H,0),U),".")>EDATE
QUIT
+16 IF $$AMA(H)
QUIT
+17 IF $$TRANS(H)
QUIT
+18 IF $$EXPIRED(H)
QUIT
+19 SET B=1
End DoDot:2
IF 'B
QUIT
+20 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
+21 ;got one visit
IF D
SET G=G+1
SET G($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))=V
End DoDot:1
+22 IF 'G
QUIT G
+23 SET D=$ORDER(G(0))
SET V=G(D)
SET H=$ORDER(^AUPNVINP("AD",V,0))
+24 QUIT 1_U_$ORDER(G(0))_U_V_U_$SELECT(H:$PIECE($PIECE(^AUPNVINP(H,0),U),"."),1:"")_U_H
READM(P,D,PV) ;EP
+1 SET ED=$$FMADD^XLFDT(D,7)
SET G=0
+2 SET X=0
SET V=0
FOR
SET X=$ORDER(^AUPNVSIT("AAH",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AAH",P,X,V))
IF V'=+V
QUIT
Begin DoDot:2
+4 IF PV=V
QUIT
+5 SET E=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+6 IF E<D
QUIT
+7 IF E>ED
QUIT
+8 SET G=1
End DoDot:2
End DoDot:1
+9 QUIT G
AMA(H) ;EP
+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
EXPIRED(H) ;EP
+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),".")
TRANS(H) ;EP
+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
BETAALG1(P,BGPD) ;EP - Beta Blocker allergy
+1 SET BGPC=0
BETAPOV ;
+1 KILL BGPG,BGPY
SET Y="BGPG("
SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$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=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+4 IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" ADR POV "_$PIECE(BGPG(X),U,2)_""
QUIT
+5 SET T=$ORDER(^ATXAX("B","BGP ADV EFF CARD RHYTH",0))
+6 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^BGP8UTL2(Z,T,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" ADR POV ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP8UTL2(Z),U,2)_"]"
QUIT
+7 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^BGP8UTL2(Z,T,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" ADR POV ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP8UTL2(Z),U,2)_"]"
QUIT
+8 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^BGP8UTL2(Z,T,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" ADR POV ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP8UTL2(Z),U,2)_"]"
QUIT
+9 QUIT
End DoDot:1
+10 IF BGPC>0
QUIT 1_U_BGPY(BGPC)
+11 KILL BGPG
SET BGPC=0
SET Y="BGPG("
SET X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(DFN))_"-"_$$FMTE^XLFDT(BGPD)
SET E=$$START1^APCLDF(X,Y)
+12 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+13 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+14 IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" ADR POV "_$PIECE(BGPG(X),U,2)_" "
End DoDot:1
+15 IF BGPC>0
QUIT 1_U_BGPY(BGPC)
+16 ;check problem list
+17 SET BGPC=0
+18 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+19 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+20 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^BGP8UTL2(I),U,2)
+21 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+22 IF $PIECE(^AUPNPROB(X,0),U,8)>BGPD
QUIT
+23 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+24 ;Q:$P(^AUPNPROB(X,0),U,12)="I"
+25 IF $$ICD^BGP8UTL2(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP8UTL2(I,T,9))
IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP8UTL($PIECE(^AUPNPROB(X,0),U,8))_" ADR Problem List "_Y_" "
QUIT
+26 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+27 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP ADR BETA BLOCKER",S))
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP8UTL($PIECE(^AUPNPROB(X,0),U,8))_" ADR Problem List "_S_" "
QUIT
+28 QUIT
End DoDot:1
+29 IF BGPC>0
QUIT 1_U_BGPY(BGPC)
+30 ;allergy tracking
+31 SET BGPC=0
+32 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+33 ;entered after end date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>BGPD
QUIT
+34 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+35 IF N["BETA BLOCK"
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP8UTL($PIECE(^GMR(120.8,X,0),U,4))_" ADR ALLERGY TRACKING "_N
End DoDot:1
+36 IF BGPC>0
QUIT 1_U_BGPY(BGPC)
+37 QUIT 0
