BGP8PC1.m

BGP8PC1 ;IHS/CMI/LAB - CALC MEASURES;  ; 12 Apr 2018  11:08 AM

 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

 ;

PROC ;EP

 S BGPBT=$H

 D JRNL^BGP8PCUT

 S BGPJ=$J,BGPH=$H

 K ^XTMP("BGP15TAX",$J),^XTMP("BGPSNOMEDSUBSET",$J)

 D UNFOLDTX^BGP8UTL2

 D XTMP^BGP8UTL("BGP8D","IPC Patient List")

 ;calculate 3 years before end of each time frame

 S BGP3YE=$$FMADD^XLFDT(BGPED,-1096)

 S BGPP3YE=$$FMADD^XLFDT(BGPPED,-1096)

 S BGPB3YE=$$FMADD^XLFDT(BGPBED,-1096)

 ;process each patient

 S DFN=0 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  D

 .Q:'$D(^AUPNPAT(DFN,0))

 .;I DUZ=2881 Q:$$HRN^AUPNPAT(DFN,DUZ(2))'=144641

 .Q:$P($G(^DPT(DFN,0)),U)["DEMO,PATIENT"

 .S X=$O(^DIBT("B","RPMS DEMO PATIENT NAMES",0)) I X Q:$D(^DIBT(X,1,DFN))

 .D PROCCY,PROCPY,PROCBY

N ;

 S BGPET=$H

 K ^XTMP("BGP15TAX",$J),^XTMP("BGPSNOMEDSUBSET",$J)

 Q

 ;

PROCCY ;EP - current time period

 K ^TMP($J)

 K BGPG

 Q:'$D(^DPT(DFN,0))

 Q:$P(^DPT(DFN,0),U,2)=""

 Q:"FM"'[$P(^DPT(DFN,0),U,2)

 S BGPEDATE=BGPED,BGPTIME=1,BGPBDATE=BGPBD,BGPGBL="^BGPGPDCR("

 S BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)

 S BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)

 S BGPSEX=$P(^DPT(DFN,0),U,2)

 Q:'$$COMMBEN(DFN,BGPBEN,$G(BGPTAXI),$G(BGPCOMMI),$G(BGPSEAT),BGPEDATE)

 S BGPIPCUP=$$IPCACTUP(DFN,BGPBDATE,BGPEDATE) ;user pop

 D CALCIND

 K ^TMP($J)

 Q

PROCPY ;

 K ^TMP($J)

 K BGPG

 Q:'$D(^DPT(DFN,0))

 Q:$P(^DPT(DFN,0),U,2)=""

 Q:"FM"'[$P(^DPT(DFN,0),U,2)

 S BGPEDATE=BGPPED,BGPTIME=2,BGPBDATE=BGPPBD,BGPGBL="^BGPGPDPR("

 S BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)

 S BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)

 S BGPSEX=$P(^DPT(DFN,0),U,2)

 Q:'$$COMMBEN(DFN,BGPBEN,$G(BGPTAXI),$G(BGPCOMMI),$G(BGPSEAT),BGPEDATE)

 S BGPIPCUP=$$IPCACTUP(DFN,BGPBDATE,BGPEDATE) ;user pop

 D CALCIND

 K ^TMP($J)

 Q

PROCBY ;

 K ^TMP($J)

 K BGPG

 Q:'$D(^DPT(DFN,0))

 Q:$P(^DPT(DFN,0),U,2)=""

 Q:"FM"'[$P(^DPT(DFN,0),U,2)

 S BGPEDATE=BGPBED,BGPTIME=3,BGPBDATE=BGPBBD,BGPGBL="^BGPGPDBR("

 S BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)

 S BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)

 S BGPSEX=$P(^DPT(DFN,0),U,2)

 Q:'$$COMMBEN(DFN,BGPBEN,$G(BGPTAXI),$G(BGPCOMMI),$G(BGPSEAT),BGPEDATE)

 S BGPIPCUP=$$IPCACTUP(DFN,BGPBDATE,BGPEDATE) ;user pop

 D CALCIND

 K ^TMP($J)

 Q

