BQIIPTBL ;VNGT/HS/ALA-IPC Tables ; 24 Jun 2011 8:06 AM
;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
;
;
TMM(DATA,TEAM) ; EP - BQI GET TEAM MEMBERS
; Input Parameters
; TEAM - IEN of the team
NEW UID,II
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIIPCTMM",UID))
K @DATA
S II=0,TYPE=$G(TYPE,"")
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIIPTBL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S HDR="I00010IEN^T00035"
S @DATA@(II)=HDR_$C(30)
S TN=0
F S TN=$O(^BSDPCT(TEAM,1,TN)) Q:'TN D
. S IEN=$P(^BSDPCT(TEAM,1,TN,0),U,1),NAME=$P($G(^VA(200,IEN,0)),U,1)
. S II=II+1,@DATA@(II)=IEN_U_NAME_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
ITM(DATA,CRIPC) ; EP -- BQI GET IPC MEASURES
;
NEW UID,II,CRN,MSN,IDATA,CODE,TYP,CAT,TIP,TP,SHEET,NUM,DEN
NEW BQIH,YEAR,BQIYR,BQIINDG,BQIMEASG,MEAS,ORD,SUB,IEN
NEW BQIINDF,BQIMEASF,CAT1,CAT2,ICAT,HDR,PDIR,TYPE
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIIPCITM",UID))
K @DATA
S II=0,TYPE=$G(TYPE,""),CRIPC=$G(CRIPC,"")
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIIPTBL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S HDR="T00030ID^T00050NAME^T00030CATEGORY^T00030CAT2^T00001SUBCATEGORY^T00030EXCEL_SHEET^T00010EXCEL_NUM_COL^"
S HDR=HDR_"T00010EXCEL_DEN_COL^T00001PER_DIRECT^T01024TOOLTIP"
S @DATA@(II)=HDR_$C(30)
; Get current IPC
I $G(CRIPC)="" S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
S MSN=0
F S MSN=$O(^BQI(90508,1,22,CRN,1,MSN)) Q:'MSN D
. S IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
. S CODE=$P(IDATA,U,1),TYP=$P(IDATA,U,2)
. ; If inactive, quit
. I $P(IDATA,U,7)=1 Q
. ; If type is Non calculable, quit
. I TYP="N" Q
. ; If order of display is blank, quit
. I $P(IDATA,U,6)="" Q
. NEW DA,IENS
. S DA(2)=1,DA(1)=CRN,DA=MSN,IENS=$$IENS^DILF(.DA)
. S SUB=$$GET1^DIQ(90508.221,IENS,.05,"I")
. S ORD=$P(IDATA,U,6),SHEET=$P(IDATA,U,8),NUM=$P(IDATA,U,10),DEN=$P(IDATA,U,9)
. I CRIPC="IPC4/IPC5" D
.. S CAT=$$GET1^DIQ(90508.221,IENS,.03,"E")
.. I CAT="" D
... S RIEN=$O(^BQI(90506.1,"B",CODE,""))
... S CAT=$$GET1^DIQ(90506.1,RIEN_",",3.02,"E")
.. S CAT2=$$GET1^DIQ(90508.221,IENS,.11,"E")
. I CRIPC="IPCMH" D
.. S CAT1=$$GET1^DIQ(90508.221,IENS,.03,"E")
.. S ICAT=$$GET1^DIQ(90508.221,IENS,.03,"I")
.. S CAT2=$$GET1^DIQ(90508.221,IENS,.11,"E")
.. I CAT2="" S CAT2=$$GET1^DIQ(90506.8,ICAT_",",.04,"E")
.. S CAT=CAT2,CAT2=CAT1
. ;I CAT2'="" S CAT=CAT2,CAT2=CAT1
. ;I CAT2="" S CAT=CAT1
. S PDIR=$$MEAS^BQIGPUTL(CODE)
. S TIP="",TP=0
. F S TP=$O(^BQI(90508,1,22,CRN,1,MSN,3,TP)) Q:'TP D
.. S TIP=TIP_^BQI(90508,1,22,CRN,1,MSN,3,TP,0)_$C(10)
. I TIP="",TYP="G" D
.. S BQIH=$$SPM^BQIGPUTL()
.. S YEAR=$$GET1^DIQ(90508,BQIH_",",2,"E")
.. S BQIYR=$$LKP^BQIGPUTL(YEAR)
.. D GFN^BQIGPUTL(BQIH,BQIYR)
.. S BQIINDG=$$ROOT^DILFD(BQIINDF,"",1)
.. S BQIMEASG=$$ROOT^DILFD(BQIMEASF,"",1)
.. S MEAS=$P(CODE,"_",2),TP=0
.. F S TP=$O(@BQIMEASG@(MEAS,18,TP)) Q:'TP D
... S TIP=TIP_@BQIMEASG@(MEAS,18,TP,0)_$C(10)
. I TIP="",TYP="M" D
.. S MEAS=$P(CODE,"_",2),TP=0
.. F S TP=$O(^BGPMUIND(90596.11,MEAS,18,TP)) Q:'TP D
... S TIP=TIP_^BGPMUIND(90596.11,MEAS,18,TP,0)_$C(10)
. S II=II+1,@DATA@(II)=CODE_U_$P(IDATA,U,4)_U_CAT_U_CAT2_U_SUB_U_SHEET_U_NUM_U_DEN_U_PDIR_U_TIP_$C(30)
;
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
;
DTE(DATA,CRIPC) ;EP -- BQI GET IPC DATES
NEW UID,II,CRN,MSN,DATE,MONTH,MSN,BQMON,TIT
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIIPCDTE",UID))
K @DATA
S II=0,TYPE=$G(TYPE,""),CRIPC=$G(CRIPC,"")
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIIPTBL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S HDR="T00030DATE^T00010ROW^T00010MONTH^T00007HIDE_MON_DATE"
S @DATA@(II)=HDR_$C(30)
; Get current IPC
I $G(CRIPC)="" S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
I CRIPC="IPCMH" S CRIPC="IPC4/IPC5"
S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
S DATE=""
F S DATE=$O(^BQI(90508,1,22,CRN,3,"B",DATE),-1) Q:DATE="" D
. S MSN=""
. F S MSN=$O(^BQI(90508,1,22,CRN,3,"B",DATE,MSN)) Q:MSN="" D
.. S BQMON=$E(DATE,4,5)
.. S TIT=$P($T(MON+BQMON^BQIIPUTL),";;",2)_"_"_(1700+$E(DATE,1,3))
.. S MONTH=$P($T(MON+BQMON^BQIIPUTL),";;",2)_"-"_$E((1700+$E(DATE,1,3)),3,4)
.. S II=II+1,@DATA@(II)=TIT_U_$P(^BQI(90508,1,22,CRN,3,MSN,0),U,2)_U_MONTH_U_DATE_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
BQIIPTBL ;VNGT/HS/ALA-IPC Tables ; 24 Jun 2011 8:06 AM
+1 ;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
+2 ;
+3 ;
TMM(DATA,TEAM) ; EP - BQI GET TEAM MEMBERS
+1 ; Input Parameters
+2 ; TEAM - IEN of the team
+3 NEW UID,II
+4 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+5 SET DATA=$NAME(^TMP("BQIIPCTMM",UID))
+6 KILL @DATA
+7 SET II=0
SET TYPE=$GET(TYPE,"")
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIIPTBL D UNWIND^%ZTER"
+9 ;
+10 SET HDR="I00010IEN^T00035"
+11 SET @DATA@(II)=HDR_$CHAR(30)
+12 SET TN=0
+13 FOR
SET TN=$ORDER(^BSDPCT(TEAM,1,TN))
IF 'TN
QUIT
Begin DoDot:1
+14 SET IEN=$PIECE(^BSDPCT(TEAM,1,TN,0),U,1)
SET NAME=$PIECE($GET(^VA(200,IEN,0)),U,1)
+15 SET II=II+1
SET @DATA@(II)=IEN_U_NAME_$CHAR(30)
End DoDot:1
+16 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+17 QUIT
+18 ;
ITM(DATA,CRIPC) ; EP -- BQI GET IPC MEASURES
+1 ;
+2 NEW UID,II,CRN,MSN,IDATA,CODE,TYP,CAT,TIP,TP,SHEET,NUM,DEN
+3 NEW BQIH,YEAR,BQIYR,BQIINDG,BQIMEASG,MEAS,ORD,SUB,IEN
+4 NEW BQIINDF,BQIMEASF,CAT1,CAT2,ICAT,HDR,PDIR,TYPE
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 SET DATA=$NAME(^TMP("BQIIPCITM",UID))
+7 KILL @DATA
+8 SET II=0
SET TYPE=$GET(TYPE,"")
SET CRIPC=$GET(CRIPC,"")
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIIPTBL D UNWIND^%ZTER"
+10 ;
+11 SET HDR="T00030ID^T00050NAME^T00030CATEGORY^T00030CAT2^T00001SUBCATEGORY^T00030EXCEL_SHEET^T00010EXCEL_NUM_COL^"
+12 SET HDR=HDR_"T00010EXCEL_DEN_COL^T00001PER_DIRECT^T01024TOOLTIP"
+13 SET @DATA@(II)=HDR_$CHAR(30)
+14 ; Get current IPC
+15 IF $GET(CRIPC)=""
SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
+16 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
QUIT
+17 SET MSN=0
+18 FOR
SET MSN=$ORDER(^BQI(90508,1,22,CRN,1,MSN))
IF 'MSN
QUIT
Begin DoDot:1
+19 SET IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
+20 SET CODE=$PIECE(IDATA,U,1)
SET TYP=$PIECE(IDATA,U,2)
+21 ; If inactive, quit
+22 IF $PIECE(IDATA,U,7)=1
QUIT
+23 ; If type is Non calculable, quit
+24 IF TYP="N"
QUIT
+25 ; If order of display is blank, quit
+26 IF $PIECE(IDATA,U,6)=""
QUIT
+27 NEW DA,IENS
+28 SET DA(2)=1
SET DA(1)=CRN
SET DA=MSN
SET IENS=$$IENS^DILF(.DA)
+29 SET SUB=$$GET1^DIQ(90508.221,IENS,.05,"I")
+30 SET ORD=$PIECE(IDATA,U,6)
SET SHEET=$PIECE(IDATA,U,8)
SET NUM=$PIECE(IDATA,U,10)
SET DEN=$PIECE(IDATA,U,9)
+31 IF CRIPC="IPC4/IPC5"
Begin DoDot:2
+32 SET CAT=$$GET1^DIQ(90508.221,IENS,.03,"E")
+33 IF CAT=""
Begin DoDot:3
+34 SET RIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
+35 SET CAT=$$GET1^DIQ(90506.1,RIEN_",",3.02,"E")
End DoDot:3
+36 SET CAT2=$$GET1^DIQ(90508.221,IENS,.11,"E")
End DoDot:2
+37 IF CRIPC="IPCMH"
Begin DoDot:2
+38 SET CAT1=$$GET1^DIQ(90508.221,IENS,.03,"E")
+39 SET ICAT=$$GET1^DIQ(90508.221,IENS,.03,"I")
+40 SET CAT2=$$GET1^DIQ(90508.221,IENS,.11,"E")
+41 IF CAT2=""
SET CAT2=$$GET1^DIQ(90506.8,ICAT_",",.04,"E")
+42 SET CAT=CAT2
SET CAT2=CAT1
End DoDot:2
+43 ;I CAT2'="" S CAT=CAT2,CAT2=CAT1
+44 ;I CAT2="" S CAT=CAT1
+45 SET PDIR=$$MEAS^BQIGPUTL(CODE)
+46 SET TIP=""
SET TP=0
+47 FOR
SET TP=$ORDER(^BQI(90508,1,22,CRN,1,MSN,3,TP))
IF 'TP
QUIT
Begin DoDot:2
+48 SET TIP=TIP_^BQI(90508,1,22,CRN,1,MSN,3,TP,0)_$CHAR(10)
End DoDot:2
+49 IF TIP=""
IF TYP="G"
Begin DoDot:2
+50 SET BQIH=$$SPM^BQIGPUTL()
+51 SET YEAR=$$GET1^DIQ(90508,BQIH_",",2,"E")
+52 SET BQIYR=$$LKP^BQIGPUTL(YEAR)
+53 DO GFN^BQIGPUTL(BQIH,BQIYR)
+54 SET BQIINDG=$$ROOT^DILFD(BQIINDF,"",1)
+55 SET BQIMEASG=$$ROOT^DILFD(BQIMEASF,"",1)
+56 SET MEAS=$PIECE(CODE,"_",2)
SET TP=0
+57 FOR
SET TP=$ORDER(@BQIMEASG@(MEAS,18,TP))
IF 'TP
QUIT
Begin DoDot:3
+58 SET TIP=TIP_@BQIMEASG@(MEAS,18,TP,0)_$CHAR(10)
End DoDot:3
End DoDot:2
+59 IF TIP=""
IF TYP="M"
Begin DoDot:2
+60 SET MEAS=$PIECE(CODE,"_",2)
SET TP=0
+61 FOR
SET TP=$ORDER(^BGPMUIND(90596.11,MEAS,18,TP))
IF 'TP
QUIT
Begin DoDot:3
+62 SET TIP=TIP_^BGPMUIND(90596.11,MEAS,18,TP,0)_$CHAR(10)
End DoDot:3
End DoDot:2
+63 SET II=II+1
SET @DATA@(II)=CODE_U_$PIECE(IDATA,U,4)_U_CAT_U_CAT2_U_SUB_U_SHEET_U_NUM_U_DEN_U_PDIR_U_TIP_$CHAR(30)
End DoDot:1
+64 ;
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 ;
DTE(DATA,CRIPC) ;EP -- BQI GET IPC DATES
+1 NEW UID,II,CRN,MSN,DATE,MONTH,MSN,BQMON,TIT
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQIIPCDTE",UID))
+4 KILL @DATA
+5 SET II=0
SET TYPE=$GET(TYPE,"")
SET CRIPC=$GET(CRIPC,"")
+6 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIIPTBL D UNWIND^%ZTER"
+7 ;
+8 SET HDR="T00030DATE^T00010ROW^T00010MONTH^T00007HIDE_MON_DATE"
+9 SET @DATA@(II)=HDR_$CHAR(30)
+10 ; Get current IPC
+11 IF $GET(CRIPC)=""
SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
+12 IF CRIPC="IPCMH"
SET CRIPC="IPC4/IPC5"
+13 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
QUIT
+14 SET DATE=""
+15 FOR
SET DATE=$ORDER(^BQI(90508,1,22,CRN,3,"B",DATE),-1)
IF DATE=""
QUIT
Begin DoDot:1
+16 SET MSN=""
+17 FOR
SET MSN=$ORDER(^BQI(90508,1,22,CRN,3,"B",DATE,MSN))
IF MSN=""
QUIT
Begin DoDot:2
+18 SET BQMON=$EXTRACT(DATE,4,5)
+19 SET TIT=$PIECE($TEXT(MON+BQMON^BQIIPUTL),";;",2)_"_"_(1700+$EXTRACT(DATE,1,3))
+20 SET MONTH=$PIECE($TEXT(MON+BQMON^BQIIPUTL),";;",2)_"-"_$EXTRACT((1700+$EXTRACT(DATE,1,3)),3,4)
+21 SET II=II+1
SET @DATA@(II)=TIT_U_$PIECE(^BQI(90508,1,22,CRN,3,MSN,0),U,2)_U_MONTH_U_DATE_$CHAR(30)
End DoDot:2
End DoDot:1
+22 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+23 QUIT
