BQIMUDCQ.m

BQIMUDCQ ;GDIT/HS/ALA-MU Clin Qual by Division ; 21 Nov 2012  3:56 PM

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

 ;

PROV(DATA,TMFRAME,PERIOD,PROV,CNT,DIV) ;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 DIV=$G(DIV,"")

 S II=0

 NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIMUDCQ 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 $G(DIV)'="",'$D(^VA(200,DUZ,2,"B",DIV)) Q

 . I $D(^BQIPROV(DUZ)) D PFND(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 $G(DIV)'="",'$D(^VA(200,PROV,2,"B",DIV)) Q

 . I PROV'=DUZ D PFND(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

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

 ;

PFND(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

 ;

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

 ;

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

 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("BQIMUDCQH",UID))

 K @DATA

 S DIV=$G(DIV,"")

 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 HDR=HDR_"T00005CURR_"_$P(^BGPMUIND(90595.11,HX,0),U,1)_"^T00005PREV"_$P(^BGPMUIND(90595.11,HX,0),U,1)_"^"

 .. 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 $G(DIV)'="",'$D(^VA(200,DUZ,2,"B",DIV)) 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)="No Data Available"

 ;

 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 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)="No Data Available"

 .. 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,CQN,PQN

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

 I DUZ=PRV S PRVR=PRV,SORT=""

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

 . I DUZ'=PRV D NAM S PRVR=PRV,SORT=""

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

 . I DUZ'=PRV S PRVR=PRV,SORT=""

 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

 ;

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

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

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

 . I CDEN="",CNUM="",CEXC="" S CURR="Not Applicable"

 . 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="Not Applicable"

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

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

 . I PDEN="",PNUM="",PEXC="" S PREV="Not Applicable"

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

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

 K BQCURR,BQPREV

 Q

 ;

CQM ;EP - Update BQIFAC for CQ data already processed

 NEW PRV

 S PRV=0

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

 . S DN=0

 . F  S DN=$O(^BQIPROV(PRV,50,DN)) Q:'DN  D

 .. S MN=0

 .. F  S MN=$O(^BQIPROV(PRV,50,DN,1,MN)) Q:'MN  D

 ... S BQDATE=$P(^BQIPROV(PRV,50,DN,0),"^",1)

 ... S MDATA=^BQIPROV(PRV,50,DN,1,MN,0)

 ... S ID=$P(MDATA,"^",1),CDEN=$P(MDATA,"^",2),CNUM=$P(MDATA,"^",3),CEXC=$P(MDATA,"^",4)

 ... S DV=0

 ... F  S DV=$O(^VA(200,PRV,2,DV)) Q:'DV  D

 .... I $G(^BQIFAC(DV,0))="" S ^BQIFAC(DV,0)=DV,^BQIFAC("B",DV,DV)=""

 .... S FAC=DV D UPD

 .... S VN=$O(^BQIFAC(DV,80,BQTMN,1,"B",ID,"")) I VN="" S VN=MN,^BQIFAC(DV,80,BQTMN,1,0)="^90505.681^"_VN_U_VN

 .... I $G(^BQIFAC(DV,80,BQTMN,1,VN,0))="" S ^BQIFAC(DV,80,BQTMN,1,VN,0)=ID,^BQIFAC(DV,80,BQTMN,1,"B",ID,VN)=""

 .... S $P(^BQIFAC(DV,80,BQTMN,1,VN,0),U,2)=$P($G(^BQIFAC(DV,80,BQTMN,1,VN,0)),U,2)+$G(CDEN)

 .... S $P(^BQIFAC(DV,80,BQTMN,1,VN,0),U,3)=$P($G(^BQIFAC(DV,80,BQTMN,1,VN,0)),U,3)+$G(CNUM)

 .... S $P(^BQIFAC(DV,80,BQTMN,1,VN,0),U,3)=$P($G(^BQIFAC(DV,80,BQTMN,1,VN,0)),U,4)+$G(CEXC)

 Q

 ;

UPD ;EP

 I $G(^BQIFAC(FAC,80,0))="" S ^BQIFAC(FAC,80,0)="^90505.68D^^"

 ;

 NEW DA,X,IENS,Y,DIC,DLAYGO

 S DA(1)=FAC,DIC="^BQIFAC("_DA(1)_",80,",X=BQDATE,DIC(0)="LNZ",DLAYGO=90505.68,DIC("P")=DLAYGO

 D ^DIC

 S DA=+Y I DA=-1 Q

 S BQTMN=DA

 Q