CALCIND ;

 D CALCIND^BGP8PCCI

 Q

V2(P,BDATE,EDATE) ;EP

 I '$D(^AUPNVSIT("AC",P)) Q ""

 K ^TMP($J,"A")

 NEW A,B,X,G,V,R

 S R=$NA(^TMP($J,"A"))

 D ALLV^APCLAPIU(P,BDATE,EDATE,R)

 I '$D(^TMP($J,"A",1)) Q ""

 S (X,G)=0 F  S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G>1)  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 G=G+1

 .Q

 K ^TMP($J,"A")

 Q $S(G<2:"",1:1)

 ;

COMMBEN(P,B,T,C,PP,EDATE) ;

 NEW X

 I PP,'$D(^DIBT(PP,1,P)) Q 0 ;PATIENT PANEL AND PATIENT NOT IN THE PANEL

 I PP,$D(^DIBT(PP,1,P)) Q 1  ;PATIENT IS IN PP

 I B=1,$$BEN^AUPNPAT(P,"C")'="01" Q 0  ;must be Indian/Alaskan Native

 I B=2,$$BEN^AUPNPAT(P,"C")="01" Q 0  ;must not be I/A

 S DOD=$$DOD^AUPNPAT(P) I DOD]"",DOD<EDATE Q 0

 I T="",C="" Q 1  ;all communities

 I C,$P($G(^AUPNPAT(P,11)),U,17)'=C Q 0

 I C,$P($G(^AUPNPAT(P,11)),U,17)=C Q 1

 S X=$P($G(^AUPNPAT(P,11)),U,18) I X="" Q 0

 I '$D(^ATXAX(T,21,"B",($P(^AUPNPAT(P,11),U,18)))),'$D(^ATXAX(T,21,"AA",$P(^AUPNPAT(P,11),U,18),$P(^AUPNPAT(P,11),U,18))) Q 0

 Q 1

 ;

IPCACTUP(P,BDATE,EDATE) ;EP - is this patient in user pop?

 NEW X,DOD

 S DOD=$$DOD^AUPNPAT(P) I DOD]"",DOD<EDATE Q 0

LVD I '$$V1(P,BDATE,EDATE) Q 0  ;did they have 1 visit to IPC clinic list

 Q 1

 ;

V1(P,BDATE,EDATE) ;

 NEW R,X,G,F,S,B,BGPV

 D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")

 S (X,G,F,S)=0 F  S X=$O(BGPV(X)) Q:X'=+X!(G)  S V=$P(BGPV(X),U,5) D

 .Q:'$D(^AUPNVSIT(V,0))

 .Q:'$P(^AUPNVSIT(V,0),U,9)

 .Q:$P(^AUPNVSIT(V,0),U,11)

 .Q:'$D(^AUPNVPRV("AD",V))

 .Q:"SAHOI"'[$P(^AUPNVSIT(V,0),U,7)

 .Q:$P(^AUPNVSIT(V,0),U,6)=""

 .I $P(^AUPNVSIT(V,0),U,7)="H" S G=1 Q   ;H visit has no clinic

 .I $P(^AUPNVSIT(V,0),U,7)="I" S G=1 Q   ;I visit has no clinic

 .S B=$$CLINIC^APCLV(V,"C")

 .Q:B=""

 .I $D(^BGPCTRL($O(^BGPCTRL("B",2018,0)),1101,"B",B)) S G=1  ;must be a primary clinic S G=V

 Q $S(G:1,1:0)

