BGP9DPA.m

BGP9DPA ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT ; 03 Jun 2009  2:54 PM

 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009

 ;

EP ;EP - called from option interactive

 D EOJ

 W:$D(IOF) @IOF

 D TERM^VALM0

 S BGPCTRL=$O(^BGPCTRL("B",2009,0))

 S X=0 F  S X=$O(^BGPCTRL(BGPCTRL,58,X)) Q:X'=+X  W !,^BGPCTRL(BGPCTRL,58,X,0)

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

 I '$D(^XUSEC("BGPZ PATIENT LISTS",DUZ)) W !!,"You do not have the security access to print patient lists.",!,"Please see your supervisor or program manager if you feel you should have",!,"the BGPZ PATIENT LISTS security key.",! D  Q

 .K DIR S DIR(0)="E",DIR("A")="Press enter to continue" D ^DIR K DIR

 ;

 ;W !!,IORVON,!,"STEPHANIE TO PROVIDE TEXT HERE",IORVOFF

 ;W !!,"This option will produce a comprehensive National GPRA report for"

 ;W !,"patients who have an appointment in a date range specified by"

 ;W !,"the user in any clinic or in a selected set of clinics."

 ;W !!,"You will be asked to enter the date range of the appointments and the"

 ;W !,"clinic names if selecting a set of clinics.",!,"STEPHANIE TO PROVIDE TEXT HERE",!

RTYPE ;

 S BGPRT1=""

 S DIR(0)="S^C:By CLINIC NAME for a specified appointment date range;P:Selected Patients w/Appointments;D:One Facility's or Divisions Appointments;A:Any selected set of patients regardless of appt status"

 S DIR("A")="Create List/Sort by",DIR("B")="C" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) D EOJ Q

 S BGPRT1=Y

 I BGPRT1="C" D CLIN G:$G(BGPQUIT) RTYPE G DATES

 I BGPRT1="D" D DIV G:$G(BGPQUIT) RTYPE G DATES

 I BGPRT1="P" D GETPAT G:$G(BGPQUIT) RTYPE G DATES

 I BGPRT1="A" D SELPT G:$G(BGPQUIT) RTYPE G ZIS

DATES K BGPAED,BGPABD

 K DIR W ! S DIR(0)="DO^::E",DIR("A")="Enter Beginning Appointment Date"

 D ^DIR G:Y<1 EOJ S BGPABD=Y

 K DIR S DIR(0)="DO^::EX",DIR("A")="Enter Ending Appointment Date"

 D ^DIR G:Y<1 EOJ  S BGPAED=Y

 ;

 I BGPAED<BGPABD D  G DATES

 . W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."

 S BGPASD=$$FMADD^XLFDT(BGPABD,-1)_".9999"

 ;

ZIS ;

 S BGPRTYPE=1,BGP9RPTH="",BGPCPPL=1,BGPINDT="G",BGP9GPU=1,BGPALLPT=1,BGPBEN=3

 S BGPHOME=$P($G(^BGPSITE(DUZ(2),0)),U,2)

 ;I BGPHOME="" W !!,"Home Location not found in Site File!!",!,"PHN Visits counts to Home will be calculated using clinic 11 only!!" H 2

 ;W !,"Your HOME location is defined as: ",$P(^DIC(4,BGPHOME,0),U)," asufac:  ",$P(^AUTTLOC(BGPHOME,0),U,10)

ENDDATE ;

 ;AI ;gather all gpra measures

 S X=0 F  S X=$O(^BGPINDN("GPRA",1,X)) Q:X'=+X  S BGPIND(X)=""

 S X=$O(^BGPCTRL("B",2009,0))

 S Y=^BGPCTRL(X,0)

 S BGPBD=$P(Y,U,8),BGPED=$P(Y,U,9)

 S BGPPBD=$P(Y,U,10),BGPPED=$P(Y,U,11)

 S BGPBBD=$P(Y,U,12),BGPBED=$P(Y,U,13)

 S BGPPER=$P(Y,U,14),BGPQTR=3

 G NT

 S BGPBD=3030101,BGPED=3031231

 S BGPPBD=3020101,BGPPED=3021231

 S BGPBBD=3000101,BGPBED=3001231

