Routine: APCHPST2

APCHPST2 ; IHS/CMI/LAB - Patient Health Summary - Post Visit ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

EP ;EP - meds/ allergies/ measurements

MEDS ;

 S X="Medicines are important - it helps to know" D S(X,1)

 S X="",$E(X,5)="Why you will take it?" D S(X)

 S X="",$E(X,5)="When to take it?" D S(X)

 S X="",$E(X,5)="How much to take?"  D S(X)

 S X="",$E(X,5)="What to do if you forget to take it?"  D S(X)

 S X="",$E(X,5)="What could happen if you forget or take too much."  D S(X)

 S X="Knowing these things will help the medicine work best for you." D S(X)

 S X="Here is a list of the medicines you are taking:"  D S(X)

 S X="" D S(X)

 ;get all "active" meds

 S APCHSDLM=$$FMADD^XLFDT(DT,-365),APCHSDLM=9999999-APCHSDLM

 S APCHSIVD=0,APCHSMCT=0 F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVMED("AA",APCHSDFN,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  S APCHSMX=0 F APCHSQ=0:0 S APCHSMX=$O(^AUPNVMED("AA",APCHSDFN,APCHSIVD,APCHSMX)) Q:APCHSMX=""  D MEDBLD

 I $G(APCHSMCT)=0 S X="",$E(X,5)="No current meds on file" D S(X)

 S APCHSMED=""

 F  S APCHSMED=$O(APCHSM(APCHSMED)) Q:$G(APCHSMED)']""  D

 .S X="",$E(X,10)=APCHSMED D S(X)

.Q

 S X="Some other questions to ask your doctor, nurse or pharmacist about" D S(X,1)

 S X="your medications:" D S(X)

 S X="",$E(X,5)="Each medicine has 2 names -- the company name and a generic name" D S(X)

 S X="",$E(X,5)="of the ingredient."  D S(X)

 S X="",$E(X,5)="What is the medicine supposed to do?" D S(X)

 S X="",$E(X,5)="When should I see or feel that the medicine is working?" D S(X)

 S X="",$E(X,5)="What are things that I might see or feel, called side effects?" D S(X)

 S X="",$E(X,5)="What should I do if they occur?"  D S(X)

 S X="",$E(X,5)="Is the medicine for just a short time -- days or weeks -- or months/years?"  D S(X)

 S X="",$E(X,5)="Are there any foods, drinks, other medicines, dietary supplements that"  D S(X)

 S X="",$E(X,5)="will keep the medicine from working or make it dangerous?" D S(X)

ALLERG ;

 S X="Allergies, reactions that you've had to medicines or other things are very" D S(X,1)

 S X="important.  Below are the allergies that we know.  If anything is wrong or" D S(X)

 S X="missing, please let your provider know." D S(X)

 S X="" D S(X)

 S APCHSALD=0,APCHSALP=0,APCHSALG=0

 D EN^APCHPALG  ;get allergies from allergy tracking and problem list

 ;I $D(APCHENT) S X="",$E(X,5)="From Allergy Tracking System:",$E(X,45)="(v)=verified   (u)=unverified" D S(X)

 I $D(APCHENT) S X="",$E(X,5)="From Allergy Tracking System:" D S(X)

 I $D(APCHENT("A")) F  S APCHSALD=$O(APCHENT("A",APCHSALD)) Q:APCHSALD'=+APCHSALD  D

 .Q:$G(APCHSALD)']""

 .F  I $D(APCHENT("A")) S APCHSALP=$O(APCHENT("A",APCHSALD,APCHSALP)) Q:APCHSALP=""  Q:APCHSALD'=+APCHSALD  D

 ..S APCHSALG=1

 ..S X="",$E(X,5)=$G(APCHENT("A",APCHSALD,APCHSALP)) D S(X)

..Q

 I $D(APCHENT("P")) F  S APCHSALD=$O(APCHENT("P",APCHSALD)) Q:APCHSALD'=+APCHSALD  D

 .Q:$G(APCHSALD)']""

 .F  I $D(APCHENT("P")) S APCHSALP=$O(APCHENT("P",APCHSALD,APCHSALP)) Q:APCHSALP=""  Q:APCHSALD'=+APCHSALD  D

 ..S APCHSALG=1

 ..S X="",$E(X,5)=$G(APCHENT("P",APCHSALD,APCHSALP)) D S(X)

..Q

 I $D(APCHENT("U")) F  S APCHSALD=$O(APCHENT("U",APCHSALD)) Q:APCHSALD'=+APCHSALD  D

 .Q:$G(APCHSALD)']""

 .F  I $D(APCHENT("U")) S APCHSALP=$O(APCHENT("U",APCHSALD,APCHSALP)) Q:APCHSALP=""  Q:APCHSALD'=+APCHSALD  D

 ..S APCHSALG=1

 ..S X="",$E(X,5)=$G(APCHENT("A",APCHSALD,APCHSALP)) D S(X)

..Q

 S APCHSALD=0,APCHSALP=0,APCHSAPR=0

 D PROBA^APCHPALG  ;get allergies from Problem List

 I $D(APCHSPT) S X="",$E(X,5)="From Problem List" D S(X,1)

 I $D(APCHSPT) F  S APCHSALD=$O(APCHSPT(APCHSALD)) Q:APCHSALD'=+APCHSALD  D

 .S APCHSALP=$O(APCHSPT(APCHSALP))

 .Q:APCHSALP'=+APCHSALP

 .S APCHSAPR=1

 .S X="",$E(X,5)=$G(APCHSPT(APCHSALP)) D S(X)

.Q

 I APCHSALG=0,APCHSAPR=0 S X="",$E(X,5)="No allergies on file." D S(X)

MEAS ;

 S X="Weight is a good measure of health - and it depends on how tall you are." D S(X,1)

 D GETHWBBP(APCHSDFN)

 ;Convert APCHX("HT") to ft & inches

 I $G(APCHX("HT"))]"" S APCHFEET=APCHX("HT")/12,APCHINCH=$P(APCHFEET,".",2),APCHINCH="."_APCHINCH*12,APCHINCH=$J(APCHINCH,2,0),APCHFEET=$P(APCHFEET,".")

 I $G(APCHX("HT"))]"" S X="",$E(X,5)="You are "_APCHFEET_" feet and "_APCHINCH_" inches tall." D S(X)

 I $G(APCHX("WT"))="" S X="",$E(X,5)="No weight on file." D S(X)

 I $G(APCHX("HT"))']"" S X="",$E(X,5)="No height on file." D S(X)

 I $G(APCHX("WT"))]"" S X="",$E(X,5)="Your last weight is "_$J(APCHX("WT"),3,0)_" pounds." D S(X)

 I $G(APCHX("WT"))]"",$$FMDIFF^XLFDT(DT,APCHX("WTD"))>120 S X="",$E(X,5)="You should have your weight rechecked at your next visit"  D S(X)

 I $G(APCHX("WTD"))]"",APCHX("WTD")=DT,$G(APCHX("BMI"))]"" D

 .S X="",$E(X,5)="Your Body Mass Index today was "_APCHX("BMI")_".  This is a good way to" D S(X)

 .S X="",$E(X,5)="compare your height and weight." D S(X)

