BUDARP7I.m

BUDARP7I ; 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 ;EP - 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 !?4,"- the patient must NOT have a gender of 'Unknown'"

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

 ;----------

PRGH ;EP

 W:$D(IOF) @IOF

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

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

 W !!,"Pregnant Patients w/HIV (Table 7, Section A)",!

 D GENI

 D PAUSE

 W !!,"This report provides a list of patients that had pregnancy-related visits"

 W !,"during the past 20 months, with at least one pregnancy-related visit"

 W !,"during the report period, and who have been diagnosed with HIV."

 W !

 Q

PRGHL ;EP

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

 D PRGHH Q:BUDQUIT

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

 D PRGHL1

 I $Y>(IOSL-3) D PRGHH G:BUDQUIT PRGHLX

 W !!,"TOTAL HIV POSITIVE PREGNANT PATIENTS: ",BUDTOT,!

PRGHLX ;

 Q

PRGHL1 ;

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

 S BUDTOT=0

 S BUDA=0 F  S BUDA=$O(^XTMP("BUDARP7",BUDJ,BUDH,"PRGH",BUDA)) Q:BUDA'=+BUDA!(BUDQUIT)  D

 .S BUDNAME="" F  S BUDNAME=$O(^XTMP("BUDARP7",BUDJ,BUDH,"PRGH",BUDA,BUDNAME)) Q:BUDNAME=""!(BUDQUIT)  D

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

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

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

 ....S BUDX=^XTMP("BUDARP7",BUDJ,BUDH,"PRGH",BUDA,BUDNAME,BUDCOM,DFN)

 ....W !,$E($P(^DPT(DFN,0),U,1),1,23),?25,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$E(BUDCOM,1,12),?54,BUDA,?59,$P(BUDX,"@",2),!

 ....S BUDTOT=BUDTOT+1

 ....S BUDALL=^XTMP("BUDARP7",BUDJ,BUDH,"PRGH",BUDA,BUDNAME,BUDCOM,DFN)

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

 ....S BUDHIV=$P(BUDALL,"#",2)

 ....S BUDHIV=$P(BUDHIV,"@",1)

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

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

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

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

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

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

 Q

PRGHH ;

 G:'BUDGPG PRGHH1

 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

PRGHH1 ;

 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, HIV Positive Pregnant Women",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 of all pregnant patients with HIV, with most recent pregnancy"

 .W !,"related visits during the past 20 months."

 .W !,"Age is calculated as of June 30."

 .W !

 W !,"PATIENT NAME",?25,"HRN",?41,"COMMUNITY",?53,"AGE",?59,"CD & Date Last HIV DX"

 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

 ;

PRGR ;EP

 W:$D(IOF) @IOF

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

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

 W !!,"All Pregnant Patients by Race and Hispanic or Latino Identity",!,"(Table 7, Section A)",!

 D GENI

 D PAUSE

 W !!,"This report provides a list by race and Hispanic or Latino Identity"

 W !,"of patients that had pregnancy-related visits during the past 20 months,"

 W !,"with at least one pregnancy related visit during the report period."

 W !

 Q

PRGRL ;EP

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

 D PRGRH Q:BUDQUIT

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

 D PRGRL1

 I $Y>(IOSL-3) D PRGRH G:BUDQUIT PRGRLX

 W !!,"TOTAL PREGNANT PATIENTS BY HISPANIC OR LATINO IDENTITY AND RACE: ",BUDTOT,!

PRGRLX ;

 Q

RACE(R) ;EP

 I R="UNREP/REF" Q "Unreported/Refused to Report"

 I R="ASIAN" Q "Asian"

 I R="NATIVE HAWAIIAN" Q "Native Hawaiian"

 I R="OTH PAC ISLANDER" Q "Other Pacific Islander"

 I R="BLACK" Q "Black/African American"

 I R="AI/AN" Q "American Indian/Alaska Native"

 I R="WHITE" Q "White"

 I R="HISPANIC,WHITE" Q "White"

 I R="HISPANIC,BLACK" Q "Black/African American"

 I R="MORE THAN ONE RACE" Q "More than One Race"

 Q ""

 ;

