Routine: BQIMUFAC

BQIMUFAC ;VNGT/HS/ALA-MU Facility ; 01 Mar 2011  7:11 AM

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

EN(DATA,REPORT,TMFRAME,PERIOD) ; EP -- BQI MU GET FACILITY

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

 NEW BQCDAR,BQPDAR,CPER,CQN,CRDT,CURDT,FAC,IMN,OBJ,PN,PPER,PQN,PRDT

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

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

 K @DATA

 S II=0

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

 S TMFRAME=$G(TMFRAME,90),REPORT=$G(REPORT,"")

 S HDR="T00050HIDE_FACILITY^T00020HIDE_ID^T00050OBJECTIVE^T00010MEAS_SET^T00005CURR_DEN^T00005CURR_NUM^T00005CURR_MET^T00010STAGE_1_GOAL^"

 S HDR=HDR_"T00005PREV_DEN^T00005PREV_NUM^T00005PREV_MET^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD"

 S @DATA@(II)=HDR_$C(30)

 D GTM^BQIMUTIM

 S FAC=$$HME^BQIGPUTL() D RTE(FAC)

DONE ;

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

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)

RTE(FAC) ; EP

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

 NEW PNUM,PEXC,CURR,PREV,PDATA,CDATA,BQZZ,ST1G,MSET,ID,FACIL,PGLOB

 S FACIL=$P(^DIC(4,FAC,0),U,1)

 S PGLOB=$$PRFPGL^BQIMUTAB(REPORT)

 S PN=0

 F  S PN=$O(@PGLOB@(PN)) Q:'PN  D

 . S ID=$P(@PGLOB@(PN,0),U,1) I $P(@PGLOB@(PN,0),U,2)'="H" Q

 . ; If attestation, quit

 . I $P(@PGLOB@(PN,0),U,6)="A" Q

 . S BQZZ(ID,"C")="0",BQZZ(ID,"P")="0"

 S CRDT=""

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

 . S CQN=$O(^BQIFAC(FAC,40,"B",CRDT,""))

 . D CPAGG

 S PRDT=""

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

 . S PQN=$O(^BQIFAC(FAC,40,"B",PRDT,""))

 . D PPAGG

 S ID=""

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

 . S IMN=$O(@PGLOB@("B",ID,"")) I IMN="" Q

 . S ST1G=$G(@PGLOB@(IMN,13,1,0)),OBJ=$P(@PGLOB@(IMN,0),U,5)

 . S MSET=$$GET1^DIQ(9001300.02,IMN_",",.03,"E")

 . S CDEN=$P($G(BQZZ(ID,"C")),U,1)

 . S CNUM=$P($G(BQZZ(ID,"C")),U,2)

 . S CEXC=$P($G(BQZZ(ID,"C")),U,3)

. ;

 . S PDEN=$P($G(BQZZ(ID,"P")),U,1)

 . S PNUM=$P($G(BQZZ(ID,"P")),U,2)

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

. ;

 . I +CDEN=0,+CNUM=0 S CURR="0%",CNUM=0

 . I +PDEN=0,+PNUM=0 S PREV="0%",PNUM=0

 . I +CDEN'=0,+CNUM=0 S CURR="0%",CNUM=0

 . I +PDEN'=0,+PNUM=0 S PREV="0%",PNUM=0

 . I +CDEN'=0,+CNUM'=0 S CURR=$J((CNUM/CDEN)*100,3,0)_"%",CURR=$$TRIM^BQIUL1(CURR," ")

 . I +PDEN'=0,+PNUM'=0 S PREV=$J((PNUM/PDEN)*100,3,0)_"%",PREV=$$TRIM^BQIUL1(PREV," ")

 . I CURR="" S CURR="N/A"

 . I PREV="" S PREV="N/A"

 . I CEXC'="" S CURR="Excluded"

 . I PEXC'="" S PREV="Excluded"

 . S:CNUM="" CNUM=0 S:PNUM="" PNUM=0 S:CDEN="" CDEN=0 S:PDEN="" PDEN=0

 . S II=II+1,@DATA@(II)=FACIL_U_ID_U_OBJ_U_MSET_U_CDEN_U_CNUM_U_CURR_U_ST1G_U_PDEN_U_PNUM_U_PREV_U_CPER_U_PPER_$C(30)