DMC ;EP

 ;

 I 'BGPIPCUP S BGPSTOP=1 Q  ;must be ipc up

 I '$$FDMPRIOR(DFN,$$FMADD^XLFDT(BGPBDATE,-1)) S BGPSTOP=1 Q  ;NO DIAGNOSIS PRIOR TO REPORT PERIOD

 ;EXCLUSIONS

 S X=$$BLINDPL^BGP8D21A(DFN,BGPEDATE) I X S BGPSTOP=1 Q  ;BLIND

 S X=$$LASTDX^BGP8UTL1(DFN,"BGP BILATERAL BLINDNESS DXS",$$DOB^AUPNPAT(DFN),BGPEDATE) I X S BGPSTOP=1 Q  ;BLIND DX

 S X=$$EYEENUC^BGP8D21A(DFN,BGPEDATE) I X S BGPSTOP=1 Q  ;BLIND

 S X=$$AMP^BGP8D27(DFN,BGPEDATE) I X S BGPSTOP=1 Q  ;FOOT AMP

 ;

 S BGPVALUE=""

 S (BGPN1,BGPD1,BGPI1,BGPI2,BGPI3,BGPI4,BGPI5)=0

 S BGPD1=1  ;hit denominator

 ;

 S BGPI1=$$HGBA1C^BGP8D2(DFN,BGPBDATE,BGPEDATE)

 I BGPI1 S BGPVALUE=BGPVALUE_"A1c: "_$$DATE^BGP8UTL($P(BGPI1,U,3))_" "_$P(BGPI1,U,4)

 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPG

22 ;BPS to set numr 2

 S BGPV=""

 S BGPBP=$$LASTBP(DFN,BGPBDATE,BGPEDATE)  ;RETURN 1^EXT DATE BP VALUE

 ;I BGPBP="" S BGPBP=$$BPCPT(DFN,BGPBDATE,BGPEDATE) I BGPBP]"" S BGPI2=1 G BPS

 I BGPBP="" G BPS

 S BGPI2=1

 S BGPV=$P(BGPBP,U,2)

BPS ;

 I BGPV]"" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"BP: "_BGPV

 ;

23 ;

24 ;micro or pos urine & GFR

 S BGPGFR=$$GFR^BGP8D211(DFN,BGPBDATE,BGPEDATE)

 S BGPESRD=$$ESRD^BGP8D211(DFN,$P(^DPT(DFN,0),U,3),BGPEDATE)

 S BGPQUP=$$QUANTUP^BGP8D211(DFN,BGPBDATE,BGPEDATE)

 I $P(BGPESRD,U) S BGPI3=1

 I BGPGFR&(BGPQUP) S BGPI3=1

 I BGPI3 D

 .I BGPESRD S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_$S(BGPESRD]"":"ESRD: "_$$DATE^BGP8UTL($P(BGPESRD,U,3))_" "_$P(BGPESRD,U,2),1:"") Q

 .S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"GFR: "_$$DATE^BGP8UTL($P(BGPGFR,U,2))

 .S BGPVALUE=BGPVALUE_" & UACR: "_$$DATE^BGP8UTL($P(BGPQUP,U,3))_" "_$P(BGPQUP,U,2)

 K BGPX,BGPC

25 ;

 S BGPEYE=$$EYE^BGP8D21(DFN,BGPBDATE,BGPEDATE)

 S A=0 I $P(BGPEYE,U)=1 S A=1

 S B=0 I $P(BGPEYE,U)=2 S B=1

 S C=0 I $P(BGPEYE,U)=3 S C=1

 S BGPI4=0 I A!(B)!(C) S BGPI4=1

 I BGPI4 S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"EYE: "_$$DATE^BGP8UTL($P(BGPEYE,U,2))_" "_$P(BGPEYE,U,3)

 K BGPG

 K ^TMP($J,"A")

26 ;FOOT EXAM

 S BGPFOOT=$$FOOT^BGP8D213(DFN,BGPBDATE,BGPEDATE,1)

 S BGPI5=$P(BGPFOOT,U)

 I BGPI5 S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"FOOT EXAM: "_$$DATE^BGP8UTL($P(BGPFOOT,U,2))_" "_$P(BGPFOOT,U,3)

ALL I BGPI1,BGPI2,BGPI3,BGPI4,BGPI5 S BGPN1=1

 S BGPVALUE="IPCUP&DM DX|||"_BGPVALUE I BGPN1 S BGPVALUE=$P(BGPVALUE,"|||")_"|||*** "_$P(BGPVALUE,"|||",2)

