BGP4D729 ; IHS/CMI/LAB - measure AHR.A ;
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
;
CHD(P,BDATE,EDATE) ;EP
;first dx prior to report period
;at least 2 visits during report period
;at least 2 Chd dxs ever
I '$$V2^BGP4D1(P,BDATE,EDATE) Q "" ;not 2 visits during report period
K ^TMP($J)
I '$$CHDV(P,$$DOB^AUPNPAT(P),$$FMADD^XLFDT(BDATE,-1),0,0) Q "" ;first dx not prior to report period
;GET CHD DIAGNOSES AND SET BY VISIT
I '$$CHDV(P,$$DOB^AUPNPAT(P),EDATE,1,1) Q "" ;not two ever
Q 1
CHDV(P,BDATE,EDATE,MIN,MINPROC) ;EP
NEW A,B,E,T,X,G,V,Y,%,G,F,BGPG,BGPCNT,T1,BGPALL
K BGPALL
S BGPCNT=0
K ^TMP($J,"A")
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 ""
S T=$O(^ATXAX("B","BGP CHD DXS",0))
I 'T G CHDP
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(BGPCNT>MIN) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
.Q:"V"[$P(^AUPNVSIT(V,0),U,3)
.Q:$P(^AUPNVSIT(V,0),U,6)=""
.I $G(BGPMFITI),'$D(^ATXAX(BGPMFITI,21,"B",$P(^AUPNVSIT(V,0),U,6))) Q
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MIN) I $D(^AUPNVPOV(Y,0)) D
..S %=$P(^AUPNVPOV(Y,0),U)
..I $$ICD^BGP4UTL2(%,T,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..;I $$ICD^BGP4UTL2(%,T1,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..;I $$ICD^BGP4UTL2(%,T2,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
I BGPCNT>MIN Q 1
CHDP ;NOW CHECK FOR MINPROC
;S BGPCNT=0
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(BGPCNT>MIN) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
.Q:"V"[$P(^AUPNVSIT(V,0),U,3)
.Q:$P(^AUPNVSIT(V,0),U,6)=""
.I $G(BGPMFITI),'$D(^ATXAX(BGPMFITI,21,"B",$P(^AUPNVSIT(V,0),U,6))) Q
.S T1=$O(^ATXAX("B","BGP PCI DXS",0))
.S T2=$O(^ATXAX("B","BGP CABG DXS",0))
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MINPROC) I $D(^AUPNVPOV(Y,0)) D
..S %=$P(^AUPNVPOV(Y,0),U)
..;I $$ICD^BGP4UTL2(%,T,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP4UTL2(%,T1,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP4UTL2(%,T2,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
.;check for procedure in BGP CABG PROCS
.S E=$O(^ATXAX("B","BGP CABG PROCS",0))
.S F=$O(^ATXAX("B","BGP PCI CM PROCS",0))
.S Y=0 F S Y=$O(^AUPNVPRC("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MINPROC) D
..Q:'$D(^AUPNVPRC(Y,0))
..I $$ICD^BGP4UTL2($P(^AUPNVPRC(Y,0),U,1),E,0) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP4UTL2($P(^AUPNVPRC(Y,0),U,1),F,0) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1
.;now check cpts
.S E=$O(^ATXAX("B","BGP CABG CPTS",0))
.S F=$O(^ATXAX("B","BGP PCI CPTS",0))
.;S G=$O(^ATXAX("B","BGP PTCA CPTS",0))
.S Y=0 F S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MINPROC) D
..Q:'$D(^AUPNVCPT(Y,0))
..I $$ICD^BGP4UTL2($P(^AUPNVCPT(Y,0),U,1),E,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP4UTL2($P(^AUPNVCPT(Y,0),U,1),F,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..;I $$ICD^BGP4UTL2($P(^AUPNVCPT(Y,0),U,1),G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
.;now check TRANS
.S E=$O(^ATXAX("B","BGP CABG CPTS",0))
.S F=$O(^ATXAX("B","BGP PCI CPTS",0))
.;S G=$O(^ATXAX("B","BGP PTCA CPTS",0))
.S Y=0 F S Y=$O(^AUPNVTC("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MINPROC) D
..Q:'$D(^AUPNVTC(Y,0))
..S I=$P(^AUPNVTC(Y,0),U,7)
..Q:I=""
..I $$ICD^BGP4UTL2(I,E,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP4UTL2(I,F,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..;I $$ICD^BGP4UTL2(I,G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
.Q
I BGPCNT>MIN Q 1
Q ""
IHDCCVD(P,BDATE,EDATE) ;EP
;first dx prior to report period
;at least 2 visits during report period
;at least 2 ihd dxs ever
I '$$V2^BGP4D1(P,BDATE,EDATE) Q "" ;not 2 visits during report period
K ^TMP($J)
I '$$FIRSTIHD(P,EDATE) Q "" ;first dx not prior to report period
I '$$V2IHD(P,$$DOB^AUPNPAT(P),EDATE) Q "" ;at least 2 IHD dxs ever
Q 1
FIRSTIHD(P,EDATE) ;EP
I $G(P)="" Q ""
NEW BGPG,Y,X,E
K BGPG
S Y="BGPG("
S X=P_"^FIRST DX [BGP IHD DXS (GPRA)" S E=$$START1^APCLDF(X,Y)
I '$D(BGPG(1)) Q ""
S X=$$FMDIFF^XLFDT(EDATE,$P(BGPG(1),U))
Q $S(X>365:1,1:"")
;
V2IHD(P,BDATE,EDATE) ;EP
I '$G(P) Q ""
I '$D(^AUPNVSIT("AC",P)) Q ""
NEW A,B,E,T,X,G,V,Y,%,G
K ^TMP($J,"A")
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 ""
S T=$O(^ATXAX("B","BGP IHD DXS (GPRA)",0))
I 'T Q ""
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G>2) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
.Q:"V"[$P(^AUPNVSIT(V,0),U,3)
.Q:$P(^AUPNVSIT(V,0),U,6)=""
.I $G(BGPMFITI),'$D(^ATXAX(BGPMFITI,21,"B",$P(^AUPNVSIT(V,0),U,6))) Q
.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
.Q:'D
.S G=G+1
.Q
K ^TMP($J,"A")
Q $S(G<2:"",1:1)
;
BGP4D729 ; IHS/CMI/LAB - measure AHR.A ;
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+2 ;
+3 ;
CHD(P,BDATE,EDATE) ;EP
+1 ;first dx prior to report period
+2 ;at least 2 visits during report period
+3 ;at least 2 Chd dxs ever
+4 ;not 2 visits during report period
IF '$$V2^BGP4D1(P,BDATE,EDATE)
QUIT ""
+5 KILL ^TMP($JOB)
+6 ;first dx not prior to report period
IF '$$CHDV(P,$$DOB^AUPNPAT(P),$$FMADD^XLFDT(BDATE,-1),0,0)
QUIT ""
+7 ;GET CHD DIAGNOSES AND SET BY VISIT
+8 ;not two ever
IF '$$CHDV(P,$$DOB^AUPNPAT(P),EDATE,1,1)
QUIT ""
+9 QUIT 1
CHDV(P,BDATE,EDATE,MIN,MINPROC) ;EP
+1 NEW A,B,E,T,X,G,V,Y,%,G,F,BGPG,BGPCNT,T1,BGPALL
+2 KILL BGPALL
+3 SET BGPCNT=0
+4 KILL ^TMP($JOB,"A")
+5 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+6 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+7 SET T=$ORDER(^ATXAX("B","BGP CHD DXS",0))
+8 IF 'T
GOTO CHDP
+9 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(BGPCNT>MIN)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+10 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+11 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+12 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+13 IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+14 IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+15 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+16 IF $GET(BGPMFITI)
IF '$DATA(^ATXAX(BGPMFITI,21,"B",$PIECE(^AUPNVSIT(V,0),U,6)))
QUIT
+17 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(BGPCNT>MIN)
QUIT
IF $DATA(^AUPNVPOV(Y,0))
Begin DoDot:2
+18 SET %=$PIECE(^AUPNVPOV(Y,0),U)
+19 IF $$ICD^BGP4UTL2(%,T,9)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+20 ;I $$ICD^BGP4UTL2(%,T1,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
+21 ;I $$ICD^BGP4UTL2(%,T2,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
End DoDot:2
End DoDot:1
+22 IF BGPCNT>MIN
QUIT 1
CHDP ;NOW CHECK FOR MINPROC
+1 ;S BGPCNT=0
+2 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(BGPCNT>MIN)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+3 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+4 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+5 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+6 IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+7 IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+8 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+9 IF $GET(BGPMFITI)
IF '$DATA(^ATXAX(BGPMFITI,21,"B",$PIECE(^AUPNVSIT(V,0),U,6)))
QUIT
+10 SET T1=$ORDER(^ATXAX("B","BGP PCI DXS",0))
+11 SET T2=$ORDER(^ATXAX("B","BGP CABG DXS",0))
+12 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(BGPCNT>MINPROC)
QUIT
IF $DATA(^AUPNVPOV(Y,0))
Begin DoDot:2
+13 SET %=$PIECE(^AUPNVPOV(Y,0),U)
+14 ;I $$ICD^BGP4UTL2(%,T,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
+15 IF $$ICD^BGP4UTL2(%,T1,9)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+16 IF $$ICD^BGP4UTL2(%,T2,9)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
End DoDot:2
+17 ;check for procedure in BGP CABG PROCS
+18 SET E=$ORDER(^ATXAX("B","BGP CABG PROCS",0))
+19 SET F=$ORDER(^ATXAX("B","BGP PCI CM PROCS",0))
+20 SET Y=0
FOR
SET Y=$ORDER(^AUPNVPRC("AD",V,Y))
IF Y'=+Y!(BGPCNT>MINPROC)
QUIT
Begin DoDot:2
+21 IF '$DATA(^AUPNVPRC(Y,0))
QUIT
+22 IF $$ICD^BGP4UTL2($PIECE(^AUPNVPRC(Y,0),U,1),E,0)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+23 IF $$ICD^BGP4UTL2($PIECE(^AUPNVPRC(Y,0),U,1),F,0)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
End DoDot:2
+24 ;now check cpts
+25 SET E=$ORDER(^ATXAX("B","BGP CABG CPTS",0))
+26 SET F=$ORDER(^ATXAX("B","BGP PCI CPTS",0))
+27 ;S G=$O(^ATXAX("B","BGP PTCA CPTS",0))
+28 SET Y=0
FOR
SET Y=$ORDER(^AUPNVCPT("AD",V,Y))
IF Y'=+Y!(BGPCNT>MINPROC)
QUIT
Begin DoDot:2
+29 IF '$DATA(^AUPNVCPT(Y,0))
QUIT
+30 IF $$ICD^BGP4UTL2($PIECE(^AUPNVCPT(Y,0),U,1),E,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+31 IF $$ICD^BGP4UTL2($PIECE(^AUPNVCPT(Y,0),U,1),F,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+32 ;I $$ICD^BGP4UTL2($P(^AUPNVCPT(Y,0),U,1),G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
End DoDot:2
+33 ;now check TRANS
+34 SET E=$ORDER(^ATXAX("B","BGP CABG CPTS",0))
+35 SET F=$ORDER(^ATXAX("B","BGP PCI CPTS",0))
+36 ;S G=$O(^ATXAX("B","BGP PTCA CPTS",0))
+37 SET Y=0
FOR
SET Y=$ORDER(^AUPNVTC("AD",V,Y))
IF Y'=+Y!(BGPCNT>MINPROC)
QUIT
Begin DoDot:2
+38 IF '$DATA(^AUPNVTC(Y,0))
QUIT
+39 SET I=$PIECE(^AUPNVTC(Y,0),U,7)
+40 IF I=""
QUIT
+41 IF $$ICD^BGP4UTL2(I,E,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+42 IF $$ICD^BGP4UTL2(I,F,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+43 ;I $$ICD^BGP4UTL2(I,G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
End DoDot:2
+44 QUIT
End DoDot:1
+45 IF BGPCNT>MIN
QUIT 1
+46 QUIT ""
IHDCCVD(P,BDATE,EDATE) ;EP
+1 ;first dx prior to report period
+2 ;at least 2 visits during report period
+3 ;at least 2 ihd dxs ever
+4 ;not 2 visits during report period
IF '$$V2^BGP4D1(P,BDATE,EDATE)
QUIT ""
+5 KILL ^TMP($JOB)
+6 ;first dx not prior to report period
IF '$$FIRSTIHD(P,EDATE)
QUIT ""
+7 ;at least 2 IHD dxs ever
IF '$$V2IHD(P,$$DOB^AUPNPAT(P),EDATE)
QUIT ""
+8 QUIT 1
FIRSTIHD(P,EDATE) ;EP
+1 IF $GET(P)=""
QUIT ""
+2 NEW BGPG,Y,X,E
+3 KILL BGPG
+4 SET Y="BGPG("
+5 SET X=P_"^FIRST DX [BGP IHD DXS (GPRA)"
SET E=$$START1^APCLDF(X,Y)
+6 IF '$DATA(BGPG(1))
QUIT ""
+7 SET X=$$FMDIFF^XLFDT(EDATE,$PIECE(BGPG(1),U))
+8 QUIT $SELECT(X>365:1,1:"")
+9 ;
V2IHD(P,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+3 NEW A,B,E,T,X,G,V,Y,%,G
+4 KILL ^TMP($JOB,"A")
+5 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+6 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+7 SET T=$ORDER(^ATXAX("B","BGP IHD DXS (GPRA)",0))
+8 IF 'T
QUIT ""
+9 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G>2)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+10 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+11 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+12 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+13 IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+14 IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+15 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+16 IF $GET(BGPMFITI)
IF '$DATA(^ATXAX(BGPMFITI,21,"B",$PIECE(^AUPNVSIT(V,0),U,6)))
QUIT
+17 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
+18 IF 'D
QUIT
+19 SET G=G+1
+20 QUIT
End DoDot:1
+21 KILL ^TMP($JOB,"A")
+22 QUIT $SELECT(G<2:"",1:1)
+23 ;
