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

BQIRMD.m

Go to the documentation of this file. 
  1. BQIRMD ;PRXM/HC/DLS - Patient Medications ; 18 Jan 2006  11:56 AM
  1.  ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
  1.  ;
  1.  Q
  1.  ;
  1. EN(DATA,DFN,DRANGE,PARMS) ; EP -- BQI PATIENT MEDICATIONS
  1.  ;Description
  1.  ;  Generates a Medication Report for a given DFN and Relative Date.
  1.  ;
  1.  ;Input
  1.  ;  DFN    - Patient Internal ID
  1.  ;  DRANGE - Date to pull Patient Meds from (to the present).
  1.  ;  PARMS  - Parameters for special filtering
  1.  ;  
  1.  ;Output
  1.  ;  DATA - Name of global in which data is stored(^TMP("BQIRMD"))
  1.  ;  
  1.  NEW UID,X,BQII,REG,PDATA,RGRP,VAL,VALUE,FILTER,FDATA,CGRP,ASDATA,BQ
  1.  NEW RMEDDT,MEDDT,MEDIEN,MEDTYPE,VSDTM,VISIT,ASN,ASNAME,ASSOC,ASVAL,BQQ
  1.  NEW MED,INST,QTY,DAYS,RDRANGE,ORPHY,MEDI,REGIEN,TREF,TN,TAX,NAME,CGFL,RGFL
  1.  NEW ASV,BN,II
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIRMD",UID))
  1.  K @DATA
  1.  ;
  1.  S BQII=0
  1.  ;
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRMD 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 med 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)'="M" 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.  .. D BLD^BQITUTL(TAX,TREF)
  1.  ;
  1.  D HDR
  1.  S DRANGE=$$DATE^BQIUL1($G(DRANGE))
  1.  S RDRANGE=9999999-DRANGE
  1.  S MEDDT=""
  1.  F  S MEDDT=$O(^AUPNVMED("AA",DFN,MEDDT)) Q:MEDDT=""!(MEDDT>RDRANGE)  D
  1.  . S MEDIEN=0
  1.  . F  S MEDIEN=$O(^AUPNVMED("AA",DFN,MEDDT,MEDIEN)) Q:MEDIEN=""  D
  1.  . . S RMEDDT=9999999-MEDDT
  1.  . . S VSDTM=$$FMTE^BQIUL1(RMEDDT)
  1.  . . S MED=$$GET1^DIQ(9000010.14,MEDIEN,.01,"E") I MED="" Q
  1.  . . S MEDI=$$GET1^DIQ(9000010.14,MEDIEN,.01,"I")
  1.  . . ;I REG'="",'$D(@TREF@(MEDI)) Q
  1.  . . I RGFL,'$D(@TREF@(MEDI)) Q
  1.  . . S VISIT=$$GET1^DIQ(9000010.14,MEDIEN,.03,"I") I VISIT="" Q
  1.  . . S INST=$$GET1^DIQ(9000010.14,MEDIEN,.05,"E")
  1.  . . S QTY=$$GET1^DIQ(9000010.14,MEDIEN,.06,"E") S:QTY="" QTY="-1"
  1.  . . S DAYS=$$GET1^DIQ(9000010.14,MEDIEN,.07,"E")
  1.  . . S ORPHY=$$GET1^DIQ(9000010.14,MEDIEN,1202,"E")
  1.  . . S BQII=BQII+1
  1.  . . S @DATA@(BQII)=VISIT_U_VSDTM_U_MED_U_INST_U_QTY_U_DAYS_U_ORPHY_$C(30)
  1.  ;
  1.  ; Check for refusals
  1.  D REF
  1.  ;
  1. DONE ; -- exit code
  1.  S BQII=BQII+1,@DATA@(BQII)=$C(31)
  1.  Q
  1.  ;
  1. HDR ;
  1.  S @DATA@(BQII)="I00010VISIT_IEN^D00030VISIT_DATETIME^T00099MED_NAME^T00200MED_INSTR^N00010MED_QTY^I00010MED_DAYS^T00035ORD_PHY"_$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. REF ; Check for refusals
  1.  NEW MEDN,RVDT,REVDT,RFIEN,MED,INST,ORPHY,QTY,DAYS,VISIT
  1.  S MEDN=""
  1.  F  S MEDN=$O(^AUPNPREF("AA",DFN,50,MEDN)) Q:MEDN=""  D
  1.  . S RVDT=""
  1.  . F  S RVDT=$O(^AUPNPREF("AA",DFN,50,MEDN,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,50,MEDN,RVDT,RFIEN)) Q:RFIEN=""  D
  1.  ... S MED=$$GET1^DIQ(50,MEDN_",",.01,"E")
  1.  ... S INST=$$GET1^DIQ(9000022,RFIEN_",",.07,"E")
  1.  ... S ORPHY=$$GET1^DIQ(9000022,RFIEN_",",1204,"E")
  1.  ... S QTY=-1,DAYS="",VISIT=""
  1.  ... S BQII=BQII+1,@DATA@(BQII)=VISIT_U_$$FMTE^BQIUL1(REVDT)_U_MED_U_INST_U_QTY_U_DAYS_U_ORPHY_$C(30)
  1.  Q