CU1 K BGPBP,BGPLDL,BGPEYE,BGPUP,BGPLHGB,BGPG,BGPX,BGPC,BGPGFR,BGPFOOT,BGPBLIND,BGPI1,BGPI2,BGPI3,BGPI4,BGPI5

 K ^TMP($J,"A")

 Q

LASTBP(P,BDATE,EDATE) ;EP

 NEW S,D,C,E,BGPG,X,Y,G,T,M,A,Z,L

 S BGPG=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","BP")

 I BGPG Q 1_U_$$DATE^BGP8UTL($P(BGPG,U,2))_" "_$P(BGPG,U,4)

 K BGPG

 S T=$O(^ATXAX("B","BGP BP MEASURED CPT",0))

 I T D  I X]"" Q 1_U_$$DATE^BGP8UTL($P(X,U,1))_" "_$P(X,U,2)

 .S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q

 S BGPG=$$LASTDX^BGP8UTL1(P,"BGP HYPERTENSION SCREEN DXS",BDATE,EDATE) I BGPG Q 1_U_$$DATE^BGP8UTL($P(BGPG,U,3))_" "_$P(BGPG,U,2)

 S S=$$CPT^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP SYSTOLIC BP CPTS",0)),5)

 S D=$$CPT^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP DIASTOLIC BP CPTS",0)),5)

 I S,D Q 1_U_$$DATE^BGP8UTL($P(S,U,1))_"&"_$$DATE^BGP8UTL($P(D,U,1))_" "_$P(S,U,2)_"/"_$P(D,U,2)

 Q ""

FDMPRIOR(P,EDATE) ;EP

 I $G(P)="" Q ""

 NEW X,BGPG,E,Y

 K BGPG

 S Y="BGPG("

 S X=P_"^FIRST DX [SURVEILLANCE DIABETES;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE S E=$$START1^APCLDF(X,Y)

 I '$D(BGPG(1)) Q ""

 Q 1

STUFF ;

 S X="BGP IPC",DA=976

 F  S X=$O(^ATXAX("B",X)) Q:X=""!(X]"BGP IPCZZZZZZ")  D

 .Q:$D(^BGPTAXR("B",X))  ;already in there

 .S DA=DA+1

 .S ^BGPTAXR(DA,0)=X_"^D^^0"

 .S ^BGPTAXR("B",X,DA)=""

 .S ^BGPTAXR(DA,12,0)="^90560.0812S^1^1"

 .S ^BGPTAXR(DA,12,1,0)=8

 .S ^BGPTAXR(DA,12,"B",8,1)=""

 .W !,X

 Q

TESTBP ;

 S DFN=0

 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  S BGPBP=$$LASTBP(DFN,3120101,DT) I BGPBP W !,DFN," ",BGPBP

 Q

BGP8PC1   ;IHS/CMI/LAB - CALC MEASURES;  ; 12 Apr 2018  11:08 AM

 +1       ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

 +2       ;

