BGP8D211 ; IHS/CMI/LAB - measure 6 19 Sep 2014 8:12 AM ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
DENTSRVD(P,BDATE,EDATE) ;EP - V18 GPRA DEV DOCUMENTED DENTAL VISIT
NEW BGPG,BGPC
K BGPG
S BGPC="",%=P_"^LAST ADA 0000;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$P(BGPG(1),U)_"^"_"RPMS DENTAL "_$P(BGPG(1),U,2)
K BGPG
S %=P_"^LAST ADA 0190;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$P(BGPG(1),U)_"^"_"RPMS DENTAL "_$P(BGPG(1),U,2)
K BGPG
S %=P_"^LAST ADA 0007;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$P(BGPG(1),U)_"^"_"RPMS DENTAL "_$P(BGPG(1),U,2)
K BGPG
S BGPG(1)=$$CPT^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP DENTAL VISIT CPT CODES",0)),5)
I BGPG(1)]"" Q 1_U_$P(BGPG(1),U)_"^"_"CDT "_$P(BGPG(1),U,2)
K BGPG
S %=P_"^LAST EXAM 30;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$P(BGPG(1),U)_"^"_$P(BGPG(1),U,3)
S BGPG=$$LASTDX^BGP8UTL1(P,"BGP DENTAL VISIT DXS",BDATE,EDATE)
I BGPG Q "1^"_$P(BGPG,U,3)_"^"_$P(BGPG,U,2)
I BGPG,$G(FORECAST),$P(BGPG,U,3)>$P(BGPC,U) S BGPC=$P(BGPG,U,3)_"^POV "_$P(BGPG,U,2)
K BGPG S G="" S %=P_"^ALL ADA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG) D I G]"",'$G(FORECAST) Q G
.S X=0 F S X=$O(BGPG(X)) Q:X'=+X S V=$P(BGPG(X),U,5) D
..I $P($G(^AUPNVSIT(V,0)),U,7)="C" Q ;NO CHART REVIEWS
..I $P($G(^AUPNVSIT(V,0)),U,7)="T" Q ;NO TELEPHONE CALLS
..S Y=+$P(BGPG(X),U,4)
..Q:'$$DVADA($$VAL^XBDIQ1(9000010.05,Y,.01))
..S G=1_U_$P(BGPG(X),U)_"^VISIT RPMS DENTAL "_$P(BGPG(X),U,2) Q
Q ""
DVADA(A) ;
;is this a dental visit ada code?
I $G(A)="" Q ""
I +A>109,+A<391 Q 1
I +A>414,+A<472 Q 1
I +A>600,+A<604 Q 1
I +A>998,+A<9975 Q 1
I +A=9999 Q 1
Q ""
;
JVN ;EP
NEW BGPVAL,A,E,%,Y,X,R,D,V
S BGPVAL=""
K ^TMP($J,"A")
S R=$NA(^TMP($J,"A"))
D ALLV^APCLAPIU(P,BDATE,EDATE,R)
S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$CLINIC^APCLV($P(^TMP($J,"A",X),U,5),"C") I R="A2",'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y S $P(BGPVAL,U,1)="JVN: "_$$DATE^BGP8UTL(D)_" Cl "_R
;OPHTHALMOLOGY
S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) D
.S V=$P(^TMP($J,"A",X),U,5)
.Q:$P($G(^AUPNVSIT(V,0)),U,7)="C"
.Q:$P($G(^AUPNVSIT(V,0)),U,7)="T"
.S R=$$CLINIC^APCLV($P(^TMP($J,"A",X),U,5),"C")
.Q:R'=17
.Q:$$DNKA($P(^TMP($J,"A",X),U,5))
.S J=$$PRIMPROV^APCLV($P(^TMP($J,"A",X),U,5),"D")
.Q:J'=79
.S Y=1,D=$P(^TMP($J,"A",X),U)
I Y S $P(BGPVAL,U,2)="Ophth: "_$$DATE^BGP8UTL(D)_" Cl/Prv "_R_"/"_J
;I 'Y D
;.S (X,Y)=0,D="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$PRIMPROV^APCLV($P(^TMP($J,"A",X),U,5),"D") I R=79,'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
;.I Y S $P(BGPVAL,U,2)="Ophth: "_$$DATE^BGP8UTL(D)_" Prv "_R
;S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$CLINIC^APCLV($P(^TMP($J,"A",X),U,5),"C") I R=18,'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
;I Y S $P(BGPVAL,U,3)="Optom: "_$$DATE^BGP8UTL(D)_" Cl "_R
;I 'Y D
;.S (X,Y)=0,D="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$PRIMPROV^APCLV($P(^TMP($J,"A",X),U,5),"D") I R="08"!(R=24),'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
;OPTOMETRY
S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) D
.S V=$P(^TMP($J,"A",X),U,5)
.Q:$P($G(^AUPNVSIT(V,0)),U,7)="C"
.Q:$P($G(^AUPNVSIT(V,0)),U,7)="T"
.S R=$$CLINIC^APCLV($P(^TMP($J,"A",X),U,5),"C")
.Q:R'=18
.Q:$$DNKA($P(^TMP($J,"A",X),U,5))
.S J=$$PRIMPROV^APCLV($P(^TMP($J,"A",X),U,5),"D")
.I J'="08",J'=24 Q
.S Y=1,D=$P(^TMP($J,"A",X),U)
I Y S $P(BGPVAL,U,3)="Optom: "_$$DATE^BGP8UTL(D)_" Cl/Prv "_R_"/"_J
Q BGPVAL
DNKA(V) ;EP
NEW D,N
S D=$$PRIMPOV^APCLV(V,"C")
I D=".0860" Q 1
S N=$$PRIMPOV^APCLV(V,"N")
I $E(D)="V",N["DNKA" Q 1
I $E(D)="V",N["DID NOT KEEP APPOINTMENT" Q 1
I $E(D)="V",N["DID NOT KEEP APPT" Q 1
Q 0
GFR(P,BDATE,EDATE) ;EP
S BGPC=""
S T=$O(^LAB(60,"B","ESTIMATED GFR",0))
S T1=$O(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0))
S T2=$O(^ATXAX("B","BGP ESTIMATED GFR 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)!(BGPC]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"") D
...Q:'$D(^AUPNVLAB(X,0))
...Q:$P(^AUPNVLAB(X,0),U,4)=""
...I T,$P(^AUPNVLAB(X,0),U)=T S BGPC=1_U_(9999999-D) Q
...I T1,$D(^ATXLAB(T1,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D) Q
...Q:'T2
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T2)
...S BGPC=1_U_(9999999-D)
...Q
Q BGPC
QUANTUP(P,BDATE,EDATE) ;EP
K BGPC,BGPX
S BGPC="",BGPLC=""
K BGPG S %=P_"^LAST LAB [BGP QUANT UACR TESTS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPLC=1_"^"_$P(BGPG(1),U,3)_"^"_$P(BGPG(1),U)
S T=$O(^ATXAX("B","BGP QUANT UACR 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)!(BGPC]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"") D
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S %=$$VAL^XBDIQ1(9000010.09,X,.01) ;$P(^AUPNVLAB(X,0),U,4)
...I $P(BGPLC,U,3)<(9999999-D) S BGPLC=1_U_%_U_(9999999-D)
S %="",E=+$$CODEN^ICPTCOD(82043),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
I %]"",$P(BGPLC,U,3)<$P(%,U,2),$$OCPT($P(%,U,3)) S BGPLC="1^CPT 82043/82570^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(82043),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
I %]"",$P(BGPLC,U,3)<$P(%,U,2),$$OCPT($P(%,U,3)) S BGPLC="1^CPT 84023/82570^"_$P(%,U,2)
Q BGPLC
OCPT(V) ;is there a 82570 on this visit?
NEW X,Y,D,E,%
S D=$$VD^APCLV(V) ;date of visit
S E=+$$CODEN^ICPTCOD("82570"),%=$$CPTI^BGP8DU(P,D,D,E)
;S X=0,Y=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
;.I $$VAL^XBDIQ1(9000010.18,X,.01)=82570 S Y=1 Q
I % Q 1
;check tran codes
;S X=0,Y=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
;.I $$VAL^XBDIQ1(9000010.33,X,.07)=82570 S Y=1 Q
S E=+$$CODEN^ICPTCOD("82570"),%=$$TRANI^BGP8DU(P,D,D,E)
I % Q 1
Q ""
LOINC(A,B) ;EP
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 ""
ESRD(P,BDATE,EDATE) ;EP
NEW X,T,A,B,C
S X=$$LASTDX^BGP8UTL1(P,"BGP ESRD PMS DXS",BDATE,EDATE)
I X Q 1_U_"POV "_$P(X,U,2)_U_$P(X,U,3)
S T=$O(^ATXAX("B","BGP ESRD CPTS",0))
I T D I X]"" Q 1_U_"CPT "_$P(X,U,2)_U_$P(X,U,1)
.S X=$$CPT^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
S X=$$LASTPRC^BGP8UTL1(P,"BGP ESRD PROCS",BDATE,EDATE)
I X Q 1_U_"PRC "_$P(X,U,2)_U_$P(X,U,3)
;added non-deleted problem list icd/snomed
S X=$$PLTAXND^BGP8DU(P,"BGP ESRD PMS DXS",EDATE)
I X Q X
S X=$$IPLSNOND^BGP8DU(P,"PXRM END STAGE RENAL DISEASE",EDATE)
I X Q X
Q 0
S ;
S BGPSET($P(^APCDTPGT(X,0),U,1))=0,BGPMET($P(^APCDTPGT(X,0),U,1))=0
Q
IGOAL ;EP
NEW BGPSET,BGPMET
;
I 'BGPACTUP S BGPSTOP=1 Q ;not user pop
F X=1:1:23 S @("BGPN"_X)=0
S BGPD1=1 ;USER POP
S BGPD2=0 ;# goals set
S BGPD3=0 ;# goals met
S X=0 F S X=$O(^APCDTPGT(X)) Q:X'=+X D
.S Y=$P(^APCDTPGT(X,0),U,1)
.I Y="PHYSICAL ACTIVITY" D S
.I Y="NUTRITION" D S
.I Y="MEDICATIONS" D S
.I Y="WELLNESS AND SAFETY" D S
.I Y="TOBACCO" D S
.I Y="ALCOHOL OR OTHER DRUGS" D S
.I Y="STRESS AND COPING" D S
.I Y="MONITORING" D S
.I Y="DIABETES CURRICULUM" D S
.I Y="OTHER" D S
;did patient have a goal set with a start date in report period
D SET
I BGPD2 S BGPN1=1
S C=2,X=0
F S X=$O(BGPSET(X)) Q:X="" S C=C+1 S @("BGPN"_C)=@("BGPN"_C)+BGPSET(X)
D MET
I BGPD3 S BGPN2=1
S C=12,X=0
F S X=$O(BGPMET(X)) Q:X="" S C=C+1 S @("BGPN"_C)=@("BGPN"_C)+BGPMET(X)
S BGPVALUE="UP|||"
S X="",Y="" F S X=$O(BGPSET(X)) Q:X="" I $P(BGPSET(X),U,1) D
.F J=2:1 S D=$P(BGPSET(X),U,J) Q:D="" D
..I Y]"" S Y=Y_", "
..S Y=Y_$$DATE^BGP8UTL(D)_" - "_X
I Y]"" S Y="GS: "_Y,BGPVALUE=BGPVALUE_Y
S Y=""
S X="",Y="" F S X=$O(BGPMET(X)) Q:X="" I $P(BGPMET(X),U,1) D
.F J=2:1 S D=$P(BGPMET(X),U,J) Q:D="" D
..I Y]"" S Y=Y_", "
..S Y=Y_$$DATE^BGP8UTL(D)_" - "_X
I Y]"" S Y="; GM: "_Y,BGPVALUE=BGPVALUE_Y
K BGPSET,BGPMET
Q
;
MET ;
NEW D,%,X,Y
S X=0,%=""
F S X=$O(^AUPNGOAL("AC",DFN,X)) Q:X'=+X D
.Q:'$D(^AUPNGOAL(X,0)) ;BAD XREF
.Q:$P(^AUPNGOAL(X,0),U,1)'="S" ;SET ONLY
.Q:$P(^AUPNGOAL(X,0),U,11)'="ME"
.;DURING REPORT PERIOD MODIFIED DATE)
.S G=0
.S D=$P($P(^AUPNGOAL(X,0),U,5),".")
.I D'<BGPBDATE,D'>BGPEDATE S G=1
.Q:'G
.S Y=0 F S Y=$O(^AUPNGOAL(X,10,Y)) Q:Y'=+Y D
..S Z=$P($G(^AUPNGOAL(X,10,Y,0)),U,1)
..Q:'Z
..S BGPD3=BGPD3+1
..S Z=$P($G(^APCDTPGT(Z,0)),U,1)
..Q:Z=""
..S $P(BGPMET(Z),U,1)=$P(BGPMET(Z),U,1)+1,J=$P(BGPMET(Z),U,1),J=J+1,$P(BGPMET(Z),U,J)=D
Q
SET ;
NEW X,Y,Z,%,D
S X=0,%=""
F S X=$O(^AUPNGOAL("AC",DFN,X)) Q:X'=+X D
.Q:'$D(^AUPNGOAL(X,0)) ;BAD XREF
.Q:$P(^AUPNGOAL(X,0),U,1)'="S" ;SET ONLY
.S D=$P($P(^AUPNGOAL(X,0),U,9),".")
.Q:D=""
.Q:D<BGPBDATE
.Q:D>BGPEDATE
.S Y=0 F S Y=$O(^AUPNGOAL(X,10,Y)) Q:Y'=+Y D
..S Z=$P($G(^AUPNGOAL(X,10,Y,0)),U,1)
..Q:'Z
..S BGPD2=BGPD2+1
..S Z=$P($G(^APCDTPGT(Z,0)),U,1)
..Q:Z=""
..S $P(BGPSET(Z),U,1)=$P(BGPSET(Z),U,1)+1,J=$P(BGPSET(Z),U,1),J=J+1,$P(BGPSET(Z),U,J)=D
Q
AWV ;EP
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPN1)=0
S BGPVALUE=""
I 'BGPACTCL S BGPSTOP=1 Q ;not active clinical
I BGPAGEB<65 S BGPSTOP=1 Q ;not over 65
S BGPD1=1
I $P(^DPT(DFN,0),U,2)="M" S BGPD2=1
I $P(^DPT(DFN,0),U,2)="F" S BGPD3=1
I BGPAGEB>64,BGPAGEB<75 S BGPD4=1
I BGPAGEB>74,BGPAGEB<85 S BGPD5=1
I BGPAGEB>84 S BGPD6=1
S BGPVAL=$$AWV1(DFN,$$FMADD^XLFDT(BGPEDATE,-456),BGPEDATE)
S BGPN1=$P(BGPVAL,U)
S BGPVALUE="AC|||" I BGPN1 S BGPVALUE=BGPVALUE_$$DATE^BGP8UTL($P(BGPVAL,U,2))_" CPT "_$P(BGPVAL,U,3)
K BGPVAL
Q
;
AWV1(P,BDATE,EDATE) ;EP
NEW T,X
S T=$O(^ATXAX("B","BGP ANNUAL WELLNESS CPTS",0))
I 'T Q ""
S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,6)
I 'X S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,6)
Q X
DMPVPL(P,BDATE,EDATE) ;EP - DM ON PL OR 2 DM VISITS EVER
I '$G(P) Q ""
I $$PLTAXND^BGP8DU(P,"SURVEILLANCE DIABETES",EDATE) Q 1
I $$IPLSNOND^BGP8DU(P,"PXRM DIABETES",EDATE) Q 1
I $$V2DM^BGP8D1(P,BDATE,EDATE) Q 1
Q ""
DMFB(P,EDATE) ;EP - DM V POV BEFORE TIME PERIOD OR PL BEFORE TIME PERIOD
I '$G(P) Q ""
I $$PLTAXND^BGP8DU(P,"SURVEILLANCE DIABETES",EDATE) Q 1
I $$IPLSNOND^BGP8DU(P,"PXRM DIABETES",EDATE) Q 1
NEW X,BGPG,E,Y
K BGPG
S Y="BGPG("
S X=P_"^FIRST DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y)
I '$D(BGPG(1)) Q ""
I $P(BGPG(1),U,1)'>EDATE Q 1
Q ""
BGP8D211 ; IHS/CMI/LAB - measure 6 19 Sep 2014 8:12 AM ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
DENTSRVD(P,BDATE,EDATE) ;EP - V18 GPRA DEV DOCUMENTED DENTAL VISIT
+1 NEW BGPG,BGPC
+2 KILL BGPG
+3 SET BGPC=""
SET %=P_"^LAST ADA 0000;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
QUIT 1_U_$PIECE(BGPG(1),U)_"^"_"RPMS DENTAL "_$PIECE(BGPG(1),U,2)
+5 KILL BGPG
+6 SET %=P_"^LAST ADA 0190;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+7 IF $DATA(BGPG(1))
QUIT 1_U_$PIECE(BGPG(1),U)_"^"_"RPMS DENTAL "_$PIECE(BGPG(1),U,2)
+8 KILL BGPG
+9 SET %=P_"^LAST ADA 0007;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+10 IF $DATA(BGPG(1))
QUIT 1_U_$PIECE(BGPG(1),U)_"^"_"RPMS DENTAL "_$PIECE(BGPG(1),U,2)
+11 KILL BGPG
+12 SET BGPG(1)=$$CPT^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP DENTAL VISIT CPT CODES",0)),5)
+13 IF BGPG(1)]""
QUIT 1_U_$PIECE(BGPG(1),U)_"^"_"CDT "_$PIECE(BGPG(1),U,2)
+14 KILL BGPG
+15 SET %=P_"^LAST EXAM 30;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+16 IF $DATA(BGPG(1))
QUIT 1_U_$PIECE(BGPG(1),U)_"^"_$PIECE(BGPG(1),U,3)
+17 SET BGPG=$$LASTDX^BGP8UTL1(P,"BGP DENTAL VISIT DXS",BDATE,EDATE)
+18 IF BGPG
QUIT "1^"_$PIECE(BGPG,U,3)_"^"_$PIECE(BGPG,U,2)
+19 IF BGPG
IF $GET(FORECAST)
IF $PIECE(BGPG,U,3)>$PIECE(BGPC,U)
SET BGPC=$PIECE(BGPG,U,3)_"^POV "_$PIECE(BGPG,U,2)
+20 KILL BGPG
SET G=""
SET %=P_"^ALL ADA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+21 IF $DATA(BGPG)
Begin DoDot:1
+22 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET V=$PIECE(BGPG(X),U,5)
Begin DoDot:2
+23 ;NO CHART REVIEWS
IF $PIECE($GET(^AUPNVSIT(V,0)),U,7)="C"
QUIT
+24 ;NO TELEPHONE CALLS
IF $PIECE($GET(^AUPNVSIT(V,0)),U,7)="T"
QUIT
+25 SET Y=+$PIECE(BGPG(X),U,4)
+26 IF '$$DVADA($$VAL^XBDIQ1(9000010.05,Y,.01))
QUIT
+27 SET G=1_U_$PIECE(BGPG(X),U)_"^VISIT RPMS DENTAL "_$PIECE(BGPG(X),U,2)
QUIT
End DoDot:2
End DoDot:1
IF G]""
IF '$GET(FORECAST)
QUIT G
+28 QUIT ""
DVADA(A) ;
+1 ;is this a dental visit ada code?
+2 IF $GET(A)=""
QUIT ""
+3 IF +A>109
IF +A<391
QUIT 1
+4 IF +A>414
IF +A<472
QUIT 1
+5 IF +A>600
IF +A<604
QUIT 1
+6 IF +A>998
IF +A<9975
QUIT 1
+7 IF +A=9999
QUIT 1
+8 QUIT ""
+9 ;
JVN ;EP
+1 NEW BGPVAL,A,E,%,Y,X,R,D,V
+2 SET BGPVAL=""
+3 KILL ^TMP($JOB,"A")
+4 SET R=$NAME(^TMP($JOB,"A"))
+5 DO ALLV^APCLAPIU(P,BDATE,EDATE,R)
+6 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(Y)
QUIT
SET R=$$CLINIC^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"C")
IF R="A2"
IF '$$DNKA($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+7 IF Y
SET $PIECE(BGPVAL,U,1)="JVN: "_$$DATE^BGP8UTL(D)_" Cl "_R
+8 ;OPHTHALMOLOGY
+9 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(Y)
QUIT
Begin DoDot:1
+10 SET V=$PIECE(^TMP($JOB,"A",X),U,5)
+11 IF $PIECE($GET(^AUPNVSIT(V,0)),U,7)="C"
QUIT
+12 IF $PIECE($GET(^AUPNVSIT(V,0)),U,7)="T"
QUIT
+13 SET R=$$CLINIC^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"C")
+14 IF R'=17
QUIT
+15 IF $$DNKA($PIECE(^TMP($JOB,"A",X),U,5))
QUIT
+16 SET J=$$PRIMPROV^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"D")
+17 IF J'=79
QUIT
+18 SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
End DoDot:1
+19 IF Y
SET $PIECE(BGPVAL,U,2)="Ophth: "_$$DATE^BGP8UTL(D)_" Cl/Prv "_R_"/"_J
+20 ;I 'Y D
+21 ;.S (X,Y)=0,D="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$PRIMPROV^APCLV($P(^TMP($J,"A",X),U,5),"D") I R=79,'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
+22 ;.I Y S $P(BGPVAL,U,2)="Ophth: "_$$DATE^BGP8UTL(D)_" Prv "_R
+23 ;S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$CLINIC^APCLV($P(^TMP($J,"A",X),U,5),"C") I R=18,'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
+24 ;I Y S $P(BGPVAL,U,3)="Optom: "_$$DATE^BGP8UTL(D)_" Cl "_R
+25 ;I 'Y D
+26 ;.S (X,Y)=0,D="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$PRIMPROV^APCLV($P(^TMP($J,"A",X),U,5),"D") I R="08"!(R=24),'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
+27 ;OPTOMETRY
+28 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(Y)
QUIT
Begin DoDot:1
+29 SET V=$PIECE(^TMP($JOB,"A",X),U,5)
+30 IF $PIECE($GET(^AUPNVSIT(V,0)),U,7)="C"
QUIT
+31 IF $PIECE($GET(^AUPNVSIT(V,0)),U,7)="T"
QUIT
+32 SET R=$$CLINIC^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"C")
+33 IF R'=18
QUIT
+34 IF $$DNKA($PIECE(^TMP($JOB,"A",X),U,5))
QUIT
+35 SET J=$$PRIMPROV^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"D")
+36 IF J'="08"
IF J'=24
QUIT
+37 SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
End DoDot:1
+38 IF Y
SET $PIECE(BGPVAL,U,3)="Optom: "_$$DATE^BGP8UTL(D)_" Cl/Prv "_R_"/"_J
+39 QUIT BGPVAL
DNKA(V) ;EP
+1 NEW D,N
+2 SET D=$$PRIMPOV^APCLV(V,"C")
+3 IF D=".0860"
QUIT 1
+4 SET N=$$PRIMPOV^APCLV(V,"N")
+5 IF $EXTRACT(D)="V"
IF N["DNKA"
QUIT 1
+6 IF $EXTRACT(D)="V"
IF N["DID NOT KEEP APPOINTMENT"
QUIT 1
+7 IF $EXTRACT(D)="V"
IF N["DID NOT KEEP APPT"
QUIT 1
+8 QUIT 0
GFR(P,BDATE,EDATE) ;EP
+1 SET BGPC=""
+2 SET T=$ORDER(^LAB(60,"B","ESTIMATED GFR",0))
+3 SET T1=$ORDER(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0))
+4 SET T2=$ORDER(^ATXAX("B","BGP ESTIMATED GFR 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)!(BGPC]"")
QUIT
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+8 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+9 IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+10 IF T
IF $PIECE(^AUPNVLAB(X,0),U)=T
SET BGPC=1_U_(9999999-D)
QUIT
+11 IF T1
IF $DATA(^ATXLAB(T1,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_(9999999-D)
QUIT
+12 IF 'T2
QUIT
+13 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+14 IF '$$LOINC(J,T2)
QUIT
+15 SET BGPC=1_U_(9999999-D)
+16 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+17 QUIT BGPC
QUANTUP(P,BDATE,EDATE) ;EP
+1 KILL BGPC,BGPX
+2 SET BGPC=""
SET BGPLC=""
+3 KILL BGPG
SET %=P_"^LAST LAB [BGP QUANT UACR TESTS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
SET BGPLC=1_"^"_$PIECE(BGPG(1),U,3)_"^"_$PIECE(BGPG(1),U)
+5 SET T=$ORDER(^ATXAX("B","BGP QUANT UACR LOINC",0))
+6 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)!(BGPC]"")
QUIT
Begin DoDot:1
+7 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+9 IF 'T
QUIT
+10 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+11 IF '$$LOINC(J,T)
QUIT
+12 ;$P(^AUPNVLAB(X,0),U,4)
SET %=$$VAL^XBDIQ1(9000010.09,X,.01)
+13 IF $PIECE(BGPLC,U,3)<(9999999-D)
SET BGPLC=1_U_%_U_(9999999-D)
End DoDot:3
End DoDot:2
End DoDot:1
+14 SET %=""
SET E=+$$CODEN^ICPTCOD(82043)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+15 IF %]""
IF $PIECE(BGPLC,U,3)<$PIECE(%,U,2)
IF $$OCPT($PIECE(%,U,3))
SET BGPLC="1^CPT 82043/82570^"_$PIECE(%,U,2)
+16 SET %=""
SET E=+$$CODEN^ICPTCOD(82043)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
+17 IF %]""
IF $PIECE(BGPLC,U,3)<$PIECE(%,U,2)
IF $$OCPT($PIECE(%,U,3))
SET BGPLC="1^CPT 84023/82570^"_$PIECE(%,U,2)
+18 QUIT BGPLC
OCPT(V) ;is there a 82570 on this visit?
+1 NEW X,Y,D,E,%
+2 ;date of visit
SET D=$$VD^APCLV(V)
+3 SET E=+$$CODEN^ICPTCOD("82570")
SET %=$$CPTI^BGP8DU(P,D,D,E)
+4 ;S X=0,Y=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
+5 ;.I $$VAL^XBDIQ1(9000010.18,X,.01)=82570 S Y=1 Q
+6 IF %
QUIT 1
+7 ;check tran codes
+8 ;S X=0,Y=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
+9 ;.I $$VAL^XBDIQ1(9000010.33,X,.07)=82570 S Y=1 Q
+10 SET E=+$$CODEN^ICPTCOD("82570")
SET %=$$TRANI^BGP8DU(P,D,D,E)
+11 IF %
QUIT 1
+12 QUIT ""
LOINC(A,B) ;EP
+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 ""
ESRD(P,BDATE,EDATE) ;EP
+1 NEW X,T,A,B,C
+2 SET X=$$LASTDX^BGP8UTL1(P,"BGP ESRD PMS DXS",BDATE,EDATE)
+3 IF X
QUIT 1_U_"POV "_$PIECE(X,U,2)_U_$PIECE(X,U,3)
+4 SET T=$ORDER(^ATXAX("B","BGP ESRD CPTS",0))
+5 IF T
Begin DoDot:1
+6 SET X=$$CPT^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
IF X]""
QUIT
+7 SET X=$$TRAN^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
End DoDot:1
IF X]""
QUIT 1_U_"CPT "_$PIECE(X,U,2)_U_$PIECE(X,U,1)
+8 SET X=$$LASTPRC^BGP8UTL1(P,"BGP ESRD PROCS",BDATE,EDATE)
+9 IF X
QUIT 1_U_"PRC "_$PIECE(X,U,2)_U_$PIECE(X,U,3)
+10 ;added non-deleted problem list icd/snomed
+11 SET X=$$PLTAXND^BGP8DU(P,"BGP ESRD PMS DXS",EDATE)
+12 IF X
QUIT X
+13 SET X=$$IPLSNOND^BGP8DU(P,"PXRM END STAGE RENAL DISEASE",EDATE)
+14 IF X
QUIT X
+15 QUIT 0
S ;
+1 SET BGPSET($PIECE(^APCDTPGT(X,0),U,1))=0
SET BGPMET($PIECE(^APCDTPGT(X,0),U,1))=0
+2 QUIT
IGOAL ;EP
+1 NEW BGPSET,BGPMET
+2 ;
+3 ;not user pop
IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+4 FOR X=1:1:23
SET @("BGPN"_X)=0
+5 ;USER POP
SET BGPD1=1
+6 ;# goals set
SET BGPD2=0
+7 ;# goals met
SET BGPD3=0
+8 SET X=0
FOR
SET X=$ORDER(^APCDTPGT(X))
IF X'=+X
QUIT
Begin DoDot:1
+9 SET Y=$PIECE(^APCDTPGT(X,0),U,1)
+10 IF Y="PHYSICAL ACTIVITY"
DO S
+11 IF Y="NUTRITION"
DO S
+12 IF Y="MEDICATIONS"
DO S
+13 IF Y="WELLNESS AND SAFETY"
DO S
+14 IF Y="TOBACCO"
DO S
+15 IF Y="ALCOHOL OR OTHER DRUGS"
DO S
+16 IF Y="STRESS AND COPING"
DO S
+17 IF Y="MONITORING"
DO S
+18 IF Y="DIABETES CURRICULUM"
DO S
+19 IF Y="OTHER"
DO S
End DoDot:1
+20 ;did patient have a goal set with a start date in report period
+21 DO SET
+22 IF BGPD2
SET BGPN1=1
+23 SET C=2
SET X=0
+24 FOR
SET X=$ORDER(BGPSET(X))
IF X=""
QUIT
SET C=C+1
SET @("BGPN"_C)=@("BGPN"_C)+BGPSET(X)
+25 DO MET
+26 IF BGPD3
SET BGPN2=1
+27 SET C=12
SET X=0
+28 FOR
SET X=$ORDER(BGPMET(X))
IF X=""
QUIT
SET C=C+1
SET @("BGPN"_C)=@("BGPN"_C)+BGPMET(X)
+29 SET BGPVALUE="UP|||"
+30 SET X=""
SET Y=""
FOR
SET X=$ORDER(BGPSET(X))
IF X=""
QUIT
IF $PIECE(BGPSET(X),U,1)
Begin DoDot:1
+31 FOR J=2:1
SET D=$PIECE(BGPSET(X),U,J)
IF D=""
QUIT
Begin DoDot:2
+32 IF Y]""
SET Y=Y_", "
+33 SET Y=Y_$$DATE^BGP8UTL(D)_" - "_X
End DoDot:2
End DoDot:1
+34 IF Y]""
SET Y="GS: "_Y
SET BGPVALUE=BGPVALUE_Y
+35 SET Y=""
+36 SET X=""
SET Y=""
FOR
SET X=$ORDER(BGPMET(X))
IF X=""
QUIT
IF $PIECE(BGPMET(X),U,1)
Begin DoDot:1
+37 FOR J=2:1
SET D=$PIECE(BGPMET(X),U,J)
IF D=""
QUIT
Begin DoDot:2
+38 IF Y]""
SET Y=Y_", "
+39 SET Y=Y_$$DATE^BGP8UTL(D)_" - "_X
End DoDot:2
End DoDot:1
+40 IF Y]""
SET Y="; GM: "_Y
SET BGPVALUE=BGPVALUE_Y
+41 KILL BGPSET,BGPMET
+42 QUIT
+43 ;
MET ;
+1 NEW D,%,X,Y
+2 SET X=0
SET %=""
+3 FOR
SET X=$ORDER(^AUPNGOAL("AC",DFN,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 ;BAD XREF
IF '$DATA(^AUPNGOAL(X,0))
QUIT
+5 ;SET ONLY
IF $PIECE(^AUPNGOAL(X,0),U,1)'="S"
QUIT
+6 IF $PIECE(^AUPNGOAL(X,0),U,11)'="ME"
QUIT
+7 ;DURING REPORT PERIOD MODIFIED DATE)
+8 SET G=0
+9 SET D=$PIECE($PIECE(^AUPNGOAL(X,0),U,5),".")
+10 IF D'<BGPBDATE
IF D'>BGPEDATE
SET G=1
+11 IF 'G
QUIT
+12 SET Y=0
FOR
SET Y=$ORDER(^AUPNGOAL(X,10,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+13 SET Z=$PIECE($GET(^AUPNGOAL(X,10,Y,0)),U,1)
+14 IF 'Z
QUIT
+15 SET BGPD3=BGPD3+1
+16 SET Z=$PIECE($GET(^APCDTPGT(Z,0)),U,1)
+17 IF Z=""
QUIT
+18 SET $PIECE(BGPMET(Z),U,1)=$PIECE(BGPMET(Z),U,1)+1
SET J=$PIECE(BGPMET(Z),U,1)
SET J=J+1
SET $PIECE(BGPMET(Z),U,J)=D
End DoDot:2
End DoDot:1
+19 QUIT
SET ;
+1 NEW X,Y,Z,%,D
+2 SET X=0
SET %=""
+3 FOR
SET X=$ORDER(^AUPNGOAL("AC",DFN,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 ;BAD XREF
IF '$DATA(^AUPNGOAL(X,0))
QUIT
+5 ;SET ONLY
IF $PIECE(^AUPNGOAL(X,0),U,1)'="S"
QUIT
+6 SET D=$PIECE($PIECE(^AUPNGOAL(X,0),U,9),".")
+7 IF D=""
QUIT
+8 IF D<BGPBDATE
QUIT
+9 IF D>BGPEDATE
QUIT
+10 SET Y=0
FOR
SET Y=$ORDER(^AUPNGOAL(X,10,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+11 SET Z=$PIECE($GET(^AUPNGOAL(X,10,Y,0)),U,1)
+12 IF 'Z
QUIT
+13 SET BGPD2=BGPD2+1
+14 SET Z=$PIECE($GET(^APCDTPGT(Z,0)),U,1)
+15 IF Z=""
QUIT
+16 SET $PIECE(BGPSET(Z),U,1)=$PIECE(BGPSET(Z),U,1)+1
SET J=$PIECE(BGPSET(Z),U,1)
SET J=J+1
SET $PIECE(BGPSET(Z),U,J)=D
End DoDot:2
End DoDot:1
+17 QUIT
AWV ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPN1)=0
+2 SET BGPVALUE=""
+3 ;not active clinical
IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+4 ;not over 65
IF BGPAGEB<65
SET BGPSTOP=1
QUIT
+5 SET BGPD1=1
+6 IF $PIECE(^DPT(DFN,0),U,2)="M"
SET BGPD2=1
+7 IF $PIECE(^DPT(DFN,0),U,2)="F"
SET BGPD3=1
+8 IF BGPAGEB>64
IF BGPAGEB<75
SET BGPD4=1
+9 IF BGPAGEB>74
IF BGPAGEB<85
SET BGPD5=1
+10 IF BGPAGEB>84
SET BGPD6=1
+11 SET BGPVAL=$$AWV1(DFN,$$FMADD^XLFDT(BGPEDATE,-456),BGPEDATE)
+12 SET BGPN1=$PIECE(BGPVAL,U)
+13 SET BGPVALUE="AC|||"
IF BGPN1
SET BGPVALUE=BGPVALUE_$$DATE^BGP8UTL($PIECE(BGPVAL,U,2))_" CPT "_$PIECE(BGPVAL,U,3)
+14 KILL BGPVAL
+15 QUIT
+16 ;
AWV1(P,BDATE,EDATE) ;EP
+1 NEW T,X
+2 SET T=$ORDER(^ATXAX("B","BGP ANNUAL WELLNESS CPTS",0))
+3 IF 'T
QUIT ""
+4 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,T,6)
+5 IF 'X
SET X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,6)
+6 QUIT X
DMPVPL(P,BDATE,EDATE) ;EP - DM ON PL OR 2 DM VISITS EVER
+1 IF '$GET(P)
QUIT ""
+2 IF $$PLTAXND^BGP8DU(P,"SURVEILLANCE DIABETES",EDATE)
QUIT 1
+3 IF $$IPLSNOND^BGP8DU(P,"PXRM DIABETES",EDATE)
QUIT 1
+4 IF $$V2DM^BGP8D1(P,BDATE,EDATE)
QUIT 1
+5 QUIT ""
DMFB(P,EDATE) ;EP - DM V POV BEFORE TIME PERIOD OR PL BEFORE TIME PERIOD
+1 IF '$GET(P)
QUIT ""
+2 IF $$PLTAXND^BGP8DU(P,"SURVEILLANCE DIABETES",EDATE)
QUIT 1
+3 IF $$IPLSNOND^BGP8DU(P,"PXRM DIABETES",EDATE)
QUIT 1
+4 NEW X,BGPG,E,Y
+5 KILL BGPG
+6 SET Y="BGPG("
+7 SET X=P_"^FIRST DX [SURVEILLANCE DIABETES"
SET E=$$START1^APCLDF(X,Y)
+8 IF '$DATA(BGPG(1))
QUIT ""
+9 IF $PIECE(BGPG(1),U,1)'>EDATE
QUIT 1
+10 QUIT ""
