Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP8D729

BGP8D729.m

Go to the documentation of this file. 
  1. BGP8D729 ; IHS/CMI/LAB - measure AHR.A ;
  1.  ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
  1.  ;
  1.  ;
  1. CHD(P,BDATE,EDATE) ;EP
  1.  ;first dx prior to report period
  1.  ;at least 2 visits during report period
  1.  ;at least 2 Chd dxs ever
  1.  I '$$V2^BGP8D1(P,BDATE,EDATE) Q ""  ;not 2 visits during report period
  1.  K ^TMP($J)
  1.  ;check problem list for any not inactive/not deleted problems that have DOO prior to BDATE or date added prior to BDATE
  1.  I $$CHDPL(P,BDATE,EDATE) Q 1  ;if on problem list don't bother with checking all the visits
  1.  I '$$CHDV(P,$$DOB^AUPNPAT(P),$$FMADD^XLFDT(BDATE,-1),0,0) Q ""  ;first dx not prior to report period
  1.  ;GET CHD DIAGNOSES AND SET BY VISIT
  1.  I '$$CHDV(P,$$DOB^AUPNPAT(P),EDATE,1,1) Q ""  ;not two ever
  1.  Q 1
  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.
  1.  NEW T,T1,T2,T3,SN1,SN2,SN3,SN4,T4,T5,SN5,SN6,SN7,SN8
  1.  S T=$O(^ATXAX("B","BGP CHD DXS",0))
  1.  S T1=$O(^ATXAX("B","BGP CABG DXS",0))
  1.  S T2=$O(^ATXAX("B","BGP PCI DXS",0))
  1.  S SN1="PXRM BGP CABG"
  1.  S SN2="PXRM BGP PCI"
  1. PL ;
  1.  NEW X,Y,I,S
  1.  S (X,Y,I)=0
  1.  F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I)  D
  1.  .Q:'$D(^AUPNPROB(X,0))
  1.  .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1.  .Q:$P(^AUPNPROB(X,0),U,12)="I"
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .I BDATE,$P(^AUPNPROB(X,0),U,13)>BDATE Q  ;if there is a doo and it is after report period skip
  1.  .I $P(^AUPNPROB(X,0),U,13)="",BDATE,$P(^AUPNPROB(X,0),U,8)>BDATE Q  ;no doo, entered after report period, skip
  1.  .S S=$$VAL^XBDIQ1(9000011,X,80001)
  1.  .I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN1,S)) S I=1 Q
  1.  .I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN2,S)) S I=1 Q
  1.  .I $$ICD^BGP8UTL2(Y,T,9) S I=1 Q  ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
  1.  .I $$ICD^BGP8UTL2(Y,T1,9) S I=1 Q  ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
  1.  .I $$ICD^BGP8UTL2(Y,T2,9) S I=1 Q  ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
  1.  .Q
  1.  Q I
  1. CHDV(P,BDATE,EDATE,MIN,MINPROC) ;EP
  1.  NEW A,B,E,T,X,G,V,Y,%,G,F,BGPG,BGPCNT,T1,BGPALL
  1.  K BGPALL
  1.  S BGPCNT=0
  1.  K ^TMP($J,"A")
  1.  S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
  1.  I '$D(^TMP($J,"A",1)) Q ""
  1.  S T=$O(^ATXAX("B","BGP CHD DXS",0))
  1.  I 'T G CHDP
  1.  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
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .;Q:"V"[$P(^AUPNVSIT(V,0),U,3)
  1.  .Q:$P(^AUPNVSIT(V,0),U,6)=""
  1.  .S (D,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MIN)  I $D(^AUPNVPOV(Y,0)) D
  1.  ..S %=$P(^AUPNVPOV(Y,0),U)
  1.  ..I $$ICD^BGP8UTL2(%,T,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  I BGPCNT>MIN Q 1
  1. CHDP ;NOW CHECK FOR MINPROC
  1.  ;S BGPCNT=0
  1.  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
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .;Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .;Q:"V"[$P(^AUPNVSIT(V,0),U,3)
  1.  .Q:$P(^AUPNVSIT(V,0),U,6)=""
  1.  .S T1=$O(^ATXAX("B","BGP PCI DXS",0))
  1.  .S T2=$O(^ATXAX("B","BGP CABG DXS",0))
  1.  .S (D,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MINPROC)  I $D(^AUPNVPOV(Y,0)) D
  1.  ..S %=$P(^AUPNVPOV(Y,0),U)
  1.  ..;I $$ICD^BGP8UTL2(%,T,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP8UTL2(%,T1,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP8UTL2(%,T2,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  .;check for procedure in BGP CABG PROCS
  1.  .S E=$O(^ATXAX("B","BGP CABG PROCS",0))
  1.  .S F=$O(^ATXAX("B","BGP PCI CM PROCS",0))
  1.  .S Y=0 F  S Y=$O(^AUPNVPRC("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MINPROC)  D
  1.  ..Q:'$D(^AUPNVPRC(Y,0))
  1.  ..I $$ICD^BGP8UTL2($P(^AUPNVPRC(Y,0),U,1),E,0) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP8UTL2($P(^AUPNVPRC(Y,0),U,1),F,0) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1
  1.  .;now check cpts
  1.  .S E=$O(^ATXAX("B","BGP CABG CPTS",0))
  1.  .S F=$O(^ATXAX("B","BGP PCI CPTS",0))
  1.  .;S G=$O(^ATXAX("B","BGP PTCA CPTS",0))
  1.  .S Y=0 F  S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MINPROC)  D
  1.  ..Q:'$D(^AUPNVCPT(Y,0))
  1.  ..I $$ICD^BGP8UTL2($P(^AUPNVCPT(Y,0),U,1),E,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP8UTL2($P(^AUPNVCPT(Y,0),U,1),F,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..;I $$ICD^BGP8UTL2($P(^AUPNVCPT(Y,0),U,1),G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  .;now check TRANS
  1.  .S E=$O(^ATXAX("B","BGP CABG CPTS",0))
  1.  .S F=$O(^ATXAX("B","BGP PCI CPTS",0))
  1.  .;S G=$O(^ATXAX("B","BGP PTCA CPTS",0))
  1.  .S Y=0 F  S Y=$O(^AUPNVTC("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MINPROC)  D
  1.  ..Q:'$D(^AUPNVTC(Y,0))
  1.  ..S I=$P(^AUPNVTC(Y,0),U,7)
  1.  ..Q:I=""
  1.  ..I $$ICD^BGP8UTL2(I,E,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP8UTL2(I,F,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..;I $$ICD^BGP8UTL2(I,G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  .Q
  1.  I BGPCNT>MIN Q 1
  1.  Q ""