BGP9DPAP ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT ;
;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
;
EP ;EP - called from option interactive
D EOJ
W:$D(IOF) @IOF
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)
;W !!,"This option will produce a comprehensive National GPRA report for"
;W !,"a selected set of patients. You will be able to enter a search "
;W !,"template of patients or enter individual patient names.",!
PATS ;
W !,"Enter a patient's HRN or name (HORSECHIEF,JOHN DOE or HORSECHIEF,JOHN)."
W !,"A template can also be selected by typing a ""["" followed by"
W !,"the template name."
W !,"Entering ""[??"" will list your templates."
K DIR S DIR(0)="E",DIR("A")="PRESS ENTER" D ^DIR K DIR
SELPT ;
K BGPSPAT
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 BGPSPAT=0,Y=+Y F BGPMJ=0:1 S BGPSPAT=$O(^DIBT(Y,1,BGPSPAT)) Q:'BGPSPAT S BGPSMI=BGPSMI+1,BGPSPAT(BGPSMI)=BGPSPAT
... W !,BGPMJ,$S(BGPMJ=1:" entry",1:" entries")," added."
.K DIC S DIC=9000001,DIC(0)="EQM" D ^DIC
.I Y>0 S BGPSPAT=+Y,BGPSMI=BGPSMI+1,BGPSPAT(BGPSMI)=BGPSPAT
W !
I X=U K BGPSPAT W !,"All selections cancelled!"
I '$O(BGPSPAT("")) W !,"No patients selected." D EOJ Q
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)
ENDDATE ;
W !!
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
;S BGPPER=""
;K DIR S DIR(0)="DO^::EXP",DIR("A")="Enter End Date of the Report Period",DIR("B")="June 30, 2009"
;D ^DIR G:Y<1 SELPT S BGPUD=Y
;K DIR
;AI ;gather all gpra measures
S X=0 F S X=$O(^BGPINDN("GPRA",1,X)) Q:X'=+X S BGPIND(X)=""
;S BGPPER=3090630
;S BGPED=""
;I BGPUD=3090630 S BGPBD=3080701,BGPED=BGPUD,BGPPER=$E(BGPED,1,3)_"0000"
;I BGPUD'=3090630 S BGPBD=$$FMADD^XLFDT(BGPUD,-364),BGPED=BGPUD,BGPPER=$E(BGPED,1,3)_"0000"
;S BGPVDT=3000000
;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)
S BGPLIST="A"
S BGPCPLC=0
;D REPORT^BGP9UTL
;I $G(BGPQUIT) D EOJ Q
;I BGPRPT="" D EOJ Q
S XBRP="PRINT^BGP9DPAP",XBRC="PROC^BGP9DPAP",XBRX="EOJ^BGP9DPAP",XBNS="BGP"
D ^XBDBQUE
Q
EOJ ;
D ^XBFMK
K DIC,DIR,DFN
D EN^XBVK("BGP"),EN^XBVK("BSD"),EN^XBVK("AMQQ")
K ^TMP($J)
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,"BGP9DPAP")
S IOM=80
D GUIR^XBLM("PRINT^BGP9DPA","^TMP($J,""BGP9DPAP"",")
S X=0,C=0 F S X=$O(^TMP($J,"BGP9DPAP",X)) Q:X'=+X D
.S BGPDATA=^TMP($J,"BGP9DPAP",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,"BGP9DPAP")
S ZTREQ="@"
Q
;
ENDLOG ;-- write the end of the log
D NOW^%DTC
S BGPNOW=$G(%)
S DIE="^BGPGUIN(",DA=BGPIEN,DR=".04////"_BGPNOW_";.07////C"
D ^DIE
K DIE,DR,DA
Q
;
PROC ;
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("BGP9DPAP",BGPGPRAJ,BGPGPRAH)
S ^XTMP("BGP9DPAP",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PTS WITH AN APPT"
K BGPAPPT,BGPAPPTS
S BGPSOX=0 F S BGPSOX=$O(BGPSPAT(BGPSOX)) Q:BGPSOX'=+BGPSOX D
.S DFN=BGPSPAT(BGPSOX)
.S BGPIISO=1,BGPISST="P" D PROCCY^BGP9D1
.Q
Q
DONE ;
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
;W:$D(IOF) @IOF
K BGPTS,BGPS,BGPM,BGPET
K ^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH)
Q
;
PRINT ;EP - called from xbdbque
S BGPIOSL=$S($G(BGPGUI):55,1:IOSL)
K BGPQ S BGPPG=0,BGPNOD=0
I '$D(^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH,"PATS")) D HEADER S BGPNOD=1 W !!,"NO DATA TO REPORT",! G DONE
D HEADER
S BGPNAME=0 F S BGPNAME=$O(^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME)) Q:BGPNAME=""!($D(BGPQ)) D
.S DFN=0 F S DFN=$O(^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN)) Q:DFN'=+DFN!($D(BGPQ)) D
..I $Y>(BGPIOSL-8) D HEADER Q:$D(BGPQ)
..W !!,$$HRN^AUPNPAT(DFN,DUZ(2)),?7,$E($P(^DPT(DFN,0),U),1,25),?38,$P(^DPT(DFN,0),U,2),?42,$$DATE^BGP9UTL($P(^DPT(DFN,0),U,3)),?51,$$COMMRES^AUPNPAT(DFN,"E")
..S BGPI=0 F S BGPI=$O(^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN,BGPI)) Q:BGPI'=+BGPI!($D(BGPQ)) D
...I $Y>(IOSL-3) D HEADER Q:$D(BGPQ)
...S BGPT=$P(^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN,BGPI),U)
...S BGPT1=$P(^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN,BGPI),U,4)
...S BGPX=$P(^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN,BGPI),U,2)
...S BGPX1=$P(^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN,BGPI),U,3)
...W !?1,BGPT
...F X=1:1 S Y=$P(BGPX,"|",X) Q:Y="" W:X=2 ?1,BGPT1 W ?28,Y,!
...F X=1:1 S Y=$P(BGPX1,"|",X) Q:Y="" W:X'=1 ! W ?28,Y
...;W !?28,$P(BGPX,U,3)
...;I BGPX1]"" W !?28,BGPX1
D DONE
Q
G:'BGPPG HEADER1
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
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,!
W !!,$$CTR("Patient Listing with GPRA Measure Data",80),!
S X="Report End Date: "_$$FMTE^XLFDT(BGPED)
W $$CTR(X,80),!
W !,"HRN",?7,"PATIENT NAME",?38,"Sex",?42,"DOB",?51,"Community"
W !,$TR($J("",80)," ","-")
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")
;----------
LIST ;"??" help list
S BGPMK=0,BGPMJ=IOSL-3 F S BGPMK=$O(BGPSPAT(BGPMK)) Q:'BGPMK S BGPSPAT=BGPSPAT(BGPMK),X=$P(^AUPNPAT(BGPSPAT,0),U) D Q:BGPMJ<0 W !,?2,X
. S BGPMJ=BGPMJ-1 Q:BGPMJ>0 S BGPMJ=IOSL-2
. K DIR S DIR(0)="E" D ^DIR I 'Y K DIRUT,DUOUT,DTOUT S BGPMJ=-1
. S X=" " K DIR Q
K BGPMK
Q
BGP9DPAP ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT ;
+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 SET BGPCTRL=$ORDER(^BGPCTRL("B",2009,0))
+4 SET X=0
FOR
SET X=$ORDER(^BGPCTRL(BGPCTRL,58,X))
IF X'=+X
QUIT
WRITE !,^BGPCTRL(BGPCTRL,58,X,0)
+5 ;W !!,"This option will produce a comprehensive National GPRA report for"
+6 ;W !,"a selected set of patients. You will be able to enter a search "
+7 ;W !,"template of patients or enter individual patient names.",!
PATS ;
+1 WRITE !,"Enter a patient's HRN or name (HORSECHIEF,JOHN DOE or HORSECHIEF,JOHN)."
+2 WRITE !,"A template can also be selected by typing a ""["" followed by"
+3 WRITE !,"the template name."
+4 WRITE !,"Entering ""[??"" will list your templates."
+5 KILL DIR
SET DIR(0)="E"
SET DIR("A")="PRESS ENTER"
DO ^DIR
KILL DIR
SELPT ;
+1 KILL BGPSPAT
+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 BGPSPAT=0
SET Y=+Y
FOR BGPMJ=0:1
SET BGPSPAT=$ORDER(^DIBT(Y,1,BGPSPAT))
IF 'BGPSPAT
QUIT
SET BGPSMI=BGPSMI+1
SET BGPSPAT(BGPSMI)=BGPSPAT
+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 BGPSPAT=+Y
SET BGPSMI=BGPSMI+1
SET BGPSPAT(BGPSMI)=BGPSPAT
End DoDot:1
IF U[X
QUIT
+18 WRITE !
+19 IF X=U
KILL BGPSPAT
WRITE !,"All selections cancelled!"
+20 IF '$ORDER(BGPSPAT(""))
WRITE !,"No patients selected."
DO EOJ
QUIT
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)
ENDDATE ;
+1 WRITE !!
+2 SET X=$ORDER(^BGPCTRL("B",2009,0))
+3 SET Y=^BGPCTRL(X,0)
+4 SET BGPBD=$PIECE(Y,U,8)
SET BGPED=$PIECE(Y,U,9)
+5 SET BGPPBD=$PIECE(Y,U,10)
SET BGPPED=$PIECE(Y,U,11)
+6 SET BGPBBD=$PIECE(Y,U,12)
SET BGPBED=$PIECE(Y,U,13)
+7 SET BGPPER=$PIECE(Y,U,14)
SET BGPQTR=3
+8 ;S BGPPER=""
+9 ;K DIR S DIR(0)="DO^::EXP",DIR("A")="Enter End Date of the Report Period",DIR("B")="June 30, 2009"
+10 ;D ^DIR G:Y<1 SELPT S BGPUD=Y
+11 ;K DIR
+12 ;AI ;gather all gpra measures
+13 SET X=0
FOR
SET X=$ORDER(^BGPINDN("GPRA",1,X))
IF X'=+X
QUIT
SET BGPIND(X)=""
+14 ;S BGPPER=3090630
+15 ;S BGPED=""
+16 ;I BGPUD=3090630 S BGPBD=3080701,BGPED=BGPUD,BGPPER=$E(BGPED,1,3)_"0000"
+17 ;I BGPUD'=3090630 S BGPBD=$$FMADD^XLFDT(BGPUD,-364),BGPED=BGPUD,BGPPER=$E(BGPED,1,3)_"0000"
+18 ;S BGPVDT=3000000
+19 ;S X=$E(BGPPER,1,3)-$E(BGPVDT,1,3)
+20 ;S X=X_"0000"
+21 ;S BGPBBD=BGPBD-X,BGPBBD=$E(BGPBBD,1,3)_$E(BGPBD,4,7)
+22 ;S BGPBED=BGPED-X,BGPBED=$E(BGPBED,1,3)_$E(BGPED,4,7)
+23 ;S BGPPBD=($E(BGPBD,1,3)-1)_$E(BGPBD,4,7)
+24 ;S BGPPED=($E(BGPED,1,3)-1)_$E(BGPED,4,7)
+25 SET BGPLIST="A"
+26 SET BGPCPLC=0
+27 ;D REPORT^BGP9UTL
+28 ;I $G(BGPQUIT) D EOJ Q
+29 ;I BGPRPT="" D EOJ Q
+30 SET XBRP="PRINT^BGP9DPAP"
SET XBRC="PROC^BGP9DPAP"
SET XBRX="EOJ^BGP9DPAP"
SET XBNS="BGP"
+31 DO ^XBDBQUE
+32 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 ;
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,"BGP9DPAP")
+3 SET IOM=80
+4 DO GUIR^XBLM("PRINT^BGP9DPA","^TMP($J,""BGP9DPAP"",")
+5 SET X=0
SET C=0
FOR
SET X=$ORDER(^TMP($JOB,"BGP9DPAP",X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET BGPDATA=^TMP($JOB,"BGP9DPAP",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,"BGP9DPAP")
+13 SET ZTREQ="@"
+14 QUIT
+15 ;
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_";.07////C"
+4 DO ^DIE
+5 KILL DIE,DR,DA
+6 QUIT
+7 ;
PROC ;
+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("BGP9DPAP",BGPGPRAJ,BGPGPRAH)
+8 SET ^XTMP("BGP9DPAP",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PTS WITH AN APPT"
+9 KILL BGPAPPT,BGPAPPTS
+10 SET BGPSOX=0
FOR
SET BGPSOX=$ORDER(BGPSPAT(BGPSOX))
IF BGPSOX'=+BGPSOX
QUIT
Begin DoDot:1
+11 SET DFN=BGPSPAT(BGPSOX)
+12 SET BGPIISO=1
SET BGPISST="P"
DO PROCCY^BGP9D1
+13 QUIT
End DoDot:1
+14 QUIT
DONE ;
+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 ;W:$D(IOF) @IOF
+4 KILL BGPTS,BGPS,BGPM,BGPET
+5 KILL ^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH)
+6 QUIT
+7 ;
PRINT ;EP - called from xbdbque
+1 SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:IOSL)
+2 KILL BGPQ
SET BGPPG=0
SET BGPNOD=0
+3 IF '$DATA(^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH,"PATS"))
DO HEADER
SET BGPNOD=1
WRITE !!,"NO DATA TO REPORT",!
GOTO DONE
+4 DO HEADER
+5 SET BGPNAME=0
FOR
SET BGPNAME=$ORDER(^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME))
IF BGPNAME=""!($DATA(BGPQ))
QUIT
Begin DoDot:1
+6 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN))
IF DFN'=+DFN!($DATA(BGPQ))
QUIT
Begin DoDot:2
+7 IF $Y>(BGPIOSL-8)
DO HEADER
IF $DATA(BGPQ)
QUIT
+8 WRITE !!,$$HRN^AUPNPAT(DFN,DUZ(2)),?7,$EXTRACT($PIECE(^DPT(DFN,0),U),1,25),?38,$PIECE(^DPT(DFN,0),U,2),?42,$$DATE^BGP9UTL($PIECE(^DPT(DFN,0),U,3)),?51,$$COMMRES^AUPNPAT(DFN,"E")
+9 SET BGPI=0
FOR
SET BGPI=$ORDER(^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN,BGPI))
IF BGPI'=+BGPI!($DATA(BGPQ))
QUIT
Begin DoDot:3
+10 IF $Y>(IOSL-3)
DO HEADER
IF $DATA(BGPQ)
QUIT
+11 SET BGPT=$PIECE(^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN,BGPI),U)
+12 SET BGPT1=$PIECE(^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN,BGPI),U,4)
+13 SET BGPX=$PIECE(^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN,BGPI),U,2)
+14 SET BGPX1=$PIECE(^XTMP("BGP9DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN,BGPI),U,3)
+15 WRITE !?1,BGPT
+16 FOR X=1:1
SET Y=$PIECE(BGPX,"|",X)
IF Y=""
QUIT
IF X=2
WRITE ?1,BGPT1
WRITE ?28,Y,!
+17 FOR X=1:1
SET Y=$PIECE(BGPX1,"|",X)
IF Y=""
QUIT
IF X'=1
WRITE !
WRITE ?28,Y
+18 ;W !?28,$P(BGPX,U,3)
+19 ;I BGPX1]"" W !?28,BGPX1
End DoDot:3
End DoDot:2
End DoDot:1
+20 DO DONE
+21 QUIT
+1 IF 'BGPPG
GOTO HEADER1
+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
+1 IF $DATA(IOF)
WRITE @IOF
SET BGPPG=BGPPG+1
+2 IF $GET(BGPGUI)
IF BGPPG'=1
WRITE !,"ZZZZZZZ"
+3 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BGPPG,!
+4 WRITE !!,$$CTR("Patient Listing with GPRA Measure Data",80),!
+5 SET X="Report End Date: "_$$FMTE^XLFDT(BGPED)
+6 WRITE $$CTR(X,80),!
+7 WRITE !,"HRN",?7,"PATIENT NAME",?38,"Sex",?42,"DOB",?51,"Community"
+8 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+9 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 ;----------
LIST ;"??" help list
+1 SET BGPMK=0
SET BGPMJ=IOSL-3
FOR
SET BGPMK=$ORDER(BGPSPAT(BGPMK))
IF 'BGPMK
QUIT
SET BGPSPAT=BGPSPAT(BGPMK)
SET X=$PIECE(^AUPNPAT(BGPSPAT,0),U)
Begin DoDot:1
+2 SET BGPMJ=BGPMJ-1
IF BGPMJ>0
QUIT
SET BGPMJ=IOSL-2
+3 KILL DIR
SET DIR(0)="E"
DO ^DIR
IF 'Y
KILL DIRUT,DUOUT,DTOUT
SET BGPMJ=-1
+4 SET X=" "
KILL DIR
QUIT
End DoDot:1
IF BGPMJ<0
QUIT
WRITE !,?2,X
+5 KILL BGPMK
+6 QUIT
