BUD8RP7J.m

BUD8RP7J ; 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

 W !,"NOTE: Patient lists may be hundreds of pages long, depending on the size of your"

 W !,"patient population.  It is recommended that you run these reports at night and"

 W !,"print to an electronic file, not directly to a printer.",!

 K DIR S DIR(0)="E",DIR("A")="Press Enter to Continue" D ^DIR K DIR

 W !!,"This Patient List option documents the individual patients and encounters"

 W !,"(visits) that are counted and summarized on each Table report (main menu"

 W !,"option REP).  The summary Table report is included at the beginning of each"

 W !,"List report."

 W !,"UDS searches your database to find all visits (encounters) and related patients"

 W !,"during the time period selected. Based on the UDS definition, to be counted"

 W !,"as a patient, the patient must have had at least one visit meeting the "

 W !,"following criteria:"

 W !?4,"- must be to a location specified in your visit location setup"

 W !?4,"- must be to Service Category Ambulatory (A), Hospitalization (H), Day"

 W !?6,"Surgery (S), Observation (O), Nursing home visit (R), "

 W !?6,"or In-Hospital (I) visit"

 W !?4,"- must NOT have an excluded clinic code (see User Manual for a list)"

 W !?4,"- must have a primary provider and a coded purpose of visit"

 W !

 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")

 ;----------

 ;

HTR ;EP

 W:$D(IOF) @IOF

 W !,$$CTR($$LOC,80)

 W !,$$CTR("UDS 2008",80)

 W !!,"All Hypertension Patients by Race (Table 7)",!

 D GENI

 D PAUSE

 W !!,"This report provides a list by race of patients age 18 and older who"

 W !,"have had two medical visits during the report period and were diagnosed"

 W !,"with hypertension before June 30 of the report period."

 W !

 Q

HTRL ;EP

 S BUDP=0,BUDQUIT=0,BUDTOT=0

 D HTRH Q:BUDQUIT

 I '$D(^XTMP("BUD8RP7",BUDJ,BUDH,"HTR")) W !!,"No patients to report." Q

 D HTRL1

 I $Y>(IOSL-3) D HTRH G:BUDQUIT HTRLX

 W !!,"TOTAL HTN PATIENTS 18+ BY RACE: ",BUDTOT,!

HTRLX ;

 Q

HTRL1 ;

 I $Y>(IOSL-7) D HTRH Q:BUDQUIT

 S BUDTOT=0

 S BUDRACE="" F  S BUDRACE=$O(^XTMP("BUD8RP7",BUDJ,BUDH,"HTR",BUDRACE)) Q:BUDRACE=""!(BUDQUIT)  D HTRL2

 Q

HTRL2 ;

 S BUDSTOT=0

 W !,BUDRACE

 S BUDCOM="" F  S BUDCOM=$O(^XTMP("BUD8RP7",BUDJ,BUDH,"HTR",BUDRACE,BUDCOM)) Q:BUDCOM=""!(BUDQUIT)  D

 .S BUDA="" F  S BUDA=$O(^XTMP("BUD8RP7",BUDJ,BUDH,"HTR",BUDRACE,BUDCOM,BUDA)) Q:BUDA=""!(BUDQUIT)  D

 ..S BUDNAME="" F  S BUDNAME=$O(^XTMP("BUD8RP7",BUDJ,BUDH,"HTR",BUDRACE,BUDCOM,BUDA,BUDNAME)) Q:BUDNAME=""!(BUDQUIT)  D

 ...S DFN=0 F  S DFN=$O(^XTMP("BUD8RP7",BUDJ,BUDH,"HTR",BUDRACE,BUDCOM,BUDA,BUDNAME,DFN)) Q:DFN'=+DFN!(BUDQUIT)  D

 ....I $Y>(IOSL-3) D HTRH Q:BUDQUIT  W !,BUDRACE

 ....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))

 ....W ?36,$E(BUDCOM,1,10),?47,$P(^DPT(DFN,0),U,2),?51,BUDA,?55,$P($$RACE^BUD8RPTC(DFN),U,3)_"-"_$P($$RACE^BUD8RPTC(DFN),U,4),!

 ....S BUDTOT=BUDTOT+1,BUDSTOT=BUDSTOT+1

 ....S BUDALL=^XTMP("BUD8RP7",BUDJ,BUDH,"HTR",BUDRACE,BUDCOM,BUDA,BUDNAME,DFN)

 ....S BUDPPV=$P(BUDALL,"#",1)

 ....F BUDX=1:1 S BUDV=$P(BUDPPV,U,BUDX) Q:BUDV=""!(BUDQUIT)  D

 .....I $Y>(IOSL-3) D HTRH Q:BUDQUIT  W !,BUDRACE

 .....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 HTRH Q:BUDQUIT  W !,BUDRACE

 W !,"Sub-Total ",BUDRACE,":  ",BUDSTOT,!

 Q

