APCHPWH9.m

APCHPWH9 ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;  

 ;;2.0;IHS PCC SUITE;**6,7,10,11,17**;MAY 14, 2009;Build 18

 ;

ADOLBP ;EP - BP component

 D SUBHEAD^APCHPWHU

 NEW APCHBP,APCHDM,APCHCKD,APCHST,APCHDT,APCHAGE

 S APCHAGE=$$AGE^AUPNPAT(APCHSDFN,DT)

 D S^APCHPWH1("BLOOD PRESSURE - Blood Pressure is a good measure of health.")

 D S^APCHPWH1(" ")

 S APCHBP=$$LASTBP^APCHPWH2(APCHSDFN)

 S APCHST=$P($P(APCHBP,U,3),"/",1)

 S APCHDT=$P($P(APCHBP,U,3),"/",2)

 I APCHBP="" D  Q

 .I APCHAGE<13 D S^APCHPWH1("No recent blood pressure on file.  We recommend that you have your child's"),S^APCHPWH1("blood pressure checked at your next visit.") D S^APCHPWH1(" ") Q

 .D S^APCHPWH1("No recent blood pressure on file.  We recommend that you have your blood"),S^APCHPWH1("pressure checked at your next visit.") D S^APCHPWH1(" ") Q

 I APCHBP]"" D

 .I APCHAGE<13 D S^APCHPWH1("Your child's last blood pressure was "_$P(APCHBP,U,3)_" on "_$$FMTE^XLFDT($P(APCHBP,U,1))_".") Q

 .D S^APCHPWH1("Your last blood pressure was "_$P(APCHBP,U,3)_" on "_$$FMTE^XLFDT($P(APCHBP,U,1))_".") Q

 Q

 ;

RECENTBP ;EP

 S APCHAGE=$$AGE^AUPNPAT(APCHSDFN,DT)

 D SUBHEAD^APCHPWHU

 NEW APCHHT,APCHWT,X,E

 D S^APCHPWH1("Here are "_$S(APCHAGE<13:"your child's",1:"your")_" most recent blood pressures.")

 D S^APCHPWH1(" ")

 K APCHWT

 S X=APCHSDFN_"^LAST 3 MEAS BP;DURING "_$$DOB^AUPNPAT(APCHSDFN)_"-"_DT S E=$$START1^APCLDF(X,"APCHWT(")

 I '$D(APCHWT) D S^APCHPWH1("No blood pressure values have been recorded.  We recommend that you have"),S^APCHPWH1($S(APCHAGE<13:"your child's",1:"your")_" blood pressure rechecked at your next visit.") Q

 S E="",$E(E,5)="Date",$E(E,18)="Blood Pressure" D S^APCHPWH1(E)

 S X=0 F  S X=$O(APCHWT(X)) Q:X'=+X  D

 .S E=""

 .S $E(E,2)=$$FMTE^XLFDT($P(APCHWT(X),U,1))

 .S $E(E,20)=$P(APCHWT(X),U,2)

 .D S^APCHPWH1(E)

 Q

 ;

DIABSCRN ;EP

 NEW APCHAGE,APCHBMI,APCHGLUC

 S APCHAGE=$$AGE^AUPNPAT(APCHSDFN,DT)

 Q:APCHAGE<10  ;no one under 10

 Q:$$DMDX^APCHPWH2(APCHSDFN)  ;don't display this component if the patient has diabetes

 S APCHBMI=$P($$BMI^APCLSIL2(APCHSDFN,DT),U)

 Q:APCHBMI=""   ;can't tell if they are overweight or obese so skip this component

 Q:'$$OW(APCHSDFN,APCHBMI,APCHAGE)  ;not overweight or obese

 D SUBHEAD^APCHPWHU

 D S^APCHPWH1("DIABETES SCREENING")

 D S^APCHPWH1(" ")

 S APCHGLUC=$$LASTGLUC(APCHSDFN,$$FMADD^XLFDT(DT,-(2*365)))  ;get last glucose value in past 2 years

 I APCHAGE<13 D  Q

 .I APCHGLUC="" D  Q

 ..D WRITET^APCHPWHU("DIAB SCRN - 10-13 NO GLUCOSE") Q

 .I APCHGLUC]"" D  Q

 ..D WRITET^APCHPWHU("DIAB SCRN - 10-13 HAS GLUCOSE")

 ..D S^APCHPWH1("Your child's last blood sugar was "_$P(APCHGLUC,U,3)_" on "_$$FMTE^XLFDT($P(APCHGLUC,U,1))_".")

 I APCHGLUC="" D  Q

 .D WRITET^APCHPWHU("DIAB SCRN - >13 NO GLUCOSE") Q

 I APCHGLUC]"" D  Q

 .D WRITET^APCHPWHU("DIAB SCRN - >13 HAS GLUCOSE")

 .D S^APCHPWH1("Your last blood sugar was "_$P(APCHGLUC,U,3)_" on "_$$FMTE^XLFDT($P(APCHGLUC,U,1))_".")

 Q

