BGP8D729 ; IHS/CMI/LAB - measure AHR.A ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
;
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^BGP8D1(P,BDATE,EDATE) Q "" ;not 2 visits during report period
K ^TMP($J)
;check problem list for any not inactive/not deleted problems that have DOO prior to BDATE or date added prior to BDATE
I $$CHDPL(P,BDATE,EDATE) Q 1 ;if on problem list don't bother with checking all the visits
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
CHDPL(P,BDATE,EDATE) ;EP - is dx on problem list as not deleted/not inactive
;with DOO or date added prior to BDATE.
NEW T,T1,T2,T3,SN1,SN2,SN3,SN4,T4,T5,SN5,SN6,SN7,SN8
S T=$O(^ATXAX("B","BGP CHD DXS",0))
S T1=$O(^ATXAX("B","BGP CABG DXS",0))
S T2=$O(^ATXAX("B","BGP PCI DXS",0))
S SN1="PXRM BGP CABG"
S SN2="PXRM BGP PCI"
PL ;
NEW X,Y,I,S
S (X,Y,I)=0
F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) D
.Q:'$D(^AUPNPROB(X,0))
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.S Y=$P(^AUPNPROB(X,0),U)
.I BDATE,$P(^AUPNPROB(X,0),U,13)>BDATE Q ;if there is a doo and it is after report period skip
.I $P(^AUPNPROB(X,0),U,13)="",BDATE,$P(^AUPNPROB(X,0),U,8)>BDATE Q ;no doo, entered after report period, skip
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN1,S)) S I=1 Q
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN2,S)) S I=1 Q
.I $$ICD^BGP8UTL2(Y,T,9) S I=1 Q ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
.I $$ICD^BGP8UTL2(Y,T1,9) S I=1 Q ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
.I $$ICD^BGP8UTL2(Y,T2,9) S I=1 Q ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
.Q
Q I
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)=""
.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^BGP8UTL2(%,T,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)=""
.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^BGP8UTL2(%,T,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP8UTL2(%,T1,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP8UTL2(%,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^BGP8UTL2($P(^AUPNVPRC(Y,0),U,1),E,0) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP8UTL2($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^BGP8UTL2($P(^AUPNVCPT(Y,0),U,1),E,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP8UTL2($P(^AUPNVCPT(Y,0),U,1),F,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..;I $$ICD^BGP8UTL2($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^BGP8UTL2(I,E,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP8UTL2(I,F,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..;I $$ICD^BGP8UTL2(I,G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
.Q
I BGPCNT>MIN Q 1
Q ""
BGP8D729 ; IHS/CMI/LAB - measure AHR.A ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+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^BGP8D1(P,BDATE,EDATE)
QUIT ""
+5 KILL ^TMP($JOB)
+6 ;check problem list for any not inactive/not deleted problems that have DOO prior to BDATE or date added prior to BDATE
+7 ;if on problem list don't bother with checking all the visits
IF $$CHDPL(P,BDATE,EDATE)
QUIT 1
+8 ;first dx not prior to report period
IF '$$CHDV(P,$$DOB^AUPNPAT(P),$$FMADD^XLFDT(BDATE,-1),0,0)
QUIT ""
+9 ;GET CHD DIAGNOSES AND SET BY VISIT
+10 ;not two ever
IF '$$CHDV(P,$$DOB^AUPNPAT(P),EDATE,1,1)
QUIT ""
+11 QUIT 1
CHDPL(P,BDATE,EDATE) ;EP - is dx on problem list as not deleted/not inactive
+1 ;with DOO or date added prior to BDATE.
+2 NEW T,T1,T2,T3,SN1,SN2,SN3,SN4,T4,T5,SN5,SN6,SN7,SN8
+3 SET T=$ORDER(^ATXAX("B","BGP CHD DXS",0))
+4 SET T1=$ORDER(^ATXAX("B","BGP CABG DXS",0))
+5 SET T2=$ORDER(^ATXAX("B","BGP PCI DXS",0))
+6 SET SN1="PXRM BGP CABG"
+7 SET SN2="PXRM BGP PCI"
PL ;
+1 NEW X,Y,I,S
+2 SET (X,Y,I)=0
+3 FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+4 IF '$DATA(^AUPNPROB(X,0))
QUIT
+5 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+7 SET Y=$PIECE(^AUPNPROB(X,0),U)
+8 ;if there is a doo and it is after report period skip
IF BDATE
IF $PIECE(^AUPNPROB(X,0),U,13)>BDATE
QUIT
+9 ;no doo, entered after report period, skip
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF BDATE
IF $PIECE(^AUPNPROB(X,0),U,8)>BDATE
QUIT
+10 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+11 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,SN1,S))
SET I=1
QUIT
+12 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,SN2,S))
SET I=1
QUIT
+13 ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
IF $$ICD^BGP8UTL2(Y,T,9)
SET I=1
QUIT
+14 ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
IF $$ICD^BGP8UTL2(Y,T1,9)
SET I=1
QUIT
+15 ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
IF $$ICD^BGP8UTL2(Y,T2,9)
SET I=1
QUIT
+16 QUIT
End DoDot:1
+17 QUIT I
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 ;Q:"V"[$P(^AUPNVSIT(V,0),U,3)
+15 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+16 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
+17 SET %=$PIECE(^AUPNVPOV(Y,0),U)
+18 IF $$ICD^BGP8UTL2(%,T,9)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
End DoDot:2
End DoDot:1
+19 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 ;Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
+7 ;Q:"V"[$P(^AUPNVSIT(V,0),U,3)
+8 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+9 SET T1=$ORDER(^ATXAX("B","BGP PCI DXS",0))
+10 SET T2=$ORDER(^ATXAX("B","BGP CABG DXS",0))
+11 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
+12 SET %=$PIECE(^AUPNVPOV(Y,0),U)
+13 ;I $$ICD^BGP8UTL2(%,T,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
+14 IF $$ICD^BGP8UTL2(%,T1,9)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+15 IF $$ICD^BGP8UTL2(%,T2,9)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
End DoDot:2
+16 ;check for procedure in BGP CABG PROCS
+17 SET E=$ORDER(^ATXAX("B","BGP CABG PROCS",0))
+18 SET F=$ORDER(^ATXAX("B","BGP PCI CM PROCS",0))
+19 SET Y=0
FOR
SET Y=$ORDER(^AUPNVPRC("AD",V,Y))
IF Y'=+Y!(BGPCNT>MINPROC)
QUIT
Begin DoDot:2
+20 IF '$DATA(^AUPNVPRC(Y,0))
QUIT
+21 IF $$ICD^BGP8UTL2($PIECE(^AUPNVPRC(Y,0),U,1),E,0)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+22 IF $$ICD^BGP8UTL2($PIECE(^AUPNVPRC(Y,0),U,1),F,0)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
End DoDot:2
+23 ;now check cpts
+24 SET E=$ORDER(^ATXAX("B","BGP CABG CPTS",0))
+25 SET F=$ORDER(^ATXAX("B","BGP PCI CPTS",0))
+26 ;S G=$O(^ATXAX("B","BGP PTCA CPTS",0))
+27 SET Y=0
FOR
SET Y=$ORDER(^AUPNVCPT("AD",V,Y))
IF Y'=+Y!(BGPCNT>MINPROC)
QUIT
Begin DoDot:2
+28 IF '$DATA(^AUPNVCPT(Y,0))
QUIT
+29 IF $$ICD^BGP8UTL2($PIECE(^AUPNVCPT(Y,0),U,1),E,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+30 IF $$ICD^BGP8UTL2($PIECE(^AUPNVCPT(Y,0),U,1),F,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+31 ;I $$ICD^BGP8UTL2($P(^AUPNVCPT(Y,0),U,1),G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
End DoDot:2
+32 ;now check TRANS
+33 SET E=$ORDER(^ATXAX("B","BGP CABG CPTS",0))
+34 SET F=$ORDER(^ATXAX("B","BGP PCI CPTS",0))
+35 ;S G=$O(^ATXAX("B","BGP PTCA CPTS",0))
+36 SET Y=0
FOR
SET Y=$ORDER(^AUPNVTC("AD",V,Y))
IF Y'=+Y!(BGPCNT>MINPROC)
QUIT
Begin DoDot:2
+37 IF '$DATA(^AUPNVTC(Y,0))
QUIT
+38 SET I=$PIECE(^AUPNVTC(Y,0),U,7)
+39 IF I=""
QUIT
+40 IF $$ICD^BGP8UTL2(I,E,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+41 IF $$ICD^BGP8UTL2(I,F,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+42 ;I $$ICD^BGP8UTL2(I,G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
End DoDot:2
+43 QUIT
End DoDot:1
+44 IF BGPCNT>MIN
QUIT 1
+45 QUIT ""