.Q

 I $G(APCHX("WTD"))]"",APCHX("WTD")<DT,$G(APCHX("BMI"))]"" D

 .S X="",$E(X,5)="Your Body Mass Index on "_$$FMTE^XLFDT(APCHX("WTD"))_" was "_APCHX("BMI")_"." D S(X)

.Q

 I $G(APCHX("BMI"))]"",APCHX("BMI")<25 S X="",$E(X,5)="You are at a healthy weight.  Keep up the good work!" D S(X)

 I APCHX("BMI")>26 D

 .S X="",$E(X,5)="You are above a healthy weight.  Too much weight can lead to lots" D S(X)

 .S X="",$E(X,5)="of health problems - diabetes, heart disease, back pain, leg pains," D S(X)

 .S X="",$E(X,5)="and more.  Ask your provider about things you can do to fix your weight." D S(X)

.Q

 I $G(APCHX("BP"))]"" S APCHSBP=$P(APCHX("BP"),"/"),APCHDBP=$P(APCHX("BP"),"/",2),X="Blood pressure is a good measure of health." D S(X,1)

 I $G(APCHX("BP"))]"" S X="",$E(X,5)="Your last blood pressure was "_APCHSBP_" over "_APCHDBP_" on "_$$FMTE^XLFDT(APCHX("BPD"))_"." D S(X) D

 .I $$AGE^AUPNPAT(APCHSDFN)>21,$$FMDIFF^XLFDT(DT,APCHX("BPD"))>365 S X="",$E(X,5)="You should have your blood pressure checked at your next visit." D S(X)

 .I $$AGE^AUPNPAT(APCHSDFN)>3,$$AGE^AUPNPAT(APCHSDFN)<22,$$FMDIFF^XLFDT(DT,APCHX("BPD"))>720 S X="You should have your blppd pressure checked at your next visit" D S(X)

.Q

 I $$AGE^AUPNPAT(APCHSDFN)>21,$G(APCHX("BP"))']"" S X="Blood pressure is a good measure of health." D S(X,1) S X="",$E(X,5)="You should have your blood pressure checked at your next visit." D S(X)

 I $$AGE^AUPNPAT(APCHSDFN)>3,$$AGE^AUPNPAT(APCHSDFN)<22,$G(APCHX("BP"))']"" S X="Blood pressure is a good measure of health." D S(X,1) S X="",$E(X,5)="You should have your blood pressure checked at your next visit." D S(X)

S(Y,F,C,T) ;set up array

 I '$G(F) S F=0

 I '$G(T) S T=0

 NEW %,X

 ;blank lines

 F F=1:1:F S X="" D S1

 S X=Y

 I $G(C) S L=$L(Y),T=(80-L)/2 D  D S1 Q

 .F %=1:1:(T-1) S X=" "_X

 F %=1:1:T S X=" "_Y

 D S1

S1 ;

 S %=$P(^TMP("APCHPHS",$J,"PHS",0),U)+1,$P(^TMP("APCHPHS",$J,"PHS",0),U)=%

 S ^TMP("APCHPHS",$J,"PHS",%)=X

