BQIIPPNL ;GDIT/HS/ALA-Panel Aggregate ; 09 Sep 2011 12:17 PM
;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23
;
;
EN(DATA,OWNR,PLIEN,CRIPC,PLIST) ;EP - BQI GET IPC PROV AGG
;Description - Entry point for the panel
;Input Parameters
; OWNR - Owner of panel
; PLIEN - Panel IEN
; CRIPC = IPC Version
; PLIST - List of DFNs (optional)
NEW UID,II,TDATA,XX,BQIND,BQMEAS,CAT,CODE,DEC,DEN,DFN,IDATA,MET,MSIEN
NEW NDA,NO,NUM,PROV,PRV,TITLE,TOTP,TYP,VAL,VALUE,XX,YES,GOAL,TNDA,CAT2
NEW STAB,MSN,NA,TAB,BQIDOD,CNT,DCAT,EXEC,GP,I,ORD,QFL,TAG,CRN
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIIPPRV",UID)) K @DATA
S TDATA=$NA(^TMP("BQIPRVIP",UID)) K @TDATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIIPPRV D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
; get the current IPC definition
S CRIPC=$G(CRIPC,"")
I CRIPC="" S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
S @DATA@(II)="I00010TOTAL_PATIENTS^I00010TOTAL_NDA^T00030CATEGORY^T00030CAT2^T00060TITLE^T00030ID^"
S @DATA@(II)=@DATA@(II)_"I00010NUMERATOR^I00010DENOMINATOR^I00010DECEASED^T00005PERCENT_MET^T00005PERCENT_GOAL"_$C(30)
;
; If a list of DFNs, process them instead of entire panel
I $D(PLIST)>0 D G DONE
. I $D(PLIST)>1 D
.. S LIST="",BN=""
.. F S BN=$O(PLIST(BN)) Q:BN="" S LIST=LIST_PLIST(BN)
.. K PLIST S PLIST=LIST
. F BQI=1:1 S DFN=$P(PLIST,$C(28),BQI) Q:DFN="" D
.. I $P($G(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",2)="R" Q
.. D RPT(DFN)
;
S DFN=0
I $O(^BQICARE(OWNR,1,PLIEN,40,DFN))="" G DONE
;
F S DFN=$O(^BQICARE(OWNR,1,PLIEN,40,DFN)) Q:'DFN D
. I $P($G(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",2)="R" Q
. D RPT(DFN)
;
S TOTP=$G(@TDATA@("TOTP")),TNDA=0
S DFN="" F S DFN=$O(@TDATA@("NDA",DFN)) Q:DFN="" S TNDA=$G(TNDA)+1
S ORD=""
F S ORD=$O(@TDATA@(ORD)) Q:ORD="" D
. S MSN=$O(^BQI(90508,1,22,CRN,1,"C",ORD,"")) Q:MSN=""
. S IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
. I $P(IDATA,U,7)=1 Q
. NEW DA,IENS
. S DA(2)=1,DA(1)=CRN,DA=MSN,IENS=$$IENS^DILF(.DA)
. S CAT=$$GET1^DIQ(90508.221,IENS,.03,"E")
. S CAT2=$$GET1^DIQ(90508.221,IENS,.11,"E")
. I CRIPC="IPC4/IPC5" D
.. S CAT=$$GET1^DIQ(90508.221,IENS,.03,"E")
.. I CAT="" D
... S RIEN=$O(^BQI(90506.1,"B",CODE,""))
... S CAT=$$GET1^DIQ(90506.1,RIEN_",",3.02,"E")
.. S CAT2=$$GET1^DIQ(90508.221,IENS,.11,"E")
. I CRIPC="IPCMH" D
.. S CAT1=$$GET1^DIQ(90508.221,IENS,.03,"E")
.. S ICAT=$$GET1^DIQ(90508.221,IENS,.03,"I")
.. S CAT2=$$GET1^DIQ(90508.221,IENS,.11,"E")
.. I CAT2="" S CAT2=$$GET1^DIQ(90506.8,ICAT_",",.04,"E")
.. S CAT=CAT2,CAT2=CAT1
. S TAB=$$GET1^DIQ(90508.221,IENS,.13,"I")
. S STAB=$$GET1^DIQ(90508.221,IENS,.14,"I")
. I TAB="A" Q
. S CODE=$P(IDATA,U,1),TITLE=$P(IDATA,U,4),GOAL=$P(IDATA,U,12)
. S NUM=$G(@TDATA@(ORD,"NUM"))
. S DEN=$G(@TDATA@(ORD,"DEN"))
. S DEC=$G(@TDATA@(ORD,"DEC"))
. ;S NDA=$G(@TDATA@(ORD,"NDA"))
. ;I $P(IDATA,U,5)'="B" S DEN=DEN+NDA
. I $P(IDATA,U,5)'="B" S DEN=DEN
. I +DEN=0 S MET="0%"
. I +DEN'=0,+NUM=0 S MET="0%"
. I +NUM'=0 S MET=$J((NUM/DEN)*100,3,0),MET=$$TRIM^BQIUL1(MET," ")_"%"
. S DCAT=CAT
. I DCAT["_1" S DCAT=$P(CAT,"_1",1)
. I DCAT["_2" S DCAT=$P(CAT,"_2",1)
. S II=II+1,@DATA@(II)=TOTP_U_$G(TNDA)_U_DCAT_U_CAT2_U_TITLE_U_CODE_U_NUM_U_DEN_U_DEC_U_MET_U_GOAL_$C(30)
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
K @TDATA
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(DFN) ; Get the CRS Clinical Performance information
I '$$HRN^BQIUL1(DFN) Q
S PROV=$P($G(^AUPNPAT(DFN,0)),U,14)
S @TDATA@("TOTP")=$G(@TDATA@("TOTP"))+1
S ORD=""
F S ORD=$O(^BQI(90508,1,22,CRN,1,"C",ORD)) Q:ORD="" D
. S MSN=""
. F S MSN=$O(^BQI(90508,1,22,CRN,1,"C",ORD,MSN)) Q:MSN="" D
.. S IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
.. S CODE=$P(IDATA,U,1),TYP=$P(IDATA,U,2),TITLE=$P(IDATA,U,4)
.. ; If inactive, quit
.. I $P(IDATA,U,7)=1 Q
.. NEW DA,IENS
.. S DA(2)=1,DA(1)=CRN,DA=MSN,IENS=$$IENS^DILF(.DA)
.. S CAT=$$GET1^DIQ(90508.221,IENS,.03,"E")
.. S MSIEN=$O(^BQI(90506.1,"B",CODE,""))
.. I CAT="",MSIEN'="" S CAT=$$GET1^DIQ(90506.1,MSIEN_",",3.03,"E")
.. I CAT="" S CAT="~"
.. I $P(IDATA,U,5)'="B" S CAT=CAT_"_2"
.. S BQIDOD=$$GET1^DIQ(2,DFN_",",.351,"I")
.. I $G(BQIDOD)'="" D Q
... I CAT'["_" S CAT=CAT_"_1"
... S @TDATA@(ORD,"DEC")=$G(@TDATA@(ORD,"DEC"))+1
.. I TYP="R",$P(IDATA,U,5)="B" D
... K XX
... I CODE="IPC_OUTC" D Q
.... I DFN'="" S VAL=$$OPAT^BQIIPOTC(CRN,DFN)
.... D CK
... I CODE["CTRL" D Q
.... I DFN'="" S VAL=$$PAT^BQIIPOTC(CRN,DFN,CODE)
.... D CK
... D Q
.... D BUN^BQIIPBNL(CRN,MSN,.XX)
.... I DFN'="" S VAL=$$PAT^BQIIPBNL(DFN,.XX)
.... D CK
.. I TYP'="G" Q
.. S BQIND=$O(^BQIPAT(DFN,30,"B",CODE,"")) I BQIND="" D Q
... S @TDATA@("NDA",DFN)=1
... S NDA=1,DEN=0,NUM=0 D STOR(ORD)
.. S BQMEAS=$P(^BQIPAT(DFN,30,BQIND,0),U,1),VALUE=$P(^(0),U,2),NUM=$P(^(0),U,3),DEN=$P(^(0),U,4),NDA=0
.. ;
.. D STOR(ORD)
Q
;
STOR(ORD) ;EP
S @TDATA@(ORD,"NUM")=$G(@TDATA@(ORD,"NUM"))+$G(NUM)
S @TDATA@(ORD,"DEN")=$G(@TDATA@(ORD,"DEN"))+$G(DEN)
S @TDATA@(ORD,"NDA")=$G(@TDATA@(ORD,"NDA"))+$G(NDA)
Q
;
CK ;Check and store
I VAL="N/A" S DEN=0,NUM=0 D STOR(ORD) Q
S CAT=CAT_"_1"
I VAL="NDA" S DEN=0,NUM=0 D STOR(ORD) Q
;I VAL="NDA" Q
I VAL="NO" S DEN=1,NUM=0 D STOR(ORD) Q
I VAL="YES" S DEN=1,NUM=1 D STOR(ORD) Q
Q
BQIIPPNL ;GDIT/HS/ALA-Panel Aggregate ; 09 Sep 2011 12:17 PM
+1 ;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23
+2 ;
+3 ;
EN(DATA,OWNR,PLIEN,CRIPC,PLIST) ;EP - BQI GET IPC PROV AGG
+1 ;Description - Entry point for the panel
+2 ;Input Parameters
+3 ; OWNR - Owner of panel
+4 ; PLIEN - Panel IEN
+5 ; CRIPC = IPC Version
+6 ; PLIST - List of DFNs (optional)
+7 NEW UID,II,TDATA,XX,BQIND,BQMEAS,CAT,CODE,DEC,DEN,DFN,IDATA,MET,MSIEN
+8 NEW NDA,NO,NUM,PROV,PRV,TITLE,TOTP,TYP,VAL,VALUE,XX,YES,GOAL,TNDA,CAT2
+9 NEW STAB,MSN,NA,TAB,BQIDOD,CNT,DCAT,EXEC,GP,I,ORD,QFL,TAG,CRN
+10 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+11 SET DATA=$NAME(^TMP("BQIIPPRV",UID))
KILL @DATA
+12 SET TDATA=$NAME(^TMP("BQIPRVIP",UID))
KILL @TDATA
+13 ;
+14 SET II=0
+15 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIIPPRV D UNWIND^%ZTER"
+16 ;
+17 ; get the current IPC definition
+18 SET CRIPC=$GET(CRIPC,"")
+19 IF CRIPC=""
SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
+20 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
QUIT
+21 SET @DATA@(II)="I00010TOTAL_PATIENTS^I00010TOTAL_NDA^T00030CATEGORY^T00030CAT2^T00060TITLE^T00030ID^"
+22 SET @DATA@(II)=@DATA@(II)_"I00010NUMERATOR^I00010DENOMINATOR^I00010DECEASED^T00005PERCENT_MET^T00005PERCENT_GOAL"_$CHAR(30)
+23 ;
+24 ; If a list of DFNs, process them instead of entire panel
+25 IF $DATA(PLIST)>0
Begin DoDot:1
+26 IF $DATA(PLIST)>1
Begin DoDot:2
+27 SET LIST=""
SET BN=""
+28 FOR
SET BN=$ORDER(PLIST(BN))
IF BN=""
QUIT
SET LIST=LIST_PLIST(BN)
+29 KILL PLIST
SET PLIST=LIST
End DoDot:2
+30 FOR BQI=1:1
SET DFN=$PIECE(PLIST,$CHAR(28),BQI)
IF DFN=""
QUIT
Begin DoDot:2
+31 IF $PIECE($GET(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",2)="R"
QUIT
+32 DO RPT(DFN)
End DoDot:2
End DoDot:1
GOTO DONE
+33 ;
+34 SET DFN=0
+35 IF $ORDER(^BQICARE(OWNR,1,PLIEN,40,DFN))=""
GOTO DONE
+36 ;
+37 FOR
SET DFN=$ORDER(^BQICARE(OWNR,1,PLIEN,40,DFN))
IF 'DFN
QUIT
Begin DoDot:1
+38 IF $PIECE($GET(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",2)="R"
QUIT
+39 DO RPT(DFN)
End DoDot:1
+40 ;
+41 SET TOTP=$GET(@TDATA@("TOTP"))
SET TNDA=0
+42 SET DFN=""
FOR
SET DFN=$ORDER(@TDATA@("NDA",DFN))
IF DFN=""
QUIT
SET TNDA=$GET(TNDA)+1
+43 SET ORD=""
+44 FOR
SET ORD=$ORDER(@TDATA@(ORD))
IF ORD=""
QUIT
Begin DoDot:1
+45 SET MSN=$ORDER(^BQI(90508,1,22,CRN,1,"C",ORD,""))
IF MSN=""
QUIT
+46 SET IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
+47 IF $PIECE(IDATA,U,7)=1
QUIT
+48 NEW DA,IENS
+49 SET DA(2)=1
SET DA(1)=CRN
SET DA=MSN
SET IENS=$$IENS^DILF(.DA)
+50 SET CAT=$$GET1^DIQ(90508.221,IENS,.03,"E")
+51 SET CAT2=$$GET1^DIQ(90508.221,IENS,.11,"E")
+52 IF CRIPC="IPC4/IPC5"
Begin DoDot:2
+53 SET CAT=$$GET1^DIQ(90508.221,IENS,.03,"E")
+54 IF CAT=""
Begin DoDot:3
+55 SET RIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
+56 SET CAT=$$GET1^DIQ(90506.1,RIEN_",",3.02,"E")
End DoDot:3
+57 SET CAT2=$$GET1^DIQ(90508.221,IENS,.11,"E")
End DoDot:2
+58 IF CRIPC="IPCMH"
Begin DoDot:2
+59 SET CAT1=$$GET1^DIQ(90508.221,IENS,.03,"E")
+60 SET ICAT=$$GET1^DIQ(90508.221,IENS,.03,"I")
+61 SET CAT2=$$GET1^DIQ(90508.221,IENS,.11,"E")
+62 IF CAT2=""
SET CAT2=$$GET1^DIQ(90506.8,ICAT_",",.04,"E")
+63 SET CAT=CAT2
SET CAT2=CAT1
End DoDot:2
+64 SET TAB=$$GET1^DIQ(90508.221,IENS,.13,"I")
+65 SET STAB=$$GET1^DIQ(90508.221,IENS,.14,"I")
+66 IF TAB="A"
QUIT
+67 SET CODE=$PIECE(IDATA,U,1)
SET TITLE=$PIECE(IDATA,U,4)
SET GOAL=$PIECE(IDATA,U,12)
+68 SET NUM=$GET(@TDATA@(ORD,"NUM"))
+69 SET DEN=$GET(@TDATA@(ORD,"DEN"))
+70 SET DEC=$GET(@TDATA@(ORD,"DEC"))
+71 ;S NDA=$G(@TDATA@(ORD,"NDA"))
+72 ;I $P(IDATA,U,5)'="B" S DEN=DEN+NDA
+73 IF $PIECE(IDATA,U,5)'="B"
SET DEN=DEN
+74 IF +DEN=0
SET MET="0%"
+75 IF +DEN'=0
IF +NUM=0
SET MET="0%"
+76 IF +NUM'=0
SET MET=$JUSTIFY((NUM/DEN)*100,3,0)
SET MET=$$TRIM^BQIUL1(MET," ")_"%"
+77 SET DCAT=CAT
+78 IF DCAT["_1"
SET DCAT=$PIECE(CAT,"_1",1)
+79 IF DCAT["_2"
SET DCAT=$PIECE(CAT,"_2",1)
+80 SET II=II+1
SET @DATA@(II)=TOTP_U_$GET(TNDA)_U_DCAT_U_CAT2_U_TITLE_U_CODE_U_NUM_U_DEN_U_DEC_U_MET_U_GOAL_$CHAR(30)
End DoDot:1
+81 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 KILL @TDATA
+3 QUIT
+4 ;
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(DFN) ; Get the CRS Clinical Performance information
+1 IF '$$HRN^BQIUL1(DFN)
QUIT
+2 SET PROV=$PIECE($GET(^AUPNPAT(DFN,0)),U,14)
+3 SET @TDATA@("TOTP")=$GET(@TDATA@("TOTP"))+1
+4 SET ORD=""
+5 FOR
SET ORD=$ORDER(^BQI(90508,1,22,CRN,1,"C",ORD))
IF ORD=""
QUIT
Begin DoDot:1
+6 SET MSN=""
+7 FOR
SET MSN=$ORDER(^BQI(90508,1,22,CRN,1,"C",ORD,MSN))
IF MSN=""
QUIT
Begin DoDot:2
+8 SET IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
+9 SET CODE=$PIECE(IDATA,U,1)
SET TYP=$PIECE(IDATA,U,2)
SET TITLE=$PIECE(IDATA,U,4)
+10 ; If inactive, quit
+11 IF $PIECE(IDATA,U,7)=1
QUIT
+12 NEW DA,IENS
+13 SET DA(2)=1
SET DA(1)=CRN
SET DA=MSN
SET IENS=$$IENS^DILF(.DA)
+14 SET CAT=$$GET1^DIQ(90508.221,IENS,.03,"E")
+15 SET MSIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
+16 IF CAT=""
IF MSIEN'=""
SET CAT=$$GET1^DIQ(90506.1,MSIEN_",",3.03,"E")
+17 IF CAT=""
SET CAT="~"
+18 IF $PIECE(IDATA,U,5)'="B"
SET CAT=CAT_"_2"
+19 SET BQIDOD=$$GET1^DIQ(2,DFN_",",.351,"I")
+20 IF $GET(BQIDOD)'=""
Begin DoDot:3
+21 IF CAT'["_"
SET CAT=CAT_"_1"
+22 SET @TDATA@(ORD,"DEC")=$GET(@TDATA@(ORD,"DEC"))+1
End DoDot:3
QUIT
+23 IF TYP="R"
IF $PIECE(IDATA,U,5)="B"
Begin DoDot:3
+24 KILL XX
+25 IF CODE="IPC_OUTC"
Begin DoDot:4
+26 IF DFN'=""
SET VAL=$$OPAT^BQIIPOTC(CRN,DFN)
+27 DO CK
End DoDot:4
QUIT
+28 IF CODE["CTRL"
Begin DoDot:4
+29 IF DFN'=""
SET VAL=$$PAT^BQIIPOTC(CRN,DFN,CODE)
+30 DO CK
End DoDot:4
QUIT
+31 Begin DoDot:4
+32 DO BUN^BQIIPBNL(CRN,MSN,.XX)
+33 IF DFN'=""
SET VAL=$$PAT^BQIIPBNL(DFN,.XX)
+34 DO CK
End DoDot:4
QUIT
End DoDot:3
+35 IF TYP'="G"
QUIT
+36 SET BQIND=$ORDER(^BQIPAT(DFN,30,"B",CODE,""))
IF BQIND=""
Begin DoDot:3
+37 SET @TDATA@("NDA",DFN)=1
+38 SET NDA=1
SET DEN=0
SET NUM=0
DO STOR(ORD)
End DoDot:3
QUIT
+39 SET BQMEAS=$PIECE(^BQIPAT(DFN,30,BQIND,0),U,1)
SET VALUE=$PIECE(^(0),U,2)
SET NUM=$PIECE(^(0),U,3)
SET DEN=$PIECE(^(0),U,4)
SET NDA=0
+40 ;
+41 DO STOR(ORD)
End DoDot:2
End DoDot:1
+42 QUIT
+43 ;
STOR(ORD) ;EP
+1 SET @TDATA@(ORD,"NUM")=$GET(@TDATA@(ORD,"NUM"))+$GET(NUM)
+2 SET @TDATA@(ORD,"DEN")=$GET(@TDATA@(ORD,"DEN"))+$GET(DEN)
+3 SET @TDATA@(ORD,"NDA")=$GET(@TDATA@(ORD,"NDA"))+$GET(NDA)
+4 QUIT
+5 ;
CK ;Check and store
+1 IF VAL="N/A"
SET DEN=0
SET NUM=0
DO STOR(ORD)
QUIT
+2 SET CAT=CAT_"_1"
+3 IF VAL="NDA"
SET DEN=0
SET NUM=0
DO STOR(ORD)
QUIT
+4 ;I VAL="NDA" Q
+5 IF VAL="NO"
SET DEN=1
SET NUM=0
DO STOR(ORD)
QUIT
+6 IF VAL="YES"
SET DEN=1
SET NUM=1
DO STOR(ORD)
QUIT
+7 QUIT