HTRH ;

 G:'BUDGPG HTRH1

 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

HTRH1 ;

 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 B, HTN Patients by Race",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 of patients age 18 and older who have had two medical visits"

 .W !,"during the report period and were diagnosed with hypertension before"

 .W !,"June 30 of the report period."

 .W !,"Age is calculated as of December 31."

 .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",?55,"RACE*"

 W !?5,"LAST HTN DATE",?19,"DX OR SRV CD",?35,"PROV TYPE",?45,"SRV CAT",?53,"CLINIC",?65,"LOCATION"

 W !,$TR($J("",80)," ","-"),!

 S BUDP=1

 Q

 ;

HTCR ;EP

 W:$D(IOF) @IOF

 W !,$$CTR($$LOC,80)

 W !,$$CTR("UDS 2008",80)

 W !!,"All Hypertension Patients w/Controlled BP by Race (Table 7)",!

 D GENI

 D PAUSE

 W !!,"This report provides a list by race of patients age 18 and older who"

 W !,"have had two medical visits during the report period, were diagnosed"

 W !,"with hypertension before June 30 of the report period, and who have"

 W !,"controlled blood pressure (<140/90 mm HG) during the report period."

 W !

 Q

HTCRL ;EP

 S BUDP=0,BUDQUIT=0,BUDTOT=0

 D HTCRH Q:BUDQUIT

 I '$D(^XTMP("BUD8RP7",BUDJ,BUDH,"HTCR")) W !!,"No patients to report." Q

 D HTCRL1

 I $Y>(IOSL-3) D HTCRH G:BUDQUIT HTCRLX

 W !!,"TOTAL HTN PATIENTS 18+ W/CONTROLLED BP BY RACE: ",BUDTOT,!

HTCRLX ;

 Q

HTCRL1 ;

 I $Y>(IOSL-7) D HTCRH Q:BUDQUIT

 S BUDTOT=0

 S BUDRACE="" F  S BUDRACE=$O(^XTMP("BUD8RP7",BUDJ,BUDH,"HTCR",BUDRACE)) Q:BUDRACE=""!(BUDQUIT)  D HTCRL2

 Q

HTCRL2 ;

 S BUDSTOT=0

 W !,BUDRACE

 S BUDNAME="" F  S BUDNAME=$O(^XTMP("BUD8RP7",BUDJ,BUDH,"HTCR",BUDRACE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT)  D

 .S BUDCOM="" F  S BUDCOM=$O(^XTMP("BUD8RP7",BUDJ,BUDH,"HTCR",BUDRACE,BUDNAME,BUDCOM)) Q:BUDCOM=""!(BUDQUIT)  D

 ..S DFN=0 F  S DFN=$O(^XTMP("BUD8RP7",BUDJ,BUDH,"HTCR",BUDRACE,BUDNAME,BUDCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT)  D

 ...I $Y>(IOSL-3) D HTCRH Q:BUDQUIT  W !,BUDRACE,!

 ...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))

 ...W ?36,$E(BUDCOM,1,10),?47,$P(^DPT(DFN,0),U,2),?51,$$AGE^AUPNPAT(DFN,BUDED),?55,$E(BUDRACE,1,24),!

 ...S BUDTOT=BUDTOT+1,BUDSTOT=BUDSTOT+1

 ...S BUDALL=^XTMP("BUD8RP7",BUDJ,BUDH,"HTCR",BUDRACE,BUDNAME,BUDCOM,DFN)

 ...W ?5,$P(BUDALL,U,2),!

 ...S BUDPPV=$P(BUDALL,"^",1)

 ...F BUDX=1:1 S BUDV=$P(BUDPPV,U,BUDX) Q:BUDV=""!(BUDQUIT)  D

 ....I $Y>(IOSL-3) D HTCRH Q:BUDQUIT  W !,BUDRACE,!

 ....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 HTCRH Q:BUDQUIT  W !,BUDRACE,!

 W !,"Sub-Total ",BUDRACE,":  ",BUDSTOT,!

 Q

HTCRH ;

 G:'BUDGPG HTCRH1

 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