PRGRL1 ;

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

 S BUDTOT=0

 S BUDRACE="" F  S BUDRACE=$O(^XTMP("BUDARP7",BUDJ,BUDH,"PRGR",BUDRACE)) Q:BUDRACE=""!(BUDQUIT)  D

 .S BUDETH="" F  S BUDETH=$O(^XTMP("BUDARP7",BUDJ,BUDH,"PRGR",BUDRACE,BUDETH)) Q:BUDETH=""!(BUDQUIT)  D PRGRL2

 Q

PRGRL2 ;

 S BUDSTOT=0

 S BUDRACEL=$$RACEL(BUDRACE,BUDETH)

 W !,BUDRACEL

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

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

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

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

 ....I $Y>(IOSL-3) D PRGRH 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,BUDA,!  ;,?51,$P($$RACE^BUDARPTC(DFN),U,3)_"-"_$P($$RACE^BUDARPTC(DFN),U,4),!

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

 ....S BUDRACV=$$RACE^BUDARPTC(DFN)

 ....W ?2,$E($P(BUDRACV,U,4),1,16)_" ("_$P(BUDRACV,U,3),")"  ;,?60,$E($P($$RACE^BUDARPTC(DFN),U,3)_"-"_$P($$RACE^BUDARPTC(DFN),U,4),1,19)

 ....S BUDHISV=$$HISP^BUDARPTC(DFN)

 ....W ?24,$P(BUDHISV,U,3)," (",$P(BUDHISV,U,2),")",!

 ....S BUDALL=^XTMP("BUDARP7",BUDJ,BUDH,"PRGR",BUDRACE,BUDETH,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 PRGRH 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 PRGRH Q:BUDQUIT  W !,BUDRACEL,!

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

 Q

PRGRH ;

 G:'BUDGPG PRGRH1

 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

PRGRH1 ;

 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 A",80),!,$$CTR("All Pregnant 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 of all pregnant patients by race and Hispanic or Latino Identity,"

 .W !,"with most recent pregnancy related visits during the past 20 months."

 .W !,"Age is calculated as of June 30."

 .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,"AGE"

 W !?2,"RACE*",?24,"HISPANIC OR LATINO IDENTITY*"

 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

 ;

PRGEL ;EP

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

 D PRGEH Q:BUDQUIT

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

 D PRGEL1

 I $Y>(IOSL-3) D PRGEH G:BUDQUIT PRGELX

 W !!,"TOTAL PREGNANT PATIENTS BY ETHNICITY: ",BUDTOT,!

PRGELX ;

 Q

ETHN(R) ;EP

 ;

 Q ""

PRGEL1 ;

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

 S BUDTOT=0

 S BUDRACE="" F  S BUDRACE=$O(^XTMP("BUDARP7",BUDJ,BUDH,"PRGE",BUDRACE)) Q:BUDRACE=""!(BUDQUIT)  D PRGEL2

 Q

PRGEL2 ;

 S BUDSTOT=0

 W !,BUDRACE,!

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

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

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

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

 ....I $Y>(IOSL-3) D PRGEH 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)),?36,$E(BUDCOM,1,10),?47,BUDA,?51,$P($$HISP^BUDARPTC(DFN),U,2)_"-"_$P($$HISP^BUDARPTC(DFN),U,3),!

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

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

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

 Q

PRGEH ;

 G:'BUDGPG PRGEH1

 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

PRGEH1 ;

 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, All Pregnant 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 of all pregnant patients by ethnicity, with most recent pregnancy related"

 .W !,"visits during the past 20 months."

 .W !,"Age is calculated as of June 30."

 .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,"AGE",?51,"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

 ;

PRGE ;EP

 W:$D(IOF) @IOF

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

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

 W !!,"All Pregnant Patients by Ethnicity (Table 7, Section A)",!

 D GENI

 D PAUSE

 W !!,"This report provides a list by ethnicity of patients that had pregnancy-"

 W !,"related visits during the past 20 months, with at least one pregnancy-"

 W !,"related visit during the report period."

 W !

 Q