OW(P,BMI,A) ;EP obese or overweight, really just overweight

 NEW S,R

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

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

 I S="" Q ""

 I S="U" Q ""

 S R=0,R=$O(^APCLBMI("H",S,A,R))

 I 'R S R=$O(^APCLBMI("H",S,A)) I R S R=$O(^APCLBMI("H",S,R,""))

 I 'R Q ""

 I BMI>$P(^APCLBMI(R,0),U,7)!(BMI<$P(^APCLBMI(R,0),U,6)) Q ""

 I BMI'<$P(^APCLBMI(R,0),U,4) Q 1

 Q ""

LASTGLUC(P,BD,ED,FORM) ;PEP - date of last GLUCOSE SCREENING

 ;  Return the last recorded GLUCOSE SCREENING:

 ;   - V Lab:  DM AUDIT GLUCOSE TESTS TAX, APCH SCREENING GLUCOSE LOINC

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

 I $G(BD)="" S BD=$$DOB^AUPNPAT(P)

 I $G(ED)="" S ED=DT

 I $G(FORM)="" S FORM="D"

 NEW APCHVAL,APCHX,R,X,Y,V,E,T,G,APCHY,APCHF

 S APCHVAL=$$LASTLAB^APCLAPIU(P,BD,ED,,$O(^ATXLAB("B","DM AUDIT GLUCOSE TESTS TAX",0)),,$O(^ATXAX("B","APCH SCREENING GLUCOSE LOINC",0)),"A")

 I FORM="D" Q $P(APCHVAL,U)

 Q APCHVAL

 ;

PROBLIST ;EP

 NEW APCHPROB,APCHX,APCHN,APCHY,APCHT,APCHI,APCHZ,S,X,APCHC,APCHS,APCHD

 K APCHPROB

 D GETPROB

 I '$D(APCHPROB) Q  ;no active problems

 D SUBHEAD^APCHPWHU

 ;D S^APCHPWH1("HEALTH PROBLEMS")

 D S^APCHPWH1("Your Health Problems (Problem List)")

 D S^APCHPWH1("A problem list is a listing of all of the medical conditions that you ")

 D S^APCHPWH1("have that don't go away quickly.")

 D S^APCHPWH1(" ")

 ;S X="Disease/Condition",$E(X,66)="Date of Onset"

 ;D S^APCHPWH1(X)

 S APCHN=0 F  S APCHN=$O(APCHPROB(APCHN)) Q:APCHN'=+APCHN  D

 .S APCHY=$$VALI^XBDIQ1(9000011,APCHN,.01)

 .S APCHY=$$ICDDX^ICDEX(APCHY)

 .S APCHT=$P(APCHY,U,4)

 .S APCHI=$P(APCHY,U,2)

 .S APCHD=$$VAL^XBDIQ1(9000011,APCHN,.13) I APCHD]"" S APCHD="Onset: "_APCHD

 .K ^UTILITY($J,"W") S X=$$VAL^XBDIQ1(9000011,APCHN,.05),DIWL=0,DIWR=48,DIWF="|" D ^DIWP

 .S X=" "_APCHI,$E(X,11)=$G(^UTILITY($J,"W",0,1,0)),$E(X,60)=APCHD D S^APCHPWH1(X)

 .F F=2:1:$G(^UTILITY($J,"W",0)) S X="",$E(X,11)=^UTILITY($J,"W",0,F,0) D S^APCHPWH1(X)

 .K DIWL,DIWR,DIWF,^UTILITY($J,"W")

 .S APCHZ=0,APCHC=0 F  S APCHZ=$O(^AUPNPROB(APCHN,11,APCHZ)) Q:APCHZ'=+APCHZ  D

 ..S APCHS=0 F  S APCHS=$O(^AUPNPROB(APCHN,11,APCHZ,11,APCHS)) Q:APCHS'=+APCHS  D

 ...S X=$P(^AUPNPROB(APCHN,11,APCHZ,11,APCHS,0),U,3)

 ...Q:X=""

 ...S APCHC=APCHC+1

 ...K ^UTILITY($J,"W") S DIWL=0,DIWR=65 D ^DIWP

 ...F F=1:1:$G(^UTILITY($J,"W",0)) S X=$S(APCHC=1:"  Notes:  ",1:""),$E(X,$S(F=1:10,1:13))=$S(F=1:" - ",1:"")_$G(^UTILITY($J,"W",0,F,0)) D S^APCHPWH1(X)

 ...K ^UTILITY($J,"W")

 Q

