BQIIPCM.m

BQIIPCM ;VNGT/HS/ALA-Get IPC Monthly Data by Provider ; 17 Jun 2011  12:38 PM

 ;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12

 ;

 ;

RET(DATA,PROV,TMFRAME,CRIPC) ;EP -- BQI GET IPC PROV MONTHLY

 NEW UID,II,HDR,C1,C2,C3,C4,NAME,HEAD,HX,PEC,SORT,QFL,PCT,CT,DDATA,TRM

 NEW CPER,PPER,TIT,BQMON,DATE,TAB,STAB,TNM,FAC,QDF,RFROM,PPIEN,TYPE,RTHRU

 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

 ; Get current IPC

 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 TMFRAME=$G(TMFRAME,"") I TMFRAME="Ever" S TMFRAME=""

 I TMFRAME'="" D

 . I TMFRAME?.N S TMFRAME=$P(^BQI(90506.9,TMFRAME,0),"^",1)

 . S PPIEN="IPC",TYPE="IPMRANGE"

 . D RANGE^BQIDCAH1(TMFRAME,PPIEN,TYPE)

 ;

 K Z

 S HDR="T00050PROVIDER^T00075IPC_MEAS^T00030CATEGORY^T00005PERCENT_GOAL^"

 S FAC=$$HME^BQIGPUTL()

 S DATE=$S(TMFRAME'="":RTHRU+1,1:""),QDF=0

 F  S DATE=$O(^BQIPROV("AD",DATE),-1) Q:DATE=""!(QDF)  D

 . S Z(DATE)="N/A^Not Applicable"

 . I DATE=$G(RFROM) S QDF=1 Q

 . I DATE<$G(RFROM) K Z(DATE) S QDF=1 Q

 S DATE="" F  S DATE=$O(Z(DATE),-1) Q:DATE=""  D HH(DATE)

 S HDR=HDR_"T00004MEDIAN"

 S @DATA@(II)=$$TKO^BQIUL1(HDR,"^")_$C(30)

 ;

 S (C1,C2,C3,C4,CT,PCT)=0

 S PROV=$G(PROV,"")

 I PROV'="" D RTE(PROV) G DONE

 I PROV="" S PROV=+PROV

 F  S PROV=$O(^BQIPROV(PROV)) Q:'PROV  D

 . I $D(^BQIPROV(PROV,30)) D RTE(PROV)

 ;

DONE ;

 S II=II+1,@DATA@(II)=$C(31)

 K Z

 Q

 ;

HH(DATE) ;EP

 S BQMON=$E(DATE,4,5)

 S TIT=$P($T(MON+BQMON^BQIIPUTL),";;",2)_"_"_(1700+$E(DATE,1,3))

 S HDR=HDR_"T00030"_TIT_U_"T00045HIDE_"_TIT_U

 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="",TRM=0

 I $P($G(^VA(200,PRV,0)),U,13)'="" S TRM=1

 S PRVR=PRV_$C(28)_$S(TRM:"*",1:"")_$P($G(^VA(200,PRV,0)),U,1)

 S DDATA=PRVR_U

 S CYR=$E(DT,1,3)

 S ORD=""

 F  S ORD=$O(^BQI(90508,1,22,CRN,1,"C",ORD)) Q:ORD=""  D

 . S IDD="",QFL=0

 . 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 S QFL=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'="P" S QFL=1 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 DDATA=DDATA_ID_$C(28)_MEAS_U_CAT_U_GOAL_U

 .. S IDN=$O(^BQIPROV(PRV,30,"B",ID,"")) I IDN="" Q

 .. S DTI="",MC=0

 .. F  S DTI=$O(Z(DTI)) Q:DTI=""  D

 ... S MSDN=$O(^BQIPROV(PRV,30,IDN,1,"B",DTI,""))

 ... I MSDN="" S Z(DTI)="N/A^Not Applicable" Q

 ... S DEN=+$P(^BQIPROV(PRV,30,IDN,1,MSDN,0),U,2),NUM=+$P(^BQIPROV(PRV,30,IDN,1,MSDN,0),U,3),MC=MC+1

 ... I ID="IPC_TOTP" D  Q

 .... S Z(DTI)=DEN_"^Total Patients: "_DEN

 ... I ID="IPC_REVG" D  Q

 .... I DEN=0 S Z(DTI)="$0^Visits: 0 Billed: 0" Q

 .... I DEN'=0,NUM=0 S Z(DTI)="$0^Visits: 0 Billed: 0" Q

 .... I DEN'=0,NUM'=0 S Z(DTI)=$$DOL(NUM/DEN)_U_"Visits: "_DEN_" Billed: "_$$DOL(NUM) Q

 ... I DEN=0 S Z(DTI)="0%^Numerator: 0 Denominator: 0",M(0,MC)="" Q

 ... I DEN'=0,NUM=0 S Z(DTI)="0%^Numerator: 0 Denominator: "_DEN,M(0,MC)="" Q

 ... I NUM'=0 D

 .... S VAL=$J((NUM/DEN)*100,3,0),M($$TRIM^BQIUL1(VAL," "),MC)=""

 .... S VAL=$$TRIM^BQIUL1(VAL," ")_"%"

 .... S Z(DTI)=VAL_U_"Numerator: "_NUM_" Denominator: "_DEN

 . I QFL Q  ;

 . I '$D(M) S MEDIAN="^"

 . I $D(M) D MEDIAN(.M,.MEDIAN)

 . S DTI=""

 . F  S DTI=$O(Z(DTI),-1) Q:DTI=""  S DDATA=DDATA_Z(DTI)_U

 . S DDATA=DDATA_MEDIAN

 . S DDATA=$$TKO^BQIUL1(DDATA,"^")

 . S II=II+1,@DATA@(II)=DDATA_$C(30)

 . K Z,M

 . S DDATA=PRVR_U

 . S FAC=$$HME^BQIGPUTL()

 . S DATE=$S(TMFRAME'="":RTHRU+1,1:""),QDF=0

 . F  S DATE=$O(^BQIPROV("AD",DATE),-1) Q:DATE=""!(QDF)  D

 .. S Z(DATE)="N/A^Not Applicable"

 .. I DATE=$G(RFROM) S QDF=1 Q

 .. I DATE<$G(RFROM) K Z(DATE) S QDF=1 Q

 Q

 ;

FAC(DATA,TMFRAME,CRIPC) ;EP -- BQI GET IPC FAC MONTHLY

 NEW UID,II,HDR,FAC,CYR,DATE,Z,I,IDN,ID,DTI,MSDN,DEN,NUM,VAL,DDATA,TIT,BQMON,DATE

 NEW CAT,CRN,GOAL,IDD,MEAS,ORD,QDF,QFL,SAME,TAB,STAB

 S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)

 S DATA=$NA(^TMP("BQIIPCF",UID))

 K @DATA

 S II=0

 NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIIPCM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2

 ; Get current IPC

 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 TMFRAME=$G(TMFRAME,"") I TMFRAME="Ever" S TMFRAME=""

 I TMFRAME'="" D

 . I TMFRAME?.N S TMFRAME=$P(^BQI(90506.9,TMFRAME,0),"^",1)

 . S PPIEN="IPC",TYPE="IPMRANGE"

 . D RANGE^BQIDCAH1(TMFRAME,PPIEN,TYPE)

 ;

 K Z

 S HDR="T00030FACILITY^T00075IPC_MEAS^T00030CATEGORY^T00005PERCENT_GOAL^"

 S FAC=$$HME^BQIGPUTL()

 S DATE=$S(TMFRAME'="":RTHRU+1,1:""),QDF=0

 F  S DATE=$O(^BQIFAC(FAC,30,"AB",DATE),-1) Q:DATE=""!(QDF)  D

 . S Z(DATE)="N/A^Not Applicable"

 . I DATE=$G(RFROM) S QDF=1 Q

 . I DATE<$G(RFROM) K Z(DATE) S QDF=1 Q

 S DATE="" F  S DATE=$O(Z(DATE),-1) Q:DATE=""  D HH(DATE)

 S HDR=HDR_"T00004MEDIAN"

 S @DATA@(II)=$$TKO^BQIUL1(HDR,"^")_$C(30)

 ;

 S FAC=$$HME^BQIGPUTL()

 S II=II+1,SAME=FAC_$C(28)_$P(^DIC(4,FAC,0),U,1)_U,DDATA=SAME

 ;

 S ORD=""

 F  S ORD=$O(^BQI(90508,1,22,CRN,1,"C",ORD)) Q:ORD=""  D

 . S IDD="",QFL=0

 . 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 S QFL=1 Q

 .. S TAB=$P(^BQI(90508,1,22,CRN,1,IDD,0),U,13)

 .. S STAB=$P(^BQI(90508,1,22,CRN,1,IDD,0),U,14)

 .. ;I TAB'="A" S QFL=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=DDATA_ID_$C(28)_MEAS_U_CAT_U_GOAL_U

 .. S IDN=$O(^BQIFAC(FAC,30,"B",ID,"")) I IDN="" Q

 .. S DTI="",MC=0

 .. F  S DTI=$O(Z(DTI)) Q:DTI=""  D

 ... S MSDN=$O(^BQIFAC(FAC,30,IDN,1,"B",DTI,""))

 ... I MSDN="" S Z(DTI)="N/A^Not Applicable" Q

 ... S DEN=+$P(^BQIFAC(FAC,30,IDN,1,MSDN,0),U,2),NUM=+$P(^BQIFAC(FAC,30,IDN,1,MSDN,0),U,3),MC=MC+1

 ... I ID="IPC_TOTP" D  Q

 .... S Z(DTI)=DEN_"^Total Patients: "_DEN

 ... I ID="IPC_REVG" D  Q

 .... I DEN=0 S Z(DTI)="$0^Visits: 0 Billed: 0" Q

 .... I DEN'=0,NUM=0 S Z(DTI)="$0^Visits: 0 Billed: 0" Q

 .... I DEN'=0,NUM'=0 S Z(DTI)=$$DOL(NUM/DEN)_U_"Visits: "_DEN_" Billed: "_$$DOL(NUM) Q

 ... I DEN=0 S Z(DTI)="0%^Numerator: 0 Denominator: 0",M(0,MC)="" Q

 ... I DEN'=0,NUM=0 S Z(DTI)="0%^Numerator: 0 Denominator: 0",M(0,MC)="" Q

 ... I NUM'=0 D

 .... S VAL=$J((NUM/DEN)*100,3,0),M($$TRIM^BQIUL1(VAL," "),MC)=""

 .... S VAL=$$TRIM^BQIUL1(VAL," ")_"%"

 .... S Z(DTI)=VAL_U_"Numerator: "_NUM_" Denominator: "_DEN

 . I QFL=1 Q  ;

 . ;S DTI="",TOT=0,TNM=0 F  S DTI=$O(Z(DTI)) Q:DTI=""  S TOT=TOT+1 S:Z(DTI)="" TNM=TNM+1

 . ;I TNM=TOT Q

 . I '$D(M) S MEDIAN="^"

 . I $D(M) D MEDIAN(.M,.MEDIAN)

 . S DTI=""

 . F  S DTI=$O(Z(DTI),-1) Q:DTI=""  S DDATA=DDATA_Z(DTI)_U

 . S DDATA=DDATA_MEDIAN

 . S @DATA@(II)=$$TKO^BQIUL1(DDATA,U)_$C(30)

 . S DDATA=SAME

 . S II=II+1

 . K Z,M

 . S FAC=$$HME^BQIGPUTL()

 . D RSF

 S @DATA@(II)=$C(31)

 K Z

 Q

 ;

RSF ;EP - Reset dates for facility

 S DATE=$S(TMFRAME'="":RTHRU+1,1:""),QDF=0

 F  S DATE=$O(^BQIFAC(FAC,30,"AB",DATE),-1) Q:DATE=""!(QDF)  D

 . S Z(DATE)="N/A^Not Applicable"

 . I DATE=$G(RFROM) S QDF=1 Q

 . I DATE<$G(RFROM) K Z(DATE) S QDF=1 Q

 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," ")," ")

 ;

TEAM(DATA,TEAM,TMFRAME,CRIPC) ;EP - BQI GET IPC TEAM MONTHLY

 NEW UID,II,HDR,C1,C2,C3,C4,NAME,HEAD,HX,PEC,SORT,QFL,PCT,CT,DDATA

 NEW CPER,PPER,TIT,BQMON,DATE,TAB,STAB,TNM,FAC,QDF,RFROM,PPIEN,TYPE,RTHRU

 S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)

 S DATA=$NA(^TMP("BQIITEAM",UID))

 K @DATA

 S II=0

 NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIIPCM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2

 ; Get current IPC

 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 TMFRAME=$G(TMFRAME,"") I TMFRAME="Ever" S TMFRAME=""

 I TMFRAME'="" D

 . I TMFRAME?.N S TMFRAME=$P(^BQI(90506.9,TMFRAME,0),"^",1)

 . S PPIEN="IPC",TYPE="IPMRANGE"

 . D RANGE^BQIDCAH1(TMFRAME,PPIEN,TYPE)

 ;

 K Z

 S HDR="T00050TEAM^T00075IPC_MEAS^T00030CATEGORY^T00005PERCENT_GOAL^"

 S FAC=$$HME^BQIGPUTL()

 S DATE=$S(TMFRAME'="":RTHRU+1,1:""),QDF=0

 F  S DATE=$O(^BQITEAM("AB",DATE),-1) Q:DATE=""!(QDF)  D

 . S Z(DATE)="N/A^Not Applicable"

 . I DATE=$G(RFROM) S QDF=1 Q

 . I DATE<$G(RFROM) K Z(DATE) S QDF=1 Q

 S DATE="" F  S DATE=$O(Z(DATE),-1) Q:DATE=""  D HH(DATE)

 S HDR=HDR_"T00004MEDIAN"

 S @DATA@(II)=$$TKO^BQIUL1(HDR,"^")_$C(30)

 ;

 S (C1,C2,C3,C4,CT,PCT)=0

 S TEAM=$G(TEAM,"")

 I TEAM'="" D  G DONE

 . S TEAM=$O(^BQITEAM("B",TEAM,"")) I TEAM="" Q

 . D RTM(TEAM)

 I TEAM="" S TEAM=+TEAM

 F  S TEAM=$O(^BQITEAM(TEAM)) Q:'TEAM  D

 . I $D(^BQITEAM(TEAM,10)) D RTM(TEAM)

 S II=II+1,@DATA@(II)=$C(31)

 K Z,M

 Q

 ;

RTM(TMN) ;EP

 S DDATA=""

 S TEM=TMN_$C(28)_$P($G(^BQITEAM(TMN,0)),U,1)

 S DDATA=TEM_U

 S CYR=$E(DT,1,3)

 S ORD=""

 F  S ORD=$O(^BQI(90508,1,22,CRN,1,"C",ORD)) Q:ORD=""  D

 . S IDD="",QFL=0

 . 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 S QFL=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'="T" S QFL=1 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 DDATA=DDATA_ID_$C(28)_MEAS_U_CAT_U_GOAL_U

 .. S IDN=$O(^BQITEAM(TMN,10,"B",ID,"")) I IDN="" Q

 .. S DTI="",MC=0

 .. F  S DTI=$O(Z(DTI)) Q:DTI=""  D

 ... S MSDN=$O(^BQITEAM(TMN,10,IDN,10,"B",DTI,""))

 ... I MSDN="" S Z(DTI)="N/A^Not Applicable" Q

 ... ;S DEN=+$P(^BQITEAM(TMN,10,IDN,10,MSDN,0),U,2),NUM=+$P(^BQITEAM(TMN,10,IDN,10,MSDN,0),U,3)

 ... I ID="IPC_TOTP" D  Q

 .... I MSDN="" S Z(DTI)="N/A^Not Applicable" Q

 ... S DEN=+$P(^BQITEAM(TMN,10,IDN,10,MSDN,0),U,2),NUM=+$P(^BQITEAM(TMN,10,IDN,10,MSDN,0),U,3),MC=MC+1

 ... I ID="IPC_TOTP" D  Q

 .... S Z(DTI)=DEN_"^Total Patients: "_DEN

 ... I ID="IPC_REVG" D  Q

 .... I DEN=0 S Z(DTI)="$0^Visits: 0 Billed: 0" Q

 .... I DEN'=0,NUM=0 S Z(DTI)="$0^Visits: 0 Billed: 0" Q

 .... I DEN'=0,NUM'=0 S Z(DTI)=$$DOL(NUM/DEN)_U_"Visits: "_DEN_" Billed: "_$$DOL(NUM) Q

 ... I DEN=0 S Z(DTI)="0%^Numerator: 0 Denominator: 0",M(0,MC)="" Q

 ... I DEN'=0,NUM=0 S Z(DTI)="0%^Numerator: 0 Denominator: "_DEN,M(0,MC)="" Q

 ... I NUM'=0 D

 .... S VAL=$J((NUM/DEN)*100,3,0),M($$TRIM^BQIUL1(VAL," "),MC)=""

 .... S VAL=$$TRIM^BQIUL1(VAL," ")_"%"

 .... S Z(DTI)=VAL_U_"Numerator: "_NUM_" Denominator: "_DEN

 ... S MSDN=$O(^BQITEAM(TMN,10,IDN,10,"B",DTI,""))

 . I QFL Q  ;

 . ;S DTI="",TOT=0,TNM=0 F  S DTI=$O(Z(DTI)) Q:DTI=""  S TOT=TOT+1 S:Z(DTI)="" TNM=TNM+1

 . ;I TNM=TOT Q

 . I '$D(M) S MEDIAN="^"

 . I $D(M) D MEDIAN(.M,.MEDIAN)

 . S DTI=""

 . F  S DTI=$O(Z(DTI),-1) Q:DTI=""  S DDATA=DDATA_Z(DTI)_U

 . S DDATA=DDATA_MEDIAN

 . S DDATA=$$TKO^BQIUL1(DDATA,"^")

 . S II=II+1,@DATA@(II)=DDATA_$C(30)

 . K Z,M

 . S DDATA=TEM_U

 . S FAC=$$HME^BQIGPUTL()

 . S DATE=$S(TMFRAME'="":RTHRU+1,1:""),QDF=0

 . F  S DATE=$O(^BQITEAM("AB",DATE),-1) Q:DATE=""!(QDF)  D

 .. S Z(DATE)="N/A^Not Applicable"

 .. I DATE=$G(RFROM) S QDF=1 Q

 .. I DATE<$G(RFROM) K Z(DATE) S QDF=1 Q

 Q

 ;

MEDIAN(MM,MEDIAN) ;EP - Find Median value

 NEW N,CT,NN,QQF

 S MEDIAN=""

 S N="",CT=0,QQF=0

 F  S N=$O(MM(N)) Q:N=""  D  Q:QQF

 . S NN="" F  S NN=$O(MM(N,NN)) Q:NN=""  S CT=CT+1

 I CT=1 S MEDIAN=$O(MM("")),QQF=1 Q

 S OEVN=CT#2,ODD=1

 I 'OEVN S ODD=0

 ;

 S N="",T=0

 I ODD D  Q

 . S QFF=0

 . F  S N=$O(MM(N)) Q:N=""  D  Q:QFF

 .. S NN="" F  S NN=$O(MM(N,NN)) Q:NN=""  D  Q:QFF

 ... S T=T+1 I T=((CT\2)+1) S MEDIAN=N,QFF=1 Q

 ;

 I 'ODD D

 . S T1=(CT\2),T2=T1+1,QFF=0

 . F  S N=$O(MM(N)) Q:N=""  D  Q:QFF

 .. S NN="" F  S NN=$O(MM(N,NN)) Q:NN=""  S T=T+1 D  Q:QFF

 ... I T=T1 S V1=N Q

 ... I T=T2 S V2=N S QFF=1

 . S MEDIAN=(V1+V2)/2

 Q

BQIIPCM   ;VNGT/HS/ALA-Get IPC Monthly Data by Provider ; 17 Jun 2011  12:38 PM

 +1       ;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12

 +2       ;

 +3       ;

RET(DATA,PROV,TMFRAME,CRIPC) ;EP -- BQI GET IPC PROV MONTHLY

 +1        NEW UID,II,HDR,C1,C2,C3,C4,NAME,HEAD,HX,PEC,SORT,QFL,PCT,CT,DDATA,TRM

 +2        NEW CPER,PPER,TIT,BQMON,DATE,TAB,STAB,TNM,FAC,QDF,RFROM,PPIEN,TYPE,RTHRU

 +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       ; Get current IPC

 +9        SET CRIPC=$GET(CRIPC,"")

 +10       IF CRIPC=""

               SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)

 +11       SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))

           IF CRN=""

               QUIT 

 +12      ;

 +13       SET TMFRAME=$GET(TMFRAME,"")

           IF TMFRAME="Ever"

               SET TMFRAME=""

 +14       IF TMFRAME'=""

               Begin DoDot:1

 +15               IF TMFRAME?.N

                       SET TMFRAME=$PIECE(^BQI(90506.9,TMFRAME,0),"^",1)

 +16               SET PPIEN="IPC"

                   SET TYPE="IPMRANGE"

 +17               DO RANGE^BQIDCAH1(TMFRAME,PPIEN,TYPE)

               End DoDot:1

 +18      ;

 +19       KILL Z

 +20       SET HDR="T00050PROVIDER^T00075IPC_MEAS^T00030CATEGORY^T00005PERCENT_GOAL^"

 +21       SET FAC=$$HME^BQIGPUTL()

 +22       SET DATE=$SELECT(TMFRAME'="":RTHRU+1,1:"")

           SET QDF=0

 +23       FOR 

               SET DATE=$ORDER(^BQIPROV("AD",DATE),-1)

               IF DATE=""!(QDF)

                   QUIT 

               Begin DoDot:1

 +24               SET Z(DATE)="N/A^Not Applicable"

 +25               IF DATE=$GET(RFROM)

                       SET QDF=1

                       QUIT 

 +26               IF DATE<$GET(RFROM)

                       KILL Z(DATE)

                       SET QDF=1

                       QUIT 

               End DoDot:1

 +27       SET DATE=""

           FOR 

               SET DATE=$ORDER(Z(DATE),-1)

               IF DATE=""

                   QUIT 

               DO HH(DATE)

 +28       SET HDR=HDR_"T00004MEDIAN"

 +29       SET @DATA@(II)=$$TKO^BQIUL1(HDR,"^")_$CHAR(30)

 +30      ;

 +31       SET (C1,C2,C3,C4,CT,PCT)=0

 +32       SET PROV=$GET(PROV,"")

 +33       IF PROV'=""

               DO RTE(PROV)

               GOTO DONE

 +34       IF PROV=""

               SET PROV=+PROV

 +35       FOR 

               SET PROV=$ORDER(^BQIPROV(PROV))

               IF 'PROV

                   QUIT 

               Begin DoDot:1

 +36               IF $DATA(^BQIPROV(PROV,30))

                       DO RTE(PROV)

               End DoDot:1

 +37      ;

DONE      ;

 +1        SET II=II+1

           SET @DATA@(II)=$CHAR(31)

 +2        KILL Z

 +3        QUIT 

 +4       ;

HH(DATE)  ;EP

 +1        SET BQMON=$EXTRACT(DATE,4,5)

 +2        SET TIT=$PIECE($TEXT(MON+BQMON^BQIIPUTL),";;",2)_"_"_(1700+$EXTRACT(DATE,1,3))

 +3        SET HDR=HDR_"T00030"_TIT_U_"T00045HIDE_"_TIT_U

 +4        QUIT 

 +5       ;

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 DDATA=""

           SET TRM=0

 +2        IF $PIECE($GET(^VA(200,PRV,0)),U,13)'=""

               SET TRM=1

 +3        SET PRVR=PRV_$CHAR(28)_$SELECT(TRM:"*",1:"")_$PIECE($GET(^VA(200,PRV,0)),U,1)

 +4        SET DDATA=PRVR_U

 +5        SET CYR=$EXTRACT(DT,1,3)

 +6        SET ORD=""

 +7        FOR 

               SET ORD=$ORDER(^BQI(90508,1,22,CRN,1,"C",ORD))

               IF ORD=""

                   QUIT 

               Begin DoDot:1

 +8                SET IDD=""

                   SET QFL=0

 +9                FOR 

                       SET IDD=$ORDER(^BQI(90508,1,22,CRN,1,"C",ORD,IDD))

                       IF IDD=""