DATE(D) ;EP - convert to slashed date

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

 Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)

GETHWBBP(P)  ;get last height, height date, weight, weight date, BMI and BP for patient P, return in APCHX("HT"),APCHX("HTD"),APCHX("WT"),APCHX("WTD"),APCHX("BMI")

 K APCHX

 S APCHX("HT")="",APCHX("HTD")="",APCHX("WT")="",APCHX("WTD")="",APCHX("BMI")="",APCHX("WC")="",APCHX("WCD")=""

LASTHT ;

 Q:'$D(^AUPNVSIT("AC",P))

 Q:'$D(^AUPNVMSR("AC",P))

 NEW APCHY

 S %=P_"^LAST MEAS HT" NEW X S E=$$START1^APCLDF(%,"APCHY(") S APCHX("HT")=$P($G(APCHY(1)),U,2),APCHX("HTD")=$P($G(APCHY(1)),U)

 S APCHX("HT")=$S(APCHX("HT")]"":$J(APCHX("HT"),2,0),1:"")

LASTWT ;

 K APCHY S %=P_"^LAST MEAS WT" NEW X S E=$$START1^APCLDF(%,"APCHY(") S APCHX("WT")=$P($G(APCHY(1)),U,2),APCHX("WTD")=$P($G(APCHY(1)),U)

LASTBP ;

 K APCHY S %=P_"^LAST MEAS BP" NEW X S E=$$START1^APCLDF(%,"APCHY(") S APCHX("BP")=$P($G(APCHY(1)),U,2),APCHX("BPD")=$P($G(APCHY(1)),U)

LASTWC ;

 K APCHY S %=P_"^LAST MEAS WC" NEW X S E=$$START1^APCLDF(%,"APCHY(") S APCHX("WC")=$P($G(APCHY(1)),U,2),APCHX("WCD")=$P($G(APCHY(1)),U)

BMI ;

 I $$AGE^AUPNPAT(P)<19,(APCHX("WTD")'=APCHX("HTD")) Q

 I APCHX("WT")=""!('APCHX("HT")) Q

 S %=""

 S W=APCHX("WT")*.45359,H=(APCHX("HT")*0.0254),H=(H*H),%=(W/H),%=$J(%,4,1)

 S APCHX("BMI")=%

MEDBLD ;BUILD ARRAY OF MEDICATIONS

 K APCHSRXP,APCHSCOT

 Q:'$D(^AUPNVMED(APCHSMX,0))

 S APCHSN=^AUPNVMED(APCHSMX,0)

 Q:'$D(^PSDRUG($P(APCHSN,U,1)))

 S APCHSDTM=-APCHSIVD\1+9999999  ;Visit date from V Med .03 field

 Q:$P(APCHSN,U,8)]""  ;date discontinued

 S APCHSRXP=$S($D(^PSRX("APCC",APCHSMX)):$O(^(APCHSMX,0)),1:0)  ;RX IEN

 I APCHSRXP>0 S RX0=^PSRX(APCHSRXP,0),RX2=^PSRX(APCHSRXP,2) D RXSTAT Q:ST="EXPIRED"!(ST="CANCELLED")!(ST="DELETED")  ;CALCULATE RX STATUS

 I $G(APCHSRXP)'>0 S APCHSCOT=1  ;may be using COTS or med entered via PCC data entry

 I $P($G(^AUPNVMED(APCHSMX,12)),U,9)]"" S APCHSCOT=1  ;external key present

 S APCHSSTA=$P($G(^PSRX(APCHSRXP,0)),U,15)  ;Active? RX File status

 Q:$G(APCHSSTA)>10  ;status is expired, deleted or cancelled

 S APCHSDYS=$P($G(APCHSN),U,7)  ;days supply

 ;Q:APCHSDYS=1  ;quit if only 1 day supply

 I $G(APCHSCOT)=1,$G(APCHSDYS)]"",$$FMDIFF^XLFDT(DT,APCHSDTM)>$G(APCHSDYS) Q

 Q:$P($G(^AUPNVMED(APCHSMX,0)),U,6)=1  ;quit if qty=1

 S APCHSMFX=$P(^PSDRUG(+APCHSN,0),U)  D  ;compare Drug File .01 field & V Med Name of Non Table Drug

 .Q:$P(APCHSN,U,4)=""

 .I $P($G(APCHSN),U,4)]"",$P($G(APCHSN),U,4)=$P(^PSDRUG(+APCHSN,0),U) Q

 .I $P($G(APCHSN),U,4)]"",$P($G(APCHSN),U,4)'=$P(^PSDRUG(+APCHSN,0),U) S APCHSMFX=$P(APCHSN,U,4)

.Q

 I $G(APCHSM(APCHSMFX)) Q  ;quit if med already exists

 S APCHSM(APCHSMFX)=+APCHSN_U_APCHSDYS  ;PSDRUG ien^days supply

 I $G(APCHSRXP)>0 S $P(APCHSM(APCHSMFX),U,3)=APCHSRXP  ;^PSRX ien

 S $P(APCHSM(APCHSMFX),U,4)=$G(ST)  ;status from RXSTAT

 S APCHSMCT=APCHSMCT+1  ;number of active meds

