BQIMUDPR.m

BQIMUDPR ;GDIT/HS/ALA-MU Performance by Division ; 21 Nov 2012  3:56 PM

 ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66

 ;

PROV(DATA,REPORT,TMFRAME,PERIOD,PROV,CNT,DIV) ;EP -- BQI MU GET PROVIDER

 NEW UID,II,HDR,C1,C2,C3,C4,NAME,HEAD,HX,PEC,SORT,QFL,PCT,CT,DDATA,CPER,PPER

 NEW BQCDAR,BQICURR,BQIPREV,BQPDAR,CDATA,CQN,CRDT,CURDT,OK,PDATA,PQN,PRDT,QQF,ID

 NEW PGLOB

 S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)

 S DATA=$NA(^TMP("BQIMUPRPF",UID))

 K @DATA

 S II=0

 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="T00050PROVIDER^T00001HIDE_PROV_SORT^T00060TYPE^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD^"

 S PGLOB=$$PRFPGL^BQIMUTAB(REPORT)

 S HX=0,PEC=6

 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)=HDR_"T00020HIDE_LAST_PROV"_$C(30)

 S (C1,C2,C3,C4,CT,PCT)=0

 S PROV=$G(PROV,"")

 I PROV="" S PROV=+PROV

 I PROV'="" D

 . S C1=+$P(PROV,":",2),C2=+$P(PROV,":",3),C3=+$P(PROV,":",4),C4=+$P(PROV,":",5),CT=+$P(PROV,":",6)

 . S PROV=$P(PROV,":",1)

 S CNT=$G(CNT,0),QFL=0,QQF=0

 I CT=0 D

 . I '$D(^BQIPROV(DUZ)) Q

 . I $G(DIV)'="",'$D(^VA(200,DUZ,2,"B",DIV)) Q

 . I $D(^BQIPROV(DUZ)) D RTE(DUZ) D

 .. I QQF S QQF=0 Q

 .. S @DATA@(II)=@DATA@(II)_U_PROV_":"_C1_":"_C2_":"_C3_":"_C4_":"_CT_$C(30)

 ;

 F  S PROV=$O(^BQIPROV(PROV)) Q:'PROV  D  Q:QFL

 . I PROV=DUZ Q

 . I '$D(^BQIPROV(PROV,40)) Q

 . I '$D(^BQI(90508,1,14,"B",PROV)) Q

 . I $G(DIV)'="",'$D(^VA(200,PROV,2,"B",DIV)) Q

 . I PROV'=DUZ D RTE(PROV) D

 .. I QQF S QQF=0 Q

 .. S @DATA@(II)=@DATA@(II)_U_PROV_":"_C1_":"_C2_":"_C3_":"_C4_":"_CT_$C(30)

 .. I CNT'=0,PCT=CNT S QFL=1

 ;

DONE ;

 S II=II+1,@DATA@(II)=$C(31)

 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

 ;

NAM ;EP

 S C1=C1+1 S:C1=27 C2=C2+1,C1=1 S:C2=27 C3=C3+1,C2=1,C1=1 S:C3=27 C4=C4+1,C3=1,C2=1,C1=1 S NAME="PROVIDER "_$S(C4>0:$C(C4+64),1:"")_$S(C3>0:$C(C3+64),1:"")_$S(C2>0:$C(C2+64),1:"")_$S(C1>0:$C(C1+64),1:"")

 Q

 ;

