BGP4DHEA.m

BGP4DHEA ; IHS/CMI/LAB - ihs area AA ;

 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007

 ;

 ;

 W:$D(IOF) @IOF

 S BGPA=$E($P(^AUTTLOC(DUZ(2),0),U,10),1,2),BGPA=$O(^AUTTAREA("C",BGPA,0)) S BGPA=$S(BGPA:$P(^AUTTAREA(BGPA,0),U),1:"UNKNOWN AREA")

 W !!,$$CTR(BGPA_" FY 04 Area Aggregate HEDIS Performance Report",80)

INTRO ;

TP ;

 D EXIT

 S BGPAREAA=1

 S BGPRTYPE=3

 S (BGPBD,BGPED,BGPTP)=""

 S DIR(0)="S^1:January 1 - December 31;2:April 1 - March 31;3:July 1 - June 30;4:October 1 - September 30",DIR("A")="Enter the date range for your report" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) D EXIT Q

 S BGPQTR=Y

 D F

 I BGPPER="" W !,"Year not entered.",! G TP

 I BGPQTR=1 S BGPBD=($E(BGPPER,1,3)-1)_"0101",BGPED=($E(BGPPER,1,3)-1)_"1231"

 I BGPQTR=2 S BGPBD=($E(BGPPER,1,3)-1)_"0401",BGPED=$E(BGPPER,1,3)_"0331"

 I BGPQTR=3 S BGPBD=($E(BGPPER,1,3)-1)_"0701",BGPED=$E(BGPPER,1,3)_"0630"

 I BGPQTR=4 S BGPBD=($E(BGPPER,1,3)-1)_"1001",BGPED=$E(BGPPER,1,3)_"0930"

 I BGPED>DT D  G:BGPDO=1 TP

 .W !!,"You have selected Current Report period ",$$FMTE^XLFDT(BGPBD)," through ",$$FMTE^XLFDT(BGPED),"."

 .W !,"The end date of this report is in the future; your data will not be",!,"complete.",!

 .K DIR S BGPDO=0 S DIR(0)="Y",DIR("A")="Do you want to change your Current Report Dates?",DIR("B")="N" KILL DA D ^DIR KILL DIR

 .I $D(DIRUT) S BGPDO=1 Q

 .I Y S BGPDO=1 Q

 .Q

BY ;get baseline year

 S BGPVDT=""

 W !!,"Enter the Baseline Year to compare data to.",!,"Use a 4 digit year, e.g. 1999, 2000"

 S DIR(0)="D^::EP"

 S DIR("A")="Enter Year (e.g. 2000)"

 D ^DIR KILL DIR

 I $D(DIRUT) G TP

 I $D(DUOUT) S DIRUT=1 G TP

 S BGPVDT=Y

 I $E(Y,4,7)'="0000" W !!,"Please enter a year only!",! G BY

 S X=$E(BGPPER,1,3)-$E(BGPVDT,1,3)

 S X=X_"0000"

 S BGPBBD=BGPBD-X,BGPBBD=$E(BGPBBD,1,3)_$E(BGPBD,4,7)

 S BGPBED=BGPED-X,BGPBED=$E(BGPBED,1,3)_$E(BGPED,4,7)

 S BGPPBD=($E(BGPBD,1,3)-1)_$E(BGPBD,4,7)

 S BGPPED=($E(BGPED,1,3)-1)_$E(BGPED,4,7)

 W !!,"The date ranges for this report are:"

 W !?5,"Reporting Period: ",?31,$$FMTE^XLFDT(BGPBD)," to ",?31,$$FMTE^XLFDT(BGPED)

 W !?5,"Previous Year Period: ",?31,$$FMTE^XLFDT(BGPPBD)," to ",?31,$$FMTE^XLFDT(BGPPED)

 W !?5,"Baseline Period: ",?31,$$FMTE^XLFDT(BGPBBD)," to ",?31,$$FMTE^XLFDT(BGPBED)

BEN ;

 S BGPBEN=""

 S DIR(0)="S^1:Indian/Alaskan Native (Classification 01);2:Not Indian Alaskan/Native (Not Classification 01);3:All (both Indian/Alaskan Natives and Non 01)",DIR("A")="Select Beneficiary Population to include in this report"

 S DIR("B")="1" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G TP

 S BGPBEN=Y