NT S BGPLIST="A"

 S BGPCPLC=0

 ;S XBRP="PRINT^BGP9DPAW",XBRC="PROC^BGP9DPA",XBRX="EOJ^BGP9DPA",XBNS="BGP"

 ;D ^XBDBQUE

 ;

 K IOP,%ZIS

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

 I POP D EOJ Q

ZIS1 ;

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

DRIVER ;

 I $D(ZTQUEUED) S ZTREQ="@"

 D PROC^BGP9DPA

 U IO

 D PRINT^BGP9DPAW

 D ^%ZISC

 D EOJ

 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^BGP9DPA",ZTDTH="",ZTDESC="CRS 09 SCHED REPORT" D ^%ZTLOAD D EOJ Q

 Q

EOJ ;

 D ^XBFMK

 K DIC,DIR,DFN

 D EN^XBVK("BGP"),EN^XBVK("BSD"),EN^XBVK("AMQQ")

 K ^TMP($J)

 Q

 ;

DIV ;

 S BGPQUIT="",BGPDIVI=""

 K DIC

 S DIC="^DG(40.8,",DIC(0)="AEMQ"  ; I $O(^DG(40.8,"C",DUZ(2),0)) S DIC("B")=$P(^DIC(4,$O(^DG(40.8,"C",DUZ(2),0)),0),U)

 D ^DIC K DIC

 I Y=-1 S BGPQUIT=1 Q

 S BGPDIVI=+Y

CLIN ;

 S BGPCLN="",BGPQUIT=""

 S DIR(0)="S^A:ANY Clinic;S:One or more selected Clinics",DIR("A")="Include patients with Appointments to",DIR("B")="A" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) S BGPQUIT=1 Q

 S BGPCLN=Y

 I BGPCLN="A" K BGPCLN Q

 ;get which clinics

 K BGPCLN

CLIN1 ;

 W ! S DIC="^SC(",DIC(0)="AEMZQ",DIC("A")="Select CLINIC: "

 S DIC("S")="I $P(^(0),U,3)=""C""" D ^DIC K DIC

 I Y=-1,'$D(BGPCLN) G CLIN

 I X="^" G CLIN

 I Y="",$D(BGPCLN) Q

 I Y=-1,$D(BGPCLN) Q

 I X="",'$D(BGPCLN) G CLIN

 S BGPCLN(+Y)=""

 G CLIN1

GETPAT ;

 K BGPPATS

GETPAT1 ;

 S BGPQUIT="",BGPDIVI=""

 K DIC

 S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC

 I Y=-1,'$D(BGPPATS) S BGPQUIT=1 Q

 S BGPPATS(+Y)=""

 Q

