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

APCLD81P.m

Go to the documentation of this file. 
  1. APCLD81P ; IHS/CMI/LAB - 2008 DIABETES AUDIT PRINT ;
  1.  ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
  1.  ;
  1.  ;
  1.  S APCLQUIT=0,APCLPG=0,APCLIOSL=$S($G(APCLGUI):55,1:IOSL)
  1.  I APCLPREP=3 G CUML
  1.  ;print ind audits first
  1.  S APCLPD=0,APCLGUIC=0 F  S APCLPD=$O(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD)) Q:APCLPD'=+APCLPD!(APCLQUIT)  D
  1.  .I $G(APCLGUI),APCLGUIC W !,"ZZZZZZZ",!  ;maw
  1.  .S APCLGUIC=1
  1.  .W:$D(IOF) @IOF
  1.  .W $$CTR("ASSESSMENT OF DIABETES CARE, 2008         DATE AUDIT RUN: "_$$FMTE^XLFDT(DT),80)
  1.  .;W !,$$CTR("DATE AUDIT RUN: "_$$FMTE^XLFDT(DT),80)
  1.  .W !,"AUDIT DATE: ",$$FMTE^XLFDT(APCLRED),?30,"FACILITY NAME: ",$P(^DIC(4,DUZ(2),0),U)
  1.  .W !,"AREA: ",$$I(6),?12,"SU: ",$$I(8),?30,"FACILITY: ",$$I(10),?48,"# PTS ON DM REGISTER: ",$$I(12)
  1.  .I $G(APCLSDPI)]"" W !,"Does you community receive SDPI grant funds?  "_$S(APCLSDPI=1:"Yes",APCLSDPI=2:"No",APCLSDPI=3:"Don't know",1:"")
  1.  .I $G(APCLSDPI)=1 W "   ",APCLSDPG
  1.  .;W !!,"TRIBAL AFFIL: ",$P($$I(120),U,1)," ",$E($P($$I(120),U,2),1,20),"   ","COMMUNITY: ",$P($$I(121),U)," ",$E($P($$I(121),U,2),1,19)
  1.  .W !,"TRIBAL AFFIL: ",$P($$I(120),U,1)," ",$E($P($$I(120),U,2),1,20),"   ","STATE of Residence: ",$P($$I(121),U)  ;cmi/maw 12/17/2007 DM2008
  1.  .W !,"REVIEWER: ",$$I(14),?17,"CHART #: ",$$I(16),?35,"DOB: ",$$I(18),?55,"SEX: ",$$I(20)
  1.  .W !,$S($G(APCLPPN):"NAME: "_$P($G(^DPT(APCLPD,0)),U),1:"") S J=$S($G(APCLPPN):$L($P(^DPT(APCLPD,0),U))+10,1:0) W ?J,"DESIGNATED PCP:  ",$$I(15)
  1.  .W !,"DATE OF DIABETES DIAGNOSIS:"
  1.  .W ?42,"Lipid Lowering Agent:  " ;,$$I(61)
  1.  .W !?1,"CMS Register: ",$$I(22),?45,$$I(61)
  1.  .W !?1,"Problem List: ",$$I(23)
  1.  .W ?42,"IMMUNIZATIONS"
  1.  .W !?1,"1st DX recorded in PCC: ",$$I(21)
  1.  .W ?42,"Flu vaccine (past yr): ",$$I(64)
  1.  .W !,"Diabetes Type: ",$$I(29)
  1.  .W ?42,"Pneumovax Ever: ",$$I(66)
  1.  .W !?1,"CMS Register: ",$$I(24)
  1.  .W ?42,"Td in past 10 yrs: ",$$I(68)
  1.  .W !?1,"Problem List: ",$$I(25)
  1.  .W ?42,"PPD Status: ",$$I(70)
  1.  .W !?1,"PCC POV's:    ",$$I(26)
  1.  .W ?42,"If PPD Pos, INH Tx Complete: "
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !
  1.  .W ?44,$P($$I(72),U),"  ",$P($$I(72),U,2)
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,"TOBACCO USE: ",$$I(27)
  1.  .W ?42,"If PPD Neg, Last PPD: " W $$FMTE^XLFDT($$I(114))
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !?1,"Referred for (or provided) Cessation"
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !?1,"Counseling: ",$$I(28)
  1.  .W ?42,"Date of Last EKG: ",$$I(76)
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,"VITAL STATISTICS"
  1.  .W ?42,"LABORATORY DATA"
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,"Height: ",$$I(30)
  1.  .W ?42,"HbA1c (most recent): ",$P($$I(78),U,1)
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .S %=$P($$I(32)," ",1),%=$$STRIP^XLFSTR($J(%,6,2)," ")
  1.  .W !,"Last Weight (in 2 yrs): ",%," ",$P($$I(32)," ",2,99)
  1.  .W ?45,"Date Obtained: ",$P($$I(78),U,2)
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,"  BMI: ",$$I(112)
  1.  .;W ?42,"HbA1c (next most recent): ",$P($$I(78),U,4)  ;cmi/maw 12/18/2007 DM2008
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,"HTN (documented DX): ",$$I(34)
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,"Last 3 Blood Pressures (in past yr):"
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !?2,$P($$I(36),";")
  1.  .W ?42,"MOST RECENT SERUM VALUE (in the"
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !?2,$P($$I(36),";",2)
  1.  .W ?42,"past 12 months):"
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !?2,$P($$I(36),";",3)
  1.  .W ?43,"Creatinine: ",$$I(84)
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,?43,"  Estimated GFR: "_$$I(79)  ;documented in the"  ;cmi/maw 12/18/2007 DM2008
  1.  .;W !,?43,"medical record during the audit"  ;cmi/maw 12/18/2007 DM2008
  1.  .;W !,?43,"period: "_$$I(79)  ;cmi/maw 12/18/2007 DM2008
  1.  .W !,?43,"Tot Cholesterol: ",$$I(86)
  1.  .W !,"EXAMINATIONS (in past year)"
  1.  .W ?43,"HDL Cholesterol: ",$$I(89)
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,"Foot exam-complete: "
  1.  .W ?43,"LDL Cholesterol: ",$$I(88)
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !?2,$$I(38)
  1.  .W ?43,"Triglycerides: ",$$I(90)
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,"Eye exam (dilated/fundus): "
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !?2,$$I(40)
  1.  .;W ?43,"Urinalysis or A/C Ratio: "  ;cmi/maw 12/18/2007 DM2008
  1.  .W ?43,"Albumin:Creatinine Ratio (UACR): "_$P($$I(91),U)  ;cmi/maw 12/18/2007 DM2008
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,"Dental exam: "
  1.  .;W ?44,$$I(92)  ;cmi/maw 12/18/2007 DM2008
  1.  .W ?43,"Protein:Creatinine Ratio (UPCR): "_$S($P($$I(91),U)="":$P($$I(93),U),1:"")  ;cmi/maw 12/18/2007 DM2008
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !?2,$$I(42)
  1.  .;W ?43,"Proteinuria: "  ;cmi/maw 12/18/2007 DM2008
  1.  .W ?43,"Other quantitative urine"  ;cmi/maw 12/18/2007 DM2008
  1.  .W !,?43,"protein test: "_$$QUANCHK   ;cmi/maw 12/18/2007 DM2008
  1.  .W !,?43,"None: "_$$ACPCOQ  ;cmi/maw 12/18/2007 DM2008
  1.  .W !,?50,$$ACPCRES
  1.  .;I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .;W !
  1.  .;W ?44,$$I(94)  ;cmi/maw 12/18/2007 DM2008
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,"EDUCATION (in past year)"
  1.  .;W ?43,"Microalbuminuria: "  ;cmi/maw 12/18/2007 DM2008
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,"Diet Instruction: ",$$I(44)
  1.  .;W ?44,$$I(96)  ;cmi/maw 12/18/2007 DM2008
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,"Exercise Instruction: ",$$I(46)
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,"DM Education (Other): ",$$I(48)
  1.  .;W ?42,"Self monitoring of blood glucose"
  1.  .;I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .;W !
  1.  .;W ?43,"documented in chart:  ",$$I(98)
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,"DM THERAPY"
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,"Select all that currently apply"
  1.  .W ?42,"Supplemental Section"
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !?1,$$I(51),?4,"1 Diet & Exercise Alone"
  1.  .W ?42,"Does pt have depression as an active"
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !?1,$$I(52),?4,"2 Insulin"
  1.  .W ?43,"problem?  ",$$I(200)
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !?1,$$I(53),?4,"3 Sulfonylurea "
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !?1,$$I(54),?4,"4 Metformin "
  1.  .W ?42,"If 'No', has pt been screened for"
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !?1,$$I(55),?4,"5 Acarbose "
  1.  .W ?43,"depression in the past year?"
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !?1,$$I(56),?4,"6 Glitazones"
  1.  .W !?1,$$I(58),?4,"7 Incretin Mimetics"  ;cmi/maw 12/18/2007 DM2008
  1.  .W !?1,$$I(59),?4,"8 DPP4 inhibitors"  ;cmi/maw 12/18/2007 DM2008
  1.  .W ?44,$$I(210)
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !?1,$P($$I(57),U),?4,"9 Unknown/Refused" I $$I(57)]"" W "  ",$P($$I(57),U,2)
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,"ACE Inhibitor/ARB Use: ",$$I(60)
  1.  .W ?43,"Local Option question:"
  1.  .I $Y>(APCLIOSL-1) D PAGE Q:APCLQUIT
  1.  .W !,"Aspirin/AntiPlatelet Therapy: ",$$I(62)
  1.  .I $E(IOST,1,2)'="P-" W !! S DIR(0)="E" D ^DIR K DIR ;CMI/GRL 1/18/07
  1.  .;D PAGE Q:APCLQUIT
  1. CUML ;
  1.  I APCLPREP=4!(APCLPREP=3) D CUML^APCLD814
  1. DONE ;
  1.  K ^TMP($J)
  1.  K ^XTMP("APCLDM81",APCLJOB,APCLBTH),APCLJOB,APCLBTH
  1.  Q
  1. I(I) ;
  1.  Q ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,I)
  1.  ;
  1. PAGE ;
  1.  I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLQUIT=1 Q
  1.  W:$D(IOF) @IOF
  1.  Q
  1.  ;
  1. ACPCOQ() ;-- return none if no UACR, UPCR, Quant
  1.  I $P($$I(91),U)="X" Q ""
  1.  I $P($$I(93),U)="X" Q ""
  1.  I $P($$I(95),U)="X" Q ""
  1.  Q "X"
  1.  ;
  1. ACPCRES() ;-- return result from UACR UPCR
  1.  I $P($$I(91),U)="X" Q $P($$I(91),U,2)
  1.  I $P($$I(93),U)="X" Q $P($$I(93),U,2)
  1.  Q ""
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. QUANCHK() ;--check quantitative
  1.  I $P($$I(91),U)]"" Q ""
  1.  I $P($$I(93),U)]"" Q ""
  1.  Q $$I(95)
  1.  ;