GETPROB ;

 NEW X,Y

 S X=0 F  S X=$O(^AUPNPROB("AC",APCHSDFN,X)) Q:X'=+X  D

 .Q:'$D(^AUPNPROB(X,0))

 .Q:$P(^AUPNPROB(X,0),U,12)="D"

 .Q:$P(^AUPNPROB(X,0),U,12)="I"

 .Q:$$VAL^XBDIQ1(9000011,X,.01)=".9999"

 .Q:$$VAL^XBDIQ1(9000011,X,.01)="ZZZ.999"

 .S APCHPROB(X)=""

 .Q

 Q

FAMHX ;EP

 NEW APCHPROB,APCHX,APCHN,APCHY,APCHT,APCHI,APCHZ,S,X,APCHC,APCHS,APCHD,APCHR

 K APCHPROB

 D GETFHX

 ;I '$D(APCHPROB) Q  ;no active problems

 D SUBHEAD^APCHPWHU

 ;D S^APCHPWH1("HEALTH PROBLEMS")

 D S^APCHPWH1("FAMILY HEALTH HISTORY")

 D S^APCHPWH1("Family health history is the gathering of information about you and ")

 D S^APCHPWH1("your family.  Knowing about your family's health history is important")

 D S^APCHPWH1("to staying healthy.")

 D S^APCHPWH1(" ")

 ;S X="",$E(X,66)="Date of Onset"

 ;D S^APCHPWH1(X)

 S APCHN=0 F  S APCHN=$O(APCHPROB(APCHN)) Q:APCHN'=+APCHN  D

 .S APCHY=$$VALI^XBDIQ1(9000014,APCHN,.01)

 .S APCHY=$$ICDDX^ICDEX(APCHY)

 .S APCHT=$P(APCHY,U,4)

 .S APCHI=$P(APCHY,U,2)

 .Q:APCHI=".9999"

 .Q:APCHI="ZZZ.999"

 .S APCHD=$$VAL^XBDIQ1(9000014,APCHN,.05) S:APCHD]"" APCHD=APCHD_" yrs" I $P(^AUPNFH(APCHN,0),U,15) S APCHD=APCHD_" (APPROXIMATE)"

 .S APCHR=$$VALI^XBDIQ1(9000014,APCHN,.09)

 .I 'APCHR S APCHRD="RELATION UNKNOWN",APCHS="UNKNOWN" G FAMHX1

 .S APCHRD=$$VAL^XBDIQ1(9000014.1,APCHR,.01),APCHRD=$E(APCHRD,1,20)

 .S APCHS=$$VAL^XBDIQ1(9000014.1,APCHR,.04) I $E(APCHS)="P" S APCHS="UNKNOWN"

FAMHX1 .K ^UTILITY($J,"W") S X=APCHT,DIWL=0,DIWR=25 D ^DIWP

 .S X=APCHRD,$E(X,23)=APCHS,$E(X,33)=$G(^UTILITY($J,"W",0,1,0)),$E(X,60)=APCHD D S^APCHPWH1(X)

 .F F=2:1:$G(^UTILITY($J,"W",0)) S X="",$E(X,33)=^UTILITY($J,"W",0,F,0) D S^APCHPWH1(X)

 D S^APCHPWH1(" ")

 D S^APCHPWH1("You can use the online Family Health History tool to make a family health")

 D S^APCHPWH1("history by going to: https://familyhistory.hhs.gov/.")

 Q

GETFHX ;

 NEW X,Y

 S X=0 F  S X=$O(^AUPNFH("AC",APCHSDFN,X)) Q:X'=+X  D

 .Q:'$D(^AUPNFH(X,0))

 .S APCHPROB(X)=""

 .Q

 Q