PROC      ;EP

 +1        SET BGPBT=$HOROLOG

 +2        DO JRNL^BGP8PCUT

 +3        SET BGPJ=$JOB

           SET BGPH=$HOROLOG

 +4        KILL ^XTMP("BGP15TAX",$JOB),^XTMP("BGPSNOMEDSUBSET",$JOB)

 +5        DO UNFOLDTX^BGP8UTL2

 +6        DO XTMP^BGP8UTL("BGP8D","IPC Patient List")

 +7       ;calculate 3 years before end of each time frame

 +8        SET BGP3YE=$$FMADD^XLFDT(BGPED,-1096)

 +9        SET BGPP3YE=$$FMADD^XLFDT(BGPPED,-1096)

 +10       SET BGPB3YE=$$FMADD^XLFDT(BGPBED,-1096)

 +11      ;process each patient

 +12       SET DFN=0

           FOR 

               SET DFN=$ORDER(^AUPNPAT(DFN))

               IF DFN'=+DFN

                   QUIT 

               Begin DoDot:1

 +13               IF '$DATA(^AUPNPAT(DFN,0))

                       QUIT 

 +14      ;I DUZ=2881 Q:$$HRN^AUPNPAT(DFN,DUZ(2))'=144641

 +15               IF $PIECE($GET(^DPT(DFN,0)),U)["DEMO,PATIENT"

                       QUIT 

 +16               SET X=$ORDER(^DIBT("B","RPMS DEMO PATIENT NAMES",0))

                   IF X

                       IF $DATA(^DIBT(X,1,DFN))

                           QUIT 

 +17               DO PROCCY

                   DO PROCPY

                   DO PROCBY

               End DoDot:1

N         ;

 +1        SET BGPET=$HOROLOG

 +2        KILL ^XTMP("BGP15TAX",$JOB),^XTMP("BGPSNOMEDSUBSET",$JOB)

 +3        QUIT 

 +4       ;

PROCCY    ;EP - current time period

 +1        KILL ^TMP($JOB)

 +2        KILL BGPG

 +3        IF '$DATA(^DPT(DFN,0))

               QUIT 

 +4        IF $PIECE(^DPT(DFN,0),U,2)=""

               QUIT 

 +5        IF "FM"'[$PIECE(^DPT(DFN,0),U,2)

               QUIT 

 +6        SET BGPEDATE=BGPED

           SET BGPTIME=1

           SET BGPBDATE=BGPBD

           SET BGPGBL="^BGPGPDCR("

 +7        SET BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)

 +8        SET BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)

 +9        SET BGPSEX=$PIECE(^DPT(DFN,0),U,2)

 +10       IF '$$COMMBEN(DFN,BGPBEN,$GET(BGPTAXI),$GET(BGPCOMMI),$GET(BGPSEAT),BGPEDATE)

               QUIT 

 +11      ;user pop

           SET BGPIPCUP=$$IPCACTUP(DFN,BGPBDATE,BGPEDATE)

 +12       DO CALCIND

 +13       KILL ^TMP($JOB)

 +14       QUIT 

PROCPY    ;

 +1        KILL ^TMP($JOB)

 +2        KILL BGPG

 +3        IF '$DATA(^DPT(DFN,0))

               QUIT 

 +4        IF $PIECE(^DPT(DFN,0),U,2)=""

               QUIT 

 +5        IF "FM"'[$PIECE(^DPT(DFN,0),U,2)

               QUIT 

 +6        SET BGPEDATE=BGPPED

           SET BGPTIME=2

           SET BGPBDATE=BGPPBD

           SET BGPGBL="^BGPGPDPR("

 +7        SET BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)

 +8        SET BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)

 +9        SET BGPSEX=$PIECE(^DPT(DFN,0),U,2)

 +10       IF '$$COMMBEN(DFN,BGPBEN,$GET(BGPTAXI),$GET(BGPCOMMI),$GET(BGPSEAT),BGPEDATE)

               QUIT 

 +11      ;user pop

           SET BGPIPCUP=$$IPCACTUP(DFN,BGPBDATE,BGPEDATE)

 +12       DO CALCIND

 +13       KILL ^TMP($JOB)

 +14       QUIT 

PROCBY    ;

 +1        KILL ^TMP($JOB)

 +2        KILL BGPG

 +3        IF '$DATA(^DPT(DFN,0))

               QUIT 

 +4        IF $PIECE(^DPT(DFN,0),U,2)=""

               QUIT 

 +5        IF "FM"'[$PIECE(^DPT(DFN,0),U,2)

               QUIT 

 +6        SET BGPEDATE=BGPBED

           SET BGPTIME=3

           SET BGPBDATE=BGPBBD

           SET BGPGBL="^BGPGPDBR("

 +7        SET BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)

 +8        SET BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)

 +9        SET BGPSEX=$PIECE(^DPT(DFN,0),U,2)

 +10       IF '$$COMMBEN(DFN,BGPBEN,$GET(BGPTAXI),$GET(BGPCOMMI),$GET(BGPSEAT),BGPEDATE)

               QUIT 

 +11      ;user pop

           SET BGPIPCUP=$$IPCACTUP(DFN,BGPBDATE,BGPEDATE)

 +12       DO CALCIND

 +13       KILL ^TMP($JOB)

 +14       QUIT 

