APCHPWH5 ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;
;;2.0;IHS PCC SUITE;**2,5,7,11**;MAY 14, 2009;Build 58
;
CCI ;EP - EO measures
I '$O(^APCHPWHT(APCHPWHT,12,0)) Q
Q:$$AGE^AUPNPAT(APCHSDFN)<18
NEW APCHSTO,APCHSTM,APCHSTCE
D SUBHEAD^APCHPWHU
D S^APCHPWH1("CCI Measures")
;
;go through each one
S APCHSTO=0 F S APCHSTO=$O(^APCHPWHT(APCHPWHT,12,APCHSTO)) Q:APCHSTO'=+APCHSTO D
.S APCHSTM=$P($G(^APCHPWHT(APCHPWHT,12,APCHSTO,0)),U,2)
.Q:'APCHSTM
.Q:'$D(^APCHPWHI(APCHSTM,0))
.S APCHSTCE=$G(^APCHPWHI(APCHSTM,1))
.I APCHSTCE="" Q
.X APCHSTCE
.Q
Q
;
LDL ;EP - cholesterol CCI measure
NEW APCHCHOL,APCHD,APCHDM
Q:$$AGE^AUPNPAT(APCHSDFN)<18
D SUBHEAD^APCHPWHU
D S^APCHPWH1("CHOLESTEROL")
D S^APCHPWH1("Controlling your cholesterol can keep your heart and blood vessels healthy.")
S APCHCHOL=$$CHOLTST(APCHSDFN)
D S^APCHPWH1("")
I APCHCHOL="" D Q
.D S^APCHPWH1("No recent cholesterol is on file. We recommend that you have your ")
.D S^APCHPWH1("cholesterol rechecked at your next visit.")
D S^APCHPWH1("Your total cholesterol result was "_$S($P(APCHCHOL,U,1)]"":$P(APCHCHOL,U,2)_" on "_$$FMTE^XLFDT($P(APCHCHOL,U,1))_".",1:"not found on file."))
D S^APCHPWH1("Your last LDL (bad cholesterol) result was "_$S($P(APCHCHOL,U,3)]"":$P(APCHCHOL,U,4)_" on "_$$FMTE^XLFDT($P(APCHCHOL,U,3))_".",1:"not found on file."))
D S^APCHPWH1("Your last HDL (good cholesterol) result was "_$S($P(APCHCHOL,U,5)]"":$P(APCHCHOL,U,6)_" on "_$$FMTE^XLFDT($P(APCHCHOL,U,5))_".",1:"not found on file."))
D S^APCHPWH1("Your last triglyceride result was "_$S($P(APCHCHOL,U,7)]"":$P(APCHCHOL,U,8)_" on "_$$FMTE^XLFDT($P(APCHCHOL,U,7))_".",1:"not found on file."))
S APCHDM=0 I $$DMDX^APCHPWH2(APCHSDFN)!($$AMIO(APCHSDFN,DT)) S APCHDM=1
S APCHLDL=+$P(APCHCHOL,U,4),APCHD=$P(APCHCHOL,U,3)
I $P(APCHCHOL,U,4)=""!($$FMDIFF^XLFDT(DT,APCHD)>$S(APCHDM:365,1:(5*365))) D G LDL2
.D S^APCHPWH1("No recent LDL cholesterol test is on file. We recommend that you have your",1)
.D S^APCHPWH1("cholesterol rechecked at your next visit.")
I APCHDM,APCHLDL,APCHLDL<100 D
.D S^APCHPWH1("LDL (bad cholesterol) should be under 100 mg/dL. Your LDL cholesterol",1)
.D S^APCHPWH1("is good! You should have your cholesterol checked every year.")
I APCHDM,APCHLDL,APCHLDL'<100 D
.D S^APCHPWH1("It is best when your LDL (bad cholesterol) is less than 100 mg/dl. Ask",1)
.D S^APCHPWH1("your provider about ways to lower your cholesterol.")
;LDL1 ;
;S APCHD=$P(APCHCHOL,U)
;S D=$P(APCHCHOL,U,3) I D]"",D>APCHD S APCHD=D
;S D=$P(APCHCHOL,U,5) I D]"",D>APCHD S APCHD=D
;S D=$P(APCHCHOL,U,7) I D]"",D>APCHD S APCHD=D
;I $$FMDIFF^XLFDT(DT,APCHD)>$S(APCHDM:365,1:(5*365)) D
;.D S^APCHPWH1("No recent cholesterol is on file. You should have your cholesterol",1)
;.D S^APCHPWH1("rechecked at your next visit.")
LDL2 ;
I +$P(APCHCHOL,U,8)>500 D
.D S^APCHPWH1("High triglyceride levels can hurt your pancreas and cause health",1)
.D S^APCHPWH1("problems such as pain and poor digestion. Ask your provider about how")
.D S^APCHPWH1("you can lower your triglycerides.")
Q
;
CVD(P) ;EP
;check problem list OR must have 3 diagnoses
N T,X,Y,I,APCHX,BDATE,EDATE
S T=$O(^ATXAX("B","BGP IHD DXS",0))
I 'T Q ""
S (X,Y,I)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)),$P(^AUPNPROB(X,0),U,12)'="D" S Y=$P(^AUPNPROB(X,0),U) I $$ICD^ATXAPI(Y,T,9) S I=1
I I Q 1
S BDATE=$$DOB^AUPNPAT(P)
S EDATE=DT
K ^TMP($J,"A")
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S T=$O(^ATXAX("B","BGP IHD DXS",0))
I 'T Q ""
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G>3) 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 (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) I $D(^AUPNVPOV(Y,0)) S %=$P(^AUPNVPOV(Y,0),U) I $$ICD^ATXAPI(%,T,9) S D=1
.Q:'D
.S G=G+1
.Q
K ^TMP($J,"A")
Q $S(G<3:"",1:1)
;
AMIO(P,EDATE) ;
NEW APCHG
K APCHG
S Y="APCHG("
S X=P_"^LAST DX [BGP AMI DXS (HEDIS);DURING "_$$FMADD^XLFDT(EDATE,-365)_"-"_$$FMADD^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(APCHG(1)) Q 1
;check for procedure in BGP CABG PROCS
S APCHG=$$LASTPRC^APCHSMU2(P,"BGP CABG PROCS",$$FMADD^XLFDT(EDATE,-365),$$FMADD^XLFDT(EDATE))
I $P(APCHG,U) Q 1
;now check cpts
S APCHG=$$CPT^APCHPWHU(P,$$FMADD^XLFDT(EDATE,-365),$$FMADD^XLFDT(EDATE),$O(^ATXAX("B","BGP CABG CPTS",0)),6)
I $P(APCHG,U) Q 1
S APCHG=$$TRAN^APCHPWHU(P,$$FMADD^XLFDT(EDATE,-365),$$FMADD^XLFDT(EDATE),$O(^ATXAX("B","BGP CABG CPTS",0)),6)
I $P(APCHG,U) Q 1
;check for procedure in BGP PTCA PROCS
S APCHG=$$LASTPRC^APCHSMU2(P,"BGP PCI CM PROCS",$$FMADD^XLFDT(EDATE,-365),$$FMADD^XLFDT(EDATE))
I $P(APCHG,U) Q 1
;now check cpts
S APCHG=$$CPT^APCHPWHU(P,$$FMADD^XLFDT(EDATE,-365),$$FMADD^XLFDT(EDATE),$O(^ATXAX("B","BGP PTCA CPTS",0)),6)
I $P(APCHG,U) Q 1
S APCHG=$$TRAN^APCHPWHU(P,$$FMADD^XLFDT(EDATE,-365),$$FMADD^XLFDT(EDATE),$O(^ATXAX("B","BGP PTCA CPTS",0)),6)
I $P(APCHG,U) Q 1
;now check IVD dxs
S APCHG(1)=$$LASTDX^APCHSMU2(P,"BGP IVD DXS",$$FMADD^XLFDT(EDATE,-(365*2)),EDATE)
I $P(APCHG(1),U) Q 1
Q ""
;
CHOLTST(P) ;
;get all cholesterol tests in APCHC
NEW APCHC,APCHL,APCHT,APCHH,D,R
S R=""
D LABS(P,"DM AUDIT CHOLESTEROL TAX","BGP TOTAL CHOLESTEROL LOINC",.APCHC)
D LABS(P,"DM AUDIT LDL CHOLESTEROL TAX","BGP LDL LOINC CODES",.APCHL)
D LABS(P,"DM AUDIT HDL TAX","BGP HDL LOINC CODES",.APCHH)
D LABS(P,"DM AUDIT TRIGLYCERIDE TAX","BGP TRIGLYCERIDE LOINC CODES",.APCHT)
;
S D=0 S D=$O(APCHC(D)) I D S R=(9999999-D)_U_$P(APCHC(D),U,2)_" "_$P($G(^AUPNVLAB($P(APCHC(D),U,3),11)),U,1)
S D=0 S D=$O(APCHL(D)) I D S $P(R,U,3)=$P(APCHL(D),U,1),$P(R,U,4)=$P(APCHL(D),U,2)
S D=0 S D=$O(APCHH(D)) I D S $P(R,U,5)=$P(APCHH(D),U,1),$P(R,U,6)=$P(APCHH(D),U,2)
S D=0 S D=$O(APCHT(D)) I D S $P(R,U,7)=$P(APCHT(D),U,1),$P(R,U,8)=$P(APCHT(D),U,2)
Q R
;
LABS(P,APCHLT,APCHLOT,APCHT) ;EP - get result of HGBA1c in past year. If no result pass null
;pass back date_u_result
NEW APCHG,E,%,L,T,D,X,J,C,G
;now get all loinc/taxonomy tests
I APCHLOT]"" S APCHLOT=$O(^ATXAX("B",APCHLOT,0))
I APCHLT]"" S APCHLT=$O(^ATXLAB("B",APCHLT,0))
S B=9999999-$$DOB^AUPNPAT(P),E=9999999-DT S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...Q:$P(^AUPNVLAB(X,0),U,4)=""
...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))="COMMENT"
...Q:'+$P(^AUPNVLAB(X,0),U,4)
...I APCHLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCHLT,21,"B",$P(^AUPNVLAB(X,0),U))) S APCHT(D)=(9999999-D)_U_+$P(^AUPNVLAB(X,0),U,4)_U_X Q
...Q:'APCHLOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,APCHLOT)
...S APCHT(D)=(9999999-D)_U_+$P(^AUPNVLAB(X,0),U,4)_U_X
...Q
Q
;
;
LOINC(A,B) ;EP
NEW %
I '$G(B) Q ""
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 ""
;
DC ;EP - diabetes comprehensive care
NEW APCHA1C,R,V,APCHKT
Q:'$$DMDX^APCHPWH2(APCHSDFN) ;not diabetic
D SUBHEAD^APCHPWHU
D S^APCHPWH1("DIABETES CARE")
AIC ;a1c
S APCHA1C=$$HGBA1C^APCHPWH4(APCHSDFN,,,1)
D S^APCHPWH1("HEMOGLOBIN A1c",1)
D S^APCHPWH1("Hemoglobin A1c is a test that measures your blood sugar control over a 3-month")
D S^APCHPWH1("period. We recommend that you have this test done every 3-6 months.")
I APCHA1C]"" D S^APCHPWH1("Your last A1c test on file was "_$P(APCHA1C,U,2)_" done on "_$P(APCHA1C,U)_".")
I APCHA1C=""!($$FMDIFF^XLFDT(DT,$P(APCHA1C,U,3))>365) D G KT
.D S^APCHPWH1("We recommend that you have your A1c tested. Ask your health care provider",1)
.D S^APCHPWH1("to order an A1c test for you.")
S V=$P(APCHA1C,U,2)
S R=$S(V[">":3,V["<":1,$E(V)'=+$E(V):"",V<7.0:1,V>6.9&(V<9.0):2,V>8.9:3,1:"")
I R=1 D
.D S^APCHPWH1("An A1c value that is less than 7% shows great blood sugar control. You",1)
.D S^APCHPWH1("are doing great!")
I R=2 D
.D S^APCHPWH1("Ask your health care provider how you can keep lowering your A1c.",1)
I R=3 D
.D S^APCHPWH1("Your A1c is too high. Ask your health care provider about ways to lower",1)
.D S^APCHPWH1("your A1c.")
KT ;kidney assessment
D S^APCHPWH1("DIABETES KIDNEY ASSESSMENT",1)
D S^APCHPWH1("Diabetes can cause kidney damage. There are tests that can see how well your")
D S^APCHPWH1("kidneys are working. Getting these tests at least once a year can help your ")
D S^APCHPWH1("health care provider protect your kidneys and lower your risk of getting ")
D S^APCHPWH1("kidney damage and dialysis.")
S APCHKT=$$KIDNEYT(APCHSDFN,$$FMADD^XLFDT(DT,-365),DT)
I APCHKT="" D
.D S^APCHPWH1("We recommend that you have your kidneys tested to see how well they are ",1)
.D S^APCHPWH1("working every year. Ask your health care provider to order a kidney ")
.D S^APCHPWH1("function test for you.")
I APCHKT]"" D
.D S^APCHPWH1("Your kidneys were tested on "_$$FMTE^XLFDT($P(APCHKT,U))_". We recommend that you ",1)
.D S^APCHPWH1("have your kidneys tested again on "_$$FMTE^XLFDT($$FMADD^XLFDT($P(APCHKT,U),365))_".")
EYE ;EYE
D S^APCHPWH1("DIABETES EYE EXAM",1)
D S^APCHPWH1("Diabetes can affect your eyes and vision. Early detection of eye problems ")
D S^APCHPWH1("can help you to get the treatment you need to lower your chances of having ")
D S^APCHPWH1("problems such as blurred vision or blindness.")
S APCHKT=$$EYET(APCHSDFN,$$DOB^AUPNPAT(APCHSDFN),DT)
I 'APCHKT D G FOOT
.D S^APCHPWH1("We recommend that you have at least one diabetes eye exam every year.",1)
.D S^APCHPWH1("Ask your health care provider to order a diabetes eye exam for you.")
I APCHKT,$$FMDIFF^XLFDT(DT,$P(APCHKT,U,2))<365 D G FOOT
.D S^APCHPWH1("Your last diabetes eye exam was done on "_$$FMTE^XLFDT($P(APCHKT,U,2))_". We recommend",1)
.D S^APCHPWH1("that you have another eye exam by "_$$FMTE^XLFDT($$FMADD^XLFDT($P(APCHKT,U,2),365))_".")
D S^APCHPWH1("Your last diabetes eye exam was done on "_$$FMTE^XLFDT($P(APCHKT,U,2))_".")
D S^APCHPWH1("We recommend that you have at least one diabetes eye exam every year. ",1)
D S^APCHPWH1("Ask your health care provider to order a diabetes eye exam for you.")
D S^APCHPWH1("DIABETES FOOT EXAM",1)
D S^APCHPWH1("Diabetes can make your feet hurt or feel numb. Having a diabetes foot")
D S^APCHPWH1("exam every year can help keep your feet healthy.")
S APCHKT=$$FOOTEX^APCHPWH6(APCHSDFN,$$DOB^AUPNPAT(APCHSDFN),DT)
I 'APCHKT D Q
.D S^APCHPWH1("We recommend that you have at least one diabetes foot exam every year.",1)
.D S^APCHPWH1("Ask your health care provider to order a diabetes foot exam for you.")
I APCHKT,$$FMDIFF^XLFDT(DT,$P(APCHKT,U))<365 D Q
.D S^APCHPWH1("Your last diabetes foot exam was done on "_$$FMTE^XLFDT($P(APCHKT,U))_". We recommend",1)
.D S^APCHPWH1("that you have another foot exam by "_$$FMTE^XLFDT($$FMADD^XLFDT($P(APCHKT,U),365))_".")
D S^APCHPWH1("Your last diabetes foot exam was done on "_$$FMTE^XLFDT($P(APCHKT,U))_".")
D S^APCHPWH1("We recommend that you have at least one diabetes foot exam every year. ",1)
D S^APCHPWH1("Ask your health care provider to order a diabetes foot exam for you.")
Q
KIDNEYT(P,BDATE,EDATE) ;
;pass back date_u_result
NEW APCHG,E,%,L,T,D,X,J,C,G,B,APCHACT,APCHACLT,APCHPCT,APCHPCLT,APCHQUT,APCHQULT,APCHT
;now get all loinc/taxonomy tests
S APCHACT=$O(^ATXLAB("B","DM AUDIT A/C RATIO TAX",0))
S APCHACLT=$O(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
S APCHPCT=$O(^ATXLAB("B","DM AUDIT P/C RATIO TAX",0))
S APCHPCLT=$O(^ATXAX("B","DM AUDIT P/C RATIO LOINC",0))
S APCHQULT=$O(^ATXAX("B","BGP QUANT URINE PROT LOINC",0))
S APCHQUT=$O(^ATXLAB("B","BGP QUANT URINE PROTEIN",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) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...Q:'$P(^AUPNVLAB(X,0),U)
...I APCHACT,$D(^ATXLAB(APCHACT,21,"B",$P(^AUPNVLAB(X,0),U))) S APCHT(D)=(9999999-D)_U_+$P(^AUPNVLAB(X,0),U,4)_U_X Q
...I APCHPCT,$D(^ATXLAB(APCHACT,21,"B",$P(^AUPNVLAB(X,0),U))) S APCHT(D)=(9999999-D)_U_+$P(^AUPNVLAB(X,0),U,4)_U_X Q
...I APCHQUT,$D(^ATXLAB(APCHACT,21,"B",$P(^AUPNVLAB(X,0),U))) S APCHT(D)=(9999999-D)_U_+$P(^AUPNVLAB(X,0),U,4)_U_X Q
...;
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...I $$LOINC(J,APCHACLT)!($$LOINC(J,APCHPCLT))!($$LOINC(J,APCHQULT)) D Q
....S APCHT(D)=(9999999-D)_U_+$P(^AUPNVLAB(X,0),U,4)_U_X
...Q
I '$D(APCHT) Q ""
S D=0,G=$O(APCHT(D))
Q APCHT(G)
;
EYET(P,BDATE,EDATE) ;
NEW A,%,APCHLEYE,APCHG,Y,X,D,R,T
S APCHLEYE=""
K APCHG S %=P_"^LAST EXAM DIABETIC EYE EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"APCHG(")
I $D(APCHG(1)) S APCHLEYE="1^"_$P(APCHG(1),U)_"^Diab Eye Ex"
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^APCHS9B4($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y,$P(APCHLEYE,U,2)<D S APCHLEYE=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^APCHS9B4($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y,$P(APCHLEYE,U,2)<D S APCHLEYE=$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^APCHS9B4($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y,$P(APCHLEYE,U,2)<D S APCHLEYE="3^"_D_"^Prv: "_R
;
;K APCHG S %=P_"^LAST DX V72.0;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"APCHG(")
;I $D(APCHG(1)),$P(APCHLEYE,U,2)<$P(APCHG(1),U) S APCHLEYE="3^"_$P(APCHG(1),U)_"^V72.0 POV" ;GPRA TOOK THIS OUT IN V13
;check cpt taxonomies
S T=$O(^ATXAX("B","BGP DM RETINAL EXAM CPTS",0))
I T D I X]"",$P(APCHLEYE,U,2)<$P(X,U,1) S APCHLEYE=1_U_$P(X,U,1)_U_"CPT: "_$P(X,U,2)
.S X=$$CPT^APCHPWHU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^APCHPWHU(P,BDATE,EDATE,T,5)
S T=$O(^ATXAX("B","BGP DM EYE EXAM CPTS",0))
I T D I X]"",$P(APCHLEYE,U,2)<$P(X,U,1) S APCHLEYE=3_U_$P(X,U,1)_U_"CPT: "_$P(X,U,2)
.S X=$$CPT^APCHPWHU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^APCHPWHU(P,BDATE,EDATE,T,5)
S X=$$LASTPRC^APCHSMU2(P,"BGP EYE EXAM PROCS",BDATE,EDATE) I X,$P(APCHLEYE,U,2)<$P(X,U,3) S APCHLEYE=3_U_$P(X,U,3)_U_"PROC: "
Q APCHLEYE
;
APCHPWH5 ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;
+1 ;;2.0;IHS PCC SUITE;**2,5,7,11**;MAY 14, 2009;Build 58
+2 ;
CCI ;EP - EO measures
+1 IF '$ORDER(^APCHPWHT(APCHPWHT,12,0))
QUIT
+2 IF $$AGE^AUPNPAT(APCHSDFN)<18
QUIT
+3 NEW APCHSTO,APCHSTM,APCHSTCE
+4 DO SUBHEAD^APCHPWHU
+5 DO S^APCHPWH1("CCI Measures")
+6 ;
+7 ;go through each one
+8 SET APCHSTO=0
FOR
SET APCHSTO=$ORDER(^APCHPWHT(APCHPWHT,12,APCHSTO))
IF APCHSTO'=+APCHSTO
QUIT
Begin DoDot:1
+9 SET APCHSTM=$PIECE($GET(^APCHPWHT(APCHPWHT,12,APCHSTO,0)),U,2)
+10 IF 'APCHSTM
QUIT
+11 IF '$DATA(^APCHPWHI(APCHSTM,0))
QUIT
+12 SET APCHSTCE=$GET(^APCHPWHI(APCHSTM,1))
+13 IF APCHSTCE=""
QUIT
+14 XECUTE APCHSTCE
+15 QUIT
End DoDot:1
+16 QUIT
+17 ;
LDL ;EP - cholesterol CCI measure
+1 NEW APCHCHOL,APCHD,APCHDM
+2 IF $$AGE^AUPNPAT(APCHSDFN)<18
QUIT
+3 DO SUBHEAD^APCHPWHU
+4 DO S^APCHPWH1("CHOLESTEROL")
+5 DO S^APCHPWH1("Controlling your cholesterol can keep your heart and blood vessels healthy.")
+6 SET APCHCHOL=$$CHOLTST(APCHSDFN)
+7 DO S^APCHPWH1("")
+8 IF APCHCHOL=""
Begin DoDot:1
+9 DO S^APCHPWH1("No recent cholesterol is on file. We recommend that you have your ")
+10 DO S^APCHPWH1("cholesterol rechecked at your next visit.")
End DoDot:1
QUIT
+11 DO S^APCHPWH1("Your total cholesterol result was "_$SELECT($PIECE(APCHCHOL,U,1)]"":$PIECE(APCHCHOL,U,2)_" on "_$$FMTE^XLFDT($PIECE(APCHCHOL,U,1))_".",1:"not found on file."))
+12 DO S^APCHPWH1("Your last LDL (bad cholesterol) result was "_$SELECT($PIECE(APCHCHOL,U,3)]"":$PIECE(APCHCHOL,U,4)_" on "_$$FMTE^XLFDT($PIECE(APCHCHOL,U,3))_".",1:"not found on file."))
+13 DO S^APCHPWH1("Your last HDL (good cholesterol) result was "_$SELECT($PIECE(APCHCHOL,U,5)]"":$PIECE(APCHCHOL,U,6)_" on "_$$FMTE^XLFDT($PIECE(APCHCHOL,U,5))_".",1:"not found on file."))
+14 DO S^APCHPWH1("Your last triglyceride result was "_$SELECT($PIECE(APCHCHOL,U,7)]"":$PIECE(APCHCHOL,U,8)_" on "_$$FMTE^XLFDT($PIECE(APCHCHOL,U,7))_".",1:"not found on file."))
+15 SET APCHDM=0
IF $$DMDX^APCHPWH2(APCHSDFN)!($$AMIO(APCHSDFN,DT))
SET APCHDM=1
+16 SET APCHLDL=+$PIECE(APCHCHOL,U,4)
SET APCHD=$PIECE(APCHCHOL,U,3)
+17 IF $PIECE(APCHCHOL,U,4)=""!($$FMDIFF^XLFDT(DT,APCHD)>$SELECT(APCHDM:365,1:(5*365)))
Begin DoDot:1
+18 DO S^APCHPWH1("No recent LDL cholesterol test is on file. We recommend that you have your",1)
+19 DO S^APCHPWH1("cholesterol rechecked at your next visit.")
End DoDot:1
GOTO LDL2
+20 IF APCHDM
IF APCHLDL
IF APCHLDL<100
Begin DoDot:1
+21 DO S^APCHPWH1("LDL (bad cholesterol) should be under 100 mg/dL. Your LDL cholesterol",1)
+22 DO S^APCHPWH1("is good! You should have your cholesterol checked every year.")
End DoDot:1
+23 IF APCHDM
IF APCHLDL
IF APCHLDL'<100
Begin DoDot:1
+24 DO S^APCHPWH1("It is best when your LDL (bad cholesterol) is less than 100 mg/dl. Ask",1)
+25 DO S^APCHPWH1("your provider about ways to lower your cholesterol.")
End DoDot:1
+26 ;LDL1 ;
+27 ;S APCHD=$P(APCHCHOL,U)
+28 ;S D=$P(APCHCHOL,U,3) I D]"",D>APCHD S APCHD=D
+29 ;S D=$P(APCHCHOL,U,5) I D]"",D>APCHD S APCHD=D
+30 ;S D=$P(APCHCHOL,U,7) I D]"",D>APCHD S APCHD=D
+31 ;I $$FMDIFF^XLFDT(DT,APCHD)>$S(APCHDM:365,1:(5*365)) D
+32 ;.D S^APCHPWH1("No recent cholesterol is on file. You should have your cholesterol",1)
+33 ;.D S^APCHPWH1("rechecked at your next visit.")
LDL2 ;
+1 IF +$PIECE(APCHCHOL,U,8)>500
Begin DoDot:1
+2 DO S^APCHPWH1("High triglyceride levels can hurt your pancreas and cause health",1)
+3 DO S^APCHPWH1("problems such as pain and poor digestion. Ask your provider about how")
+4 DO S^APCHPWH1("you can lower your triglycerides.")
End DoDot:1
+5 QUIT
+6 ;
CVD(P) ;EP
+1 ;check problem list OR must have 3 diagnoses
+2 NEW T,X,Y,I,APCHX,BDATE,EDATE
+3 SET T=$ORDER(^ATXAX("B","BGP IHD DXS",0))
+4 IF 'T
QUIT ""
+5 SET (X,Y,I)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
IF $DATA(^AUPNPROB(X,0))
IF $PIECE(^AUPNPROB(X,0),U,12)'="D"
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $$ICD^ATXAPI(Y,T,9)
SET I=1
+6 IF I
QUIT 1
+7 SET BDATE=$$DOB^AUPNPAT(P)
+8 SET EDATE=DT
+9 KILL ^TMP($JOB,"A")
+10 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+11 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+12 SET T=$ORDER(^ATXAX("B","BGP IHD DXS",0))
+13 IF 'T
QUIT ""
+14 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G>3)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+15 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+16 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+17 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+18 IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+19 IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+20 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+21 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(D)
QUIT
IF $DATA(^AUPNVPOV(Y,0))
SET %=$PIECE(^AUPNVPOV(Y,0),U)
IF $$ICD^ATXAPI(%,T,9)
SET D=1
+22 IF 'D
QUIT
+23 SET G=G+1
+24 QUIT
End DoDot:1
+25 KILL ^TMP($JOB,"A")
+26 QUIT $SELECT(G<3:"",1:1)
+27 ;
AMIO(P,EDATE) ;
+1 NEW APCHG
+2 KILL APCHG
+3 SET Y="APCHG("
+4 SET X=P_"^LAST DX [BGP AMI DXS (HEDIS);DURING "_$$FMADD^XLFDT(EDATE,-365)_"-"_$$FMADD^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 IF $DATA(APCHG(1))
QUIT 1
+6 ;check for procedure in BGP CABG PROCS
+7 SET APCHG=$$LASTPRC^APCHSMU2(P,"BGP CABG PROCS",$$FMADD^XLFDT(EDATE,-365),$$FMADD^XLFDT(EDATE))
+8 IF $PIECE(APCHG,U)
QUIT 1
+9 ;now check cpts
+10 SET APCHG=$$CPT^APCHPWHU(P,$$FMADD^XLFDT(EDATE,-365),$$FMADD^XLFDT(EDATE),$ORDER(^ATXAX("B","BGP CABG CPTS",0)),6)
+11 IF $PIECE(APCHG,U)
QUIT 1
+12 SET APCHG=$$TRAN^APCHPWHU(P,$$FMADD^XLFDT(EDATE,-365),$$FMADD^XLFDT(EDATE),$ORDER(^ATXAX("B","BGP CABG CPTS",0)),6)
+13 IF $PIECE(APCHG,U)
QUIT 1
+14 ;check for procedure in BGP PTCA PROCS
+15 SET APCHG=$$LASTPRC^APCHSMU2(P,"BGP PCI CM PROCS",$$FMADD^XLFDT(EDATE,-365),$$FMADD^XLFDT(EDATE))
+16 IF $PIECE(APCHG,U)
QUIT 1
+17 ;now check cpts
+18 SET APCHG=$$CPT^APCHPWHU(P,$$FMADD^XLFDT(EDATE,-365),$$FMADD^XLFDT(EDATE),$ORDER(^ATXAX("B","BGP PTCA CPTS",0)),6)
+19 IF $PIECE(APCHG,U)
QUIT 1
+20 SET APCHG=$$TRAN^APCHPWHU(P,$$FMADD^XLFDT(EDATE,-365),$$FMADD^XLFDT(EDATE),$ORDER(^ATXAX("B","BGP PTCA CPTS",0)),6)
+21 IF $PIECE(APCHG,U)
QUIT 1
+22 ;now check IVD dxs
+23 SET APCHG(1)=$$LASTDX^APCHSMU2(P,"BGP IVD DXS",$$FMADD^XLFDT(EDATE,-(365*2)),EDATE)
+24 IF $PIECE(APCHG(1),U)
QUIT 1
+25 QUIT ""
+26 ;
CHOLTST(P) ;
+1 ;get all cholesterol tests in APCHC
+2 NEW APCHC,APCHL,APCHT,APCHH,D,R
+3 SET R=""
+4 DO LABS(P,"DM AUDIT CHOLESTEROL TAX","BGP TOTAL CHOLESTEROL LOINC",.APCHC)
+5 DO LABS(P,"DM AUDIT LDL CHOLESTEROL TAX","BGP LDL LOINC CODES",.APCHL)
+6 DO LABS(P,"DM AUDIT HDL TAX","BGP HDL LOINC CODES",.APCHH)
+7 DO LABS(P,"DM AUDIT TRIGLYCERIDE TAX","BGP TRIGLYCERIDE LOINC CODES",.APCHT)
+8 ;
+9 SET D=0
SET D=$ORDER(APCHC(D))
IF D
SET R=(9999999-D)_U_$PIECE(APCHC(D),U,2)_" "_$PIECE($GET(^AUPNVLAB($PIECE(APCHC(D),U,3),11)),U,1)
+10 SET D=0
SET D=$ORDER(APCHL(D))
IF D
SET $PIECE(R,U,3)=$PIECE(APCHL(D),U,1)
SET $PIECE(R,U,4)=$PIECE(APCHL(D),U,2)
+11 SET D=0
SET D=$ORDER(APCHH(D))
IF D
SET $PIECE(R,U,5)=$PIECE(APCHH(D),U,1)
SET $PIECE(R,U,6)=$PIECE(APCHH(D),U,2)
+12 SET D=0
SET D=$ORDER(APCHT(D))
IF D
SET $PIECE(R,U,7)=$PIECE(APCHT(D),U,1)
SET $PIECE(R,U,8)=$PIECE(APCHT(D),U,2)
+13 QUIT R
+14 ;
LABS(P,APCHLT,APCHLOT,APCHT) ;EP - get result of HGBA1c in past year. If no result pass null
+1 ;pass back date_u_result
+2 NEW APCHG,E,%,L,T,D,X,J,C,G
+3 ;now get all loinc/taxonomy tests
+4 IF APCHLOT]""
SET APCHLOT=$ORDER(^ATXAX("B",APCHLOT,0))
+5 IF APCHLT]""
SET APCHLT=$ORDER(^ATXLAB("B",APCHLT,0))
+6 SET B=9999999-$$DOB^AUPNPAT(P)
SET E=9999999-DT
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+7 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+9 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+10 IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+11 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))="COMMENT"
QUIT
+12 IF '+$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+13 IF APCHLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(APCHLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET APCHT(D)=(9999999-D)_U_+$PIECE(^AUPNVLAB(X,0),U,4)_U_X
QUIT
+14 IF 'APCHLOT
QUIT
+15 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+16 IF '$$LOINC(J,APCHLOT)
QUIT
+17 SET APCHT(D)=(9999999-D)_U_+$PIECE(^AUPNVLAB(X,0),U,4)_U_X
+18 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
+21 ;
LOINC(A,B) ;EP
+1 NEW %
+2 IF '$GET(B)
QUIT ""
+3 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+4 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+5 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+6 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+7 QUIT ""
+8 ;
DC ;EP - diabetes comprehensive care
+1 NEW APCHA1C,R,V,APCHKT
+2 ;not diabetic
IF '$$DMDX^APCHPWH2(APCHSDFN)
QUIT
+3 DO SUBHEAD^APCHPWHU
+4 DO S^APCHPWH1("DIABETES CARE")
AIC ;a1c
+1 SET APCHA1C=$$HGBA1C^APCHPWH4(APCHSDFN,,,1)
+2 DO S^APCHPWH1("HEMOGLOBIN A1c",1)
+3 DO S^APCHPWH1("Hemoglobin A1c is a test that measures your blood sugar control over a 3-month")
+4 DO S^APCHPWH1("period. We recommend that you have this test done every 3-6 months.")
+5 IF APCHA1C]""
DO S^APCHPWH1("Your last A1c test on file was "_$PIECE(APCHA1C,U,2)_" done on "_$PIECE(APCHA1C,U)_".")
+6 IF APCHA1C=""!($$FMDIFF^XLFDT(DT,$PIECE(APCHA1C,U,3))>365)
Begin DoDot:1
+7 DO S^APCHPWH1("We recommend that you have your A1c tested. Ask your health care provider",1)
+8 DO S^APCHPWH1("to order an A1c test for you.")
End DoDot:1
GOTO KT
+9 SET V=$PIECE(APCHA1C,U,2)
+10 SET R=$SELECT(V[">":3,V["<":1,$EXTRACT(V)'=+$EXTRACT(V):"",V<7.0:1,V>6.9&(V<9.0):2,V>8.9:3,1:"")
+11 IF R=1
Begin DoDot:1
+12 DO S^APCHPWH1("An A1c value that is less than 7% shows great blood sugar control. You",1)
+13 DO S^APCHPWH1("are doing great!")
End DoDot:1
+14 IF R=2
Begin DoDot:1
+15 DO S^APCHPWH1("Ask your health care provider how you can keep lowering your A1c.",1)
End DoDot:1
+16 IF R=3
Begin DoDot:1
+17 DO S^APCHPWH1("Your A1c is too high. Ask your health care provider about ways to lower",1)
+18 DO S^APCHPWH1("your A1c.")
End DoDot:1
KT ;kidney assessment
+1 DO S^APCHPWH1("DIABETES KIDNEY ASSESSMENT",1)
+2 DO S^APCHPWH1("Diabetes can cause kidney damage. There are tests that can see how well your")
+3 DO S^APCHPWH1("kidneys are working. Getting these tests at least once a year can help your ")
+4 DO S^APCHPWH1("health care provider protect your kidneys and lower your risk of getting ")
+5 DO S^APCHPWH1("kidney damage and dialysis.")
+6 SET APCHKT=$$KIDNEYT(APCHSDFN,$$FMADD^XLFDT(DT,-365),DT)
+7 IF APCHKT=""
Begin DoDot:1
+8 DO S^APCHPWH1("We recommend that you have your kidneys tested to see how well they are ",1)
+9 DO S^APCHPWH1("working every year. Ask your health care provider to order a kidney ")
+10 DO S^APCHPWH1("function test for you.")
End DoDot:1
+11 IF APCHKT]""
Begin DoDot:1
+12 DO S^APCHPWH1("Your kidneys were tested on "_$$FMTE^XLFDT($PIECE(APCHKT,U))_". We recommend that you ",1)
+13 DO S^APCHPWH1("have your kidneys tested again on "_$$FMTE^XLFDT($$FMADD^XLFDT($PIECE(APCHKT,U),365))_".")
End DoDot:1
EYE ;EYE
+1 DO S^APCHPWH1("DIABETES EYE EXAM",1)
+2 DO S^APCHPWH1("Diabetes can affect your eyes and vision. Early detection of eye problems ")
+3 DO S^APCHPWH1("can help you to get the treatment you need to lower your chances of having ")
+4 DO S^APCHPWH1("problems such as blurred vision or blindness.")
+5 SET APCHKT=$$EYET(APCHSDFN,$$DOB^AUPNPAT(APCHSDFN),DT)
+6 IF 'APCHKT
Begin DoDot:1
+7 DO S^APCHPWH1("We recommend that you have at least one diabetes eye exam every year.",1)
+8 DO S^APCHPWH1("Ask your health care provider to order a diabetes eye exam for you.")
End DoDot:1
GOTO FOOT
+9 IF APCHKT
IF $$FMDIFF^XLFDT(DT,$PIECE(APCHKT,U,2))<365
Begin DoDot:1
+10 DO S^APCHPWH1("Your last diabetes eye exam was done on "_$$FMTE^XLFDT($PIECE(APCHKT,U,2))_". We recommend",1)
+11 DO S^APCHPWH1("that you have another eye exam by "_$$FMTE^XLFDT($$FMADD^XLFDT($PIECE(APCHKT,U,2),365))_".")
End DoDot:1
GOTO FOOT
+12 DO S^APCHPWH1("Your last diabetes eye exam was done on "_$$FMTE^XLFDT($PIECE(APCHKT,U,2))_".")
+13 DO S^APCHPWH1("We recommend that you have at least one diabetes eye exam every year. ",1)
+14 DO S^APCHPWH1("Ask your health care provider to order a diabetes eye exam for you.")
+1 DO S^APCHPWH1("DIABETES FOOT EXAM",1)
+2 DO S^APCHPWH1("Diabetes can make your feet hurt or feel numb. Having a diabetes foot")
+3 DO S^APCHPWH1("exam every year can help keep your feet healthy.")
+4 SET APCHKT=$$FOOTEX^APCHPWH6(APCHSDFN,$$DOB^AUPNPAT(APCHSDFN),DT)
+5 IF 'APCHKT
Begin DoDot:1
+6 DO S^APCHPWH1("We recommend that you have at least one diabetes foot exam every year.",1)
+7 DO S^APCHPWH1("Ask your health care provider to order a diabetes foot exam for you.")
End DoDot:1
QUIT
+8 IF APCHKT
IF $$FMDIFF^XLFDT(DT,$PIECE(APCHKT,U))<365
Begin DoDot:1
+9 DO S^APCHPWH1("Your last diabetes foot exam was done on "_$$FMTE^XLFDT($PIECE(APCHKT,U))_". We recommend",1)
+10 DO S^APCHPWH1("that you have another foot exam by "_$$FMTE^XLFDT($$FMADD^XLFDT($PIECE(APCHKT,U),365))_".")
End DoDot:1
QUIT
+11 DO S^APCHPWH1("Your last diabetes foot exam was done on "_$$FMTE^XLFDT($PIECE(APCHKT,U))_".")
+12 DO S^APCHPWH1("We recommend that you have at least one diabetes foot exam every year. ",1)
+13 DO S^APCHPWH1("Ask your health care provider to order a diabetes foot exam for you.")
+14 QUIT
KIDNEYT(P,BDATE,EDATE) ;
+1 ;pass back date_u_result
+2 NEW APCHG,E,%,L,T,D,X,J,C,G,B,APCHACT,APCHACLT,APCHPCT,APCHPCLT,APCHQUT,APCHQULT,APCHT
+3 ;now get all loinc/taxonomy tests
+4 SET APCHACT=$ORDER(^ATXLAB("B","DM AUDIT A/C RATIO TAX",0))
+5 SET APCHACLT=$ORDER(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
+6 SET APCHPCT=$ORDER(^ATXLAB("B","DM AUDIT P/C RATIO TAX",0))
+7 SET APCHPCLT=$ORDER(^ATXAX("B","DM AUDIT P/C RATIO LOINC",0))
+8 SET APCHQULT=$ORDER(^ATXAX("B","BGP QUANT URINE PROT LOINC",0))
+9 SET APCHQUT=$ORDER(^ATXLAB("B","BGP QUANT URINE PROTEIN",0))
+10 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)
QUIT
Begin DoDot:1
+11 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+12 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+13 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+14 IF '$PIECE(^AUPNVLAB(X,0),U)
QUIT
+15 IF APCHACT
IF $DATA(^ATXLAB(APCHACT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET APCHT(D)=(9999999-D)_U_+$PIECE(^AUPNVLAB(X,0),U,4)_U_X
QUIT
+16 IF APCHPCT
IF $DATA(^ATXLAB(APCHACT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET APCHT(D)=(9999999-D)_U_+$PIECE(^AUPNVLAB(X,0),U,4)_U_X
QUIT
+17 IF APCHQUT
IF $DATA(^ATXLAB(APCHACT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET APCHT(D)=(9999999-D)_U_+$PIECE(^AUPNVLAB(X,0),U,4)_U_X
QUIT
+18 ;
+19 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+20 IF $$LOINC(J,APCHACLT)!($$LOINC(J,APCHPCLT))!($$LOINC(J,APCHQULT))
Begin DoDot:4
+21 SET APCHT(D)=(9999999-D)_U_+$PIECE(^AUPNVLAB(X,0),U,4)_U_X
End DoDot:4
QUIT
+22 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+23 IF '$DATA(APCHT)
QUIT ""
+24 SET D=0
SET G=$ORDER(APCHT(D))
+25 QUIT APCHT(G)
+26 ;
EYET(P,BDATE,EDATE) ;
+1 NEW A,%,APCHLEYE,APCHG,Y,X,D,R,T
+2 SET APCHLEYE=""
+3 KILL APCHG
SET %=P_"^LAST EXAM DIABETIC EYE EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"APCHG(")
+4 IF $DATA(APCHG(1))
SET APCHLEYE="1^"_$PIECE(APCHG(1),U)_"^Diab Eye Ex"
+5 KILL ^TMP($JOB,"A")
+6 SET A="^TMP($J,""A"","
+7 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+8 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^APCHS9B4($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+9 IF Y
IF $PIECE(APCHLEYE,U,2)<D
SET APCHLEYE=3_"^"_D_"^Cl: "_R
+10 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^APCHS9B4($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+11 IF Y
IF $PIECE(APCHLEYE,U,2)<D
SET APCHLEYE=$SELECT(R="A2":3,1:3)_"^"_D_"^Cl: "_R
+12 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^APCHS9B4($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+13 IF Y
IF $PIECE(APCHLEYE,U,2)<D
SET APCHLEYE="3^"_D_"^Prv: "_R
+14 ;
+15 ;K APCHG S %=P_"^LAST DX V72.0;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"APCHG(")
+16 ;I $D(APCHG(1)),$P(APCHLEYE,U,2)<$P(APCHG(1),U) S APCHLEYE="3^"_$P(APCHG(1),U)_"^V72.0 POV" ;GPRA TOOK THIS OUT IN V13
+17 ;check cpt taxonomies
+18 SET T=$ORDER(^ATXAX("B","BGP DM RETINAL EXAM CPTS",0))
+19 IF T
Begin DoDot:1
+20 SET X=$$CPT^APCHPWHU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+21 SET X=$$TRAN^APCHPWHU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(APCHLEYE,U,2)<$PIECE(X,U,1)
SET APCHLEYE=1_U_$PIECE(X,U,1)_U_"CPT: "_$PIECE(X,U,2)
+22 SET T=$ORDER(^ATXAX("B","BGP DM EYE EXAM CPTS",0))
+23 IF T
Begin DoDot:1
+24 SET X=$$CPT^APCHPWHU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+25 SET X=$$TRAN^APCHPWHU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(APCHLEYE,U,2)<$PIECE(X,U,1)
SET APCHLEYE=3_U_$PIECE(X,U,1)_U_"CPT: "_$PIECE(X,U,2)
+26 SET X=$$LASTPRC^APCHSMU2(P,"BGP EYE EXAM PROCS",BDATE,EDATE)
IF X
IF $PIECE(APCHLEYE,U,2)<$PIECE(X,U,3)
SET APCHLEYE=3_U_$PIECE(X,U,3)_U_"PROC: "
+27 QUIT APCHLEYE
+28 ;