BQIMUDCQ  ;GDIT/HS/ALA-MU Clin Qual by Division ; 21 Nov 2012  3:56 PM

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

 +2       ;

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

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

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

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

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

 +5        KILL @DATA

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

 +7        SET II=0

 +8       ; SAC 2006 2.2.3.3.2

           NEW $ESTACK,$ETRAP

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

 +9       ;

 +10       DO GTM^BQIMUTIM

 +11      ;

 +12       SET HDR="T00050PROVIDER^T00035HIDE_PROV_SORT^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD^"

 +13       SET HX=0

           SET PEC=5

 +14       FOR 

               SET HX=$ORDER(^BGPMUIND(90596.11,HX))

               IF 'HX

                   QUIT 

               Begin DoDot:1

 +15               SET MSN=$PIECE(^BGPMUIND(90596.11,HX,0),U,1)

 +16               IF $GET(^BGPMUIND(90595.11,MSN,0))=""

                       QUIT 

 +17               IF $PIECE(^BGPMUIND(90595.11,MSN,0),U,4)'="H"

                       Begin DoDot:2

 +18                       SET HDR=HDR_"T00005"_$PIECE(^BGPMUIND(90596.11,HX,0),U,4)_"_CURR^T00005"_$PIECE(^BGPMUIND(90596.11,HX,0),U,4)_"_PREV^"

 +19                       SET HEAD($PIECE(^BGPMUIND(90596.11,HX,0),U,4))=PEC

                           SET PEC=PEC+2

                       End DoDot: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 '$DATA(^BQI(90508,1,14,"B",DUZ))

                       QUIT 

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

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

                           QUIT 

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

                       DO PFND(DUZ)

                       Begin DoDot:2

 +33                       IF QQF

                               SET QQF=0

                               QUIT 

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

 +35                       FOR BJ=3:1:$LENGTH(@DATA@(II),U)

                               IF $PIECE(@DATA@(II),U,BJ)=""

                                   SET $PIECE(@DATA@(II),U,BJ)="NDA"

                       End DoDot:2

               End DoDot:1

 +36      ;

 +37       FOR 

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

               IF 'PROV

                   QUIT 

               Begin DoDot:1

 +38               IF PROV=DUZ

                       QUIT 

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

                       QUIT 

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

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

                           QUIT 

 +41               IF PROV'=DUZ

                       DO PFND(PROV)

                       Begin DoDot:2

 +42                       IF QQF

                               SET QQF=0

                               QUIT 

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

 +44                       FOR BJ=3:1:$LENGTH(@DATA@(II),U)

                               IF $PIECE(@DATA@(II),U,BJ)=""

                                   SET $PIECE(@DATA@(II),U,BJ)="NDA"

 +45                       IF CNT'=0

                               IF PCT=CNT

                                   SET QFL=1

                       End DoDot:2

               End DoDot:1

               IF QFL

                   QUIT 

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       ;

PFND(PRV) ; Find data

 +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,CQN,PQN,PDATA,CDATA

 +3       ;

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

 +11      ;

 +12       SET II=II+1

           SET @DATA@(II)=PRVR_U_SORT_U_CPER_U_PPER_U

 +13      ;

 +14       KILL BQCURR,BQPREV

 +15       SET CRDT=""

 +16       FOR 

               SET CRDT=$ORDER(BQCDAR(CRDT))

               IF CRDT=""

                   QUIT 

               Begin DoDot:1

 +17               SET CQN=$ORDER(^BQIPROV(PRV,50,"B",CRDT,""))

 +18               DO CAGG

               End DoDot:1

 +19      ;

 +20       SET PRDT=""

 +21       FOR 

               SET PRDT=$ORDER(BQPDAR(PRDT))

               IF PRDT=""

                   QUIT 

               Begin DoDot:1

 +22               SET PQN=$ORDER(^BQIPROV(PRV,50,"B",PRDT,""))

 +23               DO PAGG

               End DoDot:1

 +24      ;

 +25       SET HX=""

 +26       FOR 

               SET HX=$ORDER(HEAD(HX))

               IF HX=""

                   QUIT 

               Begin DoDot:1

 +27               SET ID=HX

                   SET PEC=$GET(HEAD(ID))

                   IF PEC=""

                       QUIT 

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

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

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

 +29               IF +CNUM=0

                       SET CURR="0%"

 +30               IF +CDEN'=0

                       IF +CNUM'=0

                           SET CURR=(CNUM/CDEN)*100