CALCIND   ;

 +1        DO CALCIND^BGP8PCCI

 +2        QUIT 

V2(P,BDATE,EDATE) ;EP

 +1        IF '$DATA(^AUPNVSIT("AC",P))

               QUIT ""

 +2        KILL ^TMP($JOB,"A")

 +3        NEW A,B,X,G,V,R

 +4        SET R=$NAME(^TMP($JOB,"A"))

 +5        DO ALLV^APCLAPIU(P,BDATE,EDATE,R)

 +6        IF '$DATA(^TMP($JOB,"A",1))

               QUIT ""

 +7        SET (X,G)=0

           FOR 

               SET X=$ORDER(^TMP($JOB,"A",X))

               IF X'=+X!(G>1)

                   QUIT 

               SET V=$PIECE(^TMP($JOB,"A",X),U,5)

               Begin DoDot:1

 +8                IF '$DATA(^AUPNVSIT(V,0))

                       QUIT 

 +9                IF '$PIECE(^AUPNVSIT(V,0),U,9)

                       QUIT 

 +10               IF $PIECE(^AUPNVSIT(V,0),U,11)

                       QUIT 

 +11               IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)

                       QUIT 

 +12               IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)

                       QUIT 

 +13               IF $PIECE(^AUPNVSIT(V,0),U,6)=""

                       QUIT 

 +14               SET G=G+1

 +15               QUIT 

               End DoDot:1

 +16       KILL ^TMP($JOB,"A")

 +17       QUIT $SELECT(G<2:"",1:1)

 +18      ;

COMMBEN(P,B,T,C,PP,EDATE) ;

 +1        NEW X

 +2       ;PATIENT PANEL AND PATIENT NOT IN THE PANEL

           IF PP

               IF '$DATA(^DIBT(PP,1,P))

                   QUIT 0

 +3       ;PATIENT IS IN PP

           IF PP

               IF $DATA(^DIBT(PP,1,P))

                   QUIT 1

 +4       ;must be Indian/Alaskan Native

           IF B=1

               IF $$BEN^AUPNPAT(P,"C")'="01"

                   QUIT 0

 +5       ;must not be I/A

           IF B=2

               IF $$BEN^AUPNPAT(P,"C")="01"

                   QUIT 0

 +6        SET DOD=$$DOD^AUPNPAT(P)

           IF DOD]""

               IF DOD<EDATE

                   QUIT 0

 +7       ;all communities

           IF T=""

               IF C=""

                   QUIT 1

 +8        IF C

               IF $PIECE($GET(^AUPNPAT(P,11)),U,17)'=C

                   QUIT 0

 +9        IF C

               IF $PIECE($GET(^AUPNPAT(P,11)),U,17)=C

                   QUIT 1

 +10       SET X=$PIECE($GET(^AUPNPAT(P,11)),U,18)

           IF X=""

               QUIT 0

 +11       IF '$DATA(^ATXAX(T,21,"B",($PIECE(^AUPNPAT(P,11),U,18))))

               IF '$DATA(^ATXAX(T,21,"AA",$PIECE(^AUPNPAT(P,11),U,18),$PIECE(^AUPNPAT(P,11),U,18)))

                   QUIT 0

 +12       QUIT 1

 +13      ;

IPCACTUP(P,BDATE,EDATE) ;EP - is this patient in user pop?

 +1        NEW X,DOD

 +2        SET DOD=$$DOD^AUPNPAT(P)

           IF DOD]""

               IF DOD<EDATE

                   QUIT 0

LVD       ;did they have 1 visit to IPC clinic list

           IF '$$V1(P,BDATE,EDATE)

               QUIT 0

 +1        QUIT 1

 +2       ;