GETLABSX ;get lab tests ordered today

 S APCHLR=$G(^DPT(APCHSDFN,"LR"))

 I $G(APCHLR)]"" S APCHLRO=0,APCHTSTP=0 D

 .F  S APCHLRO=$O(^LRO(69,DT,1,"AA",APCHLR,APCHLRO)) Q:APCHLRO=""  Q:APCHLRO'=+APCHLRO  D

 ..F  S APCHTSTP=$O(^LRO(69,DT,1,APCHLRO,2,"B",APCHTSTP)) Q:APCHTSTP'=+APCHTSTP  D

 ...S APCHTCTR=$O(^LRO(69,DT,1,APCHLRO,2,"B",APCHTSTP,0))

 ...S APCHTEST=$P(^LAB(60,APCHTSTP,0),U)

 ...S APCHTST(APCHTEST)=""

 ...Q

RXSTAT ;gets status of rx ... TAKEN FROM PSOFUNC ROUTINE

 Q:$G(APCHSRXP)'>0

 S J=APCHSRXP

 S ST0=+$P(RX0,"^",15) I ST0<12,$O(^PS(52.5,"B",J,0)),$D(^PS(52.5,+$O(^(0)),0)),'$G(^("P")) S ST0=5

 I ST0<12,$P(RX2,"^",6)'>DT S ST0=11

 S ST=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL FILL^HOLD^PENDING DUE TO DRUG INTERACTION^SUSPENDED^^^^^DONE^EXPIRED^CANCELLED^DELETED","^",ST0+2),$P(RX0,"^",15)=ST0

APCHPST2  ; IHS/CMI/LAB - Patient Health Summary - Post Visit ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;

 +3       ;

 +4       ;

EP        ;EP - meds/ allergies/ measurements

MEDS      ;

 +1        SET X="Medicines are important - it helps to know"

           DO S(X,1)

 +2        SET X=""

           SET $EXTRACT(X,5)="Why you will take it?"

           DO S(X)

 +3        SET X=""

           SET $EXTRACT(X,5)="When to take it?"

           DO S(X)

 +4        SET X=""

           SET $EXTRACT(X,5)="How much to take?"

           DO S(X)

 +5        SET X=""

           SET $EXTRACT(X,5)="What to do if you forget to take it?"

           DO S(X)

 +6        SET X=""

           SET $EXTRACT(X,5)="What could happen if you forget or take too much."

           DO S(X)

 +7        SET X="Knowing these things will help the medicine work best for you."

           DO S(X)

 +8        SET X="Here is a list of the medicines you are taking:"

           DO S(X)

 +9        SET X=""

           DO S(X)

 +10      ;

 +11      ;get all "active" meds

 +12       SET APCHSDLM=$$FMADD^XLFDT(DT,-365)

           SET APCHSDLM=9999999-APCHSDLM

 +13       SET APCHSIVD=0

           SET APCHSMCT=0

           FOR APCHSQ=0:0

               SET APCHSIVD=$ORDER(^AUPNVMED("AA",APCHSDFN,APCHSIVD))

               IF APCHSIVD=""!(APCHSIVD>APCHSDLM)

                   QUIT

               SET APCHSMX=0

               FOR APCHSQ=0:0

                   SET APCHSMX=$ORDER(^AUPNVMED("AA",APCHSDFN,APCHSIVD,APCHSMX))

                   IF APCHSMX=""

                       QUIT

                   DO MEDBLD

 +14       IF $GET(APCHSMCT)=0

               SET X=""

               SET $EXTRACT(X,5)="No current meds on file"

               DO S(X)

 +15       SET APCHSMED=""

 +16       FOR

               SET APCHSMED=$ORDER(APCHSM(APCHSMED))

               IF $GET(APCHSMED)']""

                   QUIT

               Begin DoDot:1

 +17               SET X=""

                   SET $EXTRACT(X,10)=APCHSMED

                   DO S(X)

 +18               QUIT

               End DoDot:1

 +19       SET X="Some other questions to ask your doctor, nurse or pharmacist about"

           DO S(X,1)

 +20       SET X="your medications:"

           DO S(X)

 +21       SET X=""

           SET $EXTRACT(X,5)="Each medicine has 2 names -- the company name and a generic name"

           DO S(X)

 +22       SET X=""

           SET $EXTRACT(X,5)="of the ingredient."

           DO S(X)

 +23       SET X=""

           SET $EXTRACT(X,5)="What is the medicine supposed to do?"

           DO S(X)

 +24       SET X=""

           SET $EXTRACT(X,5)="When should I see or feel that the medicine is working?"

           DO S(X)

 +25       SET X=""

           SET $EXTRACT(X,5)="What are things that I might see or feel, called side effects?"

           DO S(X)

 +26       SET X=""

           SET $EXTRACT(X,5)="What should I do if they occur?"

           DO S(X)

 +27       SET X=""

           SET $EXTRACT(X,5)="Is the medicine for just a short time -- days or weeks -- or months/years?"

           DO S(X)

 +28       SET X=""

           SET $EXTRACT(X,5)="Are there any foods, drinks, other medicines, dietary supplements that"

           DO S(X)

 +29       SET X=""

           SET $EXTRACT(X,5)="will keep the medicine from working or make it dangerous?"

           DO S(X)

 +30      ;

