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
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)
+7 IF BGPDATA="ZZZZZZZ"
SET BGPDATA=$CHAR(12)
+8 SET ^BGPGUIN(BGPIEN,11,X,0)=BGPDATA
SET C=C+1
End DoDot:1
+9 SET ^BGPGUIN(BGPIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
+10 SET DA=BGPIEN
SET DIK="^BGPGUIN("
DO IX1^DIK
+11 DO ENDLOG
+12 KILL ^TMP($JOB,"BGP9DPA")
+13 SET ZTREQ="@"
+14 QUIT
+15 ;
GUIECP ;EP
+1 KILL ^TMP($JOB,"BGP9DPA")
+2 SET IOM=80
+3 DO GUIR^XBLM("CPPRINT^BGP9DPA","^TMP($J,""BGP9DPA"",")
+4 SET X=0
SET C=0
FOR
SET X=$ORDER(^TMP($JOB,"BGP9DPA",X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET BGPDATA=^TMP($JOB,"BGP9DPA",X)
+6 IF BGPDATA="ZZZZZZZ"
SET BGPDATA=$CHAR(12)
+7 SET ^BGPGUIN(BGPIEN,11,X,0)=BGPDATA
SET C=C+1
End DoDot:1
+8 SET ^BGPGUIN(BGPIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
+9 SET DA=BGPIEN
SET DIK="^BGPGUIN("
DO IX1^DIK
+10 DO ENDLOG
+11 KILL ^TMP($JOB,"BGP9DPA")
+12 SET ZTREQ="@"
+13 QUIT
+14 ;
ENDLOG ;-- write the end of the log
+1 DO NOW^%DTC
+2 SET BGPNOW=$GET(%)
+3 SET DIE="^BGPGUIN("
SET DA=BGPIEN
SET DR=".04////"_BGPNOW_";.06////C"
+4 DO ^DIE
+5 KILL DIE,DR,DA
+6 QUIT
+7 ;
PROC ;EP
+1 DO JRNL^BGP9UTL
+2 SET BGPGPRAJ=$JOB
SET BGPGPRAH=$HOROLOG
+3 SET BGPCHWC=0
+4 SET BGPCHSO=$PIECE($GET(^BGPSITE(DUZ(2),0)),U,6)
+5 ;calculate 3 years before end of each time frame
+6 SET BGP3YE=$$FMADD^XLFDT(BGPED,-1096)
+7 KILL ^XTMP("BGP9DPA",BGPGPRAJ,BGPGPRAH)
+8 SET ^XTMP("BGP9DPA",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PTS WITH GPRA DATA"
+9 KILL BGPAPPT,BGPAPPTS
+10 SET BGPTA=0
+11 IF BGPRT1="A"
Begin DoDot:1
+12 SET BGPSOX=0
FOR
SET BGPSOX=$ORDER(BGPPATS(BGPSOX))
IF BGPSOX'=+BGPSOX
QUIT
Begin DoDot:2
+13 SET DFN=BGPPATS(BGPSOX)
+14 IF $PIECE($GET(^DPT(DFN,0)),U)["DEMO,PATIENT"
QUIT
+15 IF $PIECE($GET(^BGPSITE(DUZ(2),0)),U,12)
IF $DATA(^DIBT($PIECE(^BGPSITE(DUZ(2),0),U,12),1,DFN))
QUIT
+16 SET BGPIISO=1
SET BGPISST="A"
DO PROCCY^BGP9D1
End DoDot:2
+17 QUIT
End DoDot:1
QUIT
+18 SET BGPSD=$$FMADD^XLFDT(BGPABD,-1)
+19 SET BGPOD=BGPSD
FOR
SET BGPOD=$$FMADD^XLFDT(BGPOD,1)
IF BGPOD>BGPAED
QUIT
Begin DoDot:1
+20 KILL BGPAPPT
+21 SET BGPCLN=$SELECT('$ORDER(BGPCLN(0)):"ALL",1:"")
+22 SET BGPARRAY="BGPAPPT("
+23 IF BGPRT1="D"
SET BGPCLN("DEV")=BGPDIVI
+24 DO LIST^BSDAPI2(BGPOD,"W",.BGPCLN,BGPARRAY)
+25 SET X=0
FOR
SET X=$ORDER(BGPAPPT(X))
IF X'=+X
QUIT
Begin DoDot:2
+26 SET Y=$PIECE(BGPAPPT(X),U)
+27 ;if patients only want that set of patients
IF BGPRT1="P"
IF Y
IF '$DATA(BGPPATS(Y))
QUIT
+28 IF Y
IF $PIECE($GET(^DPT(Y,0)),U)["DEMO,PATIENT"
QUIT
+29 IF $PIECE($GET(^BGPSITE(DUZ(2),0)),U,12)
IF $DATA(^DIBT($PIECE(^BGPSITE(DUZ(2),0),U,12),1,Y))
QUIT
+30 SET BGPTA=BGPTA+1
SET BGPAPPTS(BGPTA)=BGPAPPT(X)
End DoDot:2
+31 QUIT
End DoDot:1
+32 SET BGPSOX=0
FOR
SET BGPSOX=$ORDER(BGPAPPTS(BGPSOX))
IF BGPSOX'=+BGPSOX
QUIT
Begin DoDot:1
+33 SET DFN=$PIECE(BGPAPPTS(BGPSOX),U,1)
+34 IF $PIECE($GET(^DPT(DFN,0)),U,1)["DEMO,PATIENT"
QUIT
+35 IF $PIECE($GET(^BGPSITE(DUZ(2),0)),U,12)
IF $DATA(^DIBT($PIECE(^BGPSITE(DUZ(2),0),U,12),1,DFN))
QUIT
+36 SET BGPIISO=1
SET BGPISST=BGPRT1
SET BGPISSO=1
DO PROCCY^BGP9D1
+37 QUIT
End DoDot:1
+38 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 KILL DIR
+4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR("A")="End of report. Press Enter"
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 ;----------
COVPAGE ;EP - called from option to display the cover page
+1 ;
+2 WRITE !!,"This option is used to print out the denominator definitions"
+3 WRITE !,"used in the GPRA & PART Measures Forecast Patient List.",!!
ZISCP ;
+1 KILL IOP,%ZIS
+2 WRITE !!
SET %ZIS="PQM"
DO ^%ZIS
+3 IF POP
DO EOJ
QUIT
+4 ;
+5 IF $DATA(IO("Q"))
GOTO TSKMNCP
+6 ;S XBRP="CPPRINT^BGP9DPA",XBRC="",XBRX="EOJ^BGP9DPA",XBNS="BGP"
+7 ;D ^XBDBQUE
+8 ;
CPPRINT ;EP - called from xbdbque
+1 USE IO
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 SET BGPPG=0
+4 SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:IOSL)
+5 ;cmi/maw added 1/14/2008
IF $GET(BGPGUI)
SET IOSL=55
+6 DO CPHEADER
+7 SET BGPGYR=2009
SET BGPGYR=$ORDER(^BGPCTRL("B",BGPGYR,0))
+8 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPCTRL(BGPGYR,39,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:1
+9 IF $Y>(IOSL-2)
DO CPHEADER
IF $DATA(BGPQ)
QUIT
+10 WRITE !,^BGPCTRL(BGPGYR,39,BGPX,0)
End DoDot:1
+11 DO CPDONE
+12 QUIT
+1 IF 'BGPPG
GOTO CPHEAD1
+2 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BGPQ=""
QUIT
CPHEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 SET BGPPG=BGPPG+1
+3 IF $GET(BGPGUI)
IF BGPPG'=1
WRITE !,"ZZZZZZZ"
+4 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BGPPG,!
+5 QUIT
CPDONE ;
+1 KILL DIR
+2 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
SET DIR(0)="EO"
SET DIR("A")="End of report. PRESS ENTER"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 KILL BGPTS,BGPS,BGPM,BGPET,BGPX,BGPGPYR
+4 QUIT
TSKMNCP ;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="CPPRINT^BGP9DPA"
SET ZTDTH=""
SET ZTDESC="CRS 09 SCHED REPORT DENOM"
DO ^%ZTLOAD
DO EOJ
QUIT
+6 QUIT
