APCHPWH2 ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;
;;2.0;IHS PCC SUITE;**4,6,7,8,10,11**;MAY 14, 2009;Build 58
;
ASK3 ;EP - called from pwh
D SUBHEAD^APCHPWHU
NEW X,T,J
S T="ASK3T" F J=1:1 S X=$T(@T+J) Q:$P(X,";;",2)="ENDTEXT" D S^APCHPWH1($P(X,";;",2))
Q
;
ACTLEVEL ;EP - calld from pwh
NEW APCHX
S APCHX=$$LASTHF^APCHSMU(DFN,"ACTIVITY LEVEL","N")
I APCHX="" Q
D SUBHEAD^APCHPWHU
D S^APCHPWH1("ACTIVITY LEVEL - ")
I APCHX="VERY ACTIVE" D Q
.D S^APCHPWH1("Your level of physical activity is outstanding! You are working hard")
.D S^APCHPWH1("and it shows. Keep up the good work and stay on track.")
I APCHX="ACTIVE" D Q
.D S^APCHPWH1("Your level of physical activity is excellent! Increasing your physical")
.D S^APCHPWH1("activity level to 60 minutes each day (about 300 minutes each week) helps ")
.D S^APCHPWH1("you get even more health benefits.")
I APCHX="SOME ACTIVITY" D Q
.D S^APCHPWH1("Increasing your physical activity to 30 minutes each day (about 150 minutes")
.D S^APCHPWH1("each week) helps you gain even more health benefits. Now you are on the way ")
.D S^APCHPWH1("to losing weight and better health.")
I APCHX="INACTIVE" D Q
.D S^APCHPWH1("Increasing your physical activity to 10 minutes each day helps you get")
.D S^APCHPWH1("more energy, lowers stress, and helps to improve your strength. Being")
.D S^APCHPWH1("active will help you feel better.")
Q
;
ALLERGY ;EP - allergies component
D SUBHEAD^APCHPWHU
NEW APCHSPT,APCHENT,APCHX
NEW APCHVER,APCHNN,APCRNUM,APCHREC,APCHALG,APCHENT,APCHCNT,APCHDATA,APCHDRUG,APCHMEC,APCHPIEN,APCHQ,APCHSNKA,APCHSP,APCHSLEN
NEW D,P
K APCHENT,APCHALG,APCHSALG,APCHSAPR
I "PB"[$P(^APCHPWHT(APCHPWHT,1,APCHSORD,0),U,3) D PROBA^APCHPALG ;get allergies from Problem List
I "AB"[$P(^APCHPWHT(APCHPWHT,1,APCHSORD,0),U,3) D EN^APCHPALG ;get allergies from allergy tracking
D S^APCHPWH1("ALLERGIES - It is important to know what allergies and side effects you")
D S^APCHPWH1("have to medicines or foods. Below is a list of allergies that we know of.")
D S^APCHPWH1("Please tell us if there are any that we missed.")
D S^APCHPWH1(" ")
I '$D(APCHSPT),'$D(APCHENT) S X="Allergies - No allergies are on file. Please tell us if there are any that" D S^APCHPWH1(X) S X="we missed." D S^APCHPWH1(X) D ALLERGYX Q
S (D,P)=0
I $D(APCHENT("A")) F S D=$O(APCHENT("A",D)) Q:D'=+D D
.Q:$G(D)']""
.S P="" F S P=$O(APCHENT("A",D,P)) Q:P="" Q:D'=+D D
..S APCHSALG=1
..S X="",$E(X,5)=$G(APCHENT("A",D,P)) D S^APCHPWH1(X)
..Q
I $D(APCHENT("P")) S D=0 F S D=$O(APCHENT("P",D)) Q:D'=+D D
.Q:$G(D)']""
.S P="" F S P=$O(APCHENT("P",D,P)) Q:P="" Q:D'=+D D
..S APCHSALG=1
..S X="",$E(X,5)=$G(APCHENT("P",D,P)) D S^APCHPWH1(X)
..Q
I $D(APCHENT("U")) S D=0 F S D=$O(APCHENT("U",D)) Q:D'=+D D
.Q:$G(D)']""
.S P=0 F I $D(APCHENT("U")) S P=$O(APCHENT("U",D,P)) Q:P="" Q:D'=+D D
..S APCHSALG=1
..S X="",$E(X,5)=$G(APCHENT("A",D,P)) D S^APCHPWH1(X)
..Q
;
S D=0,P=0,APCHSAPR=0
D S^APCHPWH1(" ")
F S D=$O(APCHSPT(D)) Q:D'=+D D
.S P=$O(APCHSPT(P))
.Q:P'=+P
.S APCHSAPR=1
.S X="",$E(X,5)=$G(APCHSPT(P)) D S^APCHPWH1(X)
.Q
ALLERGYX ;
K APCHVER,APCHNN,APCRNUM,APCHREC,APCHALG,APCHENT,APCHCNT,APCHDATA,APCHDRUG,APCHMEC,APCHPIEN,APCHQ,APCHSNKA,APCHSP,APCHSLEN
Q
ASK3T ;;
;;ASK ME 3 - Every time you talk with a doctor, nurse, pharmacist, or other
;;health care worker, use the Ask Me 3 questions to better understand your
;;health. Make sure you know the answers to these three questions:
;;1. What is my main problem?
;;2. What do I need to do?
;;3. Why is it important for me to do this?
;;ENDTEXT
;
IMMUNDUE ;EP - immunizations due
NEW APCHIMM,APCHI
K APCHIMM,APCH31,APCHBIER
S APCHIMM=""
S APCH31=$C(31)_$C(31)
D IMMFORC^BIRPC(.APCHIMM,APCHSDFN)
S APCHBIER=$P(APCHIMM,APCH31,2)
I APCHBIER]"" D SUBHEAD^APCHPWHU,S^APCHPWH1("IMMUNIZATIONS (shots). Ask your doctor if you are due for any immunizations.",1) K APCHIMM,APCHBIER,APCH31 Q
D SUBHEAD^APCHPWHU
I $E($G(APCHIMM),1,2)="No" S X="IMMUNIZATIONS (shots) NEEDED. Getting shots protects you from some diseases" D S^APCHPWH1(X) D S^APCHPWH1("and illnesses. Your immunizations are up to date.") Q
I $E($G(APCHIMM),1,2)=" " F APCHIMMN=1:1 S APCHIMMT=$P($P(APCHIMM,U,APCHIMMN),"|") Q:$G(APCHIMMT)']"" D
.I $E(APCHIMMT,1,2)=" " S APCHIMMT=$E(APCHIMMT,3,99)
.I $G(APCHIMMT)]"" S APCHI(APCHIMMN)=APCHIMMT
.Q
I $D(APCHI) S APCHICTR=0 D
.F S APCHICTR=$O(APCHI(APCHICTR)) Q:'APCHICTR D
..Q:$L(APCHI(APCHICTR))<3
..S APCHIMDU=APCHICTR
.I +$G(APCHIMDU)>0 S X=APCHIMDU_$S(APCHIMDU>1:" Immunizations Due:",1:" Immunization Due") D S^APCHPWH1(X,1)
.F I=1:1:APCHIMDU S X="",$E(X,5)=APCHI(I) D S^APCHPWH1(X)
.Q
Q
;
IMMUNREC ;EP - immunizations received
N APCHSARR,APCH31,APCHBIER,APCHBIDE
S APCHSARR=""
S APCH31=$C(31)_$C(31),APCHSARR=""
NEW APCHBIDE,I F I=4,26,27,60,33,44,57 S APCHBIDE(I)=""
D IMMHX^BIRPC(.APCHSARR,APCHSDFN,.APCHBIDE)
S APCHBIER=$P(APCHSARR,APCH31,2)
I APCHBIER]"" K APCHSARR,APCHBIDE,APCHBIER,APCH31 D VIMMDISP Q
S APCHSARR=$P(APCHSARR,APCH31,1)
D SUBHEAD^APCHPWHU
D S^APCHPWH1("IMMUNIZATION (shot) RECORD - It is important to keep track of your"),S^APCHPWH1("immunizations.")
I $P(APCHSARR,U,1)["NO RECORDS" D S^APCHPWH1("No immunizations on file.") Q
D S^APCHPWH1("You received the following immunization(s):")
NEW APCHI,APCHV,APCHX,APCHY,APCHZ
S APCHZ="",APCHV="|"
F APCHI=1:1 S APCHY=$P(APCHSARR,U,APCHI) Q:APCHY="" D
.Q:$P(APCHY,APCHV)'="I"
.I $P(APCHY,APCHV,4)'=APCHZ D S^APCHPWH1(" ") S APCHZ=$P(APCHY,APCHV,4)
.S X="",$E(X,3)=$P(APCHY,APCHV,2)_" on "_$P(APCHY,APCHV,8) D S^APCHPWH1(X)
.Q
Q
;
VIMMDISP ;
D SUBHEAD^APCHPWHU
D S^APCHPWH1("IMMUNIZATION (shot) RECORD - It is important to keep track of your"),S^APCHPWH1("immunizations.")
NEW X,Y,Z,D,V
K Z
S X=0 F S X=$O(^AUPNVIMM("AC",APCHSDFN,X)) Q:X'=+X D
.S Y=$$VAL^XBDIQ1(9000010.11,X,.01)
.S V=$$VALI^XBDIQ1(9000010.11,X,.03)
.Q:'V
.Q:'$D(^AUPNVSIT(V,0))
.S D=$$FMTE^XLFDT($P($P(^AUPNVSIT(V,0),U),"."))
.S Z(Y,D)=""
I '$D(Z) D S^APCHPWH1("You have no immunizations on file.") Q
D S^APCHPWH1("You received the following immunizations(s):")
S X="" F S X=$O(Z(X)) Q:X="" S Y="" F S Y=$O(Z(X,Y)) Q:Y="" S D="",$E(D,5)=Y,$E(D,22)=X D S^APCHPWH1(X)
Q
;
HTWTBMI ;EP - ht/wt/bmi component
I $$AGE^AUPNPAT(APCHSDFN,DT)>12,$$AGE^AUPNPAT(APCHSDFN,DT)<19 D ADOLHTWT^APCHPWH8 Q ;adolescent
I $$AGE^AUPNPAT(APCHSDFN,DT)<13 D PEDHTWT^APCHPWH8 Q ;pediatric
;GET LAST VISIT THAT IS A,O,H
I $$LASTVPP(APCHSDFN,$$FMADD^XLFDT(DT,-(30*3)),DT) Q ;last visit dx was pregnancy
D SUBHEAD^APCHPWHU
NEW APCHHT,APCHWT,APCHAGE,APCHNOBM,APCHHTA,APCHWTA,APCHFEET,APCHINCH,APCHHTNG,APCHWTNG,APCLBMI
S APCHNOBM=0,APCHHTNG=0,APCHWTNG=0
D S^APCHPWH1("HEIGHT/WEIGHT/BMI - Weight and Body Mass Index are good measures of your ")
D S^APCHPWH1("health. Determining a healthy weight and Body Mass Index also depends on")
D S^APCHPWH1("how tall you are.")
D S^APCHPWH1(" ")
S APCHAGE=$$AGE^AUPNPAT(DT)
S APCHHT=$$LASTITEM^APCLAPIU(APCHSDFN,"HT","MEASUREMENT",,,"A")
S APCHHTA=$$FMDIFF^XLFDT(DT,$P(APCHHT,U))
I APCHHT=""!(APCHAGE<51&(APCHHTA>(5*365)))!(APCHAGE>50&(APCHHTA>(2*365))) S APCHHTNG=1
S APCHWT=$$LASTITEM^APCLAPIU(APCHSDFN,"WT","MEASUREMENT",,,"A")
S APCHWTA=$$FMDIFF^XLFDT(DT,$P(APCHWT,U))
I APCHWT=""!(APCHAGE<51&(APCHWTA>(5*365)))!(APCHAGE>50&(APCHWTA>(2*365))) S APCHWTNG=1
I 'APCHHTNG S APCHFEET=$P(APCHHT,U,3)/12,APCHINCH=$P(APCHFEET,".",2),APCHINCH="."_APCHINCH*12,APCHINCH=$J(APCHINCH,2,0),APCHFEET=$P(APCHFEET,".")
I 'APCHWTNG S APCHWTLB=$J($P(APCHWT,U,3),3,0)
I 'APCHWTNG,'APCHHTNG D
.D S^APCHPWH1("You are "_APCHFEET_" feet and "_APCHINCH_" inches tall.")
.D S^APCHPWH1("Your last weight was "_APCHWTLB_" pounds on "_$$FMTE^XLFDT($P(APCHWT,U,1))_".")
.D S^APCHPWH1("We recommend that you have your weight rechecked at your next visit.")
.;BMI
.S APCLBMI=$$BMI($P(APCHHT,U,3),$P(APCHWT,U,3))
.D S^APCHPWH1("Your Body Mass Index on "_$$FMTE^XLFDT($P(APCHWT,U,1))_" was "_APCLBMI_".",1)
.I $L($P(APCLBMI,"."))>2 D Q
..D S^APCHPWH1("You are above a healthy weight. Ask your health care provider about")
..D S^APCHPWH1("a weight that is good for you.")
.I $E(APCLBMI,1,2)>18,$E(APCLBMI,1,2)<26 D
..D S^APCHPWH1("You are at a healthy weight. Keep up the good work!")
.I $E(APCLBMI,1,2)<18 D
..D S^APCHPWH1("Your current BMI is below normal. Ask your health care provider")
..D S^APCHPWH1("about a weight that is good for you.")
.I $E(APCLBMI,1,2)>25 D
..D S^APCHPWH1("You are above a healthy weight. Ask your health care provider about")
..D S^APCHPWH1("a weight that is good for you.")
I APCHHTNG,'APCHWTNG D
.D S^APCHPWH1("Your last weight was "_APCHWTLB_" pounds on "_$$FMTE^XLFDT($P(APCHWT,U,1))_".")
.D S^APCHPWH1("No recent height on file. We recommend that you have your height ") D S^APCHPWH1("rechecked at your next visit.")
I APCHWTNG,'APCHHTNG D
.D S^APCHPWH1("You are "_APCHFEET_" feet and "_APCHINCH_" inches tall.")
.D S^APCHPWH1("No recent weight on file. We recommend that you have your weight ") D S^APCHPWH1("rechecked at your next visit.")
I APCHHTNG,APCHWTNG D
.D S^APCHPWH1("No recent weight on file. We recommend that you have your weight rechecked at ") D S^APCHPWH1("your next visit.")
.D S^APCHPWH1("No recent height on file. We recommend that you have your height rechecked at ") D S^APCHPWH1("your next visit.")
Q
;
BMI(H,W) ;
NEW %
S %=""
S W=W*.45359,H=(H*0.0254),H=(H*H),%=(W/H),%=$J(%,4,1)
Q %
;
LASTVPP(P,BDATE,EDATE) ;EP
I '$D(^AUPNVSIT("AC",P)) Q ""
NEW APCHV,A,B,X,E,V,RAPCHR,D
K APCHV
S A="APCHV(",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(APCHV) Q ""
;
S X=0 F S X=$O(APCHV(X)) Q:X'=+X S V=$P(APCHV(X),U,5),APCHR((9999999-$P(APCHV(X),U,1)),V)=APCHV(X)
S (X,G,R,D)=0 F S D=$O(APCHR(D)) Q:D'=+D!(G) S X=0 F S X=$O(APCHR(D,X)) Q:X'=+X!(G) S V=$P(APCHR(D,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(^AUPNVPOV("AD",V))
.Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
.S A=0 F S A=$O(^AUPNVPOV("AD",V,A)) Q:A'=+A!(G) D
..Q:'$D(^AUPNVPOV(A,0))
..S E=$P(^AUPNVPOV(A,0),U)
..Q:'$$ICD^ATXAPI(E,$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0)),9)
..S G=1
.Q
Q G
;
BP ;EP - BP component
I $$AGE^AUPNPAT(APCHSDFN,DT)<3 Q
I $$AGE^AUPNPAT(APCHSDFN,DT)<18 D ADOLBP^APCHPWH9 Q
D SUBHEAD^APCHPWHU
NEW APCHBP,APCHDM,APCHCKD,APCHST,APCHDT
D S^APCHPWH1("BLOOD PRESSURE - Blood Pressure is a good measure of health.")
D S^APCHPWH1(" ")
S APCHBP=$$LASTBP(APCHSDFN)
S APCHST=$P($P(APCHBP,U,3),"/",1)
S APCHDT=$P($P(APCHBP,U,3),"/",2)
I APCHBP="" D S^APCHPWH1("You should have your blood pressure checked at your next visit.") D S^APCHPWH1(" ") Q
I APCHBP]"" D S^APCHPWH1("Your blood pressure was "_$P(APCHBP,U,3)_" on "_$$FMTE^XLFDT($P(APCHBP,U,1))_".")
I $P(APCHBP,U)<$$FMADD^XLFDT(DT,-365) D Q
.D S^APCHPWH1("You should have your blood pressure checked every year or more often.")
.D S^APCHPWH1("Ask your provider to check your blood pressure at your next visit.")
D S^APCHPWH1(" ")
S APCHDM=$$DMDX(APCHSDFN)
S APCHCKD=$$CKD^APCHPWH6(APCHSDFN)
I 'APCHDM,'APCHCKD D Q
.I APCHDT>89!(APCHST>139) D Q
..D S^APCHPWH1("Your last blood pressure was too high. Eating healthy foods, cutting back on")
..D S^APCHPWH1("salt, and more physical activity can help lower blood pressure. If you")
..D S^APCHPWH1("take medicine to lower your blood pressure, be sure to take it everyday.")
.D S^APCHPWH1("Your blood pressure is good! It is very important to have your blood")
.D S^APCHPWH1("pressure checked often.")
I APCHDT>79!(APCHST>129) D Q
.D S^APCHPWH1("Your last blood pressure was too high. Eating healthy foods, cutting back on")
.D S^APCHPWH1("salt, and more physical activity can help lower blood pressure. If you")
.D S^APCHPWH1("take medicine to lower your blood pressure, be sure to take it everyday.")
D S^APCHPWH1("Your blood pressure is good! It is very important to have your blood")
D S^APCHPWH1("pressure checked often.")
Q
;
DMDX(P) ;EP
;check problem list, icare tag or visit supplement logic
N T,X,Y,I,APCHX,APCHY,APCHV,APCHSNVN,APCHSNYR,APCHVSTS,APCHSBD,D,V,APCHSVDT,APCHSCNT,APCHSFOK,APCHSUPI,%,E,APCHSCI
S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",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)'="I",$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
I $T(ATAG^BQITDUTL)]"" S X=$$ATAG^BQITDUTL(P,"Diabetes") I $P(X,U),($P(X,U,2)="P"!($P(X,U,2)="A")) Q 1
;
PVCH ;IHS/CMI/LAB - now check for dx in past year per Bill and Charlton by pcp
S APCHSUPI=$O(^APCHSUP("B","DIABETIC CARE SUMMARY",0))
I 'APCHSUPI S APCHSNVN=1,APCHSNYR=365 G BD
S APCHSNVN=$S($P($G(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,2):$P($G(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,2),1:1)
S APCHSNYR=$S($P($G(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,3):$P($G(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,3),1:1)
BD ;
S APCHSNYR=APCHSNYR*365
S APCHSBD=$$FMADD^XLFDT(DT,-(APCHSNYR))
S APCHY="APCHVSTS(",%=P_"^ALL VISITS;DURING "_APCHSBD_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,APCHY)
I '$D(APCHVSTS) Q 0
S (X,APCHSCNT,APCHSFOK)=0 F S X=$O(APCHVSTS(X)) Q:X'=+X!(APCHSFOK) S V=$P(APCHVSTS(X),U,5) D
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:"DAHO"'[$P(^AUPNVSIT(V,0),U,7)
.Q:'$D(^AUPNVPRV("AD",V))
.Q:'$D(^AUPNVPOV("AD",V))
.S APCHSVDT=$P(+V,".")
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) S APCHSCM=$P($G(^AUPNVPOV(Y,0)),U) I APCHSCM S APCHSCM=$P($$ICDDX^ICDEX(APCHSCM,APCHSVDT),U,2) I APCHSCM]"" D CHKCODE
.Q:'D
.;S Y=$$PRIMPROV^APCLV(V,"F")
.;Q:'Y
.;Q:$P($G(^DIC(7,Y,9999999)),U,3)'="Y"
.S APCHSCNT=APCHSCNT+1
.I APCHSCNT'<APCHSNVN S APCHSFOK=1
.Q
Q APCHSFOK
;
CHKCODE ;
S D=0
F APCHSCI=0:0 S APCHSCI=$O(^APCHSUP(APCHSUPI,13,APCHSCI)) Q:'APCHSCI D CHKCODE1 Q:D
Q
CHKCODE1 ;
S D=0
S APCHSC1=$P(^APCHSUP(APCHSUPI,13,APCHSCI,0),U,1)
I APCHSC1["-" S APCHSC2=$P(APCHSC1,"-",2),APCHSC1=$P(APCHSC1,"-",1)
E S APCHSC2=APCHSC1
S APCHSC1=APCHSC1_" ",APCHSC2=APCHSC2_" "
I APCHSC1'](APCHSCM_" "),(APCHSCM_" ")']APCHSC2 S D=1
Q
LASTBP(P) ;EP
;exclude ER
NEW APCHD,APCHC,APCHX,V,M,T
K APCHX
S APCHX="",APCHD="",APCHC=0
S T=$O(^AUTTMSR("B","BP",""))
F S APCHD=$O(^AUPNVMSR("AA",P,T,APCHD)) Q:APCHD=""!(APCHC=1) D
.S M=0 F S M=$O(^AUPNVMSR("AA",P,T,APCHD,M)) Q:M'=+M!(APCHC=1) D
..Q:$P($G(^AUPNVMSR(M,2)),U,1)
..S V=$P($G(^AUPNVMSR(M,0)),U,3) Q:'V
..Q:'$D(^AUPNVSIT(V,0))
..Q:$$CLINIC^APCLV(V,"C")=30
..S APCHC=APCHC+1,APCHX(APCHC)=(9999999-APCHD)_U_U_$P(^AUPNVMSR(M,0),U,4)
..Q
.Q
Q $G(APCHX(1))
APCHPWH2 ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;
+1 ;;2.0;IHS PCC SUITE;**4,6,7,8,10,11**;MAY 14, 2009;Build 58
+2 ;
ASK3 ;EP - called from pwh
+1 DO SUBHEAD^APCHPWHU
+2 NEW X,T,J
+3 SET T="ASK3T"
FOR J=1:1
SET X=$TEXT(@T+J)
IF $PIECE(X,";;",2)="ENDTEXT"
QUIT
DO S^APCHPWH1($PIECE(X,";;",2))
+4 QUIT
+5 ;
ACTLEVEL ;EP - calld from pwh
+1 NEW APCHX
+2 SET APCHX=$$LASTHF^APCHSMU(DFN,"ACTIVITY LEVEL","N")
+3 IF APCHX=""
QUIT
+4 DO SUBHEAD^APCHPWHU
+5 DO S^APCHPWH1("ACTIVITY LEVEL - ")
+6 IF APCHX="VERY ACTIVE"
Begin DoDot:1
+7 DO S^APCHPWH1("Your level of physical activity is outstanding! You are working hard")
+8 DO S^APCHPWH1("and it shows. Keep up the good work and stay on track.")
End DoDot:1
QUIT
+9 IF APCHX="ACTIVE"
Begin DoDot:1
+10 DO S^APCHPWH1("Your level of physical activity is excellent! Increasing your physical")
+11 DO S^APCHPWH1("activity level to 60 minutes each day (about 300 minutes each week) helps ")
+12 DO S^APCHPWH1("you get even more health benefits.")
End DoDot:1
QUIT
+13 IF APCHX="SOME ACTIVITY"
Begin DoDot:1
+14 DO S^APCHPWH1("Increasing your physical activity to 30 minutes each day (about 150 minutes")
+15 DO S^APCHPWH1("each week) helps you gain even more health benefits. Now you are on the way ")
+16 DO S^APCHPWH1("to losing weight and better health.")
End DoDot:1
QUIT
+17 IF APCHX="INACTIVE"
Begin DoDot:1
+18 DO S^APCHPWH1("Increasing your physical activity to 10 minutes each day helps you get")
+19 DO S^APCHPWH1("more energy, lowers stress, and helps to improve your strength. Being")
+20 DO S^APCHPWH1("active will help you feel better.")
End DoDot:1
QUIT
+21 QUIT
+22 ;
ALLERGY ;EP - allergies component
+1 DO SUBHEAD^APCHPWHU
+2 NEW APCHSPT,APCHENT,APCHX
+3 NEW APCHVER,APCHNN,APCRNUM,APCHREC,APCHALG,APCHENT,APCHCNT,APCHDATA,APCHDRUG,APCHMEC,APCHPIEN,APCHQ,APCHSNKA,APCHSP,APCHSLEN
+4 NEW D,P
+5 KILL APCHENT,APCHALG,APCHSALG,APCHSAPR
+6 ;get allergies from Problem List
IF "PB"[$PIECE(^APCHPWHT(APCHPWHT,1,APCHSORD,0),U,3)
DO PROBA^APCHPALG
+7 ;get allergies from allergy tracking
IF "AB"[$PIECE(^APCHPWHT(APCHPWHT,1,APCHSORD,0),U,3)
DO EN^APCHPALG
+8 DO S^APCHPWH1("ALLERGIES - It is important to know what allergies and side effects you")
+9 DO S^APCHPWH1("have to medicines or foods. Below is a list of allergies that we know of.")
+10 DO S^APCHPWH1("Please tell us if there are any that we missed.")
+11 DO S^APCHPWH1(" ")
+12 IF '$DATA(APCHSPT)
IF '$DATA(APCHENT)
SET X="Allergies - No allergies are on file. Please tell us if there are any that"
DO S^APCHPWH1(X)
SET X="we missed."
DO S^APCHPWH1(X)
DO ALLERGYX
QUIT
+13 SET (D,P)=0
+14 IF $DATA(APCHENT("A"))
FOR
SET D=$ORDER(APCHENT("A",D))
IF D'=+D
QUIT
Begin DoDot:1
+15 IF $GET(D)']""
QUIT
+16 SET P=""
FOR
SET P=$ORDER(APCHENT("A",D,P))
IF P=""
QUIT
IF D'=+D
QUIT
Begin DoDot:2
+17 SET APCHSALG=1
+18 SET X=""
SET $EXTRACT(X,5)=$GET(APCHENT("A",D,P))
DO S^APCHPWH1(X)
+19 QUIT
End DoDot:2
End DoDot:1
+20 IF $DATA(APCHENT("P"))
SET D=0
FOR
SET D=$ORDER(APCHENT("P",D))
IF D'=+D
QUIT
Begin DoDot:1
+21 IF $GET(D)']""
QUIT
+22 SET P=""
FOR
SET P=$ORDER(APCHENT("P",D,P))
IF P=""
QUIT
IF D'=+D
QUIT
Begin DoDot:2
+23 SET APCHSALG=1
+24 SET X=""
SET $EXTRACT(X,5)=$GET(APCHENT("P",D,P))
DO S^APCHPWH1(X)
+25 QUIT
End DoDot:2
End DoDot:1
+26 IF $DATA(APCHENT("U"))
SET D=0
FOR
SET D=$ORDER(APCHENT("U",D))
IF D'=+D
QUIT
Begin DoDot:1
+27 IF $GET(D)']""
QUIT
+28 SET P=0
FOR
IF $DATA(APCHENT("U"))
SET P=$ORDER(APCHENT("U",D,P))
IF P=""
QUIT
IF D'=+D
QUIT
Begin DoDot:2
+29 SET APCHSALG=1
+30 SET X=""
SET $EXTRACT(X,5)=$GET(APCHENT("A",D,P))
DO S^APCHPWH1(X)
+31 QUIT
End DoDot:2
End DoDot:1
+32 ;
+33 SET D=0
SET P=0
SET APCHSAPR=0
+34 DO S^APCHPWH1(" ")
+35 FOR
SET D=$ORDER(APCHSPT(D))
IF D'=+D
QUIT
Begin DoDot:1
+36 SET P=$ORDER(APCHSPT(P))
+37 IF P'=+P
QUIT
+38 SET APCHSAPR=1
+39 SET X=""
SET $EXTRACT(X,5)=$GET(APCHSPT(P))
DO S^APCHPWH1(X)
+40 QUIT
End DoDot:1
ALLERGYX ;
+1 KILL APCHVER,APCHNN,APCRNUM,APCHREC,APCHALG,APCHENT,APCHCNT,APCHDATA,APCHDRUG,APCHMEC,APCHPIEN,APCHQ,APCHSNKA,APCHSP,APCHSLEN
+2 QUIT
ASK3T ;;
+1 ;;ASK ME 3 - Every time you talk with a doctor, nurse, pharmacist, or other
+2 ;;health care worker, use the Ask Me 3 questions to better understand your
+3 ;;health. Make sure you know the answers to these three questions:
+4 ;;1. What is my main problem?
+5 ;;2. What do I need to do?
+6 ;;3. Why is it important for me to do this?
+7 ;;ENDTEXT
+8 ;
IMMUNDUE ;EP - immunizations due
+1 NEW APCHIMM,APCHI
+2 KILL APCHIMM,APCH31,APCHBIER
+3 SET APCHIMM=""
+4 SET APCH31=$CHAR(31)_$CHAR(31)
+5 DO IMMFORC^BIRPC(.APCHIMM,APCHSDFN)
+6 SET APCHBIER=$PIECE(APCHIMM,APCH31,2)
+7 IF APCHBIER]""
DO SUBHEAD^APCHPWHU
DO S^APCHPWH1("IMMUNIZATIONS (shots). Ask your doctor if you are due for any immunizations.",1)
KILL APCHIMM,APCHBIER,APCH31
QUIT
+8 DO SUBHEAD^APCHPWHU
+9 IF $EXTRACT($GET(APCHIMM),1,2)="No"
SET X="IMMUNIZATIONS (shots) NEEDED. Getting shots protects you from some diseases"
DO S^APCHPWH1(X)
DO S^APCHPWH1("and illnesses. Your immunizations are up to date.")
QUIT
+10 IF $EXTRACT($GET(APCHIMM),1,2)=" "
FOR APCHIMMN=1:1
SET APCHIMMT=$PIECE($PIECE(APCHIMM,U,APCHIMMN),"|")
IF $GET(APCHIMMT)']""
QUIT
Begin DoDot:1
+11 IF $EXTRACT(APCHIMMT,1,2)=" "
SET APCHIMMT=$EXTRACT(APCHIMMT,3,99)
+12 IF $GET(APCHIMMT)]""
SET APCHI(APCHIMMN)=APCHIMMT
+13 QUIT
End DoDot:1
+14 IF $DATA(APCHI)
SET APCHICTR=0
Begin DoDot:1
+15 FOR
SET APCHICTR=$ORDER(APCHI(APCHICTR))
IF 'APCHICTR
QUIT
Begin DoDot:2
+16 IF $LENGTH(APCHI(APCHICTR))<3
QUIT
+17 SET APCHIMDU=APCHICTR
End DoDot:2
+18 IF +$GET(APCHIMDU)>0
SET X=APCHIMDU_$SELECT(APCHIMDU>1:" Immunizations Due:",1:" Immunization Due")
DO S^APCHPWH1(X,1)
+19 FOR I=1:1:APCHIMDU
SET X=""
SET $EXTRACT(X,5)=APCHI(I)
DO S^APCHPWH1(X)
+20 QUIT
End DoDot:1
+21 QUIT
+22 ;
IMMUNREC ;EP - immunizations received
+1 NEW APCHSARR,APCH31,APCHBIER,APCHBIDE
+2 SET APCHSARR=""
+3 SET APCH31=$CHAR(31)_$CHAR(31)
SET APCHSARR=""
+4 NEW APCHBIDE,I
FOR I=4,26,27,60,33,44,57
SET APCHBIDE(I)=""
+5 DO IMMHX^BIRPC(.APCHSARR,APCHSDFN,.APCHBIDE)
+6 SET APCHBIER=$PIECE(APCHSARR,APCH31,2)
+7 IF APCHBIER]""
KILL APCHSARR,APCHBIDE,APCHBIER,APCH31
DO VIMMDISP
QUIT
+8 SET APCHSARR=$PIECE(APCHSARR,APCH31,1)
+9 DO SUBHEAD^APCHPWHU
+10 DO S^APCHPWH1("IMMUNIZATION (shot) RECORD - It is important to keep track of your")
DO S^APCHPWH1("immunizations.")
+11 IF $PIECE(APCHSARR,U,1)["NO RECORDS"
DO S^APCHPWH1("No immunizations on file.")
QUIT
+12 DO S^APCHPWH1("You received the following immunization(s):")
+13 NEW APCHI,APCHV,APCHX,APCHY,APCHZ
+14 SET APCHZ=""
SET APCHV="|"
+15 FOR APCHI=1:1
SET APCHY=$PIECE(APCHSARR,U,APCHI)
IF APCHY=""
QUIT
Begin DoDot:1
+16 IF $PIECE(APCHY,APCHV)'="I"
QUIT
+17 IF $PIECE(APCHY,APCHV,4)'=APCHZ
DO S^APCHPWH1(" ")
SET APCHZ=$PIECE(APCHY,APCHV,4)
+18 SET X=""
SET $EXTRACT(X,3)=$PIECE(APCHY,APCHV,2)_" on "_$PIECE(APCHY,APCHV,8)
DO S^APCHPWH1(X)
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
VIMMDISP ;
+1 DO SUBHEAD^APCHPWHU
+2 DO S^APCHPWH1("IMMUNIZATION (shot) RECORD - It is important to keep track of your")
DO S^APCHPWH1("immunizations.")
+3 NEW X,Y,Z,D,V
+4 KILL Z
+5 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",APCHSDFN,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET Y=$$VAL^XBDIQ1(9000010.11,X,.01)
+7 SET V=$$VALI^XBDIQ1(9000010.11,X,.03)
+8 IF 'V
QUIT
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 SET D=$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
+11 SET Z(Y,D)=""
End DoDot:1
+12 IF '$DATA(Z)
DO S^APCHPWH1("You have no immunizations on file.")
QUIT
+13 DO S^APCHPWH1("You received the following immunizations(s):")
+14 SET X=""
FOR
SET X=$ORDER(Z(X))
IF X=""
QUIT
SET Y=""
FOR
SET Y=$ORDER(Z(X,Y))
IF Y=""
QUIT
SET D=""
SET $EXTRACT(D,5)=Y
SET $EXTRACT(D,22)=X
DO S^APCHPWH1(X)
+15 QUIT
+16 ;
HTWTBMI ;EP - ht/wt/bmi component
+1 ;adolescent
IF $$AGE^AUPNPAT(APCHSDFN,DT)>12
IF $$AGE^AUPNPAT(APCHSDFN,DT)<19
DO ADOLHTWT^APCHPWH8
QUIT
+2 ;pediatric
IF $$AGE^AUPNPAT(APCHSDFN,DT)<13
DO PEDHTWT^APCHPWH8
QUIT
+3 ;GET LAST VISIT THAT IS A,O,H
+4 ;last visit dx was pregnancy
IF $$LASTVPP(APCHSDFN,$$FMADD^XLFDT(DT,-(30*3)),DT)
QUIT
+5 DO SUBHEAD^APCHPWHU
+6 NEW APCHHT,APCHWT,APCHAGE,APCHNOBM,APCHHTA,APCHWTA,APCHFEET,APCHINCH,APCHHTNG,APCHWTNG,APCLBMI
+7 SET APCHNOBM=0
SET APCHHTNG=0
SET APCHWTNG=0
+8 DO S^APCHPWH1("HEIGHT/WEIGHT/BMI - Weight and Body Mass Index are good measures of your ")
+9 DO S^APCHPWH1("health. Determining a healthy weight and Body Mass Index also depends on")
+10 DO S^APCHPWH1("how tall you are.")
+11 DO S^APCHPWH1(" ")
+12 SET APCHAGE=$$AGE^AUPNPAT(DT)
+13 SET APCHHT=$$LASTITEM^APCLAPIU(APCHSDFN,"HT","MEASUREMENT",,,"A")
+14 SET APCHHTA=$$FMDIFF^XLFDT(DT,$PIECE(APCHHT,U))
+15 IF APCHHT=""!(APCHAGE<51&(APCHHTA>(5*365)))!(APCHAGE>50&(APCHHTA>(2*365)))
SET APCHHTNG=1
+16 SET APCHWT=$$LASTITEM^APCLAPIU(APCHSDFN,"WT","MEASUREMENT",,,"A")
+17 SET APCHWTA=$$FMDIFF^XLFDT(DT,$PIECE(APCHWT,U))
+18 IF APCHWT=""!(APCHAGE<51&(APCHWTA>(5*365)))!(APCHAGE>50&(APCHWTA>(2*365)))
SET APCHWTNG=1
+19 IF 'APCHHTNG
SET APCHFEET=$PIECE(APCHHT,U,3)/12
SET APCHINCH=$PIECE(APCHFEET,".",2)
SET APCHINCH="."_APCHINCH*12
SET APCHINCH=$JUSTIFY(APCHINCH,2,0)
SET APCHFEET=$PIECE(APCHFEET,".")
+20 IF 'APCHWTNG
SET APCHWTLB=$JUSTIFY($PIECE(APCHWT,U,3),3,0)
+21 IF 'APCHWTNG
IF 'APCHHTNG
Begin DoDot:1
+22 DO S^APCHPWH1("You are "_APCHFEET_" feet and "_APCHINCH_" inches tall.")
+23 DO S^APCHPWH1("Your last weight was "_APCHWTLB_" pounds on "_$$FMTE^XLFDT($PIECE(APCHWT,U,1))_".")
+24 DO S^APCHPWH1("We recommend that you have your weight rechecked at your next visit.")
+25 ;BMI
+26 SET APCLBMI=$$BMI($PIECE(APCHHT,U,3),$PIECE(APCHWT,U,3))
+27 DO S^APCHPWH1("Your Body Mass Index on "_$$FMTE^XLFDT($PIECE(APCHWT,U,1))_" was "_APCLBMI_".",1)
+28 IF $LENGTH($PIECE(APCLBMI,"."))>2
Begin DoDot:2
+29 DO S^APCHPWH1("You are above a healthy weight. Ask your health care provider about")
+30 DO S^APCHPWH1("a weight that is good for you.")
End DoDot:2
QUIT
+31 IF $EXTRACT(APCLBMI,1,2)>18
IF $EXTRACT(APCLBMI,1,2)<26
Begin DoDot:2
+32 DO S^APCHPWH1("You are at a healthy weight. Keep up the good work!")
End DoDot:2
+33 IF $EXTRACT(APCLBMI,1,2)<18
Begin DoDot:2
+34 DO S^APCHPWH1("Your current BMI is below normal. Ask your health care provider")
+35 DO S^APCHPWH1("about a weight that is good for you.")
End DoDot:2
+36 IF $EXTRACT(APCLBMI,1,2)>25
Begin DoDot:2
+37 DO S^APCHPWH1("You are above a healthy weight. Ask your health care provider about")
+38 DO S^APCHPWH1("a weight that is good for you.")
End DoDot:2
End DoDot:1
+39 IF APCHHTNG
IF 'APCHWTNG
Begin DoDot:1
+40 DO S^APCHPWH1("Your last weight was "_APCHWTLB_" pounds on "_$$FMTE^XLFDT($PIECE(APCHWT,U,1))_".")
+41 DO S^APCHPWH1("No recent height on file. We recommend that you have your height ")
DO S^APCHPWH1("rechecked at your next visit.")
End DoDot:1
+42 IF APCHWTNG
IF 'APCHHTNG
Begin DoDot:1
+43 DO S^APCHPWH1("You are "_APCHFEET_" feet and "_APCHINCH_" inches tall.")
+44 DO S^APCHPWH1("No recent weight on file. We recommend that you have your weight ")
DO S^APCHPWH1("rechecked at your next visit.")
End DoDot:1
+45 IF APCHHTNG
IF APCHWTNG
Begin DoDot:1
+46 DO S^APCHPWH1("No recent weight on file. We recommend that you have your weight rechecked at ")
DO S^APCHPWH1("your next visit.")
+47 DO S^APCHPWH1("No recent height on file. We recommend that you have your height rechecked at ")
DO S^APCHPWH1("your next visit.")
End DoDot:1
+48 QUIT
+49 ;
BMI(H,W) ;
+1 NEW %
+2 SET %=""
+3 SET W=W*.45359
SET H=(H*0.0254)
SET H=(H*H)
SET %=(W/H)
SET %=$JUSTIFY(%,4,1)
+4 QUIT %
+5 ;
LASTVPP(P,BDATE,EDATE) ;EP
+1 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+2 NEW APCHV,A,B,X,E,V,RAPCHR,D
+3 KILL APCHV
+4 SET A="APCHV("
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+5 IF '$DATA(APCHV)
QUIT ""
+6 ;
+7 SET X=0
FOR
SET X=$ORDER(APCHV(X))
IF X'=+X
QUIT
SET V=$PIECE(APCHV(X),U,5)
SET APCHR((9999999-$PIECE(APCHV(X),U,1)),V)=APCHV(X)
+8 SET (X,G,R,D)=0
FOR
SET D=$ORDER(APCHR(D))
IF D'=+D!(G)
QUIT
SET X=0
FOR
SET X=$ORDER(APCHR(D,X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(APCHR(D,X),U,5)
Begin DoDot:1
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+11 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+12 IF '$DATA(^AUPNVPOV("AD",V))
QUIT
+13 IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+14 SET A=0
FOR
SET A=$ORDER(^AUPNVPOV("AD",V,A))
IF A'=+A!(G)
QUIT
Begin DoDot:2
+15 IF '$DATA(^AUPNVPOV(A,0))
QUIT
+16 SET E=$PIECE(^AUPNVPOV(A,0),U)
+17 IF '$$ICD^ATXAPI(E,$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0)),9)
QUIT
+18 SET G=1
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT G
+21 ;
BP ;EP - BP component
+1 IF $$AGE^AUPNPAT(APCHSDFN,DT)<3
QUIT
+2 IF $$AGE^AUPNPAT(APCHSDFN,DT)<18
DO ADOLBP^APCHPWH9
QUIT
+3 DO SUBHEAD^APCHPWHU
+4 NEW APCHBP,APCHDM,APCHCKD,APCHST,APCHDT
+5 DO S^APCHPWH1("BLOOD PRESSURE - Blood Pressure is a good measure of health.")
+6 DO S^APCHPWH1(" ")
+7 SET APCHBP=$$LASTBP(APCHSDFN)
+8 SET APCHST=$PIECE($PIECE(APCHBP,U,3),"/",1)
+9 SET APCHDT=$PIECE($PIECE(APCHBP,U,3),"/",2)
+10 IF APCHBP=""
DO S^APCHPWH1("You should have your blood pressure checked at your next visit.")
DO S^APCHPWH1(" ")
QUIT
+11 IF APCHBP]""
DO S^APCHPWH1("Your blood pressure was "_$PIECE(APCHBP,U,3)_" on "_$$FMTE^XLFDT($PIECE(APCHBP,U,1))_".")
+12 IF $PIECE(APCHBP,U)<$$FMADD^XLFDT(DT,-365)
Begin DoDot:1
+13 DO S^APCHPWH1("You should have your blood pressure checked every year or more often.")
+14 DO S^APCHPWH1("Ask your provider to check your blood pressure at your next visit.")
End DoDot:1
QUIT
+15 DO S^APCHPWH1(" ")
+16 SET APCHDM=$$DMDX(APCHSDFN)
+17 SET APCHCKD=$$CKD^APCHPWH6(APCHSDFN)
+18 IF 'APCHDM
IF 'APCHCKD
Begin DoDot:1
+19 IF APCHDT>89!(APCHST>139)
Begin DoDot:2
+20 DO S^APCHPWH1("Your last blood pressure was too high. Eating healthy foods, cutting back on")
+21 DO S^APCHPWH1("salt, and more physical activity can help lower blood pressure. If you")
+22 DO S^APCHPWH1("take medicine to lower your blood pressure, be sure to take it everyday.")
End DoDot:2
QUIT
+23 DO S^APCHPWH1("Your blood pressure is good! It is very important to have your blood")
+24 DO S^APCHPWH1("pressure checked often.")
End DoDot:1
QUIT
+25 IF APCHDT>79!(APCHST>129)
Begin DoDot:1
+26 DO S^APCHPWH1("Your last blood pressure was too high. Eating healthy foods, cutting back on")
+27 DO S^APCHPWH1("salt, and more physical activity can help lower blood pressure. If you")
+28 DO S^APCHPWH1("take medicine to lower your blood pressure, be sure to take it everyday.")
End DoDot:1
QUIT
+29 DO S^APCHPWH1("Your blood pressure is good! It is very important to have your blood")
+30 DO S^APCHPWH1("pressure checked often.")
+31 QUIT
+32 ;
DMDX(P) ;EP
+1 ;check problem list, icare tag or visit supplement logic
+2 NEW T,X,Y,I,APCHX,APCHY,APCHV,APCHSNVN,APCHSNYR,APCHVSTS,APCHSBD,D,V,APCHSVDT,APCHSCNT,APCHSFOK,APCHSUPI,%,E,APCHSCI
+3 SET T=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",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)'="I"
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 IF $TEXT(ATAG^BQITDUTL)]""
SET X=$$ATAG^BQITDUTL(P,"Diabetes")
IF $PIECE(X,U)
IF ($PIECE(X,U,2)="P"!($PIECE(X,U,2)="A"))
QUIT 1
+8 ;
PVCH ;IHS/CMI/LAB - now check for dx in past year per Bill and Charlton by pcp
+1 SET APCHSUPI=$ORDER(^APCHSUP("B","DIABETIC CARE SUMMARY",0))
+2 IF 'APCHSUPI
SET APCHSNVN=1
SET APCHSNYR=365
GOTO BD
+3 SET APCHSNVN=$SELECT($PIECE($GET(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,2):$PIECE($GET(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,2),1:1)
+4 SET APCHSNYR=$SELECT($PIECE($GET(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,3):$PIECE($GET(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,3),1:1)
BD ;
+1 SET APCHSNYR=APCHSNYR*365
+2 SET APCHSBD=$$FMADD^XLFDT(DT,-(APCHSNYR))
+3 SET APCHY="APCHVSTS("
SET %=P_"^ALL VISITS;DURING "_APCHSBD_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(%,APCHY)
+4 IF '$DATA(APCHVSTS)
QUIT 0
+5 SET (X,APCHSCNT,APCHSFOK)=0
FOR
SET X=$ORDER(APCHVSTS(X))
IF X'=+X!(APCHSFOK)
QUIT
SET V=$PIECE(APCHVSTS(X),U,5)
Begin DoDot:1
+6 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+7 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+8 IF "DAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+9 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+10 IF '$DATA(^AUPNVPOV("AD",V))
QUIT
+11 SET APCHSVDT=$PIECE(+V,".")
+12 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(D)
QUIT
SET APCHSCM=$PIECE($GET(^AUPNVPOV(Y,0)),U)
IF APCHSCM
SET APCHSCM=$PIECE($$ICDDX^ICDEX(APCHSCM,APCHSVDT),U,2)
IF APCHSCM]""
DO CHKCODE
+13 IF 'D
QUIT
+14 ;S Y=$$PRIMPROV^APCLV(V,"F")
+15 ;Q:'Y
+16 ;Q:$P($G(^DIC(7,Y,9999999)),U,3)'="Y"
+17 SET APCHSCNT=APCHSCNT+1
+18 IF APCHSCNT'<APCHSNVN
SET APCHSFOK=1
+19 QUIT
End DoDot:1
+20 QUIT APCHSFOK
+21 ;
CHKCODE ;
+1 SET D=0
+2 FOR APCHSCI=0:0
SET APCHSCI=$ORDER(^APCHSUP(APCHSUPI,13,APCHSCI))
IF 'APCHSCI
QUIT
DO CHKCODE1
IF D
QUIT
+3 QUIT
CHKCODE1 ;
+1 SET D=0
+2 SET APCHSC1=$PIECE(^APCHSUP(APCHSUPI,13,APCHSCI,0),U,1)
+3 IF APCHSC1["-"
SET APCHSC2=$PIECE(APCHSC1,"-",2)
SET APCHSC1=$PIECE(APCHSC1,"-",1)
+4 IF '$TEST
SET APCHSC2=APCHSC1
+5 SET APCHSC1=APCHSC1_" "
SET APCHSC2=APCHSC2_" "
+6 IF APCHSC1'](APCHSCM_" ")
IF (APCHSCM_" ")']APCHSC2
SET D=1
+7 QUIT
LASTBP(P) ;EP
+1 ;exclude ER
+2 NEW APCHD,APCHC,APCHX,V,M,T
+3 KILL APCHX
+4 SET APCHX=""
SET APCHD=""
SET APCHC=0
+5 SET T=$ORDER(^AUTTMSR("B","BP",""))
+6 FOR
SET APCHD=$ORDER(^AUPNVMSR("AA",P,T,APCHD))
IF APCHD=""!(APCHC=1)
QUIT
Begin DoDot:1
+7 SET M=0
FOR
SET M=$ORDER(^AUPNVMSR("AA",P,T,APCHD,M))
IF M'=+M!(APCHC=1)
QUIT
Begin DoDot:2
+8 IF $PIECE($GET(^AUPNVMSR(M,2)),U,1)
QUIT
+9 SET V=$PIECE($GET(^AUPNVMSR(M,0)),U,3)
IF 'V
QUIT
+10 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+11 IF $$CLINIC^APCLV(V,"C")=30
QUIT
+12 SET APCHC=APCHC+1
SET APCHX(APCHC)=(9999999-APCHD)_U_U_$PIECE(^AUPNVMSR(M,0),U,4)
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 QUIT $GET(APCHX(1))
