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
+5 SET T=$ORDER(^ATXAX("B","BGP BP MEASURED CPT",0))
+6 IF T
Begin DoDot:1
+7 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
End DoDot:1
IF X]""
QUIT 1_U_$$DATE^BGP8UTL($PIECE(X,U,1))_" "_$PIECE(X,U,2)
+8 SET BGPG=$$LASTDX^BGP8UTL1(P,"BGP HYPERTENSION SCREEN DXS",BDATE,EDATE)
IF BGPG
QUIT 1_U_$$DATE^BGP8UTL($PIECE(BGPG,U,3))_" "_$PIECE(BGPG,U,2)
+9 SET S=$$CPT^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP SYSTOLIC BP CPTS",0)),5)
+10 SET D=$$CPT^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP DIASTOLIC BP CPTS",0)),5)
+11 IF S
IF D
QUIT 1_U_$$DATE^BGP8UTL($PIECE(S,U,1))_"&"_$$DATE^BGP8UTL($PIECE(D,U,1))_" "_$PIECE(S,U,2)_"/"_$PIECE(D,U,2)
+12 QUIT ""
FDMPRIOR(P,EDATE) ;EP
+1 IF $GET(P)=""
QUIT ""
+2 NEW X,BGPG,E,Y
+3 KILL BGPG
+4 SET Y="BGPG("
+5 SET X=P_"^FIRST DX [SURVEILLANCE DIABETES;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+6 IF '$DATA(BGPG(1))
QUIT ""
+7 QUIT 1
STUFF ;
+1 SET X="BGP IPC"
SET DA=976
+2 FOR
SET X=$ORDER(^ATXAX("B",X))
IF X=""!(X]"BGP IPCZZZZZZ")
QUIT
Begin DoDot:1
+3 ;already in there
IF $DATA(^BGPTAXR("B",X))
QUIT
+4 SET DA=DA+1
+5 SET ^BGPTAXR(DA,0)=X_"^D^^0"
+6 SET ^BGPTAXR("B",X,DA)=""
+7 SET ^BGPTAXR(DA,12,0)="^90560.0812S^1^1"
+8 SET ^BGPTAXR(DA,12,1,0)=8
+9 SET ^BGPTAXR(DA,12,"B",8,1)=""
+10 WRITE !,X
End DoDot:1
+11 QUIT
TESTBP ;
+1 SET DFN=0
+2 FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
SET BGPBP=$$LASTBP(DFN,3120101,DT)
IF BGPBP
WRITE !,DFN," ",BGPBP
+3 QUIT
