BQIMUPRV.m

BQIMUPRV ;GDIT/HS/ALA-MU for Providers ; 18 Oct 2011  2:32 PM

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

 ;

 ;

EN(DATA,REPORT,TMFRAME,PERIOD,PROV,CNT) ; 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 PGLOB

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

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

 K @DATA

 S II=0

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

 ;

 D GTM^BQIMUTIM

 ;

 S REPORT=$G(REPORT,"")

 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 $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 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=""

 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

 I TYPE="" 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)

 . 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

 ;

CQM(DATA,TMFRAME,PERIOD,PROV,CNT) ; EP -- BQI MU GET PROV CQM

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

 NEW BJ,BQCDAR,BQDTM,BQPDAR,CRDT,CURDT,CYR,ID,MSN,NYR,PRDT,PYR,QQF

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

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

 K @DATA

 S II=0

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

 ;

 D GTM^BQIMUTIM

 ;

 S HDR="T00050PROVIDER^T00035HIDE_PROV_SORT^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD^"

 S HX=0,PEC=5

 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)=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 '$D(^BQI(90508,1,14,"B",DUZ)) Q

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

 .. I QQF S QQF=0 Q

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

 .. F BJ=3:1:$L(@DATA@(II),U) I $P(@DATA@(II),U,BJ)="" S $P(@DATA@(II),U,BJ)="NDA"

 ;

 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 PROV'=DUZ D FND(PROV) D

 .. I QQF S QQF=0 Q

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

 .. F BJ=3:1:$L(@DATA@(II),U) I $P(@DATA@(II),U,BJ)="" S $P(@DATA@(II),U,BJ)="NDA"

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

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

 Q

 ;

FND(PRV) ; Find data

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

 NEW PNUM,PEXC,CURR,PREV,SORT,USN,TYPE,DDATA,CQN,PQN,PDATA,CDATA

 ;

 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,1))

 ;

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

 ;

 K BQCURR,BQPREV

 S CRDT=""

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

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

 . D CAGG

 ;

 S PRDT=""

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

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

 K BQCURR,BQPREV

 ;

 Q

 ;

CAGG ; Aggregate

 NEW ID

 S ID=""

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

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

 ;

 I CQN="" Q

 S IDN=0

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

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

 . S CDATA=^BQIPROV(PRV,50,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

 ;

CPAGG ; Aggregate performance

 NEW ID

 S ID=""

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

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

 ;

 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)

 . 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

 ;

PAGG ; Aggregate

 NEW ID

 S ID=""

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

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

 ;

 I PQN="" Q

 S IDN=0

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

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

 . S PDATA=^BQIPROV(PRV,50,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

 ;

PPAGG ;

 NEW ID

 S ID=""

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

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

 ;

 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)

 . 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

BQIMUPRV  ;GDIT/HS/ALA-MU for Providers ; 18 Oct 2011  2:32 PM

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

 +2       ;

 +3       ;

EN(DATA,REPORT,TMFRAME,PERIOD,PROV,CNT) ; 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 PGLOB

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

 +4        SET DATA=$NAME(^TMP("BQIMUPROV",UID))

 +5        KILL @DATA

 +6        SET II=0

 +7       ; SAC 2006 2.2.3.3.2

           NEW $ESTACK,$ETRAP

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

 +8       ;

 +9        DO GTM^BQIMUTIM

 +10      ;

 +11       SET REPORT=$GET(REPORT,"")

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

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

 +14       SET HX=0

           SET PEC=6

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

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

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

 +22       IF PROV=""

               SET PROV=+PROV

 +23       IF PROV'=""

               Begin DoDot:1

 +24               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)

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

               End DoDot:1

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

           SET QFL=0

           SET QQF=0

 +27       IF CT=0

               Begin DoDot:1

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

                       QUIT 

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

                       DO RTE(DUZ)

                       Begin DoDot:2

 +30                       IF QQF

                               SET QQF=0

                               QUIT 

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

                       End DoDot:2

               End DoDot:1

 +32      ;

 +33       FOR 

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

               IF 'PROV

                   QUIT 

               Begin DoDot:1

 +34               IF PROV=DUZ

                       QUIT 

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

                       QUIT 

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

                       QUIT 

 +37               IF PROV'=DUZ

                       DO RTE(PROV)

                       Begin DoDot:2

 +38                       IF QQF

                               SET QQF=0

                               QUIT 

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

 +40                       IF CNT'=0

                               IF PCT=CNT

                                   SET QFL=1

                       End DoDot:2

               End DoDot:1

               IF QFL

                   QUIT 

 +41      ;

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=""

 +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 

               End DoDot:1

 +17       IF TYPE=""

               SET QQF=1

               SET CT=CT-1

               SET PCT=PCT-1

               QUIT 

 +18       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))

 +19       SET II=II+1

           SET @DATA@(II)=PRVR_U_SORT_U_TYPE_U_CPER_U_PPER_U

 +20      ;

 +21       KILL BQCURR,BQPREV

 +22       SET CRDT=""

 +23       FOR 

               SET CRDT=$ORDER(BQCDAR(CRDT))

               IF CRDT=""

                   QUIT 

               Begin DoDot:1

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

 +25               DO CPAGG

               End DoDot:1

 +26      ;

 +27       SET PRDT=""

 +28       FOR 

               SET PRDT=$ORDER(BQPDAR(PRDT))

               IF PRDT=""

                   QUIT 

               Begin DoDot:1

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

 +30               DO PPAGG

               End DoDot:1

 +31      ;

 +32       SET HX=""

 +33       FOR 

               SET HX=$ORDER(HEAD(HX))

               IF HX=""

                   QUIT 

               Begin DoDot:1

 +34               SET ID=HX

                   SET PEC=$GET(HEAD(ID))

                   IF PEC=""

                       QUIT 

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

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

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

 +37               IF +CNUM=0

                       SET CURR="0%"

 +38               IF +CDEN'=0

                       IF +CNUM'=0