HTCRH1 ;

 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 B, HTN w/Controlled BP by Race",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 of patients age 18 and older who have had two medical visits"

 .W !,"during the report period, who were diagnosed with hypertension before"

 .W !,"June 30 of the report period, and have controlled blood pressure"

 .W !,"(BP <140/90 mm Hg)."

 .W !,"Age is calculated as of December 31."

 .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",?55,"RACE*"

 W !?5,"LAST BP VALUE OR CD & DATE"

 W !?5,"LAST HTN DATE",?19,"DX OR SRV CD",?35,"PROV TYPE",?45,"SRV CAT",?53,"CLINIC",?65,"LOCATION"

 W !,$TR($J("",80)," ","-"),!

 S BUDP=1

 Q

 ;

HTUR ;EP

 W:$D(IOF) @IOF

 W !,$$CTR($$LOC,80)

 W !,$$CTR("UDS 2008",80)

 W !!,"All Hypertension Patients w/Uncontrolled BP by Race (Table 7)",!

 D GENI

 D PAUSE

 W !!,"This report provides a list by race of patients age 18 and older who"

 W !,"have had two medical visits during the report period, were diagnosed"

 W !,"with hypertension before June 30 of the report period, and who do not have"

 W !,"controlled blood pressure (<140/90 mm HG) during the report period."

 W !

 Q

HTURL ;EP

 S BUDP=0,BUDQUIT=0,BUDTOT=0

 D HTURH Q:BUDQUIT

 I '$D(^XTMP("BUD8RP7",BUDJ,BUDH,"HTUR")) W !!,"No patients to report." Q

 D HTURL1

 I $Y>(IOSL-3) D HTURH G:BUDQUIT HTURLX

 W !!,"TOTAL HTN PATIENTS 18+ W/UNCONTROLLED BP BY RACE: ",BUDTOT,!

HTURLX ;

 Q

HTURL1 ;

 I $Y>(IOSL-7) D HTURH Q:BUDQUIT

 S BUDTOT=0

 S BUDRACE="" F  S BUDRACE=$O(^XTMP("BUD8RP7",BUDJ,BUDH,"HTUR",BUDRACE)) Q:BUDRACE=""!(BUDQUIT)  D HTURL2

 Q

HTURL2 ;

 S BUDSTOT=0

 W !,BUDRACE

 S BUDNAME="" F  S BUDNAME=$O(^XTMP("BUD8RP7",BUDJ,BUDH,"HTUR",BUDRACE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT)  D

 .S BUDCOM="" F  S BUDCOM=$O(^XTMP("BUD8RP7",BUDJ,BUDH,"HTUR",BUDRACE,BUDNAME,BUDCOM)) Q:BUDCOM=""!(BUDQUIT)  D

 ..S DFN=0 F  S DFN=$O(^XTMP("BUD8RP7",BUDJ,BUDH,"HTUR",BUDRACE,BUDNAME,BUDCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT)  D

 ...I $Y>(IOSL-3) D HTURH Q:BUDQUIT  W !,BUDRACE,!

 ...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))

 ...W ?36,$E(BUDCOM,1,10),?47,$P(^DPT(DFN,0),U,2),?51,$$AGE^AUPNPAT(DFN,BUDED),?55,$P($$RACE^BUD8RPTC(DFN),U,3)_"-"_$P($$RACE^BUD8RPTC(DFN),U,4),!

 ...S BUDTOT=BUDTOT+1,BUDSTOT=BUDSTOT+1

 ...S BUDALL=^XTMP("BUD8RP7",BUDJ,BUDH,"HTUR",BUDRACE,BUDNAME,BUDCOM,DFN)

 ...W ?5,$P(BUDALL,U,2),!

 ...S BUDPPV=$P(BUDALL,"^",1)

 ...F BUDX=1:1 S BUDV=$P(BUDPPV,U,BUDX) Q:BUDV=""!(BUDQUIT)  D

 ....I $Y>(IOSL-3) D HTURH Q:BUDQUIT  W !,BUDRACE,!

 ....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 HTURH Q:BUDQUIT  W !,BUDRACE,!

 W !,"Sub-Total ",BUDRACE,":  ",BUDSTOT,!

 Q

HTURH ;

 G:'BUDGPG HTURH1

 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