ASU ;

 S BGPSUCNT=0

 S BGPRPTT=""

 S DIR(0)="S^A:AREA Aggregate;F:One Facility",DIR("A")="Run Report for",DIR("B")="A" KILL DA D ^DIR KILL DIR

 G:$D(DIRUT) BY

 S BGPRPTT=Y

 I BGPRPTT="F" D  G:$D(BGPQUIT) ASU

 .S BGPSUCNT=0,BGPSU="",BGPSUC="" K BGPSUL

 .K BGPSUL S BGPX=0 F  S BGPX=$O(^BGPHEDCF(BGPX)) Q:BGPX'=+BGPX  S V=^BGPHEDCF(BGPX,0) I $P(V,U)=BGPBD,$P(V,U,2)=BGPED,$P(V,U,7)=BGPPER,$P(V,U,12)=3,$P(V,U,5)=BGPBBD,$P(V,U,6)=BGPBED,$P(V,U,14)=BGPBEN S BGPSUL(BGPX)="",BGPSUCNT=BGPSUCNT+1

 .I '$D(BGPSUL) W !!,"No data from that time period has been uploaded from the service units.",! S BGPQUIT=1 Q

 .W !!,"Data from the following Facilities has been received.",!,"Please select the facility.",!

 .K BGPSUL1 S X=0,C=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  S C=C+1,BGPSUL1(C)=X

 .S X=0 F  S X=$O(BGPSUL1(X)) Q:X'=+X  S BGP0=^BGPHEDCF(BGPSUL1(X),0) W !?2,X,")",?2,"FY: ",$$FMTE^XLFDT($P(BGP0,U,7)),?11,"END DATE: ",$$VAL^XBDIQ1(90370.03,BGPSUL1(X),.02) D

 ..W ?36,"SU: ",$$SU($P(BGP0,U,11)),?60,"Facility: ",$E($$FAC($P(BGP0,U,9)),1,15)

 .W !?2,"0)",?5,"None of the Above"

 .S DIR(0)="N^0:"_C_":0",DIR("A")="Please Select the Facility",DIR("B")="0" KILL DA D ^DIR KILL DIR

 .I $D(DIRUT) S BGPQUIT=1 Q

 .I 'Y S BGPQUIT=1 Q

 .K BGPSUL S BGPSUL(BGPSUL1(Y))="",BGPSUCNT=1,X=$P(^BGPHEDCF(BGPSUL1(Y),0),U,9),X=$O(^AUTTLOC("C",X,0)) I X S BGPSUNM=$P(^DIC(4,X,0),U)

 .Q

 G:BGPRPTT="F" ZIS

GETSU ;

 K BGPSUL S BGPX=0 F  S BGPX=$O(^BGPHEDCF(BGPX)) Q:BGPX'=+BGPX  S V=^BGPHEDCF(BGPX,0) I $P(V,U)=BGPBD,$P(V,U,2)=BGPED,$P(V,U,7)=BGPPER,$P(V,U,5)=BGPBBD,$P(V,U,6)=BGPBED,$P(V,U,12)=3,$P(V,U,14)=BGPBEN S BGPSUL(BGPX)=""

 I '$D(BGPSUL) W !!,"No data from that time period has been uploaded from the service units.",! G INTRO

 W !!,"Data from the following Facilities has been received and will be used",!,"in the Area Aggregate Report:",!

 S X=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  S BGP0=^BGPHEDCF(X,0) W !?2,"FY: ",$$FMTE^XLFDT($P(BGP0,U,7)),?11,"END DATE: ",$$VAL^XBDIQ1(90370.03,X,.02),?35,"SU: ",$$SU($P(BGP0,U,11)),?55,"Facility: ",$E($$FAC($P(BGP0,U,9)),1,15)

ZIS ;call to XBDBQUE

 D ^XBFMK

 K DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM

