BGP1DPA ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT 03 Jun 2011 2:54 PM ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
EP ;EP - called from option interactive
D EOJ
W:$D(IOF) @IOF
D TERM^VALM0
S BGPCTRL=$O(^BGPCTRL("B",2011,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
;
D TAXCHK^BGP1XTCN
S X=$$DEMOCHK^BGP1UTL2()
I 'X W !!,"Exiting Report....." D PAUSE^BGP1CL,EOJ Q
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 TEMP
I BGPRT1="D" D DIV G:$G(BGPQUIT) RTYPE G TEMP
I BGPRT1="P" D GETPAT G:$G(BGPQUIT) RTYPE G TEMP
I BGPRT1="A" D SELPT G:$G(BGPQUIT) RTYPE G TEMP
TEMP ;search template created?
S BGPSTMP=""
S DIR(0)="S^R:Forecast Report for the Patients;S:Search Template of the Patients",DIR("A")="Do you wish to create",DIR("B")="R" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G RTYPE
I Y="R" G DATES
D STMP
I $G(BGPSTMP)="" G TEMP
DATES ;
I BGPRT1="A" G ZIS
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 $$FMDIFF^XLFDT(BGPAED,BGPABD)>7 W !!,"You can only run this for a maximum 7 day time period." G DATES
;
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"
ADDON ;
K BGPQ
I BGPRT1="C"!(BGPRT1="D") D G:$D(BGPQ) RTYPE
.S DIR(0)="S^A:ALL Patients with Appointments in the date range;O:ONLY Patients added on since a specified date"
.S DIR("A")="Run the forecast report for",DIR("B")="A" KILL DA D ^DIR KILL DIR
.I $D(DIRUT) S BGPQ=1 Q
.S BGPRT2=Y
.I BGPRT2="A" Q
.S BGPADDOD=""
.S DIR(0)="D^:"_DT_":EP",DIR("A")="Patients 'Added On' on or after what date" KILL DA D ^DIR KILL DIR
.I $D(DIRUT) S BGPQ=1 Q
.I Y="" S BGPQ=1 Q
.S BGPADDOD=Y
;
ZIS ;
S BGPRTYPE=1,BGP1RPTH="",BGPCPPL=1,BGPINDB="G",BGP1GPU=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(^BGPINDB("GPRA",1,X)) Q:X'=+X S BGPIND(X)=""
S X=$O(^BGPCTRL("B",2011,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=3020111,BGPPED=3021231
S BGPBBD=3000101,BGPBED=3001231
NT S BGPLIST="A"
S BGPCPLC=0
;S XBRP="PRINT^BGP1DPAW",XBRC="PROC^BGP1DPA",XBRX="EOJ^BGP1DPA",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^BGP1DPA
U IO
D PRINT^BGP1DPAW
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^BGP1DPA",ZTDTH="",ZTDESC="CRS 11 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^BGP1DPAP"
.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,BGP1RPTH="",BGPCPPL=1,BGPINDB="G",BGP1GPU=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="^BGPGUIB(",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^BGP1DPA",ZTDESC="GUI CN GRPA APPT" D ^%ZTLOAD
D EOJ
Q
GUIEP ;EP
D PROC
K ^TMP($J,"BGP1DPA")
S IOM=80
D GUIR^XBLM("PRINT^BGP1DPA","^TMP($J,""BGP1DPA"",")
S X=0,C=0 F S X=$O(^TMP($J,"BGP1DPA",X)) Q:X'=+X D
.S BGPDATA=^TMP($J,"BGP1DPA",X)
.I BGPDATA="ZZZZZZZ" S BGPDATA=$C(12)
.S ^BGPGUIB(BGPIEN,11,X,0)=BGPDATA,C=C+1
S ^BGPGUIB(BGPIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
S DA=BGPIEN,DIK="^BGPGUIB(" D IX1^DIK
D ENDLOG
K ^TMP($J,"BGP1DPA")
S ZTREQ="@"
Q
;
GUIECP ;EP
K ^TMP($J,"BGP1DPA")
S IOM=80
D GUIR^XBLM("CPPRINT^BGP1DPA","^TMP($J,""BGP1DPA"",")
S X=0,C=0 F S X=$O(^TMP($J,"BGP1DPA",X)) Q:X'=+X D
.S BGPDATA=^TMP($J,"BGP1DPA",X)
.I BGPDATA="ZZZZZZZ" S BGPDATA=$C(12)
.S ^BGPGUIB(BGPIEN,11,X,0)=BGPDATA,C=C+1
S ^BGPGUIB(BGPIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
S DA=BGPIEN,DIK="^BGPGUIB(" D IX1^DIK
D ENDLOG
K ^TMP($J,"BGP1DPA")
S ZTREQ="@"
Q
;
ENDLOG ;-- write the end of the log
D NOW^%DTC
S BGPNOW=$G(%)
S DIE="^BGPGUIB(",DA=BGPIEN,DR=".04////"_BGPNOW_";.06////C"
D ^DIE
K DIE,DR,DA
Q
;
PROC ;EP
D JRNL^BGP1UTL
S BGPGPRAJ=$J,BGPGPRAH=$H
S BGPCHWC=0
S BGPCHSO=$P($G(^BGPSITE(DUZ(2),0)),U,6)
S BGPURBAN=$P($G(^BGPSITE(DUZ(2),0)),U,13)
;calculate 3 years before end of each time frame
S BGP3YE=$$FMADD^XLFDT(BGPED,-1096)
K ^XTMP("BGP1DPA",BGPGPRAJ,BGPGPRAH)
S ^XTMP("BGP1DPA",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 X=$O(^DIBT("B","RPMS DEMO PATIENT NAMES",0)) I X Q:$D(^DIBT(X,1,DFN))
..I $G(BGPSTMP) S ^DIBT(BGPSTMP,1,DFN)="" Q
..S BGPIISO=1,BGPISST="A" D PROCCY^BGP1D1
.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 Z=$O(^DIBT("B","RPMS DEMO PATIENT NAMES",0)) I Z Q:$D(^DIBT(Z,1,Y))
..;check appt made date if want add ons only
..S G=0
..I BGPRT1="C"!(BGPRT1="D"),BGPRT2="O" D
...;get date appt made Y is patient, C is clinic ien, D is appt date/time
...S C=$P(BGPAPPT(X),U,2),D=$P(BGPAPPT(X),U,3)
...S (A,G)=0 F S A=$O(^SC(C,"S",D,1,A)) Q:A'=+A!(G) D
....Q:'$D(^SC(C,"S",D,1,A,0))
....Q:$P(^SC(C,"S",D,1,A,0),U,1)'=Y
....I $P(^SC(C,"S",D,1,A,0),U,7)<BGPADDOD K BGPAPPT(X) S G=1 ;don't display this one
..Q:G
..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 X=$O(^DIBT("B","RPMS DEMO PATIENT NAMES",0)) I X Q:$D(^DIBT(X,1,DFN))
.I $G(BGPSTMP) S ^DIBT(BGPSTMP,1,DFN)="" Q
.S BGPIISO=1,BGPISST=BGPRT1,BGPISSO=1 D PROCCY^BGP1D1
.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^BGP1DPA",XBRC="",XBRX="EOJ^BGP1DPA",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/2010
D CPHEADER
S BGPGYR=2011,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 ;
I BGPPG 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^BGP1DPA",ZTDTH="",ZTDESC="CRS 11 SCHED REPORT DENOM" D ^%ZTLOAD D EOJ Q
Q
STMP ;EP
EN1 ;EP Help
K BGPQUIT S BGPSTMP=""
EN2 K DIC,DLAYGO S DLAYGO=.401,DIC="^DIBT(",DIC(0)="AELMQZ",DIC("A")="Patient Search Template: ",DIC("S")="I $P(^(0),U,4)=9000001&($P(^(0),U,5)=DUZ)"
D ^DIC K DIC,DLAYGO
I +Y<1 W !!,"No Search Template selected." H 2 S BGPQUIT=1 Q
S BGPSTMP=+Y,BGPSNAM=$P(^DIBT(BGPSTMP,0),U)
DUP I '$P(Y,U,3) D I Q K BGPSTMP,Y G EN2
.S Q=""
.W !
.S DIR(0)="Y",DIR("A")="That template already exists!! Do you want to overwrite it",DIR("B")="N" K DA D ^DIR K DIR
.I $D(DIRUT) S Q=1 Q
.I 'Y S Q=1 Q
.L +^DIBT(BGPSTMP):10 Q:'$T
.S BGPSTN=$P(^DIBT(BGPSTMP,0),U) S DA=BGPSTMP,DIK="^DIBT(" D ^DIK
.S ^DIBT(BGPSTMP,0)=BGPSNAM,DA=BGPSTMP,DIK="^DIBT(" D IX1^DIK
.L -^DIBT(BGPSTMP)
.Q
I BGPSTMP,$D(^DIBT(BGPSTMP)) D
.W !,?5,"An unduplicated PATIENT list resulting from this report",!,?5,"will be stored in the",BGPSNAM," Search Template.",!
.K ^DIBT(BGPSTMP,1)
.S DHIT="S ^DIBT("_BGPSTMP_",1,DFN)="""""
.S DIE="^DIBT(",DA=BGPSTMP,DR="2////"_DT_";3////M;4////9000001;5////"_DUZ_";6////M"
.D ^DIE
.K DIE,DA,DR
Q
BGP1DPA ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT 03 Jun 2011 2:54 PM ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+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",2011,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 DO TAXCHK^BGP1XTCN
+11 SET X=$$DEMOCHK^BGP1UTL2()
+12 IF 'X
WRITE !!,"Exiting Report....."
DO PAUSE^BGP1CL
DO EOJ
QUIT
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 TEMP
+7 IF BGPRT1="D"
DO DIV
IF $GET(BGPQUIT)
GOTO RTYPE
GOTO TEMP
+8 IF BGPRT1="P"
DO GETPAT
IF $GET(BGPQUIT)
GOTO RTYPE
GOTO TEMP
+9 IF BGPRT1="A"
DO SELPT
IF $GET(BGPQUIT)
GOTO RTYPE
GOTO TEMP
TEMP ;search template created?
+1 SET BGPSTMP=""
+2 SET DIR(0)="S^R:Forecast Report for the Patients;S:Search Template of the Patients"
SET DIR("A")="Do you wish to create"
SET DIR("B")="R"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO RTYPE
+4 IF Y="R"
GOTO DATES
+5 DO STMP
+6 IF $GET(BGPSTMP)=""
GOTO TEMP
DATES ;
+1 IF BGPRT1="A"
GOTO ZIS
+2 KILL BGPAED,BGPABD
+3 KILL DIR
WRITE !
SET DIR(0)="DO^::E"
SET DIR("A")="Enter Beginning Appointment Date"
+4 DO ^DIR
IF Y<1
GOTO EOJ
SET BGPABD=Y
+5 KILL DIR
SET DIR(0)="DO^::EX"
SET DIR("A")="Enter Ending Appointment Date"
+6 DO ^DIR
IF Y<1
GOTO EOJ
SET BGPAED=Y
+7 IF $$FMDIFF^XLFDT(BGPAED,BGPABD)>7
WRITE !!,"You can only run this for a maximum 7 day time period."
GOTO DATES
+8 ;
+9 IF BGPAED<BGPABD
Begin DoDot:1
+10 WRITE !!,$CHAR(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
End DoDot:1
GOTO DATES
+11 SET BGPASD=$$FMADD^XLFDT(BGPABD,-1)_".9999"
ADDON ;
+1 KILL BGPQ
+2 IF BGPRT1="C"!(BGPRT1="D")
Begin DoDot:1
+3 SET DIR(0)="S^A:ALL Patients with Appointments in the date range;O:ONLY Patients added on since a specified date"
+4 SET DIR("A")="Run the forecast report for"
SET DIR("B")="A"
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
SET BGPQ=1
QUIT
+6 SET BGPRT2=Y
+7 IF BGPRT2="A"
QUIT
+8 SET BGPADDOD=""
+9 SET DIR(0)="D^:"_DT_":EP"
SET DIR("A")="Patients 'Added On' on or after what date"
KILL DA
DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)
SET BGPQ=1
QUIT
+11 IF Y=""
SET BGPQ=1
QUIT
+12 SET BGPADDOD=Y
End DoDot:1
IF $DATA(BGPQ)
GOTO RTYPE
+13 ;
ZIS ;
+1 SET BGPRTYPE=1
SET BGP1RPTH=""
SET BGPCPPL=1
SET BGPINDB="G"
SET BGP1GPU=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(^BGPINDB("GPRA",1,X))
IF X'=+X
QUIT
SET BGPIND(X)=""
+3 SET X=$ORDER(^BGPCTRL("B",2011,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=3020111
SET BGPPED=3021231
+12 SET BGPBBD=3000101
SET BGPBED=3001231
NT SET BGPLIST="A"
+1 SET BGPCPLC=0
+2 ;S XBRP="PRINT^BGP1DPAW",XBRC="PROC^BGP1DPA",XBRX="EOJ^BGP1DPA",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^BGP1DPA
+3 USE IO
+4 DO PRINT^BGP1DPAW
+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^BGP1DPA"
SET ZTDTH=""
SET ZTDESC="CRS 11 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^BGP1DPAP"
+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 BGP1RPTH=""
SET BGPCPPL=1
SET BGPINDB="G"
SET BGP1GPU=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="^BGPGUIB("
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^BGP1DPA"
SET ZTDESC="GUI CN GRPA APPT"
DO ^%ZTLOAD
+21 DO EOJ
+22 QUIT
GUIEP ;EP
+1 DO PROC
+2 KILL ^TMP($JOB,"BGP1DPA")
+3 SET IOM=80
+4 DO GUIR^XBLM("PRINT^BGP1DPA","^TMP($J,""BGP1DPA"",")
+5 SET X=0
SET C=0
FOR
SET X=$ORDER(^TMP($JOB,"BGP1DPA",X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET BGPDATA=^TMP($JOB,"BGP1DPA",X)
+7 IF BGPDATA="ZZZZZZZ"
SET BGPDATA=$CHAR(12)
+8 SET ^BGPGUIB(BGPIEN,11,X,0)=BGPDATA
SET C=C+1
End DoDot:1
+9 SET ^BGPGUIB(BGPIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
+10 SET DA=BGPIEN
SET DIK="^BGPGUIB("
DO IX1^DIK
+11 DO ENDLOG
+12 KILL ^TMP($JOB,"BGP1DPA")
+13 SET ZTREQ="@"
+14 QUIT
+15 ;
GUIECP ;EP
+1 KILL ^TMP($JOB,"BGP1DPA")
+2 SET IOM=80
+3 DO GUIR^XBLM("CPPRINT^BGP1DPA","^TMP($J,""BGP1DPA"",")
+4 SET X=0
SET C=0
FOR
SET X=$ORDER(^TMP($JOB,"BGP1DPA",X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET BGPDATA=^TMP($JOB,"BGP1DPA",X)
+6 IF BGPDATA="ZZZZZZZ"
SET BGPDATA=$CHAR(12)
+7 SET ^BGPGUIB(BGPIEN,11,X,0)=BGPDATA
SET C=C+1
End DoDot:1
+8 SET ^BGPGUIB(BGPIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
+9 SET DA=BGPIEN
SET DIK="^BGPGUIB("
DO IX1^DIK
+10 DO ENDLOG
+11 KILL ^TMP($JOB,"BGP1DPA")
+12 SET ZTREQ="@"
+13 QUIT
+14 ;
ENDLOG ;-- write the end of the log
+1 DO NOW^%DTC
+2 SET BGPNOW=$GET(%)
+3 SET DIE="^BGPGUIB("
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^BGP1UTL
+2 SET BGPGPRAJ=$JOB
SET BGPGPRAH=$HOROLOG
+3 SET BGPCHWC=0
+4 SET BGPCHSO=$PIECE($GET(^BGPSITE(DUZ(2),0)),U,6)
+5 SET BGPURBAN=$PIECE($GET(^BGPSITE(DUZ(2),0)),U,13)
+6 ;calculate 3 years before end of each time frame
+7 SET BGP3YE=$$FMADD^XLFDT(BGPED,-1096)
+8 KILL ^XTMP("BGP1DPA",BGPGPRAJ,BGPGPRAH)
+9 SET ^XTMP("BGP1DPA",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PTS WITH GPRA DATA"
+10 KILL BGPAPPT,BGPAPPTS
+11 SET BGPTA=0
+12 IF BGPRT1="A"
Begin DoDot:1
+13 SET BGPSOX=0
FOR
SET BGPSOX=$ORDER(BGPPATS(BGPSOX))
IF BGPSOX'=+BGPSOX
QUIT
Begin DoDot:2
+14 SET DFN=BGPPATS(BGPSOX)
+15 IF $PIECE($GET(^DPT(DFN,0)),U)["DEMO,PATIENT"
QUIT
+16 ;I $P($G(^BGPSITE(DUZ(2),0)),U,12) Q:$D(^DIBT($P(^BGPSITE(DUZ(2),0),U,12),1,DFN))
+17 SET X=$ORDER(^DIBT("B","RPMS DEMO PATIENT NAMES",0))
IF X
IF $DATA(^DIBT(X,1,DFN))
QUIT
+18 IF $GET(BGPSTMP)
SET ^DIBT(BGPSTMP,1,DFN)=""
QUIT
+19 SET BGPIISO=1
SET BGPISST="A"
DO PROCCY^BGP1D1
End DoDot:2
+20 QUIT
End DoDot:1
QUIT
+21 SET BGPSD=$$FMADD^XLFDT(BGPABD,-1)
+22 SET BGPOD=BGPSD
FOR
SET BGPOD=$$FMADD^XLFDT(BGPOD,1)
IF BGPOD>BGPAED
QUIT
Begin DoDot:1
+23 KILL BGPAPPT
+24 SET BGPCLN=$SELECT('$ORDER(BGPCLN(0)):"ALL",1:"")
+25 SET BGPARRAY="BGPAPPT("
+26 IF BGPRT1="D"
SET BGPCLN("DEV")=BGPDIVI
+27 DO LIST^BSDAPI2(BGPOD,"W",.BGPCLN,BGPARRAY)
+28 SET X=0
FOR
SET X=$ORDER(BGPAPPT(X))
IF X'=+X
QUIT
Begin DoDot:2
+29 SET Y=$PIECE(BGPAPPT(X),U)
+30 ;if patients only want that set of patients
IF BGPRT1="P"
IF Y
IF '$DATA(BGPPATS(Y))
QUIT
+31 IF Y
IF $PIECE($GET(^DPT(Y,0)),U)["DEMO,PATIENT"
QUIT
+32 ;I $P($G(^BGPSITE(DUZ(2),0)),U,12) Q:$D(^DIBT($P(^BGPSITE(DUZ(2),0),U,12),1,Y))
+33 SET Z=$ORDER(^DIBT("B","RPMS DEMO PATIENT NAMES",0))
IF Z
IF $DATA(^DIBT(Z,1,Y))
QUIT
+34 ;check appt made date if want add ons only
+35 SET G=0
+36 IF BGPRT1="C"!(BGPRT1="D")
IF BGPRT2="O"
Begin DoDot:3
+37 ;get date appt made Y is patient, C is clinic ien, D is appt date/time
+38 SET C=$PIECE(BGPAPPT(X),U,2)
SET D=$PIECE(BGPAPPT(X),U,3)
+39 SET (A,G)=0
FOR
SET A=$ORDER(^SC(C,"S",D,1,A))
IF A'=+A!(G)
QUIT
Begin DoDot:4
+40 IF '$DATA(^SC(C,"S",D,1,A,0))
QUIT
+41 IF $PIECE(^SC(C,"S",D,1,A,0),U,1)'=Y
QUIT
+42 ;don't display this one
IF $PIECE(^SC(C,"S",D,1,A,0),U,7)<BGPADDOD
KILL BGPAPPT(X)
SET G=1
End DoDot:4
End DoDot:3
+43 IF G
QUIT
+44 SET BGPTA=BGPTA+1
SET BGPAPPTS(BGPTA)=BGPAPPT(X)
End DoDot:2
+45 QUIT
End DoDot:1
+46 SET BGPSOX=0
FOR
SET BGPSOX=$ORDER(BGPAPPTS(BGPSOX))
IF BGPSOX'=+BGPSOX
QUIT
Begin DoDot:1
+47 SET DFN=$PIECE(BGPAPPTS(BGPSOX),U,1)
+48 IF $PIECE($GET(^DPT(DFN,0)),U,1)["DEMO,PATIENT"
QUIT
+49 ;I $P($G(^BGPSITE(DUZ(2),0)),U,12) Q:$D(^DIBT($P(^BGPSITE(DUZ(2),0),U,12),1,DFN))
+50 SET X=$ORDER(^DIBT("B","RPMS DEMO PATIENT NAMES",0))
IF X
IF $DATA(^DIBT(X,1,DFN))
QUIT
+51 IF $GET(BGPSTMP)
SET ^DIBT(BGPSTMP,1,DFN)=""
QUIT
+52 SET BGPIISO=1
SET BGPISST=BGPRT1
SET BGPISSO=1
DO PROCCY^BGP1D1
+53 QUIT
End DoDot:1
+54 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^BGP1DPA",XBRC="",XBRX="EOJ^BGP1DPA",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/2010
IF $GET(BGPGUI)
SET IOSL=55
+6 DO CPHEADER
+7 SET BGPGYR=2011
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 BGPPG
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^BGP1DPA"
SET ZTDTH=""
SET ZTDESC="CRS 11 SCHED REPORT DENOM"
DO ^%ZTLOAD
DO EOJ
QUIT
+6 QUIT
STMP ;EP
EN1 ;EP Help
+1 KILL BGPQUIT
SET BGPSTMP=""
EN2 KILL DIC,DLAYGO
SET DLAYGO=.401
SET DIC="^DIBT("
SET DIC(0)="AELMQZ"
SET DIC("A")="Patient Search Template: "
SET DIC("S")="I $P(^(0),U,4)=9000001&($P(^(0),U,5)=DUZ)"
+1 DO ^DIC
KILL DIC,DLAYGO
+2 IF +Y<1
WRITE !!,"No Search Template selected."
HANG 2
SET BGPQUIT=1
QUIT
+3 SET BGPSTMP=+Y
SET BGPSNAM=$PIECE(^DIBT(BGPSTMP,0),U)
DUP IF '$PIECE(Y,U,3)
Begin DoDot:1
+1 SET Q=""
+2 WRITE !
+3 SET DIR(0)="Y"
SET DIR("A")="That template already exists!! Do you want to overwrite it"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
SET Q=1
QUIT
+5 IF 'Y
SET Q=1
QUIT
+6 LOCK +^DIBT(BGPSTMP):10
IF '$TEST
QUIT
+7 SET BGPSTN=$PIECE(^DIBT(BGPSTMP,0),U)
SET DA=BGPSTMP
SET DIK="^DIBT("
DO ^DIK
+8 SET ^DIBT(BGPSTMP,0)=BGPSNAM
SET DA=BGPSTMP
SET DIK="^DIBT("
DO IX1^DIK
+9 LOCK -^DIBT(BGPSTMP)
+10 QUIT
End DoDot:1
IF Q
KILL BGPSTMP,Y
GOTO EN2
+11 IF BGPSTMP
IF $DATA(^DIBT(BGPSTMP))
Begin DoDot:1
+12 WRITE !,?5,"An unduplicated PATIENT list resulting from this report",!,?5,"will be stored in the",BGPSNAM," Search Template.",!
+13 KILL ^DIBT(BGPSTMP,1)
+14 SET DHIT="S ^DIBT("_BGPSTMP_",1,DFN)="""""
+15 SET DIE="^DIBT("
SET DA=BGPSTMP
SET DR="2////"_DT_";3////M;4////9000001;5////"_DUZ_";6////M"
+16 DO ^DIE
+17 KILL DIE,DA,DR
End DoDot:1
+18 QUIT