HTURH1 ;

 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 B, HTN w/Uncontrolled BP by Race",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 of patients age 18 and older who have had two medical visits"

 .W !,"during the report period, who were diagnosed with hypertension before"

 .W !,"June 30 of the report period, and do not have controlled blood pressure"

 .W !,"(BP <140/90 mm Hg)."

 .W !,"Age is calculated as of December 31."

 .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",?55,"RACE*"

 W !?5,"LAST BP VALUE & DATE"

 W !?5,"LAST HTN DATE",?19,"DX OR SRV CD",?35,"PROV TYPE",?45,"SRV CAT",?53,"CLINIC",?65,"LOCATION"

 W !,$TR($J("",80)," ","-"),!

 S BUDP=1

 Q

 ;

BUD8RP7J  ; 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        WRITE !,"NOTE: Patient lists may be hundreds of pages long, depending on the size of your"

 +2        WRITE !,"patient population.  It is recommended that you run these reports at night and"

 +3        WRITE !,"print to an electronic file, not directly to a printer.",!

 +4        KILL DIR

           SET DIR(0)="E"

           SET DIR("A")="Press Enter to Continue"

           DO ^DIR

           KILL DIR

 +5        WRITE !!,"This Patient List option documents the individual patients and encounters"

 +6        WRITE !,"(visits) that are counted and summarized on each Table report (main menu"

 +7        WRITE !,"option REP).  The summary Table report is included at the beginning of each"

 +8        WRITE !,"List report."

 +9        WRITE !,"UDS searches your database to find all visits (encounters) and related patients"

 +10       WRITE !,"during the time period selected. Based on the UDS definition, to be counted"

 +11       WRITE !,"as a patient, the patient must have had at least one visit meeting the "

 +12       WRITE !,"following criteria:"

 +13       WRITE !?4,"- must be to a location specified in your visit location setup"

 +14       WRITE !?4,"- must be to Service Category Ambulatory (A), Hospitalization (H), Day"

 +15       WRITE !?6,"Surgery (S), Observation (O), Nursing home visit (R), "

 +16       WRITE !?6,"or In-Hospital (I) visit"

 +17       WRITE !?4,"- must NOT have an excluded clinic code (see User Manual for a list)"

 +18       WRITE !?4,"- must have a primary provider and a coded purpose of visit"

 +19       WRITE !

 +20       QUIT 

 +21      ;

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       ;

HTR       ;EP

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        WRITE !,$$CTR($$LOC,80)

 +3        WRITE !,$$CTR("UDS 2008",80)

 +4        WRITE !!,"All Hypertension Patients by Race (Table 7)",!

 +5        DO GENI

 +6        DO PAUSE

 +7        WRITE !!,"This report provides a list by race of patients age 18 and older who"

 +8        WRITE !,"have had two medical visits during the report period and were diagnosed"

 +9        WRITE !,"with hypertension before June 30 of the report period."

 +10       WRITE !

 +11       QUIT 

HTRL      ;EP

 +1        SET BUDP=0

           SET BUDQUIT=0

           SET BUDTOT=0

 +2        DO HTRH

           IF BUDQUIT

               QUIT 

 +3        IF '$DATA(^XTMP("BUD8RP7",BUDJ,BUDH,"HTR"))

               WRITE !!,"No patients to report."

               QUIT 

 +4        DO HTRL1

 +5        IF $Y>(IOSL-3)

               DO HTRH

               IF BUDQUIT

                   GOTO HTRLX

 +6        WRITE !!,"TOTAL HTN PATIENTS 18+ BY RACE: ",BUDTOT,!

HTRLX     ;

 +1        QUIT 

HTRL1     ;

 +1        IF $Y>(IOSL-7)

               DO HTRH

               IF BUDQUIT

                   QUIT 

 +2        SET BUDTOT=0

 +3        SET BUDRACE=""

           FOR 

               SET BUDRACE=$ORDER(^XTMP("BUD8RP7",BUDJ,BUDH,"HTR",BUDRACE))

               IF BUDRACE=""!(BUDQUIT)

                   QUIT 

               DO HTRL2

 +4        QUIT 