CQ(DATA,TMFRAME,PERIOD) ; EP -- BQI MU GET FAC CQ

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

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

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

 S TMFRAME=$G(TMFRAME,90)

 K @DATA

 S II=0

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

 S HDR="T00050HIDE_FACILITY^T00020HIDE_ID^T00050OBJECTIVE^T00010MEAS_SET^T00005CURR_DEN^T00005CURR_NUM^T00005CURR_MET^T00010STAGE_1_GOAL^"

 S HDR=HDR_"T00005PREV_DEN^T00005PREV_NUM^T00005PREV_MET^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD"

 S @DATA@(II)=HDR_$C(30)

 D GTM^BQIMUTIM

 S FAC=$$HME^BQIGPUTL() D RET(FAC)

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

RET(FAC) ; EP

 NEW DATE,MN,PRVR,IDN,CDEN,CNUM,CEXC,PDEN,BGPIND,CRDT,CQN,PRDT

 NEW PNUM,PEXC,CURR,PREV,BQZZ,CDATA,PDATA,FACIL,X,I,ID,IMN,ST1G

 NEW MSN,MSET

 S FACIL=$P(^DIC(4,FAC,0),U,1)

 S X=0 F  S X=$O(^BGPMUIND(90595.11,"AMS","H",X)) Q:X'=+X  S BGPIND(X)=""

 S I="" F  S I=$O(BGPIND(I)) Q:I=""  D

 . S BN="" F  S BN=$O(^BGPMUIND(90596.11,"B",I,BN)) Q:BN=""  D

 .. S ID=$P(^BGPMUIND(90596.11,BN,0),U,4),BQZZ(ID,"C")="0",BQZZ(ID,"P")="0"

 S CRDT=""

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

 . S CQN=$O(^BQIFAC(FAC,50,"B",CRDT,""))

 . D CAGG

 S PRDT=""

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

 . S PQN=$O(^BQIFAC(FAC,50,"B",PRDT,""))

 . D PAGG

 S ID=""

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

 . S IMN=$O(^BGPMUIND(90596.11,"C",ID,"")) I IMN="" Q

 . S ST1G="",OBJ=$P($G(^BGPMUIND(90596.11,IMN,17)),U,3)

 . S MSN=$P(^BGPMUIND(90596.11,IMN,0),U,1)

 . I $P(^BGPMUIND(90595.11,MSN,0),U,4)'="H" Q

 . S MSET="HOSPITAL"

. ;

 . S CDEN=$P($G(BQZZ(ID,"C")),U,1)

 . S CNUM=$P($G(BQZZ(ID,"C")),U,2)

. ;

 . S PDEN=$P($G(BQZZ(ID,"P")),U,1)

 . S PNUM=$P($G(BQZZ(ID,"P")),U,2)

