BQIRMD ;PRXM/HC/DLS - Patient Medications ; 18 Jan 2006 11:56 AM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
Q
;
EN(DATA,DFN,DRANGE,PARMS) ; EP -- BQI PATIENT MEDICATIONS
;Description
; Generates a Medication Report for a given DFN and Relative Date.
;
;Input
; DFN - Patient Internal ID
; DRANGE - Date to pull Patient Meds from (to the present).
; PARMS - Parameters for special filtering
;
;Output
; DATA - Name of global in which data is stored(^TMP("BQIRMD"))
;
NEW UID,X,BQII,REG,PDATA,RGRP,VAL,VALUE,FILTER,FDATA,CGRP,ASDATA,BQ
NEW RMEDDT,MEDDT,MEDIEN,MEDTYPE,VSDTM,VISIT,ASN,ASNAME,ASSOC,ASVAL,BQQ
NEW MED,INST,QTY,DAYS,RDRANGE,ORPHY,MEDI,REGIEN,TREF,TN,TAX,NAME,CGFL,RGFL
NEW ASV,BN,II
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRMD",UID))
K @DATA
;
S BQII=0
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRMD D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S PARMS=$G(PARMS,"")
I PARMS="" D
. S LIST="",BN=""
. F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
. K PARMS
. S PARMS=LIST
. K LIST
;
F BQ=1:1:$L(PARMS,$C(28)) S FILTER(BQ)=$P(PARMS,$C(28),BQ)
F BQQ=1:1:BQ D
. S PDATA=$G(FILTER(BQQ)) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. S FDATA(BQQ)=NAME
. F II=1:1:$L(VALUE,$C(29)) D
.. S VAL=$P(VALUE,$C(29),II),ASSOC=$P(VAL,$C(25),2,99)
.. S FILTER(BQQ,II)=$P(VAL,$C(25),1)
.. I ASSOC'="" D
... F ASN=1:1:$L(ASSOC,$C(25)) D
.... S ASDATA=$P(ASSOC,$C(25),ASN)
.... S ASVAL=$P(ASDATA,"=",2),ASNAME=$P(ASDATA,"=",1)
.... S FILTER(BQQ,II,ASN)=ASNAME
.... I ASVAL'[$C(24) S FILTER(BQQ,II,ASN,1)=ASVAL Q
.... F ASV=1:1:$L(ASVAL,$C(24)) S FILTER(BQQ,II,ASN,ASV)=$P(ASVAL,$C(24),ASV)
.. I ASSOC="" S FILTER(BQQ,II)=VAL
I $D(FDATA) F BQQ=1:1:BQ S FILTER(BQQ)=FDATA(BQQ)
K FDATA,PARMS
;
NEW BQQ,MBQ,NAME,VALUE,SBQ,MSBQ
K REG,CGRP
S BQQ="",CGFL=0,RGFL=0
F S BQQ=$O(FILTER(BQQ)) Q:BQQ="" D
. ;S NAME=FILTER(BQQ)
. S MBQ=""
. F S MBQ=$O(FILTER(BQQ,MBQ)) Q:MBQ="" D
.. S VALUE=FILTER(BQQ,MBQ),NAME=FILTER(BQQ)
.. ;I NAME="REG" S REG(VALUE)="",RGFL=1
.. I NAME="REG" S RGFL=1
.. S @NAME@(VALUE)=""
.. ;I NAME="CGRP" S CGRP(VALUE)=""
.. S SBQ=""
.. F S SBQ=$O(FILTER(BQQ,MBQ,SBQ)) Q:SBQ="" D
... ;S NAME=FILTER(BQQ,MBQ,SBQ)
... S MSBQ=""
... F S MSBQ=$O(FILTER(BQQ,MBQ,SBQ,MSBQ)) Q:MSBQ="" D
.... S VALUE=FILTER(BQQ,MBQ,SBQ,MSBQ),NAME=FILTER(BQQ,MBQ,SBQ)
.... ;I NAME="CGRP" S CGRP(VALUE)="",CGFL=1
.... I NAME="CGRP" S CGFL=1
.... S @NAME@(VALUE)=""
;
; Get med taxonomies
S TREF=$NA(^TMP("BQITAX",UID))
K @TREF
S REG=""
F S REG=$O(REG(REG)) Q:REG="" D
. S REGIEN=$$FIND1^DIC(90507,,"MX",REG)
. S TN=0
. F S TN=$O(^BQI(90507,REGIEN,10,TN)) Q:'TN D
.. I $P(^BQI(90507,REGIEN,10,TN,0),U,5)'="M" Q
.. S RGRP=$P(^BQI(90507,REGIEN,10,TN,0),U,7)
.. I CGFL,RGRP'="",'$D(CGRP(RGRP)) Q
.. S TAX=$P(^BQI(90507,REGIEN,10,TN,0),U,1)
.. D BLD^BQITUTL(TAX,TREF)
;
D HDR
S DRANGE=$$DATE^BQIUL1($G(DRANGE))
S RDRANGE=9999999-DRANGE
S MEDDT=""
F S MEDDT=$O(^AUPNVMED("AA",DFN,MEDDT)) Q:MEDDT=""!(MEDDT>RDRANGE) D
. S MEDIEN=0
. F S MEDIEN=$O(^AUPNVMED("AA",DFN,MEDDT,MEDIEN)) Q:MEDIEN="" D
. . S RMEDDT=9999999-MEDDT
. . S VSDTM=$$FMTE^BQIUL1(RMEDDT)
. . S MED=$$GET1^DIQ(9000010.14,MEDIEN,.01,"E") I MED="" Q
. . S MEDI=$$GET1^DIQ(9000010.14,MEDIEN,.01,"I")
. . ;I REG'="",'$D(@TREF@(MEDI)) Q
. . I RGFL,'$D(@TREF@(MEDI)) Q
. . S VISIT=$$GET1^DIQ(9000010.14,MEDIEN,.03,"I") I VISIT="" Q
. . S INST=$$GET1^DIQ(9000010.14,MEDIEN,.05,"E")
. . S QTY=$$GET1^DIQ(9000010.14,MEDIEN,.06,"E") S:QTY="" QTY="-1"
. . S DAYS=$$GET1^DIQ(9000010.14,MEDIEN,.07,"E")
. . S ORPHY=$$GET1^DIQ(9000010.14,MEDIEN,1202,"E")
. . S BQII=BQII+1
. . S @DATA@(BQII)=VISIT_U_VSDTM_U_MED_U_INST_U_QTY_U_DAYS_U_ORPHY_$C(30)
;
; Check for refusals
D REF
;
DONE ; -- exit code
S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
;
HDR ;
S @DATA@(BQII)="I00010VISIT_IEN^D00030VISIT_DATETIME^T00099MED_NAME^T00200MED_INSTR^N00010MED_QTY^I00010MED_DAYS^T00035ORD_PHY"_$C(30)
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(BQII),$D(DATA) S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
;
REF ; Check for refusals
NEW MEDN,RVDT,REVDT,RFIEN,MED,INST,ORPHY,QTY,DAYS,VISIT
S MEDN=""
F S MEDN=$O(^AUPNPREF("AA",DFN,50,MEDN)) Q:MEDN="" D
. S RVDT=""
. F S RVDT=$O(^AUPNPREF("AA",DFN,50,MEDN,RVDT)) Q:RVDT="" D
.. ; Reverse the reverse date
.. S REVDT=9999999-RVDT
.. I DRANGE'="",(REVDT\1)<DRANGE Q
.. S RFIEN=""
.. F S RFIEN=$O(^AUPNPREF("AA",DFN,50,MEDN,RVDT,RFIEN)) Q:RFIEN="" D
... S MED=$$GET1^DIQ(50,MEDN_",",.01,"E")
... S INST=$$GET1^DIQ(9000022,RFIEN_",",.07,"E")
... S ORPHY=$$GET1^DIQ(9000022,RFIEN_",",1204,"E")
... S QTY=-1,DAYS="",VISIT=""
... S BQII=BQII+1,@DATA@(BQII)=VISIT_U_$$FMTE^BQIUL1(REVDT)_U_MED_U_INST_U_QTY_U_DAYS_U_ORPHY_$C(30)
Q
BQIRMD ;PRXM/HC/DLS - Patient Medications ; 18 Jan 2006 11:56 AM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
+3 QUIT
+4 ;
EN(DATA,DFN,DRANGE,PARMS) ; EP -- BQI PATIENT MEDICATIONS
+1 ;Description
+2 ; Generates a Medication Report for a given DFN and Relative Date.
+3 ;
+4 ;Input
+5 ; DFN - Patient Internal ID
+6 ; DRANGE - Date to pull Patient Meds from (to the present).
+7 ; PARMS - Parameters for special filtering
+8 ;
+9 ;Output
+10 ; DATA - Name of global in which data is stored(^TMP("BQIRMD"))
+11 ;
+12 NEW UID,X,BQII,REG,PDATA,RGRP,VAL,VALUE,FILTER,FDATA,CGRP,ASDATA,BQ
+13 NEW RMEDDT,MEDDT,MEDIEN,MEDTYPE,VSDTM,VISIT,ASN,ASNAME,ASSOC,ASVAL,BQQ
+14 NEW MED,INST,QTY,DAYS,RDRANGE,ORPHY,MEDI,REGIEN,TREF,TN,TAX,NAME,CGFL,RGFL
+15 NEW ASV,BN,II
+16 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+17 SET DATA=$NAME(^TMP("BQIRMD",UID))
+18 KILL @DATA
+19 ;
+20 SET BQII=0
+21 ;
+22 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRMD D UNWIND^%ZTER"
+23 ;
+24 SET PARMS=$GET(PARMS,"")
+25 IF PARMS=""
Begin DoDot:1
+26 SET LIST=""
SET BN=""
+27 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+28 KILL PARMS
+29 SET PARMS=LIST
+30 KILL LIST
End DoDot:1
+31 ;
+32 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
SET FILTER(BQ)=$PIECE(PARMS,$CHAR(28),BQ)
+33 FOR BQQ=1:1:BQ
Begin DoDot:1
+34 SET PDATA=$GET(FILTER(BQQ))
IF PDATA=""
QUIT
+35 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+36 SET FDATA(BQQ)=NAME
+37 FOR II=1:1:$LENGTH(VALUE,$CHAR(29))
Begin DoDot:2
+38 SET VAL=$PIECE(VALUE,$CHAR(29),II)
SET ASSOC=$PIECE(VAL,$CHAR(25),2,99)
+39 SET FILTER(BQQ,II)=$PIECE(VAL,$CHAR(25),1)
+40 IF ASSOC'=""
Begin DoDot:3
+41 FOR ASN=1:1:$LENGTH(ASSOC,$CHAR(25))
Begin DoDot:4
+42 SET ASDATA=$PIECE(ASSOC,$CHAR(25),ASN)
+43 SET ASVAL=$PIECE(ASDATA,"=",2)
SET ASNAME=$PIECE(ASDATA,"=",1)
+44 SET FILTER(BQQ,II,ASN)=ASNAME
+45 IF ASVAL'[$CHAR(24)
SET FILTER(BQQ,II,ASN,1)=ASVAL
QUIT
+46 FOR ASV=1:1:$LENGTH(ASVAL,$CHAR(24))
SET FILTER(BQQ,II,ASN,ASV)=$PIECE(ASVAL,$CHAR(24),ASV)
End DoDot:4
End DoDot:3
+47 IF ASSOC=""
SET FILTER(BQQ,II)=VAL
End DoDot:2
End DoDot:1
+48 IF $DATA(FDATA)
FOR BQQ=1:1:BQ
SET FILTER(BQQ)=FDATA(BQQ)
+49 KILL FDATA,PARMS
+50 ;
+51 NEW BQQ,MBQ,NAME,VALUE,SBQ,MSBQ
+52 KILL REG,CGRP
+53 SET BQQ=""
SET CGFL=0
SET RGFL=0
+54 FOR
SET BQQ=$ORDER(FILTER(BQQ))
IF BQQ=""
QUIT
Begin DoDot:1
+55 ;S NAME=FILTER(BQQ)
+56 SET MBQ=""
+57 FOR
SET MBQ=$ORDER(FILTER(BQQ,MBQ))
IF MBQ=""
QUIT
Begin DoDot:2
+58 SET VALUE=FILTER(BQQ,MBQ)
SET NAME=FILTER(BQQ)
+59 ;I NAME="REG" S REG(VALUE)="",RGFL=1
+60 IF NAME="REG"
SET RGFL=1
+61 SET @NAME@(VALUE)=""
+62 ;I NAME="CGRP" S CGRP(VALUE)=""
+63 SET SBQ=""
+64 FOR
SET SBQ=$ORDER(FILTER(BQQ,MBQ,SBQ))
IF SBQ=""
QUIT
Begin DoDot:3
+65 ;S NAME=FILTER(BQQ,MBQ,SBQ)
+66 SET MSBQ=""
+67 FOR
SET MSBQ=$ORDER(FILTER(BQQ,MBQ,SBQ,MSBQ))
IF MSBQ=""
QUIT
Begin DoDot:4
+68 SET VALUE=FILTER(BQQ,MBQ,SBQ,MSBQ)
SET NAME=FILTER(BQQ,MBQ,SBQ)
+69 ;I NAME="CGRP" S CGRP(VALUE)="",CGFL=1
+70 IF NAME="CGRP"
SET CGFL=1
+71 SET @NAME@(VALUE)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+72 ;
+73 ; Get med taxonomies
+74 SET TREF=$NAME(^TMP("BQITAX",UID))
+75 KILL @TREF
+76 SET REG=""
+77 FOR
SET REG=$ORDER(REG(REG))
IF REG=""
QUIT
Begin DoDot:1
+78 SET REGIEN=$$FIND1^DIC(90507,,"MX",REG)
+79 SET TN=0
+80 FOR
SET TN=$ORDER(^BQI(90507,REGIEN,10,TN))
IF 'TN
QUIT
Begin DoDot:2
+81 IF $PIECE(^BQI(90507,REGIEN,10,TN,0),U,5)'="M"
QUIT
+82 SET RGRP=$PIECE(^BQI(90507,REGIEN,10,TN,0),U,7)
+83 IF CGFL
IF RGRP'=""
IF '$DATA(CGRP(RGRP))
QUIT
+84 SET TAX=$PIECE(^BQI(90507,REGIEN,10,TN,0),U,1)
+85 DO BLD^BQITUTL(TAX,TREF)
End DoDot:2
End DoDot:1
+86 ;
+87 DO HDR
+88 SET DRANGE=$$DATE^BQIUL1($GET(DRANGE))
+89 SET RDRANGE=9999999-DRANGE
+90 SET MEDDT=""
+91 FOR
SET MEDDT=$ORDER(^AUPNVMED("AA",DFN,MEDDT))
IF MEDDT=""!(MEDDT>RDRANGE)
QUIT
Begin DoDot:1
+92 SET MEDIEN=0
+93 FOR
SET MEDIEN=$ORDER(^AUPNVMED("AA",DFN,MEDDT,MEDIEN))
IF MEDIEN=""
QUIT
Begin DoDot:2
+94 SET RMEDDT=9999999-MEDDT
+95 SET VSDTM=$$FMTE^BQIUL1(RMEDDT)
+96 SET MED=$$GET1^DIQ(9000010.14,MEDIEN,.01,"E")
IF MED=""
QUIT
+97 SET MEDI=$$GET1^DIQ(9000010.14,MEDIEN,.01,"I")
+98 ;I REG'="",'$D(@TREF@(MEDI)) Q
+99 IF RGFL
IF '$DATA(@TREF@(MEDI))
QUIT
+100 SET VISIT=$$GET1^DIQ(9000010.14,MEDIEN,.03,"I")
IF VISIT=""
QUIT
+101 SET INST=$$GET1^DIQ(9000010.14,MEDIEN,.05,"E")
+102 SET QTY=$$GET1^DIQ(9000010.14,MEDIEN,.06,"E")
IF QTY=""
SET QTY="-1"
+103 SET DAYS=$$GET1^DIQ(9000010.14,MEDIEN,.07,"E")
+104 SET ORPHY=$$GET1^DIQ(9000010.14,MEDIEN,1202,"E")
+105 SET BQII=BQII+1
+106 SET @DATA@(BQII)=VISIT_U_VSDTM_U_MED_U_INST_U_QTY_U_DAYS_U_ORPHY_$CHAR(30)
End DoDot:2
End DoDot:1
+107 ;
+108 ; Check for refusals
+109 DO REF
+110 ;
DONE ; -- exit code
+1 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+2 QUIT
+3 ;
HDR ;
+1 SET @DATA@(BQII)="I00010VISIT_IEN^D00030VISIT_DATETIME^T00099MED_NAME^T00200MED_INSTR^N00010MED_QTY^I00010MED_DAYS^T00035ORD_PHY"_$CHAR(30)
+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(BQII)
IF $DATA(DATA)
SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+6 QUIT
+7 ;
REF ; Check for refusals
+1 NEW MEDN,RVDT,REVDT,RFIEN,MED,INST,ORPHY,QTY,DAYS,VISIT
+2 SET MEDN=""
+3 FOR
SET MEDN=$ORDER(^AUPNPREF("AA",DFN,50,MEDN))
IF MEDN=""
QUIT
Begin DoDot:1
+4 SET RVDT=""
+5 FOR
SET RVDT=$ORDER(^AUPNPREF("AA",DFN,50,MEDN,RVDT))
IF RVDT=""
QUIT
Begin DoDot:2
+6 ; Reverse the reverse date
+7 SET REVDT=9999999-RVDT
+8 IF DRANGE'=""
IF (REVDT\1)<DRANGE
QUIT
+9 SET RFIEN=""
+10 FOR
SET RFIEN=$ORDER(^AUPNPREF("AA",DFN,50,MEDN,RVDT,RFIEN))
IF RFIEN=""
QUIT
Begin DoDot:3
+11 SET MED=$$GET1^DIQ(50,MEDN_",",.01,"E")
+12 SET INST=$$GET1^DIQ(9000022,RFIEN_",",.07,"E")
+13 SET ORPHY=$$GET1^DIQ(9000022,RFIEN_",",1204,"E")
+14 SET QTY=-1
SET DAYS=""
SET VISIT=""
+15 SET BQII=BQII+1
SET @DATA@(BQII)=VISIT_U_$$FMTE^BQIUL1(REVDT)_U_MED_U_INST_U_QTY_U_DAYS_U_ORPHY_$CHAR(30)
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
