BUD1RP7K.m

BUD1RP7K ; 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 visits"

 W !,"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 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), Telemedicine (M), 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")

 ;----------

 ;

HTE ;EP

 W:$D(IOF) @IOF

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

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

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

 D GENI

 D PAUSE

 W !!,"This report provides a list by ethnicity 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

HTEL ;EP

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

 D HTEH Q:BUDQUIT

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

 D HTEL1

 I $Y>(IOSL-3) D HTEH G:BUDQUIT HTELX

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

HTELX ;

 Q

HTEL1 ;

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

 S BUDTOT=0

 S BUDRACE="" F  S BUDRACE=$O(^XTMP("BUD1RP7",BUDJ,BUDH,"HTE",BUDRACE)) Q:BUDRACE=""!(BUDQUIT)  D HTEL2

 Q

HTEL2 ;

 S BUDSTOT=0

 W !,BUDRACE

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

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

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

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

 ....I $Y>(IOSL-3) D HTEH 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($$HISP^BUD1RPTC(DFN),U,2)_"-"_$P($$HISP^BUD1RPTC(DFN),U,3),!

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

 ....S BUDALL=^XTMP("BUD1RP7",BUDJ,BUDH,"HTE",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 HTEH 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 HTEH Q:BUDQUIT  W !,BUDRACE,!

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

 Q

HTEH ;

 G:'BUDGPG HTEH1

 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

HTEH1 ;

 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 Ethnicity",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 ethnicity 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 !,"* 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",?55,"ETHNICITY*"

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

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

 S BUDP=1

 Q

 ;

HTCE ;EP

 W:$D(IOF) @IOF

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

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

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

 D GENI

 D PAUSE

 W !!,"This report provides a list by ethnicity 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

HTCEL ;EP

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

 D HTCEH Q:BUDQUIT

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

 D HTCEL1

 I $Y>(IOSL-3) D HTCEH G:BUDQUIT HTCELX

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

HTCELX ;

 Q

HTCEL1 ;

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

 S BUDTOT=0

 S BUDRACE="" F  S BUDRACE=$O(^XTMP("BUD1RP7",BUDJ,BUDH,"HTCE",BUDRACE)) Q:BUDRACE=""!(BUDQUIT)  D HTCEL2

 Q

HTCEL2 ;

 S BUDSTOT=0

 W !,BUDRACE

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

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

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

 ...I $Y>(IOSL-3) D HTCEH 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($$HISP^BUD1RPTC(DFN),U,2)_"-"_$P($$HISP^BUD1RPTC(DFN),U,3),!

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

 ...S BUDALL=^XTMP("BUD1RP7",BUDJ,BUDH,"HTCE",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 HTCEH 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 HTCEH Q:BUDQUIT  W !,BUDRACE,!

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

 Q

HTCEH ;

 G:'BUDGPG HTCEH1

 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

HTCEH1 ;

 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 Ethnicity",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 ethnicity 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 !,"* 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",?55,"ETHNICITY*"

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

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

 S BUDP=1

 Q

 ;

HTUE ;EP

 W:$D(IOF) @IOF

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

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

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

 D GENI

 D PAUSE

 W !!,"This report provides a list by ethnicity 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

HTUEL ;EP

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

 D HTUEH Q:BUDQUIT

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

 D HTUEL1

 I $Y>(IOSL-3) D HTUEH G:BUDQUIT HTUELX

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

HTUELX ;

 Q

HTUEL1 ;

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

 S BUDTOT=0

 S BUDRACE="" F  S BUDRACE=$O(^XTMP("BUD1RP7",BUDJ,BUDH,"HTUE",BUDRACE)) Q:BUDRACE=""!(BUDQUIT)  D HTUEL2

 Q

HTUEL2 ;

 S BUDSTOT=0

 W !,BUDRACE

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

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

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

 ...I $Y>(IOSL-3) D HTUEH 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($$HISP^BUD1RPTC(DFN),U,2)_"-"_$P($$HISP^BUD1RPTC(DFN),U,3),!

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

 ...S BUDALL=^XTMP("BUD1RP7",BUDJ,BUDH,"HTUE",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 HTUEH 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 HTUEH Q:BUDQUIT  W !,BUDRACE,!

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

 Q

HTUEH ;

 G:'BUDGPG HTUEH1

 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

HTUEH1 ;

 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 Ethnicity",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 ethnicity 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 !,"* 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",?55,"ETHNICITY*"

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

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

 S BUDP=1

 Q

 ;

BUD1RP7K  ; 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 visits"

 +6        WRITE !,"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 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), Telemedicine (M), 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       ;

HTE       ;EP

 +1        IF $DATA(IOF)

               WRITE @IOF

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

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

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

 +5        DO GENI

 +6        DO PAUSE

 +7        WRITE !!,"This report provides a list by ethnicity 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 

HTEL      ;EP

 +1        SET BUDP=0

           SET BUDQUIT=0

           SET BUDTOT=0

 +2        DO HTEH

           IF BUDQUIT

               QUIT 

 +3        IF '$DATA(^XTMP("BUD1RP7",BUDJ,BUDH,"HTE"))

               WRITE !!,"No patients to report."

               QUIT 

 +4        DO HTEL1

 +5        IF $Y>(IOSL-3)

               DO HTEH

               IF BUDQUIT

                   GOTO HTELX

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

HTELX     ;

 +1        QUIT 

HTEL1     ;

 +1        IF $Y>(IOSL-7)

               DO HTEH

               IF BUDQUIT

                   QUIT 

 +2        SET BUDTOT=0

 +3        SET BUDRACE=""

           FOR 

               SET BUDRACE=$ORDER(^XTMP("BUD1RP7",BUDJ,BUDH,"HTE",BUDRACE))

               IF BUDRACE=""!(BUDQUIT)

                   QUIT 

               DO HTEL2

 +4        QUIT 

HTEL2     ;

 +1        SET BUDSTOT=0

 +2        WRITE !,BUDRACE

 +3        SET BUDCOM=""

           FOR 

               SET BUDCOM=$ORDER(^XTMP("BUD1RP7",BUDJ,BUDH,"HTE",BUDRACE,BUDCOM))

               IF BUDCOM=""!(BUDQUIT)

                   QUIT 

               Begin DoDot:1

 +4                SET BUDA=""

                   FOR 

                       SET BUDA=$ORDER(^XTMP("BUD1RP7",BUDJ,BUDH,"HTE",BUDRACE,BUDCOM,BUDA))

                       IF BUDA=""!(BUDQUIT)

                           QUIT 

                       Begin DoDot:2

 +5                        SET BUDNAME=""

                           FOR 

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

                               IF BUDNAME=""!(BUDQUIT)

                                   QUIT 

                               Begin DoDot:3

 +6                                SET DFN=0

                                   FOR 

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

                                       IF DFN'=+DFN!(BUDQUIT)

                                           QUIT 

                                       Begin DoDot:4

 +7                                        IF $Y>(IOSL-3)

                                               DO HTEH

                                               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($$HISP^BUD1RPTC(DFN),U,2)_"-"_$PIECE($$HISP^BUD1RPTC(DFN),U,3),!

 +10                                       SET BUDTOT=BUDTOT+1

                                           SET BUDSTOT=BUDSTOT+1

 +11                                       SET BUDALL=^XTMP("BUD1RP7",BUDJ,BUDH,"HTE",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 HTEH

                                                       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 HTEH

               IF BUDQUIT

                   QUIT 

               WRITE !,BUDRACE,!

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

 +20       QUIT 

HTEH      ;

 +1        IF 'BUDGPG

               GOTO HTEH1

 +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 

HTEH1     ;

 +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 Ethnicity",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 ethnicity 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 !,"* E- denotes the value was obtained from the Ethnicity field"

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

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

 +17               WRITE !

               End DoDot:1

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

 +19       WRITE !?5,"VISIT DATE",?19,"DX OR SVC CD",?35,"PROV TYPE",?45,"SVC CAT",?53,"CLINIC",?65,"LOCATION"

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

 +21       SET BUDP=1

 +22       QUIT 

 +23      ;

HTCE      ;EP

 +1        IF $DATA(IOF)

               WRITE @IOF

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

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

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

 +5        DO GENI

 +6        DO PAUSE

 +7        WRITE !!,"This report provides a list by ethnicity 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 

HTCEL     ;EP

 +1        SET BUDP=0

           SET BUDQUIT=0

           SET BUDTOT=0

 +2        DO HTCEH

           IF BUDQUIT

               QUIT 

 +3        IF '$DATA(^XTMP("BUD1RP7",BUDJ,BUDH,"HTCE"))

               WRITE !!,"No patients to report."

               QUIT 

 +4        DO HTCEL1

 +5        IF $Y>(IOSL-3)

               DO HTCEH

               IF BUDQUIT

                   GOTO HTCELX

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

HTCELX    ;

 +1        QUIT 

HTCEL1    ;

 +1        IF $Y>(IOSL-7)

               DO HTCEH

               IF BUDQUIT

                   QUIT 

 +2        SET BUDTOT=0

 +3        SET BUDRACE=""

           FOR 

               SET BUDRACE=$ORDER(^XTMP("BUD1RP7",BUDJ,BUDH,"HTCE",BUDRACE))

               IF BUDRACE=""!(BUDQUIT)

                   QUIT 

               DO HTCEL2

 +4        QUIT 

HTCEL2    ;

 +1        SET BUDSTOT=0

 +2        WRITE !,BUDRACE

 +3        SET BUDNAME=""

           FOR 

               SET BUDNAME=$ORDER(^XTMP("BUD1RP7",BUDJ,BUDH,"HTCE",BUDRACE,BUDNAME))

               IF BUDNAME=""!(BUDQUIT)

                   QUIT 

               Begin DoDot:1

 +4                SET BUDCOM=""

                   FOR 

                       SET BUDCOM=$ORDER(^XTMP("BUD1RP7",BUDJ,BUDH,"HTCE",BUDRACE,BUDNAME,BUDCOM))

                       IF BUDCOM=""!(BUDQUIT)

                           QUIT 

                       Begin DoDot:2

 +5                        SET DFN=0

                           FOR 

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

                               IF DFN'=+DFN!(BUDQUIT)

                                   QUIT 

                               Begin DoDot:3

 +6                                IF $Y>(IOSL-3)

                                       DO HTCEH

                                       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,$PIECE($$HISP^BUD1RPTC(DFN),U,2)_"-"_$PIECE($$HISP^BUD1RPTC(DFN),U,3),!

 +9                                SET BUDTOT=BUDTOT+1

                                   SET BUDSTOT=BUDSTOT+1

 +10                               SET BUDALL=^XTMP("BUD1RP7",BUDJ,BUDH,"HTCE",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 HTCEH

                                               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