APPTS ;EP

 NEW APCHAPPT,X,Y,APCHCLN,APCHSDAT,APCHSVDT,APCHX,APCHSAM,APCHSVT,APCHSN,F,APCHAGE

 ;gather up all appts in APCHAPPT

 S APCHSDAT=0,APCHSVDT=DT-.01 F  S APCHSVDT=$O(^DPT(APCHSDFN,"S",APCHSVDT)) Q:'APCHSVDT  D

 .S APCHSN=^DPT(APCHSDFN,"S",APCHSVDT,0)

 .Q:"CP"[$E($P(APCHSN,U,2)_" ")  ;SKIP CANCELLED

 .Q:$P(APCHSN,U,7)=4  ;skip unscheduled

 .S N=$P(APCHSN,U,1)

 .Q:$P($G(^BSDSC(N,0)),U,12)="C"  ;CLINIC SERVICE CATEGORY IS CHART REVIEW SO NOT A PATIENT APPT

 .S APCHAPPT(APCHSVDT)=""

 I '$D(APCHAPPT) Q  ;no appointments so skip component

 D SUBHEAD^APCHPWHU

 ;D S^APCHPWH1("YOUR APPOINTMENTS")

 ;D S^APCHPWH1(" ")

 S APCHAGE=$$AGE^AUPNPAT(APCHSDFN,DT)

 I APCHAGE<13 D

 .D S^APCHPWH1("APPOINTMENTS:  Your child is scheduled to come back for another appointment.")

 .D S^APCHPWH1("Please call us at "_$$VAL^XBDIQ1(9999999.06,DUZ(2),.13)_" if you have any questions or need to "),S^APCHPWH1("reschedule an appointment.")

 I APCHAGE>12 D

 .D S^APCHPWH1("APPOINTMENTS:  You are scheduled to come back for another appointment.")

 .D S^APCHPWH1("Please call us at "_$$VAL^XBDIQ1(9999999.06,DUZ(2),.13)_" if you have any questions or need to "),S^APCHPWH1("reschedule an appointment.")

 S APCHSVDT=0 F  S APCHSVDT=$O(APCHAPPT(APCHSVDT)) Q:APCHSVDT=""  D APPTS1

 Q

APPTS1 ;

 S APCHSN=^DPT(APCHSDFN,"S",APCHSVDT,0)

 S APCHSAM="am"

 S APCHSVT=$E($P(APCHSVDT,".",2)_"000",1,4) S:APCHSVT>1159 APCHSAM="pm" S:APCHSVT>1300 APCHSVT=APCHSVT-1200 S:$L(APCHSVT)=3 APCHSVT=" "_APCHSVT S:$E(APCHSVT)="0" APCHSVT=" "_$E(APCHSVT,2,4) S APCHSVT=$E(APCHSVT,1,2)_":"_$E(APCHSVT,3,4)

 S APCHSVT=APCHSVT_APCHSAM

 S APCHSCP=+APCHSN,APCHSCN=$P($G(^SC(APCHSCP,0)),U,1) Q:APCHSCN=""

 ;get name of facility where clinic meets

 D S^APCHPWH1(" ")

 S F=$P(^SC(APCHSCP,0),U,4)

 I F S F=$S($P($G(^APCCCTRL(F,0)),U,13):$P(^APCCCTRL(F,0),U,13),1:$P(^DIC(4,F,0),U,1))

 S X=$$FMTE^XLFDT($P(APCHSVDT,".")),$E(X,14)=APCHSVT,$E(X,24)=APCHSCN I F]"" S X=X_"  ("_F_")"

 D S^APCHPWH1(X)

 ;now display provider

 S P=$$PRV(APCHSCP)

 I P]"" D S^APCHPWH1("Provider: "_$P(P,U,2))

 Q

PRV(CLINIC) ;EP; -- returns default provider for clinic

 ; Y returns as ien^provider name

 NEW X,Y

 S Y=""

 S X=0 F  S X=$O(^SC(CLINIC,"PR",X)) Q:'X  D

 . I $P($G(^SC(CLINIC,"PR",X,0)),U,2)=1 S Y=+^SC(CLINIC,"PR",X,0)

 I $G(Y) S Y=Y_U_$$GET1^DIQ(200,Y,.01)

 ;I '$G(Y) S Y="0^UNAFFILIATED CLINICS"

 Q $G(Y)

PEDSCRN ;EP

 NEW APCHAGE,APCHAM,APCHLVAE,APCHDMPV,APCHLDE

 S APCHAGE=$$AGE^AUPNPAT(APCHSDFN,DT)

 Q:APCHAGE>18

 D SUBHEAD^APCHPWHU

 D S^APCHPWH1("PEDIATRIC SCREENING")

 D S^APCHPWH1(" ")

 ;EYE EXAM

 S APCHSAM=$$AGE^APCLSILU(APCHSDFN,2,DT)  ;age in months

 I APCHSAM<15 G DENTAL

 ;

 S APCHLVAE=$$LASTVAE^APCLAPI1(APCHSDFN,$$FMADD^XLFDT(DT,-365),DT)

 I APCHLVAE="" D

 .D S^APCHPWH1("We recommend that your child have an eye exam.  Be sure to discuss")

 .D S^APCHPWH1("this with your child's provider.")

 I APCHLVAE]"" D

 .D S^APCHPWH1("Your child's last vision test was performed on "_$$FMTE^XLFDT($P(APCHLVAE,U))_".")