RACEL(R,E) ;EP

 I R=1,E=1 Q "Asian, Hispanic"

 I R=1,E=2 Q "Asian, Non-Hispanic"

 I R=2,E=1 Q "Native Hawaiian, Hispanic"

 I R=2,E=2 Q "Native Hawaiian, Non-Hispanic"

 I R=3,E=1 Q "Other Pacific Islander, Hispanic"

 I R=3,E=2 Q "Other Pacific Islander, Non-Hispanic"

 I R=4,E=1 Q "Black/African American, Hispanic"

 I R=4,E=2 Q "Black/African American, Non-Hispanic"

 I R=5,E=1 Q "American Indian/Alaska Native, Hispanic"

 I R=5,E=2 Q "American Indian/Alaska Native, Non-Hispanic"

 I R=6,E=1 Q "White, Hispanic"

 I R=6,E=2 Q "White, Non-Hispanic"

 I R=7,E=1 Q "More than one race, Hispanic"

 I R=7,E=2 Q "More than one race, Non-Hispanic"

 I R=8,E=1 Q "Unreported / Refused to Report, Hispanic"

 I R=8,E=2 Q "Unreported / Refused to Report, Non-Hispanic"

 I R=8,E=3 Q "Unreported / Refused to Report Race and Identity"

 Q "UNKNOWN"

 ;

BUDARP7I  ; 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      ;EP - 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 !?4,"- the patient must NOT have a gender of 'Unknown'"

 +20       WRITE !

 +21       QUIT 

 +22      ;

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

PRGH      ;EP

 +1        IF $DATA(IOF)

               WRITE @IOF

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

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

 +4        WRITE !!,"Pregnant Patients w/HIV (Table 7, Section A)",!

 +5        DO GENI

 +6        DO PAUSE

 +7        WRITE !!,"This report provides a list of patients that had pregnancy-related visits"

 +8        WRITE !,"during the past 20 months, with at least one pregnancy-related visit"

 +9        WRITE !,"during the report period, and who have been diagnosed with HIV."

 +10       WRITE !

 +11       QUIT 

PRGHL     ;EP

 +1        SET BUDP=0

           SET BUDQUIT=0

           SET BUDTOT=0

 +2        DO PRGHH

           IF BUDQUIT

               QUIT 

 +3        IF '$DATA(^XTMP("BUDARP7",BUDJ,BUDH,"PRGH"))

               WRITE !!,"No patients to report."

               QUIT 

 +4        DO PRGHL1

 +5        IF $Y>(IOSL-3)

               DO PRGHH

               IF BUDQUIT

                   GOTO PRGHLX

 +6        WRITE !!,"TOTAL HIV POSITIVE PREGNANT PATIENTS: ",BUDTOT,!

PRGHLX    ;

 +1        QUIT 

PRGHL1    ;

 +1        IF $Y>(IOSL-7)

               DO PRGHH

               IF BUDQUIT

                   QUIT 

 +2        SET BUDTOT=0

 +3        SET BUDA=0

           FOR 

               SET BUDA=$ORDER(^XTMP("BUDARP7",BUDJ,BUDH,"PRGH",BUDA))

               IF BUDA'=+BUDA!(BUDQUIT)

                   QUIT 

               Begin DoDot:1

 +4                SET BUDNAME=""

                   FOR 

                       SET BUDNAME=$ORDER(^XTMP("BUDARP7",BUDJ,BUDH,"PRGH",BUDA,BUDNAME))

                       IF BUDNAME=""!(BUDQUIT)

                           QUIT 

                       Begin DoDot:2

 +5                        SET BUDCOM=""

                           FOR 

                               SET BUDCOM=$ORDER(^XTMP("BUDARP7",BUDJ,BUDH,"PRGH",BUDA,BUDNAME,BUDCOM))

                               IF BUDCOM=""!(BUDQUIT)

                                   QUIT 

                               Begin DoDot:3

 +6                                SET DFN=0

                                   FOR 

                                       SET DFN=$ORDER(^XTMP("BUDARP7",BUDJ,BUDH,"PRGH",BUDA,BUDNAME,BUDCOM,DFN))

                                       IF DFN'=+DFN!(BUDQUIT)

                                           QUIT 

                                       Begin DoDot:4

 +7                                        IF $Y>(IOSL-3)

                                               DO PRGHH

                                               IF BUDQUIT

                                                   QUIT 

 +8                                        SET BUDX=^XTMP("BUDARP7",BUDJ,BUDH,"PRGH",BUDA,BUDNAME,BUDCOM,DFN)

 +9                                        WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U,1),1,23),?25,$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$EXTRACT(BUDCOM,1,12),?54,BUDA,?59,$PIECE(BUDX,"@",2),!

 +10                                       SET BUDTOT=BUDTOT+1

 +11                                       SET BUDALL=^XTMP("BUDARP7",BUDJ,BUDH,"PRGH",BUDA,BUDNAME,BUDCOM,DFN)

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

 +13                                       SET BUDHIV=$PIECE(BUDALL,"#",2)

 +14                                       SET BUDHIV=$PIECE(BUDHIV,"@",1)

 +15                                       FOR BUDX=1:1

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

                                               IF BUDV=""!(BUDQUIT)

                                                   QUIT 

                                               Begin DoDot:5

 +16                                               IF $Y>(IOSL-3)

                                                       DO PRGHH

                                                       IF BUDQUIT

                                                           QUIT 

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

                                                       WRITE ?5,BUDV,!

                                                       QUIT 

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

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

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

 +20                                       FOR BUDX=1:1

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

                                               IF BUDV=""!(BUDQUIT)

                                                   QUIT 

                                               Begin DoDot:5

 +21                                               IF $Y>(IOSL-3)

                                                       DO PRGHH

                                                       IF BUDQUIT

                                                           QUIT 

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

                                                       WRITE ?5,BUDV,!

                                                       QUIT 

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

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

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

 +25       QUIT 

