BUDBRP6A.m

BUDBRP6A ; IHS/CMI/LAB - HIV/DEP ; 

 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50

 ;

 ;

HIVLIST1 ;EP

 D EOJ

 S BUDHIV1L=1

 D HIV1

 G EN1^BUDBRP6B

HIVLIST2 ;EP

 D EOJ

 S BUDHIV2L=1

 D HIV2

 G EN1^BUDBRP6B

PAUSE ;

 K DIR S DIR(0)="E",DIR("A")="PRESS ENTER" KILL DA D ^DIR KILL DIR

 Q

GENI ;EP

 D GENI^BUDBRP6I

 Q

 ;

EOJ ;

 D EN^XBVK("BUD")

 Q

CTR(X,Y) ;

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

LOC() ;

 Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

HIV1 ;EP

 W:$D(IOF) @IOF

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

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

 W !!,"Newly Idenitifed HIV Cases with Timely Follow-Up (Table 6B)",!

 D GENI

 D PAUSE

 W !!,"This report provides a list of all patients whose first ever HIV"

 W !,"diagnosis occurred between October 1 of the prior year through"

 W !,"September 30th of the current report year and had a medical visit for"

 W !,"HIV care within 90 days of the first-ever HIV diagnosis, and had at "

 W !,"least one medical visit during the report year."

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

 W !

 Q

HIV1L ;EP

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

 D HIV1H Q:BUDQUIT

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

 D HIV1L1

 I $Y>(IOSL-3) D HIV1H Q:BUDQUIT

 W !,"TOTAL PATIENTS WITH FIRST HIV DX & TIMELY FOLLOW-UP:  ",BUDTOT,!

 Q