DENTAL ;

 ;how many dm pov's?  if 2 or more go to age 18, if not then go to age 11

 S APCHDMPV=$$DMPV(APCHSDFN)

 I 'APCHDMPV Q:APCHAGE<12

 S APCHLDE=$$LASTDENT^APCLAPI2(APCHSDFN)

 I APCHLDE="" D

 .D S^APCHPWH1("We recommend that your child have a dental checkup.  Be sure to discuss")

 .D S^APCHPWH1("this with your child's provider.")

 I APCHLDE]"" D

 .D S^APCHPWH1("Your child's last dental checkup was performed on "_$$FMTE^XLFDT($P(APCHLDE,U))_".")

 Q

DMPV(P) ;EP - how many dm povs?

 NEW X,E,APCHX

 S X=P_"^LAST 2 DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,"APCHX(")

 I '$D(APCHX(2)) Q 0

 Q 1

ANTICOAG ;EP

 NEW APCHGOAL,APCHV,APCHD,G

 Q:'$$ACTWARF^APCHSTP1(APCHSDFN,$$FMADD^XLFDT(DT,-45),DT)  ;not a candidate for this component, not active prescription for warfarin

 D SUBHEAD^APCHPWHU

 D S^APCHPWH1("ANTICOAGULATION THERAPY - You are taking Warfarin to prevent dangerous types")

 D S^APCHPWH1("of blood clots.")

 D S^APCHPWH1(" ")

 S APCHGOAL=$$MRGOAL^APCHSACG(APCHSDFN)

 I APCHGOAL="" D

 .D S^APCHPWH1("Your INR Target is not on file.  We recommend that you ask your health")

 .D S^APCHPWH1("care provider about your INR Target at your next visit.")

 I APCHGOAL]"" D

 .S G=$P(APCHGOAL,U,2)

 .S G=$P(G,"-")_"and"_$P(G,"-",2)

 .D S^APCHPWH1("Your INR Target is between "_G_" documented on "_$$FMTE^XLFDT($P(APCHGOAL,U)))

 K APCHV

 S APCHV="APCHV"

 D ALLLAB^APCLAPIU(APCHSDFN,$$FMADD^XLFDT(DT,-(3*365)),DT,$O(^ATXLAB("B","BJPC INR LAB TESTS",0)),$O(^ATXAX("B","BJPC INR LAB LOINCS",0)),"INR",.APCHV)

 ;reorder by date

 K APCHD

 S G=0 F  S G=$O(APCHV(G)) Q:G'=+G  S APCHD(9999999-$P(APCHV(G),U,1),$P(APCHV(G),U,4))=APCHV(G)

 I '$D(APCHD) D  I 1

 .D S^APCHPWH1("Your last 3 INR results were:",1)

 .D S^APCHPWH1("  None Documented.  We recommend that you ask your health care"),S^APCHPWH1("provider about your INR results.")

 E  D

 .S G=0,C=0 F  S G=$O(APCHD(G)) Q:G'=+G!(C>2)  D

 ..S X=0 F  S X=$O(APCHD(G,X)) Q:X'=+X!(C>2)  D

 ...S C=C+1 D S^APCHPWH1($S(C=1:"Your last 3 INR results were: ",1:"")_$P(APCHD(G,X),U,3)_"  on "_$$FMTE^XLFDT($P(APCHD(G,X),U,1)),$S(C=1:1,1:0),0,$S(C=1:0,1:30))

 K APCHMEDS

 D GETMEDS^APCHSMU1(DFN,$$FMADD^XLFDT(DT,-160),DT,"BGP CMS WARFARIN MEDS",,,"WARFARIN",.APCHMEDS)

 ;REORDER BY DATE

 S X=0 F  S X=$O(APCHMEDS(X)) Q:X'=+X  S APCHMEDD(9999999-$P(APCHMEDS(X),U,1),X)=APCHMEDS(X)

 S G=$O(APCHMEDD(0)),H=$O(APCHMEDD(G,0))

 I G,H S G=APCHMEDD(G,H) D

 .D S^APCHPWH1("Your most recent medication to prevent blood clots is:")

 .D S^APCHPWH1("      "_$P(G,U,2)_"    "_$$FMTE^XLFDT($P(G,U,1)))

 .;sig

 .K ^UTILITY($J,"W") S X=$$VAL^XBDIQ1(9000010.14,$P(G,U,4),.05),DIWL=0,DIWR=58 D ^DIWP

 .S X="",$E(X,7)="Directions: "_$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" ") D S^APCHPWH1(X)

 .I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) S X="",$E(X,19)=$G(^UTILITY($J,"W",0,F,0)) D S^APCHPWH1(X)

 .K ^UTILITY($J,"W")

 ;Any appt after $$NOW that has a clinic stop of D1?  if so, display it, if not display nothing

 K APCHMEDS,APCHMEDD

 NEW APCHSDAT,APCHSVDT,APCHSN,APCHSD1

 S APCHSD1=""  ;will contain appt if one found

 S APCHSDAT=0,APCHSVDT=$$NOW^XLFDT() F  S APCHSVDT=$O(^DPT(APCHSDFN,"S",APCHSVDT)) Q:'APCHSVDT!(APCHSD1)  D ONEVIS

 Q

 ;