V1(P,BDATE,EDATE) ;

 +1        NEW R,X,G,F,S,B,BGPV

 +2        DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")

 +3        SET (X,G,F,S)=0

           FOR 

               SET X=$ORDER(BGPV(X))

               IF X'=+X!(G)

                   QUIT 

               SET V=$PIECE(BGPV(X),U,5)

               Begin DoDot:1

 +4                IF '$DATA(^AUPNVSIT(V,0))

                       QUIT 

 +5                IF '$PIECE(^AUPNVSIT(V,0),U,9)

                       QUIT 

 +6                IF $PIECE(^AUPNVSIT(V,0),U,11)

                       QUIT 

 +7                IF '$DATA(^AUPNVPRV("AD",V))

                       QUIT 

 +8                IF "SAHOI"'[$PIECE(^AUPNVSIT(V,0),U,7)

                       QUIT 

 +9                IF $PIECE(^AUPNVSIT(V,0),U,6)=""

                       QUIT 

 +10      ;H visit has no clinic

                   IF $PIECE(^AUPNVSIT(V,0),U,7)="H"

                       SET G=1

                       QUIT 

 +11      ;I visit has no clinic

                   IF $PIECE(^AUPNVSIT(V,0),U,7)="I"

                       SET G=1

                       QUIT 

 +12               SET B=$$CLINIC^APCLV(V,"C")

 +13               IF B=""

                       QUIT 

 +14      ;must be a primary clinic S G=V

                   IF $DATA(^BGPCTRL($ORDER(^BGPCTRL("B",2018,0)),1101,"B",B))

                       SET G=1

               End DoDot:1

 +15       QUIT $SELECT(G:1,1:0)

DMC       ;EP

 +1       ;

 +2       ;must be ipc up

           IF 'BGPIPCUP

               SET BGPSTOP=1

               QUIT 

 +3       ;NO DIAGNOSIS PRIOR TO REPORT PERIOD

           IF '$$FDMPRIOR(DFN,$$FMADD^XLFDT(BGPBDATE,-1))

               SET BGPSTOP=1

               QUIT 

 +4       ;EXCLUSIONS

 +5       ;BLIND

           SET X=$$BLINDPL^BGP8D21A(DFN,BGPEDATE)

           IF X

               SET BGPSTOP=1

               QUIT 

 +6       ;BLIND DX

           SET X=$$LASTDX^BGP8UTL1(DFN,"BGP BILATERAL BLINDNESS DXS",$$DOB^AUPNPAT(DFN),BGPEDATE)

           IF X

               SET BGPSTOP=1

               QUIT 

 +7       ;BLIND

           SET X=$$EYEENUC^BGP8D21A(DFN,BGPEDATE)

           IF X

               SET BGPSTOP=1

               QUIT 

 +8       ;FOOT AMP

           SET X=$$AMP^BGP8D27(DFN,BGPEDATE)

           IF X

               SET BGPSTOP=1

               QUIT 

 +9       ;

 +10       SET BGPVALUE=""

 +11       SET (BGPN1,BGPD1,BGPI1,BGPI2,BGPI3,BGPI4,BGPI5)=0

 +12      ;hit denominator

           SET BGPD1=1

 +13      ;

 +14       SET BGPI1=$$HGBA1C^BGP8D2(DFN,BGPBDATE,BGPEDATE)

 +15       IF BGPI1

               SET BGPVALUE=BGPVALUE_"A1c: "_$$DATE^BGP8UTL($PIECE(BGPI1,U,3))_" "_$PIECE(BGPI1,U,4)

 +16       KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPG

22        ;BPS to set numr 2

 +1        SET BGPV=""

 +2       ;RETURN 1^EXT DATE BP VALUE

           SET BGPBP=$$LASTBP(DFN,BGPBDATE,BGPEDATE)

 +3       ;I BGPBP="" S BGPBP=$$BPCPT(DFN,BGPBDATE,BGPEDATE) I BGPBP]"" S BGPI2=1 G BPS

 +4        IF BGPBP=""

               GOTO BPS

 +5        SET BGPI2=1

 +6        SET BGPV=$PIECE(BGPBP,U,2)