HTRL2     ;

 +1        SET BUDSTOT=0

 +2        WRITE !,BUDRACE

 +3        SET BUDCOM=""

           FOR 

               SET BUDCOM=$ORDER(^XTMP("BUD8RP7",BUDJ,BUDH,"HTR",BUDRACE,BUDCOM))

               IF BUDCOM=""!(BUDQUIT)

                   QUIT 

               Begin DoDot:1

 +4                SET BUDA=""

                   FOR 

                       SET BUDA=$ORDER(^XTMP("BUD8RP7",BUDJ,BUDH,"HTR",BUDRACE,BUDCOM,BUDA))

                       IF BUDA=""!(BUDQUIT)

                           QUIT 

                       Begin DoDot:2

 +5                        SET BUDNAME=""

                           FOR 

                               SET BUDNAME=$ORDER(^XTMP("BUD8RP7",BUDJ,BUDH,"HTR",BUDRACE,BUDCOM,BUDA,BUDNAME))

                               IF BUDNAME=""!(BUDQUIT)

                                   QUIT 

                               Begin DoDot:3

 +6                                SET DFN=0

                                   FOR 

                                       SET DFN=$ORDER(^XTMP("BUD8RP7",BUDJ,BUDH,"HTR",BUDRACE,BUDCOM,BUDA,BUDNAME,DFN))

                                       IF DFN'=+DFN!(BUDQUIT)

                                           QUIT 

                                       Begin DoDot:4

 +7                                        IF $Y>(IOSL-3)

                                               DO HTRH

                                               IF BUDQUIT

                                                   QUIT 

                                               WRITE !,BUDRACE

 +8                                        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))

 +9                                        WRITE ?36,$EXTRACT(BUDCOM,1,10),?47,$PIECE(^DPT(DFN,0),U,2),?51,BUDA,?55,$PIECE($$RACE^BUD8RPTC(DFN),U,3)_"-"_$PIECE($$RACE^BUD8RPTC(DFN),U,4),!

 +10                                       SET BUDTOT=BUDTOT+1

                                           SET BUDSTOT=BUDSTOT+1

 +11                                       SET BUDALL=^XTMP("BUD8RP7",BUDJ,BUDH,"HTR",BUDRACE,BUDCOM,BUDA,BUDNAME,DFN)

 +12                                       SET BUDPPV=$PIECE(BUDALL,"#",1)

 +13                                       FOR BUDX=1:1

                                               SET BUDV=$PIECE(BUDPPV,U,BUDX)

                                               IF BUDV=""!(BUDQUIT)

                                                   QUIT 

                                               Begin DoDot:5

 +14                                               IF $Y>(IOSL-3)

                                                       DO HTRH

                                                       IF BUDQUIT

                                                           QUIT 

                                                       WRITE !,BUDRACE

 +15                                               IF $EXTRACT(BUDV)="P"

                                                       WRITE ?5,BUDV,!

                                                       QUIT 

 +16                                               SET V=$PIECE(BUDV,"|")

                                                   SET C=$PIECE(BUDV,"|",2)

 +17                                               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

 +18       IF $Y>(IOSL-4)

               DO HTRH

               IF BUDQUIT

                   QUIT 

               WRITE !,BUDRACE

 +19       WRITE !,"Sub-Total ",BUDRACE,":  ",BUDSTOT,!

 +20       QUIT 

HTRH      ;

 +1        IF 'BUDGPG

               GOTO HTRH1

 +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 

HTRH1     ;

 +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 B, HTN Patients by Race",80),!

 +6        WRITE $$CTR($PIECE(^DIC(4,BUDSITE,0),U),80),!

 +7        SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)

           WRITE $$CTR(X,80),!

 +8        WRITE $TRANSLATE($JUSTIFY("",80)," ","-")

 +9        IF BUDP=0

               Begin DoDot:1

 +10               WRITE !,"List by race of patients age 18 and older who have had two medical visits"

 +11               WRITE !,"during the report period and were diagnosed with hypertension before"

 +12               WRITE !,"June 30 of the report period."

 +13               WRITE !,"Age is calculated as of December 31."

 +14               WRITE !," *R- denotes the value was obtained from the Race field"

 +15               WRITE !,"  C- denotes the value was obtained from the Classification/Beneficiary field"

 +16               WRITE !

               End DoDot:1

 +17       WRITE !?2,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?47,"SEX",?51,"AGE",?55,"RACE*"

 +18       WRITE !?5,"LAST HTN DATE",?19,"DX OR SRV CD",?35,"PROV TYPE",?45,"SRV CAT",?53,"CLINIC",?65,"LOCATION"

 +19       WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-"),!

 +20       SET BUDP=1

 +21       QUIT 

 +22      ;

HTCR      ;EP

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        WRITE !,$$CTR($$LOC,80)

 +3        WRITE !,$$CTR("UDS 2008",80)

 +4        WRITE !!,"All Hypertension Patients w/Controlled BP by Race (Table 7)",!

 +5        DO GENI

 +6        DO PAUSE

 +7        WRITE !!,"This report provides a list by race of patients age 18 and older who"

 +8        WRITE !,"have had two medical visits during the report period, were diagnosed"

 +9        WRITE !,"with hypertension before June 30 of the report period, and who have"

 +10       WRITE !,"controlled blood pressure (<140/90 mm HG) during the report period."

 +11       WRITE !

 +12       QUIT 

