Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCHPWH5

APCHPWH5.m

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