ONEVIS S APCHSN=^DPT(APCHSDFN,"S",APCHSVDT,0)

 Q:"CP"[$E($P(APCHSN,U,2)_" ")

 Q:$P(APCHSN,U,7)=4  ;skip unscheduled

 S C=$P(APCHSN,U,1)

 Q:C=""

 S C=$P($G(^SC(C,0)),U,7)

 Q:C=""

 S C=$P($G(^DIC(40.7,C,0)),U,2)

 I C'="D1" Q  ;not anticoag clinic

 S APCHSD1=1

 S APCHSAM="am"

 S Y=APCHSVDT\1 S Y=$$FMTE^XLFDT(Y) S APCHSDAT=Y  ;,APCHSNDM=APCHSNDM-1

 S APCHSVT=$E($P(APCHSVDT,".",2)_"000",1,4) S:APCHSVT>1159 APCHSAM="pm" S:APCHSVT>1300 APCHSVT=APCHSVT-1200 S:$L(APCHSVT)=3 APCHSVT=" "_APCHSVT S:$E(APCHSVT)="0" APCHSVT=" "_$E(APCHSVT,2,4) S APCHSVT=$E(APCHSVT,1,2)_":"_$E(APCHSVT,3,4)

 D S^APCHPWH1(" ")

 D S^APCHPWH1("Your next anticoagulation appointment is on "_APCHSDAT_" "_APCHSVT_APCHSAM)

 Q

APCHPWH9  ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;  

 +1       ;;2.0;IHS PCC SUITE;**6,7,10,11,17**;MAY 14, 2009;Build 18

 +2       ;

ADOLBP    ;EP - BP component

 +1        DO SUBHEAD^APCHPWHU

 +2        NEW APCHBP,APCHDM,APCHCKD,APCHST,APCHDT,APCHAGE

 +3        SET APCHAGE=$$AGE^AUPNPAT(APCHSDFN,DT)

 +4        DO S^APCHPWH1("BLOOD PRESSURE - Blood Pressure is a good measure of health.")

 +5        DO S^APCHPWH1(" ")

 +6        SET APCHBP=$$LASTBP^APCHPWH2(APCHSDFN)

 +7        SET APCHST=$PIECE($PIECE(APCHBP,U,3),"/",1)

 +8        SET APCHDT=$PIECE($PIECE(APCHBP,U,3),"/",2)

 +9        IF APCHBP=""

               Begin DoDot:1

 +10               IF APCHAGE<13

                       DO S^APCHPWH1("No recent blood pressure on file.  We recommend that you have your child's")

                       DO S^APCHPWH1("blood pressure checked at your next visit.")

                       DO S^APCHPWH1(" ")

                       QUIT 

 +11               DO S^APCHPWH1("No recent blood pressure on file.  We recommend that you have your blood")

                   DO S^APCHPWH1("pressure checked at your next visit.")

                   DO S^APCHPWH1(" ")

                   QUIT 

               End DoDot:1

               QUIT 

 +12       IF APCHBP]""

               Begin DoDot:1

 +13               IF APCHAGE<13

                       DO S^APCHPWH1("Your child's last blood pressure was "_$PIECE(APCHBP,U,3)_" on "_$$FMTE^XLFDT($PIECE(APCHBP,U,1))_".")

                       QUIT 

 +14               DO S^APCHPWH1("Your last blood pressure was "_$PIECE(APCHBP,U,3)_" on "_$$FMTE^XLFDT($PIECE(APCHBP,U,1))_".")

                   QUIT 

               End DoDot:1

 +15       QUIT 

 +16      ;

