BQIIPPRA ;GDIT/HS/ALA-IPC Provider Monthly Aggregate ; 30 Nov 2011 11:17 AM
;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
;
;
EN(DATA,PLIST) ;EP -- BQI GET IPC MON PROV AGG
;Input Parameters
; PLIST - List of DFNs (optional) assumes Microsystem list of providers if PLIST is blank
NEW UID,II,TDATA,DTI,HDR,ORD,IDD,ID,BQMON,TIT,POS,Z,MEAS,MSDN,NUM,DEN
NEW PROV,BQI,CAT,GOAL,IDN,POS1,POS2,TAB,STAB
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIIPPRA",UID)) K @DATA
S TDATA=$NA(^TMP("BQIPRVMAG",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
NEW CRIPC,CRN
S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
;
S HDR="T00050IPC_MEAS^T00030CATEGORY^T00005PERCENT_GOAL^"
K Z
S DTI="",POS=3
F S DTI=$O(^BQI(90508,1,22,CRN,3,"B",DTI)) Q:DTI="" D
. S BQMON=$E(DTI,4,5)
. S TIT=$P($T(MON+BQMON^BQIIPUTL),";;",2)_"_"_(1700+$E(DTI,1,3))
. S HDR=HDR_"T00010"_TIT_U_"T00045HIDE_"_TIT_U
. S POS=POS+1
. S Z(DTI)=POS_"^"_(POS+1)
. S POS=POS+1
;
S ORD=""
F S ORD=$O(^BQI(90508,1,22,CRN,1,"C",ORD)) Q:ORD="" D
. S IDD=""
. F S IDD=$O(^BQI(90508,1,22,CRN,1,"C",ORD,IDD)) Q:IDD="" D
.. S ID=$P(^BQI(90508,1,22,CRN,1,IDD,0),U,1)
.. I $P(^BQI(90508,1,22,CRN,1,IDD,0),U,7)=1 Q
.. S DTI=""
.. F S DTI=$O(^BQI(90508,1,22,CRN,3,"B",DTI)) Q:DTI="" S @TDATA@(ID,DTI)="0^0"
;
S @DATA@(II)=$$TKO^BQIUL1(HDR,"^")_$C(30)
;
; If a list of DFNs, process them instead of entire panel
I $D(PLIST)>0 D
. 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 PROV=$P(PLIST,$C(28),BQI) Q:PROV="" D RTE(PROV)
;
I $G(PLIST)="" S PROV="" F S PROV=$O(^BQI(90508,1,22,CRN,2,"B",PROV)) Q:PROV="" D RTE(PROV)
;
S ORD=""
F S ORD=$O(^BQI(90508,1,22,CRN,1,"C",ORD)) Q:ORD="" D
. S IDD=""
. F S IDD=$O(^BQI(90508,1,22,CRN,1,"C",ORD,IDD)) Q:IDD="" D
.. S ID=$P(^BQI(90508,1,22,CRN,1,IDD,0),U,1)
.. I $P(^BQI(90508,1,22,CRN,1,IDD,0),U,7)=1 Q
.. I $G(@TDATA@(ID))="" Q
.. S FDATA=@TDATA@(ID)
.. S DATE=""
.. F S DATE=$O(@TDATA@(ID,DATE)) Q:DATE="" D
... S DEN=$P(@TDATA@(ID,DATE),U,1),NUM=$P(@TDATA@(ID,DATE),U,2)
... S POS1=$P(Z(DATE),U,1),POS2=$P(Z(DATE),U,2)
... I ID="IPC_TOTP" D Q
.... S $P(FDATA,U,POS1)=DEN,$P(FDATA,U,POS2)="Total Patients: "_DEN
... I ID="IPC_REVG" D Q
.... I DEN=0 S $P(FDATA,U,POS1)="$0.00",$P(FDATA,U,POS2)="Visits: "_DEN_" Billed: $0.00" Q
.... S $P(FDATA,U,POS1)=$$DOL(NUM/DEN),$P(FDATA,U,POS2)="Visits: "_DEN_" Billed: "_$$DOL(NUM)
... I DEN=0 S $P(FDATA,U,POS1)="0%",$P(FDATA,U,POS2)="Numerator: 0 Denominator: 0" Q
... I DEN'=0,NUM=0 S $P(FDATA,U,POS1)="0%",$P(FDATA,U,POS2)="Numerator: 0 Denominator: "_DEN Q
... I NUM'=0 D
.... S VAL=$J((NUM/DEN)*100,3,0)
.... S VAL=$$TRIM^BQIUL1(VAL," ")_"%"
.... S $P(FDATA,U,POS1)=VAL,$P(FDATA,U,POS2)="Numerator: "_NUM_" Denominator: "_DEN
.. S DATE=""
.. F S DATE=$O(Z(DATE)) Q:DATE="" D
... S POS1=$P(Z(DATE),U,1),POS2=$P(Z(DATE),U,2)
... I $P(FDATA,U,POS1)="" S $P(FDATA,U,POS1)="N/A"
... I $P(FDATA,U,POS2)="" S $P(FDATA,U,POS2)="Not Applicable"
.. S II=II+1,@DATA@(II)=FDATA_$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
;
RTE(PRV) ;EP
S ORD=""
F S ORD=$O(^BQI(90508,1,22,CRN,1,"C",ORD)) Q:ORD="" D
. S IDD=""
. F S IDD=$O(^BQI(90508,1,22,CRN,1,"C",ORD,IDD)) Q:IDD="" D
.. S ID=$P(^BQI(90508,1,22,CRN,1,IDD,0),U,1),MEAS=$P(^(0),U,4),GOAL=$P(^(0),U,12)
.. I $P(^BQI(90508,1,22,CRN,1,IDD,0),U,7)=1 Q
.. NEW DA,IENS
.. S DA(2)=1,DA(1)=CRN,DA=IDD,IENS=$$IENS^DILF(.DA)
.. S CAT=$$GET1^DIQ(90508.221,IENS,.03,"E")
.. S TAB=$$GET1^DIQ(90508.221,IENS,.13,"I")
.. S STAB=$$GET1^DIQ(90508.221,IENS,.14,"I")
.. I TAB="A",STAB="F" Q
.. I CAT="" D
... S CODE=ID
... S RIEN=$O(^BQI(90506.1,"B",CODE,"")) I RIEN="" Q
... S CAT=$$GET1^DIQ(90506.1,RIEN_",",3.02,"E")
.. S @TDATA@(ID)=ID_$C(28)_MEAS_U_CAT_U_GOAL_U
.. S IDN=$O(^BQIPROV(PRV,30,"B",ID,"")) I IDN="" Q
.. S DTI=""
.. F S DTI=$O(^BQI(90508,1,22,CRN,3,"B",DTI)) Q:DTI="" D
... S MSDN=$O(^BQIPROV(PRV,30,IDN,1,"B",DTI,""))
... I MSDN="" S DEN=0,NUM=0
... I MSDN'="" S DEN=+$P(^BQIPROV(PRV,30,IDN,1,MSDN,0),U,2),NUM=+$P(^BQIPROV(PRV,30,IDN,1,MSDN,0),U,3)
... S $P(@TDATA@(ID,DTI),U,1)=$P($G(@TDATA@(ID,DTI)),U,1)+DEN,$P(@TDATA@(ID,DTI),U,2)=$P($G(@TDATA@(ID,DTI)),U,2)+NUM
Q
;
DOL(X) ;EP - Dollar formatter
S X2="2$" D COMMA^%DTC S X=X_$E("00",1,2-$L($P(X,".",2))) K X2
Q $$TKO^BQIUL1($$TRIM^BQIUL1(X," ")," ")
BQIIPPRA ;GDIT/HS/ALA-IPC Provider Monthly Aggregate ; 30 Nov 2011 11:17 AM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
+2 ;
+3 ;
EN(DATA,PLIST) ;EP -- BQI GET IPC MON PROV AGG
+1 ;Input Parameters
+2 ; PLIST - List of DFNs (optional) assumes Microsystem list of providers if PLIST is blank
+3 NEW UID,II,TDATA,DTI,HDR,ORD,IDD,ID,BQMON,TIT,POS,Z,MEAS,MSDN,NUM,DEN
+4 NEW PROV,BQI,CAT,GOAL,IDN,POS1,POS2,TAB,STAB
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 SET DATA=$NAME(^TMP("BQIIPPRA",UID))
KILL @DATA
+7 SET TDATA=$NAME(^TMP("BQIPRVMAG",UID))
KILL @TDATA
+8 ;
+9 SET II=0
+10 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIIPPRV D UNWIND^%ZTER"
+11 ;
+12 ; get the current IPC definition
+13 NEW CRIPC,CRN
+14 SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
+15 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
QUIT
+16 ;
+17 SET HDR="T00050IPC_MEAS^T00030CATEGORY^T00005PERCENT_GOAL^"
+18 KILL Z
+19 SET DTI=""
SET POS=3
+20 FOR
SET DTI=$ORDER(^BQI(90508,1,22,CRN,3,"B",DTI))
IF DTI=""
QUIT
Begin DoDot:1
+21 SET BQMON=$EXTRACT(DTI,4,5)
+22 SET TIT=$PIECE($TEXT(MON+BQMON^BQIIPUTL),";;",2)_"_"_(1700+$EXTRACT(DTI,1,3))
+23 SET HDR=HDR_"T00010"_TIT_U_"T00045HIDE_"_TIT_U
+24 SET POS=POS+1
+25 SET Z(DTI)=POS_"^"_(POS+1)
+26 SET POS=POS+1
End DoDot:1
+27 ;
+28 SET ORD=""
+29 FOR
SET ORD=$ORDER(^BQI(90508,1,22,CRN,1,"C",ORD))
IF ORD=""
QUIT
Begin DoDot:1
+30 SET IDD=""
+31 FOR
SET IDD=$ORDER(^BQI(90508,1,22,CRN,1,"C",ORD,IDD))
IF IDD=""
QUIT
Begin DoDot:2
+32 SET ID=$PIECE(^BQI(90508,1,22,CRN,1,IDD,0),U,1)
+33 IF $PIECE(^BQI(90508,1,22,CRN,1,IDD,0),U,7)=1
QUIT
+34 SET DTI=""
+35 FOR
SET DTI=$ORDER(^BQI(90508,1,22,CRN,3,"B",DTI))
IF DTI=""
QUIT
SET @TDATA@(ID,DTI)="0^0"
End DoDot:2
End DoDot:1
+36 ;
+37 SET @DATA@(II)=$$TKO^BQIUL1(HDR,"^")_$CHAR(30)
+38 ;
+39 ; If a list of DFNs, process them instead of entire panel
+40 IF $DATA(PLIST)>0
Begin DoDot:1
+41 IF $DATA(PLIST)>1
Begin DoDot:2
+42 SET LIST=""
SET BN=""
+43 FOR
SET BN=$ORDER(PLIST(BN))
IF BN=""
QUIT
SET LIST=LIST_PLIST(BN)
+44 KILL PLIST
SET PLIST=LIST
End DoDot:2
+45 FOR BQI=1:1
SET PROV=$PIECE(PLIST,$CHAR(28),BQI)
IF PROV=""
QUIT
DO RTE(PROV)
End DoDot:1
+46 ;
+47 IF $GET(PLIST)=""
SET PROV=""
FOR
SET PROV=$ORDER(^BQI(90508,1,22,CRN,2,"B",PROV))
IF PROV=""
QUIT
DO RTE(PROV)
+48 ;
+49 SET ORD=""
+50 FOR
SET ORD=$ORDER(^BQI(90508,1,22,CRN,1,"C",ORD))
IF ORD=""
QUIT
Begin DoDot:1
+51 SET IDD=""
+52 FOR
SET IDD=$ORDER(^BQI(90508,1,22,CRN,1,"C",ORD,IDD))
IF IDD=""
QUIT
Begin DoDot:2
+53 SET ID=$PIECE(^BQI(90508,1,22,CRN,1,IDD,0),U,1)
+54 IF $PIECE(^BQI(90508,1,22,CRN,1,IDD,0),U,7)=1
QUIT
+55 IF $GET(@TDATA@(ID))=""
QUIT
+56 SET FDATA=@TDATA@(ID)
+57 SET DATE=""
+58 FOR
SET DATE=$ORDER(@TDATA@(ID,DATE))
IF DATE=""
QUIT
Begin DoDot:3
+59 SET DEN=$PIECE(@TDATA@(ID,DATE),U,1)
SET NUM=$PIECE(@TDATA@(ID,DATE),U,2)
+60 SET POS1=$PIECE(Z(DATE),U,1)
SET POS2=$PIECE(Z(DATE),U,2)
+61 IF ID="IPC_TOTP"
Begin DoDot:4
+62 SET $PIECE(FDATA,U,POS1)=DEN
SET $PIECE(FDATA,U,POS2)="Total Patients: "_DEN
End DoDot:4
QUIT
+63 IF ID="IPC_REVG"
Begin DoDot:4
+64 IF DEN=0
SET $PIECE(FDATA,U,POS1)="$0.00"
SET $PIECE(FDATA,U,POS2)="Visits: "_DEN_" Billed: $0.00"
QUIT
+65 SET $PIECE(FDATA,U,POS1)=$$DOL(NUM/DEN)
SET $PIECE(FDATA,U,POS2)="Visits: "_DEN_" Billed: "_$$DOL(NUM)
End DoDot:4
QUIT
+66 IF DEN=0
SET $PIECE(FDATA,U,POS1)="0%"
SET $PIECE(FDATA,U,POS2)="Numerator: 0 Denominator: 0"
QUIT
+67 IF DEN'=0
IF NUM=0
SET $PIECE(FDATA,U,POS1)="0%"
SET $PIECE(FDATA,U,POS2)="Numerator: 0 Denominator: "_DEN
QUIT
+68 IF NUM'=0
Begin DoDot:4
+69 SET VAL=$JUSTIFY((NUM/DEN)*100,3,0)
+70 SET VAL=$$TRIM^BQIUL1(VAL," ")_"%"
+71 SET $PIECE(FDATA,U,POS1)=VAL
SET $PIECE(FDATA,U,POS2)="Numerator: "_NUM_" Denominator: "_DEN
End DoDot:4
End DoDot:3
+72 SET DATE=""
+73 FOR
SET DATE=$ORDER(Z(DATE))
IF DATE=""
QUIT
Begin DoDot:3
+74 SET POS1=$PIECE(Z(DATE),U,1)
SET POS2=$PIECE(Z(DATE),U,2)
+75 IF $PIECE(FDATA,U,POS1)=""
SET $PIECE(FDATA,U,POS1)="N/A"
+76 IF $PIECE(FDATA,U,POS2)=""
SET $PIECE(FDATA,U,POS2)="Not Applicable"
End DoDot:3
+77 SET II=II+1
SET @DATA@(II)=FDATA_$CHAR(30)
End DoDot:2
End DoDot:1
+78 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+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(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
RTE(PRV) ;EP
+1 SET ORD=""
+2 FOR
SET ORD=$ORDER(^BQI(90508,1,22,CRN,1,"C",ORD))
IF ORD=""
QUIT
Begin DoDot:1
+3 SET IDD=""
+4 FOR
SET IDD=$ORDER(^BQI(90508,1,22,CRN,1,"C",ORD,IDD))
IF IDD=""
QUIT
Begin DoDot:2
+5 SET ID=$PIECE(^BQI(90508,1,22,CRN,1,IDD,0),U,1)
SET MEAS=$PIECE(^(0),U,4)
SET GOAL=$PIECE(^(0),U,12)
+6 IF $PIECE(^BQI(90508,1,22,CRN,1,IDD,0),U,7)=1
QUIT
+7 NEW DA,IENS
+8 SET DA(2)=1
SET DA(1)=CRN
SET DA=IDD
SET IENS=$$IENS^DILF(.DA)
+9 SET CAT=$$GET1^DIQ(90508.221,IENS,.03,"E")
+10 SET TAB=$$GET1^DIQ(90508.221,IENS,.13,"I")
+11 SET STAB=$$GET1^DIQ(90508.221,IENS,.14,"I")
+12 IF TAB="A"
IF STAB="F"
QUIT
+13 IF CAT=""
Begin DoDot:3
+14 SET CODE=ID
+15 SET RIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
IF RIEN=""
QUIT
+16 SET CAT=$$GET1^DIQ(90506.1,RIEN_",",3.02,"E")
End DoDot:3
+17 SET @TDATA@(ID)=ID_$CHAR(28)_MEAS_U_CAT_U_GOAL_U
+18 SET IDN=$ORDER(^BQIPROV(PRV,30,"B",ID,""))
IF IDN=""
QUIT
+19 SET DTI=""
+20 FOR
SET DTI=$ORDER(^BQI(90508,1,22,CRN,3,"B",DTI))
IF DTI=""
QUIT
Begin DoDot:3
+21 SET MSDN=$ORDER(^BQIPROV(PRV,30,IDN,1,"B",DTI,""))
+22 IF MSDN=""
SET DEN=0
SET NUM=0
+23 IF MSDN'=""
SET DEN=+$PIECE(^BQIPROV(PRV,30,IDN,1,MSDN,0),U,2)
SET NUM=+$PIECE(^BQIPROV(PRV,30,IDN,1,MSDN,0),U,3)
+24 SET $PIECE(@TDATA@(ID,DTI),U,1)=$PIECE($GET(@TDATA@(ID,DTI)),U,1)+DEN
SET $PIECE(@TDATA@(ID,DTI),U,2)=$PIECE($GET(@TDATA@(ID,DTI)),U,2)+NUM
End DoDot:3
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
DOL(X) ;EP - Dollar formatter
+1 SET X2="2$"
DO COMMA^%DTC
SET X=X_$EXTRACT("00",1,2-$LENGTH($PIECE(X,".",2)))
KILL X2
+2 QUIT $$TKO^BQIUL1($$TRIM^BQIUL1(X," ")," ")