GI ;gather all gpra indicators

 S X=0 F  S X=$O(^BGPHEIF(X)) Q:X'=+X  S BGPIND(X)=""

 S BGPINDT="H"

 ;

 D PT^BGP4DHSL

 I BGPROT="" G ASU

 ;W !! S %ZIS="PQM" D ^%ZIS

 K IOP,%ZIS W !! S %ZIS=$S(BGPDELT'="S":"PQM",1:"PM") D ^%ZIS

 ;I POP W !,"Report Aborted" S DA=BGPRPT,DIK="^BGPHEDFC(" D ^DIK K DIK D EXIT Q

 I $D(IO("Q")) G TSKMN

DRIVER ;

 U IO

 D PRINT^BGP4PHEP

 D ^%ZISC

 D EXIT

 Q

 ;

TSKMN ;EP ENTRY POINT FROM TASKMAN

 S ZTIO=$S($D(ION):ION,1:IO) I $D(IOST)#2,IOST]"" S ZTIO=ZTIO_";"_IOST

 I $G(IO("DOC"))]"" S ZTIO=ZTIO_";"_$G(IO("DOC"))

 I $D(IOM)#2,IOM S ZTIO=ZTIO_";"_IOM I $D(IOSL)#2,IOSL S ZTIO=ZTIO_";"_IOSL

 K ZTSAVE S ZTSAVE("BGP*")=""

 S ZTCPU=$G(IOCPU),ZTRTN="DRIVER^BGP4DARA",ZTDTH="",ZTDESC="GPRA REPORT" D ^%ZTLOAD D EXIT Q

 Q

 ;

FAC(S) ;

 NEW N S N=$O(^AUTTLOC("C",S,0))

 I N="" Q N

 Q $E($P(^DIC(4,N,0),U),1,15)

SU(S) ;

 NEW N S N=$O(^AUTTSU("C",S,0))

 I N="" Q N

 Q $E($P(^AUTTSU(N,0),U),1,15)

EXIT ;

 D EN^XBVK("BGP")

 D KILL^AUPNPAT

 D ^XBFMK

 Q

 ;

Q ;which quarter

 D F

 I BGPPER="" W !,"No YEAR entered" S BGPQUIT="" Q

 S DIR(0)="N^1:4:0",DIR("A")="Which Area Director's Quarter" KILL DA D ^DIR KILL DIR

 I $D(DIRUT)!(Y="") S BGPQUIT="" Q

 S BGPQTR=Y

 I Y=1 S BGPBD=($E(BGPPER,1,3)-2)_"1001",BGPED=($E(BGPPER,1,3)-1)_"0930" Q

 I Y=2 S BGPBD=($E(BGPPER,1,3)-1)_"0101",BGPED=($E(BGPPER,1,3)-1)_"1231" Q

 I Y=3 S BGPBD=($E(BGPPER,1,3)-1)_"0401",BGPED=$E(BGPPER,1,3)_"0331" Q

 I Y=4 S BGPBD=$E(BGPPER,1,3)_"0401",BGPED=$E(BGPPER,1,3)_"0630" Q

 Q

F ;fiscal year

 S BGPPER=""

 W !

 S BGPVDT=""

 W !,"Enter the Fiscal Year (FY) for the report END date.  Use a 4 digit",!,"year, e.g. 2002, 2004"

 S DIR(0)="D^::EP"

 S DIR("A")="Enter FY"

 S DIR("?")="This report is compiled for a period.  Enter a valid date."

 D ^DIR

 K DIC

 I $D(DUOUT) S DIRUT=1 S BGPQUIT="" Q

 S BGPVDT=Y

 I $E(Y,4,7)'="0000" W !!,"Please enter a year only!",! G F

 S BGPPER=BGPVDT,BGPBD=($E(BGPVDT,1,3)-1)_"1001",BGPED=$E(BGPVDT,1,3)_"0930"

 Q

A ;area dir year

 W !

 S BGPVDT=""

 W !,"Enter the appropriate AREA REPORTING YEAR.  Use a 4 digit year, e.g. 2002"

 S DIR(0)="D^::EP"

 S DIR("A")="Enter AREA REPORTING YEAR (e.g. 1999)"

 S DIR("?")="This report is compiled for a period.  Enter a valid date."

 D ^DIR

 K DIC

 I $D(DUOUT) S DIRUT=1 S BGPQUIT="" Q

 S BGPVDT=Y

 I $E(Y,4,7)'="0000" W !!,"Please enter a year only!",! G A

 S BGPPER=BGPVDT,BGPBD=($E(BGPVDT,1,3)-1)_"0701",BGPED=$E(BGPVDT,1,3)_"0630"

 Q

CTR(X,Y) ;EP - Center X in a field Y wide.

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

 ;----------