ALLERG    ;

 +1        SET X="Allergies, reactions that you've had to medicines or other things are very"

           DO S(X,1)

 +2        SET X="important.  Below are the allergies that we know.  If anything is wrong or"

           DO S(X)

 +3        SET X="missing, please let your provider know."

           DO S(X)

 +4        SET X=""

           DO S(X)

 +5        SET APCHSALD=0

           SET APCHSALP=0

           SET APCHSALG=0

 +6       ;get allergies from allergy tracking and problem list

           DO EN^APCHPALG

 +7       ;I $D(APCHENT) S X="",$E(X,5)="From Allergy Tracking System:",$E(X,45)="(v)=verified   (u)=unverified" D S(X)

 +8        IF $DATA(APCHENT)

               SET X=""

               SET $EXTRACT(X,5)="From Allergy Tracking System:"

               DO S(X)

 +9        IF $DATA(APCHENT("A"))

FOR

                   SET APCHSALD=$ORDER(APCHENT("A",APCHSALD))

                   IF APCHSALD'=+APCHSALD

                       QUIT

                   Begin DoDot:1

 +10                   IF $GET(APCHSALD)']""

                           QUIT

 +11                   FOR

                           IF $DATA(APCHENT("A"))

                               SET APCHSALP=$ORDER(APCHENT("A",APCHSALD,APCHSALP))

                               IF APCHSALP=""

                                   QUIT

                               IF APCHSALD'=+APCHSALD

                                   QUIT

                               Begin DoDot:2

 +12                               SET APCHSALG=1

 +13                               SET X=""

                                   SET $EXTRACT(X,5)=$GET(APCHENT("A",APCHSALD,APCHSALP))

                                   DO S(X)

 +14                               QUIT

                               End DoDot:2

                   End DoDot:1

 +15       IF $DATA(APCHENT("P"))

FOR

                   SET APCHSALD=$ORDER(APCHENT("P",APCHSALD))

                   IF APCHSALD'=+APCHSALD

                       QUIT

                   Begin DoDot:1

 +16                   IF $GET(APCHSALD)']""

                           QUIT

 +17                   FOR

                           IF $DATA(APCHENT("P"))

                               SET APCHSALP=$ORDER(APCHENT("P",APCHSALD,APCHSALP))

                               IF APCHSALP=""

                                   QUIT

                               IF APCHSALD'=+APCHSALD

                                   QUIT

                               Begin DoDot:2

 +18                               SET APCHSALG=1

 +19                               SET X=""

                                   SET $EXTRACT(X,5)=$GET(APCHENT("P",APCHSALD,APCHSALP))

                                   DO S(X)

 +20                               QUIT

                               End DoDot:2

                   End DoDot:1

 +21       IF $DATA(APCHENT("U"))

FOR

                   SET APCHSALD=$ORDER(APCHENT("U",APCHSALD))

                   IF APCHSALD'=+APCHSALD

                       QUIT

                   Begin DoDot:1

 +22                   IF $GET(APCHSALD)']""

                           QUIT

 +23                   FOR

                           IF $DATA(APCHENT("U"))

                               SET APCHSALP=$ORDER(APCHENT("U",APCHSALD,APCHSALP))

                               IF APCHSALP=""

                                   QUIT

                               IF APCHSALD'=+APCHSALD

                                   QUIT

                               Begin DoDot:2

 +24                               SET APCHSALG=1

 +25                               SET X=""

                                   SET $EXTRACT(X,5)=$GET(APCHENT("A",APCHSALD,APCHSALP))

                                   DO S(X)

 +26                               QUIT

                               End DoDot:2

                   End DoDot:1

 +27      ;

 +28       SET APCHSALD=0

           SET APCHSALP=0

           SET APCHSAPR=0

 +29      ;get allergies from Problem List

           DO PROBA^APCHPALG

 +30       IF $DATA(APCHSPT)

               SET X=""

               SET $EXTRACT(X,5)="From Problem List"

               DO S(X,1)

 +31       IF $DATA(APCHSPT)

FOR

                   SET APCHSALD=$ORDER(APCHSPT(APCHSALD))

                   IF APCHSALD'=+APCHSALD

                       QUIT

                   Begin DoDot:1

 +32                   SET APCHSALP=$ORDER(APCHSPT(APCHSALP))

 +33                   IF APCHSALP'=+APCHSALP

                           QUIT

 +34                   SET APCHSAPR=1

 +35                   SET X=""

                       SET $EXTRACT(X,5)=$GET(APCHSPT(APCHSALP))

                       DO S(X)

 +36                   QUIT

                   End DoDot:1

 +37       IF APCHSALG=0

               IF APCHSAPR=0

                   SET X=""

                   SET $EXTRACT(X,5)="No allergies on file."

                   DO S(X)

 +38      ;