HIV1L1 ;

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

 S BUDAGE="" F  S BUDAGE=$O(^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV1",BUDAGE)) Q:BUDAGE=""!(BUDQUIT)  D

 .S BUDNAME="" F  S BUDNAME=$O(^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV1",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT)  D

 ..S BUDCOM="" F  S BUDCOM=$O(^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV1",BUDAGE,BUDNAME,BUDCOM)) Q:BUDCOM=""!(BUDQUIT)  D

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

 ....I $Y>(IOSL-3) D HIV1H Q:BUDQUIT

 ....W !,$E($P(^DPT(DFN,0),U,1),1,25),?29,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$E(BUDCOM,1,25),?70,$P(^DPT(DFN,0),U,2),?75,BUDAGE,!

 ....S BUDTOT=BUDTOT+1

 ....S BUDALL=^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV1",BUDAGE,BUDNAME,BUDCOM,DFN)

 ....W ?5,$P(BUDALL,"|",1),?35,$S($P(BUDALL,"|",3)]"":$P(BUDALL,"|",3),1:"None"),?46,$P(BUDALL,"|",2)

HIV1H ;

 G:'BUDGPG HIV1H1

 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

HIV1H1 ;

 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 6B, Section L,",80),!,$$CTR("Newly Identified HIV Cases with Timely Follow-Up",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),!

 S X="Population:  "_$S($G(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"") W $$CTR(X,80),!

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

 I BUDP=0 D

 .W !!,"This report provides a list of all patients whose first ever HIV"

 .W !,"diagnosis occurred between October 1 of the prior year through"

 .W !,"September 30th of the current report year and had a medical visit for"

 .W !,"HIV care within 90 days of the first-ever HIV diagnosis, and had at "

 .W !,"least one medical visit during the report year."

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

 W !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"

 W !?5,"First HIV DX: Date",?35,"Date of Onset",?50,"HIV Follow-up: Date"

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

 S BUDP=1

 Q

 ;----------

HIV2 ;EP

 W:$D(IOF) @IOF

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

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

 W !!,"Newly Idenitifed HIV Cases with Timely Follow-Up (Table 6B)",!

 D GENI

 D PAUSE

 W !!,"This report provides a list of all patients whose first ever HIV"

 W !,"diagnosis occurred between October 1 of the prior year through"

 W !,"September 30th of the current report year and did not have a medical visit"

 W !,"for HIV care within 90 days of the first-ever HIV diagnosis, and had at "

 W !,"least one medical visit during the report year."

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

 W !

 Q

HIV2L ;EP

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

 D HIV2H Q:BUDQUIT

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

 D HIV2L1

 I $Y>(IOSL-3) D HIV2H Q:BUDQUIT

 W !,"TOTAL PATIENTS WITH FIRST HIV DX & TIMELY FOLLOW-UP:  ",BUDTOT,!

 Q

HIV2L1 ;

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

 S BUDAGE="" F  S BUDAGE=$O(^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV2",BUDAGE)) Q:BUDAGE=""!(BUDQUIT)  D

 .S BUDNAME="" F  S BUDNAME=$O(^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV2",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT)  D

 ..S BUDCOM="" F  S BUDCOM=$O(^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV2",BUDAGE,BUDNAME,BUDCOM)) Q:BUDCOM=""!(BUDQUIT)  D

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

 ....I $Y>(IOSL-3) D HIV2H Q:BUDQUIT

 ....W !,$E($P(^DPT(DFN,0),U,1),1,25),?29,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$E(BUDCOM,1,25),?70,$P(^DPT(DFN,0),U,2),?75,BUDAGE,!

 ....S BUDTOT=BUDTOT+1

 ....S BUDALL=^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV2",BUDAGE,BUDNAME,BUDCOM,DFN)

 ....W ?5,$P(BUDALL,"|",1),?35,$S($P(BUDALL,"|",3)]"":$P(BUDALL,"|",3),1:"None"),?46,$P(BUDALL,"|",2)

HIV2H ;

 G:'BUDGPG HIV2H1

 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

HIV2H1 ;

 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 6B, Section L,",80),!,$$CTR("Newly Identified HIV Cases without Timely Follow-Up",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),!

 S X="Population:  "_$S($G(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"") W $$CTR(X,80),!

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

 I BUDP=0 D

 .W !!,"This report provides a list of all patients whose first ever HIV"

 .W !,"diagnosis occurred between October 1 of the prior year through"

 .W !,"September 30th of the current report year and did not have a medical visit"

 .W !,"for HIV care within 90 days of the first-ever HIV diagnosis, and had at "

 .W !,"least one medical visit during the report year."

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

 W !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"

 W !?5,"First HIV DX: Date",?35,"Date of Onset",?50,"HIV Follow-up: Date"

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

 S BUDP=1

 Q

DEPLIST1 ;EP

 D EOJ

 S BUDDEP1L=1

 D DEP1

 G EN1^BUDBRP6B

DEPLIST2 ;EP

 D EOJ

 S BUDDEP2L=1

 D DEP2

 G EN1^BUDBRP6B

DEP1 ;EP

 W:$D(IOF) @IOF

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

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

 W !!,"All Patients 12+ w/Depression Scrn & if Positive a Follow-up Plan (Table 6B)",!

 D GENI

 D PAUSE

 W !!,"This report provides a list of all patients 12 years and older who were "

 W !,"screened for depression with a standardized tool during the report year"

 W !,"and had a follow-up plan documented if screened positive, and had at"

 W !,"least one medical visit during the report year."

 W !

 Q

DEP1L ;EP

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

 D DEP1H Q:BUDQUIT

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

 D DEP1L1

 I $Y>(IOSL-3) D DEP1H Q:BUDQUIT

 W !,"TOTAL PATIENTS WITH DEP SCRN & IF POSITIVE, FOLLOW-UP:  ",BUDTOT,!

 Q

DEP1L1 ;

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

 S BUDAGE="" F  S BUDAGE=$O(^XTMP("BUDBRP6B",BUDJ,BUDH,"DEP1",BUDAGE)) Q:BUDAGE=""!(BUDQUIT)  D

 .S BUDNAME="" F  S BUDNAME=$O(^XTMP("BUDBRP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT)  D

 ..S BUDCOM="" F  S BUDCOM=$O(^XTMP("BUDBRP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME,BUDCOM)) Q:BUDCOM=""!(BUDQUIT)  D

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

 ....I $Y>(IOSL-3) D DEP1H Q:BUDQUIT

 ....W !,$E($P(^DPT(DFN,0),U,1),1,25),?29,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$E(BUDCOM,1,25),?70,$P(^DPT(DFN,0),U,2),?75,BUDAGE,!

 ....S BUDTOT=BUDTOT+1

 ....S BUDALL=^XTMP("BUDBRP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME,BUDCOM,DFN)

 ....S BUD1=$P(BUDALL,"|",1),BUD2=$P(BUDALL,"|",2)

 ....I BUD1]"" W ?5,$P(BUD1,U,2),": ",$P(BUD1,U,3),": ",$$FMTE^XLFDT($P(BUD1,U,1),5)

 ....W ?35,"Follow-up: " I BUD2]"" W $P(BUD2,U,2),": ",$$FMTE^XLFDT($P(BUD2,U,1),5)

DEP1H ;

 G:'BUDGPG DEP1H1

 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

DEP1H1 ;

 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 6B, Section M,",80),!,$$CTR("Patients Screened for Depression and Followed Up if Appropriate",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),!

 S X="Population:  "_$S($G(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"") W $$CTR(X,80),!

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

 I BUDP=0 D

 .W !!,"This report provides a list of all patients 12 years and older who were "

 .W !,"screened for depression with a standardized tool during the report year and"

 .W !,"had a follow-up plan documented if screened positive, and had at least one"

 .W !,"medical visit during the report year. "

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

 W !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"

 W !?5,"Depression Scrn: Date/Result",?35,"Follow-up Plan: Date"

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

 S BUDP=1

 Q

DEP2 ;EP

 W:$D(IOF) @IOF

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

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

 W !!,"All Patients 12+ w/o Depression Scrn or w/o Follow-up (Table 6B)",!

 D GENI

 D PAUSE

 W !!,"This report provides a list of all patients 12 years and older not"

 W !,"screened for depression or who were screened for depression with a"

 W !,"standardized tool during the report year and does not have a follow-up"

 W !,"plan documented if screened positive, and had at least one medical visit"

 W !,"during the report year."

 W !

 Q

DEP2L ;EP

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

 D DEP2H Q:BUDQUIT

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

 D DEP2L1

 I $Y>(IOSL-3) D DEP2H Q:BUDQUIT

 W !,"TOTAL PATIENTS W/O DEP SCRN OR W/O FOLLOW-UP IF POSITIVE:  ",BUDTOT,!

 Q

DEP2L1 ;

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

 S BUDAGE="" F  S BUDAGE=$O(^XTMP("BUDBRP6B",BUDJ,BUDH,"DEP2",BUDAGE)) Q:BUDAGE=""!(BUDQUIT)  D

 .S BUDNAME="" F  S BUDNAME=$O(^XTMP("BUDBRP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT)  D

 ..S BUDCOM="" F  S BUDCOM=$O(^XTMP("BUDBRP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME,BUDCOM)) Q:BUDCOM=""!(BUDQUIT)  D

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

 ....I $Y>(IOSL-3) D DEP2H Q:BUDQUIT

 ....W !,$E($P(^DPT(DFN,0),U,1),1,25),?29,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$E(BUDCOM,1,25),?70,$P(^DPT(DFN,0),U,2),?75,BUDAGE,!

 ....S BUDTOT=BUDTOT+1

 ....S BUDALL=^XTMP("BUDBRP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME,BUDCOM,DFN)

 ....S BUD1=$P(BUDALL,"|",1),BUD2=$P(BUDALL,"|",2)

 ....I BUD1]"" W ?5,$P(BUD1,U,2),": ",$P(BUD1,U,3),": ",$$FMTE^XLFDT($P(BUD1,U,1),5)

 ....W ?35,"Follow-up: " I BUD2]"" W $P(BUD2,U,2),": ",$$FMTE^XLFDT($P(BUD2,U,1),5)

DEP2H ;

 G:'BUDGPG DEP2H1

 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

DEP2H1 ;

 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 6B, Section M,",80),!,$$CTR("Patients not Screened for Depression or w/o Follow-up",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),!

 S X="Population:  "_$S($G(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"") W $$CTR(X,80),!

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

 I BUDP=0 D

 .W !!,"This report provides a list of all patients 12 years and older not"

 .W !,"screened for depression or who were screened for depression with a"

 .W !,"standardized tool during the report year and does not have a follow-up"

 .W !,"plan documented if screened positive, and had at least one medical visit"

 .W !,"during the report year."

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

 W !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"

 W !?5,"Depression Scrn: Date/Result",?35,"Follow-up Plan: Date"

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

 S BUDP=1

 Q

BUDBRP6A  ; IHS/CMI/LAB - HIV/DEP ; 

 +1       ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50

 +2       ;

 +3       ;

HIVLIST1  ;EP

 +1        DO EOJ

 +2        SET BUDHIV1L=1

 +3        DO HIV1

 +4        GOTO EN1^BUDBRP6B

HIVLIST2  ;EP

 +1        DO EOJ

 +2        SET BUDHIV2L=1

 +3        DO HIV2

 +4        GOTO EN1^BUDBRP6B

PAUSE     ;

 +1        KILL DIR

           SET DIR(0)="E"

           SET DIR("A")="PRESS ENTER"

           KILL DA

           DO ^DIR

           KILL DIR

 +2        QUIT 

GENI      ;EP

 +1        DO GENI^BUDBRP6I

 +2        QUIT 

 +3       ;

EOJ       ;

 +1        DO EN^XBVK("BUD")

 +2        QUIT 

CTR(X,Y)  ;

 +1        QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X

LOC()     ;

 +1        QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

HIV1      ;EP

 +1        IF $DATA(IOF)

               WRITE @IOF

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

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

 +4        WRITE !!,"Newly Idenitifed HIV Cases with Timely Follow-Up (Table 6B)",!

 +5        DO GENI

 +6        DO PAUSE

 +7        WRITE !!,"This report provides a list of all patients whose first ever HIV"

 +8        WRITE !,"diagnosis occurred between October 1 of the prior year through"

 +9        WRITE !,"September 30th of the current report year and had a medical visit for"

 +10       WRITE !,"HIV care within 90 days of the first-ever HIV diagnosis, and had at "

 +11       WRITE !,"least one medical visit during the report year."

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

 +13       WRITE !

 +14       QUIT 

HIV1L     ;EP

 +1        SET BUDP=0

           SET BUDQUIT=0

           SET BUDTOT=0

 +2        DO HIV1H

           IF BUDQUIT

               QUIT 

 +3        IF '$DATA(^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV1"))

               WRITE !!,"No patients to report.",!

               QUIT 

 +4        DO HIV1L1

 +5        IF $Y>(IOSL-3)

               DO HIV1H

               IF BUDQUIT

                   QUIT 

 +6        WRITE !,"TOTAL PATIENTS WITH FIRST HIV DX & TIMELY FOLLOW-UP:  ",BUDTOT,!

 +7        QUIT 

HIV1L1    ;

 +1        IF $Y>(IOSL-7)

               DO HIV1H

               IF BUDQUIT

                   QUIT 

 +2        SET BUDAGE=""

           FOR 

               SET BUDAGE=$ORDER(^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV1",BUDAGE))

               IF BUDAGE=""!(BUDQUIT)

                   QUIT 

               Begin DoDot:1

 +3                SET BUDNAME=""

                   FOR 

                       SET BUDNAME=$ORDER(^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV1",BUDAGE,BUDNAME))

                       IF BUDNAME=""!(BUDQUIT)

                           QUIT 

                       Begin DoDot:2

 +4                        SET BUDCOM=""

                           FOR 

                               SET BUDCOM=$ORDER(^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV1",BUDAGE,BUDNAME,BUDCOM))

                               IF BUDCOM=""!(BUDQUIT)

                                   QUIT 

                               Begin DoDot:3

 +5                                SET DFN=0

                                   FOR 

                                       SET DFN=$ORDER(^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV1",BUDAGE,BUDNAME,BUDCOM,DFN))

                                       IF DFN'=+DFN!(BUDQUIT)

                                           QUIT 

                                       Begin DoDot:4

 +6                                        IF $Y>(IOSL-3)

                                               DO HIV1H

                                               IF BUDQUIT

                                                   QUIT 

 +7                                        WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U,1),1,25),?29,$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$EXTRACT(BUDCOM,1,25),?70,$PIECE(^DPT(DFN,0),U,2),?75,BUDAG

E,!

 +8                                        SET BUDTOT=BUDTOT+1

 +9                                        SET BUDALL=^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV1",BUDAGE,BUDNAME,BUDCOM,DFN)

 +10                                       WRITE ?5,$PIECE(BUDALL,"|",1),?35,$SELECT($PIECE(BUDALL,"|",3)]"":$PIECE(BUDALL,"|",3),1:"None"),?46,$PIECE(BUDALL,"|",2)

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

HIV1H     ;

 +1        IF 'BUDGPG

               GOTO HIV1H1

 +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 

HIV1H1    ;

 +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 6B, Section L,",80),!,$$CTR("Newly Identified HIV Cases with Timely Follow-Up",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        SET X="Population:  "_$SELECT($GET(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"")

           WRITE $$CTR(X,80),!

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

 +10       IF BUDP=0

               Begin DoDot:1

 +11               WRITE !!,"This report provides a list of all patients whose first ever HIV"

 +12               WRITE !,"diagnosis occurred between October 1 of the prior year through"

 +13               WRITE !,"September 30th of the current report year and had a medical visit for"

 +14               WRITE !,"HIV care within 90 days of the first-ever HIV diagnosis, and had at "

 +15               WRITE !,"least one medical visit during the report year."

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

               End DoDot:1

 +17       WRITE !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"

 +18       WRITE !?5,"First HIV DX: Date",?35,"Date of Onset",?50,"HIV Follow-up: Date"

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

 +20       SET BUDP=1

 +21       QUIT 

 +22      ;----------

HIV2      ;EP

 +1        IF $DATA(IOF)

               WRITE @IOF

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

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

 +4        WRITE !!,"Newly Idenitifed HIV Cases with Timely Follow-Up (Table 6B)",!

 +5        DO GENI

 +6        DO PAUSE

 +7        WRITE !!,"This report provides a list of all patients whose first ever HIV"

 +8        WRITE !,"diagnosis occurred between October 1 of the prior year through"

 +9        WRITE !,"September 30th of the current report year and did not have a medical visit"

 +10       WRITE !,"for HIV care within 90 days of the first-ever HIV diagnosis, and had at "

 +11       WRITE !,"least one medical visit during the report year."

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

 +13       WRITE !

 +14       QUIT 

HIV2L     ;EP

 +1        SET BUDP=0

           SET BUDQUIT=0

           SET BUDTOT=0

 +2        DO HIV2H

           IF BUDQUIT

               QUIT 

 +3        IF '$DATA(^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV2"))

               WRITE !!,"No patients to report.",!

               QUIT 

 +4        DO HIV2L1

 +5        IF $Y>(IOSL-3)

               DO HIV2H

               IF BUDQUIT

                   QUIT 

 +6        WRITE !,"TOTAL PATIENTS WITH FIRST HIV DX & TIMELY FOLLOW-UP:  ",BUDTOT,!

 +7        QUIT 

HIV2L1    ;

 +1        IF $Y>(IOSL-7)

               DO HIV2H

               IF BUDQUIT

                   QUIT 

 +2        SET BUDAGE=""

           FOR 

               SET BUDAGE=$ORDER(^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV2",BUDAGE))

               IF BUDAGE=""!(BUDQUIT)

                   QUIT 

               Begin DoDot:1

 +3                SET BUDNAME=""

                   FOR 

                       SET BUDNAME=$ORDER(^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV2",BUDAGE,BUDNAME))

                       IF BUDNAME=""!(BUDQUIT)

                           QUIT 

                       Begin DoDot:2

 +4                        SET BUDCOM=""

                           FOR 

                               SET BUDCOM=$ORDER(^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV2",BUDAGE,BUDNAME,BUDCOM))

                               IF BUDCOM=""!(BUDQUIT)

                                   QUIT 

                               Begin DoDot:3

 +5                                SET DFN=0

                                   FOR 

                                       SET DFN=$ORDER(^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV2",BUDAGE,BUDNAME,BUDCOM,DFN))

                                       IF DFN'=+DFN!(BUDQUIT)

                                           QUIT 

                                       Begin DoDot:4

 +6                                        IF $Y>(IOSL-3)

                                               DO HIV2H

                                               IF BUDQUIT

                                                   QUIT 

 +7                                        WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U,1),1,25),?29,$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$EXTRACT(BUDCOM,1,25),?70,$PIECE(^DPT(DFN,0),U,2),?75,BUDAG

E,!

 +8                                        SET BUDTOT=BUDTOT+1

 +9                                        SET BUDALL=^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV2",BUDAGE,BUDNAME,BUDCOM,DFN)

 +10                                       WRITE ?5,$PIECE(BUDALL,"|",1),?35,$SELECT($PIECE(BUDALL,"|",3)]"":$PIECE(BUDALL,"|",3),1:"None"),?46,$PIECE(BUDALL,"|",2)

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

HIV2H     ;

 +1        IF 'BUDGPG

               GOTO HIV2H1

 +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 

HIV2H1    ;

 +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 6B, Section L,",80),!,$$CTR("Newly Identified HIV Cases without Timely Follow-Up",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        SET X="Population:  "_$SELECT($GET(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"")

           WRITE $$CTR(X,80),!

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

 +10       IF BUDP=0

               Begin DoDot:1

 +11               WRITE !!,"This report provides a list of all patients whose first ever HIV"

 +12               WRITE !,"diagnosis occurred between October 1 of the prior year through"

 +13               WRITE !,"September 30th of the current report year and did not have a medical visit"

 +14               WRITE !,"for HIV care within 90 days of the first-ever HIV diagnosis, and had at "

 +15               WRITE !,"least one medical visit during the report year."

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

               End DoDot:1

 +17       WRITE !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"

 +18       WRITE !?5,"First HIV DX: Date",?35,"Date of Onset",?50,"HIV Follow-up: Date"

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

 +20       SET BUDP=1

 +21       QUIT 

DEPLIST1  ;EP

 +1        DO EOJ

 +2        SET BUDDEP1L=1

 +3        DO DEP1

 +4        GOTO EN1^BUDBRP6B

DEPLIST2  ;EP

 +1        DO EOJ

 +2        SET BUDDEP2L=1

 +3        DO DEP2

 +4        GOTO EN1^BUDBRP6B

DEP1      ;EP

 +1        IF $DATA(IOF)

               WRITE @IOF

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

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