EOP ;EP - End of page.

 Q:$E(IOST)'="C"

 Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))

 NEW DIR

 K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT

 S DIR(0)="E" D ^DIR

 Q

 ;----------

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

 ;----------

 ;

BGP4DHEA  ; IHS/CMI/LAB - ihs area AA ;

 +1       ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007

 +2       ;

 +3       ;

 +4        IF $DATA(IOF)

               WRITE @IOF

 +5        SET BGPA=$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),1,2)

           SET BGPA=$ORDER(^AUTTAREA("C",BGPA,0))

           SET BGPA=$SELECT(BGPA:$PIECE(^AUTTAREA(BGPA,0),U),1:"UNKNOWN AREA")

 +6        WRITE !!,$$CTR(BGPA_" FY 04 Area Aggregate HEDIS Performance Report",80)

INTRO     ;

TP        ;

 +1        DO EXIT

 +2        SET BGPAREAA=1

 +3        SET BGPRTYPE=3

 +4        SET (BGPBD,BGPED,BGPTP)=""

 +5        SET DIR(0)="S^1:January 1 - December 31;2:April 1 - March 31;3:July 1 - June 30;4:October 1 - September 30"

           SET DIR("A")="Enter the date range for your report"

           KILL DA

           DO ^DIR

           KILL DIR

 +6        IF $DATA(DIRUT)

               DO EXIT

               QUIT 

 +7        SET BGPQTR=Y

 +8        DO F

 +9        IF BGPPER=""

               WRITE !,"Year not entered.",!

               GOTO TP

 +10       IF BGPQTR=1

               SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0101"

               SET BGPED=($EXTRACT(BGPPER,1,3)-1)_"1231"

 +11       IF BGPQTR=2

               SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0401"

               SET BGPED=$EXTRACT(BGPPER,1,3)_"0331"

 +12       IF BGPQTR=3

               SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0701"

               SET BGPED=$EXTRACT(BGPPER,1,3)_"0630"

 +13       IF BGPQTR=4

               SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"1001"

               SET BGPED=$EXTRACT(BGPPER,1,3)_"0930"

 +14       IF BGPED>DT

               Begin DoDot:1

 +15               WRITE !!,"You have selected Current Report period ",$$FMTE^XLFDT(BGPBD)," through ",$$FMTE^XLFDT(BGPED),"."

 +16               WRITE !,"The end date of this report is in the future; your data will not be",!,"complete.",!

 +17               KILL DIR

                   SET BGPDO=0

                   SET DIR(0)="Y"

                   SET DIR("A")="Do you want to change your Current Report Dates?"

                   SET DIR("B")="N"

                   KILL DA

                   DO ^DIR

                   KILL DIR

 +18               IF $DATA(DIRUT)

                       SET BGPDO=1

                       QUIT 

 +19               IF Y

                       SET BGPDO=1

                       QUIT 

 +20               QUIT 

               End DoDot:1

               IF BGPDO=1

                   GOTO TP

BY        ;get baseline year

 +1        SET BGPVDT=""

 +2        WRITE !!,"Enter the Baseline Year to compare data to.",!,"Use a 4 digit year, e.g. 1999, 2000"

 +3        SET DIR(0)="D^::EP"

 +4        SET DIR("A")="Enter Year (e.g. 2000)"

 +5        DO ^DIR

           KILL DIR

 +6        IF $DATA(DIRUT)

               GOTO TP

 +7        IF $DATA(DUOUT)

               SET DIRUT=1

               GOTO TP

 +8        SET BGPVDT=Y

 +9        IF $EXTRACT(Y,4,7)'="0000"

               WRITE !!,"Please enter a year only!",!

               GOTO BY

 +10       SET X=$EXTRACT(BGPPER,1,3)-$EXTRACT(BGPVDT,1,3)

 +11       SET X=X_"0000"

 +12       SET BGPBBD=BGPBD-X

           SET BGPBBD=$EXTRACT(BGPBBD,1,3)_$EXTRACT(BGPBD,4,7)

 +13       SET BGPBED=BGPED-X

           SET BGPBED=$EXTRACT(BGPBED,1,3)_$EXTRACT(BGPED,4,7)

 +14       SET BGPPBD=($EXTRACT(BGPBD,1,3)-1)_$EXTRACT(BGPBD,4,7)

 +15       SET BGPPED=($EXTRACT(BGPED,1,3)-1)_$EXTRACT(BGPED,4,7)

 +16       WRITE !!,"The date ranges for this report are:"

 +17       WRITE !?5,"Reporting Period: ",?31,$$FMTE^XLFDT(BGPBD)," to ",?31,$$FMTE^XLFDT(BGPED)

 +18       WRITE !?5,"Previous Year Period: ",?31,$$FMTE^XLFDT(BGPPBD)," to ",?31,$$FMTE^XLFDT(BGPPED)

 +19       WRITE !?5,"Baseline Period: ",?31,$$FMTE^XLFDT(BGPBBD)," to ",?31,$$FMTE^XLFDT(BGPBED)