MEAS      ;

 +1        SET X="Weight is a good measure of health - and it depends on how tall you are."

           DO S(X,1)

 +2        DO GETHWBBP(APCHSDFN)

 +3       ;Convert APCHX("HT") to ft & inches

 +4        IF $GET(APCHX("HT"))]""

               SET APCHFEET=APCHX("HT")/12

               SET APCHINCH=$PIECE(APCHFEET,".",2)

               SET APCHINCH="."_APCHINCH*12

               SET APCHINCH=$JUSTIFY(APCHINCH,2,0)

               SET APCHFEET=$PIECE(APCHFEET,".")

 +5        IF $GET(APCHX("HT"))]""

               SET X=""

               SET $EXTRACT(X,5)="You are "_APCHFEET_" feet and "_APCHINCH_" inches tall."

               DO S(X)

 +6       ;

 +7        IF $GET(APCHX("WT"))=""

               SET X=""

               SET $EXTRACT(X,5)="No weight on file."

               DO S(X)

 +8        IF $GET(APCHX("HT"))']""

               SET X=""

               SET $EXTRACT(X,5)="No height on file."

               DO S(X)

 +9        IF $GET(APCHX("WT"))]""

               SET X=""

               SET $EXTRACT(X,5)="Your last weight is "_$JUSTIFY(APCHX("WT"),3,0)_" pounds."

               DO S(X)

 +10       IF $GET(APCHX("WT"))]""

               IF $$FMDIFF^XLFDT(DT,APCHX("WTD"))>120

                   SET X=""

                   SET $EXTRACT(X,5)="You should have your weight rechecked at your next visit"

                   DO S(X)

 +11       IF $GET(APCHX("WTD"))]""

               IF APCHX("WTD")=DT

                   IF $GET(APCHX("BMI"))]""

                       Begin DoDot:1

 +12                       SET X=""

                           SET $EXTRACT(X,5)="Your Body Mass Index today was "_APCHX("BMI")_".  This is a good way to"

                           DO S(X)

 +13                       SET X=""

                           SET $EXTRACT(X,5)="compare your height and weight."

                           DO S(X)

 +14                       QUIT

                       End DoDot:1

 +15       IF $GET(APCHX("WTD"))]""

               IF APCHX("WTD")<DT

                   IF $GET(APCHX("BMI"))]""

                       Begin DoDot:1

 +16                       SET X=""

                           SET $EXTRACT(X,5)="Your Body Mass Index on "_$$FMTE^XLFDT(APCHX("WTD"))_" was "_APCHX("BMI")_"."

                           DO S(X)

 +17                       QUIT

                       End DoDot:1

 +18       IF $GET(APCHX("BMI"))]""

               IF APCHX("BMI")<25

                   SET X=""

                   SET $EXTRACT(X,5)="You are at a healthy weight.  Keep up the good work!"

                   DO S(X)

 +19       IF APCHX("BMI")>26

               Begin DoDot:1

 +20               SET X=""

                   SET $EXTRACT(X,5)="You are above a healthy weight.  Too much weight can lead to lots"

                   DO S(X)

 +21               SET X=""

                   SET $EXTRACT(X,5)="of health problems - diabetes, heart disease, back pain, leg pains,"

                   DO S(X)

 +22               SET X=""

                   SET $EXTRACT(X,5)="and more.  Ask your provider about things you can do to fix your weight."

                   DO S(X)

 +23               QUIT

               End DoDot:1

 +24      ;

 +25       IF $GET(APCHX("BP"))]""

               SET APCHSBP=$PIECE(APCHX("BP"),"/")

               SET APCHDBP=$PIECE(APCHX("BP"),"/",2)

               SET X="Blood pressure is a good measure of health."

               DO S(X,1)

 +26       IF $GET(APCHX("BP"))]""

               SET X=""

               SET $EXTRACT(X,5)="Your last blood pressure was "_APCHSBP_" over "_APCHDBP_" on "_$$FMTE^XLFDT(APCHX("BPD"))_"."

               DO S(X)

               Begin DoDot:1

 +27               IF $$AGE^AUPNPAT(APCHSDFN)>21

                       IF $$FMDIFF^XLFDT(DT,APCHX("BPD"))>365

                           SET X=""

                           SET $EXTRACT(X,5)="You should have your blood pressure checked at your next visit."

                           DO S(X)

 +28               IF $$AGE^AUPNPAT(APCHSDFN)>3

                       IF $$AGE^AUPNPAT(APCHSDFN)<22

                           IF $$FMDIFF^XLFDT(DT,APCHX("BPD"))>720

                               SET X="You should have your blppd pressure checked at your next visit"

                               DO S(X)

 +29               QUIT

               End DoDot:1

 +30       IF $$AGE^AUPNPAT(APCHSDFN)>21

               IF $GET(APCHX("BP"))']""

                   SET X="Blood pressure is a good measure of health."

                   DO S(X,1)

                   SET X=""

                   SET $EXTRACT(X,5)="You should have your blood pressure checked at your next visit."

                   DO S(X)

 +31       IF $$AGE^AUPNPAT(APCHSDFN)>3

               IF $$AGE^AUPNPAT(APCHSDFN)<22

                   IF $GET(APCHX("BP"))']""

                       SET X="Blood pressure is a good measure of health."

                       DO S(X,1)

                       SET X=""

                       SET $EXTRACT(X,5)="You should have your blood pressure checked at your next visit."

                       DO S(X)

