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

BQIIPTBL.m

Go to the documentation of this file. 
  1. BQIIPTBL ;VNGT/HS/ALA-IPC Tables ; 24 Jun 2011  8:06 AM
  1.  ;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
  1.  ;
  1.  ;
  1. TMM(DATA,TEAM) ; EP - BQI GET TEAM MEMBERS
  1.  ; Input Parameters
  1.  ;   TEAM - IEN of the team
  1.  NEW UID,II
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIIPCTMM",UID))
  1.  K @DATA
  1.  S II=0,TYPE=$G(TYPE,"")
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIIPTBL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S HDR="I00010IEN^T00035"
  1.  S @DATA@(II)=HDR_$C(30)
  1.  S TN=0
  1.  F  S TN=$O(^BSDPCT(TEAM,1,TN)) Q:'TN  D
  1.  . S IEN=$P(^BSDPCT(TEAM,1,TN,0),U,1),NAME=$P($G(^VA(200,IEN,0)),U,1)
  1.  . S II=II+1,@DATA@(II)=IEN_U_NAME_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ITM(DATA,CRIPC) ; EP -- BQI GET IPC MEASURES
  1.  ;
  1.  NEW UID,II,CRN,MSN,IDATA,CODE,TYP,CAT,TIP,TP,SHEET,NUM,DEN
  1.  NEW BQIH,YEAR,BQIYR,BQIINDG,BQIMEASG,MEAS,ORD,SUB,IEN
  1.  NEW BQIINDF,BQIMEASF,CAT1,CAT2,ICAT,HDR,PDIR,TYPE
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIIPCITM",UID))
  1.  K @DATA
  1.  S II=0,TYPE=$G(TYPE,""),CRIPC=$G(CRIPC,"")
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIIPTBL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S HDR="T00030ID^T00050NAME^T00030CATEGORY^T00030CAT2^T00001SUBCATEGORY^T00030EXCEL_SHEET^T00010EXCEL_NUM_COL^"
  1.  S HDR=HDR_"T00010EXCEL_DEN_COL^T00001PER_DIRECT^T01024TOOLTIP"
  1.  S @DATA@(II)=HDR_$C(30)
  1.  ; Get current IPC
  1.  I $G(CRIPC)="" S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
  1.  S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
  1.  S MSN=0
  1.  F  S MSN=$O(^BQI(90508,1,22,CRN,1,MSN)) Q:'MSN  D
  1.  . S IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
  1.  . S CODE=$P(IDATA,U,1),TYP=$P(IDATA,U,2)
  1.  . ; If inactive, quit
  1.  . I $P(IDATA,U,7)=1 Q
  1.  . ; If type is Non calculable, quit
  1.  . I TYP="N" Q
  1.  . ; If order of display is blank, quit
  1.  . I $P(IDATA,U,6)="" Q
  1.  . NEW DA,IENS
  1.  . S DA(2)=1,DA(1)=CRN,DA=MSN,IENS=$$IENS^DILF(.DA)
  1.  . S SUB=$$GET1^DIQ(90508.221,IENS,.05,"I")
  1.  . S ORD=$P(IDATA,U,6),SHEET=$P(IDATA,U,8),NUM=$P(IDATA,U,10),DEN=$P(IDATA,U,9)
  1.  . I CRIPC="IPC4/IPC5" D
  1.  .. S CAT=$$GET1^DIQ(90508.221,IENS,.03,"E")
  1.  .. I CAT="" D
  1.  ... S RIEN=$O(^BQI(90506.1,"B",CODE,""))
  1.  ... S CAT=$$GET1^DIQ(90506.1,RIEN_",",3.02,"E")
  1.  .. S CAT2=$$GET1^DIQ(90508.221,IENS,.11,"E")
  1.  . I CRIPC="IPCMH" D
  1.  .. S CAT1=$$GET1^DIQ(90508.221,IENS,.03,"E")
  1.  .. S ICAT=$$GET1^DIQ(90508.221,IENS,.03,"I")
  1.  .. S CAT2=$$GET1^DIQ(90508.221,IENS,.11,"E")
  1.  .. I CAT2="" S CAT2=$$GET1^DIQ(90506.8,ICAT_",",.04,"E")
  1.  .. S CAT=CAT2,CAT2=CAT1
  1.  . ;I CAT2'="" S CAT=CAT2,CAT2=CAT1
  1.  . ;I CAT2="" S CAT=CAT1
  1.  . S PDIR=$$MEAS^BQIGPUTL(CODE)
  1.  . S TIP="",TP=0
  1.  . F  S TP=$O(^BQI(90508,1,22,CRN,1,MSN,3,TP)) Q:'TP  D
  1.  .. S TIP=TIP_^BQI(90508,1,22,CRN,1,MSN,3,TP,0)_$C(10)
  1.  . I TIP="",TYP="G" D
  1.  .. S BQIH=$$SPM^BQIGPUTL()
  1.  .. S YEAR=$$GET1^DIQ(90508,BQIH_",",2,"E")
  1.  .. S BQIYR=$$LKP^BQIGPUTL(YEAR)
  1.  .. D GFN^BQIGPUTL(BQIH,BQIYR)
  1.  .. S BQIINDG=$$ROOT^DILFD(BQIINDF,"",1)
  1.  .. S BQIMEASG=$$ROOT^DILFD(BQIMEASF,"",1)
  1.  .. S MEAS=$P(CODE,"_",2),TP=0
  1.  .. F  S TP=$O(@BQIMEASG@(MEAS,18,TP)) Q:'TP  D
  1.  ... S TIP=TIP_@BQIMEASG@(MEAS,18,TP,0)_$C(10)
  1.  . I TIP="",TYP="M" D
  1.  .. S MEAS=$P(CODE,"_",2),TP=0
  1.  .. F  S TP=$O(^BGPMUIND(90596.11,MEAS,18,TP)) Q:'TP  D
  1.  ... S TIP=TIP_^BGPMUIND(90596.11,MEAS,18,TP,0)_$C(10)
  1.  . 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)
  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. DTE(DATA,CRIPC) ;EP -- BQI GET IPC DATES
  1.  NEW UID,II,CRN,MSN,DATE,MONTH,MSN,BQMON,TIT
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIIPCDTE",UID))
  1.  K @DATA
  1.  S II=0,TYPE=$G(TYPE,""),CRIPC=$G(CRIPC,"")
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIIPTBL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S HDR="T00030DATE^T00010ROW^T00010MONTH^T00007HIDE_MON_DATE"
  1.  S @DATA@(II)=HDR_$C(30)
  1.  ; Get current IPC
  1.  I $G(CRIPC)="" S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
  1.  I CRIPC="IPCMH" S CRIPC="IPC4/IPC5"
  1.  S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
  1.  S DATE=""
  1.  F  S DATE=$O(^BQI(90508,1,22,CRN,3,"B",DATE),-1) Q:DATE=""  D
  1.  . S MSN=""
  1.  . F  S MSN=$O(^BQI(90508,1,22,CRN,3,"B",DATE,MSN)) Q:MSN=""  D
  1.  .. S BQMON=$E(DATE,4,5)
  1.  .. S TIT=$P($T(MON+BQMON^BQIIPUTL),";;",2)_"_"_(1700+$E(DATE,1,3))
  1.  .. S MONTH=$P($T(MON+BQMON^BQIIPUTL),";;",2)_"-"_$E((1700+$E(DATE,1,3)),3,4)
  1.  .. 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)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q