Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BPCDBS1

BPCDBS1.m

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