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)
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
;
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)
Q
;
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)
Q
;
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
Q
;
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
Q
;
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
Q
;
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
Q
;
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
Q
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
