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
Q
S1 ;
S %=$P(^TMP("APCHPHS",$J,"PHS",0),U)+1,$P(^TMP("APCHPHS",$J,"PHS",0),U)=%
S ^TMP("APCHPHS",$J,"PHS",%)=X
Q
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")=%
Q
;
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
Q
;
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
Q
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
