BGP4GRB ; IHS/CMI/LAB - BGP Gui Area Reports 5/2/2005 8:38:59 PM ;
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
;
;
;area GPRA reports
Q
;
DEBUG(RETVAL,BGPSTR) ;run the debugger
D DEBUG^%Serenji("FOR^BGP4GRB(.RETVAL,.BGPSTR)")
Q
;
FOR(RETVAL,BGPSTR) ;-- gpra patient forcast report
S X="MERR^BGP4GU",@^%ZOSF("TRAP") ; m error trap
N BGPI,BGPGDA,P,R,BGPLST,BGPDIV,BGPBADT,BGPEADT,BGPCLN,BGPPATL,BGPPATI,BGPPAT,BGPCLNL,BGPST,BGPSTI,BGPCNT,BGPFN,BGPANY,BGPAO,BGPAOD,BGPSTM
N BGPGY
S P="|",R="~"
S RETVAL="^BGPTMP("_$J_")"
S BGPI=0
S BGPOPT="CRS 14 PATIENT FORECAST REPORT"
I $G(BGPSTR)="" D CATSTR^BGP4GU(.BGPSTR,.BGPSTR)
S BGPLST=$P(BGPSTR,P)
S BGPDIV=$P(BGPSTR,P,2)
I BGPDIV]"" S BGPDIV=$O(^DG(40.8,"B",BGPDIV,0))
S BGPBADT=$P(BGPSTR,P,3)
S BGPEADT=$P(BGPSTR,P,4)
S BGPCLNL=$P(BGPSTR,P,5)
S BGPPATL=$P(BGPSTR,P,6)
S BGPPATI=$P(BGPSTR,P,7)
I BGPPATI]"" S BGPPATL(BGPPATI)="",BGPPAT(BGPPATI)=""
S BGPRT=$P(BGPSTR,P,8)
S BGPST=$P(BGPSTR,P,9)
S BGPFN=$P(BGPSTR,P,10)
S BGPANY=$P(BGPSTR,P,11)
S BGPAO=$P(BGPSTR,P,12)
S BGPAOD=$P(BGPSTR,P,13)
S BGPSTM=$P(BGPSTR,P,14)
S BGPGY=$P(BGPSTR,P,15)
I $G(BGPSTM)]"",BGPSTM'?.N S BGPSTM=$O(^DIBT("B",BGPSTM,0))
;I BGPST]"" S BGPSTI=$O(^DIBT("B",BGPST,0))
I BGPCLNL]"",BGPCLNL'="A" D
. N I
. F I=1:1 D Q:$P(BGPCLNL,R,I)=""
.. Q:$P(BGPCLNL,R,I)=""
.. S BGPCLN($P(BGPCLNL,R,I))=$P(BGPCLNL,R,I)
I BGPPATL]"" D
. N J
. F J=1:1 D Q:$P(BGPPATL,R,J)=""
.. Q:$P(BGPPATL,R,J)=""
.. S BGPPAT($P(BGPPATL,R,J))=$P(BGPPATL,R,J)
I $G(BGPST) D
. N BGPDA
. S BGPCNT=0
. S BGPDA=0 F S BGPDA=$O(^DIBT(BGPST,1,BGPDA)) Q:'BGPDA D
.. S BGPCNT=BGPCNT+1
.. S BGPPAT(BGPCNT)=BGPDA
S ^BGPTMP($J,BGPI)="T00250DATA"_$C(30)
D EP^BGP4GFOR(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPLST,BGPDIV,BGPBADT,BGPEADT,.BGPCLN,.BGPPAT,BGPRT,BGPFN,BGPANY,BGPAO,BGPAOD,BGPSTM,BGPGY)
S BGPI=BGPI+1
S ^BGPTMP($J,BGPI)=+$G(BGPERR)_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
D EN^XBVK("BGP")
Q
;
FORD(RETVAL,BGPSTR) ;-- return the patient forecast denominator
S X="MERR^BGP4GU",@^%ZOSF("TRAP") ; m error trap
N P,BGPRDT,BGPFN
S P="|"
S BGPRDT=$P(BGPSTR,P)
S BGPFN=$P(BGPSTR,P,2)
S RETVAL="^BGPTMP("_$J_")"
S BGPI=0
S BGPGUI=1
S BGPOPT="CRS 14 PATIENT FORECAST DENOMINATOR DEFINITIONS"
D ^XBFMK
D GUILOG(BGPOPT,BGPRDT,BGPFN)
S ^BGPTMP($J,BGPI)="T00250DATA"_$C(30)
K ZTSAVE S ZTSAVE("*")=""
S ZTIO="",ZTDTH=$S(BGPRDT]"":BGPRDT,1:$$NOW^XLFDT),ZTRTN="GUIECP^BGP4DPA",ZTDESC="GUI Denominator Definitions" D ^%ZTLOAD
S BGPI=BGPI+1
S ^BGPTMP($J,BGPI)=+$G(BGPERR)_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
D EN^XBVK("BGP")
Q
AEO(RETVAL,BGPSTR) ;-- area EO report
S X="MERR^BGP4GU",@^%ZOSF("TRAP") ; m error trap
N BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPCT,BGPYN,BGPOT,BGPOPT,BGPRT,BGPHC
N BGPQTR,BGPRE,BGPBAS,BGPBEN,BGPFAC,A,R,BGPFN
I $G(BGPSTR)="" D CATSTR^BGPGR(.BGPSTR,.BGPSTR)
S P="|",A="*",R="~"
S BGPI=0
S BGPERR=""
S BGPQTR=$P(BGPSTR,P)
S BGPRT=$P(BGPSTR,P,2)
S BGPRE=$P(BGPSTR,P,3)
S BGPPER=$P(BGPSTR,P,4)
S BGPBAS=$P(BGPSTR,P,5)
S BGPBEN=$P(BGPSTR,P,6)
S BGPOT=$P(BGPSTR,P,7)
S BGPLSTI=$P(BGPSTR,P,8)
S BGPHC=$P(BGPSTR,P,9)
S BGPFN=$P(BGPSTR,P,11)
S BGPOPT="CRS 14 AREA EO REPORT"
N I
F I=2:1 D Q:$P(BGPLSTI,A,I)=""
. Q:$P(BGPLSTI,A,I)=""
. N BGPL
. S BGPL=$P($P(BGPLSTI,A,I),R)
. S BGPLIST(BGPL)=""
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
S ^BGPTMP($J,BGPI)="T00250DATA"_$C(30)
;D EP^BGP4GAEO(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPRT,.BGPLIST,BGPQTR,BGPPER,BGPBAS,BGPBEN,BGPOT,BGPRE,BGPHC,BGPFN)
S BGPI=BGPI+1
S ^BGPTMP($J,BGPI)=$G(BGPERR)_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
D EN^XBVK("BGP")
Q
;
GUILOG(BGPOPT,RDT,FN) ;-- log in the GUI REPORT FILE
D NOW^%DTC
S BGPNOW=$G(%)
K DD,D0,DIC
S X=DUZ_$$NOW^XLFDT
S X=FN
S BGPGFNM=X
S DIC="^BGPGUIJ(",DIC(0)="L",DIADD=1,DLAYGO=90552.19,DIC("DR")=".02////"_DUZ_";.03////"_$S(RDT]"":RDT,1:$$NOW^XLFDT)_";.05///"_BGPOPT_";.06///R;.07///P"
K DD,D0,DO D FILE^DICN K DLAYGO,DIADD,DD,D0,DO
I Y=-1 S BGPIEN=-1 Q
S BGPIEN=+Y
Q
;
FOR9(RETVAL,BGPSTR) ;-- gpra patient forcast report
S X="MERR^BGP4GU",@^%ZOSF("TRAP") ; m error trap
N BGPI,BGPGDA,P,R,BGPLST,BGPDIV,BGPBADT,BGPEADT,BGPCLN,BGPPATL,BGPPATI,BGPPAT,BGPCLNL,BGPST,BGPSTI,BGPCNT,BGPFN
S P="|",R="~"
S RETVAL="^BGPTMP("_$J_")"
S BGPI=0
S BGPOPT="CRS 14 PATIENT FORECAST REPORT 11"
I $G(BGPSTR)="" D CATSTR^BGP4GU(.BGPSTR,.BGPSTR)
S BGPLST=$P(BGPSTR,P)
S BGPDIV=$P(BGPSTR,P,2)
I BGPDIV]"" S BGPDIV=$O(^DG(40.8,"B",BGPDIV,0))
S BGPBADT=$P(BGPSTR,P,3)
S BGPEADT=$P(BGPSTR,P,4)
S BGPCLNL=$P(BGPSTR,P,5)
S BGPPATL=$P(BGPSTR,P,6)
S BGPPATI=$P(BGPSTR,P,7)
I BGPPATI]"" S BGPPATL(BGPPATI)="",BGPPAT(BGPPATI)=""
S BGPRT=$P(BGPSTR,P,8)
S BGPST=$P(BGPSTR,P,9)
S BGPFN=$P(BGPSTR,P,10)
I BGPST]"" S BGPSTI=$O(^DIBT("B",BGPST,0))
I BGPCLNL]"",BGPCLNL'="A" D
. N I
. F I=1:1 D Q:$P(BGPCLNL,R,I)=""
.. Q:$P(BGPCLNL,R,I)=""
.. S BGPCLN($P(BGPCLNL,R,I))=$P(BGPCLNL,R,I)
I BGPPATL]"" D
. N J
. F J=1:1 D Q:$P(BGPPATL,R,J)=""
.. Q:$P(BGPPATL,R,J)=""
.. S BGPPAT($P(BGPPATL,R,J))=$P(BGPPATL,R,J)
I $G(BGPSTI) D
. N BGPDA
. S BGPCNT=0
. S BGPDA=0 F S BGPDA=$O(^DIBT(BGPSTI,1,BGPDA)) Q:'BGPDA D
.. S BGPCNT=BGPCNT+1
.. S BGPPAT(BGPCNT)=BGPDA
S ^BGPTMP($J,BGPI)="T00250DATA"_$C(30)
D EP^BGP4GFO9(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPLST,BGPDIV,BGPBADT,BGPEADT,.BGPCLN,.BGPPAT,BGPRT,BGPFN)
S BGPI=BGPI+1
S ^BGPTMP($J,BGPI)=+$G(BGPERR)_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
D EN^XBVK("BGP")
Q
;
FOR10(RETVAL,BGPSTR) ;-- gpra patient forcast report
S X="MERR^BGP4GU",@^%ZOSF("TRAP") ; m error trap
N BGPI,BGPGDA,P,R,BGPLST,BGPDIV,BGPBADT,BGPEADT,BGPCLN,BGPPATL,BGPPATI,BGPPAT,BGPCLNL,BGPST,BGPSTI,BGPCNT,BGPFN
S P="|",R="~"
S RETVAL="^BGPTMP("_$J_")"
S BGPI=0
S BGPOPT="CRS 14 PATIENT FORECAST REPORT 11"
I $G(BGPSTR)="" D CATSTR^BGP4GU(.BGPSTR,.BGPSTR)
S BGPLST=$P(BGPSTR,P)
S BGPDIV=$P(BGPSTR,P,2)
I BGPDIV]"" S BGPDIV=$O(^DG(40.8,"B",BGPDIV,0))
S BGPBADT=$P(BGPSTR,P,3)
S BGPEADT=$P(BGPSTR,P,4)
S BGPCLNL=$P(BGPSTR,P,5)
S BGPPATL=$P(BGPSTR,P,6)
S BGPPATI=$P(BGPSTR,P,7)
I BGPPATI]"" S BGPPATL(BGPPATI)="",BGPPAT(BGPPATI)=""
S BGPRT=$P(BGPSTR,P,8)
S BGPST=$P(BGPSTR,P,9)
S BGPFN=$P(BGPSTR,P,10)
I BGPST]"" S BGPSTI=$O(^DIBT("B",BGPST,0))
I BGPCLNL]"",BGPCLNL'="A" D
. N I
. F I=1:1 D Q:$P(BGPCLNL,R,I)=""
.. Q:$P(BGPCLNL,R,I)=""
.. S BGPCLN($P(BGPCLNL,R,I))=$P(BGPCLNL,R,I)
I BGPPATL]"" D
. N J
. F J=1:1 D Q:$P(BGPPATL,R,J)=""
.. Q:$P(BGPPATL,R,J)=""
.. S BGPPAT($P(BGPPATL,R,J))=$P(BGPPATL,R,J)
I $G(BGPSTI) D
. N BGPDA
. S BGPCNT=0
. S BGPDA=0 F S BGPDA=$O(^DIBT(BGPSTI,1,BGPDA)) Q:'BGPDA D
.. S BGPCNT=BGPCNT+1
.. S BGPPAT(BGPCNT)=BGPDA
S ^BGPTMP($J,BGPI)="T00250DATA"_$C(30)
D EP^BGP4GFO9(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPLST,BGPDIV,BGPBADT,BGPEADT,.BGPCLN,.BGPPAT,BGPRT,BGPFN)
S BGPI=BGPI+1
S ^BGPTMP($J,BGPI)=+$G(BGPERR)_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
D EN^XBVK("BGP")
Q
;
ADASH(RETVAL,BGPSTR) ;-- area dashboard
S X="MERR^BGP4GU",@^%ZOSF("TRAP") ; m error trap
N BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPAF,BGPYN,BGPOT,BGPOPT,BGPRT,BGPFN,A,R,BGPYR
I $G(BGPSTR)="" D CATSTR^BGPGR(.BGPSTR,.BGPSTR)
S P="|",A="*",R="~"
S BGPI=0
S BGPERR=""
S BGPAF=$P(BGPSTR,P)
S BGPOT=$P(BGPSTR,P,2)
S BGPFN=$P(BGPSTR,P,3)
S BGPOPT="CRS 14 AREA NATIONAL GPRA DASHBOARD REPORT"
S BGPRT=$P(BGPSTR,P,4)
S BGPLSTI=$P(BGPSTR,P,5)
S BGPFN=$P(BGPSTR,P,7)
S BGPYR=$P(BGPSTR,P,8)
N I
F I=2:1 D Q:$P(BGPLSTI,A,I)=""
. Q:$P(BGPLSTI,A,I)=""
. N BGPL
. S BGPL=$P($P(BGPLSTI,A,I),R)
. S BGPLIST(BGPL)=""
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
S ^BGPTMP($J,BGPI)="T02500DATA"_$C(30)
D EP^BGP4GADB(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPAF,.BGPLIST,BGPOT,BGPRT,BGPFN,BGPYR)
S BGPI=BGPI+1
S ^BGPTMP($J,BGPI)=$G(BGPERR)_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
D EN^XBVK("BGP")
Q
;
MANE(RETVAL,BGPSTR) ;-- queue the manual extract
A S X="MERR^BGP4GU",@^%ZOSF("TRAP") ; m error trap
N BGPI,BGPSITE,BGPTAXI,BGPRT,P,Q,BGPDTH
S P="|"
I $G(BGPSTR)="" D CATSTR^BGPGR(.BGPSTR,.BGPSTR)
S BGPSITE=$P(BGPSTR,P)
S BGPTAXI=$P(BGPSTR,P,2)
S BGPRT=$P(BGPSTR,P,3)
S BGPDTH=$$FMTH^XLFDT(BGPRT)
S BGPI=0
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
S ^BGPTMP($J,BGPI)="T00001DATA"_$C(30)
S BGPT=$P(^BGPGP2PM(BGPSITE,0),U,2)
S Q=0
F F=.02,4.2,4.3,4.4,4.5 I $$VAL^XBDIQ1(90241.04,BGPSITE,F)="" S Q=1
I Q D Q
. S BGPI=BGPI+1
. S ^BGPTMP($J,BGPI)=0_$C(30)
. S ^BGPTMP($J,BGPI+1)=$C(31)
I BGPT="T" D
.S BGPDT=$$FMADD^XLFDT(DT,-60)
.S BGPY=$E(BGPDT,1,3)
.S BGPM=+$E(BGPDT,4,5)
.S BGPD=$P("31^28^31^30^31^30^31^31^30^31^30^31",U,BGPM)
.I BGPM=2 S BGPD=BGPD+$$LEAP^XLFDT2(BGPY+1700)
.S BGPD=$E("00",1,2-$L(BGPD))_BGPD
.S BGPM=$E("00",1,2-$L(BGPM))_BGPM
.S BGPEND=BGPY_BGPM_BGPD
.S (BGPBD,BGPED,BGPTP)=""
.S BGPBD=$$FMADD^XLFDT(BGPEND,-364),BGPED=BGPEND,BGPPER=$E(BGPED,1,3)_"0000"
.S BGPVDT=3000000 ;***HARD CODED TO BASELINE YEAR 2000
.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 X=$O(^BGPCTRL("B",2014,0))
S Y=^BGPCTRL(X,0)
S BGPBD=$S(+$E(DT,4,7)<701:$E(DT,1,3)-1_"0701",1:$E(DT,1,3)_"0701")
S (BGPEND,BGPED)=$S(+$E(DT,4,7)<701:$E(DT,1,3)_"0630",1:$E(DT,1,3)+1_"0630")
;S BGPPBD=$P(Y,U,10),BGPPED=$P(Y,U,11)
S BGPPBD=$E(BGPBD,1,3)-1_"0701",BGPPED=$E(BGPED,1,3)-1_"0630"
S BGPBBD=$P(Y,U,12),BGPBED=$P(Y,U,13)
S BGPPER=$P(Y,U,14)
S BGPQTR=3
S BGPVDT=3000000 ;***HARD CODED TO BASELINE YEAR 2000
S BGPAMEX=1,BGPERRM=""
S BGPMAN=1
D QUE^BGP4AUEX(BGPEND,BGPRT)
I $G(ZTSK) D
. S BGPI=BGPI+1
. S ^BGPTMP($J,BGPI)=1_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
D EN^XBVK("BGP")
Q
;
MANA ;-- queue the area auto extract
Q
;
BGP4GRB ; IHS/CMI/LAB - BGP Gui Area Reports 5/2/2005 8:38:59 PM ;
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+2 ;
+3 ;
+4 ;
+5 ;area GPRA reports
+6 QUIT
+7 ;
DEBUG(RETVAL,BGPSTR) ;run the debugger
+1 DO DEBUG^%Serenji("FOR^BGP4GRB(.RETVAL,.BGPSTR)")
+2 QUIT
+3 ;
FOR(RETVAL,BGPSTR) ;-- gpra patient forcast report
+1 ; m error trap
SET X="MERR^BGP4GU"
SET @^%ZOSF("TRAP")
+2 NEW BGPI,BGPGDA,P,R,BGPLST,BGPDIV,BGPBADT,BGPEADT,BGPCLN,BGPPATL,BGPPATI,BGPPAT,BGPCLNL,BGPST,BGPSTI,BGPCNT,BGPFN,BGPANY,BGPAO,BGPAOD,BGPSTM
+3 NEW BGPGY
+4 SET P="|"
SET R="~"
+5 SET RETVAL="^BGPTMP("_$JOB_")"
+6 SET BGPI=0
+7 SET BGPOPT="CRS 14 PATIENT FORECAST REPORT"
+8 IF $GET(BGPSTR)=""
DO CATSTR^BGP4GU(.BGPSTR,.BGPSTR)
+9 SET BGPLST=$PIECE(BGPSTR,P)
+10 SET BGPDIV=$PIECE(BGPSTR,P,2)
+11 IF BGPDIV]""
SET BGPDIV=$ORDER(^DG(40.8,"B",BGPDIV,0))
+12 SET BGPBADT=$PIECE(BGPSTR,P,3)
+13 SET BGPEADT=$PIECE(BGPSTR,P,4)
+14 SET BGPCLNL=$PIECE(BGPSTR,P,5)
+15 SET BGPPATL=$PIECE(BGPSTR,P,6)
+16 SET BGPPATI=$PIECE(BGPSTR,P,7)
+17 IF BGPPATI]""
SET BGPPATL(BGPPATI)=""
SET BGPPAT(BGPPATI)=""
+18 SET BGPRT=$PIECE(BGPSTR,P,8)
+19 SET BGPST=$PIECE(BGPSTR,P,9)
+20 SET BGPFN=$PIECE(BGPSTR,P,10)
+21 SET BGPANY=$PIECE(BGPSTR,P,11)
+22 SET BGPAO=$PIECE(BGPSTR,P,12)
+23 SET BGPAOD=$PIECE(BGPSTR,P,13)
+24 SET BGPSTM=$PIECE(BGPSTR,P,14)
+25 SET BGPGY=$PIECE(BGPSTR,P,15)
+26 IF $GET(BGPSTM)]""
IF BGPSTM'?.N
SET BGPSTM=$ORDER(^DIBT("B",BGPSTM,0))
+27 ;I BGPST]"" S BGPSTI=$O(^DIBT("B",BGPST,0))
+28 IF BGPCLNL]""
IF BGPCLNL'="A"
Begin DoDot:1
+29 NEW I
+30 FOR I=1:1
Begin DoDot:2
+31 IF $PIECE(BGPCLNL,R,I)=""
QUIT
+32 SET BGPCLN($PIECE(BGPCLNL,R,I))=$PIECE(BGPCLNL,R,I)
End DoDot:2
IF $PIECE(BGPCLNL,R,I)=""
QUIT
End DoDot:1
+33 IF BGPPATL]""
Begin DoDot:1
+34 NEW J
+35 FOR J=1:1
Begin DoDot:2
+36 IF $PIECE(BGPPATL,R,J)=""
QUIT
+37 SET BGPPAT($PIECE(BGPPATL,R,J))=$PIECE(BGPPATL,R,J)
End DoDot:2
IF $PIECE(BGPPATL,R,J)=""
QUIT
End DoDot:1
+38 IF $GET(BGPST)
Begin DoDot:1
+39 NEW BGPDA
+40 SET BGPCNT=0
+41 SET BGPDA=0
FOR
SET BGPDA=$ORDER(^DIBT(BGPST,1,BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:2
+42 SET BGPCNT=BGPCNT+1
+43 SET BGPPAT(BGPCNT)=BGPDA
End DoDot:2
End DoDot:1
+44 SET ^BGPTMP($JOB,BGPI)="T00250DATA"_$CHAR(30)
+45 DO EP^BGP4GFOR(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPLST,BGPDIV,BGPBADT,BGPEADT,.BGPCLN,.BGPPAT,BGPRT,BGPFN,BGPANY,BGPAO,BGPAOD,BGPSTM,BGPGY)
+46 SET BGPI=BGPI+1
+47 SET ^BGPTMP($JOB,BGPI)=+$GET(BGPERR)_$CHAR(30)
+48 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+49 DO EN^XBVK("BGP")
+50 QUIT
+51 ;
FORD(RETVAL,BGPSTR) ;-- return the patient forecast denominator
+1 ; m error trap
SET X="MERR^BGP4GU"
SET @^%ZOSF("TRAP")
+2 NEW P,BGPRDT,BGPFN
+3 SET P="|"
+4 SET BGPRDT=$PIECE(BGPSTR,P)
+5 SET BGPFN=$PIECE(BGPSTR,P,2)
+6 SET RETVAL="^BGPTMP("_$JOB_")"
+7 SET BGPI=0
+8 SET BGPGUI=1
+9 SET BGPOPT="CRS 14 PATIENT FORECAST DENOMINATOR DEFINITIONS"
+10 DO ^XBFMK
+11 DO GUILOG(BGPOPT,BGPRDT,BGPFN)
+12 SET ^BGPTMP($JOB,BGPI)="T00250DATA"_$CHAR(30)
+13 KILL ZTSAVE
SET ZTSAVE("*")=""
+14 SET ZTIO=""
SET ZTDTH=$SELECT(BGPRDT]"":BGPRDT,1:$$NOW^XLFDT)
SET ZTRTN="GUIECP^BGP4DPA"
SET ZTDESC="GUI Denominator Definitions"
DO ^%ZTLOAD
+15 SET BGPI=BGPI+1
+16 SET ^BGPTMP($JOB,BGPI)=+$GET(BGPERR)_$CHAR(30)
+17 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+18 DO EN^XBVK("BGP")
+19 QUIT
AEO(RETVAL,BGPSTR) ;-- area EO report
+1 ; m error trap
SET X="MERR^BGP4GU"
SET @^%ZOSF("TRAP")
+2 NEW BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPCT,BGPYN,BGPOT,BGPOPT,BGPRT,BGPHC
+3 NEW BGPQTR,BGPRE,BGPBAS,BGPBEN,BGPFAC,A,R,BGPFN
+4 IF $GET(BGPSTR)=""
DO CATSTR^BGPGR(.BGPSTR,.BGPSTR)
+5 SET P="|"
SET A="*"
SET R="~"
+6 SET BGPI=0
+7 SET BGPERR=""
+8 SET BGPQTR=$PIECE(BGPSTR,P)
+9 SET BGPRT=$PIECE(BGPSTR,P,2)
+10 SET BGPRE=$PIECE(BGPSTR,P,3)
+11 SET BGPPER=$PIECE(BGPSTR,P,4)
+12 SET BGPBAS=$PIECE(BGPSTR,P,5)
+13 SET BGPBEN=$PIECE(BGPSTR,P,6)
+14 SET BGPOT=$PIECE(BGPSTR,P,7)
+15 SET BGPLSTI=$PIECE(BGPSTR,P,8)
+16 SET BGPHC=$PIECE(BGPSTR,P,9)
+17 SET BGPFN=$PIECE(BGPSTR,P,11)
+18 SET BGPOPT="CRS 14 AREA EO REPORT"
+19 NEW I
+20 FOR I=2:1
Begin DoDot:1
+21 IF $PIECE(BGPLSTI,A,I)=""
QUIT
+22 NEW BGPL
+23 SET BGPL=$PIECE($PIECE(BGPLSTI,A,I),R)
+24 SET BGPLIST(BGPL)=""
End DoDot:1
IF $PIECE(BGPLSTI,A,I)=""
QUIT
+25 KILL ^BGPTMP($JOB)
+26 SET RETVAL="^BGPTMP("_$JOB_")"
+27 SET ^BGPTMP($JOB,BGPI)="T00250DATA"_$CHAR(30)
+28 ;D EP^BGP4GAEO(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPRT,.BGPLIST,BGPQTR,BGPPER,BGPBAS,BGPBEN,BGPOT,BGPRE,BGPHC,BGPFN)
+29 SET BGPI=BGPI+1
+30 SET ^BGPTMP($JOB,BGPI)=$GET(BGPERR)_$CHAR(30)
+31 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+32 DO EN^XBVK("BGP")
+33 QUIT
+34 ;
GUILOG(BGPOPT,RDT,FN) ;-- log in the GUI REPORT FILE
+1 DO NOW^%DTC
+2 SET BGPNOW=$GET(%)
+3 KILL DD,D0,DIC
+4 SET X=DUZ_$$NOW^XLFDT
+5 SET X=FN
+6 SET BGPGFNM=X
+7 SET DIC="^BGPGUIJ("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=90552.19
SET DIC("DR")=".02////"_DUZ_";.03////"_$SELECT(RDT]"":RDT,1:$$NOW^XLFDT)_";.05///"_BGPOPT_";.06///R;.07///P"
+8 KILL DD,D0,DO
DO FILE^DICN
KILL DLAYGO,DIADD,DD,D0,DO
+9 IF Y=-1
SET BGPIEN=-1
QUIT
+10 SET BGPIEN=+Y
+11 QUIT
+12 ;
FOR9(RETVAL,BGPSTR) ;-- gpra patient forcast report
+1 ; m error trap
SET X="MERR^BGP4GU"
SET @^%ZOSF("TRAP")
+2 NEW BGPI,BGPGDA,P,R,BGPLST,BGPDIV,BGPBADT,BGPEADT,BGPCLN,BGPPATL,BGPPATI,BGPPAT,BGPCLNL,BGPST,BGPSTI,BGPCNT,BGPFN
+3 SET P="|"
SET R="~"
+4 SET RETVAL="^BGPTMP("_$JOB_")"
+5 SET BGPI=0
+6 SET BGPOPT="CRS 14 PATIENT FORECAST REPORT 11"
+7 IF $GET(BGPSTR)=""
DO CATSTR^BGP4GU(.BGPSTR,.BGPSTR)
+8 SET BGPLST=$PIECE(BGPSTR,P)
+9 SET BGPDIV=$PIECE(BGPSTR,P,2)
+10 IF BGPDIV]""
SET BGPDIV=$ORDER(^DG(40.8,"B",BGPDIV,0))
+11 SET BGPBADT=$PIECE(BGPSTR,P,3)
+12 SET BGPEADT=$PIECE(BGPSTR,P,4)
+13 SET BGPCLNL=$PIECE(BGPSTR,P,5)
+14 SET BGPPATL=$PIECE(BGPSTR,P,6)
+15 SET BGPPATI=$PIECE(BGPSTR,P,7)
+16 IF BGPPATI]""
SET BGPPATL(BGPPATI)=""
SET BGPPAT(BGPPATI)=""
+17 SET BGPRT=$PIECE(BGPSTR,P,8)
+18 SET BGPST=$PIECE(BGPSTR,P,9)
+19 SET BGPFN=$PIECE(BGPSTR,P,10)
+20 IF BGPST]""
SET BGPSTI=$ORDER(^DIBT("B",BGPST,0))
+21 IF BGPCLNL]""
IF BGPCLNL'="A"
Begin DoDot:1
+22 NEW I
+23 FOR I=1:1
Begin DoDot:2
+24 IF $PIECE(BGPCLNL,R,I)=""
QUIT
+25 SET BGPCLN($PIECE(BGPCLNL,R,I))=$PIECE(BGPCLNL,R,I)
End DoDot:2
IF $PIECE(BGPCLNL,R,I)=""
QUIT
End DoDot:1
+26 IF BGPPATL]""
Begin DoDot:1
+27 NEW J
+28 FOR J=1:1
Begin DoDot:2
+29 IF $PIECE(BGPPATL,R,J)=""
QUIT
+30 SET BGPPAT($PIECE(BGPPATL,R,J))=$PIECE(BGPPATL,R,J)
End DoDot:2
IF $PIECE(BGPPATL,R,J)=""
QUIT
End DoDot:1
+31 IF $GET(BGPSTI)
Begin DoDot:1
+32 NEW BGPDA
+33 SET BGPCNT=0
+34 SET BGPDA=0
FOR
SET BGPDA=$ORDER(^DIBT(BGPSTI,1,BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:2
+35 SET BGPCNT=BGPCNT+1
+36 SET BGPPAT(BGPCNT)=BGPDA
End DoDot:2
End DoDot:1
+37 SET ^BGPTMP($JOB,BGPI)="T00250DATA"_$CHAR(30)
+38 DO EP^BGP4GFO9(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPLST,BGPDIV,BGPBADT,BGPEADT,.BGPCLN,.BGPPAT,BGPRT,BGPFN)
+39 SET BGPI=BGPI+1
+40 SET ^BGPTMP($JOB,BGPI)=+$GET(BGPERR)_$CHAR(30)
+41 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+42 DO EN^XBVK("BGP")
+43 QUIT
+44 ;
FOR10(RETVAL,BGPSTR) ;-- gpra patient forcast report
+1 ; m error trap
SET X="MERR^BGP4GU"
SET @^%ZOSF("TRAP")
+2 NEW BGPI,BGPGDA,P,R,BGPLST,BGPDIV,BGPBADT,BGPEADT,BGPCLN,BGPPATL,BGPPATI,BGPPAT,BGPCLNL,BGPST,BGPSTI,BGPCNT,BGPFN
+3 SET P="|"
SET R="~"
+4 SET RETVAL="^BGPTMP("_$JOB_")"
+5 SET BGPI=0
+6 SET BGPOPT="CRS 14 PATIENT FORECAST REPORT 11"
+7 IF $GET(BGPSTR)=""
DO CATSTR^BGP4GU(.BGPSTR,.BGPSTR)
+8 SET BGPLST=$PIECE(BGPSTR,P)
+9 SET BGPDIV=$PIECE(BGPSTR,P,2)
+10 IF BGPDIV]""
SET BGPDIV=$ORDER(^DG(40.8,"B",BGPDIV,0))
+11 SET BGPBADT=$PIECE(BGPSTR,P,3)
+12 SET BGPEADT=$PIECE(BGPSTR,P,4)
+13 SET BGPCLNL=$PIECE(BGPSTR,P,5)
+14 SET BGPPATL=$PIECE(BGPSTR,P,6)
+15 SET BGPPATI=$PIECE(BGPSTR,P,7)
+16 IF BGPPATI]""
SET BGPPATL(BGPPATI)=""
SET BGPPAT(BGPPATI)=""
+17 SET BGPRT=$PIECE(BGPSTR,P,8)
+18 SET BGPST=$PIECE(BGPSTR,P,9)
+19 SET BGPFN=$PIECE(BGPSTR,P,10)
+20 IF BGPST]""
SET BGPSTI=$ORDER(^DIBT("B",BGPST,0))
+21 IF BGPCLNL]""
IF BGPCLNL'="A"
Begin DoDot:1
+22 NEW I
+23 FOR I=1:1
Begin DoDot:2
+24 IF $PIECE(BGPCLNL,R,I)=""
QUIT
+25 SET BGPCLN($PIECE(BGPCLNL,R,I))=$PIECE(BGPCLNL,R,I)
End DoDot:2
IF $PIECE(BGPCLNL,R,I)=""
QUIT
End DoDot:1
+26 IF BGPPATL]""
Begin DoDot:1
+27 NEW J
+28 FOR J=1:1
Begin DoDot:2
+29 IF $PIECE(BGPPATL,R,J)=""
QUIT
+30 SET BGPPAT($PIECE(BGPPATL,R,J))=$PIECE(BGPPATL,R,J)
End DoDot:2
IF $PIECE(BGPPATL,R,J)=""
QUIT
End DoDot:1
+31 IF $GET(BGPSTI)
Begin DoDot:1
+32 NEW BGPDA
+33 SET BGPCNT=0
+34 SET BGPDA=0
FOR
SET BGPDA=$ORDER(^DIBT(BGPSTI,1,BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:2
+35 SET BGPCNT=BGPCNT+1
+36 SET BGPPAT(BGPCNT)=BGPDA
End DoDot:2
End DoDot:1
+37 SET ^BGPTMP($JOB,BGPI)="T00250DATA"_$CHAR(30)
+38 DO EP^BGP4GFO9(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPLST,BGPDIV,BGPBADT,BGPEADT,.BGPCLN,.BGPPAT,BGPRT,BGPFN)
+39 SET BGPI=BGPI+1
+40 SET ^BGPTMP($JOB,BGPI)=+$GET(BGPERR)_$CHAR(30)
+41 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+42 DO EN^XBVK("BGP")
+43 QUIT
+44 ;
ADASH(RETVAL,BGPSTR) ;-- area dashboard
+1 ; m error trap
SET X="MERR^BGP4GU"
SET @^%ZOSF("TRAP")
+2 NEW BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPAF,BGPYN,BGPOT,BGPOPT,BGPRT,BGPFN,A,R,BGPYR
+3 IF $GET(BGPSTR)=""
DO CATSTR^BGPGR(.BGPSTR,.BGPSTR)
+4 SET P="|"
SET A="*"
SET R="~"
+5 SET BGPI=0
+6 SET BGPERR=""
+7 SET BGPAF=$PIECE(BGPSTR,P)
+8 SET BGPOT=$PIECE(BGPSTR,P,2)
+9 SET BGPFN=$PIECE(BGPSTR,P,3)
+10 SET BGPOPT="CRS 14 AREA NATIONAL GPRA DASHBOARD REPORT"
+11 SET BGPRT=$PIECE(BGPSTR,P,4)
+12 SET BGPLSTI=$PIECE(BGPSTR,P,5)
+13 SET BGPFN=$PIECE(BGPSTR,P,7)
+14 SET BGPYR=$PIECE(BGPSTR,P,8)
+15 NEW I
+16 FOR I=2:1
Begin DoDot:1
+17 IF $PIECE(BGPLSTI,A,I)=""
QUIT
+18 NEW BGPL
+19 SET BGPL=$PIECE($PIECE(BGPLSTI,A,I),R)
+20 SET BGPLIST(BGPL)=""
End DoDot:1
IF $PIECE(BGPLSTI,A,I)=""
QUIT
+21 KILL ^BGPTMP($JOB)
+22 SET RETVAL="^BGPTMP("_$JOB_")"
+23 SET ^BGPTMP($JOB,BGPI)="T02500DATA"_$CHAR(30)
+24 DO EP^BGP4GADB(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPAF,.BGPLIST,BGPOT,BGPRT,BGPFN,BGPYR)
+25 SET BGPI=BGPI+1
+26 SET ^BGPTMP($JOB,BGPI)=$GET(BGPERR)_$CHAR(30)
+27 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+28 DO EN^XBVK("BGP")
+29 QUIT
+30 ;
MANE(RETVAL,BGPSTR) ;-- queue the manual extract
A ; m error trap
SET X="MERR^BGP4GU"
SET @^%ZOSF("TRAP")
+1 NEW BGPI,BGPSITE,BGPTAXI,BGPRT,P,Q,BGPDTH
+2 SET P="|"
+3 IF $GET(BGPSTR)=""
DO CATSTR^BGPGR(.BGPSTR,.BGPSTR)
+4 SET BGPSITE=$PIECE(BGPSTR,P)
+5 SET BGPTAXI=$PIECE(BGPSTR,P,2)
+6 SET BGPRT=$PIECE(BGPSTR,P,3)
+7 SET BGPDTH=$$FMTH^XLFDT(BGPRT)
+8 SET BGPI=0
+9 KILL ^BGPTMP($JOB)
+10 SET RETVAL="^BGPTMP("_$JOB_")"
+11 SET ^BGPTMP($JOB,BGPI)="T00001DATA"_$CHAR(30)
+12 SET BGPT=$PIECE(^BGPGP2PM(BGPSITE,0),U,2)
+13 SET Q=0
+14 FOR F=.02,4.2,4.3,4.4,4.5
IF $$VAL^XBDIQ1(90241.04,BGPSITE,F)=""
SET Q=1
+15 IF Q
Begin DoDot:1
+16 SET BGPI=BGPI+1
+17 SET ^BGPTMP($JOB,BGPI)=0_$CHAR(30)
+18 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
End DoDot:1
QUIT
+19 IF BGPT="T"
Begin DoDot:1
+20 SET BGPDT=$$FMADD^XLFDT(DT,-60)
+21 SET BGPY=$EXTRACT(BGPDT,1,3)
+22 SET BGPM=+$EXTRACT(BGPDT,4,5)
+23 SET BGPD=$PIECE("31^28^31^30^31^30^31^31^30^31^30^31",U,BGPM)
+24 IF BGPM=2
SET BGPD=BGPD+$$LEAP^XLFDT2(BGPY+1700)
+25 SET BGPD=$EXTRACT("00",1,2-$LENGTH(BGPD))_BGPD
+26 SET BGPM=$EXTRACT("00",1,2-$LENGTH(BGPM))_BGPM
+27 SET BGPEND=BGPY_BGPM_BGPD
+28 SET (BGPBD,BGPED,BGPTP)=""
+29 SET BGPBD=$$FMADD^XLFDT(BGPEND,-364)
SET BGPED=BGPEND
SET BGPPER=$EXTRACT(BGPED,1,3)_"0000"
+30 ;***HARD CODED TO BASELINE YEAR 2000
SET BGPVDT=3000000
+31 SET X=$EXTRACT(BGPPER,1,3)-$EXTRACT(BGPVDT,1,3)
+32 SET X=X_"0000"
+33 SET BGPBBD=BGPBD-X
SET BGPBBD=$EXTRACT(BGPBBD,1,3)_$EXTRACT(BGPBD,4,7)
+34 SET BGPBED=BGPED-X
SET BGPBED=$EXTRACT(BGPBED,1,3)_$EXTRACT(BGPED,4,7)
+35 SET BGPPBD=($EXTRACT(BGPBD,1,3)-1)_$EXTRACT(BGPBD,4,7)
+36 SET BGPPED=($EXTRACT(BGPED,1,3)-1)_$EXTRACT(BGPED,4,7)
End DoDot:1
+37 SET X=$ORDER(^BGPCTRL("B",2014,0))
+38 SET Y=^BGPCTRL(X,0)
+39 SET BGPBD=$SELECT(+$EXTRACT(DT,4,7)<701:$EXTRACT(DT,1,3)-1_"0701",1:$EXTRACT(DT,1,3)_"0701")
+40 SET (BGPEND,BGPED)=$SELECT(+$EXTRACT(DT,4,7)<701:$EXTRACT(DT,1,3)_"0630",1:$EXTRACT(DT,1,3)+1_"0630")
+41 ;S BGPPBD=$P(Y,U,10),BGPPED=$P(Y,U,11)
+42 SET BGPPBD=$EXTRACT(BGPBD,1,3)-1_"0701"
SET BGPPED=$EXTRACT(BGPED,1,3)-1_"0630"
+43 SET BGPBBD=$PIECE(Y,U,12)
SET BGPBED=$PIECE(Y,U,13)
+44 SET BGPPER=$PIECE(Y,U,14)
+45 SET BGPQTR=3
+46 ;***HARD CODED TO BASELINE YEAR 2000
SET BGPVDT=3000000
+47 SET BGPAMEX=1
SET BGPERRM=""
+48 SET BGPMAN=1
+49 DO QUE^BGP4AUEX(BGPEND,BGPRT)
+50 IF $GET(ZTSK)
Begin DoDot:1
+51 SET BGPI=BGPI+1
+52 SET ^BGPTMP($JOB,BGPI)=1_$CHAR(30)
End DoDot:1
+53 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+54 DO EN^XBVK("BGP")
+55 QUIT
+56 ;
MANA ;-- queue the area auto extract
+1 QUIT
+2 ;