. ;

 . I ID[".ED." D

 .. S CURR=""

 .. I CDEN'="" S CURR=$J(CDEN,4,0)_" mins",CURR=$$TRIM^BQIUL1(CURR," ")

 .. S PREV=""

 .. I PDEN'="" S PREV=$J(PDEN,4,0)_" mins",PREV=$$TRIM^BQIUL1(PREV," ")

 . I ID'[".ED." D

 .. I +CDEN=0,+CNUM=0 S CURR="0%",CNUM=0

 .. I +CDEN'=0,+CNUM=0 S CURR="0%",CNUM=0

 .. I +CDEN'=0,+CNUM'=0,(CDEN-CEXC)=0 S CURR="0%"

 .. I +CDEN'=0,+CNUM'=0,(CDEN-CEXC)'=0 S CURR=$J((CNUM/(CDEN-CEXC))*100,3,0)_"%",CURR=$$TRIM^BQIUL1(CURR," ")

 .. S:CNUM="" CNUM=0 S:CDEN="" CDEN=0

 .. I +PDEN=0,+PNUM=0 S PREV="0%",PNUM=0

 .. I +PDEN'=0,+PNUM=0 S PREV="0%",PNUM=0

 .. I +PDEN'=0,+PNUM'=0,(PDEN-PEXC)=0 S PREV="0%"

 .. I +PDEN'=0,+PNUM'=0,(PDEN-PEXC)'=0 S PREV=$J((PNUM/(PDEN-PEXC))*100,3,0)_"%",PREV=$$TRIM^BQIUL1(PREV," ")

 . S II=II+1,@DATA@(II)=FACIL_U_ID_U_OBJ_U_MSET_U_CDEN_U_CNUM_U_CURR_U_ST1G_U_PDEN_U_PNUM_U_PREV_U_CPER_U_PPER_$C(30)

 K BQZZ

CAGG ; Aggregate

 I CQN="" Q

 S IDN=0

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

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

 . S CDATA=^BQIFAC(FAC,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(BQZZ(ID,"C"),U,1)=$P($G(BQZZ(ID,"C")),U,1)+CDEN

 . S $P(BQZZ(ID,"C"),U,2)=$P($G(BQZZ(ID,"C")),U,2)+CNUM

 . S $P(BQZZ(ID,"C"),U,3)=$P($G(BQZZ(ID,"C")),U,3)+CEXC

PAGG ; Aggregate

 I PQN="" Q

 S IDN=0

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

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

 . S PDATA=^BQIFAC(FAC,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)

. ;

 . 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(BQZZ(ID,"P"),U,1)=$P($G(BQZZ(ID,"P")),U,1)+PDEN

 . S $P(BQZZ(ID,"P"),U,2)=$P($G(BQZZ(ID,"P")),U,2)+PNUM

 . S $P(BQZZ(ID,"P"),U,3)=$P($G(BQZZ(ID,"P")),U,3)+PEXC

CPAGG ; Aggregate performance

 I CQN="" Q

 S IDN=0

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

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

 . S CDATA=^BQIFAC(FAC,40,CQN,1,IDN,0)

 . S CDEN=$P(CDATA,U,2),CNUM=$P(CDATA,U,3)

 . S CEXC=$G(^BQIFAC(FAC,40,CQN,1,IDN,1))

 . S ID=$P(CDATA,U,1)

 . S $P(BQZZ(ID,"C"),U,1)=$P($G(BQZZ(ID,"C")),U,1)+CDEN

 . S $P(BQZZ(ID,"C"),U,2)=$P($G(BQZZ(ID,"C")),U,2)+CNUM

 . S $P(BQZZ(ID,"C"),U,3)=CEXC

PPAGG ;

 I PQN="" Q

 S IDN=0

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

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

 . S PDATA=^BQIFAC(FAC,40,PQN,1,IDN,0)

 . S PDEN=$P(PDATA,U,2),PNUM=$P(PDATA,U,3)

 . S PEXC=$G(^BQIFAC(FAC,40,PQN,1,IDN,1))

 . S ID=$P(PDATA,U,1)

. ;

 . 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(BQZZ(ID,"P"),U,1)=$P($G(BQZZ(ID,"P")),U,1)+PDEN

 . S $P(BQZZ(ID,"P"),U,2)=$P($G(BQZZ(ID,"P")),U,2)+PNUM

 . S $P(BQZZ(ID,"P"),U,3)=PEXC

BQIMUFAC  ;VNGT/HS/ALA-MU Facility ; 01 Mar 2011  7:11 AM

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

 +2       ;

 +3       ;

EN(DATA,REPORT,TMFRAME,PERIOD) ; EP -- BQI MU GET FACILITY

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

 +2        NEW BQCDAR,BQPDAR,CPER,CQN,CRDT,CURDT,FAC,IMN,OBJ,PN,PPER,PQN,PRDT

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

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

 +5        KILL @DATA

 +6        SET II=0

 +7       ; SAC 2006 2.2.3.3.2

           NEW $ESTACK,$ETRAP

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

 +8        SET TMFRAME=$GET(TMFRAME,90)

           SET REPORT=$GET(REPORT,"")

 +9        SET HDR="T00050HIDE_FACILITY^T00020HIDE_ID^T00050OBJECTIVE^T00010MEAS_SET^T00005CURR_DEN^T00005CURR_NUM^T00005CURR_MET^T00010STAGE_1_GOAL^"

 +10       SET HDR=HDR_"T00005PREV_DEN^T00005PREV_NUM^T00005PREV_MET^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD"

 +11       SET @DATA@(II)=HDR_$CHAR(30)

 +12       DO GTM^BQIMUTIM

 +13       SET FAC=$$HME^BQIGPUTL()

           DO RTE(FAC)

 +14      ;

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       ;

RTE(FAC)  ; EP

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

 +2        NEW PNUM,PEXC,CURR,PREV,PDATA,CDATA,BQZZ,ST1G,MSET,ID,FACIL,PGLOB

 +3        SET FACIL=$PIECE(^DIC(4,FAC,0),U,1)

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

 +5       ;

 +6        SET PN=0

 +7        FOR

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

               IF 'PN

                   QUIT

               Begin DoDot:1

 +8                SET ID=$PIECE(@PGLOB@(PN,0),U,1)

                   IF $PIECE(@PGLOB@(PN,0),U,2)'="H"

                       QUIT

 +9       ; If attestation, quit

 +10               IF $PIECE(@PGLOB@(PN,0),U,6)="A"

                       QUIT

 +11               SET BQZZ(ID,"C")="0"

                   SET BQZZ(ID,"P")="0"

               End DoDot:1

 +12      ;

 +13       SET CRDT=""

 +14       FOR

               SET CRDT=$ORDER(BQCDAR(CRDT))

               IF CRDT=""

                   QUIT

               Begin DoDot:1

 +15               SET CQN=$ORDER(^BQIFAC(FAC,40,"B",CRDT,""))

 +16               DO CPAGG

               End DoDot:1

 +17      ;

 +18       SET PRDT=""

 +19       FOR

               SET PRDT=$ORDER(BQPDAR(PRDT))

               IF PRDT=""

                   QUIT

               Begin DoDot:1

 +20               SET PQN=$ORDER(^BQIFAC(FAC,40,"B",PRDT,""))

 +21               DO PPAGG

               End DoDot:1

 +22      ;

 +23       SET ID=""

 +24       FOR

               SET ID=$ORDER(BQZZ(ID))

               IF ID=""

                   QUIT

               Begin DoDot:1

 +25               SET IMN=$ORDER(@PGLOB@("B",ID,""))

                   IF IMN=""

                       QUIT

 +26               SET ST1G=$GET(@PGLOB@(IMN,13,1,0))

                   SET OBJ=$PIECE(@PGLOB@(IMN,0),U,5)

 +27               SET MSET=$$GET1^DIQ(9001300.02,IMN_",",.03,"E")

 +28               SET CDEN=$PIECE($GET(BQZZ(ID,"C")),U,1)

 +29               SET CNUM=$PIECE($GET(BQZZ(ID,"C")),U,2)

 +30               SET CEXC=$PIECE($GET(BQZZ(ID,"C")),U,3)

 +31      ;

 +32               SET PDEN=$PIECE($GET(BQZZ(ID,"P")),U,1)

 +33               SET PNUM=$PIECE($GET(BQZZ(ID,"P")),U,2)

 +34               SET PEXC=$PIECE($GET(BQZZ(ID,"P")),U,3)

 +35      ;

 +36               IF +CDEN=0

                       IF +CNUM=0

                           SET CURR="0%"

                           SET CNUM=0

 +37               IF +PDEN=0

                       IF +PNUM=0

                           SET PREV="0%"

                           SET PNUM=0

 +38               IF +CDEN'=0

                       IF +CNUM=0

                           SET CURR="0%"

                           SET CNUM=0

 +39               IF +PDEN'=0

                       IF +PNUM=0

                           SET PREV="0%"

                           SET PNUM=0

 +40               IF +CDEN'=0

                       IF +CNUM'=0

                           SET CURR=$JUSTIFY((CNUM/CDEN)*100,3,0)_"%"

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

 +41               IF +PDEN'=0

                       IF +PNUM'=0

                           SET PREV=$JUSTIFY((PNUM/PDEN)*100,3,0)_"%"

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

 +42               IF CURR=""

                       SET CURR="N/A"

 +43               IF PREV=""

                       SET PREV="N/A"

 +44               IF CEXC'=""

                       SET CURR="Excluded"

 +45               IF PEXC'=""

                       SET PREV="Excluded"

 +46               IF CNUM=""

                       SET CNUM=0

                   IF PNUM=""

                       SET PNUM=0

                   IF CDEN=""

                       SET CDEN=0

                   IF PDEN=""

                       SET PDEN=0

 +47               SET II=II+1

                   SET @DATA@(II)=FACIL_U_ID_U_OBJ_U_MSET_U_CDEN_U_CNUM_U_CURR_U_ST1G_U_PDEN_U_PNUM_U_PREV_U_CPER_U_PPER_$CHAR(30)

               End DoDot:1

 +48       QUIT

 +49      ;

CQ(DATA,TMFRAME,PERIOD) ; EP -- BQI MU GET FAC CQ

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

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

 +3        SET DATA=$NAME(^TMP("BQIMUFCQ",UID))

 +4        SET TMFRAME=$GET(TMFRAME,90)

 +5        KILL @DATA

 +6        SET II=0

 +7       ; SAC 2006 2.2.3.3.2

           NEW $ESTACK,$ETRAP

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

 +8       ;

 +9        SET HDR="T00050HIDE_FACILITY^T00020HIDE_ID^T00050OBJECTIVE^T00010MEAS_SET^T00005CURR_DEN^T00005CURR_NUM^T00005CURR_MET^T00010STAGE_1_GOAL^"

 +10       SET HDR=HDR_"T00005PREV_DEN^T00005PREV_NUM^T00005PREV_MET^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD"

 +11       SET @DATA@(II)=HDR_$CHAR(30)

 +12      ;

 +13       DO GTM^BQIMUTIM

 +14      ;

 +15       SET FAC=$$HME^BQIGPUTL()

           DO RET(FAC)

 +16       SET II=II+1

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

 +17       QUIT

 +18      ;

RET(FAC)  ; EP

 +1        NEW DATE,MN,PRVR,IDN,CDEN,CNUM,CEXC,PDEN,BGPIND,CRDT,CQN,PRDT

 +2        NEW PNUM,PEXC,CURR,PREV,BQZZ,CDATA,PDATA,FACIL,X,I,ID,IMN,ST1G

 +3        NEW MSN,MSET

 +4        SET FACIL=$PIECE(^DIC(4,FAC,0),U,1)

 +5       ;

 +6        SET X=0

FOR

               SET X=$ORDER(^BGPMUIND(90595.11,"AMS","H",X))

               IF X'=+X

                   QUIT

               SET BGPIND(X)=""

 +7        SET I=""

FOR

               SET I=$ORDER(BGPIND(I))

               IF I=""

                   QUIT

               Begin DoDot:1

 +8                SET BN=""

FOR

                       SET BN=$ORDER(^BGPMUIND(90596.11,"B",I,BN))

                       IF BN=""

                           QUIT

                       Begin DoDot:2

 +9                        SET ID=$PIECE(^BGPMUIND(90596.11,BN,0),U,4)

                           SET BQZZ(ID,"C")="0"

                           SET BQZZ(ID,"P")="0"

                       End DoDot:2

               End DoDot:1

 +10      ;

 +11       SET CRDT=""

 +12       FOR

               SET CRDT=$ORDER(BQCDAR(CRDT))

               IF CRDT=""

                   QUIT

               Begin DoDot:1

 +13               SET CQN=$ORDER(^BQIFAC(FAC,50,"B",CRDT,""))

 +14               DO CAGG

               End DoDot:1

 +15      ;

 +16       SET PRDT=""

 +17       FOR

               SET PRDT=$ORDER(BQPDAR(PRDT))

               IF PRDT=""

                   QUIT

               Begin DoDot:1

 +18               SET PQN=$ORDER(^BQIFAC(FAC,50,"B",PRDT,""))

 +19               DO PAGG

               End DoDot:1

 +20      ;

 +21       SET ID=""

 +22       FOR

               SET ID=$ORDER(BQZZ(ID))

               IF ID=""

                   QUIT

               Begin DoDot:1

 +23               SET IMN=$ORDER(^BGPMUIND(90596.11,"C",ID,""))

                   IF IMN=""

                       QUIT

 +24               SET ST1G=""

                   SET OBJ=$PIECE($GET(^BGPMUIND(90596.11,IMN,17)),U,3)

 +25               SET MSN=$PIECE(^BGPMUIND(90596.11,IMN,0),U,1)

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

                       QUIT

 +27               SET MSET="HOSPITAL"

 +28      ;

 +29               SET CDEN=$PIECE($GET(BQZZ(ID,"C")),U,1)

 +30               SET CNUM=$PIECE($GET(BQZZ(ID,"C")),U,2)

 +31      ;

 +32               SET PDEN=$PIECE($GET(BQZZ(ID,"P")),U,1)

 +33               SET PNUM=$PIECE($GET(BQZZ(ID,"P")),U,2)

 +34      ;

 +35               IF ID[".ED."

                       Begin DoDot:2

 +36                       SET CURR=""

 +37                       IF CDEN'=""

                               SET CURR=$JUSTIFY(CDEN,4,0)_" mins"

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

 +38                       SET PREV=""

 +39                       IF PDEN'=""

                               SET PREV=$JUSTIFY(PDEN,4,0)_" mins"

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

                       End DoDot:2

 +40               IF ID'[".ED."

                       Begin DoDot:2

 +41                       IF +CDEN=0

                               IF +CNUM=0

                                   SET CURR="0%"

                                   SET CNUM=0

 +42                       IF +CDEN'=0

                               IF +CNUM=0

                                   SET CURR="0%"

                                   SET CNUM=0

 +43                       IF +CDEN'=0

                               IF +CNUM'=0

                                   IF (CDEN-CEXC)=0

                                       SET CURR="0%"

 +44                       IF +CDEN'=0

                               IF +CNUM'=0

                                   IF (CDEN-CEXC)'=0

                                       SET CURR=$JUSTIFY((CNUM/(CDEN-CEXC))*100,3,0)_"%"

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

 +45                       IF CNUM=""

                               SET CNUM=0

                           IF CDEN=""

                               SET CDEN=0

 +46                       IF +PDEN=0

                               IF +PNUM=0

                                   SET PREV="0%"

                                   SET PNUM=0

 +47                       IF +PDEN'=0

                               IF +PNUM=0

                                   SET PREV="0%"

                                   SET PNUM=0

 +48                       IF +PDEN'=0

                               IF +PNUM'=0

                                   IF (PDEN-PEXC)=0

                                       SET PREV="0%"

 +49                       IF +PDEN'=0

                               IF +PNUM'=0

                                   IF (PDEN-PEXC)'=0

                                       SET PREV=$JUSTIFY((PNUM/(PDEN-PEXC))*100,3,0)_"%"

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

                       End DoDot:2

 +50               SET II=II+1

                   SET @DATA@(II)=FACIL_U_ID_U_OBJ_U_MSET_U_CDEN_U_CNUM_U_CURR_U_ST1G_U_PDEN_U_PNUM_U_PREV_U_CPER_U_PPER_$CHAR(30)

               End DoDot:1

 +51       KILL BQZZ

 +52       QUIT

 +53      ;

CAGG      ; Aggregate

 +1       ;

 +2        IF CQN=""

               QUIT

 +3        SET IDN=0

 +4        FOR

               SET IDN=$ORDER(^BQIFAC(FAC,50,CQN,1,IDN))

               IF 'IDN

                   QUIT

               Begin DoDot:1

 +5                SET (CDEN,CNUM,CEXC,CURR)=""

 +6                SET CDATA=^BQIFAC(FAC,50,CQN,1,IDN,0)

 +7                SET CDEN=$PIECE(CDATA,U,2)

                   SET CNUM=$PIECE(CDATA,U,3)

                   SET CEXC=$PIECE(CDATA,U,4)

 +8                SET ID=$PIECE(CDATA,U,1)

 +9                SET $PIECE(BQZZ(ID,"C"),U,1)=$PIECE($GET(BQZZ(ID,"C")),U,1)+CDEN

 +10               SET $PIECE(BQZZ(ID,"C"),U,2)=$PIECE($GET(BQZZ(ID,"C")),U,2)+CNUM

 +11               SET $PIECE(BQZZ(ID,"C"),U,3)=$PIECE($GET(BQZZ(ID,"C")),U,3)+CEXC

               End DoDot:1

 +12       QUIT

 +13      ;

PAGG      ; Aggregate

 +1        IF PQN=""

               QUIT

 +2        SET IDN=0

 +3        FOR

               SET IDN=$ORDER(^BQIFAC(FAC,50,PQN,1,IDN))

               IF 'IDN

                   QUIT

               Begin DoDot:1

 +4                SET (PDEN,PNUM,PEXC,PREV)=""

 +5                SET PDATA=^BQIFAC(FAC,50,PQN,1,IDN,0)

 +6                SET PDEN=$PIECE(PDATA,U,2)

                   SET PNUM=$PIECE(PDATA,U,3)

                   SET PEXC=$PIECE(PDATA,U,4)

 +7                SET ID=$PIECE(PDATA,U,1)

 +8       ;

 +9                IF +PNUM=0

                       SET PREV=0

 +10               IF +PDEN'=0

                       IF +PNUM'=0

                           SET PREV=$JUSTIFY((PNUM/PDEN)*100,3,0)

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

 +11               IF PDEN=""

                       IF PNUM=""

                           IF PEXC'=""

                               SET PREV="Excluded"

 +12               IF PDEN=""

                       IF PNUM=""

                           IF PEXC=""

                               SET PREV=""

 +13               SET $PIECE(BQZZ(ID,"P"),U,1)=$PIECE($GET(BQZZ(ID,"P")),U,1)+PDEN

 +14               SET $PIECE(BQZZ(ID,"P"),U,2)=$PIECE($GET(BQZZ(ID,"P")),U,2)+PNUM

 +15               SET $PIECE(BQZZ(ID,"P"),U,3)=$PIECE($GET(BQZZ(ID,"P")),U,3)+PEXC

               End DoDot:1

 +16       QUIT

 +17      ;

CPAGG     ; Aggregate performance

 +1        IF CQN=""

               QUIT

 +2        SET IDN=0

 +3        FOR

               SET IDN=$ORDER(^BQIFAC(FAC,40,CQN,1,IDN))

               IF 'IDN

                   QUIT

               Begin DoDot:1

 +4                SET (CDEN,CNUM,CEXC,CURR)=""

 +5                SET CDATA=^BQIFAC(FAC,40,CQN,1,IDN,0)

 +6                SET CDEN=$PIECE(CDATA,U,2)

                   SET CNUM=$PIECE(CDATA,U,3)

 +7                SET CEXC=$GET(^BQIFAC(FAC,40,CQN,1,IDN,1))

 +8                SET ID=$PIECE(CDATA,U,1)

 +9                SET $PIECE(BQZZ(ID,"C"),U,1)=$PIECE($GET(BQZZ(ID,"C")),U,1)+CDEN

 +10               SET $PIECE(BQZZ(ID,"C"),U,2)=$PIECE($GET(BQZZ(ID,"C")),U,2)+CNUM

 +11               SET $PIECE(BQZZ(ID,"C"),U,3)=CEXC

               End DoDot:1

 +12       QUIT

 +13      ;

PPAGG     ;

 +1        IF PQN=""

               QUIT

 +2        SET IDN=0

 +3        FOR

               SET IDN=$ORDER(^BQIFAC(FAC,40,PQN,1,IDN))

               IF 'IDN

                   QUIT

               Begin DoDot:1

 +4                SET (PDEN,PNUM,PEXC,PREV)=""

 +5                SET PDATA=^BQIFAC(FAC,40,PQN,1,IDN,0)

 +6                SET PDEN=$PIECE(PDATA,U,2)

                   SET PNUM=$PIECE(PDATA,U,3)

 +7                SET PEXC=$GET(^BQIFAC(FAC,40,PQN,1,IDN,1))

 +8                SET ID=$PIECE(PDATA,U,1)

 +9       ;

 +10               IF +PNUM=0

                       SET PREV=0

 +11               IF +PDEN'=0

                       IF +PNUM'=0

                           SET PREV=$JUSTIFY((PNUM/PDEN)*100,3,0)

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

 +12               IF PDEN=""

                       IF PNUM=""

                           IF PEXC'=""

                               SET PREV="Excluded"

 +13               IF PDEN=""

                       IF PNUM=""

                           IF PEXC=""

                               SET PREV=""

 +14               SET $PIECE(BQZZ(ID,"P"),U,1)=$PIECE($GET(BQZZ(ID,"P")),U,1)+PDEN

 +15               SET $PIECE(BQZZ(ID,"P"),U,2)=$PIECE($GET(BQZZ(ID,"P")),U,2)+PNUM

 +16               SET $PIECE(BQZZ(ID,"P"),U,3)=PEXC

               End DoDot:1

 +17       QUIT

BQIMUFAC.m