BDMD310 ; IHS/CMI/LAB -IHS -GETS DATA FOR DIABETES QA REPORT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
;
;
EN ; - ENTRY POINT - from ^BDMASK
K ^BDMDATA("BDMEPI",$J)
S ^XTMP("BDMDM31",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^DM AUDIT 2003"
S BDMEPIN=0
S BDMPD=0 F S BDMPD=$O(^XTMP("BDMDM31",BDMJOB,BDMBTH,"PATS",BDMPD)) Q:'BDMPD D
.I BDMTYPE'="P",BDMTYPE'="S" Q:$$DEMO^BDMUTL(BDMPD,$G(BDMDEMO))
.I BDMPREP=2 D EPIREC Q
.D GATHER
I BDMPREP=2 D WRITEF^BDMD31 Q
I BDMPREP=3!(BDMPREP=4) D CUML^BDMD315
Q
S(P,I,V) ;
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",P,I)=V
Q
REC(DFN,BDMRTYP,BDMRBD,BDMRED,BDMED,BDMDMRG) ;EP - called to send back a visit record as
NEW BDMX,BDMREC
S BDMREC=""
S BDMRTYP("IEN")=$O(^BDMRECD("B",BDMRTYP,0))
I 'BDMRTYP("IEN") Q BDMREC
PROC ;
S BDMX=0
F S BDMX=$O(^BDMRECD(BDMRTYP("IEN"),11,"AC",BDMX)) Q:BDMX'=+BDMX!(BDMREC=-1) S BDMTTT=$O(^BDMRECD(BDMRTYP("IEN"),11,"AC",BDMX,0)) D
.S X="" X:$D(^BDMRECD(BDMRTYP("IEN"),11,BDMTTT,11)) ^BDMRECD(BDMRTYP("IEN"),11,BDMTTT,11)
.S $E(BDMREC,$P(^BDMRECD(BDMRTYP("IEN"),11,BDMTTT,0),U,2))=X ;W !,BDMTTT,?5,$P(^BDMRECD(BDMRTYP("IEN"),11,BDMTTT,0),U),?40,X H 1
Q BDMREC
EPIREC ;create epi info record in ^BDMDATA("BDMEPI",$J,n)
S BDMEPIR="",BDMEPIR=$$REC(BDMPD,"DM AUDIT 2003 EPI REC 1",BDMRBD,BDMRED,BDMADAT,BDMDMRG),BDMEPIN=BDMEPIN+1,^BDMDATA("BDMEPI",$J,BDMEPIN)=BDMEPIR
S BDMEPIR="",BDMEPIR=$$REC(BDMPD,"DM AUDIT 2003 EPI REC 2",BDMRBD,BDMRED,BDMADAT,BDMDMRG),BDMEPIN=BDMEPIN+1,^BDMDATA("BDMEPI",$J,BDMEPIN)=BDMEPIR
S BDMEPIR="",BDMEPIR=$$REC(BDMPD,"DM AUDIT 2003 EPI REC 3",BDMRBD,BDMRED,BDMADAT,BDMDMRG),BDMEPIN=BDMEPIN+1,^BDMDATA("BDMEPI",$J,BDMEPIN)=BDMEPIR
S BDMEPIR="",BDMEPIR=$$REC(BDMPD,"DM AUDIT 2003 EPI REC 4",BDMRBD,BDMRED,BDMADAT,BDMDMRG),BDMEPIN=BDMEPIN+1,^BDMDATA("BDMEPI",$J,BDMEPIN)=BDMEPIR
Q
GATHER ;gather data for 1 patient
S BDMER=0
;set report dates
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,1)=$S($G(BDMFISC)]"":BDMFISC,1:BDMRBD_" - "_BDMRED)
;set audit date to DT
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,2)=$$FMTE^XLFDT(DT)
;set area, su, facility code and name
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,4)=$P(^DIC(4,DUZ(2),0),U)
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,6)=$E($P(^AUTTLOC(DUZ(2),0),U,10),1,2)
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,8)=$E($P(^AUTTLOC(DUZ(2),0),U,10),3,4)
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,10)=$E($P(^AUTTLOC(DUZ(2),0),U,10),5,6)
;# pats in register
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,12)=$S(BDMDMRG:$$RSTAT^BDMDM6(BDMDMRG,"A"),1:"")
;reviewer
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,14)=$P(^VA(200,DUZ,0),U,2)
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,15)=$$VAL^XBDIQ1(9000001,BDMPD,.14)
DEMO ;pat demographics
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,16)=$$HRN^AUPNPAT(BDMPD,DUZ(2))
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,18)=$$DOB^AUPNPAT(BDMPD,"E")
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,20)=$$VAL^XBDIQ1(2,BDMPD,.02)
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,120)=$$TRIBE(BDMPD)
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,121)=$$COMM(BDMPD)
DXDT ;dates of and dm dxs
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,22)=$S(BDMDMRG:$$CMSFDX^BDMD313(BDMPD,BDMDMRG,"D"),1:"")
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,24)=$S(BDMDMRG:$$CMSFDX^BDMD313(BDMPD,BDMDMRG,"DX"),1:"")
S ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,23)=$$PLDMDOO^BDMD313(BDMPD)
D S(BDMPD,25,$$PLDMDXS^BDMD313(BDMPD))
D S(BDMPD,21,$$FRSTDMDX^BDMD313(BDMPD))
D S(BDMPD,26,$$LASTDMDX^BDMD313(BDMPD,BDMRED))
D S(BDMPD,27,$$TOBACCO^BDMD316(BDMPD,BDMRED))
S BDMTYDM="" D TYPEDM,S(BDMPD,29,BDMTYDM)
D S(BDMPD,28,$$CESS^BDMD311(BDMPD,BDMRBD,BDMRED))
VITAL ;
D S(BDMPD,30,$$LASTHT^BDMD313(BDMPD,BDMRED))
D S(BDMPD,32,$$LASTWT^BDMD313(BDMPD,BDMRED))
;htn dx
D S(BDMPD,34,$$HTNDX^BDMD313(BDMPD,BDMRED))
;last 3 BPs
D S(BDMPD,36,$$BPS^BDMD313(BDMPD,BDMRBD,BDMRED))
EXAMS ;
D S(BDMPD,38,$$DFE^BDMD317(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,40,$$EYE^BDMD317(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,42,$$DENTAL^BDMD317(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,44,$$DIETEDUC^BDMD317(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,46,$$EXEDUC^BDMD317(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,48,$$OTHEDUC^BDMD317(BDMPD,BDMRBD,BDMRED))
THERAPY ;
S BDM6MBD=$$FMADD^XLFDT(BDMADAT,-(6*31)),BDM6MBD=$$FMTE^XLFDT(BDM6MBD)
D S(BDMPD,52,$$INSULIN^BDMD312(BDMPD,BDM6MBD,BDMRED))
D S(BDMPD,53,$$SULF^BDMD312(BDMPD,BDM6MBD,BDMRED))
D S(BDMPD,54,$$MET^BDMD312(BDMPD,BDM6MBD,BDMRED))
D S(BDMPD,55,$$ACAR^BDMD312(BDMPD,BDM6MBD,BDMRED))
D S(BDMPD,56,$$TROG^BDMD312(BDMPD,BDM6MBD,BDMRED))
S Y=0 F X=52:1:56 I ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,X)="X" S Y=1
D S(BDMPD,51,$S(Y:"",1:"X"))
D S(BDMPD,60,$$ACE^BDMD316(BDMPD,BDM6MBD,BDMRED))
IMM ;
D S(BDMPD,62,$$ASPIRIN^BDMD316(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,61,$$LIPID^BDMD316(BDMPD,BDM6MBD,BDMRED))
D S(BDMPD,64,$$FLU^BDMD313(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,66,$$PNEU^BDMD313(BDMPD,BDMRED))
D S(BDMPD,68,$$TD^BDMD31B(BDMPD,BDMRED))
PPD ;
D S(BDMPD,70,$$PPD^BDMD318(BDMPD,BDMRED))
D S(BDMPD,114,$$LASTNP^BDMD318(BDMPD,BDMRED))
D S(BDMPD,72,$$TBTX^BDMD312(BDMPD))
D S(BDMPD,76,$$EKG^BDMD312(BDMPD,BDMRED))
LABS ;
D S(BDMPD,78,$$HGBA1C^BDMD318(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,82,$$BS^BDMD318(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,84,$$CREAT^BDMD318(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,86,$$CHOL^BDMD318(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,88,$$LDL^BDMD318(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,89,$$HDL^BDMD318(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,90,$$TRIG^BDMD318(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,92,$$URIN^BDMD318(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,94,$$PROTEIN^BDMD318(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,96,$$MICRO^BDMD318(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,98,$$SELF^BDMD316(BDMPD,BDMRBD,BDMRED))
;D S(BDMPD,100,$$SDM^BDMD316(BDMPD,BDMRBD,BDMRED))
;D S(BDMPD,102,$$PERI^BDMD316(BDMPD,BDMRBD,BDMRED))
;D S(BDMPD,104,$$AST^BDMD312(BDMPD,BDMRBD,BDMRED))
;D S(BDMPD,106,$$ALT^BDMD312(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,108,$$PAP^BDMD312(BDMPD,BDMRBD,BDMRED))
;D S(BDMPD,110,$$MAMMOG^BDMD312(BDMPD,BDMRBD,BDMRED))
D S(BDMPD,112,$$BMI^BDMD318(BDMPD,BDMRBD,BDMRED))
;
Q
TYPEDM ;return type of DM in BDMTYDM
I ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,24)="NIDDM" S BDMTYDM="2 Type 2" Q
I ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,24)="TYPE II" S BDMTYDM="2 Type 2" Q
I ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,24)[2 S BDMTYDM="2 Type 2" Q
I ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,24)="IDDM" S BDMTYDM="1 Type 1" Q
I ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,24)[1 S BDMTYDM="1 Type 1" Q
S X=^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,25) ;get problem list dxs
F I=1:1 S C=$P(X,";",I) Q:C=""!(BDMTYDM]"") I $E(C,6)=0!($E(C,6)=2) S BDMTYDM="2 Type 2"
Q:BDMTYDM]""
F I=1:1 S C=$P(X,";",I) Q:C=""!(BDMTYDM]"") I $E(C,6)=1!($E(C,6)=3) S BDMTYDM="1 Type 1"
Q:BDMTYDM]""
S X=^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,26) ;get pov list dxs
I X[2 S BDMTYDM="2 Type 2" Q
I X[1 S BDMTYDM="1 Type 1" Q
Q
DATE(D) ;EP
I $G(D)="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+($E(D,1,3)))
TRIBE(P) ;EP
I '$G(P) Q ""
I '$D(^AUPNPAT(P,11)) Q ""
Q $$TRIBE^AUPNPAT(P,"C")_"^"_$$TRIBE^AUPNPAT(P,"E")
COMM(P) ;EP
I '$G(P) Q ""
I '$D(^AUPNPAT(P,11)) Q ""
Q $$COMMRES^AUPNPAT(P,"C")_"^"_$$COMMRES^AUPNPAT(P,"E")
BDMD310 ; IHS/CMI/LAB -IHS -GETS DATA FOR DIABETES QA REPORT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
+2 ;
+3 ;
EN ; - ENTRY POINT - from ^BDMASK
+1 KILL ^BDMDATA("BDMEPI",$JOB)
+2 SET ^XTMP("BDMDM31",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^DM AUDIT 2003"
+3 SET BDMEPIN=0
+4 SET BDMPD=0
FOR
SET BDMPD=$ORDER(^XTMP("BDMDM31",BDMJOB,BDMBTH,"PATS",BDMPD))
IF 'BDMPD
QUIT
Begin DoDot:1
+5 IF BDMTYPE'="P"
IF BDMTYPE'="S"
IF $$DEMO^BDMUTL(BDMPD,$GET(BDMDEMO))
QUIT
+6 IF BDMPREP=2
DO EPIREC
QUIT
+7 DO GATHER
End DoDot:1
+8 IF BDMPREP=2
DO WRITEF^BDMD31
QUIT
+9 IF BDMPREP=3!(BDMPREP=4)
DO CUML^BDMD315
+10 QUIT
S(P,I,V) ;
+1 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",P,I)=V
+2 QUIT
REC(DFN,BDMRTYP,BDMRBD,BDMRED,BDMED,BDMDMRG) ;EP - called to send back a visit record as
+1 NEW BDMX,BDMREC
+2 SET BDMREC=""
+3 SET BDMRTYP("IEN")=$ORDER(^BDMRECD("B",BDMRTYP,0))
+4 IF 'BDMRTYP("IEN")
QUIT BDMREC
PROC ;
+1 SET BDMX=0
+2 FOR
SET BDMX=$ORDER(^BDMRECD(BDMRTYP("IEN"),11,"AC",BDMX))
IF BDMX'=+BDMX!(BDMREC=-1)
QUIT
SET BDMTTT=$ORDER(^BDMRECD(BDMRTYP("IEN"),11,"AC",BDMX,0))
Begin DoDot:1
+3 SET X=""
IF $DATA(^BDMRECD(BDMRTYP("IEN"),11,BDMTTT,11))
XECUTE ^BDMRECD(BDMRTYP("IEN"),11,BDMTTT,11)
+4 ;W !,BDMTTT,?5,$P(^BDMRECD(BDMRTYP("IEN"),11,BDMTTT,0),U),?40,X H 1
SET $EXTRACT(BDMREC,$PIECE(^BDMRECD(BDMRTYP("IEN"),11,BDMTTT,0),U,2))=X
End DoDot:1
+5 QUIT BDMREC
EPIREC ;create epi info record in ^BDMDATA("BDMEPI",$J,n)
+1 SET BDMEPIR=""
SET BDMEPIR=$$REC(BDMPD,"DM AUDIT 2003 EPI REC 1",BDMRBD,BDMRED,BDMADAT,BDMDMRG)
SET BDMEPIN=BDMEPIN+1
SET ^BDMDATA("BDMEPI",$JOB,BDMEPIN)=BDMEPIR
+2 SET BDMEPIR=""
SET BDMEPIR=$$REC(BDMPD,"DM AUDIT 2003 EPI REC 2",BDMRBD,BDMRED,BDMADAT,BDMDMRG)
SET BDMEPIN=BDMEPIN+1
SET ^BDMDATA("BDMEPI",$JOB,BDMEPIN)=BDMEPIR
+3 SET BDMEPIR=""
SET BDMEPIR=$$REC(BDMPD,"DM AUDIT 2003 EPI REC 3",BDMRBD,BDMRED,BDMADAT,BDMDMRG)
SET BDMEPIN=BDMEPIN+1
SET ^BDMDATA("BDMEPI",$JOB,BDMEPIN)=BDMEPIR
+4 SET BDMEPIR=""
SET BDMEPIR=$$REC(BDMPD,"DM AUDIT 2003 EPI REC 4",BDMRBD,BDMRED,BDMADAT,BDMDMRG)
SET BDMEPIN=BDMEPIN+1
SET ^BDMDATA("BDMEPI",$JOB,BDMEPIN)=BDMEPIR
+5 QUIT
GATHER ;gather data for 1 patient
+1 SET BDMER=0
+1 ;set report dates
+2 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,1)=$SELECT($GET(BDMFISC)]"":BDMFISC,1:BDMRBD_" - "_BDMRED)
+3 ;set audit date to DT
+4 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,2)=$$FMTE^XLFDT(DT)
+5 ;set area, su, facility code and name
+6 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,4)=$PIECE(^DIC(4,DUZ(2),0),U)
+7 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,6)=$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),1,2)
+8 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,8)=$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),3,4)
+9 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,10)=$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),5,6)
+10 ;# pats in register
+11 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,12)=$SELECT(BDMDMRG:$$RSTAT^BDMDM6(BDMDMRG,"A"),1:"")
+12 ;reviewer
+13 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,14)=$PIECE(^VA(200,DUZ,0),U,2)
+14 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,15)=$$VAL^XBDIQ1(9000001,BDMPD,.14)
DEMO ;pat demographics
+1 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,16)=$$HRN^AUPNPAT(BDMPD,DUZ(2))
+2 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,18)=$$DOB^AUPNPAT(BDMPD,"E")
+3 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,20)=$$VAL^XBDIQ1(2,BDMPD,.02)
+4 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,120)=$$TRIBE(BDMPD)
+5 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,121)=$$COMM(BDMPD)
DXDT ;dates of and dm dxs
+1 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,22)=$SELECT(BDMDMRG:$$CMSFDX^BDMD313(BDMPD,BDMDMRG,"D"),1:"")
+2 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,24)=$SELECT(BDMDMRG:$$CMSFDX^BDMD313(BDMPD,BDMDMRG,"DX"),1:"")
+3 SET ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,23)=$$PLDMDOO^BDMD313(BDMPD)
+4 DO S(BDMPD,25,$$PLDMDXS^BDMD313(BDMPD))
+5 DO S(BDMPD,21,$$FRSTDMDX^BDMD313(BDMPD))
+6 DO S(BDMPD,26,$$LASTDMDX^BDMD313(BDMPD,BDMRED))
+7 DO S(BDMPD,27,$$TOBACCO^BDMD316(BDMPD,BDMRED))
+8 SET BDMTYDM=""
DO TYPEDM
DO S(BDMPD,29,BDMTYDM)
+9 DO S(BDMPD,28,$$CESS^BDMD311(BDMPD,BDMRBD,BDMRED))
VITAL ;
+1 DO S(BDMPD,30,$$LASTHT^BDMD313(BDMPD,BDMRED))
+2 DO S(BDMPD,32,$$LASTWT^BDMD313(BDMPD,BDMRED))
+3 ;htn dx
+4 DO S(BDMPD,34,$$HTNDX^BDMD313(BDMPD,BDMRED))
+5 ;last 3 BPs
+6 DO S(BDMPD,36,$$BPS^BDMD313(BDMPD,BDMRBD,BDMRED))
EXAMS ;
+1 DO S(BDMPD,38,$$DFE^BDMD317(BDMPD,BDMRBD,BDMRED))
+2 DO S(BDMPD,40,$$EYE^BDMD317(BDMPD,BDMRBD,BDMRED))
+3 DO S(BDMPD,42,$$DENTAL^BDMD317(BDMPD,BDMRBD,BDMRED))
+4 DO S(BDMPD,44,$$DIETEDUC^BDMD317(BDMPD,BDMRBD,BDMRED))
+5 DO S(BDMPD,46,$$EXEDUC^BDMD317(BDMPD,BDMRBD,BDMRED))
+6 DO S(BDMPD,48,$$OTHEDUC^BDMD317(BDMPD,BDMRBD,BDMRED))
THERAPY ;
+1 SET BDM6MBD=$$FMADD^XLFDT(BDMADAT,-(6*31))
SET BDM6MBD=$$FMTE^XLFDT(BDM6MBD)
+2 DO S(BDMPD,52,$$INSULIN^BDMD312(BDMPD,BDM6MBD,BDMRED))
+3 DO S(BDMPD,53,$$SULF^BDMD312(BDMPD,BDM6MBD,BDMRED))
+4 DO S(BDMPD,54,$$MET^BDMD312(BDMPD,BDM6MBD,BDMRED))
+5 DO S(BDMPD,55,$$ACAR^BDMD312(BDMPD,BDM6MBD,BDMRED))
+6 DO S(BDMPD,56,$$TROG^BDMD312(BDMPD,BDM6MBD,BDMRED))
+7 SET Y=0
FOR X=52:1:56
IF ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,X)="X"
SET Y=1
+8 DO S(BDMPD,51,$SELECT(Y:"",1:"X"))
+9 DO S(BDMPD,60,$$ACE^BDMD316(BDMPD,BDM6MBD,BDMRED))
IMM ;
+1 DO S(BDMPD,62,$$ASPIRIN^BDMD316(BDMPD,BDMRBD,BDMRED))
+2 DO S(BDMPD,61,$$LIPID^BDMD316(BDMPD,BDM6MBD,BDMRED))
+3 DO S(BDMPD,64,$$FLU^BDMD313(BDMPD,BDMRBD,BDMRED))
+4 DO S(BDMPD,66,$$PNEU^BDMD313(BDMPD,BDMRED))
+5 DO S(BDMPD,68,$$TD^BDMD31B(BDMPD,BDMRED))
PPD ;
+1 DO S(BDMPD,70,$$PPD^BDMD318(BDMPD,BDMRED))
+2 DO S(BDMPD,114,$$LASTNP^BDMD318(BDMPD,BDMRED))
+3 DO S(BDMPD,72,$$TBTX^BDMD312(BDMPD))
+4 DO S(BDMPD,76,$$EKG^BDMD312(BDMPD,BDMRED))
LABS ;
+1 DO S(BDMPD,78,$$HGBA1C^BDMD318(BDMPD,BDMRBD,BDMRED))
+2 DO S(BDMPD,82,$$BS^BDMD318(BDMPD,BDMRBD,BDMRED))
+3 DO S(BDMPD,84,$$CREAT^BDMD318(BDMPD,BDMRBD,BDMRED))
+4 DO S(BDMPD,86,$$CHOL^BDMD318(BDMPD,BDMRBD,BDMRED))
+5 DO S(BDMPD,88,$$LDL^BDMD318(BDMPD,BDMRBD,BDMRED))
+6 DO S(BDMPD,89,$$HDL^BDMD318(BDMPD,BDMRBD,BDMRED))
+7 DO S(BDMPD,90,$$TRIG^BDMD318(BDMPD,BDMRBD,BDMRED))
+8 DO S(BDMPD,92,$$URIN^BDMD318(BDMPD,BDMRBD,BDMRED))
+9 DO S(BDMPD,94,$$PROTEIN^BDMD318(BDMPD,BDMRBD,BDMRED))
+10 DO S(BDMPD,96,$$MICRO^BDMD318(BDMPD,BDMRBD,BDMRED))
+11 DO S(BDMPD,98,$$SELF^BDMD316(BDMPD,BDMRBD,BDMRED))
+12 ;D S(BDMPD,100,$$SDM^BDMD316(BDMPD,BDMRBD,BDMRED))
+13 ;D S(BDMPD,102,$$PERI^BDMD316(BDMPD,BDMRBD,BDMRED))
+14 ;D S(BDMPD,104,$$AST^BDMD312(BDMPD,BDMRBD,BDMRED))
+15 ;D S(BDMPD,106,$$ALT^BDMD312(BDMPD,BDMRBD,BDMRED))
+16 DO S(BDMPD,108,$$PAP^BDMD312(BDMPD,BDMRBD,BDMRED))
+17 ;D S(BDMPD,110,$$MAMMOG^BDMD312(BDMPD,BDMRBD,BDMRED))
+18 DO S(BDMPD,112,$$BMI^BDMD318(BDMPD,BDMRBD,BDMRED))
+19 ;
+20 QUIT
TYPEDM ;return type of DM in BDMTYDM
+1 IF ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,24)="NIDDM"
SET BDMTYDM="2 Type 2"
QUIT
+2 IF ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,24)="TYPE II"
SET BDMTYDM="2 Type 2"
QUIT
+3 IF ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,24)[2
SET BDMTYDM="2 Type 2"
QUIT
+4 IF ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,24)="IDDM"
SET BDMTYDM="1 Type 1"
QUIT
+5 IF ^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,24)[1
SET BDMTYDM="1 Type 1"
QUIT
+6 ;get problem list dxs
SET X=^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,25)
+7 FOR I=1:1
SET C=$PIECE(X,";",I)
IF C=""!(BDMTYDM]"")
QUIT
IF $EXTRACT(C,6)=0!($EXTRACT(C,6)=2)
SET BDMTYDM="2 Type 2"
+8 IF BDMTYDM]""
QUIT
+9 FOR I=1:1
SET C=$PIECE(X,";",I)
IF C=""!(BDMTYDM]"")
QUIT
IF $EXTRACT(C,6)=1!($EXTRACT(C,6)=3)
SET BDMTYDM="1 Type 1"
+10 IF BDMTYDM]""
QUIT
+11 ;get pov list dxs
SET X=^XTMP("BDMDM31",BDMJOB,BDMBTH,"AUDIT",BDMPD,26)
+12 IF X[2
SET BDMTYDM="2 Type 2"
QUIT
+13 IF X[1
SET BDMTYDM="1 Type 1"
QUIT
+14 QUIT
DATE(D) ;EP
+1 IF $GET(D)=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+($EXTRACT(D,1,3)))
TRIBE(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^AUPNPAT(P,11))
QUIT ""
+3 QUIT $$TRIBE^AUPNPAT(P,"C")_"^"_$$TRIBE^AUPNPAT(P,"E")
COMM(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^AUPNPAT(P,11))
QUIT ""
+3 QUIT $$COMMRES^AUPNPAT(P,"C")_"^"_$$COMMRES^AUPNPAT(P,"E")
