- 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
