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

BQIRLB.m

Go to the documentation of this file. 
  1. BQIRLB ;PRXM/HC/DLS - Patient Labs ; 18 Jan 2006  11:46 AM
  1.  ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
  1.  ;
  1.  Q
  1.  ;
  1. EN(DATA,DFN,DRANGE,PARMS) ; EP -- BQI PATIENT LABS
  1.  ;Description
  1.  ;  Generates a Lab Review Report for a Given DFN and Relative Date.
  1.  ;
  1.  ;Input
  1.  ;  DFN    - Patient Internal ID
  1.  ;  DRANGE - 'From' for pulling Patient Labs (to the present).
  1.  ;  PARMS  - Parameters for special filtering
  1.  ;
  1.  ;Output
  1.  ;  DATA - Name of global in which data is stored(^TMP("BQIRLB"))
  1.  ;
  1.  NEW UID,X,BQII,LABDT,LABTYP,RLABDT,LABIEN,ORPHY,VISIT,PAR,PNL,SPNLNM
  1.  NEW DATE,TEST,RSLT,UNIT,REFLOW,REFHIGH,RANGE,RDRANGE,NRMABN,TST,PNLNM
  1.  NEW ASDATA,ASN,ASNAME,ASSOC,ASV,ASVAL,BN,BQ,CGFL,FILTER,II,PDATA,REGIEN
  1.  NEW RGFL,RGRP,TAX,TN,TREF,VAL,FDATA
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIRLB",UID))
  1.  K @DATA
  1.  ;
  1.  S BQII=0
  1.  ;
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRLB D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S PARMS=$G(PARMS,"")
  1.  I PARMS="" D
  1.  . S LIST="",BN=""
  1.  . F  S BN=$O(PARMS(BN)) Q:BN=""  S LIST=LIST_PARMS(BN)
  1.  . K PARMS
  1.  . S PARMS=LIST
  1.  . K LIST
  1.  ;
  1.  F BQ=1:1:$L(PARMS,$C(28)) S FILTER(BQ)=$P(PARMS,$C(28),BQ)
  1.  F BQQ=1:1:BQ D
  1.  . S PDATA=$G(FILTER(BQQ)) Q:PDATA=""
  1.  . S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
  1.  . S FDATA(BQQ)=NAME
  1.  . F II=1:1:$L(VALUE,$C(29)) D
  1.  .. S VAL=$P(VALUE,$C(29),II),ASSOC=$P(VAL,$C(25),2,99)
  1.  .. S FILTER(BQQ,II)=$P(VAL,$C(25),1)
  1.  .. I ASSOC'="" D
  1.  ... F ASN=1:1:$L(ASSOC,$C(25)) D
  1.  .... S ASDATA=$P(ASSOC,$C(25),ASN)
  1.  .... S ASVAL=$P(ASDATA,"=",2),ASNAME=$P(ASDATA,"=",1)
  1.  .... S FILTER(BQQ,II,ASN)=ASNAME
  1.  .... I ASVAL'[$C(24) S FILTER(BQQ,II,ASN,1)=ASVAL Q
  1.  .... F ASV=1:1:$L(ASVAL,$C(24)) S FILTER(BQQ,II,ASN,ASV)=$P(ASVAL,$C(24),ASV)
  1.  .. I ASSOC="" S FILTER(BQQ,II)=VAL
  1.  I $D(FDATA) F BQQ=1:1:BQ S FILTER(BQQ)=FDATA(BQQ)
  1.  K FDATA,PARMS
  1.  ;
  1.  NEW BQQ,MBQ,NAME,VALUE,SBQ,MSBQ
  1.  K REG,CGRP
  1.  S BQQ="",CGFL=0,RGFL=0
  1.  F  S BQQ=$O(FILTER(BQQ)) Q:BQQ=""  D
  1.  . ;S NAME=FILTER(BQQ)
  1.  . S MBQ=""
  1.  . F  S MBQ=$O(FILTER(BQQ,MBQ)) Q:MBQ=""  D
  1.  .. S VALUE=FILTER(BQQ,MBQ),NAME=FILTER(BQQ)
  1.  .. ;I NAME="REG" S REG(VALUE)="",RGFL=1
  1.  .. I NAME="REG" S RGFL=1
  1.  .. S @NAME@(VALUE)=""
  1.  .. ;I NAME="CGRP" S CGRP(VALUE)=""
  1.  .. S SBQ=""
  1.  .. F  S SBQ=$O(FILTER(BQQ,MBQ,SBQ)) Q:SBQ=""  D
  1.  ... ;S NAME=FILTER(BQQ,MBQ,SBQ)
  1.  ... S MSBQ=""
  1.  ... F  S MSBQ=$O(FILTER(BQQ,MBQ,SBQ,MSBQ)) Q:MSBQ=""  D
  1.  .... S VALUE=FILTER(BQQ,MBQ,SBQ,MSBQ),NAME=FILTER(BQQ,MBQ,SBQ)
  1.  .... ;I NAME="CGRP" S CGRP(VALUE)="",CGFL=1
  1.  .... I NAME="CGRP" S CGFL=1
  1.  .... S @NAME@(VALUE)=""
  1.  ;
  1.  ; Get lab taxonomies
  1.  S TREF=$NA(^TMP("BQITAX",UID))
  1.  K @TREF
  1.  S REG=""
  1.  F  S REG=$O(REG(REG)) Q:REG=""  D
  1.  . S REGIEN=$$FIND1^DIC(90507,,"MX",REG)
  1.  . S TN=0
  1.  . F  S TN=$O(^BQI(90507,REGIEN,10,TN)) Q:'TN  D
  1.  .. I $P(^BQI(90507,REGIEN,10,TN,0),U,5)'="T" Q
  1.  .. S RGRP=$P(^BQI(90507,REGIEN,10,TN,0),U,7)
  1.  .. I CGFL,RGRP'="",'$D(CGRP(RGRP)) Q
  1.  .. S TAX=$P(^BQI(90507,REGIEN,10,TN,0),U,1)
  1.  .. I $P(^BQI(90507,REGIEN,10,TN,0),U,2)["ATXLAB" D BLD^BQITUTL(TAX,TREF,"L")
  1.  .. I $P(^BQI(90507,REGIEN,10,TN,0),U,2)["ATXAX" D BLD^BQITUTL(TAX,TREF)
  1.  ;
  1.  D HDR
  1.  S DRANGE=$$DATE^BQIUL1($G(DRANGE))
  1.  S LABIEN=""
  1.  F  S LABIEN=$O(^AUPNVLAB("AC",DFN,LABIEN),-1) Q:LABIEN=""  D
  1.  . D LAB(LABIEN)
  1.  . I $G(VISIT)="" Q
  1.  . S RLABDT=$$GET1^DIQ(9000010,VISIT,.01,"I") I RLABDT=0 Q
  1.  . S DATE=$$FMTE^BQIUL1(RLABDT)
  1.  . I DRANGE'="",(RLABDT\1)<DRANGE Q
  1.  . S BQII=BQII+1,@DATA@(BQII)=VISIT_"^"_LABIEN_"^"_DATE_"^"_TEST_"^"_RSLT_"^"_UNIT_"^"_RANGE_"^"_NRMABN_"^"
  1.  . S @DATA@(BQII)=@DATA@(BQII)_ORPHY_"^"_PAR_"^"_$S(PNL=1:"Y",1:"N")_"^"_SPNLNM_"^"_PNLNM_$C(30)
  1.  ;
  1.  ; Check for refusals
  1.  D REF
  1.  ;
  1. DONE ;
  1.  S BQII=BQII+1,@DATA@(BQII)=$C(31)
  1.  Q
  1.  ;
  1. HDR ;
  1.  S @DATA@(BQII)="I00010VISIT_IEN^I00010LAB_IEN^D00030LAB_DATE^T00050LAB_TEST^T00030LAB_RSLT^T00015LAB_UNIT^T00020LAB_RANGE^T00010LAB_NRMABN^"
  1.  S @DATA@(BQII)=@DATA@(BQII)_"T00035LAB_ORD_PHYS^I00010PARENT_IEN^T00001PANEL_FLAG^T00050SUB_PANEL_NAME^T00050PAR_PANEL_NAME"_$C(30)
  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(BQII),$D(DATA) S BQII=BQII+1,@DATA@(BQII)=$C(31)
  1.  Q
  1.  ;
  1. LAB(LABIEN) ;EP - Get data for a specific lab
  1.  S TEST=$$GET1^DIQ(9000010.09,LABIEN,".01","E") I TEST="" Q
  1.  S TST=$$GET1^DIQ(9000010.09,LABIEN,".01","I")
  1.  ;
  1.  I $G(RGFL),'$D(@TREF@(TST)) S VISIT="" Q
  1.  ;I TST="" Q
  1.  S RSLT=$$GET1^DIQ(9000010.09,LABIEN,".04","E")
  1.  S ORPHY=$$GET1^DIQ(9000010.09,LABIEN,1202,"E")
  1.  S UNIT=$$GET1^DIQ(9000010.09,LABIEN,"1101","E")
  1.  S REFLOW=$$GET1^DIQ(9000010.09,LABIEN,"1104","E")
  1.  S REFHIGH=$$GET1^DIQ(9000010.09,LABIEN,"1105","E")
  1.  S RANGE=REFLOW_"-"_REFHIGH
  1.  I RANGE="-" S RANGE=""
  1.  S NRMABN=$$GET1^DIQ(9000010.09,LABIEN,".05","I")
  1.  S VISIT=$$GET1^DIQ(9000010.09,LABIEN,".03","I")
  1.  S PNL=0,SPNLNM="",PNLNM=""
  1.  I LABIEN=VISIT Q
  1.  I $O(^LAB(60,TST,2,0))'="" S PNL=1,SPNLNM=$P($G(^LAB(60,TST,0)),U,1)
  1.  S PAR=$$GET1^DIQ(9000010.09,LABIEN,1208,"I")
  1.  ;
  1.  I PAR'="" D
  1.  . NEW TST,NPAR
  1.  . S TST=$$GET1^DIQ(9000010.09,PAR,".01","I")
  1.  . I TST="" Q
  1.  . I TST'="" S PNLNM=$P($G(^LAB(60,TST,0)),U,1)
  1.  . I $O(^LAB(60,TST,2,0))="" Q
  1.  . S NPAR=$$GET1^DIQ(9000010.09,PAR,1208,"I")
  1.  . I NPAR'="" D
  1.  .. NEW TST
  1.  .. S TST=$$GET1^DIQ(9000010.09,NPAR,".01","I")
  1.  .. S SPNLNM=PNLNM
  1.  .. I TST="" Q
  1.  .. I TST'="" S PNLNM=$P($G(^LAB(60,TST,0)),U,1)
  1.  I 'PNL,PAR'="",SPNLNM="" S SPNLNM=PNLNM,PNLNM=""
  1.  I PNL S TEST=""
  1.  I PNL,PAR="" D
  1.  . NEW PTS,LTS,SBFL
  1.  . S PTS=0,SBFL=0
  1.  . F  S PTS=$O(^LAB(60,TST,2,PTS)) Q:'PTS  D
  1.  .. S LTS=$P(^LAB(60,TST,2,PTS,0),U,1)
  1.  .. I $O(^LAB(60,LTS,2,0))'="" D
  1.  ... NEW N
  1.  ... S N=""
  1.  ... F  S N=$O(^AUPNVLAB("AD",VISIT,N)) Q:N=""  D
  1.  .... I $P(^AUPNVLAB(N,0),U,1)=LTS S SBFL=1
  1.  . I SBFL S PNLNM=SPNLNM,SPNLNM=""
  1.  Q
  1.  ;
  1. REF ; Find refusals
  1.  NEW TST,RVDT,REVDT,RFIEN
  1.  S TST=""
  1.  F  S TST=$O(^AUPNPREF("AA",DFN,60,TST)) Q:TST=""  D
  1.  . S RVDT=""
  1.  . F  S RVDT=$O(^AUPNPREF("AA",DFN,60,TST,RVDT)) Q:RVDT=""  D
  1.  .. ; Reverse the reverse date
  1.  .. S REVDT=9999999-RVDT
  1.  .. I DRANGE'="",(REVDT\1)<DRANGE Q
  1.  .. S RFIEN=""
  1.  .. F  S RFIEN=$O(^AUPNPREF("AA",DFN,60,TST,RVDT,RFIEN)) Q:RFIEN=""  D
  1.  ... S RSLT=$$GET1^DIQ(9000022,RFIEN_",",.07,"E")
  1.  ... S ORPHY=$$GET1^DIQ(9000022,RFIEN_",",1204,"E")
  1.  ... S LABIEN=TST
  1.  ... S DATE=$$FMTE^BQIUL1(REVDT)
  1.  ... S VISIT="",PAR="",PNL="",UNIT="",RANGE="",NRMABN="",SPNLNM="",PNLNM=""
  1.  ... S BQII=BQII+1,@DATA@(BQII)=VISIT_"^"_LABIEN_"^"_DATE_"^"_TEST_"^"_RSLT_"^"_UNIT_"^"_RANGE_"^"_NRMABN_"^"
  1.  ... S @DATA@(BQII)=@DATA@(BQII)_ORPHY_"^"_PAR_"^"_$S(PNL=1:"Y",1:"N")_"^"_SPNLNM_"^"_PNLNM_$C(30)
  1.  Q