RECENTBP  ;EP

 +1        SET APCHAGE=$$AGE^AUPNPAT(APCHSDFN,DT)

 +2        DO SUBHEAD^APCHPWHU

 +3        NEW APCHHT,APCHWT,X,E

 +4        DO S^APCHPWH1("Here are "_$SELECT(APCHAGE<13:"your child's",1:"your")_" most recent blood pressures.")

 +5        DO S^APCHPWH1(" ")

 +6        KILL APCHWT

 +7        SET X=APCHSDFN_"^LAST 3 MEAS BP;DURING "_$$DOB^AUPNPAT(APCHSDFN)_"-"_DT

           SET E=$$START1^APCLDF(X,"APCHWT(")

 +8        IF '$DATA(APCHWT)

               DO S^APCHPWH1("No blood pressure values have been recorded.  We recommend that you have")

               DO S^APCHPWH1($SELECT(APCHAGE<13:"your child's",1:"your")_" blood pressure rechecked at your next visit.")

               QUIT 

 +9        SET E=""

           SET $EXTRACT(E,5)="Date"

           SET $EXTRACT(E,18)="Blood Pressure"

           DO S^APCHPWH1(E)

 +10       SET X=0

           FOR 

               SET X=$ORDER(APCHWT(X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +11               SET E=""

 +12               SET $EXTRACT(E,2)=$$FMTE^XLFDT($PIECE(APCHWT(X),U,1))

 +13               SET $EXTRACT(E,20)=$PIECE(APCHWT(X),U,2)

 +14               DO S^APCHPWH1(E)

               End DoDot:1

 +15       QUIT 

 +16      ;

DIABSCRN  ;EP

 +1        NEW APCHAGE,APCHBMI,APCHGLUC

 +2        SET APCHAGE=$$AGE^AUPNPAT(APCHSDFN,DT)

 +3       ;no one under 10

           IF APCHAGE<10

               QUIT 

 +4       ;don't display this component if the patient has diabetes

           IF $$DMDX^APCHPWH2(APCHSDFN)

               QUIT 

 +5        SET APCHBMI=$PIECE($$BMI^APCLSIL2(APCHSDFN,DT),U)

 +6       ;can't tell if they are overweight or obese so skip this component

           IF APCHBMI=""

               QUIT 

 +7       ;not overweight or obese

           IF '$$OW(APCHSDFN,APCHBMI,APCHAGE)

               QUIT 

 +8        DO SUBHEAD^APCHPWHU

 +9        DO S^APCHPWH1("DIABETES SCREENING")

 +10       DO S^APCHPWH1(" ")

 +11      ;get last glucose value in past 2 years

           SET APCHGLUC=$$LASTGLUC(APCHSDFN,$$FMADD^XLFDT(DT,-(2*365)))

 +12       IF APCHAGE<13

               Begin DoDot:1

 +13               IF APCHGLUC=""

                       Begin DoDot:2

 +14                       DO WRITET^APCHPWHU("DIAB SCRN - 10-13 NO GLUCOSE")

                           QUIT 

                       End DoDot:2

                       QUIT 

 +15               IF APCHGLUC]""

                       Begin DoDot:2

 +16                       DO WRITET^APCHPWHU("DIAB SCRN - 10-13 HAS GLUCOSE")

 +17                       DO S^APCHPWH1("Your child's last blood sugar was "_$PIECE(APCHGLUC,U,3)_" on "_$$FMTE^XLFDT($PIECE(APCHGLUC,U,1))_".")

                       End DoDot:2

                       QUIT 

               End DoDot:1

               QUIT 

 +18       IF APCHGLUC=""

               Begin DoDot:1

 +19               DO WRITET^APCHPWHU("DIAB SCRN - >13 NO GLUCOSE")

                   QUIT 

               End DoDot:1

               QUIT 

 +20       IF APCHGLUC]""

               Begin DoDot:1

 +21               DO WRITET^APCHPWHU("DIAB SCRN - >13 HAS GLUCOSE")

 +22               DO S^APCHPWH1("Your last blood sugar was "_$PIECE(APCHGLUC,U,3)_" on "_$$FMTE^XLFDT($PIECE(APCHGLUC,U,1))_".")

               End DoDot:1

               QUIT 

 +23       QUIT 

