Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BQIMUDFC

BQIMUDFC.m

Go to the documentation of this file. 
  1. BQIMUDFC ;GDIT/HS/ALA-Facility by Division ; 26 Nov 2012  11:07 AM
  1.  ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
  1.  ;
  1. PERF(DATA,REPORT,TMFRAME,PERIOD,DIV) ;EP -- BQI MU PERF BY DIVISION
  1.  NEW BQCDAR,BQPDAR,CDATA,CDEN,CEXC,CNUM,CPER,CQN,CRDT,CURDT,CURR,HDR,HEAD,HX,ID,IDN,II,PDATA
  1.  NEW PDEN,PEC,PEXC,PNUM,PPER,PQN,PRDT,PREV,PRVR,SORT,PGLOB
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIMUPRPF",UID))
  1.  K @DATA
  1.  S II=0,SORT=""
  1.  S DIV=$G(DIV,""),REPORT=$G(REPORT,"")
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIMUPRV D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  D GTM^BQIMUTIM
  1.  ;
  1.  S HDR="T00050FACILITY^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD^"
  1.  S PGLOB=$$PRFPGL^BQIMUTAB(REPORT)
  1.  S HX=0,PEC=4
  1.  F  S HX=$O(@PGLOB@(HX)) Q:'HX  I $P(@PGLOB@(HX,0),U,2)="E" D
  1.  . I $P(@PGLOB@(HX,0),U,6)'="R" Q
  1.  . S HDR=HDR_"T00005"_$P(@PGLOB@(HX,0),U,1)_"_CURR^T00005"_$P(@PGLOB@(HX,0),U,1)_"_PREV^"
  1.  . S HEAD($P(@PGLOB@(HX,0),U,1))=PEC,PEC=PEC+2
  1.  S @DATA@(II)=$$TKO^BQIUL1(HDR,"^")_$C(30)
  1.  ;
  1.  I $G(DIV)'="" D RPF
  1.  I $G(DIV)="" S DIV=0 D
  1.  . F  S DIV=$O(^BQIFAC(DIV)) Q:'DIV  D RPF
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. CQM(DATA,TMFRAME,PERIOD,DIV) ;EP -- BQI MU CQM BY DIVISION
  1.  NEW BQCDAR,BQPDAR,CDATA,CDEN,CEXC,CNUM,CPER,CQN,CRDT,CURDT,CURR,HDR,HEAD,HX,ID,IDN,II,PDATA
  1.  NEW PDEN,PEC,PEXC,PNUM,PPER,PQN,PRDT,PREV,PRVR,SORT,MSN
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIMUFCQM",UID))
  1.  K @DATA
  1.  S DIV=$G(DIV,"")
  1.  S II=0,SORT=""
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIMUDFC D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  D GTM^BQIMUTIM
  1.  S HDR="T00050FACILITY^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD^"
  1.  S HX=0,PEC=4
  1.  F  S HX=$O(^BGPMUIND(90596.11,HX)) Q:'HX  D
  1.  . S MSN=$P(^BGPMUIND(90596.11,HX,0),U,1)
  1.  . I $G(^BGPMUIND(90595.11,MSN,0))="" Q
  1.  . I $P(^BGPMUIND(90595.11,MSN,0),U,4)'="H" D
  1.  .. S HDR=HDR_"T00005"_$P(^BGPMUIND(90596.11,HX,0),U,4)_"_CURR^T00005"_$P(^BGPMUIND(90596.11,HX,0),U,4)_"_PREV^"
  1.  .. S HEAD($P(^BGPMUIND(90596.11,HX,0),U,4))=PEC,PEC=PEC+2
  1.  S @DATA@(II)=$$TKO^BQIUL1(HDR,"^")_$C(30)
  1.  ;
  1.  I $G(DIV)'="" D RCQ
  1.  I $G(DIV)="" S DIV=0 D
  1.  . F  S DIV=$O(^BQIFAC(DIV)) Q:'DIV  D RCQ
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. RCQ ;
  1.  S PRVR=DIV_$C(28)_$P(^DIC(4,DIV,0),U,1)
  1.  S II=II+1,@DATA@(II)=PRVR_U_CPER_U_PPER_U
  1.  K BQCURR,BQPREV
  1.  S CRDT=""
  1.  F  S CRDT=$O(BQCDAR(CRDT)) Q:CRDT=""  D
  1.  . S CQN=$O(^BQIFAC(DIV,80,"B",CRDT,""))
  1.  . D CAGG
  1.  ;
  1.  S PRDT=""
  1.  F  S PRDT=$O(BQPDAR(PRDT)) Q:PRDT=""  D
  1.  . S PQN=$O(^BQIFAC(DIV,80,"B",PRDT,""))
  1.  . D PAGG
  1.  ;
  1.  S HX=""
  1.  F  S HX=$O(HEAD(HX)) Q:HX=""  D
  1.  . S ID=HX,PEC=$G(HEAD(ID)) I PEC="" Q
  1.  . S CDEN=$P($G(BQCURR(ID)),U,1),CNUM=$P($G(BQCURR(ID)),U,2),CEXC=$P($G(BQCURR(ID)),U,3)
  1.  . I +CNUM=0 S CURR="0%"
  1.  . I +CDEN'=0,+CNUM'=0 S CURR=(CNUM/CDEN)*100,CURR=$J(CURR,3,0)_"%",CURR=$$TRIM^BQIUL1(CURR," ")
  1.  . I CDEN="",CNUM="",CEXC'="" S CURR="Excluded"
  1.  . I CDEN="",CNUM="",CEXC="" S CURR=""
  1.  . S PDEN=$P($G(BQPREV(ID)),U,1),PNUM=$P($G(BQPREV(ID)),U,2),PEXC=$P($G(BQPREV(ID)),U,3)
  1.  . I +PNUM=0 S PREV="0%"
  1.  . I +PDEN'=0,+PNUM'=0 S PREV=$J((PNUM/PDEN)*100,3,0)_"%",PREV=$$TRIM^BQIUL1(PREV," ")
  1.  . I PDEN="",PNUM="",PEXC'="" S PREV="Excluded"
  1.  . I PDEN="",PNUM="",PEXC="" S PREV=""
  1.  . S $P(@DATA@(II),U,PEC)=CURR
  1.  . S $P(@DATA@(II),U,PEC+1)=PREV
  1.  S @DATA@(II)=@DATA@(II)_$C(30)
  1.  K BQCURR,BQPREV
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. CAGG ; Aggregate
  1.  NEW ID
  1.  S ID=""
  1.  F  S ID=$O(HEAD(ID)) Q:ID=""  D
  1.  . S BQCURR(ID)=$S(CQN="":"NDA",'$D(^BQIFAC(DIV,80,CQN,1)):"NDA",1:"N/A")
  1.  ;
  1.  I CQN="" Q
  1.  S IDN=0
  1.  F  S IDN=$O(^BQIFAC(DIV,80,CQN,1,IDN)) Q:'IDN  D
  1.  . S (CDEN,CNUM,CEXC,CURR)=""
  1.  . S CDATA=^BQIFAC(DIV,80,CQN,1,IDN,0)
  1.  . S CDEN=$P(CDATA,U,2),CNUM=$P(CDATA,U,3),CEXC=$P(CDATA,U,4)
  1.  . S ID=$P(CDATA,U,1)
  1.  . S $P(BQCURR(ID),U,1)=$P($G(BQCURR(ID)),U,1)+CDEN
  1.  . S $P(BQCURR(ID),U,2)=$P($G(BQCURR(ID)),U,2)+CNUM
  1.  . S $P(BQCURR(ID),U,3)=$P($G(BQCURR(ID)),U,3)+CEXC
  1.  Q
  1.  ;
  1. PAGG ; Aggregate
  1.  NEW ID
  1.  S ID=""
  1.  F  S ID=$O(HEAD(ID)) Q:ID=""  D
  1.  . S BQPREV(ID)=$S(PQN="":"NDA",'$D(^BQIFAC(DIV,80,PQN,1)):"NDA",1:"N/A")
  1.  ;
  1.  I PQN="" Q
  1.  S IDN=0
  1.  F  S IDN=$O(^BQIFAC(DIV,80,PQN,1,IDN)) Q:'IDN  D
  1.  . S (PDEN,PNUM,PEXC,PREV)=""
  1.  . S PDATA=^BQIFAC(DIV,80,PQN,1,IDN,0)
  1.  . S PDEN=$P(PDATA,U,2),PNUM=$P(PDATA,U,3),PEXC=$P(PDATA,U,4)
  1.  . S ID=$P(PDATA,U,1)
  1.  . S $P(BQPREV(ID),U,1)=$P($G(BQPREV(ID)),U,1)+PDEN
  1.  . S $P(BQPREV(ID),U,2)=$P($G(BQPREV(ID)),U,2)+PNUM
  1.  . S $P(BQPREV(ID),U,3)=$P($G(BQPREV(ID)),U,3)+PEXC
  1.  Q
  1.  ;
  1. RPF ;
  1.  S PRVR=DIV_$C(28)_$P(^DIC(4,DIV,0),U,1)
  1.  S II=II+1,@DATA@(II)=PRVR_U_CPER_U_PPER_U
  1.  K BQCURR,BQPREV
  1.  S CRDT=""
  1.  F  S CRDT=$O(BQCDAR(CRDT)) Q:CRDT=""  D
  1.  . S CQN=$O(^BQIFAC(DIV,70,"B",CRDT,""))
  1.  . D CPAGG
  1.  ;
  1.  S PRDT=""
  1.  F  S PRDT=$O(BQPDAR(PRDT)) Q:PRDT=""  D
  1.  . S PQN=$O(^BQIFAC(DIV,70,"B",PRDT,""))
  1.  . D PPAGG
  1.  ;
  1.  S HX=""
  1.  F  S HX=$O(HEAD(HX)) Q:HX=""  D
  1.  . S ID=HX,PEC=$G(HEAD(ID)) I PEC="" Q
  1.  . S CDEN=$P($G(BQCURR(ID)),U,1),CNUM=$P($G(BQCURR(ID)),U,2)
  1.  . S CEXC=$P($G(BQCURR(ID)),U,3)
  1.  . I +CNUM=0 S CURR="0%"
  1.  . I +CDEN'=0,+CNUM'=0 S CURR=(CNUM/CDEN)*100,CURR=$J(CURR,3,0)_"%",CURR=$$TRIM^BQIUL1(CURR," ")
  1.  . I CDEN="",CNUM="",CEXC'="" S CURR="Excluded"
  1.  . I CDEN="",CNUM="",CEXC="" S CURR=""
  1.  . S PDEN=$P($G(BQPREV(ID)),U,1),PNUM=$P($G(BQPREV(ID)),U,2),PEXC=$P($G(BQPREV(ID)),U,3)
  1.  . I +PNUM=0 S PREV="0%"
  1.  . I +PDEN'=0,+PNUM'=0 S PREV=$J((PNUM/PDEN)*100,3,0)_"%",PREV=$$TRIM^BQIUL1(PREV," ")
  1.  . I PDEN="",PNUM="",PEXC'="" S PREV="Excluded"
  1.  . I PDEN="",PNUM="",PEXC="" S PREV=""
  1.  . S $P(@DATA@(II),U,PEC)=CURR
  1.  . S $P(@DATA@(II),U,PEC+1)=PREV
  1.  S @DATA@(II)=@DATA@(II)_$C(30)
  1.  K BQCURR,BQPREV
  1.  Q
  1.  ;
  1. CPAGG ; Aggregate performance
  1.  NEW ID
  1.  S ID=""
  1.  F  S ID=$O(HEAD(ID)) Q:ID=""  D
  1.  . S BQCURR(ID)=$S(CQN="":"NDA",'$D(^BQIFAC(DIV,70,CQN,1)):"NDA",1:"N/A")
  1.  ;
  1.  I CQN="" Q
  1.  S IDN=0
  1.  F  S IDN=$O(^BQIFAC(DIV,70,CQN,1,IDN)) Q:'IDN  D
  1.  . S (CDEN,CNUM,CEXC,CURR)=""
  1.  . S CDATA=^BQIFAC(DIV,70,CQN,1,IDN,0)
  1.  . S CEXC=$G(^BQIFAC(DIV,70,CQN,1,IDN,1))
  1.  . S CDEN=$P(CDATA,U,2),CNUM=$P(CDATA,U,3)
  1.  . S ID=$P(CDATA,U,1)
  1.  . I CDEN="",CEXC'="" S $P(BQICURR(ID),U,3)=CEXC Q
  1.  . S $P(BQCURR(ID),U,1)=$P($G(BQCURR(ID)),U,1)+CDEN
  1.  . S $P(BQCURR(ID),U,2)=$P($G(BQCURR(ID)),U,2)+CNUM
  1.  Q
  1.  ;
  1. PPAGG ;
  1.  NEW ID
  1.  S ID=""
  1.  F  S ID=$O(HEAD(ID)) Q:ID=""  D
  1.  . S BQPREV(ID)=$S(PQN="":"NDA",'$D(^BQIFAC(DIV,70,PQN,1)):"NDA",1:"N/A")
  1.  ;
  1.  I PQN="" Q
  1.  S IDN=0
  1.  F  S IDN=$O(^BQIFAC(DIV,70,PQN,1,IDN)) Q:'IDN  D
  1.  . S (PDEN,PNUM,PEXC,PREV)=""
  1.  . S PDATA=^BQIFAC(DIV,70,PQN,1,IDN,0)
  1.  . S PEXC=$G(^BQIFAC(DIV,70,PQN,1,IDN,1))
  1.  . S PDEN=$P(PDATA,U,2),PNUM=$P(PDATA,U,3)
  1.  . S ID=$P(PDATA,U,1)
  1.  . I PDEN="",PEXC'="" S $P(BQIPREV(ID),U,3)=PEXC
  1.  . S $P(BQPREV(ID),U,1)=$P($G(BQPREV(ID)),U,1)+PDEN
  1.  . S $P(BQPREV(ID),U,2)=$P($G(BQPREV(ID)),U,2)+PNUM
  1.  Q