BPS       ;

 +1        IF BGPV]""

               SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"BP: "_BGPV

 +2       ;

23        ;

24        ;micro or pos urine & GFR

 +1        SET BGPGFR=$$GFR^BGP8D211(DFN,BGPBDATE,BGPEDATE)

 +2        SET BGPESRD=$$ESRD^BGP8D211(DFN,$PIECE(^DPT(DFN,0),U,3),BGPEDATE)

 +3        SET BGPQUP=$$QUANTUP^BGP8D211(DFN,BGPBDATE,BGPEDATE)

 +4        IF $PIECE(BGPESRD,U)

               SET BGPI3=1

 +5        IF BGPGFR&(BGPQUP)

               SET BGPI3=1

 +6        IF BGPI3

               Begin DoDot:1

 +7                IF BGPESRD

                       SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_$SELECT(BGPESRD]"":"ESRD: "_$$DATE^BGP8UTL($PIECE(BGPESRD,U,3))_" "_$PIECE(BGPESRD,U,2),1:"")

                       QUIT 

 +8                SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"GFR: "_$$DATE^BGP8UTL($PIECE(BGPGFR,U,2))

 +9                SET BGPVALUE=BGPVALUE_" & UACR: "_$$DATE^BGP8UTL($PIECE(BGPQUP,U,3))_" "_$PIECE(BGPQUP,U,2)

               End DoDot:1

 +10       KILL BGPX,BGPC

25        ;

 +1        SET BGPEYE=$$EYE^BGP8D21(DFN,BGPBDATE,BGPEDATE)

 +2        SET A=0

           IF $PIECE(BGPEYE,U)=1

               SET A=1

 +3        SET B=0

           IF $PIECE(BGPEYE,U)=2

               SET B=1

 +4        SET C=0

           IF $PIECE(BGPEYE,U)=3

               SET C=1

 +5        SET BGPI4=0

           IF A!(B)!(C)

               SET BGPI4=1

 +6        IF BGPI4

               SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"EYE: "_$$DATE^BGP8UTL($PIECE(BGPEYE,U,2))_" "_$PIECE(BGPEYE,U,3)

 +7        KILL BGPG

 +8        KILL ^TMP($JOB,"A")

26        ;FOOT EXAM

 +1        SET BGPFOOT=$$FOOT^BGP8D213(DFN,BGPBDATE,BGPEDATE,1)

 +2        SET BGPI5=$PIECE(BGPFOOT,U)

 +3        IF BGPI5

               SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"FOOT EXAM: "_$$DATE^BGP8UTL($PIECE(BGPFOOT,U,2))_" "_$PIECE(BGPFOOT,U,3)

ALL        IF BGPI1

               IF BGPI2

                   IF BGPI3

                       IF BGPI4

                           IF BGPI5

                               SET BGPN1=1

 +1        SET BGPVALUE="IPCUP&DM DX|||"_BGPVALUE

           IF BGPN1

               SET BGPVALUE=$PIECE(BGPVALUE,"|||")_"|||*** "_$PIECE(BGPVALUE,"|||",2)

CU1        KILL BGPBP,BGPLDL,BGPEYE,BGPUP,BGPLHGB,BGPG,BGPX,BGPC,BGPGFR,BGPFOOT,BGPBLIND,BGPI1,BGPI2,BGPI3,BGPI4,BGPI5

 +1        KILL ^TMP($JOB,"A")

 +2        QUIT 

LASTBP(P,BDATE,EDATE) ;EP

 +1        NEW S,D,C,E,BGPG,X,Y,G,T,M,A,Z,L

 +2        SET BGPG=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","BP")

 +3        IF BGPG

               QUIT 1_U_$$DATE^BGP8UTL($PIECE(BGPG,U,2))_" "_$PIECE(BGPG,U,4)

 +4        KILL BGPG