S(Y,F,C,T) ;set up array

 +1        IF '$GET(F)

               SET F=0

 +2        IF '$GET(T)

               SET T=0

 +3        NEW %,X

 +4       ;blank lines

 +5        FOR F=1:1:F

               SET X=""

               DO S1

 +6        SET X=Y

 +7        IF $GET(C)

               SET L=$LENGTH(Y)

               SET T=(80-L)/2

               Begin DoDot:1

 +8                FOR %=1:1:(T-1)

                       SET X=" "_X

               End DoDot:1

               DO S1

               QUIT

 +9        FOR %=1:1:T

               SET X=" "_Y

 +10       DO S1

 +11       QUIT

S1        ;

 +1        SET %=$PIECE(^TMP("APCHPHS",$JOB,"PHS",0),U)+1

           SET $PIECE(^TMP("APCHPHS",$JOB,"PHS",0),U)=%

 +2        SET ^TMP("APCHPHS",$JOB,"PHS",%)=X

 +3        QUIT

DATE(D)   ;EP - convert to slashed date

 +1        IF $GET(D)=""

               QUIT ""

 +2        QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)

GETHWBBP(P) ;get last height, height date, weight, weight date, BMI and BP for patient P, return in APCHX("HT"),APCHX("HTD"),APCHX("WT"),APCHX("WTD"),APCHX("BMI")

 +1        KILL APCHX

 +2        SET APCHX("HT")=""

           SET APCHX("HTD")=""

           SET APCHX("WT")=""

           SET APCHX("WTD")=""

           SET APCHX("BMI")=""

           SET APCHX("WC")=""

           SET APCHX("WCD")=""

LASTHT    ;

 +1        IF '$DATA(^AUPNVSIT("AC",P))

               QUIT

 +2        IF '$DATA(^AUPNVMSR("AC",P))

               QUIT

 +3        NEW APCHY

 +4        SET %=P_"^LAST MEAS HT"

           NEW X

           SET E=$$START1^APCLDF(%,"APCHY(")

           SET APCHX("HT")=$PIECE($GET(APCHY(1)),U,2)

           SET APCHX("HTD")=$PIECE($GET(APCHY(1)),U)

 +5        SET APCHX("HT")=$SELECT(APCHX("HT")]"":$JUSTIFY(APCHX("HT"),2,0),1:"")

LASTWT    ;

 +1        KILL APCHY

           SET %=P_"^LAST MEAS WT"

           NEW X

           SET E=$$START1^APCLDF(%,"APCHY(")

           SET APCHX("WT")=$PIECE($GET(APCHY(1)),U,2)

           SET APCHX("WTD")=$PIECE($GET(APCHY(1)),U)

LASTBP    ;

 +1        KILL APCHY

           SET %=P_"^LAST MEAS BP"

           NEW X

           SET E=$$START1^APCLDF(%,"APCHY(")

           SET APCHX("BP")=$PIECE($GET(APCHY(1)),U,2)

           SET APCHX("BPD")=$PIECE($GET(APCHY(1)),U)

LASTWC    ;

 +1        KILL APCHY

           SET %=P_"^LAST MEAS WC"

           NEW X

           SET E=$$START1^APCLDF(%,"APCHY(")

           SET APCHX("WC")=$PIECE($GET(APCHY(1)),U,2)

           SET APCHX("WCD")=$PIECE($GET(APCHY(1)),U)