BEN       ;

 +1        SET BGPBEN=""

 +2        SET DIR(0)="S^1:Indian/Alaskan Native (Classification 01);2:Not Indian Alaskan/Native (Not Classification 01);3:All (both Indian/Alaskan Natives and Non 01)"

           SET DIR("A")="Select Beneficiary Population to include in this report"

 +3        SET DIR("B")="1"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               GOTO TP

 +5        SET BGPBEN=Y

ASU       ;

 +1        SET BGPSUCNT=0

 +2        SET BGPRPTT=""

 +3        SET DIR(0)="S^A:AREA Aggregate;F:One Facility"

           SET DIR("A")="Run Report for"

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               GOTO BY

 +5        SET BGPRPTT=Y

 +6        IF BGPRPTT="F"

               Begin DoDot:1

 +7                SET BGPSUCNT=0

                   SET BGPSU=""

                   SET BGPSUC=""

                   KILL BGPSUL

 +8                KILL BGPSUL

                   SET BGPX=0

                   FOR 

                       SET BGPX=$ORDER(^BGPHEDCF(BGPX))

                       IF BGPX'=+BGPX

                           QUIT 

                       SET V=^BGPHEDCF(BGPX,0)

                       IF $PIECE(V,U)=BGPBD

                           IF $PIECE(V,U,2)=BGPED

                               IF $PIECE(V,U,7)=BGPPER

                                   IF $PIECE(V,U,12)=3

                                       IF $PIECE(V,U,5)=BGPBBD

                                           IF $PIECE(V,U,6)=BGPBED

                                               IF $PIECE(V,U,14)=BGPBEN

                                                   SET BGPSUL(BGPX)=""

                                                   SET BGPSUCNT=BGPSUCNT+1

 +9                IF '$DATA(BGPSUL)

                       WRITE !!,"No data from that time period has been uploaded from the service units.",!

                       SET BGPQUIT=1

                       QUIT 

 +10               WRITE !!,"Data from the following Facilities has been received.",!,"Please select the facility.",!

 +11               KILL BGPSUL1

                   SET X=0

                   SET C=0

                   FOR 

                       SET X=$ORDER(BGPSUL(X))

                       IF X'=+X

                           QUIT 

                       SET C=C+1

                       SET BGPSUL1(C)=X

 +12               SET X=0

                   FOR 

                       SET X=$ORDER(BGPSUL1(X))

                       IF X'=+X

                           QUIT 

                       SET BGP0=^BGPHEDCF(BGPSUL1(X),0)

                       WRITE !?2,X,")",?2,"FY: ",$$FMTE^XLFDT($PIECE(BGP0,U,7)),?11,"END DATE: ",$$VAL^XBDIQ1(90370.03,BGPSUL1(X),.02)

                       Begin DoDot:2

 +13                       WRITE ?36,"SU: ",$$SU($PIECE(BGP0,U,11)),?60,"Facility: ",$EXTRACT($$FAC($PIECE(BGP0,U,9)),1,15)

                       End DoDot:2

 +14               WRITE !?2,"0)",?5,"None of the Above"

 +15               SET DIR(0)="N^0:"_C_":0"

                   SET DIR("A")="Please Select the Facility"

                   SET DIR("B")="0"

                   KILL DA

                   DO ^DIR

                   KILL DIR

 +16               IF $DATA(DIRUT)

                       SET BGPQUIT=1

                       QUIT 

 +17               IF 'Y

                       SET BGPQUIT=1

                       QUIT 

 +18               KILL BGPSUL

                   SET BGPSUL(BGPSUL1(Y))=""

                   SET BGPSUCNT=1

                   SET X=$PIECE(^BGPHEDCF(BGPSUL1(Y),0),U,9)

                   SET X=$ORDER(^AUTTLOC("C",X,0))

                   IF X

                       SET BGPSUNM=$PIECE(^DIC(4,X,0),U)

 +19               QUIT 

               End DoDot:1

               IF $DATA(BGPQUIT)

                   GOTO ASU

 +20       IF BGPRPTT="F"

               GOTO ZIS

