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

APCLD810.m

Go to the documentation of this file. 
  1. APCLD810 ; IHS/CMI/LAB -IHS -GETS DATA FOR DIABETES QA REPORT ;
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;
  1.  ;
  1. EN ; - ENTRY POINT - from ^APCLASK
  1.  K ^APCLDATA("APCLEPI",$J)
  1.  S ^XTMP("APCLDM81",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^DM AUDIT 2008"
  1.  S APCLEPIN=0
  1.  S APCLPD=0 F  S APCLPD=$O(^XTMP("APCLDM81",APCLJOB,APCLBTH,"PATS",APCLPD)) Q:'APCLPD  D
  1.  .I APCLTYPE'="P",APCLTYPE'="S" Q:$$DEMO^APCLUTL(APCLPD,$G(APCLDEMO))
  1.  .I APCLPREP=2 D EPIREC Q
  1.  .D GATHER
  1.  I APCLPREP=2 D WRITEF^APCLD81 Q
  1.  I APCLPREP=3!(APCLPREP=4) D CUML^APCLD815
  1.  Q
  1. S(P,I,V) ;
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",P,I)=V
  1.  Q
  1. REC(DFN,APCLRTYP,APCLRBD,APCLRED,APCLED,APCLDMRG,APCLBDAT) ;EP - called to send back a visit record as
  1.  NEW APCLX,APCLREC
  1.  S APCLREC=""
  1.  S APCLRTYP("IEN")=$O(^APCLRECD("B",APCLRTYP,0))
  1.  I 'APCLRTYP("IEN") Q APCLREC
  1. PROC ;
  1.  S APCLEPIX=0
  1.  F  S APCLEPIX=$O(^APCLRECD(APCLRTYP("IEN"),11,"AC",APCLEPIX)) Q:APCLEPIX'=+APCLEPIX!(APCLREC=-1)  S APCLTTT=$O(^APCLRECD(APCLRTYP("IEN"),11,"AC",APCLEPIX,0))  D
  1.  .S X="" X:$D(^APCLRECD(APCLRTYP("IEN"),11,APCLTTT,11)) ^APCLRECD(APCLRTYP("IEN"),11,APCLTTT,11)
  1.  .S $E(APCLREC,$P(^APCLRECD(APCLRTYP("IEN"),11,APCLTTT,0),U,2))=X   ;W !,APCLTTT,?5,$P(^APCLRECD(APCLRTYP("IEN"),11,APCLTTT,0),U),?40,X
  1.  Q APCLREC
  1. EPIREC ;create epi info record in ^APCLDATA("APCLEPI",$J,n)
  1.  S APCLEPIR="",APCLEPIR=$$REC(APCLPD,"DM AUDIT 2008 EPI REC 1",APCLRBD,APCLRED,APCLADAT,APCLDMRG,APCLBDAT),APCLEPIN=APCLEPIN+1,^APCLDATA("APCLEPI",$J,APCLEPIN)=APCLEPIR
  1.  S APCLTHER="",APCLEPIR="",APCLEPIR=$$REC(APCLPD,"DM AUDIT 2008 EPI REC 2",APCLRBD,APCLRED,APCLADAT,APCLDMRG,APCLBDAT),APCLEPIN=APCLEPIN+1,^APCLDATA("APCLEPI",$J,APCLEPIN)=APCLEPIR
  1.  S APCLEPIR="",APCLEPIR=$$REC(APCLPD,"DM AUDIT 2008 EPI REC 3",APCLRBD,APCLRED,APCLADAT,APCLDMRG,APCLBDAT),APCLEPIN=APCLEPIN+1,^APCLDATA("APCLEPI",$J,APCLEPIN)=APCLEPIR
  1.  ;S APCLEPIR="",APCLEPIR=$$REC(APCLPD,"DM AUDIT 2008 EPI REC 4",APCLRBD,APCLRED,APCLADAT,APCLDMRG,APCLBDAT),APCLEPIN=APCLEPIN+1,^APCLDATA("APCLEPI",$J,APCLEPIN)=APCLEPIR
  1.  Q
  1. GATHER ;gather data for 1 patient
  1.  S APCLER=0
  1.  ;set report dates
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,1)=$S($G(APCLFISC)]"":APCLFISC,1:APCLRBD_" - "_APCLRED)
  1.  ;set audit date to DT
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,2)=$$FMTE^XLFDT(DT)
  1.  ;set area, su, facility code and name
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,4)=$P(^DIC(4,DUZ(2),0),U)
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,6)=$E($P(^AUTTLOC(DUZ(2),0),U,10),1,2)
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,8)=$E($P(^AUTTLOC(DUZ(2),0),U,10),3,4)
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,10)=$E($P(^AUTTLOC(DUZ(2),0),U,10),5,6)
  1.  ;# pats in register
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,12)=$S(APCLDMRG:$$RSTAT^APCLDM6(APCLDMRG,"A"),1:"")
  1.  ;reviewer
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,14)=$P(^VA(200,DUZ,0),U,2)
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,15)=$$VAL^XBDIQ1(9000001,APCLPD,.14)
  1. DEMO ;pat demographics
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,16)=$$HRN^AUPNPAT(APCLPD,DUZ(2))
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,18)=$$DOB^AUPNPAT(APCLPD,"E")
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,20)=$$VAL^XBDIQ1(2,APCLPD,.02)
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,120)=$$TRIBE(APCLPD)
  1.  ;S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,121)=$$COMM(APCLPD)  ;cmi/maw 12/17/2007 not around anymore DM2008
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,121)=$S($P($G(^DPT(APCLPD,.11)),U,5):$P($G(^DIC(5,$P(^DPT(APCLPD,.11),U,5),0)),U,2),1:"")  ;cmi/maw 12/17/2007 state of residence DM2008
  1. DXDT ;dates of and dm dxs
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,22)=$S(APCLDMRG:$$CMSFDX^APCLD813(APCLPD,APCLDMRG,"D"),1:"")
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)=$S(APCLDMRG:$$CMSFDX^APCLD813(APCLPD,APCLDMRG,"DX"),1:"")
  1.  S ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,23)=$$PLDMDOO^APCLD813(APCLPD)
  1.  D S(APCLPD,25,$$PLDMDXS^APCLD813(APCLPD))
  1.  D S(APCLPD,21,$$FRSTDMDX^APCLD813(APCLPD))
  1.  D S(APCLPD,26,$$LASTDMDX^APCLD813(APCLPD,APCLRED))
  1.  D S(APCLPD,27,$$TOBACCO^APCLD816(APCLPD,APCLRED))
  1.  S APCLTYDM="" D TYPEDM,S(APCLPD,29,APCLTYDM)
  1.  D S(APCLPD,28,$$CESS^APCLD811(APCLPD,APCLRBD,APCLRED))
  1.  ;
  1. VITAL ;
  1.  D S(APCLPD,30,$$LASTHT^APCLD813(APCLPD,APCLRED))
  1.  D S(APCLPD,32,$$LASTWT^APCLD813(APCLPD,APCLRED))
  1.  ;htn dx
  1.  D S(APCLPD,34,$$HTNDX^APCLD813(APCLPD,APCLRED))
  1.  ;last 3 BPs
  1.  D S(APCLPD,36,$$BPS^APCLD813(APCLPD,APCLRBD,APCLRED))
  1. EXAMS ;
  1.  D S(APCLPD,38,$$DFE^APCLD817(APCLPD,APCLRBD,APCLRED))
  1.  D S(APCLPD,40,$$EYE^APCLD817(APCLPD,APCLRBD,APCLRED))
  1.  D S(APCLPD,42,$$DENTAL^APCLD817(APCLPD,APCLRBD,APCLRED))
  1.  D S(APCLPD,44,$$DIETEDUC^APCLD817(APCLPD,APCLRBD,APCLRED))
  1.  D S(APCLPD,46,$$EXEDUC^APCLD817(APCLPD,APCLRBD,APCLRED))
  1.  D S(APCLPD,48,$$OTHEDUC^APCLD817(APCLPD,APCLRBD,APCLRED))
  1. THERAPY ;
  1.  S APCL6MBD=$$FMADD^XLFDT(APCLADAT,-(6*31)),APCL6MBD=$$FMTE^XLFDT(APCL6MBD)
  1.  D S(APCLPD,52,$$INSULIN^APCLD812(APCLPD,APCL6MBD,APCLRED))
  1.  D S(APCLPD,53,$$SULF^APCLD812(APCLPD,APCL6MBD,APCLRED))
  1.  D S(APCLPD,54,$$MET^APCLD812(APCLPD,APCL6MBD,APCLRED))
  1.  D S(APCLPD,55,$$ACAR^APCLD812(APCLPD,APCL6MBD,APCLRED))
  1.  D S(APCLPD,56,$$TROG^APCLD812(APCLPD,APCL6MBD,APCLRED))
  1.  D S(APCLPD,58,$$INCR^APCLD812(APCLPD,APCL6MBD,APCLRED))  ;cmi/maw 12/18/2007 DM2008
  1.  D S(APCLPD,59,$$DPP4^APCLD812(APCLPD,APCL6MBD,APCLRED))  ;cmi/maw 12/18/2008 DM2008
  1.  S Y=$$REFMED^APCLD812(APCLPD,APCLRBD,APCLRED) S Y=$S(Y="":"",1:"X"_U_$P(Y,U,2)) D S(APCLPD,57,Y)
  1.  S Y=0 F X=52:1:59 I $E(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,X))="X" S Y=1  ;cmi/maw 6/17/2008 per gary
  1.  D S(APCLPD,51,$S(Y:"",1:"X"))
  1.  D S(APCLPD,60,$$ACE^APCLD816(APCLPD,APCL6MBD,APCLRED))
  1. IMM ;
  1.  D S(APCLPD,62,$$ASPIRIN^APCLD816(APCLPD,APCLRBD,APCLRED))
  1.  D S(APCLPD,61,$$LIPID^APCLD816(APCLPD,APCLRBD,APCLRED))
  1.  D S(APCLPD,64,$$FLU^APCLD813(APCLPD,APCLRBD,APCLRED))
  1.  D S(APCLPD,66,$$PNEU^APCLD813(APCLPD,APCLRED))
  1.  D S(APCLPD,68,$$TD^APCLD81B(APCLPD,APCLRED))
  1. PPD ;
  1.  D S(APCLPD,70,$$PPD^APCLD818(APCLPD,APCLRED))
  1.  D S(APCLPD,114,$$LASTNP^APCLD818(APCLPD,APCLRED))
  1.  D S(APCLPD,72,$$TBTX^APCLD812(APCLPD))
  1.  D S(APCLPD,76,$$EKG^APCLD812(APCLPD,APCLRED))
  1. LABS ;
  1.  D S(APCLPD,78,$$HGBA1C^APCLD818(APCLPD,APCLBDAT,APCLADAT))
  1.  ;D S(APCLPD,82,$$BS^APCLD818(APCLPD,APCLRBD,APCLRED))
  1.  D S(APCLPD,79,$$GFR^APCLD81C(APCLPD,APCLBDAT,APCLADAT))  ;cmi/maw 12/17/2007 DM2008
  1.  D S(APCLPD,84,$$CREAT^APCLD818(APCLPD,APCLBDAT,APCLADAT))
  1.  D S(APCLPD,86,$$CHOL^APCLD818(APCLPD,APCLBDAT,APCLADAT))
  1.  D S(APCLPD,88,$$LDL^APCLD818(APCLPD,APCLBDAT,APCLADAT))
  1.  D S(APCLPD,89,$$HDL^APCLD818(APCLPD,APCLBDAT,APCLADAT))
  1.  D S(APCLPD,90,$$TRIG^APCLD818(APCLPD,APCLBDAT,APCLADAT))
  1.  D S(APCLPD,91,$$UACR^APCLD81C(APCLPD,APCLBDAT,APCLADAT))  ;cmi/maw 12/17/2007 DM2008
  1.  D S(APCLPD,93,$$UPCR^APCLD81C(APCLPD,APCLBDAT,APCLADAT))  ;cmi/maw 12/17/2007 DM2008
  1.  D S(APCLPD,95,$$QUAN^APCLD81C(APCLPD,APCLBDAT,APCLADAT))  ;cmi/maw 12/17/2007 DM2008
  1.  ;D S(APCLPD,92,$$URIN^APCLD818(APCLPD,APCLBDAT,APCLADAT))  ;cmi/maw 12/17/2007 DM2008
  1.  D S(APCLPD,94,$$PROTEIN^APCLD818(APCLPD,APCLBDAT,APCLADAT))  ;cmi/maw 12/17/2007 DM2008
  1.  D S(APCLPD,96,$$MICRO^APCLD818(APCLPD,APCLBDAT,APCLADAT))  ;cmi/maw 12/17/2007 DM2008
  1.  ;D S(APCLPD,98,$$SELF^APCLD816(APCLPD,APCLRBD,APCLRED))
  1.  D S(APCLPD,112,$$BMI^APCLD818(APCLPD,APCLRBD,APCLRED))
  1.  D S(APCLPD,200,$$DEPDX^APCLD812(APCLPD,APCLBDAT,APCLADAT))
  1.  S APCLDEP=$E($G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,200)))
  1.  D S(APCLPD,210,$S(APCLDEP="Y":"",1:$$DEPSCR^APCLD812(APCLPD,APCLBDAT,APCLADAT)))
  1.  ;
  1.  Q
  1. TYPEDM ;return type of DM in APCLTYDM
  1.  NEW X
  1.  I ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)="NIDDM" S APCLTYDM="2  Type 2" Q
  1.  I ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)="TYPE II" S APCLTYDM="2  Type 2" Q
  1.  I ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)[2 S APCLTYDM="2  Type 2" Q
  1.  I ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)="IDDM" S APCLTYDM="1  Type 1" Q
  1.  I ^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)[1 S APCLTYDM="1  Type 1" Q
  1.  S X=^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,25) ;get problem list dxs
  1.  F I=1:1 S C=$P(X,";",I) Q:C=""!(APCLTYDM]"")  I $E(C,6)=0!($E(C,6)=2) S APCLTYDM="2  Type 2"
  1.  Q:APCLTYDM]""
  1.  F I=1:1 S C=$P(X,";",I) Q:C=""!(APCLTYDM]"")  I $E(C,6)=1!($E(C,6)=3) S APCLTYDM="1  Type 1"
  1.  Q:APCLTYDM]""
  1.  S X=^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,26) ;get pov list dxs
  1.  I X[2 S APCLTYDM="2  Type 2" Q
  1.  I X[1 S APCLTYDM="1  Type 1" Q
  1.  Q
  1. DATE(D) ;EP
  1.  I $G(D)="" Q ""
  1.  Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+($E(D,1,3)))
  1. TRIBE(P) ;EP
  1.  I '$G(P) Q ""
  1.  I '$D(^AUPNPAT(P,11)) Q ""
  1.  Q $$TRIBE^AUPNPAT(P,"C")_"^"_$$TRIBE^AUPNPAT(P,"E")
  1. COMM(P) ;EP
  1.  I '$G(P) Q ""
  1.  I '$D(^AUPNPAT(P,11)) Q ""
  1.  Q $$COMMRES^AUPNPAT(P,"C")_"^"_$$COMMRES^AUPNPAT(P,"E")
  1. EAUDIT ;EP
  1.  K ^APCLDATA("APCLEPI",$J)
  1.  S ^XTMP("APCLDM81",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^DM AUDIT 2008"
  1.  S APCLEPIN=0
  1.  S APCLBEGD=$$FMADD^XLFDT(APCLADAT,-365)
  1.  S APCL3YE=$$FMADD^XLFDT(APCLADAT,-1096)
  1.  I APCLACTI=1 D
  1.  .S APCLEAUT=0 F  S APCLEAUT=$O(^ACM(41,"B",APCLDMRG,APCLEAUT)) Q:APCLEAUT'=+APCLEAUT  D
  1.  ..I $P($G(^ACM(41,APCLEAUT,"DT")),U,1)'="A" Q
  1.  ..S APCLPD=$P(^ACM(41,APCLEAUT,0),U,2)
  1.  ..Q:$$DEMO^APCLUTL(APCLPD,$G(APCLDEMO))
  1.  ..S APCLX=$$ACTDMPT^APCLD81G(APCLPD,APCLBEGD,APCLADAT,APCLTAXI,APCLBEN,APCL3YE)
  1.  ..I 'APCLX Q  ;not active diabetic
  1.  ..I APCLPREP=2 D EPIREC Q
  1.  ..D GATHER
  1.  .Q
  1.  I APCLACTI=0 S APCLPD=0 F  S APCLPD=$O(^AUPNPAT(APCLPD)) Q:'APCLPD  D
  1.  .S APCLX=$$ACTDMPT^APCLD81G(APCLPD,APCLBEGD,APCLADAT,APCLTAXI,APCLBEN,APCL3YE)
  1.  .I 'APCLX Q  ;not active diabetic
  1.  .I APCLACTI,'$$ACTONREG(APCLPD,APCLDMRG) Q
  1.  .I APCLPREP=2 D EPIREC Q
  1.  .D GATHER
  1.  I APCLPREP=2 D WRITEF^APCLD81 Q
  1.  I APCLPREP=3!(APCLPREP=4) D CUML^APCLD815
  1.  Q
  1. ACTONREG(P,R) ;
  1.  I '$D(^ACM(41,"AC",P,R)) Q 0
  1.  S X=^ACM(41,"AC",P,R)
  1.  I $P($G(^ACM(41,X,"DT")),U,1)'="A" Q 0
  1.  Q 1
  1.  ;
  1. URINPROT() ;
  1.  I $$UACR^APCLD81C(APCLPD,APCLBDAT,APCLADAT)]"" Q 1  ;cmi/maw 12/17/2007 DM2008
  1.  I $$UPCR^APCLD81C(APCLPD,APCLBDAT,APCLADAT)]"" Q 2  ;cmi/maw 12/17/2007 DM2008
  1.  I $$QUAN^APCLD81C(APCLPD,APCLBDAT,APCLADAT)]"" Q 3  ;cmi/maw 12/17/2007 DM2008
  1.  Q 4
  1.  ;