BUDBRP7L ; IHS/CMI/LAB - UDS REPORT DRIVER TABLE 6B ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
PAUSE ;
K DIR S DIR(0)="E",DIR("A")="PRESS ENTER" KILL DA D ^DIR KILL DIR
Q
GENI ;general introductions
D GENI^BUDBRP7I
Q
;
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
;
DMR ;EP
W:$D(IOF) @IOF
W !,$$CTR($$LOC,80)
W !,$$CTR("UDS 2014",80)
W !!,"All Patients w/DM by Race and Hispanic or Latino Identity (Table 7)",!
D GENI
D PAUSE
W !!,"This report provides a list by race of patients age 18 to 75 years old who"
W !,"have had two medical visits during the report period, with a diagnosis"
W !,"of Type I or Type II diabetes anytime through the end of the report"
W !,"period, and without a diagnosis of polycystic ovaries, gestational"
W !,"diabetes, or steroid-induced diabetes."
W !
Q
DMRL ;EP
S BUDP=0,BUDQUIT=0,BUDTOT=0
D DMRH Q:BUDQUIT
I '$D(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR")) W !!,"No patients to report." Q
D DMRL1
I $Y>(IOSL-3) D DMRH G:BUDQUIT DMRLX
W !!," TOTAL DIABETES PATIENTS 18-75 BY RACE AND HISPANIC OR LATINO IDENTITY: ",BUDTOT,!
DMRLX ;
Q
DMRL1 ;
I $Y>(IOSL-7) D DMRH Q:BUDQUIT
S BUDTOT=0
S BUDRACE="" F S BUDRACE=$O(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR",BUDRACE)) Q:BUDRACE=""!(BUDQUIT) D
.S BUDETH="" F S BUDETH=$O(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR",BUDRACE,BUDETH)) Q:BUDETH=""!(BUDQUIT) D DMRL2
Q
DMRL2 ;
S BUDSTOT=0
S BUDRACEL=$$RACEL^BUDBRP7I(BUDRACE,BUDETH)
W !,BUDRACEL
S BUDCOM="" F S BUDCOM=$O(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR",BUDRACE,BUDETH,BUDCOM)) Q:BUDCOM=""!(BUDQUIT) D
.S BUDA="" F S BUDA=$O(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR",BUDRACE,BUDETH,BUDCOM,BUDA)) Q:BUDA=""!(BUDQUIT) D
..S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR",BUDRACE,BUDETH,BUDCOM,BUDA,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
...S DFN=0 F S DFN=$O(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR",BUDRACE,BUDETH,BUDCOM,BUDA,BUDNAME,DFN)) Q:DFN'=+DFN!(BUDQUIT) D
....I $Y>(IOSL-3) D DMRH Q:BUDQUIT W !,BUDRACEL,!
....W !?2,$E($P(^DPT(DFN,0),U,1),1,20),?24,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?36,$E(BUDCOM,1,10),?47,$P(^DPT(DFN,0),U,2),?51,BUDA,! ;
....S BUDTOT=BUDTOT+1,BUDSTOT=BUDSTOT+1
....S BUDRACV=$$RACE^BUDBRPTC(DFN)
....W ?2,$E($P(BUDRACV,U,4),1,16)_" ("_$P(BUDRACV,U,3),")" ;,?60,$E($P($$RACE^BUDBRPTC(DFN),U,3)_"-"_$P($$RACE^BUDBRPTC(DFN),U,4),1,19)
....S BUDHISV=$$HISP^BUDBRPTC(DFN)
....W ?24,$P(BUDHISV,U,3)," (",$P(BUDHISV,U,2),")",!
....S BUDALL=^XTMP("BUDBRP7",BUDJ,BUDH,"DMR",BUDRACE,BUDETH,BUDCOM,BUDA,BUDNAME,DFN)
....S BUDPPV=$P(BUDALL,"^",1)
....;W ?5,$P(BUDALL,"^",2),!
....F BUDX=1:1 S BUDV=$P(BUDPPV,U,BUDX) Q:BUDV=""!(BUDQUIT) D
.....I $Y>(IOSL-3) D DMRH Q:BUDQUIT W !,BUDRACEL,!
.....I $E(BUDV)="P" W ?5,BUDV,! Q
.....S V=$P(BUDV,"|"),C=$P(BUDV,"|",2)
.....W ?5,$$FMTE^XLFDT($P($P(^AUPNVSIT(V,0),U),".")),?19,C,?35,$$PRIMPROV^APCLV(V,"D"),?45,$P(^AUPNVSIT(V,0),U,7),?53,$$CLINIC^APCLV(V,"C"),?65,$E($$VAL^XBDIQ1(9000010,V,.06),1,15),!
I $Y>(IOSL-4) D DMRH Q:BUDQUIT W !,BUDRACEL,!
W !,"Sub-Total ",BUDRACEL,": ",BUDSTOT,!
Q
DMRH ;
G:'BUDGPG DMRH1
K DIR I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BUDQUIT=1 Q
DMRH1 ;
W:$D(IOF) @IOF S BUDGPG=BUDGPG+1
W !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
W !,$$CTR("*** RPMS Uniform Data System (UDS) ***",80)
W !,$$CTR("Patient List for Table 7, Section C",80)
W !,$$CTR("Diabetes Patients by Race and Hispanic or Latino Identity",80),! ;, DM Patients by Race and Hispanic or Latino Identity",80),!
W $$CTR($P(^DIC(4,BUDSITE,0),U),80),!
S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) W $$CTR(X,80),!
W $TR($J("",80)," ","-")
I BUDP=0 D
.W !,"List by race and Hispanic or Latino identity of all patients 18 to 75 years "
.W !,"old who have had two medical visits during the report period and were diagnosed"
.W !,"with Type I or Type II diabetes anytime through the end of the report period."
.W !,"Age is calculated as of December 31."
.W !,"* E - denotes the value was obtained from the Ethnicity field."
.W !," R - denotes the value was obtained from the Race field"
.W !," C - denotes the value was obtained from the Classification/Beneficiary field"
.W !
W !?2,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?47,"SEX",?51,"AGE"
W !?2,"RACE*",?24,"HISPANIC OR LATINO IDENTITY*"
W !?5,"LAST DM DATE",?19,"DX OR SVC CD",?35,"PROV TYPE",?45,"SVC CAT",?53,"CLINIC",?65,"LOCATION"
W !,$TR($J("",80)," ","-"),!
S BUDP=1
Q
;
DMR1 ;EP
W:$D(IOF) @IOF
W !,$$CTR($$LOC,80)
W !,$$CTR("UDS 2014",80)
W !!,"All Patients w/DM and A1c <8 by Race and Hispanic or Latino Identity (Table 7)",!
D GENI
D PAUSE
W !!,"This report provides a list by race and Hispanic or Latino Identity"
W !,"of patients age 18 to 75 years old who have had two"
W !,"medical visits during the report period, with a diagnosis"
W !,"of Type I or Type II diabetes anytime through the end of the report"
W !,"period, and without a diagnosis of polycystic ovaries, gestational diabetes,"
W !,"or steroid-induced diabetes and with a most recent hemoglobin A1c of less"
W !,"than 8%."
W !
Q
DMR1L ;EP
S BUDP=0,BUDQUIT=0,BUDTOT=0
D DMR1H Q:BUDQUIT
I '$D(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR1")) W !!,"No patients to report." Q
D DMR1L1
I $Y>(IOSL-3) D DMR1H G:BUDQUIT DMR1LX
W !!,"TOTAL DIABETES PTS 18-75 W/A1C <8% BY RACE & HISPANIC OR LATINO IDENTITY: ",BUDTOT,!
DMR1LX ;
Q
DMR1L1 ;
I $Y>(IOSL-7) D DMR1H Q:BUDQUIT
S BUDTOT=0
S BUDRACE="" F S BUDRACE=$O(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR1",BUDRACE)) Q:BUDRACE=""!(BUDQUIT) D
.S BUDETH="" F S BUDETH=$O(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR1",BUDRACE,BUDETH)) Q:BUDETH=""!(BUDQUIT) D DMR1L2
Q
DMR1L2 ;
S BUDSTOT=0
S BUDRACEL=$$RACEL^BUDBRP7I(BUDRACE,BUDETH)
W !,BUDRACEL
S BUDCOM="" F S BUDCOM=$O(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR1",BUDRACE,BUDETH,BUDCOM)) Q:BUDCOM=""!(BUDQUIT) D
.S BUDA="" F S BUDA=$O(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR1",BUDRACE,BUDETH,BUDCOM,BUDA)) Q:BUDA=""!(BUDQUIT) D
..S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR1",BUDRACE,BUDETH,BUDCOM,BUDA,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
...S DFN=0 F S DFN=$O(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR1",BUDRACE,BUDETH,BUDCOM,BUDA,BUDNAME,DFN)) Q:DFN'=+DFN!(BUDQUIT) D
....I $Y>(IOSL-3) D DMR1H Q:BUDQUIT W !,BUDRACEL,!
....W !?2,$E($P(^DPT(DFN,0),U,1),1,20),?24,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?36,$E(BUDCOM,1,10),?47,$P(^DPT(DFN,0),U,2),?51,BUDA,! ;
....S BUDTOT=BUDTOT+1,BUDSTOT=BUDSTOT+1
....S BUDRACV=$$RACE^BUDBRPTC(DFN)
....W ?2,$E($P(BUDRACV,U,4),1,16)_" ("_$P(BUDRACV,U,3),")" ;,?60,$E($P($$RACE^BUDBRPTC(DFN),U,3)_"-"_$P($$RACE^BUDBRPTC(DFN),U,4),1,19)
....S BUDHISV=$$HISP^BUDBRPTC(DFN)
....W ?24,$P(BUDHISV,U,3)," (",$P(BUDHISV,U,2),")",!
....S BUDALL=^XTMP("BUDBRP7",BUDJ,BUDH,"DMR1",BUDRACE,BUDETH,BUDCOM,BUDA,BUDNAME,DFN)
....S BUDPPV=$P(BUDALL,"^",1)
....W ?5,$P(BUDALL,"^",2),!
....F BUDX=1:1 S BUDV=$P(BUDPPV,U,BUDX) Q:BUDV=""!(BUDQUIT) D
.....I $Y>(IOSL-3) D DMR1H Q:BUDQUIT W !,BUDRACEL,!
.....I $E(BUDV)="P" W ?5,BUDV,! Q
.....S V=$P(BUDV,"|"),C=$P(BUDV,"|",2)
.....W ?5,$$FMTE^XLFDT($P($P(^AUPNVSIT(V,0),U),".")),?19,C,?35,$$PRIMPROV^APCLV(V,"D"),?45,$P(^AUPNVSIT(V,0),U,7),?53,$$CLINIC^APCLV(V,"C"),?65,$E($$VAL^XBDIQ1(9000010,V,.06),1,15),!
I $Y>(IOSL-4) D DMR1H Q:BUDQUIT W !,BUDRACEL,!
W !,"Sub-Total ",BUDRACEL,": ",BUDSTOT,!
Q
DMR1H ;
G:'BUDGPG DMR1H1
K DIR I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BUDQUIT=1 Q
DMR1H1 ;
W:$D(IOF) @IOF S BUDGPG=BUDGPG+1
W !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
W !,$$CTR("*** RPMS Uniform Data System (UDS) ***",80)
W !,$$CTR("Patient List for Table 7, Section C",80)
W !,$$CTR("Diabetes w/A1c <8 by Race and Hispanic or Latino Identity",80),!
W $$CTR($P(^DIC(4,BUDSITE,0),U),80),!
S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) W $$CTR(X,80),!
W $TR($J("",80)," ","-")
I BUDP=0 D
.W !,"List by race and Hispanic or Latino identity of all patients 18 to 75 years"
.W !,"old who have had two medical visits during the report period and were diagnosed"
.W !,"with Type I or Type II diabetes anytime through the end of the report period "
.W !,"and whose most recent hemoglobin A1c is <8%."
.W !,"Age is calculated as of December 31."
.W !,"* E - denotes the value was obtained from the Ethnicity field."
.W !," R - denotes the value was obtained from the Race field"
.W !," C - denotes the value was obtained from the Classification/Beneficiary field"
.W !
W !?2,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?47,"SEX",?51,"AGE"
W !?2,"RACE*",?24,"HISPANIC OR LATINO IDENTITY*"
W !?5,"LAST A1C VALUE OR CD & DATE"
W !?5,"LAST DM DATE",?19,"DX OR SVC CD",?35,"PROV TYPE",?45,"SVC CAT",?53,"CLINIC",?65,"LOCATION"
W !,$TR($J("",80)," ","-"),!
S BUDP=1
Q
BUDBRP7L ; IHS/CMI/LAB - UDS REPORT DRIVER TABLE 6B ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
+3 ;
PAUSE ;
+1 KILL DIR
SET DIR(0)="E"
SET DIR("A")="PRESS ENTER"
KILL DA
DO ^DIR
KILL DIR
+2 QUIT
GENI ;general introductions
+1 DO GENI^BUDBRP7I
+2 QUIT
+3 ;
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
+3 ;
DMR ;EP
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,$$CTR($$LOC,80)
+3 WRITE !,$$CTR("UDS 2014",80)
+4 WRITE !!,"All Patients w/DM by Race and Hispanic or Latino Identity (Table 7)",!
+5 DO GENI
+6 DO PAUSE
+7 WRITE !!,"This report provides a list by race of patients age 18 to 75 years old who"
+8 WRITE !,"have had two medical visits during the report period, with a diagnosis"
+9 WRITE !,"of Type I or Type II diabetes anytime through the end of the report"
+10 WRITE !,"period, and without a diagnosis of polycystic ovaries, gestational"
+11 WRITE !,"diabetes, or steroid-induced diabetes."
+12 WRITE !
+13 QUIT
DMRL ;EP
+1 SET BUDP=0
SET BUDQUIT=0
SET BUDTOT=0
+2 DO DMRH
IF BUDQUIT
QUIT
+3 IF '$DATA(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR"))
WRITE !!,"No patients to report."
QUIT
+4 DO DMRL1
+5 IF $Y>(IOSL-3)
DO DMRH
IF BUDQUIT
GOTO DMRLX
+6 WRITE !!," TOTAL DIABETES PATIENTS 18-75 BY RACE AND HISPANIC OR LATINO IDENTITY: ",BUDTOT,!
DMRLX ;
+1 QUIT
DMRL1 ;
+1 IF $Y>(IOSL-7)
DO DMRH
IF BUDQUIT
QUIT
+2 SET BUDTOT=0
+3 SET BUDRACE=""
FOR
SET BUDRACE=$ORDER(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR",BUDRACE))
IF BUDRACE=""!(BUDQUIT)
QUIT
Begin DoDot:1
+4 SET BUDETH=""
FOR
SET BUDETH=$ORDER(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR",BUDRACE,BUDETH))
IF BUDETH=""!(BUDQUIT)
QUIT
DO DMRL2
End DoDot:1
+5 QUIT
DMRL2 ;
+1 SET BUDSTOT=0
+2 SET BUDRACEL=$$RACEL^BUDBRP7I(BUDRACE,BUDETH)
+3 WRITE !,BUDRACEL
+4 SET BUDCOM=""
FOR
SET BUDCOM=$ORDER(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR",BUDRACE,BUDETH,BUDCOM))
IF BUDCOM=""!(BUDQUIT)
QUIT
Begin DoDot:1
+5 SET BUDA=""
FOR
SET BUDA=$ORDER(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR",BUDRACE,BUDETH,BUDCOM,BUDA))
IF BUDA=""!(BUDQUIT)
QUIT
Begin DoDot:2
+6 SET BUDNAME=""
FOR
SET BUDNAME=$ORDER(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR",BUDRACE,BUDETH,BUDCOM,BUDA,BUDNAME))
IF BUDNAME=""!(BUDQUIT)
QUIT
Begin DoDot:3
+7 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR",BUDRACE,BUDETH,BUDCOM,BUDA,BUDNAME,DFN))
IF DFN'=+DFN!(BUDQUIT)
QUIT
Begin DoDot:4
+8 IF $Y>(IOSL-3)
DO DMRH
IF BUDQUIT
QUIT
WRITE !,BUDRACEL,!
+9 ;
WRITE !?2,$EXTRACT($PIECE(^DPT(DFN,0),U,1),1,20),?24,$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?36,$EXTRACT(BUDCOM,1,10),?47,$PIECE(^DPT(DFN,0),U,2),?51,BUD
A,!
+10 SET BUDTOT=BUDTOT+1
SET BUDSTOT=BUDSTOT+1
+11 SET BUDRACV=$$RACE^BUDBRPTC(DFN)
+12 ;,?60,$E($P($$RACE^BUDBRPTC(DFN),U,3)_"-"_$P($$RACE^BUDBRPTC(DFN),U,4),1,19)
WRITE ?2,$EXTRACT($PIECE(BUDRACV,U,4),1,16)_" ("_$PIECE(BUDRACV,U,3),")"
+13 SET BUDHISV=$$HISP^BUDBRPTC(DFN)
+14 WRITE ?24,$PIECE(BUDHISV,U,3)," (",$PIECE(BUDHISV,U,2),")",!
+15 SET BUDALL=^XTMP("BUDBRP7",BUDJ,BUDH,"DMR",BUDRACE,BUDETH,BUDCOM,BUDA,BUDNAME,DFN)
+16 SET BUDPPV=$PIECE(BUDALL,"^",1)
+17 ;W ?5,$P(BUDALL,"^",2),!
+18 FOR BUDX=1:1
SET BUDV=$PIECE(BUDPPV,U,BUDX)
IF BUDV=""!(BUDQUIT)
QUIT
Begin DoDot:5
+19 IF $Y>(IOSL-3)
DO DMRH
IF BUDQUIT
QUIT
WRITE !,BUDRACEL,!
+20 IF $EXTRACT(BUDV)="P"
WRITE ?5,BUDV,!
QUIT
+21 SET V=$PIECE(BUDV,"|")
SET C=$PIECE(BUDV,"|",2)
+22 WRITE ?5,$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(V,0),U),".")),?19,C,?35,$$PRIMPROV^APCLV(V,"D"),?45,$PIECE(^AUPNVSIT(V,0),U,7),?53,$$CLINIC^APCLV(V,"C"),?65,$EXTRACT($$VAL^XBDIQ1(9000010,V,.06),1,15),!
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+23 IF $Y>(IOSL-4)
DO DMRH
IF BUDQUIT
QUIT
WRITE !,BUDRACEL,!
+24 WRITE !,"Sub-Total ",BUDRACEL,": ",BUDSTOT,!
+25 QUIT
DMRH ;
+1 IF 'BUDGPG
GOTO DMRH1
+2 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
IF '$DATA(ZTQUEUED)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BUDQUIT=1
QUIT
DMRH1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET BUDGPG=BUDGPG+1
+2 WRITE !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
+3 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
+4 WRITE !,$$CTR("*** RPMS Uniform Data System (UDS) ***",80)
+5 WRITE !,$$CTR("Patient List for Table 7, Section C",80)
+6 ;, DM Patients by Race and Hispanic or Latino Identity",80),!
WRITE !,$$CTR("Diabetes Patients by Race and Hispanic or Latino Identity",80),!
+7 WRITE $$CTR($PIECE(^DIC(4,BUDSITE,0),U),80),!
+8 SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)
WRITE $$CTR(X,80),!
+9 WRITE $TRANSLATE($JUSTIFY("",80)," ","-")
+10 IF BUDP=0
Begin DoDot:1
+11 WRITE !,"List by race and Hispanic or Latino identity of all patients 18 to 75 years "
+12 WRITE !,"old who have had two medical visits during the report period and were diagnosed"
+13 WRITE !,"with Type I or Type II diabetes anytime through the end of the report period."
+14 WRITE !,"Age is calculated as of December 31."
+15 WRITE !,"* E - denotes the value was obtained from the Ethnicity field."
+16 WRITE !," R - denotes the value was obtained from the Race field"
+17 WRITE !," C - denotes the value was obtained from the Classification/Beneficiary field"
+18 WRITE !
End DoDot:1
+19 WRITE !?2,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?47,"SEX",?51,"AGE"
+20 WRITE !?2,"RACE*",?24,"HISPANIC OR LATINO IDENTITY*"
+21 WRITE !?5,"LAST DM DATE",?19,"DX OR SVC CD",?35,"PROV TYPE",?45,"SVC CAT",?53,"CLINIC",?65,"LOCATION"
+22 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-"),!
+23 SET BUDP=1
+24 QUIT
+25 ;
DMR1 ;EP
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,$$CTR($$LOC,80)
+3 WRITE !,$$CTR("UDS 2014",80)
+4 WRITE !!,"All Patients w/DM and A1c <8 by Race and Hispanic or Latino Identity (Table 7)",!
+5 DO GENI
+6 DO PAUSE
+7 WRITE !!,"This report provides a list by race and Hispanic or Latino Identity"
+8 WRITE !,"of patients age 18 to 75 years old who have had two"
+9 WRITE !,"medical visits during the report period, with a diagnosis"
+10 WRITE !,"of Type I or Type II diabetes anytime through the end of the report"
+11 WRITE !,"period, and without a diagnosis of polycystic ovaries, gestational diabetes,"
+12 WRITE !,"or steroid-induced diabetes and with a most recent hemoglobin A1c of less"
+13 WRITE !,"than 8%."
+14 WRITE !
+15 QUIT
DMR1L ;EP
+1 SET BUDP=0
SET BUDQUIT=0
SET BUDTOT=0
+2 DO DMR1H
IF BUDQUIT
QUIT
+3 IF '$DATA(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR1"))
WRITE !!,"No patients to report."
QUIT
+4 DO DMR1L1
+5 IF $Y>(IOSL-3)
DO DMR1H
IF BUDQUIT
GOTO DMR1LX
+6 WRITE !!,"TOTAL DIABETES PTS 18-75 W/A1C <8% BY RACE & HISPANIC OR LATINO IDENTITY: ",BUDTOT,!
DMR1LX ;
+1 QUIT
DMR1L1 ;
+1 IF $Y>(IOSL-7)
DO DMR1H
IF BUDQUIT
QUIT
+2 SET BUDTOT=0
+3 SET BUDRACE=""
FOR
SET BUDRACE=$ORDER(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR1",BUDRACE))
IF BUDRACE=""!(BUDQUIT)
QUIT
Begin DoDot:1
+4 SET BUDETH=""
FOR
SET BUDETH=$ORDER(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR1",BUDRACE,BUDETH))
IF BUDETH=""!(BUDQUIT)
QUIT
DO DMR1L2
End DoDot:1
+5 QUIT
DMR1L2 ;
+1 SET BUDSTOT=0
+2 SET BUDRACEL=$$RACEL^BUDBRP7I(BUDRACE,BUDETH)
+3 WRITE !,BUDRACEL
+4 SET BUDCOM=""
FOR
SET BUDCOM=$ORDER(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR1",BUDRACE,BUDETH,BUDCOM))
IF BUDCOM=""!(BUDQUIT)
QUIT
Begin DoDot:1
+5 SET BUDA=""
FOR
SET BUDA=$ORDER(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR1",BUDRACE,BUDETH,BUDCOM,BUDA))
IF BUDA=""!(BUDQUIT)
QUIT
Begin DoDot:2
+6 SET BUDNAME=""
FOR
SET BUDNAME=$ORDER(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR1",BUDRACE,BUDETH,BUDCOM,BUDA,BUDNAME))
IF BUDNAME=""!(BUDQUIT)
QUIT
Begin DoDot:3
+7 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUDBRP7",BUDJ,BUDH,"DMR1",BUDRACE,BUDETH,BUDCOM,BUDA,BUDNAME,DFN))
IF DFN'=+DFN!(BUDQUIT)
QUIT
Begin DoDot:4
+8 IF $Y>(IOSL-3)
DO DMR1H
IF BUDQUIT
QUIT
WRITE !,BUDRACEL,!
+9 ;
WRITE !?2,$EXTRACT($PIECE(^DPT(DFN,0),U,1),1,20),?24,$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?36,$EXTRACT(BUDCOM,1,10),?47,$PIECE(^DPT(DFN,0),U,2),?51,BUD
A,!
+10 SET BUDTOT=BUDTOT+1
SET BUDSTOT=BUDSTOT+1
+11 SET BUDRACV=$$RACE^BUDBRPTC(DFN)
+12 ;,?60,$E($P($$RACE^BUDBRPTC(DFN),U,3)_"-"_$P($$RACE^BUDBRPTC(DFN),U,4),1,19)
WRITE ?2,$EXTRACT($PIECE(BUDRACV,U,4),1,16)_" ("_$PIECE(BUDRACV,U,3),")"
+13 SET BUDHISV=$$HISP^BUDBRPTC(DFN)
+14 WRITE ?24,$PIECE(BUDHISV,U,3)," (",$PIECE(BUDHISV,U,2),")",!
+15 SET BUDALL=^XTMP("BUDBRP7",BUDJ,BUDH,"DMR1",BUDRACE,BUDETH,BUDCOM,BUDA,BUDNAME,DFN)
+16 SET BUDPPV=$PIECE(BUDALL,"^",1)
+17 WRITE ?5,$PIECE(BUDALL,"^",2),!
+18 FOR BUDX=1:1
SET BUDV=$PIECE(BUDPPV,U,BUDX)
IF BUDV=""!(BUDQUIT)
QUIT
Begin DoDot:5
+19 IF $Y>(IOSL-3)
DO DMR1H
IF BUDQUIT
QUIT
WRITE !,BUDRACEL,!
+20 IF $EXTRACT(BUDV)="P"
WRITE ?5,BUDV,!
QUIT
+21 SET V=$PIECE(BUDV,"|")
SET C=$PIECE(BUDV,"|",2)
+22 WRITE ?5,$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(V,0),U),".")),?19,C,?35,$$PRIMPROV^APCLV(V,"D"),?45,$PIECE(^AUPNVSIT(V,0),U,7),?53,$$CLINIC^APCLV(V,"C"),?65,$EXTRACT($$VAL^XBDIQ1(9000010,V,.06),1,15),!
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+23 IF $Y>(IOSL-4)
DO DMR1H
IF BUDQUIT
QUIT
WRITE !,BUDRACEL,!
+24 WRITE !,"Sub-Total ",BUDRACEL,": ",BUDSTOT,!
+25 QUIT
DMR1H ;
+1 IF 'BUDGPG
GOTO DMR1H1
+2 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
IF '$DATA(ZTQUEUED)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BUDQUIT=1
QUIT
DMR1H1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET BUDGPG=BUDGPG+1
+2 WRITE !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
+3 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
+4 WRITE !,$$CTR("*** RPMS Uniform Data System (UDS) ***",80)
+5 WRITE !,$$CTR("Patient List for Table 7, Section C",80)
+6 WRITE !,$$CTR("Diabetes w/A1c <8 by Race and Hispanic or Latino Identity",80),!
+7 WRITE $$CTR($PIECE(^DIC(4,BUDSITE,0),U),80),!
+8 SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)
WRITE $$CTR(X,80),!
+9 WRITE $TRANSLATE($JUSTIFY("",80)," ","-")
+10 IF BUDP=0
Begin DoDot:1
+11 WRITE !,"List by race and Hispanic or Latino identity of all patients 18 to 75 years"
+12 WRITE !,"old who have had two medical visits during the report period and were diagnosed"
+13 WRITE !,"with Type I or Type II diabetes anytime through the end of the report period "
+14 WRITE !,"and whose most recent hemoglobin A1c is <8%."
+15 WRITE !,"Age is calculated as of December 31."
+16 WRITE !,"* E - denotes the value was obtained from the Ethnicity field."
+17 WRITE !," R - denotes the value was obtained from the Race field"
+18 WRITE !," C - denotes the value was obtained from the Classification/Beneficiary field"
+19 WRITE !
End DoDot:1
+20 WRITE !?2,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?47,"SEX",?51,"AGE"
+21 WRITE !?2,"RACE*",?24,"HISPANIC OR LATINO IDENTITY*"
+22 WRITE !?5,"LAST A1C VALUE OR CD & DATE"
+23 WRITE !?5,"LAST DM DATE",?19,"DX OR SVC CD",?35,"PROV TYPE",?45,"SVC CAT",?53,"CLINIC",?65,"LOCATION"
+24 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-"),!
+25 SET BUDP=1
+26 QUIT
