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

BQIMUFCH.m

Go to the documentation of this file. 
  1. BQIMUFCH ;VNGT/HS/ALA-Hospital Hover Help ; 06 May 2011  8:17 AM
  1.  ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
  1.  ;
  1.  ;
  1. EN(DATA,REPORT,TMFRAME,PERIOD) ; EP -- BQI MU GET FACILITY HOVER
  1.  NEW UID,II,HDR,C1,C2,C3,C4,NAME,HEAD,HX,PEC,SORT,QFL,PCT,CT,DDATA
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIMUFCPH",UID))
  1.  K @DATA
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIMUFCH D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  S TMFRAME=$G(TMFRAME,90),REPORT=$G(REPORT,"")
  1.  S HDR="T00050HIDE_FACILITY^T00020HIDE_ID^T00050OBJECTIVE^T00010MEAS_SET^T00005CURR_DEN^T00005CURR_NUM^T00005CURR_MET^T00010STAGE_1_GOAL^"
  1.  S HDR=HDR_"T00005PREV_DEN^T00005PREV_NUM^T00005PREV_MET^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD"
  1.  S @DATA@(II)=HDR_$C(30)
  1.  D GTM^BQIMUTIM
  1.  S FAC=$$HME^BQIGPUTL() D RTE(FAC)
  1.  ;
  1. DONE ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  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. RTE(FAC) ; EP
  1.  NEW DATE,MN,MDATA,PRVR,CFROM,CTHRU,PFROM,PTHRU,IDN,CDEN,CNUM,CEXC,PDEN
  1.  NEW PNUM,PEXC,CURR,PREV,PDATA,CDATA,BQZZ,ST1G,MSET,ID,FACIL,PGLOB
  1.  ;S FACIL=FAC_$C(28)_$P(^DIC(4,FAC,0),U,1)
  1.  S FACIL=$P(^DIC(4,FAC,0),U,1)
  1.  S PGLOB=$$PRFPGL^BQIMUTAB(REPORT)
  1.  ;
  1.  S PN=0
  1.  F  S PN=$O(@PGLOB@(PN)) Q:'PN  D
  1.  . S ID=$P(@PGLOB@(PN,0),U,1) I $P(@PGLOB@(PN,0),U,2)'="H" Q
  1.  . I $P(@PGLOB@(PN,0),U,6)="A" Q
  1.  . S BQZZ(ID,"C")="NDA",BQZZ(ID,"P")="NDA"
  1.  ;
  1.  S CRDT=""
  1.  F  S CRDT=$O(BQCDAR(CRDT)) Q:CRDT=""  D
  1.  . S CQN=$O(^BQIFAC(FAC,40,"B",CRDT,""))
  1.  . D CPAGG
  1.  ;
  1.  S PRDT=""
  1.  F  S PRDT=$O(BQPDAR(PRDT)) Q:PRDT=""  D
  1.  . S PQN=$O(^BQIFAC(FAC,40,"B",PRDT,""))
  1.  . D PPAGG
  1.  ;
  1.  S ID=""
  1.  F  S ID=$O(BQZZ(ID)) Q:ID=""  D
  1.  . S IMN=$O(@PGLOB@("B",ID,"")) I IMN="" Q
  1.  . S ST1G=$G(@PGLOB@(IMN,13,1,0)),OBJ=$P(@PGLOB@(IMN,0),U,5)
  1.  . S MSET=$$GET1^DIQ(9001300.02,IMN_",",.03,"E")
  1.  . S CDEN=$P($G(BQZZ(ID,"C")),U,1)
  1.  . S CNUM=$P($G(BQZZ(ID,"C")),U,2)
  1.  . S CEXC=$P($G(BQZZ(ID,"C")),U,3)
  1.  . ;
  1.  . S PDEN=$P($G(BQZZ(ID,"P")),U,1)
  1.  . S PNUM=$P($G(BQZZ(ID,"P")),U,2)
  1.  . S PEXC=$P($G(BQZZ(ID,"P")),U,3)
  1.  . ;
  1.  . I +CDEN=0,+CNUM=0 S CURR=""
  1.  . I +PDEN=0,+PNUM=0 S PREV=""
  1.  . I +CDEN'=0,+CNUM=0 S CURR=""
  1.  . I +PDEN'=0,+PNUM=0 S PREV=""
  1.  . I +CDEN'=0,+CNUM'=0 S CURR=""
  1.  . I +PDEN'=0,+PNUM'=0 S PREV=""
  1.  . I CURR="" S CURR="N/A"
  1.  . I PREV="" S PREV="N/A"
  1.  . I CEXC'="" S CURR=CEXC
  1.  . I PEXC'="" S PREV=PEXC
  1.  . S:CNUM="" CNUM=0 S:PNUM="" PNUM=0 S:CDEN="" CDEN=0 S:PDEN="" PDEN=0
  1.  . 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)
  1.  K BQZZ
  1.  Q
  1.  ;
  1. CQ(DATA,TMFRAME,PERIOD) ; EP -- BQI MU GET FAC CQ HOVER
  1.  NEW UID,II,HDR,C1,C2,C3,C4,NAME,HEAD,HX,PEC,SORT,QFL,PCT,CT,DDATA
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIMUFCQH",UID))
  1.  K @DATA
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIMUFCH D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  S TMFRAME=$G(TMFRAME,90)
  1.  S HDR="T00050HIDE_FACILITY^T00020HIDE_ID^T00050OBJECTIVE^T00010MEAS_SET^T00005CURR_DEN^T00005CURR_NUM^T00005CURR_MET^T00010STAGE_1_GOAL^"
  1.  S HDR=HDR_"T00005PREV_DEN^T00005PREV_NUM^T00005PREV_MET^T00030HIDE_CURR_PERIOD^T00030HIDE_PREV_PERIOD"
  1.  S @DATA@(II)=HDR_$C(30)
  1.  ;
  1.  D GTM^BQIMUTIM
  1.  ;
  1.  S FAC=$$HME^BQIGPUTL() D RET(FAC)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. RET(FAC) ; EP
  1.  NEW DATE,MN,MDATA,PRVR,CFROM,CTHRU,PFROM,PTHRU,IDN,CDEN,CNUM,CEXC,PDEN
  1.  NEW PNUM,PEXC,CURR,PREV,PDATA,CDATA,BQZZ,ST1G,MSET,ID,FACIL
  1.  ;S FACIL=FAC_$C(28)_$P(^DIC(4,FAC,0),U,1)
  1.  S FACIL=$P(^DIC(4,FAC,0),U,1)
  1.  ;
  1.  S X=0 F  S X=$O(^BGPMUIND(90595.11,"AMS","H",X)) Q:X'=+X  S BGPIND(X)=""
  1.  S I="" F  S I=$O(BGPIND(I)) Q:I=""  D
  1.  . S BN="" F  S BN=$O(^BGPMUIND(90596.11,"B",I,BN)) Q:BN=""  D
  1.  .. S ID=$P(^BGPMUIND(90596.11,BN,0),U,4),BQZZ(ID,"C")="NDA",BQZZ(ID,"P")="NDA"
  1.  ;
  1.  S CRDT=""
  1.  F  S CRDT=$O(BQCDAR(CRDT)) Q:CRDT=""  D
  1.  . S CQN=$O(^BQIFAC(FAC,50,"B",CRDT,""))
  1.  . D CAGG
  1.  ;
  1.  S PRDT=""
  1.  F  S PRDT=$O(BQPDAR(PRDT)) Q:PRDT=""  D
  1.  . S PQN=$O(^BQIFAC(FAC,50,"B",PRDT,""))
  1.  . D PAGG
  1.  ;
  1.  S ID=""
  1.  F  S ID=$O(BQZZ(ID)) Q:ID=""  D
  1.  . S IMN=$O(^BGPMUIND(90596.11,"C",ID,"")) I IMN="" Q
  1.  . S ST1G="",OBJ=$P($G(^BGPMUIND(90596.11,IMN,17)),U,3)
  1.  . S MSN=$P(^BGPMUIND(90596.11,IMN,0),U,1)
  1.  . I $P(^BGPMUIND(90595.11,MSN,0),U,4)'="H" Q
  1.  . S MSET="HOSPITAL"
  1.  . ;
  1.  . S CDEN=$P($G(BQZZ(ID,"C")),U,1)
  1.  . S CNUM=$P($G(BQZZ(ID,"C")),U,2)
  1.  . S CEXC=$P($G(BQZZ(ID,"C")),U,3)
  1.  . ;
  1.  . S PDEN=$P($G(BQZZ(ID,"P")),U,1)
  1.  . S PNUM=$P($G(BQZZ(ID,"P")),U,2)
  1.  . S PEXC=$P($G(BQZZ(ID,"P")),U,3)
  1.  . ;
  1.  . I ID[".ED." D
  1.  .. S CURR=""
  1.  .. I CDEN'="" S CURR=""
  1.  .. S PREV=""
  1.  .. I PDEN'="" S PREV=""
  1.  . I ID'[".ED." D
  1.  .. I +CDEN=0,+CNUM=0 S CURR=""
  1.  .. I +CDEN'=0,+CNUM=0 S CURR=""
  1.  .. I +CDEN'=0,+CNUM'=0,(CDEN-CEXC)=0 S CURR=""
  1.  .. I +CDEN'=0,+CNUM'=0,(CDEN-CEXC)'=0 S CURR=""
  1.  .. S:CNUM="" CNUM=0 S:CDEN="" CDEN=0
  1.  .. I +PDEN=0,+PNUM=0 S PREV=""
  1.  .. I +PDEN'=0,+PNUM=0 S PREV=""
  1.  .. I +PDEN'=0,+PNUM'=0,(PDEN-PEXC)=0 S PREV=""
  1.  .. I +PDEN'=0,+PNUM'=0,(PDEN-PEXC)'=0 S PREV=""
  1.  . 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)
  1.  K BQZZ
  1.  Q
  1.  ;
  1. CAGG ; Aggregate
  1.  ;
  1.  I CQN="" Q
  1.  S IDN=0
  1.  F  S IDN=$O(^BQIFAC(FAC,50,CQN,1,IDN)) Q:'IDN  D
  1.  . S (CDEN,CNUM,CEXC,CURR)=""
  1.  . S CDATA=^BQIFAC(FAC,50,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(BQZZ(ID,"C"),U,1)=$P($G(BQZZ(ID,"C")),U,1)+CDEN
  1.  . S $P(BQZZ(ID,"C"),U,2)=$P($G(BQZZ(ID,"C")),U,2)+CNUM
  1.  . S $P(BQZZ(ID,"C"),U,3)=$P($G(BQZZ(ID,"C")),U,3)+CEXC
  1.  Q
  1.  ;
  1. PAGG ; Aggregate
  1.  I PQN="" Q
  1.  S IDN=0
  1.  F  S IDN=$O(^BQIFAC(FAC,50,PQN,1,IDN)) Q:'IDN  D
  1.  . S (PDEN,PNUM,PEXC,PREV)=""
  1.  . S PDATA=^BQIFAC(FAC,50,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.  . ;
  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(BQZZ(ID,"P"),U,1)=$P($G(BQZZ(ID,"P")),U,1)+PDEN
  1.  . S $P(BQZZ(ID,"P"),U,2)=$P($G(BQZZ(ID,"P")),U,2)+PNUM
  1.  . S $P(BQZZ(ID,"P"),U,3)=$P($G(BQZZ(ID,"P")),U,3)+PEXC
  1.  Q
  1.  ;
  1. CPAGG ; Aggregate performance
  1.  I CQN="" Q
  1.  S IDN=0
  1.  F  S IDN=$O(^BQIFAC(FAC,40,CQN,1,IDN)) Q:'IDN  D
  1.  . S (CDEN,CNUM,CEXC,CURR)=""
  1.  . S CDATA=^BQIFAC(FAC,40,CQN,1,IDN,0)
  1.  . S CDEN=$P(CDATA,U,2),CNUM=$P(CDATA,U,3)
  1.  . S CEXC=$G(^BQIFAC(FAC,40,CQN,1,IDN,1))
  1.  . S ID=$P(CDATA,U,1)
  1.  . S $P(BQZZ(ID,"C"),U,1)=$P($G(BQZZ(ID,"C")),U,1)+CDEN
  1.  . S $P(BQZZ(ID,"C"),U,2)=$P($G(BQZZ(ID,"C")),U,2)+CNUM
  1.  . S $P(BQZZ(ID,"C"),U,3)=CEXC
  1.  Q
  1.  ;
  1. PPAGG ;
  1.  I PQN="" Q
  1.  S IDN=0
  1.  F  S IDN=$O(^BQIFAC(FAC,40,PQN,1,IDN)) Q:'IDN  D
  1.  . S (PDEN,PNUM,PEXC,PREV)=""
  1.  . S PDATA=^BQIFAC(FAC,40,PQN,1,IDN,0)
  1.  . S PDEN=$P(PDATA,U,2),PNUM=$P(PDATA,U,3)
  1.  . S PEXC=$G(^BQIFAC(FAC,40,PQN,1,IDN,1))
  1.  . S ID=$P(PDATA,U,1)
  1.  . ;
  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(BQZZ(ID,"P"),U,1)=$P($G(BQZZ(ID,"P")),U,1)+PDEN
  1.  . S $P(BQZZ(ID,"P"),U,2)=$P($G(BQZZ(ID,"P")),U,2)+PNUM
  1.  . S $P(BQZZ(ID,"P"),U,3)=PEXC
  1.  Q