BMI       ;

 +1        IF $$AGE^AUPNPAT(P)<19

               IF (APCHX("WTD")'=APCHX("HTD"))

                   QUIT

 +2        IF APCHX("WT")=""!('APCHX("HT"))

               QUIT

 +3        SET %=""

 +4        SET W=APCHX("WT")*.45359

           SET H=(APCHX("HT")*0.0254)

           SET H=(H*H)

           SET %=(W/H)

           SET %=$JUSTIFY(%,4,1)

 +5        SET APCHX("BMI")=%

 +6        QUIT

 +7       ;

MEDBLD    ;BUILD ARRAY OF MEDICATIONS

 +1       ;

 +2        KILL APCHSRXP,APCHSCOT

 +3        IF '$DATA(^AUPNVMED(APCHSMX,0))

               QUIT

 +4        SET APCHSN=^AUPNVMED(APCHSMX,0)

 +5        IF '$DATA(^PSDRUG($PIECE(APCHSN,U,1)))

               QUIT

 +6       ;Visit date from V Med .03 field

           SET APCHSDTM=-APCHSIVD\1+9999999

 +7       ;date discontinued

           IF $PIECE(APCHSN,U,8)]""

               QUIT

 +8       ;RX IEN

           SET APCHSRXP=$SELECT($DATA(^PSRX("APCC",APCHSMX)):$ORDER(^(APCHSMX,0)),1:0)

 +9       ;CALCULATE RX STATUS

           IF APCHSRXP>0

               SET RX0=^PSRX(APCHSRXP,0)

               SET RX2=^PSRX(APCHSRXP,2)

               DO RXSTAT

               IF ST="EXPIRED"!(ST="CANCELLED")!(ST="DELETED")

                   QUIT

 +10      ;may be using COTS or med entered via PCC data entry

           IF $GET(APCHSRXP)'>0

               SET APCHSCOT=1

 +11      ;external key present

           IF $PIECE($GET(^AUPNVMED(APCHSMX,12)),U,9)]""

               SET APCHSCOT=1

 +12      ;Active? RX File status

           SET APCHSSTA=$PIECE($GET(^PSRX(APCHSRXP,0)),U,15)

 +13      ;status is expired, deleted or cancelled

           IF $GET(APCHSSTA)>10

               QUIT

 +14      ;days supply

           SET APCHSDYS=$PIECE($GET(APCHSN),U,7)

 +15      ;Q:APCHSDYS=1  ;quit if only 1 day supply

 +16       IF $GET(APCHSCOT)=1

               IF $GET(APCHSDYS)]""

                   IF $$FMDIFF^XLFDT(DT,APCHSDTM)>$GET(APCHSDYS)

                       QUIT

 +17      ;quit if qty=1

           IF $PIECE($GET(^AUPNVMED(APCHSMX,0)),U,6)=1

               QUIT

 +18      ;compare Drug File .01 field & V Med Name of Non Table Drug

           SET APCHSMFX=$PIECE(^PSDRUG(+APCHSN,0),U)

           Begin DoDot:1

 +19           IF $PIECE(APCHSN,U,4)=""

                   QUIT

 +20           IF $PIECE($GET(APCHSN),U,4)]""

                   IF $PIECE($GET(APCHSN),U,4)=$PIECE(^PSDRUG(+APCHSN,0),U)

                       QUIT

 +21           IF $PIECE($GET(APCHSN),U,4)]""

                   IF $PIECE($GET(APCHSN),U,4)'=$PIECE(^PSDRUG(+APCHSN,0),U)

                       SET APCHSMFX=$PIECE(APCHSN,U,4)

 +22           QUIT

           End DoDot:1

 +23      ;quit if med already exists

           IF $GET(APCHSM(APCHSMFX))

               QUIT

 +24      ;PSDRUG ien^days supply

           SET APCHSM(APCHSMFX)=+APCHSN_U_APCHSDYS

 +25      ;^PSRX ien

           IF $GET(APCHSRXP)>0

               SET $PIECE(APCHSM(APCHSMFX),U,3)=APCHSRXP

 +26      ;status from RXSTAT

           SET $PIECE(APCHSM(APCHSMFX),U,4)=$GET(ST)

 +27      ;number of active meds

           SET APCHSMCT=APCHSMCT+1

 +28       QUIT

 +29      ;

GETLABSX  ;get lab tests ordered today

 +1       ;

 +2        SET APCHLR=$GET(^DPT(APCHSDFN,"LR"))

 +3        IF $GET(APCHLR)]""

               SET APCHLRO=0

               SET APCHTSTP=0

               Begin DoDot:1

 +4                FOR

                       SET APCHLRO=$ORDER(^LRO(69,DT,1,"AA",APCHLR,APCHLRO))

                       IF APCHLRO=""

                           QUIT

                       IF APCHLRO'=+APCHLRO

                           QUIT

                       Begin DoDot:2

 +5                        FOR

                               SET APCHTSTP=$ORDER(^LRO(69,DT,1,APCHLRO,2,"B",APCHTSTP))

                               IF APCHTSTP'=+APCHTSTP

                                   QUIT

                               Begin DoDot:3

 +6                                SET APCHTCTR=$ORDER(^LRO(69,DT,1,APCHLRO,2,"B",APCHTSTP,0))

 +7                                SET APCHTEST=$PIECE(^LAB(60,APCHTSTP,0),U)

 +8                                SET APCHTST(APCHTEST)=""

 +9                                QUIT

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +10      ;

 +11      ;

RXSTAT    ;gets status of rx ... TAKEN FROM PSOFUNC ROUTINE

 +1        IF $GET(APCHSRXP)'>0

               QUIT

 +2        SET J=APCHSRXP

 +3        SET ST0=+$PIECE(RX0,"^",15)

           IF ST0<12

               IF $ORDER(^PS(52.5,"B",J,0))

                   IF $DATA(^PS(52.5,+$ORDER(^(0)),0))

                       IF '$GET(^("P"))

                           SET ST0=5

 +4        IF ST0<12

               IF $PIECE(RX2,"^",6)'>DT

                   SET ST0=11

 +5        SET ST=$PIECE("ERROR^ACTIVE^NON-VERIFIED^REFILL FILL^HOLD^PENDING DUE TO DRUG INTERACTION^SUSPENDED^^^^^DONE^EXPIRED^CANCELLED^DELETED","^",ST0+2)

           SET $PIECE(RX0,"^",15)=ST0

 +6        QUIT

APCHPST2.m