BQIRMAGG ;PRXM/HC/ALA-Reminders Aggregate ; 16 Mar 2007 4:11 PM
;;2.2;ICARE MANAGEMENT SYSTEM;;Jul 28, 2011;Build 37
;
Q
;
EN(DATA,OWNR,PLIEN) ;EP -- BQI GET REMINDERS AGGREGATE
;Description - Entry point for the panel
NEW UID,II,DFN,AGGREG,REM,PRCUR,PROVR,RCAT,RCLIN,REMNM,RMCODE,NREMNM
NEW RIEN,GRDT
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRMAGG",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRMAGG D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="I00010MEAS_IEN^T00030CATEGORY^T00030CLIN_GROUP^T00050REMINDER^T00015CODE^I00010PATS_ELIGIBLE^I00010PAT_CURRENT^N00010PER_CURRENT^I00010PAT_OVERDUE^N00010PER_OVERDUE"_$C(30)
S DFN=0,GRDT=$$DATE^BQIUL1("T-30")
F S DFN=$O(^BQICARE(OWNR,1,PLIEN,40,DFN)) Q:'DFN D RPT
;
S REMNM=""
F S REMNM=$O(AGGREG(REMNM)) Q:REMNM="" D
. S RMCODE=""
. F S RMCODE=$O(AGGREG(REMNM,RMCODE)) Q:RMCODE="" D
.. ;S PRCUR=$J(($P(AGGREG(REMNM,RMCODE),U,2)/$P(AGGREG(REMNM,RMCODE),U,1))*100,3,1)_"%"
.. S PRCUR=$J(($P(AGGREG(REMNM,RMCODE),U,2)/$P(AGGREG(REMNM,RMCODE),U,1))*100,3,1)
.. ;S PROVR=$J(($P(AGGREG(REMNM,RMCODE),U,3)/$P(AGGREG(REMNM,RMCODE),U,1))*100,3,1)_"%"
.. S PROVR=$J(($P(AGGREG(REMNM,RMCODE),U,3)/$P(AGGREG(REMNM,RMCODE),U,1))*100,3,1)
.. S RIEN=$$FIND1^DIC(90506.1,"","X",RMCODE,"B","","ERROR")
.. ;S RCAT=$$GET1^DIQ(90506.1,RIEN_",",2.03,"E")
.. ;S RCLIN=$$GET1^DIQ(90506.1,RIEN_",",2.05,"E")
.. S RCAT=$$GET1^DIQ(90506.1,RIEN_",",3.03,"E")
.. S RCLIN=$$GET1^DIQ(90506.1,RIEN_",",3.02,"E")
.. I REMNM'?.U S NREMNM=REMNM
.. I REMNM?.UP S NREMNM=$$LOWER^VALM1(REMNM)
.. I NREMNM="Breast Mri" S NREMNM="Breast MRI"
.. S II=II+1,@DATA@(II)=RIEN_U_RCAT_U_RCLIN_U_NREMNM_U_RMCODE_U_$P(AGGREG(REMNM,RMCODE),U,1)_U_$P(AGGREG(REMNM,RMCODE),U,2)_U_PRCUR_U_$P(AGGREG(REMNM,RMCODE),U,3)_U_PROVR_$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
;
RPT ;
; If patient is 'removed', don't include
I $P($G(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",2)="R" Q
;
NEW RDATA,RIEN,DUE,LAST,CT,PELIG,PCUR,POVR,REM,REMNM,RMCODE,DIEN
S RIEN=0
F S RIEN=$O(^BQIPAT(DFN,40,RIEN)) Q:'RIEN D
. S RDATA=^BQIPAT(DFN,40,RIEN,0)
. S CT=0,PELIG=0,PCUR=0,POVR=0
. S RMCODE=$P(RDATA,U,1)
. S DIEN=$O(^BQI(90506.1,"B",RMCODE,"")) Q:DIEN=""
. ; If it's inactive reminder, quit
. I $P(^BQI(90506.1,DIEN,0),U,10)=1 Q
. ; If it's a register reminder, quit
. ;I $$GET1^DIQ(90506.1,DIEN_",",2.03,"E")="CARE MANAGEMENT" Q
. I $$GET1^DIQ(90506.1,DIEN_",",3.03,"E")="CARE MANAGEMENT" Q
. S REMNM=$P(^BQI(90506.1,DIEN,0),U,3)
. ; NDA patients have no data so CT should be 0
. F I=2:1:4 S:$P(RDATA,U,I)'="" CT=CT+1
. I CT=0 Q
. ; EHR reminders return a N/A
. I $P(RDATA,U,3)="N/A" Q
. S PELIG=PELIG+1
. I CT'=0 D
.. S DUE=$P(RDATA,U,4),LAST=$P(RDATA,U,2)
.. I LAST="",DUE="" Q
.. ;I LAST'="",DUE'="" D
.. I DUE'="" D
... I DUE<GRDT S POVR=POVR+1 Q
... ;E S PCUR=PCUR+1
... I DUE>DT S PCUR=PCUR+1
.. ;I LAST'="",DUE="",LAST<GRDT S POVR=POVR+1
. S $P(AGGREG(REMNM,RMCODE),U,1)=$P($G(AGGREG(REMNM,RMCODE)),U,1)+PELIG
. S $P(AGGREG(REMNM,RMCODE),U,2)=$P($G(AGGREG(REMNM,RMCODE)),U,2)+PCUR
. S $P(AGGREG(REMNM,RMCODE),U,3)=$P($G(AGGREG(REMNM,RMCODE)),U,3)+POVR
Q
BQIRMAGG ;PRXM/HC/ALA-Reminders Aggregate ; 16 Mar 2007 4:11 PM
+1 ;;2.2;ICARE MANAGEMENT SYSTEM;;Jul 28, 2011;Build 37
+2 ;
+3 QUIT
+4 ;
EN(DATA,OWNR,PLIEN) ;EP -- BQI GET REMINDERS AGGREGATE
+1 ;Description - Entry point for the panel
+2 NEW UID,II,DFN,AGGREG,REM,PRCUR,PROVR,RCAT,RCLIN,REMNM,RMCODE,NREMNM
+3 NEW RIEN,GRDT
+4 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+5 SET DATA=$NAME(^TMP("BQIRMAGG",UID))
+6 KILL @DATA
+7 ;
+8 SET II=0
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRMAGG D UNWIND^%ZTER"
+10 ;
+11 SET @DATA@(II)="I00010MEAS_IEN^T00030CATEGORY^T00030CLIN_GROUP^T00050REMINDER^T00015CODE^I00010PATS_ELIGIBLE^I00010PAT_CURRENT^N00010PER_CURRENT^I00010PAT_OVERDUE^N00010PER_OVERDUE"_$CHAR(30)
+12 SET DFN=0
SET GRDT=$$DATE^BQIUL1("T-30")
+13 FOR
SET DFN=$ORDER(^BQICARE(OWNR,1,PLIEN,40,DFN))
IF 'DFN
QUIT
DO RPT
+14 ;
+15 SET REMNM=""
+16 FOR
SET REMNM=$ORDER(AGGREG(REMNM))
IF REMNM=""
QUIT
Begin DoDot:1
+17 SET RMCODE=""
+18 FOR
SET RMCODE=$ORDER(AGGREG(REMNM,RMCODE))
IF RMCODE=""
QUIT
Begin DoDot:2
+19 ;S PRCUR=$J(($P(AGGREG(REMNM,RMCODE),U,2)/$P(AGGREG(REMNM,RMCODE),U,1))*100,3,1)_"%"
+20 SET PRCUR=$JUSTIFY(($PIECE(AGGREG(REMNM,RMCODE),U,2)/$PIECE(AGGREG(REMNM,RMCODE),U,1))*100,3,1)
+21 ;S PROVR=$J(($P(AGGREG(REMNM,RMCODE),U,3)/$P(AGGREG(REMNM,RMCODE),U,1))*100,3,1)_"%"
+22 SET PROVR=$JUSTIFY(($PIECE(AGGREG(REMNM,RMCODE),U,3)/$PIECE(AGGREG(REMNM,RMCODE),U,1))*100,3,1)
+23 SET RIEN=$$FIND1^DIC(90506.1,"","X",RMCODE,"B","","ERROR")
+24 ;S RCAT=$$GET1^DIQ(90506.1,RIEN_",",2.03,"E")
+25 ;S RCLIN=$$GET1^DIQ(90506.1,RIEN_",",2.05,"E")
+26 SET RCAT=$$GET1^DIQ(90506.1,RIEN_",",3.03,"E")
+27 SET RCLIN=$$GET1^DIQ(90506.1,RIEN_",",3.02,"E")
+28 IF REMNM'?.U
SET NREMNM=REMNM
+29 IF REMNM?.UP
SET NREMNM=$$LOWER^VALM1(REMNM)
+30 IF NREMNM="Breast Mri"
SET NREMNM="Breast MRI"
+31 SET II=II+1
SET @DATA@(II)=RIEN_U_RCAT_U_RCLIN_U_NREMNM_U_RMCODE_U_$PIECE(AGGREG(REMNM,RMCODE),U,1)_U_$PIECE(AGGREG(REMNM,RMCODE),U,2)_U_PRCUR_U_$PIECE(AGGREG(REMNM,RMCODE),U,3)_U_PROVR_$CHAR(30)
End DoDot:2
End DoDot:1
+32 ;
DONE SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
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 ;
RPT ;
+1 ; If patient is 'removed', don't include
+2 IF $PIECE($GET(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",2)="R"
QUIT
+3 ;
+4 NEW RDATA,RIEN,DUE,LAST,CT,PELIG,PCUR,POVR,REM,REMNM,RMCODE,DIEN
+5 SET RIEN=0
+6 FOR
SET RIEN=$ORDER(^BQIPAT(DFN,40,RIEN))
IF 'RIEN
QUIT
Begin DoDot:1
+7 SET RDATA=^BQIPAT(DFN,40,RIEN,0)
+8 SET CT=0
SET PELIG=0
SET PCUR=0
SET POVR=0
+9 SET RMCODE=$PIECE(RDATA,U,1)
+10 SET DIEN=$ORDER(^BQI(90506.1,"B",RMCODE,""))
IF DIEN=""
QUIT
+11 ; If it's inactive reminder, quit
+12 IF $PIECE(^BQI(90506.1,DIEN,0),U,10)=1
QUIT
+13 ; If it's a register reminder, quit
+14 ;I $$GET1^DIQ(90506.1,DIEN_",",2.03,"E")="CARE MANAGEMENT" Q
+15 IF $$GET1^DIQ(90506.1,DIEN_",",3.03,"E")="CARE MANAGEMENT"
QUIT
+16 SET REMNM=$PIECE(^BQI(90506.1,DIEN,0),U,3)
+17 ; NDA patients have no data so CT should be 0
+18 FOR I=2:1:4
IF $PIECE(RDATA,U,I)'=""
SET CT=CT+1
+19 IF CT=0
QUIT
+20 ; EHR reminders return a N/A
+21 IF $PIECE(RDATA,U,3)="N/A"
QUIT
+22 SET PELIG=PELIG+1
+23 IF CT'=0
Begin DoDot:2
+24 SET DUE=$PIECE(RDATA,U,4)
SET LAST=$PIECE(RDATA,U,2)
+25 IF LAST=""
IF DUE=""
QUIT
+26 ;I LAST'="",DUE'="" D
+27 IF DUE'=""
Begin DoDot:3
+28 IF DUE<GRDT
SET POVR=POVR+1
QUIT
+29 ;E S PCUR=PCUR+1
+30 IF DUE>DT
SET PCUR=PCUR+1
End DoDot:3
+31 ;I LAST'="",DUE="",LAST<GRDT S POVR=POVR+1
End DoDot:2
+32 SET $PIECE(AGGREG(REMNM,RMCODE),U,1)=$PIECE($GET(AGGREG(REMNM,RMCODE)),U,1)+PELIG
+33 SET $PIECE(AGGREG(REMNM,RMCODE),U,2)=$PIECE($GET(AGGREG(REMNM,RMCODE)),U,2)+PCUR
+34 SET $PIECE(AGGREG(REMNM,RMCODE),U,3)=$PIECE($GET(AGGREG(REMNM,RMCODE)),U,3)+POVR
End DoDot:1
+35 QUIT