GETSU     ;

 +1        KILL BGPSUL

           SET BGPX=0

           FOR 

               SET BGPX=$ORDER(^BGPHEDCF(BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               SET V=^BGPHEDCF(BGPX,0)

               IF $PIECE(V,U)=BGPBD

                   IF $PIECE(V,U,2)=BGPED

                       IF $PIECE(V,U,7)=BGPPER

                           IF $PIECE(V,U,5)=BGPBBD

                               IF $PIECE(V,U,6)=BGPBED

                                   IF $PIECE(V,U,12)=3

                                       IF $PIECE(V,U,14)=BGPBEN

                                           SET BGPSUL(BGPX)=""

 +2        IF '$DATA(BGPSUL)

               WRITE !!,"No data from that time period has been uploaded from the service units.",!

               GOTO INTRO

 +3        WRITE !!,"Data from the following Facilities has been received and will be used",!,"in the Area Aggregate Report:",!

 +4        SET X=0

           FOR 

               SET X=$ORDER(BGPSUL(X))

               IF X'=+X

                   QUIT 

               SET BGP0=^BGPHEDCF(X,0)

               WRITE !?2,"FY: ",$$FMTE^XLFDT($PIECE(BGP0,U,7)),?11,"END DATE: ",$$VAL^XBDIQ1(90370.03,X,.02),?35,"SU: ",$$SU($PIECE(BGP0,U,11)),?55,"Facility: ",$EXTRACT($$FAC($PIECE(BGP0,U,9)),1,15)

ZIS       ;call to XBDBQUE

 +1        DO ^XBFMK

 +2        KILL DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM

GI        ;gather all gpra indicators

 +1        SET X=0

           FOR 

               SET X=$ORDER(^BGPHEIF(X))

               IF X'=+X

                   QUIT 

               SET BGPIND(X)=""

 +2        SET BGPINDT="H"

 +3       ;

 +4        DO PT^BGP4DHSL

 +5        IF BGPROT=""

               GOTO ASU

 +6       ;W !! S %ZIS="PQM" D ^%ZIS

 +7        KILL IOP,%ZIS

           WRITE !!

           SET %ZIS=$SELECT(BGPDELT'="S":"PQM",1:"PM")

           DO ^%ZIS

 +8       ;I POP W !,"Report Aborted" S DA=BGPRPT,DIK="^BGPHEDFC(" D ^DIK K DIK D EXIT Q

 +9        IF $DATA(IO("Q"))

               GOTO TSKMN

DRIVER    ;

 +1        USE IO

 +2        DO PRINT^BGP4PHEP

 +3        DO ^%ZISC

 +4        DO EXIT

 +5        QUIT 

 +6       ;

TSKMN     ;EP ENTRY POINT FROM TASKMAN

 +1        SET ZTIO=$SELECT($DATA(ION):ION,1:IO)

           IF $DATA(IOST)#2

               IF IOST]""

                   SET ZTIO=ZTIO_";"_IOST

 +2        IF $GET(IO("DOC"))]""

               SET ZTIO=ZTIO_";"_$GET(IO("DOC"))

 +3        IF $DATA(IOM)#2

               IF IOM

                   SET ZTIO=ZTIO_";"_IOM

                   IF $DATA(IOSL)#2

                       IF IOSL

                           SET ZTIO=ZTIO_";"_IOSL

 +4        KILL ZTSAVE

           SET ZTSAVE("BGP*")=""

 +5        SET ZTCPU=$GET(IOCPU)

           SET ZTRTN="DRIVER^BGP4DARA"

           SET ZTDTH=""

           SET ZTDESC="GPRA REPORT"

           DO ^%ZTLOAD

           DO EXIT

           QUIT 

 +6        QUIT 

 +7       ;

FAC(S)    ;

 +1        NEW N

           SET N=$ORDER(^AUTTLOC("C",S,0))

 +2        IF N=""

               QUIT N

 +3        QUIT $EXTRACT($PIECE(^DIC(4,N,0),U),1,15)

SU(S)     ;

 +1        NEW N

           SET N=$ORDER(^AUTTSU("C",S,0))

 +2        IF N=""

               QUIT N

 +3        QUIT $EXTRACT($PIECE(^AUTTSU(N,0),U),1,15)

EXIT      ;

 +1        DO EN^XBVK("BGP")

 +2        DO KILL^AUPNPAT

 +3        DO ^XBFMK

 +4        QUIT 

 +5       ;

Q         ;which quarter

 +1        DO F

 +2        IF BGPPER=""

               WRITE !,"No YEAR entered"

               SET BGPQUIT=""

               QUIT 

 +3        SET DIR(0)="N^1:4:0"

           SET DIR("A")="Which Area Director's Quarter"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)!(Y="")

               SET BGPQUIT=""

               QUIT 

 +5        SET BGPQTR=Y

 +6        IF Y=1

               SET BGPBD=($EXTRACT(BGPPER,1,3)-2)_"1001"

               SET BGPED=($EXTRACT(BGPPER,1,3)-1)_"0930"

               QUIT 

 +7        IF Y=2

               SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0101"

               SET BGPED=($EXTRACT(BGPPER,1,3)-1)_"1231"

               QUIT 

 +8        IF Y=3

               SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0401"

               SET BGPED=$EXTRACT(BGPPER,1,3)_"0331"

               QUIT 

 +9        IF Y=4

               SET BGPBD=$EXTRACT(BGPPER,1,3)_"0401"

               SET BGPED=$EXTRACT(BGPPER,1,3)_"0630"

               QUIT 

 +10       QUIT 

