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
SET CURR=$JUSTIFY(CURR,3,0)_"%"
SET CURR=$$TRIM^BQIUL1(CURR," ")
+31 IF CDEN=""
IF CNUM=""
IF CEXC'=""
SET CURR="Excluded"
+32 IF CDEN=""
IF CNUM=""
IF CEXC=""
SET CURR=""
+33 SET PDEN=$PIECE($GET(BQPREV(ID)),U,1)
SET PNUM=$PIECE($GET(BQPREV(ID)),U,2)
SET PEXC=$PIECE($GET(BQPREV(ID)),U,3)
+34 IF +PNUM=0
SET PREV="0%"
+35 IF +PDEN'=0
IF +PNUM'=0
SET PREV=$JUSTIFY((PNUM/PDEN)*100,3,0)_"%"
SET PREV=$$TRIM^BQIUL1(PREV," ")
+36 IF PDEN=""
IF PNUM=""
IF PEXC'=""
SET PREV="Excluded"
+37 IF PDEN=""
IF PNUM=""
IF PEXC=""
SET PREV=""
+38 SET $PIECE(@DATA@(II),U,PEC)=CURR
+39 SET $PIECE(@DATA@(II),U,PEC+1)=PREV
End DoDot:1
+40 KILL BQCURR,BQPREV
+41 ;
+42 QUIT
+43 ;
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(^BQIPROV(PRV,50,CQN,1)):"NDA",1:"N/A")
End DoDot:1
+5 ;
+6 IF CQN=""
QUIT
+7 SET IDN=0
+8 FOR
SET IDN=$ORDER(^BQIPROV(PRV,50,CQN,1,IDN))
IF 'IDN
QUIT
Begin DoDot:1
+9 SET (CDEN,CNUM,CEXC,CURR)=""
+10 SET CDATA=^BQIPROV(PRV,50,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(^BQIPROV(PRV,50,PQN,1)):"NDA",1:"N/A")
End DoDot:1
+5 ;
+6 IF PQN=""
QUIT
+7 SET IDN=0
+8 FOR
SET IDN=$ORDER(^BQIPROV(PRV,50,PQN,1,IDN))
IF 'IDN
QUIT
Begin DoDot:1
+9 SET (PDEN,PNUM,PEXC,PREV)=""
+10 SET PDATA=^BQIPROV(PRV,50,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 ;
HOV(DATA,TMFRAME,PERIOD,PROV,CNT,DIV) ;EP -- BQI MU GET PROV CQM HOVER
+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("BQIMUDCQH",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^BQIMUPRV D UNWIND^%ZTER"
+9 DO GTM^BQIMUTIM
+10 SET HDR="T00050PROVIDER^T00035HIDE_PROV_SORT^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD^"
+11 SET HX=0
SET PEC=5
+12 FOR
SET HX=$ORDER(^BGPMUIND(90596.11,HX))
IF 'HX
QUIT
Begin DoDot:1
+13 SET MSN=$PIECE(^BGPMUIND(90596.11,HX,0),U,1)
+14 IF $GET(^BGPMUIND(90595.11,MSN,0))=""
QUIT
+15 IF $PIECE(^BGPMUIND(90595.11,MSN,0),U,4)'="H"
Begin DoDot:2
+16 SET HDR=HDR_"T00005"_$PIECE(^BGPMUIND(90596.11,HX,0),U,4)_"_CURR^T00005"_$PIECE(^BGPMUIND(90596.11,HX,0),U,4)_"_PREV^"
+17 ;S HDR=HDR_"T00005CURR_"_$P(^BGPMUIND(90595.11,HX,0),U,1)_"^T00005PREV"_$P(^BGPMUIND(90595.11,HX,0),U,1)_"^"
+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)=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(^BQI(90508,1,14,"B",DUZ))
QUIT
+30 IF $GET(DIV)'=""
IF '$DATA(^VA(200,DUZ,2,"B",DIV))
QUIT
+31 IF $DATA(^BQIPROV(DUZ))
DO FND(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)
+34 FOR BJ=3:1:$LENGTH(@DATA@(II),U)
IF $PIECE(@DATA@(II),U,BJ)=""
SET $PIECE(@DATA@(II),U,BJ)="No Data Available"
End DoDot:2
End DoDot:1
+35 ;
+36 FOR
SET PROV=$ORDER(^BQIPROV(PROV))
IF 'PROV
QUIT
Begin DoDot:1
+37 IF PROV=DUZ
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 FND(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 FOR BJ=3:1:$LENGTH(@DATA@(II),U)
IF $PIECE(@DATA@(II),U,BJ)=""
SET $PIECE(@DATA@(II),U,BJ)="No Data Available"
+44 IF CNT'=0
IF PCT=CNT
SET QFL=1
End DoDot:2
End DoDot:1
IF QFL
QUIT
+45 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+46 QUIT
+47 ;
FND(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,CQN,PQN
+3 SET CT=CT+1
SET PCT=PCT+1
+4 IF DUZ=PRV
SET PRVR=PRV
SET SORT=""
+5 IF '$DATA(^XUSEC("BQIZMUMGR",DUZ))
IF '$DATA(^XUSEC("BQIZMGR",DUZ))
Begin DoDot:1
+6 IF DUZ'=PRV
DO NAM
SET PRVR=PRV
SET SORT=""
End DoDot:1
+7 IF $DATA(^XUSEC("BQIZMUMGR",DUZ))!($DATA(^XUSEC("BQIZMGR",DUZ)))
Begin DoDot:1
+8 IF DUZ'=PRV
SET PRVR=PRV
SET SORT=""
End DoDot:1
+9 SET II=II+1
SET @DATA@(II)=PRVR_U_SORT_U_CPER_U_PPER_U
+10 ;
+11 KILL BQCURR,BQPREV
+12 SET CRDT=""
+13 FOR
SET CRDT=$ORDER(BQCDAR(CRDT))
IF CRDT=""
QUIT
Begin DoDot:1
+14 SET CQN=$ORDER(^BQIPROV(PRV,50,"B",CRDT,""))
+15 DO CAGG
End DoDot:1
+16 ;
+17 SET PRDT=""
+18 FOR
SET PRDT=$ORDER(BQPDAR(PRDT))
IF PRDT=""
QUIT
Begin DoDot:1
+19 SET PQN=$ORDER(^BQIPROV(PRV,50,"B",PRDT,""))
+20 DO PAGG
End DoDot:1
+21 ;
+22 KILL BQCURR,BQPREV
+23 SET CRDT=""
+24 FOR
SET CRDT=$ORDER(BQCDAR(CRDT))
IF CRDT=""
QUIT
Begin DoDot:1
+25 SET CQN=$ORDER(^BQIPROV(PRV,50,"B",CRDT,""))
+26 DO CAGG
End DoDot:1
+27 ;
+28 SET PRDT=""
+29 FOR
SET PRDT=$ORDER(BQPDAR(PRDT))
IF PRDT=""
QUIT
Begin DoDot:1
+30 SET PQN=$ORDER(^BQIPROV(PRV,50,"B",PRDT,""))
+31 DO PAGG
End DoDot:1
+32 ;
+33 SET HX=""
+34 FOR
SET HX=$ORDER(HEAD(HX))
IF HX=""
QUIT
Begin DoDot:1
+35 SET ID=HX
SET PEC=$GET(HEAD(ID))
IF PEC=""
QUIT
+36 SET CDEN=$PIECE($GET(BQCURR(ID)),U,1)
SET CNUM=$PIECE($GET(BQCURR(ID)),U,2)
SET CEXC=$PIECE($GET(BQCURR(ID)),U,3)
+37 IF +CNUM=0
SET CURR="Not Applicable"
+38 IF +CDEN'=0
SET CURR="Numerator: "_+CNUM_" Denominator: "_CDEN
+39 IF CDEN=""
IF CNUM=""
IF CEXC'=""
SET CURR="Excluded"
+40 IF CDEN=""
IF CNUM=""
IF CEXC=""
SET CURR="Not Applicable"
+41 SET PDEN=$PIECE($GET(BQPREV(ID)),U,1)
SET PNUM=$PIECE($GET(BQPREV(ID)),U,2)
SET PEXC=$PIECE($GET(BQPREV(ID)),U,3)
+42 IF +PNUM=0
SET PREV="Not Applicable"
+43 IF +PDEN'=0
SET PREV="Numerator: "_+PNUM_" Denominator: "_PDEN
+44 IF PDEN=""
IF PNUM=""
IF PEXC'=""
SET PREV=PEXC
+45 IF PDEN=""
IF PNUM=""
IF PEXC=""
SET PREV="Not Applicable"
+46 SET $PIECE(@DATA@(II),U,PEC)=CURR
+47 SET $PIECE(@DATA@(II),U,PEC+1)=PREV
End DoDot:1
+48 KILL BQCURR,BQPREV
+49 QUIT
+50 ;
CQM ;EP - Update BQIFAC for CQ data already processed
+1 NEW PRV
+2 SET PRV=0
+3 FOR
SET PRV=$ORDER(^BQIPROV(PRV))
IF 'PRV
QUIT
Begin DoDot:1
+4 SET DN=0
+5 FOR
SET DN=$ORDER(^BQIPROV(PRV,50,DN))
IF 'DN
QUIT
Begin DoDot:2
+6 SET MN=0
+7 FOR
SET MN=$ORDER(^BQIPROV(PRV,50,DN,1,MN))
IF 'MN
QUIT
Begin DoDot:3
+8 SET BQDATE=$PIECE(^BQIPROV(PRV,50,DN,0),"^",1)
+9 SET MDATA=^BQIPROV(PRV,50,DN,1,MN,0)
+10 SET ID=$PIECE(MDATA,"^",1)
SET CDEN=$PIECE(MDATA,"^",2)
SET CNUM=$PIECE(MDATA,"^",3)
SET CEXC=$PIECE(MDATA,"^",4)
+11 SET DV=0
+12 FOR
SET DV=$ORDER(^VA(200,PRV,2,DV))
IF 'DV
QUIT
Begin DoDot:4
+13 IF $GET(^BQIFAC(DV,0))=""
SET ^BQIFAC(DV,0)=DV
SET ^BQIFAC("B",DV,DV)=""
+14 SET FAC=DV
DO UPD
+15 SET VN=$ORDER(^BQIFAC(DV,80,BQTMN,1,"B",ID,""))
IF VN=""
SET VN=MN
SET ^BQIFAC(DV,80,BQTMN,1,0)="^90505.681^"_VN_U_VN
+16 IF $GET(^BQIFAC(DV,80,BQTMN,1,VN,0))=""
SET ^BQIFAC(DV,80,BQTMN,1,VN,0)=ID
SET ^BQIFAC(DV,80,BQTMN,1,"B",ID,VN)=""
+17 SET $PIECE(^BQIFAC(DV,80,BQTMN,1,VN,0),U,2)=$PIECE($GET(^BQIFAC(DV,80,BQTMN,1,VN,0)),U,2)+$GET(CDEN)
+18 SET $PIECE(^BQIFAC(DV,80,BQTMN,1,VN,0),U,3)=$PIECE($GET(^BQIFAC(DV,80,BQTMN,1,VN,0)),U,3)+$GET(CNUM)
+19 SET $PIECE(^BQIFAC(DV,80,BQTMN,1,VN,0),U,3)=$PIECE($GET(^BQIFAC(DV,80,BQTMN,1,VN,0)),U,4)+$GET(CEXC)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
UPD ;EP
+1 IF $GET(^BQIFAC(FAC,80,0))=""
SET ^BQIFAC(FAC,80,0)="^90505.68D^^"
+2 ;
+3 NEW DA,X,IENS,Y,DIC,DLAYGO
+4 SET DA(1)=FAC
SET DIC="^BQIFAC("_DA(1)_",80,"
SET X=BQDATE
SET DIC(0)="LNZ"
SET DLAYGO=90505.68
SET DIC("P")=DLAYGO
+5 DO ^DIC
+6 SET DA=+Y
IF DA=-1
QUIT
+7 SET BQTMN=DA
+8 QUIT