OW(P,BMI,A) ;EP obese or overweight, really just overweight

 +1        NEW S,R

 +2        IF $GET(BMI)=""

               QUIT ""

 +3        SET S=$PIECE(^DPT(P,0),U,2)

 +4        IF S=""

               QUIT ""

 +5        IF S="U"

               QUIT ""

 +6        SET R=0

           SET R=$ORDER(^APCLBMI("H",S,A,R))

 +7        IF 'R

               SET R=$ORDER(^APCLBMI("H",S,A))

               IF R

                   SET R=$ORDER(^APCLBMI("H",S,R,""))

 +8        IF 'R

               QUIT ""

 +9        IF BMI>$PIECE(^APCLBMI(R,0),U,7)!(BMI<$PIECE(^APCLBMI(R,0),U,6))

               QUIT ""

 +10       IF BMI'<$PIECE(^APCLBMI(R,0),U,4)

               QUIT 1

 +11       QUIT ""

LASTGLUC(P,BD,ED,FORM) ;PEP - date of last GLUCOSE SCREENING

 +1       ;  Return the last recorded GLUCOSE SCREENING:

 +2       ;   - V Lab:  DM AUDIT GLUCOSE TESTS TAX, APCH SCREENING GLUCOSE LOINC

 +3        IF $GET(P)=""

               QUIT ""

 +4        IF $GET(BD)=""

               SET BD=$$DOB^AUPNPAT(P)

 +5        IF $GET(ED)=""

               SET ED=DT

 +6        IF $GET(FORM)=""

               SET FORM="D"

 +7        NEW APCHVAL,APCHX,R,X,Y,V,E,T,G,APCHY,APCHF

 +8        SET APCHVAL=$$LASTLAB^APCLAPIU(P,BD,ED,,$ORDER(^ATXLAB("B","DM AUDIT GLUCOSE TESTS TAX",0)),,$ORDER(^ATXAX("B","APCH SCREENING GLUCOSE LOINC",0)),"A")

 +9        IF FORM="D"

               QUIT $PIECE(APCHVAL,U)

 +10       QUIT APCHVAL

 +11      ;

PROBLIST  ;EP

 +1        NEW APCHPROB,APCHX,APCHN,APCHY,APCHT,APCHI,APCHZ,S,X,APCHC,APCHS,APCHD

 +2        KILL APCHPROB

 +3        DO GETPROB

 +4       ;no active problems

           IF '$DATA(APCHPROB)

               QUIT 

 +5        DO SUBHEAD^APCHPWHU

 +6       ;D S^APCHPWH1("HEALTH PROBLEMS")

 +7        DO S^APCHPWH1("Your Health Problems (Problem List)")

 +8        DO S^APCHPWH1("A problem list is a listing of all of the medical conditions that you ")

 +9        DO S^APCHPWH1("have that don't go away quickly.")

 +10       DO S^APCHPWH1(" ")

 +11      ;S X="Disease/Condition",$E(X,66)="Date of Onset"

 +12      ;D S^APCHPWH1(X)

 +13       SET APCHN=0

           FOR 

               SET APCHN=$ORDER(APCHPROB(APCHN))

               IF APCHN'=+APCHN

                   QUIT 

               Begin DoDot:1

 +14               SET APCHY=$$VALI^XBDIQ1(9000011,APCHN,.01)

 +15               SET APCHY=$$ICDDX^ICDEX(APCHY)

 +16               SET APCHT=$PIECE(APCHY,U,4)

 +17               SET APCHI=$PIECE(APCHY,U,2)

 +18               SET APCHD=$$VAL^XBDIQ1(9000011,APCHN,.13)

                   IF APCHD]""

                       SET APCHD="Onset: "_APCHD

 +19               KILL ^UTILITY($JOB,"W")

                   SET X=$$VAL^XBDIQ1(9000011,APCHN,.05)

                   SET DIWL=0

                   SET DIWR=48

                   SET DIWF="|"

                   DO ^DIWP

 +20               SET X=" "_APCHI

                   SET $EXTRACT(X,11)=$GET(^UTILITY($JOB,"W",0,1,0))

                   SET $EXTRACT(X,60)=APCHD

                   DO S^APCHPWH1(X)

 +21               FOR F=2:1:$GET(^UTILITY($JOB,"W",0))

                       SET X=""

                       SET $EXTRACT(X,11)=^UTILITY($JOB,"W",0,F,0)

                       DO S^APCHPWH1(X)

 +22               KILL DIWL,DIWR,DIWF,^UTILITY($JOB,"W")

 +23               SET APCHZ=0

                   SET APCHC=0

                   FOR 

                       SET APCHZ=$ORDER(^AUPNPROB(APCHN,11,APCHZ))

                       IF APCHZ'=+APCHZ

                           QUIT