BQIMUDFC ;GDIT/HS/ALA-Facility by Division ; 26 Nov 2012 11:07 AM
;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
;
PERF(DATA,REPORT,TMFRAME,PERIOD,DIV) ;EP -- BQI MU PERF BY DIVISION
NEW BQCDAR,BQPDAR,CDATA,CDEN,CEXC,CNUM,CPER,CQN,CRDT,CURDT,CURR,HDR,HEAD,HX,ID,IDN,II,PDATA
NEW PDEN,PEC,PEXC,PNUM,PPER,PQN,PRDT,PREV,PRVR,SORT,PGLOB
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIMUPRPF",UID))
K @DATA
S II=0,SORT=""
S DIV=$G(DIV,""),REPORT=$G(REPORT,"")
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIMUPRV D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
D GTM^BQIMUTIM
;
S HDR="T00050FACILITY^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD^"
S PGLOB=$$PRFPGL^BQIMUTAB(REPORT)
S HX=0,PEC=4
F S HX=$O(@PGLOB@(HX)) Q:'HX I $P(@PGLOB@(HX,0),U,2)="E" D
. I $P(@PGLOB@(HX,0),U,6)'="R" Q
. S HDR=HDR_"T00005"_$P(@PGLOB@(HX,0),U,1)_"_CURR^T00005"_$P(@PGLOB@(HX,0),U,1)_"_PREV^"
. S HEAD($P(@PGLOB@(HX,0),U,1))=PEC,PEC=PEC+2
S @DATA@(II)=$$TKO^BQIUL1(HDR,"^")_$C(30)
;
I $G(DIV)'="" D RPF
I $G(DIV)="" S DIV=0 D
. F S DIV=$O(^BQIFAC(DIV)) Q:'DIV D RPF
S II=II+1,@DATA@(II)=$C(31)
Q
;
CQM(DATA,TMFRAME,PERIOD,DIV) ;EP -- BQI MU CQM BY DIVISION
NEW BQCDAR,BQPDAR,CDATA,CDEN,CEXC,CNUM,CPER,CQN,CRDT,CURDT,CURR,HDR,HEAD,HX,ID,IDN,II,PDATA
NEW PDEN,PEC,PEXC,PNUM,PPER,PQN,PRDT,PREV,PRVR,SORT,MSN
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIMUFCQM",UID))
K @DATA
S DIV=$G(DIV,"")
S II=0,SORT=""
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIMUDFC D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
D GTM^BQIMUTIM
S HDR="T00050FACILITY^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD^"
S HX=0,PEC=4
F S HX=$O(^BGPMUIND(90596.11,HX)) Q:'HX D
. S MSN=$P(^BGPMUIND(90596.11,HX,0),U,1)
. I $G(^BGPMUIND(90595.11,MSN,0))="" Q
. I $P(^BGPMUIND(90595.11,MSN,0),U,4)'="H" D
.. S HDR=HDR_"T00005"_$P(^BGPMUIND(90596.11,HX,0),U,4)_"_CURR^T00005"_$P(^BGPMUIND(90596.11,HX,0),U,4)_"_PREV^"
.. S HEAD($P(^BGPMUIND(90596.11,HX,0),U,4))=PEC,PEC=PEC+2
S @DATA@(II)=$$TKO^BQIUL1(HDR,"^")_$C(30)
;
I $G(DIV)'="" D RCQ
I $G(DIV)="" S DIV=0 D
. F S DIV=$O(^BQIFAC(DIV)) Q:'DIV D RCQ
S II=II+1,@DATA@(II)=$C(31)
Q
;
RCQ ;
S PRVR=DIV_$C(28)_$P(^DIC(4,DIV,0),U,1)
S II=II+1,@DATA@(II)=PRVR_U_CPER_U_PPER_U
K BQCURR,BQPREV
S CRDT=""
F S CRDT=$O(BQCDAR(CRDT)) Q:CRDT="" D
. S CQN=$O(^BQIFAC(DIV,80,"B",CRDT,""))
. D CAGG
;
S PRDT=""
F S PRDT=$O(BQPDAR(PRDT)) Q:PRDT="" D
. S PQN=$O(^BQIFAC(DIV,80,"B",PRDT,""))
. D PAGG
;
S HX=""
F S HX=$O(HEAD(HX)) Q:HX="" D
. S ID=HX,PEC=$G(HEAD(ID)) I PEC="" Q
. S CDEN=$P($G(BQCURR(ID)),U,1),CNUM=$P($G(BQCURR(ID)),U,2),CEXC=$P($G(BQCURR(ID)),U,3)
. I +CNUM=0 S CURR="0%"
. I +CDEN'=0,+CNUM'=0 S CURR=(CNUM/CDEN)*100,CURR=$J(CURR,3,0)_"%",CURR=$$TRIM^BQIUL1(CURR," ")
. I CDEN="",CNUM="",CEXC'="" S CURR="Excluded"
. I CDEN="",CNUM="",CEXC="" S CURR=""
. S PDEN=$P($G(BQPREV(ID)),U,1),PNUM=$P($G(BQPREV(ID)),U,2),PEXC=$P($G(BQPREV(ID)),U,3)
. I +PNUM=0 S PREV="0%"
. I +PDEN'=0,+PNUM'=0 S PREV=$J((PNUM/PDEN)*100,3,0)_"%",PREV=$$TRIM^BQIUL1(PREV," ")
. I PDEN="",PNUM="",PEXC'="" S PREV="Excluded"
. I PDEN="",PNUM="",PEXC="" S PREV=""
. S $P(@DATA@(II),U,PEC)=CURR
. S $P(@DATA@(II),U,PEC+1)=PREV
S @DATA@(II)=@DATA@(II)_$C(30)
K BQCURR,BQPREV
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
;
CAGG ; Aggregate
NEW ID
S ID=""
F S ID=$O(HEAD(ID)) Q:ID="" D
. S BQCURR(ID)=$S(CQN="":"NDA",'$D(^BQIFAC(DIV,80,CQN,1)):"NDA",1:"N/A")
;
I CQN="" Q
S IDN=0
F S IDN=$O(^BQIFAC(DIV,80,CQN,1,IDN)) Q:'IDN D
. S (CDEN,CNUM,CEXC,CURR)=""
. S CDATA=^BQIFAC(DIV,80,CQN,1,IDN,0)
. S CDEN=$P(CDATA,U,2),CNUM=$P(CDATA,U,3),CEXC=$P(CDATA,U,4)
. S ID=$P(CDATA,U,1)
. S $P(BQCURR(ID),U,1)=$P($G(BQCURR(ID)),U,1)+CDEN
. S $P(BQCURR(ID),U,2)=$P($G(BQCURR(ID)),U,2)+CNUM
. S $P(BQCURR(ID),U,3)=$P($G(BQCURR(ID)),U,3)+CEXC
Q
;
PAGG ; Aggregate
NEW ID
S ID=""
F S ID=$O(HEAD(ID)) Q:ID="" D
. S BQPREV(ID)=$S(PQN="":"NDA",'$D(^BQIFAC(DIV,80,PQN,1)):"NDA",1:"N/A")
;
I PQN="" Q
S IDN=0
F S IDN=$O(^BQIFAC(DIV,80,PQN,1,IDN)) Q:'IDN D
. S (PDEN,PNUM,PEXC,PREV)=""
. S PDATA=^BQIFAC(DIV,80,PQN,1,IDN,0)
. S PDEN=$P(PDATA,U,2),PNUM=$P(PDATA,U,3),PEXC=$P(PDATA,U,4)
. S ID=$P(PDATA,U,1)
. S $P(BQPREV(ID),U,1)=$P($G(BQPREV(ID)),U,1)+PDEN
. S $P(BQPREV(ID),U,2)=$P($G(BQPREV(ID)),U,2)+PNUM
. S $P(BQPREV(ID),U,3)=$P($G(BQPREV(ID)),U,3)+PEXC
Q
;
RPF ;
S PRVR=DIV_$C(28)_$P(^DIC(4,DIV,0),U,1)
S II=II+1,@DATA@(II)=PRVR_U_CPER_U_PPER_U
K BQCURR,BQPREV
S CRDT=""
F S CRDT=$O(BQCDAR(CRDT)) Q:CRDT="" D
. S CQN=$O(^BQIFAC(DIV,70,"B",CRDT,""))
. D CPAGG
;
S PRDT=""
F S PRDT=$O(BQPDAR(PRDT)) Q:PRDT="" D
. S PQN=$O(^BQIFAC(DIV,70,"B",PRDT,""))
. D PPAGG
;
S HX=""
F S HX=$O(HEAD(HX)) Q:HX="" D
. S ID=HX,PEC=$G(HEAD(ID)) I PEC="" Q
. S CDEN=$P($G(BQCURR(ID)),U,1),CNUM=$P($G(BQCURR(ID)),U,2)
. S CEXC=$P($G(BQCURR(ID)),U,3)
. I +CNUM=0 S CURR="0%"
. I +CDEN'=0,+CNUM'=0 S CURR=(CNUM/CDEN)*100,CURR=$J(CURR,3,0)_"%",CURR=$$TRIM^BQIUL1(CURR," ")
. I CDEN="",CNUM="",CEXC'="" S CURR="Excluded"
. I CDEN="",CNUM="",CEXC="" S CURR=""
. S PDEN=$P($G(BQPREV(ID)),U,1),PNUM=$P($G(BQPREV(ID)),U,2),PEXC=$P($G(BQPREV(ID)),U,3)
. I +PNUM=0 S PREV="0%"
. I +PDEN'=0,+PNUM'=0 S PREV=$J((PNUM/PDEN)*100,3,0)_"%",PREV=$$TRIM^BQIUL1(PREV," ")
. I PDEN="",PNUM="",PEXC'="" S PREV="Excluded"
. I PDEN="",PNUM="",PEXC="" S PREV=""
. S $P(@DATA@(II),U,PEC)=CURR
. S $P(@DATA@(II),U,PEC+1)=PREV
S @DATA@(II)=@DATA@(II)_$C(30)
K BQCURR,BQPREV
Q
;
CPAGG ; Aggregate performance
NEW ID
S ID=""
F S ID=$O(HEAD(ID)) Q:ID="" D
. S BQCURR(ID)=$S(CQN="":"NDA",'$D(^BQIFAC(DIV,70,CQN,1)):"NDA",1:"N/A")
;
I CQN="" Q
S IDN=0
F S IDN=$O(^BQIFAC(DIV,70,CQN,1,IDN)) Q:'IDN D
. S (CDEN,CNUM,CEXC,CURR)=""
. S CDATA=^BQIFAC(DIV,70,CQN,1,IDN,0)
. S CEXC=$G(^BQIFAC(DIV,70,CQN,1,IDN,1))
. S CDEN=$P(CDATA,U,2),CNUM=$P(CDATA,U,3)
. S ID=$P(CDATA,U,1)
. I CDEN="",CEXC'="" S $P(BQICURR(ID),U,3)=CEXC Q
. S $P(BQCURR(ID),U,1)=$P($G(BQCURR(ID)),U,1)+CDEN
. S $P(BQCURR(ID),U,2)=$P($G(BQCURR(ID)),U,2)+CNUM
Q
;
PPAGG ;
NEW ID
S ID=""
F S ID=$O(HEAD(ID)) Q:ID="" D
. S BQPREV(ID)=$S(PQN="":"NDA",'$D(^BQIFAC(DIV,70,PQN,1)):"NDA",1:"N/A")
;
I PQN="" Q
S IDN=0
F S IDN=$O(^BQIFAC(DIV,70,PQN,1,IDN)) Q:'IDN D
. S (PDEN,PNUM,PEXC,PREV)=""
. S PDATA=^BQIFAC(DIV,70,PQN,1,IDN,0)
. S PEXC=$G(^BQIFAC(DIV,70,PQN,1,IDN,1))
. S PDEN=$P(PDATA,U,2),PNUM=$P(PDATA,U,3)
. S ID=$P(PDATA,U,1)
. I PDEN="",PEXC'="" S $P(BQIPREV(ID),U,3)=PEXC
. S $P(BQPREV(ID),U,1)=$P($G(BQPREV(ID)),U,1)+PDEN
. S $P(BQPREV(ID),U,2)=$P($G(BQPREV(ID)),U,2)+PNUM
Q
BQIMUDFC ;GDIT/HS/ALA-Facility by Division ; 26 Nov 2012 11:07 AM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
+2 ;
PERF(DATA,REPORT,TMFRAME,PERIOD,DIV) ;EP -- BQI MU PERF BY DIVISION
+1 NEW BQCDAR,BQPDAR,CDATA,CDEN,CEXC,CNUM,CPER,CQN,CRDT,CURDT,CURR,HDR,HEAD,HX,ID,IDN,II,PDATA
+2 NEW PDEN,PEC,PEXC,PNUM,PPER,PQN,PRDT,PREV,PRVR,SORT,PGLOB
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BQIMUPRPF",UID))
+5 KILL @DATA
+6 SET II=0
SET SORT=""
+7 SET DIV=$GET(DIV,"")
SET REPORT=$GET(REPORT,"")
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIMUPRV D UNWIND^%ZTER"
+9 ;
+10 DO GTM^BQIMUTIM
+11 ;
+12 SET HDR="T00050FACILITY^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD^"
+13 SET PGLOB=$$PRFPGL^BQIMUTAB(REPORT)
+14 SET HX=0
SET PEC=4
+15 FOR
SET HX=$ORDER(@PGLOB@(HX))
IF 'HX
QUIT
IF $PIECE(@PGLOB@(HX,0),U,2)="E"
Begin DoDot:1
+16 IF $PIECE(@PGLOB@(HX,0),U,6)'="R"
QUIT
+17 SET HDR=HDR_"T00005"_$PIECE(@PGLOB@(HX,0),U,1)_"_CURR^T00005"_$PIECE(@PGLOB@(HX,0),U,1)_"_PREV^"
+18 SET HEAD($PIECE(@PGLOB@(HX,0),U,1))=PEC
SET PEC=PEC+2
End DoDot:1
+19 SET @DATA@(II)=$$TKO^BQIUL1(HDR,"^")_$CHAR(30)
+20 ;
+21 IF $GET(DIV)'=""
DO RPF
+22 IF $GET(DIV)=""
SET DIV=0
Begin DoDot:1
+23 FOR
SET DIV=$ORDER(^BQIFAC(DIV))
IF 'DIV
QUIT
DO RPF
End DoDot:1
+24 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+25 QUIT
+26 ;
CQM(DATA,TMFRAME,PERIOD,DIV) ;EP -- BQI MU CQM BY DIVISION
+1 NEW BQCDAR,BQPDAR,CDATA,CDEN,CEXC,CNUM,CPER,CQN,CRDT,CURDT,CURR,HDR,HEAD,HX,ID,IDN,II,PDATA
+2 NEW PDEN,PEC,PEXC,PNUM,PPER,PQN,PRDT,PREV,PRVR,SORT,MSN
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BQIMUFCQM",UID))
+5 KILL @DATA
+6 SET DIV=$GET(DIV,"")
+7 SET II=0
SET SORT=""
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIMUDFC D UNWIND^%ZTER"
+9 ;
+10 DO GTM^BQIMUTIM
+11 SET HDR="T00050FACILITY^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD^"
+12 SET HX=0
SET PEC=4
+13 FOR
SET HX=$ORDER(^BGPMUIND(90596.11,HX))
IF 'HX
QUIT
Begin DoDot:1
+14 SET MSN=$PIECE(^BGPMUIND(90596.11,HX,0),U,1)
+15 IF $GET(^BGPMUIND(90595.11,MSN,0))=""
QUIT
+16 IF $PIECE(^BGPMUIND(90595.11,MSN,0),U,4)'="H"
Begin DoDot:2
+17 SET HDR=HDR_"T00005"_$PIECE(^BGPMUIND(90596.11,HX,0),U,4)_"_CURR^T00005"_$PIECE(^BGPMUIND(90596.11,HX,0),U,4)_"_PREV^"
+18 SET HEAD($PIECE(^BGPMUIND(90596.11,HX,0),U,4))=PEC
SET PEC=PEC+2
End DoDot:2
End DoDot:1
+19 SET @DATA@(II)=$$TKO^BQIUL1(HDR,"^")_$CHAR(30)
+20 ;
+21 IF $GET(DIV)'=""
DO RCQ
+22 IF $GET(DIV)=""
SET DIV=0
Begin DoDot:1
+23 FOR
SET DIV=$ORDER(^BQIFAC(DIV))
IF 'DIV
QUIT
DO RCQ
End DoDot:1
+24 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+25 QUIT
+26 ;
RCQ ;
+1 SET PRVR=DIV_$CHAR(28)_$PIECE(^DIC(4,DIV,0),U,1)
+2 SET II=II+1
SET @DATA@(II)=PRVR_U_CPER_U_PPER_U
+3 KILL BQCURR,BQPREV
+4 SET CRDT=""
+5 FOR
SET CRDT=$ORDER(BQCDAR(CRDT))
IF CRDT=""
QUIT
Begin DoDot:1
+6 SET CQN=$ORDER(^BQIFAC(DIV,80,"B",CRDT,""))
+7 DO CAGG
End DoDot:1
+8 ;
+9 SET PRDT=""
+10 FOR
SET PRDT=$ORDER(BQPDAR(PRDT))
IF PRDT=""
QUIT
Begin DoDot:1
+11 SET PQN=$ORDER(^BQIFAC(DIV,80,"B",PRDT,""))
+12 DO PAGG
End DoDot:1
+13 ;
+14 SET HX=""
+15 FOR
SET HX=$ORDER(HEAD(HX))
IF HX=""
QUIT
Begin DoDot:1
+16 SET ID=HX
SET PEC=$GET(HEAD(ID))
IF PEC=""
QUIT
+17 SET CDEN=$PIECE($GET(BQCURR(ID)),U,1)
SET CNUM=$PIECE($GET(BQCURR(ID)),U,2)
SET CEXC=$PIECE($GET(BQCURR(ID)),U,3)
+18 IF +CNUM=0
SET CURR="0%"
+19 IF +CDEN'=0
IF +CNUM'=0
SET CURR=(CNUM/CDEN)*100
SET CURR=$JUSTIFY(CURR,3,0)_"%"
SET CURR=$$TRIM^BQIUL1(CURR," ")
+20 IF CDEN=""
IF CNUM=""
IF CEXC'=""
SET CURR="Excluded"
+21 IF CDEN=""
IF CNUM=""
IF CEXC=""
SET CURR=""
+22 SET PDEN=$PIECE($GET(BQPREV(ID)),U,1)
SET PNUM=$PIECE($GET(BQPREV(ID)),U,2)
SET PEXC=$PIECE($GET(BQPREV(ID)),U,3)
+23 IF +PNUM=0
SET PREV="0%"
+24 IF +PDEN'=0
IF +PNUM'=0
SET PREV=$JUSTIFY((PNUM/PDEN)*100,3,0)_"%"
SET PREV=$$TRIM^BQIUL1(PREV," ")
+25 IF PDEN=""
IF PNUM=""
IF PEXC'=""
SET PREV="Excluded"
+26 IF PDEN=""
IF PNUM=""
IF PEXC=""
SET PREV=""
+27 SET $PIECE(@DATA@(II),U,PEC)=CURR
+28 SET $PIECE(@DATA@(II),U,PEC+1)=PREV
End DoDot:1
+29 SET @DATA@(II)=@DATA@(II)_$CHAR(30)
+30 KILL BQCURR,BQPREV
+31 QUIT
+32 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
CAGG ; Aggregate
+1 NEW ID
+2 SET ID=""
+3 FOR
SET ID=$ORDER(HEAD(ID))
IF ID=""
QUIT
Begin DoDot:1
+4 SET BQCURR(ID)=$SELECT(CQN="":"NDA",'$DATA(^BQIFAC(DIV,80,CQN,1)):"NDA",1:"N/A")
End DoDot:1
+5 ;
+6 IF CQN=""
QUIT
+7 SET IDN=0
+8 FOR
SET IDN=$ORDER(^BQIFAC(DIV,80,CQN,1,IDN))
IF 'IDN
QUIT
Begin DoDot:1
+9 SET (CDEN,CNUM,CEXC,CURR)=""
+10 SET CDATA=^BQIFAC(DIV,80,CQN,1,IDN,0)
+11 SET CDEN=$PIECE(CDATA,U,2)
SET CNUM=$PIECE(CDATA,U,3)
SET CEXC=$PIECE(CDATA,U,4)
+12 SET ID=$PIECE(CDATA,U,1)
+13 SET $PIECE(BQCURR(ID),U,1)=$PIECE($GET(BQCURR(ID)),U,1)+CDEN
+14 SET $PIECE(BQCURR(ID),U,2)=$PIECE($GET(BQCURR(ID)),U,2)+CNUM
+15 SET $PIECE(BQCURR(ID),U,3)=$PIECE($GET(BQCURR(ID)),U,3)+CEXC
End DoDot:1
+16 QUIT
+17 ;
PAGG ; Aggregate
+1 NEW ID
+2 SET ID=""
+3 FOR
SET ID=$ORDER(HEAD(ID))
IF ID=""
QUIT
Begin DoDot:1
+4 SET BQPREV(ID)=$SELECT(PQN="":"NDA",'$DATA(^BQIFAC(DIV,80,PQN,1)):"NDA",1:"N/A")
End DoDot:1
+5 ;
+6 IF PQN=""
QUIT
+7 SET IDN=0
+8 FOR
SET IDN=$ORDER(^BQIFAC(DIV,80,PQN,1,IDN))
IF 'IDN
QUIT
Begin DoDot:1
+9 SET (PDEN,PNUM,PEXC,PREV)=""
+10 SET PDATA=^BQIFAC(DIV,80,PQN,1,IDN,0)
+11 SET PDEN=$PIECE(PDATA,U,2)
SET PNUM=$PIECE(PDATA,U,3)
SET PEXC=$PIECE(PDATA,U,4)
+12 SET ID=$PIECE(PDATA,U,1)
+13 SET $PIECE(BQPREV(ID),U,1)=$PIECE($GET(BQPREV(ID)),U,1)+PDEN
+14 SET $PIECE(BQPREV(ID),U,2)=$PIECE($GET(BQPREV(ID)),U,2)+PNUM
+15 SET $PIECE(BQPREV(ID),U,3)=$PIECE($GET(BQPREV(ID)),U,3)+PEXC
End DoDot:1
+16 QUIT
+17 ;
RPF ;
+1 SET PRVR=DIV_$CHAR(28)_$PIECE(^DIC(4,DIV,0),U,1)
+2 SET II=II+1
SET @DATA@(II)=PRVR_U_CPER_U_PPER_U
+3 KILL BQCURR,BQPREV
+4 SET CRDT=""
+5 FOR
SET CRDT=$ORDER(BQCDAR(CRDT))
IF CRDT=""
QUIT
Begin DoDot:1
+6 SET CQN=$ORDER(^BQIFAC(DIV,70,"B",CRDT,""))
+7 DO CPAGG
End DoDot:1
+8 ;
+9 SET PRDT=""
+10 FOR
SET PRDT=$ORDER(BQPDAR(PRDT))
IF PRDT=""
QUIT
Begin DoDot:1
+11 SET PQN=$ORDER(^BQIFAC(DIV,70,"B",PRDT,""))
+12 DO PPAGG
End DoDot:1
+13 ;
+14 SET HX=""
+15 FOR
SET HX=$ORDER(HEAD(HX))
IF HX=""
QUIT
Begin DoDot:1
+16 SET ID=HX
SET PEC=$GET(HEAD(ID))
IF PEC=""
QUIT
+17 SET CDEN=$PIECE($GET(BQCURR(ID)),U,1)
SET CNUM=$PIECE($GET(BQCURR(ID)),U,2)
+18 SET CEXC=$PIECE($GET(BQCURR(ID)),U,3)
+19 IF +CNUM=0
SET CURR="0%"
+20 IF +CDEN'=0
IF +CNUM'=0
SET CURR=(CNUM/CDEN)*100
SET CURR=$JUSTIFY(CURR,3,0)_"%"
SET CURR=$$TRIM^BQIUL1(CURR," ")
+21 IF CDEN=""
IF CNUM=""
IF CEXC'=""
SET CURR="Excluded"
+22 IF CDEN=""
IF CNUM=""
IF CEXC=""
SET CURR=""
+23 SET PDEN=$PIECE($GET(BQPREV(ID)),U,1)
SET PNUM=$PIECE($GET(BQPREV(ID)),U,2)
SET PEXC=$PIECE($GET(BQPREV(ID)),U,3)
+24 IF +PNUM=0
SET PREV="0%"
+25 IF +PDEN'=0
IF +PNUM'=0
SET PREV=$JUSTIFY((PNUM/PDEN)*100,3,0)_"%"
SET PREV=$$TRIM^BQIUL1(PREV," ")
+26 IF PDEN=""
IF PNUM=""
IF PEXC'=""
SET PREV="Excluded"
+27 IF PDEN=""
IF PNUM=""
IF PEXC=""
SET PREV=""
+28 SET $PIECE(@DATA@(II),U,PEC)=CURR
+29 SET $PIECE(@DATA@(II),U,PEC+1)=PREV
End DoDot:1
+30 SET @DATA@(II)=@DATA@(II)_$CHAR(30)
+31 KILL BQCURR,BQPREV
+32 QUIT
+33 ;
CPAGG ; Aggregate performance
+1 NEW ID
+2 SET ID=""
+3 FOR
SET ID=$ORDER(HEAD(ID))
IF ID=""
QUIT
Begin DoDot:1
+4 SET BQCURR(ID)=$SELECT(CQN="":"NDA",'$DATA(^BQIFAC(DIV,70,CQN,1)):"NDA",1:"N/A")
End DoDot:1
+5 ;
+6 IF CQN=""
QUIT
+7 SET IDN=0
+8 FOR
SET IDN=$ORDER(^BQIFAC(DIV,70,CQN,1,IDN))
IF 'IDN
QUIT
Begin DoDot:1
+9 SET (CDEN,CNUM,CEXC,CURR)=""
+10 SET CDATA=^BQIFAC(DIV,70,CQN,1,IDN,0)
+11 SET CEXC=$GET(^BQIFAC(DIV,70,CQN,1,IDN,1))
+12 SET CDEN=$PIECE(CDATA,U,2)
SET CNUM=$PIECE(CDATA,U,3)
+13 SET ID=$PIECE(CDATA,U,1)
+14 IF CDEN=""
IF CEXC'=""
SET $PIECE(BQICURR(ID),U,3)=CEXC
QUIT
+15 SET $PIECE(BQCURR(ID),U,1)=$PIECE($GET(BQCURR(ID)),U,1)+CDEN
+16 SET $PIECE(BQCURR(ID),U,2)=$PIECE($GET(BQCURR(ID)),U,2)+CNUM
End DoDot:1
+17 QUIT
+18 ;
PPAGG ;
+1 NEW ID
+2 SET ID=""
+3 FOR
SET ID=$ORDER(HEAD(ID))
IF ID=""
QUIT
Begin DoDot:1
+4 SET BQPREV(ID)=$SELECT(PQN="":"NDA",'$DATA(^BQIFAC(DIV,70,PQN,1)):"NDA",1:"N/A")
End DoDot:1
+5 ;
+6 IF PQN=""
QUIT
+7 SET IDN=0
+8 FOR
SET IDN=$ORDER(^BQIFAC(DIV,70,PQN,1,IDN))
IF 'IDN
QUIT
Begin DoDot:1
+9 SET (PDEN,PNUM,PEXC,PREV)=""
+10 SET PDATA=^BQIFAC(DIV,70,PQN,1,IDN,0)
+11 SET PEXC=$GET(^BQIFAC(DIV,70,PQN,1,IDN,1))
+12 SET PDEN=$PIECE(PDATA,U,2)
SET PNUM=$PIECE(PDATA,U,3)
+13 SET ID=$PIECE(PDATA,U,1)
+14 IF PDEN=""
IF PEXC'=""
SET $PIECE(BQIPREV(ID),U,3)=PEXC
+15 SET $PIECE(BQPREV(ID),U,1)=$PIECE($GET(BQPREV(ID)),U,1)+PDEN
+16 SET $PIECE(BQPREV(ID),U,2)=$PIECE($GET(BQPREV(ID)),U,2)+PNUM
End DoDot:1
+17 QUIT