PRGHH     ;

 +1        IF 'BUDGPG

               GOTO PRGHH1

 +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 

PRGHH1    ;

 +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, HIV Positive Pregnant Women",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 of all pregnant patients with HIV, with most recent pregnancy"

 +11               WRITE !,"related visits during the past 20 months."

 +12               WRITE !,"Age is calculated as of June 30."

 +13               WRITE !

               End DoDot:1

 +14       WRITE !,"PATIENT NAME",?25,"HRN",?41,"COMMUNITY",?53,"AGE",?59,"CD & Date Last HIV DX"

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

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

 +17       SET BUDP=1

 +18       QUIT 

 +19      ;

PRGR      ;EP

 +1        IF $DATA(IOF)

               WRITE @IOF

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

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

 +4        WRITE !!,"All Pregnant Patients by Race and Hispanic or Latino Identity",!,"(Table 7, Section A)",!

 +5        DO GENI

 +6        DO PAUSE

 +7        WRITE !!,"This report provides a list by race and Hispanic or Latino Identity"

 +8        WRITE !,"of patients that had pregnancy-related visits during the past 20 months,"

 +9        WRITE !,"with at least one pregnancy related visit during the report period."

 +10       WRITE !

 +11       QUIT 

PRGRL     ;EP

 +1        SET BUDP=0

           SET BUDQUIT=0

           SET BUDTOT=0

 +2        DO PRGRH

           IF BUDQUIT

               QUIT 

 +3        IF '$DATA(^XTMP("BUDARP7",BUDJ,BUDH,"PRGR"))

               WRITE !!,"No patients to report."

               QUIT 

 +4        DO PRGRL1

 +5        IF $Y>(IOSL-3)

               DO PRGRH

               IF BUDQUIT

                   GOTO PRGRLX

 +6        WRITE !!,"TOTAL PREGNANT PATIENTS BY HISPANIC OR LATINO IDENTITY AND RACE: ",BUDTOT,!

PRGRLX    ;

 +1        QUIT 

RACE(R)   ;EP

 +1        IF R="UNREP/REF"

               QUIT "Unreported/Refused to Report"

 +2        IF R="ASIAN"

               QUIT "Asian"

 +3        IF R="NATIVE HAWAIIAN"

               QUIT "Native Hawaiian"

 +4        IF R="OTH PAC ISLANDER"

               QUIT "Other Pacific Islander"

 +5        IF R="BLACK"

               QUIT "Black/African American"

 +6        IF R="AI/AN"

               QUIT "American Indian/Alaska Native"

 +7        IF R="WHITE"

               QUIT "White"

 +8        IF R="HISPANIC,WHITE"

               QUIT "White"

 +9        IF R="HISPANIC,BLACK"

               QUIT "Black/African American"

 +10       IF R="MORE THAN ONE RACE"

               QUIT "More than One Race"

 +11       QUIT ""

 +12      ;

PRGRL1    ;

 +1        IF $Y>(IOSL-7)