BPCDBS1 ; IHS/OIT/MJL - DIABETIC CARE SUMMARY SUPPLEMENT ;
;;1.5;BPC;;MAY 26, 2005
;;2.0T4;IHS RPMS/PCC Health Summary;;MAR 24, 1997
;
;
EP ;EP - called from component
Q:'$G(APCHSPAT)
I $E(IOST)="C" S DIR(0)="E" D ^DIR
I $D(DIRUT) S APCHSQIT=1 Q
D EP2(APCHSPAT)
W ;write out array
W:$D(IOF) @IOF
K APCHQUIT
S APCHX=0 F S APCHX=$O(^TMP("APCHS",$J,"DCS",APCHX)) Q:APCHX'=+APCHX!($D(APCHQUIT)) D
.I $Y>(IOSL-3) D HEADER Q:$D(APCHQUIT)
.W !,^TMP("APCHS",$J,"DCS",APCHX)
.Q
I $D(APCHQUIT) S APCHSQIT=1
D EOJ
Q
;
EOJ ;
K APCHX,APCHQUIT,APCHY,APCHSDFN,APCHSBEG,APCHSTOB,APCHSUPI,APCHSED,APCHTOBN,APCHTOB
K N,%,T,F,X,Y,B,C,E,F,H,L,N,P,T,W
Q
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCHQUIT="" Q
HEAD1 ;
W:$D(IOF) @IOF
Q
EP2(APCHSDFN) ;EP - PASS DFN get back array of patient care summary
;at this point you are stuck with ^TMP("APCHS",$J,"DCS"
K ^TMP("APCHS",$J,"DCS")
S ^TMP("APCHS",$J,"DCS",0)=0
D SETARRAY
Q
SETARRAY ;set up array containing dm care summary
;CHECK TO SEE IF START1^APCLDF EXISTS
S X="APCLDF" X ^%ZOSF("TEST") I '$T Q
S X="DIABETES PATIENT CARE SUMMARY Report Date: "_$$FMTE^XLFDT(DT) D S(X)
S X="AGE: "_$$AGE^AUPNPAT(APCHSDFN),$E(X,15)="Sex: "_$$SEX^AUPNPAT(APCHSDFN),$E(X,31)="Date of DM Onset: "_$$DOO(APCHSDFN) D S(X,1,"","")
D GETHWB(APCHSDFN) S X="Last Height: "_APCHX("HT"),$E(X,31)=APCHX("HTD"),$E(X,50)="BMI: "_APCHX("BMI") D S(X)
S X="Last Weight: "_APCHX("WT"),$E(X,31)=APCHX("WTD") D S(X)
D TOBACCO
S X="Tobacco Use: "_$G(APCHTOB),$E(X,50)="HTN documented (Dx): "_$$HTN(APCHSDFN) D S(X,1)
S B=$$BP(APCHSDFN)
S X="Last 3 BP: "_$P($G(APCHX(1)),U,2)_" "_$$FMTE^XLFDT($P($G(APCHX(1)),U))
D S(X,1)
S X="" I $D(APCHX(2)) S X="",$E(X,13)=$P(APCHX(2),U,2)_" "_$$FMTE^XLFDT($P(APCHX(2),U))
D S(X)
S X="" I $D(APCHX(3)) S X="",$E(X,13)=$P(APCHX(3),U,2)_" "_$$FMTE^XLFDT($P(APCHX(3),U))
D S(X)
M12 ;
;determine date range
S APCHSBEG=$E(DT,1,3)-1_$E(DT,4,7)
S X="In past 12 months:" D S(X,1)
S X="Diabetic Foot Exam:",$E(X,27)=$$DFE(APCHSDFN,APCHSBEG) D S(X)
S X="Diabetic Eye Exam:",$E(X,27)=$$EYE(APCHSDFN,APCHSBEG) D S(X)
S X="Dental Exam:",$E(X,27)=$$DENTAL(APCHSDFN,APCHSBEG) D S(X)
S X="Rectal Exam (age>40):",$E(X,27)=$$RECTAL(APCHSDFN,APCHSBEG) D S(X)
S X=" (Females Only)" D S(X)
S X=" Pap Smear:",$E(X,27)=$$PAP(APCHSDFN,APCHSBEG) D S(X)
S X=" Breast exam:",$E(X,27)=$$BREAST(APCHSDFN,APCHSBEG) D S(X)
S X=" Last Mammogram:",$E(X,27)=$$MAMMOG(APCHSDFN) D S(X)
;D MORE^APCHS9B2
S X=$P(^DPT(APCHSDFN,0),U),$E(X,35)="DOB: "_$$DOB^AUPNPAT(APCHSDFN,"S"),$E(X,55)="Chart #"_$$HRN^AUPNPAT(APCHSDFN,DUZ(2),2) D S(X,3)
S X="" D S(X,1)
Q
S(Y,F,C,T) ;set up array
I '$G(F) S F=0
I '$G(T) S T=0
;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("APCHS",$J,"DCS",0),U)+1,$P(^TMP("APCHS",$J,"DCS",0),U)=%
S ^TMP("APCHS",$J,"DCS",%)=X
Q
HTN(P) ;
NEW APCHX,X
S APCHX=""
S X=P_"^DX [SURVEILLANCE HYPERTENSION" S E=$$START1^APCLDF(X,"APCHX(") I $D(APCHX(1)) S APCHX="Yes"
I $G(APCHX)="" S APCHX="No"
Q APCHX
BP(P) ;last 3 BPs
K APCHX
S APCHX=""
S X=P_"^LAST 3 MEASUREMENTS BP" S E=$$START1^APCLDF(X,"APCHX(")
I '$D(APCHX) S APCHX(1)="None recorded"
Q APCHX
DOO(P) ;get first dm dx from case management
NEW APCHX,X
S APCHX=""
S X=P_"^PROBLEM [DM AUDIT PROBLEM DIABETES DX" S E=$$START1^APCLDF(X,"APCHX(") I $D(APCHX(1)) S APCHX=$P(^AUPNPROB(+$P(APCHX(1),U,4),0),U,13)
I APCHX]"" S APCHX=$$FMTE^XLFDT(APCHX)
Q APCHX
GETHWB(P) ;get last height, height date, weight, weight date and BMI 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")=""
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")=$$FMTE^XLFDT($P($G(APCHY(1)),U))
S APCHX("HT")=$J(APCHX("HT"),2,0)
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")=$$FMTE^XLFDT($P($G(APCHY(1)),U))
BMI ;
I APCHX("WT")=""!('APCHX("HT")) Q
S %=""
S W=(APCHX("WT")/5)*2.3,H=(APCHX("HT")*2.5),H=(H*H)/10000,%=(W/H),%=$J(%,4,1)
S APCHX("BMI")=%
Q
TOBACCO ;EP
K APCHTOB
D TOBACCO3
I $D(APCHTOB) Q
D TOBACCO0
I $D(APCHTOB) Q
D TOBACCO1 ;check Problem file for tobacco use
I $D(APCHTOB) Q
D TOBACCO2 ;check POVs for tobacco use
I $D(APCHTOB) Q
S APCHTOB="UNDOCUMENTED",APCHTOB="UNDOCUMENTED"
Q
TOBACCO0 ;check for tobacco documented in health factors
K APCH S APCHX=APCHSDFN_"^LAST HEALTH [DM AUDIT TOBACCO HLTH FACTORS" S E=$$START1^APCLDF(APCHX,"APCH(") Q:E I $D(APCH(1)) D S APCHTOBN=$O(APCHTOB("")),APCHTOB=APCHTOB(APCHTOBN)
. I $P(APCH(1),U,3)["NON" S APCHTOB="NO, DOES NOT USE TOBACCO" Q
. I $P(APCH(1),U,3)["PREVIOUS" S APCHTOB="PAST USE OF TOBACCO" Q
. S APCHTOB="YES, USES TOBACCO"
.Q
Q
TOBACCO3 ;lookup in health status
S %=$O(^ATXAX("B","DM AUDIT TOBACCO HLTH FACTORS",0))
Q:'%
S (X,Y)=0 F S X=$O(^AUPNHF("AA",APCHSDFN,X)) Q:X'=+X!(Y) I $D(^ATXAX(%,21,"B",X)) S Y=X
Q:'Y
S Y=$P(^AUTTHF(Y,0),U)
S APCHTOB=Y
I Y["NON" S APCHTOB="NO, DOES NOT USE TOBACCO" Q
I Y["PREVIOUS" S APCHTOB="PAST USE OF TOBACCO" Q
S APCHTOB="YES, USES TOBACCO"
Q
TOBACCO1 ;check problem file for tobacco use
K APCH S APCHX=APCHSDFN_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS" S E=$$START1^APCLDF(APCHX,"APCH(") Q:E I $D(APCH(1)) D S APCHTOBN=$O(APCHTOB("")),APCHTOB=APCHTOB(APCHTOBN)
. I $P(^ICD9($P(APCH(1),U,2),0),U,1)=305.13 S APCHTOB="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCH(1),U,4),0),U,5),0),U),1,30) Q
. S APCHTOB="YES, USES TOBACCO - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCH(1),U,4),0),U,5),0),U),1,30)
.Q
Q
TOBACCO2 ;check pov file for TOBACCO USE DOC
K APCH S APCHX=APCHSDFN_"^LAST DX [DM AUDIT SMOKING RELATED DXS" S E=$$START1^APCLDF(APCHX,"APCH(") Q:E I $D(APCH(1)) D S APCHTOBN=$O(APCHTOB("")),APCHTOB=APCHTOB(APCHTOBN)
. I $P(APCH(1),U,2)=305.13 S APCHTOB="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(APCH(1),U,4),0),U,4),0),U),1,30) Q
. S APCHTOB="YES, USES TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(APCH(1),U,4),0),U,4),0),U),1,30)
.Q
Q
;
;;3.0;IHS PCC REPORTS;;FEB 05, 1997
DFE(P,APCHSED) ;
NEW APCHY S %=P_"^LAST EXAM DIABETIC FOOT EXAM",E=$$START1^APCLDF(%,"APCHY(")
I '$D(APCHY) Q "No <never recorded>"
I $P(APCHY(1),U)'<APCHSED S APCHX="Yes "_$$FMTE^XLFDT($P(APCHY(1),U))
Q "No "_$$FMTE^XLFDT($P(APCHY(1),U))
EYE(P,APCHSED) ;
NEW APCHY S %=P_"^LAST EXAM DIABETIC EYE EXAM",E=$$START1^APCLDF(%,"APCHY(")
I '$D(APCHY) Q "No <never recorded>"
I $P(APCHY(1),U)'<APCHSED S APCHX="Yes "_$$FMTE^XLFDT($P(APCHY(1),U))
Q "No "_$$FMTE^XLFDT($P(APCHY(1),U))
DENTAL(P,APCHSED) ;
NEW APCHY S %=P_"^LAST ADA [DM AUDIT DENTAL EXAM ADA CODES",E=$$START1^APCLDF(%,"APCHX(")
I E Q "Unable to determine - DM Audit Taxonomy missing"
I '$D(APCHY) Q "No <never recorded>"
I $P(APCHY(1),U)'<APCHSED S APCHX="Yes "_$$FMTE^XLFDT($P(APCHY(1),U))
Q "No "_$$FMTE^XLFDT($P(APCHY(1),U))
RECTAL(P,APCHSED) ;
I $$AGE^AUPNPAT(P)<41 Q "N/A"
NEW APCHY S %=P_"^LAST EXAM RECTAL",E=$$START1^APCLDF(%,"APCHY(")
I '$D(APCHY) Q "No <never recorded>"
I $P(APCHY(1),U)'<APCHSED S APCHX="Yes "_$$FMTE^XLFDT($P(APCHY(1),U))
Q "No "_$$FMTE^XLFDT($P(APCHY(1),U))
PAP(P,APCHSED) ;
I $$SEX^AUPNPAT(P)'="F" Q "N/A"
NEW APCHY S %=P_"^LAST LAB PAP SMEAR",E=$$START1^APCLDF(%,"APCHY(")
I '$D(APCHY) Q "No <never recorded>"
I $P(APCHY(1),U)'<APCHSED S APCHX="Yes "_$$FMTE^XLFDT($P(APCHY(1),U))
Q "No "_$$FMTE^XLFDT($P(APCHY(1),U))
BREAST(P,APCHSED) ;
I $$SEX^AUPNPAT(P)'="F" Q "N/A"
NEW APCHY S %=P_"^LAST EXAM BREAST",E=$$START1^APCLDF(%,"APCHY(")
I '$D(APCHY) Q "No <never recorded>"
I $P(APCHY(1),U)'<APCHSED S APCHX="Yes "_$$FMTE^XLFDT($P(APCHY(1),U))
Q "No "_$$FMTE^XLFDT($P(APCHY(1),U))
MAMMOG(P) ;
I $$SEX^AUPNPAT(P)'="F" Q "N/A"
;NEW APCHY S %=P_"^LAST RAD MAMMOGRAM BILAT",E=$$START1^APCLDF(%,"APCHY(")
;I '$D(APCHY) S %=P_"^LAST RAD SCREENING MAMMOGRAM",E=$$START1^APCLDF(%,"APCHY(")
;I '$D(APCHY) Q "No <never recorded>"
I '$D(^AUPNVRAD("AC",P)) Q "No <never recorded>"
S BPCRIEN="",APCHY(1)="" F S BPCRIEN=$O(^AUPNVRAD("AC",P,BPCRIEN)) Q:BPCRIEN="" D
.S BPCRP=$P(^AUPNVRAD(BPCRIEN,0),U,1)
.S BPCPROC=$P(^RAMIS(71,BPCRP,0),U,1)
.I BPCPROC["MAMMOGRAM" S APCHY(1)=$P($P(^AUPNVRAD(BPCRIEN,0),U,3),".",1)
I APCHY(1)="" Q "No <never recorded>"
Q " "_$$FMTE^XLFDT($P(APCHY(1),U))
BPCDBS1 ; IHS/OIT/MJL - DIABETIC CARE SUMMARY SUPPLEMENT ;
+1 ;;1.5;BPC;;MAY 26, 2005
+2 ;;2.0T4;IHS RPMS/PCC Health Summary;;MAR 24, 1997
+3 ;
+4 ;
EP ;EP - called from component
+1 IF '$GET(APCHSPAT)
QUIT
+2 IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
DO ^DIR
+3 IF $DATA(DIRUT)
SET APCHSQIT=1
QUIT
+4 DO EP2(APCHSPAT)
W ;write out array
+1 IF $DATA(IOF)
WRITE @IOF
+2 KILL APCHQUIT
+3 SET APCHX=0
FOR
SET APCHX=$ORDER(^TMP("APCHS",$JOB,"DCS",APCHX))
IF APCHX'=+APCHX!($DATA(APCHQUIT))
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-3)
DO HEADER
IF $DATA(APCHQUIT)
QUIT
+5 WRITE !,^TMP("APCHS",$JOB,"DCS",APCHX)
+6 QUIT
End DoDot:1
+7 IF $DATA(APCHQUIT)
SET APCHSQIT=1
+8 DO EOJ
+9 QUIT
+10 ;
EOJ ;
+1 KILL APCHX,APCHQUIT,APCHY,APCHSDFN,APCHSBEG,APCHSTOB,APCHSUPI,APCHSED,APCHTOBN,APCHTOB
+2 KILL N,%,T,F,X,Y,B,C,E,F,H,L,N,P,T,W
+3 QUIT
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCHQUIT=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 QUIT
EP2(APCHSDFN) ;EP - PASS DFN get back array of patient care summary
+1 ;at this point you are stuck with ^TMP("APCHS",$J,"DCS"
+2 KILL ^TMP("APCHS",$JOB,"DCS")
+3 SET ^TMP("APCHS",$JOB,"DCS",0)=0
+4 DO SETARRAY
+5 QUIT
SETARRAY ;set up array containing dm care summary
+1 ;CHECK TO SEE IF START1^APCLDF EXISTS
+2 SET X="APCLDF"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+3 SET X="DIABETES PATIENT CARE SUMMARY Report Date: "_$$FMTE^XLFDT(DT)
DO S(X)
+4 SET X="AGE: "_$$AGE^AUPNPAT(APCHSDFN)
SET $EXTRACT(X,15)="Sex: "_$$SEX^AUPNPAT(APCHSDFN)
SET $EXTRACT(X,31)="Date of DM Onset: "_$$DOO(APCHSDFN)
DO S(X,1,"","")
+5 DO GETHWB(APCHSDFN)
SET X="Last Height: "_APCHX("HT")
SET $EXTRACT(X,31)=APCHX("HTD")
SET $EXTRACT(X,50)="BMI: "_APCHX("BMI")
DO S(X)
+6 SET X="Last Weight: "_APCHX("WT")
SET $EXTRACT(X,31)=APCHX("WTD")
DO S(X)
+7 DO TOBACCO
+8 SET X="Tobacco Use: "_$GET(APCHTOB)
SET $EXTRACT(X,50)="HTN documented (Dx): "_$$HTN(APCHSDFN)
DO S(X,1)
+9 SET B=$$BP(APCHSDFN)
+10 SET X="Last 3 BP: "_$PIECE($GET(APCHX(1)),U,2)_" "_$$FMTE^XLFDT($PIECE($GET(APCHX(1)),U))
+11 DO S(X,1)
+12 SET X=""
IF $DATA(APCHX(2))
SET X=""
SET $EXTRACT(X,13)=$PIECE(APCHX(2),U,2)_" "_$$FMTE^XLFDT($PIECE(APCHX(2),U))
+13 DO S(X)
+14 SET X=""
IF $DATA(APCHX(3))
SET X=""
SET $EXTRACT(X,13)=$PIECE(APCHX(3),U,2)_" "_$$FMTE^XLFDT($PIECE(APCHX(3),U))
+15 DO S(X)
M12 ;
+1 ;determine date range
+2 SET APCHSBEG=$EXTRACT(DT,1,3)-1_$EXTRACT(DT,4,7)
+3 SET X="In past 12 months:"
DO S(X,1)
+4 SET X="Diabetic Foot Exam:"
SET $EXTRACT(X,27)=$$DFE(APCHSDFN,APCHSBEG)
DO S(X)
+5 SET X="Diabetic Eye Exam:"
SET $EXTRACT(X,27)=$$EYE(APCHSDFN,APCHSBEG)
DO S(X)
+6 SET X="Dental Exam:"
SET $EXTRACT(X,27)=$$DENTAL(APCHSDFN,APCHSBEG)
DO S(X)
+7 SET X="Rectal Exam (age>40):"
SET $EXTRACT(X,27)=$$RECTAL(APCHSDFN,APCHSBEG)
DO S(X)
+8 SET X=" (Females Only)"
DO S(X)
+9 SET X=" Pap Smear:"
SET $EXTRACT(X,27)=$$PAP(APCHSDFN,APCHSBEG)
DO S(X)
+10 SET X=" Breast exam:"
SET $EXTRACT(X,27)=$$BREAST(APCHSDFN,APCHSBEG)
DO S(X)
+11 SET X=" Last Mammogram:"
SET $EXTRACT(X,27)=$$MAMMOG(APCHSDFN)
DO S(X)
+12 ;D MORE^APCHS9B2
+13 SET X=$PIECE(^DPT(APCHSDFN,0),U)
SET $EXTRACT(X,35)="DOB: "_$$DOB^AUPNPAT(APCHSDFN,"S")
SET $EXTRACT(X,55)="Chart #"_$$HRN^AUPNPAT(APCHSDFN,DUZ(2),2)
DO S(X,3)
+14 SET X=""
DO S(X,1)
+15 QUIT
S(Y,F,C,T) ;set up array
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(T)
SET T=0
+3 ;blank lines
+4 FOR F=1:1:F
SET X=""
DO S1
+5 SET X=Y
+6 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+7 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+8 FOR %=1:1:T
SET X=" "_Y
+9 DO S1
+10 QUIT
S1 ;
+1 SET %=$PIECE(^TMP("APCHS",$JOB,"DCS",0),U)+1
SET $PIECE(^TMP("APCHS",$JOB,"DCS",0),U)=%
+2 SET ^TMP("APCHS",$JOB,"DCS",%)=X
+3 QUIT
HTN(P) ;
+1 NEW APCHX,X
+2 SET APCHX=""
+3 SET X=P_"^DX [SURVEILLANCE HYPERTENSION"
SET E=$$START1^APCLDF(X,"APCHX(")
IF $DATA(APCHX(1))
SET APCHX="Yes"
+4 IF $GET(APCHX)=""
SET APCHX="No"
+5 QUIT APCHX
BP(P) ;last 3 BPs
+1 KILL APCHX
+2 SET APCHX=""
+3 SET X=P_"^LAST 3 MEASUREMENTS BP"
SET E=$$START1^APCLDF(X,"APCHX(")
+4 IF '$DATA(APCHX)
SET APCHX(1)="None recorded"
+5 QUIT APCHX
DOO(P) ;get first dm dx from case management
+1 NEW APCHX,X
+2 SET APCHX=""
+3 SET X=P_"^PROBLEM [DM AUDIT PROBLEM DIABETES DX"
SET E=$$START1^APCLDF(X,"APCHX(")
IF $DATA(APCHX(1))
SET APCHX=$PIECE(^AUPNPROB(+$PIECE(APCHX(1),U,4),0),U,13)
+4 IF APCHX]""
SET APCHX=$$FMTE^XLFDT(APCHX)
+5 QUIT APCHX
GETHWB(P) ;get last height, height date, weight, weight date and BMI 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")=""
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")=$$FMTE^XLFDT($PIECE($GET(APCHY(1)),U))
+5 SET APCHX("HT")=$JUSTIFY(APCHX("HT"),2,0)
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")=$$FMTE^XLFDT($PIECE($GET(APCHY(1)),U))
BMI ;
+1 IF APCHX("WT")=""!('APCHX("HT"))
QUIT
+2 SET %=""
+3 SET W=(APCHX("WT")/5)*2.3
SET H=(APCHX("HT")*2.5)
SET H=(H*H)/10000
SET %=(W/H)
SET %=$JUSTIFY(%,4,1)
+4 SET APCHX("BMI")=%
+5 QUIT
TOBACCO ;EP
+1 KILL APCHTOB
+2 DO TOBACCO3
+3 IF $DATA(APCHTOB)
QUIT
+4 DO TOBACCO0
+5 IF $DATA(APCHTOB)
QUIT
+6 ;check Problem file for tobacco use
DO TOBACCO1
+7 IF $DATA(APCHTOB)
QUIT
+8 ;check POVs for tobacco use
DO TOBACCO2
+9 IF $DATA(APCHTOB)
QUIT
+10 SET APCHTOB="UNDOCUMENTED"
SET APCHTOB="UNDOCUMENTED"
+11 QUIT
TOBACCO0 ;check for tobacco documented in health factors
+1 KILL APCH
SET APCHX=APCHSDFN_"^LAST HEALTH [DM AUDIT TOBACCO HLTH FACTORS"
SET E=$$START1^APCLDF(APCHX,"APCH(")
IF E
QUIT
IF $DATA(APCH(1))
Begin DoDot:1
+2 IF $PIECE(APCH(1),U,3)["NON"
SET APCHTOB="NO, DOES NOT USE TOBACCO"
QUIT
+3 IF $PIECE(APCH(1),U,3)["PREVIOUS"
SET APCHTOB="PAST USE OF TOBACCO"
QUIT
+4 SET APCHTOB="YES, USES TOBACCO"
+5 QUIT
End DoDot:1
SET APCHTOBN=$ORDER(APCHTOB(""))
SET APCHTOB=APCHTOB(APCHTOBN)
+6 QUIT
TOBACCO3 ;lookup in health status
+1 SET %=$ORDER(^ATXAX("B","DM AUDIT TOBACCO HLTH FACTORS",0))
+2 IF '%
QUIT
+3 SET (X,Y)=0
FOR
SET X=$ORDER(^AUPNHF("AA",APCHSDFN,X))
IF X'=+X!(Y)
QUIT
IF $DATA(^ATXAX(%,21,"B",X))
SET Y=X
+4 IF 'Y
QUIT
+5 SET Y=$PIECE(^AUTTHF(Y,0),U)
+6 SET APCHTOB=Y
+7 IF Y["NON"
SET APCHTOB="NO, DOES NOT USE TOBACCO"
QUIT
+8 IF Y["PREVIOUS"
SET APCHTOB="PAST USE OF TOBACCO"
QUIT
+9 SET APCHTOB="YES, USES TOBACCO"
+10 QUIT
TOBACCO1 ;check problem file for tobacco use
+1 KILL APCH
SET APCHX=APCHSDFN_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS"
SET E=$$START1^APCLDF(APCHX,"APCH(")
IF E
QUIT
IF $DATA(APCH(1))
Begin DoDot:1
+2 IF $PIECE(^ICD9($PIECE(APCH(1),U,2),0),U,1)=305.13
SET APCHTOB="PAST USE OF TOBACCO"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(APCH(1),U,4),0),U,5),0),U),1,30)
QUIT
+3 SET APCHTOB="YES, USES TOBACCO - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(APCH(1),U,4),0),U,5),0),U),1,30)
+4 QUIT
End DoDot:1
SET APCHTOBN=$ORDER(APCHTOB(""))
SET APCHTOB=APCHTOB(APCHTOBN)
+5 QUIT
TOBACCO2 ;check pov file for TOBACCO USE DOC
+1 KILL APCH
SET APCHX=APCHSDFN_"^LAST DX [DM AUDIT SMOKING RELATED DXS"
SET E=$$START1^APCLDF(APCHX,"APCH(")
IF E
QUIT
IF $DATA(APCH(1))
Begin DoDot:1
+2 IF $PIECE(APCH(1),U,2)=305.13
SET APCHTOB="PAST USE OF TOBACCO"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNVPOV(+$PIECE(APCH(1),U,4),0),U,4),0),U),1,30)
QUIT
+3 SET APCHTOB="YES, USES TOBACCO"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNVPOV(+$PIECE(APCH(1),U,4),0),U,4),0),U),1,30)
+4 QUIT
End DoDot:1
SET APCHTOBN=$ORDER(APCHTOB(""))
SET APCHTOB=APCHTOB(APCHTOBN)
+5 QUIT
+6 ;
+7 ;;3.0;IHS PCC REPORTS;;FEB 05, 1997
DFE(P,APCHSED) ;
+1 NEW APCHY
SET %=P_"^LAST EXAM DIABETIC FOOT EXAM"
SET E=$$START1^APCLDF(%,"APCHY(")
+2 IF '$DATA(APCHY)
QUIT "No <never recorded>"
+3 IF $PIECE(APCHY(1),U)'<APCHSED
SET APCHX="Yes "_$$FMTE^XLFDT($PIECE(APCHY(1),U))
+4 QUIT "No "_$$FMTE^XLFDT($PIECE(APCHY(1),U))
EYE(P,APCHSED) ;
+1 NEW APCHY
SET %=P_"^LAST EXAM DIABETIC EYE EXAM"
SET E=$$START1^APCLDF(%,"APCHY(")
+2 IF '$DATA(APCHY)
QUIT "No <never recorded>"
+3 IF $PIECE(APCHY(1),U)'<APCHSED
SET APCHX="Yes "_$$FMTE^XLFDT($PIECE(APCHY(1),U))
+4 QUIT "No "_$$FMTE^XLFDT($PIECE(APCHY(1),U))
DENTAL(P,APCHSED) ;
+1 NEW APCHY
SET %=P_"^LAST ADA [DM AUDIT DENTAL EXAM ADA CODES"
SET E=$$START1^APCLDF(%,"APCHX(")
+2 IF E
QUIT "Unable to determine - DM Audit Taxonomy missing"
+3 IF '$DATA(APCHY)
QUIT "No <never recorded>"
+4 IF $PIECE(APCHY(1),U)'<APCHSED
SET APCHX="Yes "_$$FMTE^XLFDT($PIECE(APCHY(1),U))
+5 QUIT "No "_$$FMTE^XLFDT($PIECE(APCHY(1),U))
RECTAL(P,APCHSED) ;
+1 IF $$AGE^AUPNPAT(P)<41
QUIT "N/A"
+2 NEW APCHY
SET %=P_"^LAST EXAM RECTAL"
SET E=$$START1^APCLDF(%,"APCHY(")
+3 IF '$DATA(APCHY)
QUIT "No <never recorded>"
+4 IF $PIECE(APCHY(1),U)'<APCHSED
SET APCHX="Yes "_$$FMTE^XLFDT($PIECE(APCHY(1),U))
+5 QUIT "No "_$$FMTE^XLFDT($PIECE(APCHY(1),U))
PAP(P,APCHSED) ;
+1 IF $$SEX^AUPNPAT(P)'="F"
QUIT "N/A"
+2 NEW APCHY
SET %=P_"^LAST LAB PAP SMEAR"
SET E=$$START1^APCLDF(%,"APCHY(")
+3 IF '$DATA(APCHY)
QUIT "No <never recorded>"
+4 IF $PIECE(APCHY(1),U)'<APCHSED
SET APCHX="Yes "_$$FMTE^XLFDT($PIECE(APCHY(1),U))
+5 QUIT "No "_$$FMTE^XLFDT($PIECE(APCHY(1),U))
BREAST(P,APCHSED) ;
+1 IF $$SEX^AUPNPAT(P)'="F"
QUIT "N/A"
+2 NEW APCHY
SET %=P_"^LAST EXAM BREAST"
SET E=$$START1^APCLDF(%,"APCHY(")
+3 IF '$DATA(APCHY)
QUIT "No <never recorded>"
+4 IF $PIECE(APCHY(1),U)'<APCHSED
SET APCHX="Yes "_$$FMTE^XLFDT($PIECE(APCHY(1),U))
+5 QUIT "No "_$$FMTE^XLFDT($PIECE(APCHY(1),U))
MAMMOG(P) ;
+1 IF $$SEX^AUPNPAT(P)'="F"
QUIT "N/A"
+2 ;NEW APCHY S %=P_"^LAST RAD MAMMOGRAM BILAT",E=$$START1^APCLDF(%,"APCHY(")
+3 ;I '$D(APCHY) S %=P_"^LAST RAD SCREENING MAMMOGRAM",E=$$START1^APCLDF(%,"APCHY(")
+4 ;I '$D(APCHY) Q "No <never recorded>"
+5 IF '$DATA(^AUPNVRAD("AC",P))
QUIT "No <never recorded>"
+6 SET BPCRIEN=""
SET APCHY(1)=""
FOR
SET BPCRIEN=$ORDER(^AUPNVRAD("AC",P,BPCRIEN))
IF BPCRIEN=""
QUIT
Begin DoDot:1
+7 SET BPCRP=$PIECE(^AUPNVRAD(BPCRIEN,0),U,1)
+8 SET BPCPROC=$PIECE(^RAMIS(71,BPCRP,0),U,1)
+9 IF BPCPROC["MAMMOGRAM"
SET APCHY(1)=$PIECE($PIECE(^AUPNVRAD(BPCRIEN,0),U,3),".",1)
End DoDot:1
+10 IF APCHY(1)=""
QUIT "No <never recorded>"
+11 QUIT " "_$$FMTE^XLFDT($PIECE(APCHY(1),U))