F         ;fiscal year

 +1        SET BGPPER=""

 +2        WRITE !

 +3        SET BGPVDT=""

 +4        WRITE !,"Enter the Fiscal Year (FY) for the report END date.  Use a 4 digit",!,"year, e.g. 2002, 2004"

 +5        SET DIR(0)="D^::EP"

 +6        SET DIR("A")="Enter FY"

 +7        SET DIR("?")="This report is compiled for a period.  Enter a valid date."

 +8        DO ^DIR

 +9        KILL DIC

 +10       IF $DATA(DUOUT)

               SET DIRUT=1

               SET BGPQUIT=""

               QUIT 

 +11       SET BGPVDT=Y

 +12       IF $EXTRACT(Y,4,7)'="0000"

               WRITE !!,"Please enter a year only!",!

               GOTO F

 +13       SET BGPPER=BGPVDT

           SET BGPBD=($EXTRACT(BGPVDT,1,3)-1)_"1001"

           SET BGPED=$EXTRACT(BGPVDT,1,3)_"0930"

 +14       QUIT 

A         ;area dir year

 +1        WRITE !

 +2        SET BGPVDT=""

 +3        WRITE !,"Enter the appropriate AREA REPORTING YEAR.  Use a 4 digit year, e.g. 2002"

 +4        SET DIR(0)="D^::EP"

 +5        SET DIR("A")="Enter AREA REPORTING YEAR (e.g. 1999)"

 +6        SET DIR("?")="This report is compiled for a period.  Enter a valid date."

 +7        DO ^DIR

 +8        KILL DIC

 +9        IF $DATA(DUOUT)

               SET DIRUT=1

               SET BGPQUIT=""

               QUIT 

 +10       SET BGPVDT=Y

 +11       IF $EXTRACT(Y,4,7)'="0000"

               WRITE !!,"Please enter a year only!",!

               GOTO A

 +12       SET BGPPER=BGPVDT

           SET BGPBD=($EXTRACT(BGPVDT,1,3)-1)_"0701"

           SET BGPED=$EXTRACT(BGPVDT,1,3)_"0630"

 +13       QUIT 

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

EOP       ;EP - End of page.

 +1        IF $EXTRACT(IOST)'="C"

               QUIT 

 +2        IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))

               QUIT 

 +3        NEW DIR

 +4        KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT

 +5        SET DIR(0)="E"

           DO ^DIR

 +6        QUIT 

 +7       ;----------

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       ;