RTE(PRV) ; EP

 NEW DATE,FAC,MN,MDATA,PRVR,CFROM,CTHRU,PFROM,PTHRU,IDN,CDEN,CNUM,CEXC,PDEN

 NEW PNUM,PEXC,CURR,PREV,SORT,USN,TYPE,DDATA

 I '$D(^BQIPROV(PRV,40)) S QQF=1 Q

 S CT=CT+1,PCT=PCT+1

 I DUZ=PRV S PRVR=PRV_$C(28)_$P($G(^VA(200,PRV,0)),U,1),SORT=1_"_"_$P($G(^VA(200,PRV,0)),U,1)

 I '$D(^XUSEC("BQIZMUMGR",DUZ)),'$D(^XUSEC("BQIZMGR",DUZ)) D

 . I DUZ'=PRV D NAM S PRVR=PRV_$C(28)_NAME,SORT=2_"_"_NAME

 I $D(^XUSEC("BQIZMUMGR",DUZ))!($D(^XUSEC("BQIZMGR",DUZ))) D

 . I DUZ'=PRV S PRVR=PRV_$C(28)_$P($G(^VA(200,PRV,0)),U,1),SORT=1_"_"_$P($G(^VA(200,PRV,0)),U,1)

 S DDATA=$G(^BQIPROV(PRV,0)) I DDATA="" Q

 ;

 S USN="",TYPE="",OK=0

 F  S USN=$O(^USR(8930.3,"B",PRV,USN),-1) Q:USN=""  D

 . I '$$CURRENT^USRLM(USN) Q

 . S TYPE=$P(^USR(8930.3,USN,0),U,2)

 . I $O(^BQI(90508,1,13,"B",TYPE,""))="" S TYPE="" Q

 . S OK=1

 I 'OK S QQF=1,CT=CT-1,PCT=PCT-1 Q

 I TYPE'="" S TYPE=$S($P($G(^USR(8930,TYPE,0)),U,4)'="":$P($G(^USR(8930,TYPE,0)),U,4),1:$P($G(^USR(8930,TYPE,0)),U,1))

 S II=II+1,@DATA@(II)=PRVR_U_SORT_U_TYPE_U_CPER_U_PPER_U

 ;

 K BQCURR,BQPREV

 S ID=""

 F  S ID=$O(HEAD(ID)) Q:ID=""  D

 . S BQCURR(ID)=$S($G(CQN)="":"NDA",'$D(^BQIPROV(PRV,40,CQN,1)):"NDA",1:"N/A")

 ;

 S CRDT=""

 F  S CRDT=$O(BQCDAR(CRDT)) Q:CRDT=""  D

 . S CQN=$O(^BQIPROV(PRV,40,"B",CRDT,""))

 . D CPAGG

 ;

 S ID=""

 F  S ID=$O(HEAD(ID)) Q:ID=""  D

 . S BQPREV(ID)=$S($G(PQN)="":"NDA",'$D(^BQIPROV(PRV,40,PQN,1)):"NDA",1:"N/A")

 ;

 S PRDT=""

 F  S PRDT=$O(BQPDAR(PRDT)) Q:PRDT=""  D

 . S PQN=$O(^BQIPROV(PRV,40,"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

 K BQCURR,BQPREV

 Q

 ;

HOV(DATA,REPORT,TMFRAME,PERIOD,PROV,CNT,DIV) ;EP -- BQI MU GET PROV HOVER

 NEW UID,II,HDR,C1,C2,C3,C4,NAME,HEAD,HX,PEC,SORT,QFL,PCT,CT,DDATA,CPER,PPER

 NEW BQCDAR,BQICURR,BQIPREV,BQPDAR,CDATA,CQN,CRDT,CURDT,OK,PDATA,PQN,PRDT,QQF,ID

 NEW PGLOB

 S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)

 S DATA=$NA(^TMP("BQIMUPRPFH",UID))

 K @DATA

 S II=0

 S DIV=$G(DIV,""),REPORT=$G(REPORT,"")

 NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIMUDPR D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2

 ;

 D GTM^BQIMUTIM

 ;

 S HDR="T00050PROVIDER^T00001HIDE_PROV_SORT^T00060TYPE^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD^"

 S PGLOB=$$PRFPGL^BQIMUTAB(REPORT)

 S HX=0,PEC=6

 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)=HDR_"T00020HIDE_LAST_PROV"_$C(30)

 S (C1,C2,C3,C4,CT,PCT)=0

 S PROV=$G(PROV,"")

 I PROV="" S PROV=+PROV

 I PROV'="" D

 . S C1=+$P(PROV,":",2),C2=+$P(PROV,":",3),C3=+$P(PROV,":",4),C4=+$P(PROV,":",5),CT=+$P(PROV,":",6)

 . S PROV=$P(PROV,":",1)

 S CNT=$G(CNT,0),QFL=0,QQF=0

 I CT=0 D

 . I '$D(^BQIPROV(DUZ)) Q

 . I $G(DIV)'="",'$D(^VA(200,DUZ,2,"B",DIV)) Q

 . I $D(^BQIPROV(DUZ)) D PRTE(DUZ) D

 .. I QQF S QQF=0 Q

 .. S @DATA@(II)=@DATA@(II)_U_PROV_":"_C1_":"_C2_":"_C3_":"_C4_":"_CT_$C(30)

 ;

 F  S PROV=$O(^BQIPROV(PROV)) Q:'PROV  D  Q:QFL

 . I PROV=DUZ Q

 . I '$D(^BQI(90508,1,14,"B",PROV)) Q

 . I $G(DIV)'="",'$D(^VA(200,PROV,2,"B",DIV)) Q

 . I PROV'=DUZ D PRTE(PROV) D

 .. I QQF S QQF=0 Q

 .. S @DATA@(II)=@DATA@(II)_U_PROV_":"_C1_":"_C2_":"_C3_":"_C4_":"_CT_$C(30)

 .. I CNT'=0,PCT=CNT S QFL=1

 S II=II+1,@DATA@(II)=$C(31)

 Q

 ;

PRTE(PRV) ; EP

 NEW DATE,FAC,MN,MDATA,PRVR,CFROM,CTHRU,PFROM,PTHRU,IDN,CDEN,CNUM,CEXC,PDEN

 NEW PNUM,PEXC,CURR,PREV,SORT,USN,TYPE,DDATA

 I '$D(^BQIPROV(PRV,40)) S QQF=1 Q

 S CT=CT+1,PCT=PCT+1

 I DUZ=PRV S PRVR=PRV_$C(28)_$P($G(^VA(200,PRV,0)),U,1),SORT=1_"_"_$P($G(^VA(200,PRV,0)),U,1)

 I '$D(^XUSEC("BQIZMUMGR",DUZ)),'$D(^XUSEC("BQIZMGR",DUZ)) D

 . I DUZ'=PRV D NAM S PRVR=PRV_$C(28)_NAME,SORT=2_"_"_NAME

 I $D(^XUSEC("BQIZMUMGR",DUZ))!($D(^XUSEC("BQIZMGR",DUZ))) D

 . I DUZ'=PRV S PRVR=PRV_$C(28)_$P($G(^VA(200,PRV,0)),U,1),SORT=1_"_"_$P($G(^VA(200,PRV,0)),U,1)

 S DDATA=$G(^BQIPROV(PRV,0)) I DDATA="" Q

 ;

 S USN="",TYPE="",OK=0

 F  S USN=$O(^USR(8930.3,"B",PRV,USN),-1) Q:USN=""  D

 . I '$$CURRENT^USRLM(USN) Q

 . S TYPE=$P(^USR(8930.3,USN,0),U,2)

 . I $O(^BQI(90508,1,13,"B",TYPE,""))="" S TYPE="" Q

 . S OK=1

 I 'OK S QQF=1,CT=CT-1,PCT=PCT-1 Q

 I TYPE'="" S TYPE=$S($P($G(^USR(8930,TYPE,0)),U,4)'="":$P($G(^USR(8930,TYPE,0)),U,4),1:$P($G(^USR(8930,TYPE,0)),U,1))

 S II=II+1,@DATA@(II)=PRVR_U_SORT_U_TYPE_U_CPER_U_PPER_U

 ;

 K BQCURR,BQPREV

 S CRDT=""

 F  S CRDT=$O(BQCDAR(CRDT)) Q:CRDT=""  D

 . S CQN=$O(^BQIPROV(PRV,40,"B",CRDT,""))

 . D CPAGG

 ;

 S PRDT=""

 F  S PRDT=$O(BQPDAR(PRDT)) Q:PRDT=""  D

 . S PQN=$O(^BQIPROV(PRV,40,"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)

 . S PDEN=$P($G(BQPREV(ID)),U,1),PNUM=$P($G(BQPREV(ID)),U,2)

 . S PEXC=$P($G(BQPREV(ID)),U,3)

 . I +CNUM=0 S CURR="None"

 . I +PNUM=0 S PREV="None"

 . I +CDEN'=0 S CURR="Numerator: "_+CNUM_" Denominator: "_CDEN

 . I +PDEN'=0 S PREV="Numerator: "_+PNUM_" Denominator: "_PDEN

 . I CDEN="",CNUM="",CEXC'="" S CURR=CEXC

 . I PDEN="",PNUM="",PEXC'="" S PREV=PEXC

 . I CURR'="" S $P(@DATA@(II),U,PEC)=CURR

 . I PREV'="" S $P(@DATA@(II),U,PEC+1)=PREV

 K BQCURR,BQPREV

 Q

 ;

CPAGG ; Aggregate performance

 NEW ID

 ;

 I CQN="" Q

 S IDN=0

 F  S IDN=$O(^BQIPROV(PRV,40,CQN,1,IDN)) Q:'IDN  D

 . S (CDEN,CNUM,CEXC,CURR)=""

 . S CDATA=^BQIPROV(PRV,40,CQN,1,IDN,0)

 . I $P(CDATA,U,4)'=REPORT Q

 . S CEXC=$G(^BQIPROV(PRV,40,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

 ;

 I PQN="" Q

 S IDN=0

 F  S IDN=$O(^BQIPROV(PRV,40,PQN,1,IDN)) Q:'IDN  D

 . S (PDEN,PNUM,PEXC,PREV)=""

 . S PDATA=^BQIPROV(PRV,40,PQN,1,IDN,0)

 . I $P(PDATA,U,4)'=REPORT Q

 . S PEXC=$G(^BQIPROV(PRV,40,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

BQIMUDPR  ;GDIT/HS/ALA-MU Performance by Division ; 21 Nov 2012  3:56 PM

 +1       ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66

 +2       ;

PROV(DATA,REPORT,TMFRAME,PERIOD,PROV,CNT,DIV) ;EP -- BQI MU GET PROVIDER

 +1        NEW UID,II,HDR,C1,C2,C3,C4,NAME,HEAD,HX,PEC,SORT,QFL,PCT,CT,DDATA,CPER,PPER

 +2        NEW BQCDAR,BQICURR,BQIPREV,BQPDAR,CDATA,CQN,CRDT,CURDT,OK,PDATA,PQN,PRDT,QQF,ID

 +3        NEW PGLOB

 +4        SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)

 +5        SET DATA=$NAME(^TMP("BQIMUPRPF",UID))

 +6        KILL @DATA

 +7        SET II=0

 +8        SET DIV=$GET(DIV,"")

           SET REPORT=$GET(REPORT,"")

 +9       ; SAC 2006 2.2.3.3.2

           NEW $ESTACK,$ETRAP

           SET $ETRAP="D ERR^BQIMUPRV D UNWIND^%ZTER"

 +10      ;

 +11       DO GTM^BQIMUTIM

 +12      ;

 +13       SET HDR="T00050PROVIDER^T00001HIDE_PROV_SORT^T00060TYPE^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD^"

 +14       SET PGLOB=$$PRFPGL^BQIMUTAB(REPORT)

 +15       SET HX=0

           SET PEC=6

 +16       FOR 

               SET HX=$ORDER(@PGLOB@(HX))

               IF 'HX

                   QUIT 

               IF $PIECE(@PGLOB@(HX,0),U,2)="E"

                   Begin DoDot:1

 +17                   IF $PIECE(@PGLOB@(HX,0),U,6)'="R"

                           QUIT 

 +18                   SET HDR=HDR_"T00005"_$PIECE(@PGLOB@(HX,0),U,1)_"_CURR^T00005"_$PIECE(@PGLOB@(HX,0),U,1)_"_PREV^"

 +19                   SET HEAD($PIECE(@PGLOB@(HX,0),U,1))=PEC

                       SET PEC=PEC+2

                   End DoDot:1

 +20       SET @DATA@(II)=HDR_"T00020HIDE_LAST_PROV"_$CHAR(30)

 +21       SET (C1,C2,C3,C4,CT,PCT)=0

 +22       SET PROV=$GET(PROV,"")

 +23       IF PROV=""

               SET PROV=+PROV

 +24       IF PROV'=""

               Begin DoDot:1

 +25               SET C1=+$PIECE(PROV,":",2)

                   SET C2=+$PIECE(PROV,":",3)

                   SET C3=+$PIECE(PROV,":",4)

                   SET C4=+$PIECE(PROV,":",5)

                   SET CT=+$PIECE(PROV,":",6)

 +26               SET PROV=$PIECE(PROV,":",1)

               End DoDot:1

 +27       SET CNT=$GET(CNT,0)

           SET QFL=0

           SET QQF=0

 +28       IF CT=0

               Begin DoDot:1

 +29               IF '$DATA(^BQIPROV(DUZ))

                       QUIT 

 +30               IF $GET(DIV)'=""

                       IF '$DATA(^VA(200,DUZ,2,"B",DIV))

                           QUIT 

 +31               IF $DATA(^BQIPROV(DUZ))

                       DO RTE(DUZ)

                       Begin DoDot:2

 +32                       IF QQF

                               SET QQF=0

                               QUIT 

 +33                       SET @DATA@(II)=@DATA@(II)_U_PROV_":"_C1_":"_C2_":"_C3_":"_C4_":"_CT_$CHAR(30)

                       End DoDot:2

               End DoDot:1

 +34      ;

 +35       FOR 

               SET PROV=$ORDER(^BQIPROV(PROV))

               IF 'PROV

                   QUIT 

               Begin DoDot:1

 +36               IF PROV=DUZ

                       QUIT 

 +37               IF '$DATA(^BQIPROV(PROV,40))

                       QUIT 

 +38               IF '$DATA(^BQI(90508,1,14,"B",PROV))

                       QUIT 

 +39               IF $GET(DIV)'=""

                       IF '$DATA(^VA(200,PROV,2,"B",DIV))

                           QUIT 

 +40               IF PROV'=DUZ

                       DO RTE(PROV)

                       Begin DoDot:2

 +41                       IF QQF

                               SET QQF=0

                               QUIT 

 +42                       SET @DATA@(II)=@DATA@(II)_U_PROV_":"_C1_":"_C2_":"_C3_":"_C4_":"_CT_$CHAR(30)

 +43                       IF CNT'=0

                               IF PCT=CNT

                                   SET QFL=1

                       End DoDot:2

               End DoDot:1

               IF QFL

                   QUIT 

 +44      ;

DONE      ;

 +1        SET II=II+1

           SET @DATA@(II)=$CHAR(31)

 +2        QUIT 

 +3       ;

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       ;

NAM       ;EP

 +1        SET C1=C1+1

           IF C1=27

               SET C2=C2+1

               SET C1=1

           IF C2=27

               SET C3=C3+1

               SET C2=1

               SET C1=1

           IF C3=27

               SET C4=C4+1

               SET C3=1

               SET C2=1

               SET C1=1

           SET NAME="PROVIDER "_$SELECT(C4>0:$CHAR(C4+64),1:"")_$SELECT(C3>0:$CHAR(C3+64),1:"")_$SELECT(C2>0:$CHAR(C2+64),1:"")_$SELECT(C1>0:$CHAR(C1+64),1:"")

 +2        QUIT 

 +3       ;

RTE(PRV)  ; EP

 +1        NEW DATE,FAC,MN,MDATA,PRVR,CFROM,CTHRU,PFROM,PTHRU,IDN,CDEN,CNUM,CEXC,PDEN

 +2        NEW PNUM,PEXC,CURR,PREV,SORT,USN,TYPE,DDATA

 +3        IF '$DATA(^BQIPROV(PRV,40))

               SET QQF=1

               QUIT 

 +4        SET CT=CT+1

           SET PCT=PCT+1

 +5        IF DUZ=PRV

               SET PRVR=PRV_$CHAR(28)_$PIECE($GET(^VA(200,PRV,0)),U,1)

               SET SORT=1_"_"_$PIECE($GET(^VA(200,PRV,0)),U,1)

 +6        IF '$DATA(^XUSEC("BQIZMUMGR",DUZ))

               IF '$DATA(^XUSEC("BQIZMGR",DUZ))

                   Begin DoDot:1

 +7                    IF DUZ'=PRV

                           DO NAM

                           SET PRVR=PRV_$CHAR(28)_NAME

                           SET SORT=2_"_"_NAME

                   End DoDot:1

 +8        IF $DATA(^XUSEC("BQIZMUMGR",DUZ))!($DATA(^XUSEC("BQIZMGR",DUZ)))

               Begin DoDot:1

 +9                IF DUZ'=PRV

                       SET PRVR=PRV_$CHAR(28)_$PIECE($GET(^VA(200,PRV,0)),U,1)

                       SET SORT=1_"_"_$PIECE($GET(^VA(200,PRV,0)),U,1)

               End DoDot:1

 +10       SET DDATA=$GET(^BQIPROV(PRV,0))

           IF DDATA=""

               QUIT 

 +11      ;

 +12       SET USN=""

           SET TYPE=""

           SET OK=0

 +13       FOR 

               SET USN=$ORDER(^USR(8930.3,"B",PRV,USN),-1)

               IF USN=""

                   QUIT 

               Begin DoDot:1

 +14               IF '$$CURRENT^USRLM(USN)

                       QUIT 

 +15               SET TYPE=$PIECE(^USR(8930.3,USN,0),U,2)

 +16               IF $ORDER(^BQI(90508,1,13,"B",TYPE,""))=""

                       SET TYPE=""

                       QUIT 

 +17               SET OK=1

               End DoDot:1

 +18       IF 'OK

               SET QQF=1

               SET CT=CT-1

               SET PCT=PCT-1

               QUIT 

 +19       IF TYPE'=""

               SET TYPE=$SELECT($PIECE($GET(^USR(8930,TYPE,0)),U,4)'="":$PIECE($GET(^USR(8930,TYPE,0)),U,4),1:$PIECE($GET(^USR(8930,TYPE,0)),U,1))

 +20       SET II=II+1

           SET @DATA@(II)=PRVR_U_SORT_U_TYPE_U_CPER_U_PPER_U

 +21      ;

 +22       KILL BQCURR,BQPREV

 +23       SET ID=""

 +24       FOR 

               SET ID=$ORDER(HEAD(ID))

               IF ID=""

                   QUIT 

               Begin DoDot:1

 +25               SET BQCURR(ID)=$SELECT($GET(CQN)="":"NDA",'$DATA(^BQIPROV(PRV,40,CQN,1)):"NDA",1:"N/A")

               End DoDot:1

 +26      ;

 +27       SET CRDT=""

 +28       FOR 

               SET CRDT=$ORDER(BQCDAR(CRDT))

               IF CRDT=""

                   QUIT 

               Begin DoDot:1

 +29               SET CQN=$ORDER(^BQIPROV(PRV,40,"B",CRDT,""))

 +30               DO CPAGG

               End DoDot:1

 +31      ;

 +32       SET ID=""

 +33       FOR 

               SET ID=$ORDER(HEAD(ID))

               IF ID=""

                   QUIT 

               Begin DoDot:1

 +34               SET BQPREV(ID)=$SELECT($GET(PQN)="":"NDA",'$DATA(^BQIPROV(PRV,40,PQN,1)):"NDA",1:"N/A")

               End DoDot:1

 +35      ;

 +36       SET PRDT=""

 +37       FOR 

               SET PRDT=$ORDER(BQPDAR(PRDT))

               IF PRDT=""

                   QUIT 

               Begin DoDot:1

 +38               SET PQN=$ORDER(^BQIPROV(PRV,40,"B",PRDT,""))

 +39               DO PPAGG

               End DoDot:1

 +40      ;

 +41       SET HX=""

 +42       FOR 

               SET HX=$ORDER(HEAD(HX))

               IF HX=""

                   QUIT 

               Begin DoDot:1

 +43               SET ID=HX

                   SET PEC=$GET(HEAD(ID))

                   IF PEC=""

                       QUIT 

 +44               SET CDEN=$PIECE($GET(BQCURR(ID)),U,1)

                   SET CNUM=$PIECE($GET(BQCURR(ID)),U,2)

 +45               SET CEXC=$PIECE($GET(BQCURR(ID)),U,3)

 +46               IF +CNUM=0

                       SET CURR="0%"

 +47               IF +CDEN'=0

                       IF +CNUM'=0

                           SET CURR=(CNUM/CDEN)*100

                           SET CURR=$JUSTIFY(CURR,3,0)_"%"

                           SET CURR=$$TRIM^BQIUL1(CURR," ")