BQIIPCMH ;GDIT/HS/ALA-Get IPC Monthly Data Export by Provider ; 11 Oct 2011 4:10 PM
;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
;
;
RET(DATA,DATE,PLIST) ;EP -- BQI GET IPC PROV MON EXPORT
NEW UID,II,HDR,C1,C2,C3,C4,NAME,HEAD,HX,PEC,SORT,QFL,PCT,CT,DDATA,CPER,PPER,TIT,BQMON
NEW BN,LIST,FAC
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIMUPROV",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIIPCM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
; If a list of IENs, 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
;
; Get current IPC
S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
I CRIPC="IPCMH" S CRIPC="IPC4/IPC5"
S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
;
K Z
;S HDR="T00050PROVIDER^T00050IPC_MEAS^T00030CATEGORY^T00030NUMERATOR^T00030DENOMINATOR"
S HDR="T00050IPC_MEAS^T00030CATEGORY^T00030NUMERATOR^T00030DENOMINATOR"
S @DATA@(II)=HDR_$C(30)
;
S (C1,C2,C3,C4,CT,PCT)=0
;S PROV=$G(PROV,"")
F BQI=1:1 S PROV=$P(PLIST,$C(28),BQI) Q:PROV="" D RTE(PROV)
;I PROV'="" D RTE(PROV) G DONE
;I PROV="" S PROV=+PROV
;F S PROV=$O(^BQIPROV(PROV)) Q:'PROV D RTE(PROV)
;
S ID=""
F S ID=$O(DDATA(ID)) Q:ID="" D
. S FDATA=DDATA(ID)_Z(ID,DATE)_U
. S FDATA=$$TKO^BQIUL1(FDATA,"^")
. 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 DDATA=""
;S PRVR=PRV_$C(28)_$P($G(^VA(200,PRV,0)),U,1)
;S DDATA=PRVR_U
S CYR=$E(DT,1,3)
S FAC=$$HME^BQIGPUTL()
;
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)
.. 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")
.. 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 DDATA(ID)=ID_$C(28)_MEAS_U_CAT_U
.. I ID="IPC_PEMP" D Q
... S IDN=$O(^BQIFAC(FAC,30,"B",ID,"")) I IDN="" D Q
.... S $P(Z(ID,DATE),U,1)=$P($G(Z(ID,DATE)),U,1)+0
.... S $P(Z(ID,DATE),U,2)=$P($G(Z(ID,DATE)),U,2)+0
... S MSDN=$O(^BQIFAC(FAC,30,IDN,1,"B",DATE,""))
... I MSDN="" S $P(Z(ID,DATE),U,1)=$P($G(Z(ID,DATE)),U,1)+0,$P(Z(ID,DATE),U,2)=$P($G(Z(ID,DATE)),U,2)+0 Q
... S DEN=+$P(^BQIFAC(FAC,30,IDN,1,MSDN,0),U,2),NUM=+$P(^BQIFAC(FAC,30,IDN,1,MSDN,0),U,3)
... S $P(Z(ID,DATE),U,1)=NUM,$P(Z(ID,DATE),U,2)=DEN
.. S IDN=$O(^BQIPROV(PRV,30,"B",ID,"")) I IDN="" D Q
... S $P(Z(ID,DATE),U,1)=$P($G(Z(ID,DATE)),U,1)+0
... S $P(Z(ID,DATE),U,2)=$P($G(Z(ID,DATE)),U,2)+0
.. D
... S MSDN=$O(^BQIPROV(PRV,30,IDN,1,"B",DATE,""))
... I MSDN="" S $P(Z(ID,DATE),U,1)=$P($G(Z(ID,DATE)),U,1)+0,$P(Z(ID,DATE),U,2)=$P($G(Z(ID,DATE)),U,2)+0 Q
... S DEN=+$P(^BQIPROV(PRV,30,IDN,1,MSDN,0),U,2),NUM=+$P(^BQIPROV(PRV,30,IDN,1,MSDN,0),U,3)
... I ID="IPC_TOTP" D Q
.... ;S Z(ID,DATE)="0^"_DEN
.... S $P(Z(ID,DATE),U,2)=$P($G(Z(ID,DATE)),U,2)+DEN
... I ID="IPC_REVG" D Q
.... I DEN=0 S $P(Z(ID,DATE),U,1)=$P($G(Z(ID,DATE)),U,1)+0,$P(Z(ID,DATE),U,2)=$P($G(Z(ID,DATE)),U,2)+0 Q
.... I DEN'=0,NUM=0 S $P(Z(ID,DATE),U,1)=$P($G(Z(ID,DATE)),U,1)+0,$P(Z(ID,DATE),U,2)=$P($G(Z(ID,DATE)),U,2)+DEN Q
.... I DEN'=0,NUM'=0 S $P(Z(ID,DATE),U,1)=$P($G(Z(ID,DATE)),U,1)+NUM,$P(Z(ID,DATE),U,2)=$P($G(Z(ID,DATE)),U,2)+DEN Q
... I DEN=0 S $P(Z(ID,DATE),U,1)=$P($G(Z(ID,DATE)),U,1)+0,$P(Z(ID,DATE),U,2)=$P($G(Z(ID,DATE)),U,2)+0 Q
... I DEN'=0,NUM=0 S $P(Z(ID,DATE),U,1)=$P($G(Z(ID,DATE)),U,1)+0,$P(Z(ID,DATE),U,2)=$P($G(Z(ID,DATE)),U,2)+DEN Q
... I NUM'=0 S $P(Z(ID,DATE),U,1)=$P($G(Z(ID,DATE)),U,1)+NUM,$P(Z(ID,DATE),U,2)=$P($G(Z(ID,DATE)),U,2)+DEN
Q
BQIIPCMH ;GDIT/HS/ALA-Get IPC Monthly Data Export by Provider ; 11 Oct 2011 4:10 PM
+1 ;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
+2 ;
+3 ;
RET(DATA,DATE,PLIST) ;EP -- BQI GET IPC PROV MON EXPORT
+1 NEW UID,II,HDR,C1,C2,C3,C4,NAME,HEAD,HX,PEC,SORT,QFL,PCT,CT,DDATA,CPER,PPER,TIT,BQMON
+2 NEW BN,LIST,FAC
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BQIMUPROV",UID))
+5 KILL @DATA
+6 SET II=0
+7 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIIPCM D UNWIND^%ZTER"
+8 ; If a list of IENs, process them instead of entire panel
+9 IF $DATA(PLIST)>0
Begin DoDot:1
+10 IF $DATA(PLIST)>1
Begin DoDot:2
+11 SET LIST=""
SET BN=""
+12 FOR
SET BN=$ORDER(PLIST(BN))
IF BN=""
QUIT
SET LIST=LIST_PLIST(BN)
+13 KILL PLIST
SET PLIST=LIST
End DoDot:2
End DoDot:1
+14 ;
+15 ; Get current IPC
+16 SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
+17 IF CRIPC="IPCMH"
SET CRIPC="IPC4/IPC5"
+18 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
QUIT
+19 ;
+20 KILL Z
+21 ;S HDR="T00050PROVIDER^T00050IPC_MEAS^T00030CATEGORY^T00030NUMERATOR^T00030DENOMINATOR"
+22 SET HDR="T00050IPC_MEAS^T00030CATEGORY^T00030NUMERATOR^T00030DENOMINATOR"
+23 SET @DATA@(II)=HDR_$CHAR(30)
+24 ;
+25 SET (C1,C2,C3,C4,CT,PCT)=0
+26 ;S PROV=$G(PROV,"")
+27 FOR BQI=1:1
SET PROV=$PIECE(PLIST,$CHAR(28),BQI)
IF PROV=""
QUIT
DO RTE(PROV)
+28 ;I PROV'="" D RTE(PROV) G DONE
+29 ;I PROV="" S PROV=+PROV
+30 ;F S PROV=$O(^BQIPROV(PROV)) Q:'PROV D RTE(PROV)
+31 ;
+32 SET ID=""
+33 FOR
SET ID=$ORDER(DDATA(ID))
IF ID=""
QUIT
Begin DoDot:1
+34 SET FDATA=DDATA(ID)_Z(ID,DATE)_U
+35 SET FDATA=$$TKO^BQIUL1(FDATA,"^")
+36 SET II=II+1
SET @DATA@(II)=FDATA_$CHAR(30)
End DoDot:1
+37 ;
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 ;S DDATA=""
+2 ;S PRVR=PRV_$C(28)_$P($G(^VA(200,PRV,0)),U,1)
+3 ;S DDATA=PRVR_U
+4 SET CYR=$EXTRACT(DT,1,3)
+5 SET FAC=$$HME^BQIGPUTL()
+6 ;
+7 SET ORD=""
+8 FOR
SET ORD=$ORDER(^BQI(90508,1,22,CRN,1,"C",ORD))
IF ORD=""
QUIT
Begin DoDot:1
+9 SET IDD=""
+10 FOR
SET IDD=$ORDER(^BQI(90508,1,22,CRN,1,"C",ORD,IDD))
IF IDD=""
QUIT
Begin DoDot:2
+11 SET ID=$PIECE(^BQI(90508,1,22,CRN,1,IDD,0),U,1)
SET MEAS=$PIECE(^(0),U,4)
+12 IF $PIECE(^BQI(90508,1,22,CRN,1,IDD,0),U,7)=1
QUIT
+13 NEW DA,IENS
+14 SET DA(2)=1
SET DA(1)=CRN
SET DA=IDD
SET IENS=$$IENS^DILF(.DA)
+15 SET CAT=$$GET1^DIQ(90508.221,IENS,.03,"E")
+16 IF CAT=""
Begin DoDot:3
+17 SET CODE=ID
+18 SET RIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
IF RIEN=""
QUIT
+19 SET CAT=$$GET1^DIQ(90506.1,RIEN_",",3.02,"E")
End DoDot:3
+20 SET DDATA(ID)=ID_$CHAR(28)_MEAS_U_CAT_U
+21 IF ID="IPC_PEMP"
Begin DoDot:3
+22 SET IDN=$ORDER(^BQIFAC(FAC,30,"B",ID,""))
IF IDN=""
Begin DoDot:4
+23 SET $PIECE(Z(ID,DATE),U,1)=$PIECE($GET(Z(ID,DATE)),U,1)+0
+24 SET $PIECE(Z(ID,DATE),U,2)=$PIECE($GET(Z(ID,DATE)),U,2)+0
End DoDot:4
QUIT
+25 SET MSDN=$ORDER(^BQIFAC(FAC,30,IDN,1,"B",DATE,""))
+26 IF MSDN=""
SET $PIECE(Z(ID,DATE),U,1)=$PIECE($GET(Z(ID,DATE)),U,1)+0
SET $PIECE(Z(ID,DATE),U,2)=$PIECE($GET(Z(ID,DATE)),U,2)+0
QUIT
+27 SET DEN=+$PIECE(^BQIFAC(FAC,30,IDN,1,MSDN,0),U,2)
SET NUM=+$PIECE(^BQIFAC(FAC,30,IDN,1,MSDN,0),U,3)
+28 SET $PIECE(Z(ID,DATE),U,1)=NUM
SET $PIECE(Z(ID,DATE),U,2)=DEN
End DoDot:3
QUIT
+29 SET IDN=$ORDER(^BQIPROV(PRV,30,"B",ID,""))
IF IDN=""
Begin DoDot:3
+30 SET $PIECE(Z(ID,DATE),U,1)=$PIECE($GET(Z(ID,DATE)),U,1)+0
+31 SET $PIECE(Z(ID,DATE),U,2)=$PIECE($GET(Z(ID,DATE)),U,2)+0
End DoDot:3
QUIT
+32 Begin DoDot:3
+33 SET MSDN=$ORDER(^BQIPROV(PRV,30,IDN,1,"B",DATE,""))
+34 IF MSDN=""
SET $PIECE(Z(ID,DATE),U,1)=$PIECE($GET(Z(ID,DATE)),U,1)+0
SET $PIECE(Z(ID,DATE),U,2)=$PIECE($GET(Z(ID,DATE)),U,2)+0
QUIT
+35 SET DEN=+$PIECE(^BQIPROV(PRV,30,IDN,1,MSDN,0),U,2)
SET NUM=+$PIECE(^BQIPROV(PRV,30,IDN,1,MSDN,0),U,3)
+36 IF ID="IPC_TOTP"
Begin DoDot:4
+37 ;S Z(ID,DATE)="0^"_DEN
+38 SET $PIECE(Z(ID,DATE),U,2)=$PIECE($GET(Z(ID,DATE)),U,2)+DEN
End DoDot:4
QUIT
+39 IF ID="IPC_REVG"
Begin DoDot:4
+40 IF DEN=0
SET $PIECE(Z(ID,DATE),U,1)=$PIECE($GET(Z(ID,DATE)),U,1)+0
SET $PIECE(Z(ID,DATE),U,2)=$PIECE($GET(Z(ID,DATE)),U,2)+0
QUIT
+41 IF DEN'=0
IF NUM=0
SET $PIECE(Z(ID,DATE),U,1)=$PIECE($GET(Z(ID,DATE)),U,1)+0
SET $PIECE(Z(ID,DATE),U,2)=$PIECE($GET(Z(ID,DATE)),U,2)+DEN
QUIT
+42 IF DEN'=0
IF NUM'=0
SET $PIECE(Z(ID,DATE),U,1)=$PIECE($GET(Z(ID,DATE)),U,1)+NUM
SET $PIECE(Z(ID,DATE),U,2)=$PIECE($GET(Z(ID,DATE)),U,2)+DEN
QUIT
End DoDot:4
QUIT
+43 IF DEN=0
SET $PIECE(Z(ID,DATE),U,1)=$PIECE($GET(Z(ID,DATE)),U,1)+0
SET $PIECE(Z(ID,DATE),U,2)=$PIECE($GET(Z(ID,DATE)),U,2)+0
QUIT
+44 IF DEN'=0
IF NUM=0
SET $PIECE(Z(ID,DATE),U,1)=$PIECE($GET(Z(ID,DATE)),U,1)+0
SET $PIECE(Z(ID,DATE),U,2)=$PIECE($GET(Z(ID,DATE)),U,2)+DEN
QUIT
+45 IF NUM'=0
SET $PIECE(Z(ID,DATE),U,1)=$PIECE($GET(Z(ID,DATE)),U,1)+NUM
SET $PIECE(Z(ID,DATE),U,2)=$PIECE($GET(Z(ID,DATE)),U,2)+DEN
End DoDot:3
End DoDot:2
End DoDot:1
+46 QUIT