HTCRL     ;EP

 +1        SET BUDP=0

           SET BUDQUIT=0

           SET BUDTOT=0

 +2        DO HTCRH

           IF BUDQUIT

               QUIT 

 +3        IF '$DATA(^XTMP("BUD8RP7",BUDJ,BUDH,"HTCR"))

               WRITE !!,"No patients to report."

               QUIT 

 +4        DO HTCRL1

 +5        IF $Y>(IOSL-3)

               DO HTCRH

               IF BUDQUIT

                   GOTO HTCRLX

 +6        WRITE !!,"TOTAL HTN PATIENTS 18+ W/CONTROLLED BP BY RACE: ",BUDTOT,!

HTCRLX    ;

 +1        QUIT 

HTCRL1    ;

 +1        IF $Y>(IOSL-7)

               DO HTCRH

               IF BUDQUIT

                   QUIT 

 +2        SET BUDTOT=0

 +3        SET BUDRACE=""

           FOR 

               SET BUDRACE=$ORDER(^XTMP("BUD8RP7",BUDJ,BUDH,"HTCR",BUDRACE))

               IF BUDRACE=""!(BUDQUIT)

                   QUIT 

               DO HTCRL2

 +4        QUIT 

HTCRL2    ;

 +1        SET BUDSTOT=0

 +2        WRITE !,BUDRACE

 +3        SET BUDNAME=""

           FOR 

               SET BUDNAME=$ORDER(^XTMP("BUD8RP7",BUDJ,BUDH,"HTCR",BUDRACE,BUDNAME))

               IF BUDNAME=""!(BUDQUIT)

                   QUIT 

               Begin DoDot:1

 +4                SET BUDCOM=""

                   FOR 

                       SET BUDCOM=$ORDER(^XTMP("BUD8RP7",BUDJ,BUDH,"HTCR",BUDRACE,BUDNAME,BUDCOM))

                       IF BUDCOM=""!(BUDQUIT)

                           QUIT 

                       Begin DoDot:2

 +5                        SET DFN=0

                           FOR 

                               SET DFN=$ORDER(^XTMP("BUD8RP7",BUDJ,BUDH,"HTCR",BUDRACE,BUDNAME,BUDCOM,DFN))

                               IF DFN'=+DFN!(BUDQUIT)

                                   QUIT 

                               Begin DoDot:3

 +6                                IF $Y>(IOSL-3)

                                       DO HTCRH

                                       IF BUDQUIT

                                           QUIT 

                                       WRITE !,BUDRACE,!

 +7                                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))

 +8                                WRITE ?36,$EXTRACT(BUDCOM,1,10),?47,$PIECE(^DPT(DFN,0),U,2),?51,$$AGE^AUPNPAT(DFN,BUDED),?55,$EXTRACT(BUDRACE,1,24),!

 +9                                SET BUDTOT=BUDTOT+1

                                   SET BUDSTOT=BUDSTOT+1

 +10                               SET BUDALL=^XTMP("BUD8RP7",BUDJ,BUDH,"HTCR",BUDRACE,BUDNAME,BUDCOM,DFN)

 +11                               WRITE ?5,$PIECE(BUDALL,U,2),!

 +12                               SET BUDPPV=$PIECE(BUDALL,"^",1)

 +13                               FOR BUDX=1:1

                                       SET BUDV=$PIECE(BUDPPV,U,BUDX)

                                       IF BUDV=""!(BUDQUIT)

                                           QUIT 

                                       Begin DoDot:4

 +14                                       IF $Y>(IOSL-3)

                                               DO HTCRH

                                               IF BUDQUIT

                                                   QUIT 

                                               WRITE !,BUDRACE,!

 +15                                       IF $EXTRACT(BUDV)="P"

                                               WRITE ?5,BUDV,!

                                               QUIT 

 +16                                       SET V=$PIECE(BUDV,"|")

                                           SET C=$PIECE(BUDV,"|",2)

 +17                                       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:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +18       IF $Y>(IOSL-4)

               DO HTCRH

               IF BUDQUIT

                   QUIT 

               WRITE !,BUDRACE,!

 +19       WRITE !,"Sub-Total ",BUDRACE,":  ",BUDSTOT,!