BGP9D21 ; IHS/CMI/LAB - measure 6 ;
;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
;
I6 ;EP
K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPUP,BGPGFR
S (BGPN1,BGPN2,BGPN3,BGPN4)=0
I 'BGPDM1 S BGPSTOP=1 Q
DMNA ;EP - called from elder care
S BGPBD1=BGP365
S BGPBD2=BGPBDATE
I61 ;EP
S BGPGFR=$$GFR^BGP9D211(DFN,BGPBD1,BGPEDATE)
S BGPESRD=$$ESRD^BGP9D211(DFN,$P(^DPT(DFN,0),U,3),BGPEDATE)
S BGPQUP=$$QUANTUP^BGP9D211(DFN,BGPBD2,BGPEDATE)
S BGPHOLD=BGPGFR_"|"_BGPESRD_"|"_BGPQUP
I $P(BGPESRD,U) S BGPN1=1
I BGPGFR&(BGPQUP) S BGPN1=1
S BGPVALUE=$S(BGPDMD1:"UP",1:"")_$S(BGPDMD2:",AD",1:"")_$S(BGPDMD3:",AAD",1:"")_"|||"
I BGPN1 D
.I BGPESRD S BGPVALUE=BGPVALUE_$S(BGPESRD]"":"ESRD: "_$P(BGPESRD,U,2)_"-"_$$DATE^BGP9UTL($P(BGPESRD,U,3)),1:"") Q
.S BGPVALUE=BGPVALUE_";GFR: "_$$DATE^BGP9UTL($P(BGPGFR,U,2))
.S BGPVALUE=BGPVALUE_" & QUANT UP: "_$P(BGPQUP,U,2)_"-"_$$DATE^BGP9UTL($P(BGPQUP,U,3))
K BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG,BGPBD1,BGPBD2,BGPQUP,BGPESRD
Q
;
I7 ;EP
K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPVALUE,BGPEYE
I 'BGPDM1 S BGPSTOP=1 Q
DMEYE ;EP - called from elder care
S BGPEYE=$$EYE(DFN,BGP365,BGPEDATE)
S BGPN2=0 I $P(BGPEYE,U)=1 S BGPN2=1
S BGPN3=0 I $P(BGPEYE,U)=2 S BGPN3=1
S BGPN4=0 I $P(BGPEYE,U)=3 S BGPN4=1
S BGPN1=0 I BGPN3!(BGPN2)!(BGPN4) S BGPN1=1
S BGPN5=0 I BGPN2!(BGPN4) S BGPN5=1
S BGPVALUE=$S(BGPDMD1:"UP",1:"")_$S(BGPDMD2:",AD",1:"")_$S(BGPDMD3:",AAD",1:"")_"|||"_$$DATE^BGP9UTL($P(BGPEYE,U,2))_" "_$P(BGPEYE,U,3)
K BGPG
K ^TMP($J,"A")
Q
;
I8 ;EP
K BGPN1,BGPVALUE,BGPN2,BGPN3,BGPN4,BGPN5
S BGPN1=0
I '$G(BGPDMD2) S BGPSTOP=1 Q
S BGPVALUE=$$DENTSRV(DFN,BGPBDATE,BGPEDATE)
S BGPN1=0 I $P(BGPVALUE,U) S BGPN1=1
S BGPN2=0 I $P(BGPVALUE,U)=2 S BGPN2=1
S BGPN3=0 I BGPN1,'BGPN2 S BGPN3=1
S BGPVALUE="AD|||"_$$DATE^BGP9UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
Q
I9 ;EP
K BGPN1,BGPVALUE,BGPN2,BGPN3,BGPN4,BGPN5
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
I '$G(BGPACTUP) S BGPSTOP=1 Q
S BGPD1=1
S A=$$AGE^AUPNPAT(DFN,BGPBDATE)
I A<6 S BGPD2=1
I A>5,A<12 S BGPD3=1
I A>11,A<20 S BGPD4=1
I A>19,A<35 S BGPD5=1
I A>34,A<45 S BGPD6=1
I A>44,A<55 S BGPD7=1
I A>54,A<75 S BGPD8=1
I A>74 S BGPD9=1
S BGPVALUE=$$DENTSRV(DFN,BGPBDATE,BGPEDATE)
S BGPN1=0 I $P(BGPVALUE,U) S BGPN1=1
S BGPN2=0 I $P(BGPVALUE,U)=2 S BGPN2=1
S BGPN3=0 I BGPN1,'BGPN2 S BGPN3=1
S BGPVALUE="UP|||"_$$DATE^BGP9UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
Q
DENTSRV(P,BDATE,EDATE,FORECAST) ;EP
K BGPG
S FORECAST=$G(FORECAST)
S BGPC="",%=P_"^LAST ADA 0000;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPC=$P(BGPG(1),U)_"^"_"ADA "_$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)),$P(BGPG(1),U)>$P(BGPC,U) S BGPC=$P(BGPG(1),U)_"^"_"ADA "_$P(BGPG(1),U,2)
K BGPG S %=P_"^LAST EXAM DENTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)),$P(BGPG(1),U)>$P(BGPC,U) S BGPC=$P(BGPG(1),U)_"^"_$P(BGPG(1),U,3)
I BGPC]"",'FORECAST Q "1^"_BGPC
S BGPG=$$LASTDXI^BGP9UTL1(P,"V72.2",BDATE,EDATE)
I BGPG,'$G(FORECAST) Q "1^"_$P(BGPG,U,3)_"^V72.2"
I BGPG,$G(FORECAST),$P(BGPG,U,3)>$P(BGPC,U) S BGPC=$P(BGPG,U,3)_"^V72.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,3)="C" D
...I '$G(FORECAST) S G=1_"^"_$P(BGPG(X),U)_"^CHS VISIT ADA "_$P(BGPG(X),U,2) Q
...I $G(FORECAST),$P(BGPG(X),U)>$P(BGPC,U) S BGPC=$P(BGPG(X),U)_"^CHS ADA VISIT"
I BGPC]"" S BGPC=1_"^"_BGPC
I $G(FORECAST) D Q BGPC
.S G=$$REFUSAL^BGP9UTL1(P,9999999.15,$O(^AUTTEXAM("C",30,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
.I G,$P(G,U,2)>$P(BGPC,U,2) S BGPC="2^"_$P(G,U,2)_"^Refused EXAM 30"
.S G=$$REFUSAL^BGP9UTL1(P,9999999.31,$O(^AUTTADA("B","0000",0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
.I G,$P(G,U,2)>$P(BGPC,U,2) S BGPC="2^"_$P(G,U,2)_"^Refused ADA 0000"
.S G=$$REFUSAL^BGP9UTL1(P,9999999.31,$O(^AUTTADA("B",0190,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
.I G,$P(G,U,2)>$P(BGPC,U,2) S BGPC="2^"_$P(G,U,2)_"^Refused ADA 0190"
S G=$$REFUSAL^BGP9UTL1(P,9999999.15,$O(^AUTTEXAM("C",30,0)),BDATE,EDATE)
I $P(G,U)=1 Q "2^"_$P(G,U,2)_"^Refused EXAM 30"
S G=$$REFUSAL^BGP9UTL1(P,9999999.31,$O(^AUTTADA("B","0000",0)),BDATE,EDATE)
I $P(G,U)=1 Q "2^"_$P(G,U,2)_"^Refused ADA 0000"
S G=$$REFUSAL^BGP9UTL1(P,9999999.31,$O(^AUTTADA("B","0190",0)),BDATE,EDATE)
I $P(G,U)=1 Q "2^"_$P(G,U,2)_"^Refused ADA 0190"
Q ""
;
EYE(P,BDATE,EDATE) ;EP
S BGPLEYE=""
K BGPG S %=P_"^LAST EXAM DIABETIC EYE EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "1^"_$P(BGPG(1),U)_"^Diab Eye Ex"
;now check cpt taxonomies
S T=$O(^ATXAX("B","BGP DM RETINAL EXAM CPTS",0))
I T D I X]"",$P(BGPLEYE,U,2)<$P(X,U,1) Q 1_U_$P(X,U,1)_U_"CPT: "_$P(X,U,2)
.S X=$$CPT^BGP9DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP9DU(P,BDATE,EDATE,T,5)
K ^TMP($J,"A")
S A="^TMP($J,""A"","
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
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 Q 3_"^"_D_"^Cl: "_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=17!(R=18)!(R=64)),'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y Q $S(R="A2":3,1:3)_"^"_D_"^Cl: "_R
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=24!(R=79)!(R="08")),'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y Q "3^"_D_"^Prv: "_R
;
K BGPG S %=P_"^LAST DX V72.0;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "3^"_$P(BGPG(1),U)_"^V72.0 POV"
;
S T=$O(^ATXAX("B","BGP DM EYE EXAM CPTS",0))
I T D I X]"" Q 3_U_$P(X,U,1)_U_"CPT: "_$P(X,U,2)
.S X=$$CPT^BGP9DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP9DU(P,BDATE,EDATE,T,5)
S X=$$LASTPRCI^BGP9UTL1(P,"95.02",BDATE,EDATE) I X]"" Q 3_U_$P(X,U,3)_U_"PROC: 95.02"
S G=$$REFUSAL^BGP9UTL1(P,9999999.15,$O(^AUTTEXAM("B","DIABETIC EYE EXAM",0)),BDATE,EDATE)
I $P(G,U)=1 Q "2^"_$P(G,U,2)_"^Refused"
Q BGPLEYE
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 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_$$DATE^BGP9UTL((9999999-D)) Q
...I T1,$D(^ATXLAB(T1,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D) Q
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...S %=$P($G(^LAB(95.3,J,9999999)),U,2)
...I %="33914-3" S BGPC=1_U_(9999999-D) Q
...S J=$P($G(^LAB(95.3,J,0)),U)_"-"_$P($G(^LAB(95.3,J,0)),U,15)
...I J="33914-3" S BGPC=1_U_(9999999-D) Q
...Q
Q BGPC
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
K BGPG S %=P_"^LAST DX [BGP ESRD PMS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "1^ESRD 585.6^^"_$P(BGPG(1),U)
S X=$$LASTPRC^BGP9UTL1(P,"BGP ESRD PROCS",BDATE,EDATE)
I X Q 1_"^ESRD PROC "_$P(X,U,2)_"^^"_$P(X,U,3)
S T=$O(^ATXAX("B","BGP ESRD CPTS",0))
I T D I X]"" Q 1_U_"ESRD "_$P(X,U,2)_U_U_$P(X,U,1)
.S X=$$CPT^BGP9DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP9DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
Q 0
BGP9D21 ; IHS/CMI/LAB - measure 6 ;
+1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
+2 ;
I6 ;EP
+1 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPUP,BGPGFR
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4)=0
+3 IF 'BGPDM1
SET BGPSTOP=1
QUIT
DMNA ;EP - called from elder care
+1 SET BGPBD1=BGP365
+2 SET BGPBD2=BGPBDATE
I61 ;EP
+1 SET BGPGFR=$$GFR^BGP9D211(DFN,BGPBD1,BGPEDATE)
+2 SET BGPESRD=$$ESRD^BGP9D211(DFN,$PIECE(^DPT(DFN,0),U,3),BGPEDATE)
+3 SET BGPQUP=$$QUANTUP^BGP9D211(DFN,BGPBD2,BGPEDATE)
+4 SET BGPHOLD=BGPGFR_"|"_BGPESRD_"|"_BGPQUP
+5 IF $PIECE(BGPESRD,U)
SET BGPN1=1
+6 IF BGPGFR&(BGPQUP)
SET BGPN1=1
+7 SET BGPVALUE=$SELECT(BGPDMD1:"UP",1:"")_$SELECT(BGPDMD2:",AD",1:"")_$SELECT(BGPDMD3:",AAD",1:"")_"|||"
+8 IF BGPN1
Begin DoDot:1
+9 IF BGPESRD
SET BGPVALUE=BGPVALUE_$SELECT(BGPESRD]"":"ESRD: "_$PIECE(BGPESRD,U,2)_"-"_$$DATE^BGP9UTL($PIECE(BGPESRD,U,3)),1:"")
QUIT
+10 SET BGPVALUE=BGPVALUE_";GFR: "_$$DATE^BGP9UTL($PIECE(BGPGFR,U,2))
+11 SET BGPVALUE=BGPVALUE_" & QUANT UP: "_$PIECE(BGPQUP,U,2)_"-"_$$DATE^BGP9UTL($PIECE(BGPQUP,U,3))
End DoDot:1
+12 KILL BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG,BGPBD1,BGPBD2,BGPQUP,BGPESRD
+13 QUIT
+14 ;
I7 ;EP
+1 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPVALUE,BGPEYE
+2 IF 'BGPDM1
SET BGPSTOP=1
QUIT
DMEYE ;EP - called from elder care
+1 SET BGPEYE=$$EYE(DFN,BGP365,BGPEDATE)
+2 SET BGPN2=0
IF $PIECE(BGPEYE,U)=1
SET BGPN2=1
+3 SET BGPN3=0
IF $PIECE(BGPEYE,U)=2
SET BGPN3=1
+4 SET BGPN4=0
IF $PIECE(BGPEYE,U)=3
SET BGPN4=1
+5 SET BGPN1=0
IF BGPN3!(BGPN2)!(BGPN4)
SET BGPN1=1
+6 SET BGPN5=0
IF BGPN2!(BGPN4)
SET BGPN5=1
+7 SET BGPVALUE=$SELECT(BGPDMD1:"UP",1:"")_$SELECT(BGPDMD2:",AD",1:"")_$SELECT(BGPDMD3:",AAD",1:"")_"|||"_$$DATE^BGP9UTL($PIECE(BGPEYE,U,2))_" "_$PIECE(BGPEYE,U,3)
+8 KILL BGPG
+9 KILL ^TMP($JOB,"A")
+10 QUIT
+11 ;
I8 ;EP
+1 KILL BGPN1,BGPVALUE,BGPN2,BGPN3,BGPN4,BGPN5
+2 SET BGPN1=0
+3 IF '$GET(BGPDMD2)
SET BGPSTOP=1
QUIT
+4 SET BGPVALUE=$$DENTSRV(DFN,BGPBDATE,BGPEDATE)
+5 SET BGPN1=0
IF $PIECE(BGPVALUE,U)
SET BGPN1=1
+6 SET BGPN2=0
IF $PIECE(BGPVALUE,U)=2
SET BGPN2=1
+7 SET BGPN3=0
IF BGPN1
IF 'BGPN2
SET BGPN3=1
+8 SET BGPVALUE="AD|||"_$$DATE^BGP9UTL($PIECE(BGPVALUE,U,2))_" "_$PIECE(BGPVALUE,U,3)
+9 QUIT
I9 ;EP
+1 KILL BGPN1,BGPVALUE,BGPN2,BGPN3,BGPN4,BGPN5
+2 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+3 IF '$GET(BGPACTUP)
SET BGPSTOP=1
QUIT
+4 SET BGPD1=1
+5 SET A=$$AGE^AUPNPAT(DFN,BGPBDATE)
+6 IF A<6
SET BGPD2=1
+7 IF A>5
IF A<12
SET BGPD3=1
+8 IF A>11
IF A<20
SET BGPD4=1
+9 IF A>19
IF A<35
SET BGPD5=1
+10 IF A>34
IF A<45
SET BGPD6=1
+11 IF A>44
IF A<55
SET BGPD7=1
+12 IF A>54
IF A<75
SET BGPD8=1
+13 IF A>74
SET BGPD9=1
+14 SET BGPVALUE=$$DENTSRV(DFN,BGPBDATE,BGPEDATE)
+15 SET BGPN1=0
IF $PIECE(BGPVALUE,U)
SET BGPN1=1
+16 SET BGPN2=0
IF $PIECE(BGPVALUE,U)=2
SET BGPN2=1
+17 SET BGPN3=0
IF BGPN1
IF 'BGPN2
SET BGPN3=1
+18 SET BGPVALUE="UP|||"_$$DATE^BGP9UTL($PIECE(BGPVALUE,U,2))_" "_$PIECE(BGPVALUE,U,3)
+19 QUIT
DENTSRV(P,BDATE,EDATE,FORECAST) ;EP
+1 KILL BGPG
+2 SET FORECAST=$GET(FORECAST)
+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))
SET BGPC=$PIECE(BGPG(1),U)_"^"_"ADA "_$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))
IF $PIECE(BGPG(1),U)>$PIECE(BGPC,U)
SET BGPC=$PIECE(BGPG(1),U)_"^"_"ADA "_$PIECE(BGPG(1),U,2)
+8 KILL BGPG
SET %=P_"^LAST EXAM DENTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+9 IF $DATA(BGPG(1))
IF $PIECE(BGPG(1),U)>$PIECE(BGPC,U)
SET BGPC=$PIECE(BGPG(1),U)_"^"_$PIECE(BGPG(1),U,3)
+10 IF BGPC]""
IF 'FORECAST
QUIT "1^"_BGPC
+11 SET BGPG=$$LASTDXI^BGP9UTL1(P,"V72.2",BDATE,EDATE)
+12 IF BGPG
IF '$GET(FORECAST)
QUIT "1^"_$PIECE(BGPG,U,3)_"^V72.2"
+13 IF BGPG
IF $GET(FORECAST)
IF $PIECE(BGPG,U,3)>$PIECE(BGPC,U)
SET BGPC=$PIECE(BGPG,U,3)_"^V72.2"
+14 KILL BGPG
SET G=""
SET %=P_"^ALL ADA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+15 IF $DATA(BGPG)
Begin DoDot:1
+16 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET V=$PIECE(BGPG(X),U,5)
Begin DoDot:2
+17 IF $PIECE($GET(^AUPNVSIT(V,0)),U,3)="C"
Begin DoDot:3
+18 IF '$GET(FORECAST)
SET G=1_"^"_$PIECE(BGPG(X),U)_"^CHS VISIT ADA "_$PIECE(BGPG(X),U,2)
QUIT
+19 IF $GET(FORECAST)
IF $PIECE(BGPG(X),U)>$PIECE(BGPC,U)
SET BGPC=$PIECE(BGPG(X),U)_"^CHS ADA VISIT"
End DoDot:3
End DoDot:2
End DoDot:1
IF G]""
IF '$GET(FORECAST)
QUIT G
+20 IF BGPC]""
SET BGPC=1_"^"_BGPC
+21 IF $GET(FORECAST)
Begin DoDot:1
+22 SET G=$$REFUSAL^BGP9UTL1(P,9999999.15,$ORDER(^AUTTEXAM("C",30,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
+23 IF G
IF $PIECE(G,U,2)>$PIECE(BGPC,U,2)
SET BGPC="2^"_$PIECE(G,U,2)_"^Refused EXAM 30"
+24 SET G=$$REFUSAL^BGP9UTL1(P,9999999.31,$ORDER(^AUTTADA("B","0000",0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
+25 IF G
IF $PIECE(G,U,2)>$PIECE(BGPC,U,2)
SET BGPC="2^"_$PIECE(G,U,2)_"^Refused ADA 0000"
+26 SET G=$$REFUSAL^BGP9UTL1(P,9999999.31,$ORDER(^AUTTADA("B",0190,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
+27 IF G
IF $PIECE(G,U,2)>$PIECE(BGPC,U,2)
SET BGPC="2^"_$PIECE(G,U,2)_"^Refused ADA 0190"
End DoDot:1
QUIT BGPC
+28 SET G=$$REFUSAL^BGP9UTL1(P,9999999.15,$ORDER(^AUTTEXAM("C",30,0)),BDATE,EDATE)
+29 IF $PIECE(G,U)=1
QUIT "2^"_$PIECE(G,U,2)_"^Refused EXAM 30"
+30 SET G=$$REFUSAL^BGP9UTL1(P,9999999.31,$ORDER(^AUTTADA("B","0000",0)),BDATE,EDATE)
+31 IF $PIECE(G,U)=1
QUIT "2^"_$PIECE(G,U,2)_"^Refused ADA 0000"
+32 SET G=$$REFUSAL^BGP9UTL1(P,9999999.31,$ORDER(^AUTTADA("B","0190",0)),BDATE,EDATE)
+33 IF $PIECE(G,U)=1
QUIT "2^"_$PIECE(G,U,2)_"^Refused ADA 0190"
+34 QUIT ""
+35 ;
EYE(P,BDATE,EDATE) ;EP
+1 SET BGPLEYE=""
+2 KILL BGPG
SET %=P_"^LAST EXAM DIABETIC EYE EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+3 IF $DATA(BGPG(1))
QUIT "1^"_$PIECE(BGPG(1),U)_"^Diab Eye Ex"
+4 ;now check cpt taxonomies
+5 SET T=$ORDER(^ATXAX("B","BGP DM RETINAL EXAM CPTS",0))
+6 IF T
Begin DoDot:1
+7 SET X=$$CPT^BGP9DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+8 SET X=$$TRAN^BGP9DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(BGPLEYE,U,2)<$PIECE(X,U,1)
QUIT 1_U_$PIECE(X,U,1)_U_"CPT: "_$PIECE(X,U,2)
+9 KILL ^TMP($JOB,"A")
+10 SET A="^TMP($J,""A"","
+11 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+12 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)
+13 IF Y
QUIT 3_"^"_D_"^Cl: "_R
+14 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=17!(R=18)!(R=64))
IF '$$DNKA($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+15 IF Y
QUIT $SELECT(R="A2":3,1:3)_"^"_D_"^Cl: "_R
+16 SET (X,Y)=0
SET D=""
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(Y)
QUIT
SET R=$$PRIMPROV^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"D")
IF (R=24!(R=79)!(R="08"))
IF '$$DNKA($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+17 IF Y
QUIT "3^"_D_"^Prv: "_R
+18 ;
+19 KILL BGPG
SET %=P_"^LAST DX V72.0;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+20 IF $DATA(BGPG(1))
QUIT "3^"_$PIECE(BGPG(1),U)_"^V72.0 POV"
+21 ;
+22 SET T=$ORDER(^ATXAX("B","BGP DM EYE EXAM CPTS",0))
+23 IF T
Begin DoDot:1
+24 SET X=$$CPT^BGP9DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+25 SET X=$$TRAN^BGP9DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
QUIT 3_U_$PIECE(X,U,1)_U_"CPT: "_$PIECE(X,U,2)
+26 SET X=$$LASTPRCI^BGP9UTL1(P,"95.02",BDATE,EDATE)
IF X]""
QUIT 3_U_$PIECE(X,U,3)_U_"PROC: 95.02"
+27 SET G=$$REFUSAL^BGP9UTL1(P,9999999.15,$ORDER(^AUTTEXAM("B","DIABETIC EYE EXAM",0)),BDATE,EDATE)
+28 IF $PIECE(G,U)=1
QUIT "2^"_$PIECE(G,U,2)_"^Refused"
+29 QUIT BGPLEYE
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 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
+5 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+7 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+8 IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+9 IF T
IF $PIECE(^AUPNVLAB(X,0),U)=T
SET BGPC=1_U_$$DATE^BGP9UTL((9999999-D))
QUIT
+10 IF T1
IF $DATA(^ATXLAB(T1,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_(9999999-D)
QUIT
+11 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+12 SET %=$PIECE($GET(^LAB(95.3,J,9999999)),U,2)
+13 IF %="33914-3"
SET BGPC=1_U_(9999999-D)
QUIT
+14 SET J=$PIECE($GET(^LAB(95.3,J,0)),U)_"-"_$PIECE($GET(^LAB(95.3,J,0)),U,15)
+15 IF J="33914-3"
SET BGPC=1_U_(9999999-D)
QUIT
+16 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+17 QUIT BGPC
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 KILL BGPG
SET %=P_"^LAST DX [BGP ESRD PMS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+2 IF $DATA(BGPG(1))
QUIT "1^ESRD 585.6^^"_$PIECE(BGPG(1),U)
+3 SET X=$$LASTPRC^BGP9UTL1(P,"BGP ESRD PROCS",BDATE,EDATE)
+4 IF X
QUIT 1_"^ESRD PROC "_$PIECE(X,U,2)_"^^"_$PIECE(X,U,3)
+5 SET T=$ORDER(^ATXAX("B","BGP ESRD CPTS",0))
+6 IF T
Begin DoDot:1
+7 SET X=$$CPT^BGP9DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
IF X]""
QUIT
+8 SET X=$$TRAN^BGP9DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
End DoDot:1
IF X]""
QUIT 1_U_"ESRD "_$PIECE(X,U,2)_U_U_$PIECE(X,U,1)
+9 QUIT 0