SELPT ;

 K BGPPATS

 S BGPSMI=0

 F  D  Q:U[X

 .S DIR(0)="FOU",DIR("A")="Select patient(s)"

 .S DIR("?",1)="     Enter a patient's HRN or name (HORSECHIEF,JOHN DOE or HORSECHIEF,JOHN).",DIR("?",2)=""

 .S DIR("?",3)="     A template can also be selected by typing a ""["" followed by",DIR("?",4)="     the template name."

 .S DIR("?",5)="",DIR("?")="     ""[??"" will list your templates.",DIR("??")="^D LIST^BGP9DPAP"

 .D ^DIR K DIR

 .S:X[U X=U

 .I $E(X)="[" D  Q

 .. S X=$E(X,2,$L(X))

 .. K DIC S DIC=.401,DIC(0)=$S(X="":"AEMQ",1:"EMQ"),DIC("S")="I $P(^(0),U,4)=2!($P(^(0),U,4)=9000001),($P(^(0),U,5)=$G(DUZ))!(DUZ(0)=""@"")" D ^DIC

 .. I Y>0 D

 ... S BGPPATS=0,Y=+Y F BGPMJ=0:1 S BGPPATS=$O(^DIBT(Y,1,BGPPATS)) Q:'BGPPATS  S BGPSMI=BGPSMI+1,BGPPATS(BGPSMI)=BGPPATS

 ... W !,BGPMJ,$S(BGPMJ=1:" entry",1:" entries")," added."

 .K DIC S DIC=9000001,DIC(0)="EQM" D ^DIC

 .I Y>0 S BGPPATS=+Y,BGPSMI=BGPSMI+1,BGPPATS(BGPSMI)=BGPPATS

 W !

 I X=U K BGPPATS W !,"All selections cancelled!"

 I '$O(BGPPATS("")) W !,"No patients selected." S BGPQUIT=1 Q

 Q

TEST ;

 D BDMG(1,3040101,3041231,13)

 Q

BDMG(BGPBD,BGPED,BGPCLN) ;EP - GUI DMS Entry Point

 ;cmi/anch/maw added 10/19/2004

 S BGPSD=$$FMADD^XLFDT(BGPBD,-1)_".9999"

 S BGPGUI=1

 N BGPOPT,BGPNOW,BGPIEN  ;maw

 S BGPOPT="List Patients on a Register w/an Appointment"

 S BGPRTYPE=1,BGP9RPTH="",BGPCPPL=1,BGPINDT="G",BGP9GPU=1

 D NOW^%DTC

 S BGPNOW=$G(%)

 K DD,D0,DIC

 S X=DUZ_$$NOW^XLFDT

 S DIC("DR")=".02////"_DUZ_";.03////"_BGPNOW_";.06///"_$G(BGPOPT)_";.07////R"

 S DIC="^BGPGUIN(",DIC(0)="L",DIADD=1,DLAYGO=9001004.4

 D FILE^DICN

 K DIADD,DLAYGO,DIC,DA

 I Y=-1 S BGPIEN=-1 Q

 S BGPIEN=+Y

 S BDMGIEN=BGPIEN  ;cmi/maw added

 D ^XBFMK

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

 S ZTIO="",ZTDTH=$$NOW^XLFDT,ZTRTN="GUIEP^BGP9DPA",ZTDESC="GUI CN GRPA APPT" D ^%ZTLOAD

 D EOJ

 Q

GUIEP ;EP

 D PROC

 K ^TMP($J,"BGP9DPA")

 S IOM=80

 D GUIR^XBLM("PRINT^BGP9DPA","^TMP($J,""BGP9DPA"",")

 S X=0,C=0 F  S X=$O(^TMP($J,"BGP9DPA",X)) Q:X'=+X  D

 .S BGPDATA=^TMP($J,"BGP9DPA",X)

 .I BGPDATA="ZZZZZZZ" S BGPDATA=$C(12)

 .S ^BGPGUIN(BGPIEN,11,X,0)=BGPDATA,C=C+1

 S ^BGPGUIN(BGPIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"

 S DA=BGPIEN,DIK="^BGPGUIN(" D IX1^DIK

 D ENDLOG

 K ^TMP($J,"BGP9DPA")

 S ZTREQ="@"

 Q

 ;

GUIECP ;EP

 K ^TMP($J,"BGP9DPA")

 S IOM=80

 D GUIR^XBLM("CPPRINT^BGP9DPA","^TMP($J,""BGP9DPA"",")

 S X=0,C=0 F  S X=$O(^TMP($J,"BGP9DPA",X)) Q:X'=+X  D

 .S BGPDATA=^TMP($J,"BGP9DPA",X)

 .I BGPDATA="ZZZZZZZ" S BGPDATA=$C(12)

 .S ^BGPGUIN(BGPIEN,11,X,0)=BGPDATA,C=C+1

 S ^BGPGUIN(BGPIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"

 S DA=BGPIEN,DIK="^BGPGUIN(" D IX1^DIK

 D ENDLOG

 K ^TMP($J,"BGP9DPA")

 S ZTREQ="@"

 Q

 ;

ENDLOG ;-- write the end of the log

 D NOW^%DTC

 S BGPNOW=$G(%)

 S DIE="^BGPGUIN(",DA=BGPIEN,DR=".04////"_BGPNOW_";.06////C"

 D ^DIE

 K DIE,DR,DA

 Q

 ;

PROC ;EP

 D JRNL^BGP9UTL

 S BGPGPRAJ=$J,BGPGPRAH=$H

 S BGPCHWC=0

 S BGPCHSO=$P($G(^BGPSITE(DUZ(2),0)),U,6)

 ;calculate 3 years before end of each time frame

 S BGP3YE=$$FMADD^XLFDT(BGPED,-1096)

 K ^XTMP("BGP9DPA",BGPGPRAJ,BGPGPRAH)

 S ^XTMP("BGP9DPA",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PTS WITH GPRA DATA"

 K BGPAPPT,BGPAPPTS

 S BGPTA=0

 I BGPRT1="A" D  Q

 .S BGPSOX=0 F  S BGPSOX=$O(BGPPATS(BGPSOX)) Q:BGPSOX'=+BGPSOX  D

 ..S DFN=BGPPATS(BGPSOX)

 ..Q:$P($G(^DPT(DFN,0)),U)["DEMO,PATIENT"

 ..I $P($G(^BGPSITE(DUZ(2),0)),U,12) Q:$D(^DIBT($P(^BGPSITE(DUZ(2),0),U,12),1,DFN))

 ..S BGPIISO=1,BGPISST="A" D PROCCY^BGP9D1

 .Q

 S BGPSD=$$FMADD^XLFDT(BGPABD,-1)

 S BGPOD=BGPSD F  S BGPOD=$$FMADD^XLFDT(BGPOD,1) Q:BGPOD>BGPAED  D

 .K BGPAPPT

 .S BGPCLN=$S('$O(BGPCLN(0)):"ALL",1:"")

 .S BGPARRAY="BGPAPPT("

 .I BGPRT1="D" S BGPCLN("DEV")=BGPDIVI

 .D LIST^BSDAPI2(BGPOD,"W",.BGPCLN,BGPARRAY)

 .S X=0 F  S X=$O(BGPAPPT(X)) Q:X'=+X  D

 ..S Y=$P(BGPAPPT(X),U)

 ..I BGPRT1="P" I Y,'$D(BGPPATS(Y)) Q  ;if patients only want that set of patients

 ..I Y Q:$P($G(^DPT(Y,0)),U)["DEMO,PATIENT"

 ..I $P($G(^BGPSITE(DUZ(2),0)),U,12) Q:$D(^DIBT($P(^BGPSITE(DUZ(2),0),U,12),1,Y))

 ..S BGPTA=BGPTA+1,BGPAPPTS(BGPTA)=BGPAPPT(X)

 .Q

 S BGPSOX=0 F  S BGPSOX=$O(BGPAPPTS(BGPSOX)) Q:BGPSOX'=+BGPSOX  D

 .S DFN=$P(BGPAPPTS(BGPSOX),U,1)

 .Q:$P($G(^DPT(DFN,0)),U,1)["DEMO,PATIENT"

 .I $P($G(^BGPSITE(DUZ(2),0)),U,12) Q:$D(^DIBT($P(^BGPSITE(DUZ(2),0),U,12),1,DFN))

 .S BGPIISO=1,BGPISST=BGPRT1,BGPISSO=1 D PROCCY^BGP9D1

 .Q

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

 K DIR

 K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT

 S DIR("A")="End of report.  Press Enter",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")

 ;----------

COVPAGE ;EP - called from option to display the cover page

 ;

 W !!,"This option is used to print out the denominator definitions"

 W !,"used in the GPRA & PART Measures Forecast Patient List.",!!

ZISCP ;

 K IOP,%ZIS

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

 I POP D EOJ Q

 ;

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

 ;S XBRP="CPPRINT^BGP9DPA",XBRC="",XBRX="EOJ^BGP9DPA",XBNS="BGP"

 ;D ^XBDBQUE

 ;

CPPRINT ;EP - called from xbdbque

 U IO

 I $D(ZTQUEUED) S ZTREQ="@"

 S BGPPG=0

 S BGPIOSL=$S($G(BGPGUI):55,1:IOSL)

 I $G(BGPGUI) S IOSL=55  ;cmi/maw added 1/14/2008

 D CPHEADER

 S BGPGYR=2009,BGPGYR=$O(^BGPCTRL("B",BGPGYR,0))

 S BGPX=0 F  S BGPX=$O(^BGPCTRL(BGPGYR,39,BGPX)) Q:BGPX'=+BGPX  D

 .I $Y>(IOSL-2) D CPHEADER Q:$D(BGPQ)

 .W !,^BGPCTRL(BGPGYR,39,BGPX,0)

 D CPDONE

 Q

CPHEADER ;EP

 G:'BGPPG CPHEAD1

 K DIR I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BGPQ="" Q

CPHEAD1 ;

 W:$D(IOF) @IOF

 S BGPPG=BGPPG+1

 I $G(BGPGUI),BGPPG'=1 W !,"ZZZZZZZ"

 W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BGPPG,!

 Q

CPDONE ;

 K DIR

 I $E(IOST)="C",IO=IO(0) S DIR(0)="EO",DIR("A")="End of report.  PRESS ENTER" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 K BGPTS,BGPS,BGPM,BGPET,BGPX,BGPGPYR

 Q

TSKMNCP ;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="CPPRINT^BGP9DPA",ZTDTH="",ZTDESC="CRS 09 SCHED REPORT DENOM" D ^%ZTLOAD D EOJ Q

 Q

BGP9DPA   ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT ; 03 Jun 2009  2:54 PM

 +1       ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009

 +2       ;

EP        ;EP - called from option interactive

 +1        DO EOJ

 +2        IF $DATA(IOF)

               WRITE @IOF

 +3        DO TERM^VALM0

 +4        SET BGPCTRL=$ORDER(^BGPCTRL("B",2009,0))

 +5        SET X=0

           FOR 

               SET X=$ORDER(^BGPCTRL(BGPCTRL,58,X))

               IF X'=+X

                   QUIT 

               WRITE !,^BGPCTRL(BGPCTRL,58,X,0)

 +6        KILL DIR

           SET DIR(0)="E"

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

           DO ^DIR

           KILL DIR

 +7        IF '$DATA(^XUSEC("BGPZ PATIENT LISTS",DUZ))

               WRITE !!,"You do not have the security access to print patient lists.",!,"Please see your supervisor or program manager if you feel you should have",!,"the BGPZ PATIENT LISTS security key.",!

               Begin DoDot:1

 +8                KILL DIR

                   SET DIR(0)="E"

                   SET DIR("A")="Press enter to continue"

                   DO ^DIR

                   KILL DIR

               End DoDot:1

               QUIT 

 +9       ;

 +10      ;W !!,IORVON,!,"STEPHANIE TO PROVIDE TEXT HERE",IORVOFF

 +11      ;W !!,"This option will produce a comprehensive National GPRA report for"

 +12      ;W !,"patients who have an appointment in a date range specified by"

 +13      ;W !,"the user in any clinic or in a selected set of clinics."

 +14      ;W !!,"You will be asked to enter the date range of the appointments and the"

 +15      ;W !,"clinic names if selecting a set of clinics.",!,"STEPHANIE TO PROVIDE TEXT HERE",!

RTYPE     ;

 +1        SET BGPRT1=""

 +2        SET DIR(0)="S^C:By CLINIC NAME for a specified appointment date range;P:Selected Patients w/Appointments;D:One Facility's or Divisions Appointments;A:Any selected set of patients regardless of appt status"

 +3        SET DIR("A")="Create List/Sort by"

           SET DIR("B")="C"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               DO EOJ

               QUIT 

 +5        SET BGPRT1=Y

 +6        IF BGPRT1="C"

               DO CLIN

               IF $GET(BGPQUIT)

                   GOTO RTYPE

               GOTO DATES

 +7        IF BGPRT1="D"

               DO DIV

               IF $GET(BGPQUIT)

                   GOTO RTYPE

               GOTO DATES

 +8        IF BGPRT1="P"

               DO GETPAT

               IF $GET(BGPQUIT)

                   GOTO RTYPE

               GOTO DATES

 +9        IF BGPRT1="A"

               DO SELPT

               IF $GET(BGPQUIT)

                   GOTO RTYPE

               GOTO ZIS

DATES      KILL BGPAED,BGPABD

 +1        KILL DIR

           WRITE !

           SET DIR(0)="DO^::E"

           SET DIR("A")="Enter Beginning Appointment Date"

 +2        DO ^DIR

           IF Y<1

               GOTO EOJ

           SET BGPABD=Y

 +3        KILL DIR

           SET DIR(0)="DO^::EX"

           SET DIR("A")="Enter Ending Appointment Date"

 +4        DO ^DIR

           IF Y<1

               GOTO EOJ

           SET BGPAED=Y

 +5       ;

 +6        IF BGPAED<BGPABD

               Begin DoDot:1

 +7                WRITE !!,$CHAR(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."

               End DoDot:1

               GOTO DATES

 +8        SET BGPASD=$$FMADD^XLFDT(BGPABD,-1)_".9999"

 +9       ;

ZIS       ;

 +1        SET BGPRTYPE=1

           SET BGP9RPTH=""

           SET BGPCPPL=1

           SET BGPINDT="G"

           SET BGP9GPU=1

           SET BGPALLPT=1

           SET BGPBEN=3

 +2        SET BGPHOME=$PIECE($GET(^BGPSITE(DUZ(2),0)),U,2)

 +3       ;I BGPHOME="" W !!,"Home Location not found in Site File!!",!,"PHN Visits counts to Home will be calculated using clinic 11 only!!" H 2

 +4       ;W !,"Your HOME location is defined as: ",$P(^DIC(4,BGPHOME,0),U)," asufac:  ",$P(^AUTTLOC(BGPHOME,0),U,10)

ENDDATE   ;

 +1       ;AI ;gather all gpra measures

 +2        SET X=0

           FOR 

               SET X=$ORDER(^BGPINDN("GPRA",1,X))

               IF X'=+X

                   QUIT 

               SET BGPIND(X)=""

 +3        SET X=$ORDER(^BGPCTRL("B",2009,0))

 +4        SET Y=^BGPCTRL(X,0)

 +5        SET BGPBD=$PIECE(Y,U,8)

           SET BGPED=$PIECE(Y,U,9)

 +6        SET BGPPBD=$PIECE(Y,U,10)

           SET BGPPED=$PIECE(Y,U,11)

 +7        SET BGPBBD=$PIECE(Y,U,12)

           SET BGPBED=$PIECE(Y,U,13)

 +8        SET BGPPER=$PIECE(Y,U,14)

           SET BGPQTR=3

 +9        GOTO NT

 +10       SET BGPBD=3030101

           SET BGPED=3031231

 +11       SET BGPPBD=3020101

           SET BGPPED=3021231

 +12       SET BGPBBD=3000101

           SET BGPBED=3001231

NT         SET BGPLIST="A"

 +1        SET BGPCPLC=0

 +2       ;S XBRP="PRINT^BGP9DPAW",XBRC="PROC^BGP9DPA",XBRX="EOJ^BGP9DPA",XBNS="BGP"

 +3       ;D ^XBDBQUE

 +4       ;

 +5        KILL IOP,%ZIS

 +6        WRITE !!

           SET %ZIS="PQM"

           DO ^%ZIS

 +7        IF POP

               DO EOJ

               QUIT 

ZIS1      ;

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

               GOTO TSKMN

DRIVER    ;

 +1        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +2        DO PROC^BGP9DPA

 +3        USE IO

 +4        DO PRINT^BGP9DPAW

 +5        DO ^%ZISC

 +6        DO EOJ

 +7        QUIT 

 +8       ;

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^BGP9DPA"

           SET ZTDTH=""

           SET ZTDESC="CRS 09 SCHED REPORT"

           DO ^%ZTLOAD

           DO EOJ

           QUIT 

 +6        QUIT 

EOJ       ;

 +1        DO ^XBFMK

 +2        KILL DIC,DIR,DFN

 +3        DO EN^XBVK("BGP")

           DO EN^XBVK("BSD")

           DO EN^XBVK("AMQQ")

 +4        KILL ^TMP($JOB)

 +5        QUIT 

 +6       ;

DIV       ;

 +1        SET BGPQUIT=""

           SET BGPDIVI=""

 +2        KILL DIC

 +3       ; I $O(^DG(40.8,"C",DUZ(2),0)) S DIC("B")=$P(^DIC(4,$O(^DG(40.8,"C",DUZ(2),0)),0),U)

           SET DIC="^DG(40.8,"

           SET DIC(0)="AEMQ"

 +4        DO ^DIC

           KILL DIC

 +5        IF Y=-1

               SET BGPQUIT=1

               QUIT 

 +6        SET BGPDIVI=+Y

CLIN      ;

 +1        SET BGPCLN=""

           SET BGPQUIT=""

 +2        SET DIR(0)="S^A:ANY Clinic;S:One or more selected Clinics"

           SET DIR("A")="Include patients with Appointments to"

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               SET BGPQUIT=1

               QUIT 

 +4        SET BGPCLN=Y

 +5        IF BGPCLN="A"

               KILL BGPCLN

               QUIT 

 +6       ;get which clinics

 +7        KILL BGPCLN

CLIN1     ;

 +1        WRITE !

           SET DIC="^SC("

           SET DIC(0)="AEMZQ"

           SET DIC("A")="Select CLINIC: "

 +2        SET DIC("S")="I $P(^(0),U,3)=""C"""

           DO ^DIC

           KILL DIC

 +3        IF Y=-1

               IF '$DATA(BGPCLN)

                   GOTO CLIN

 +4        IF X="^"

               GOTO CLIN

 +5        IF Y=""

               IF $DATA(BGPCLN)

                   QUIT 

 +6        IF Y=-1

               IF $DATA(BGPCLN)

                   QUIT 

 +7        IF X=""

               IF '$DATA(BGPCLN)

                   GOTO CLIN

 +8        SET BGPCLN(+Y)=""

 +9        GOTO CLIN1

GETPAT    ;

 +1        KILL BGPPATS

GETPAT1   ;

 +1        SET BGPQUIT=""

           SET BGPDIVI=""

 +2        KILL DIC

 +3        SET DIC="^AUPNPAT("

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC

 +4        IF Y=-1

               IF '$DATA(BGPPATS)

                   SET BGPQUIT=1

                   QUIT 

 +5        SET BGPPATS(+Y)=""

 +6        QUIT 

SELPT     ;

 +1        KILL BGPPATS

 +2        SET BGPSMI=0

 +3        FOR 

               Begin DoDot:1

 +4                SET DIR(0)="FOU"

                   SET DIR("A")="Select patient(s)"

 +5                SET DIR("?",1)="     Enter a patient's HRN or name (HORSECHIEF,JOHN DOE or HORSECHIEF,JOHN)."

                   SET DIR("?",2)=""

 +6                SET DIR("?",3)="     A template can also be selected by typing a ""["" followed by"

                   SET DIR("?",4)="     the template name."

 +7                SET DIR("?",5)=""

                   SET DIR("?")="     ""[??"" will list your templates."

                   SET DIR("??")="^D LIST^BGP9DPAP"

 +8                DO ^DIR

                   KILL DIR

 +9                IF X[U

                       SET X=U

 +10               IF $EXTRACT(X)="["

                       Begin DoDot:2

 +11                       SET X=$EXTRACT(X,2,$LENGTH(X))

 +12                       KILL DIC

                           SET DIC=.401

                           SET DIC(0)=$SELECT(X="":"AEMQ",1:"EMQ")

                           SET DIC("S")="I $P(^(0),U,4)=2!($P(^(0),U,4)=9000001),($P(^(0),U,5)=$G(DUZ))!(DUZ(0)=""@"")"

                           DO ^DIC

 +13                       IF Y>0

                               Begin DoDot:3

 +14                               SET BGPPATS=0

                                   SET Y=+Y

                                   FOR BGPMJ=0:1

                                       SET BGPPATS=$ORDER(^DIBT(Y,1,BGPPATS))

                                       IF 'BGPPATS

                                           QUIT 

                                       SET BGPSMI=BGPSMI+1

                                       SET BGPPATS(BGPSMI)=BGPPATS

 +15                               WRITE !,BGPMJ,$SELECT(BGPMJ=1:" entry",1:" entries")," added."

                               End DoDot:3

                       End DoDot:2

                       QUIT 

 +16               KILL DIC

                   SET DIC=9000001

                   SET DIC(0)="EQM"

                   DO ^DIC

 +17               IF Y>0

                       SET BGPPATS=+Y

                       SET BGPSMI=BGPSMI+1

                       SET BGPPATS(BGPSMI)=BGPPATS

               End DoDot:1

               IF U[X

                   QUIT 

 +18       WRITE !

 +19       IF X=U

               KILL BGPPATS

               WRITE !,"All selections cancelled!"

 +20       IF '$ORDER(BGPPATS(""))

               WRITE !,"No patients selected."

               SET BGPQUIT=1

               QUIT 

 +21       QUIT 

TEST      ;

 +1        DO BDMG(1,3040101,3041231,13)

 +2        QUIT 

BDMG(BGPBD,BGPED,BGPCLN) ;EP - GUI DMS Entry Point

 +1       ;cmi/anch/maw added 10/19/2004

 +2        SET BGPSD=$$FMADD^XLFDT(BGPBD,-1)_".9999"

 +3        SET BGPGUI=1

 +4       ;maw

           NEW BGPOPT,BGPNOW,BGPIEN

 +5        SET BGPOPT="List Patients on a Register w/an Appointment"

 +6        SET BGPRTYPE=1

           SET BGP9RPTH=""

           SET BGPCPPL=1

           SET BGPINDT="G"

           SET BGP9GPU=1

 +7        DO NOW^%DTC

 +8        SET BGPNOW=$GET(%)

 +9        KILL DD,D0,DIC

 +10       SET X=DUZ_$$NOW^XLFDT

 +11       SET DIC("DR")=".02////"_DUZ_";.03////"_BGPNOW_";.06///"_$GET(BGPOPT)_";.07////R"

 +12       SET DIC="^BGPGUIN("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9001004.4

 +13       DO FILE^DICN

 +14       KILL DIADD,DLAYGO,DIC,DA

 +15       IF Y=-1

               SET BGPIEN=-1

               QUIT 

 +16       SET BGPIEN=+Y

 +17      ;cmi/maw added

           SET BDMGIEN=BGPIEN

 +18       DO ^XBFMK

 +19       KILL ZTSAVE

           SET ZTSAVE("*")=""

 +20       SET ZTIO=""

           SET ZTDTH=$$NOW^XLFDT

           SET ZTRTN="GUIEP^BGP9DPA"

           SET ZTDESC="GUI CN GRPA APPT"

           DO ^%ZTLOAD

 +21       DO EOJ

 +22       QUIT 

GUIEP     ;EP

 +1        DO PROC

 +2        KILL ^TMP($JOB,"BGP9DPA")

 +3        SET IOM=80

 +4        DO GUIR^XBLM("PRINT^BGP9DPA","^TMP($J,""BGP9DPA"",")

 +5        SET X=0

           SET C=0

           FOR 

               SET X=$ORDER(^TMP($JOB,"BGP9DPA",X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +6                SET BGPDATA=^TMP($JOB,"BGP9DPA",X)