BQIIPSNG ;GDIT/HS/ALA-Update a Single Provider ; 06 Dec 2012 1:18 PM
;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23
;
EN(BQIPROV,BQDATE,CRIPC) ;EP - Monthly
; 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
; Calculate the IPC measures
S MSN=0
F S MSN=$O(^BQI(90508,1,22,CRN,1,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)
. ; If inactive, quit
. I $P(IDATA,U,7)=1 Q
. ; If type is non calculable
. I TYP="N" D NCLC Q
. ; If type is RPMS
. I TYP="R" Q
. ; If type is CRS
. I TYP="G" D CRS Q
. I TYP="M" D MU
;
; Update the Goal Set
NEW TPRN,PRV,TPRD,GPRN,GPRD,DEN,FAC,YEAR
S YEAR=$$GET1^DIQ(90508,1_",",2,"E")
S TPRN=$O(^BQIPROV(BQIPROV,30,"B","IPC_TOTP",""))
I TPRN="" D TOTP
I TPRN'="" S TPRD=$O(^BQIPROV(BQIPROV,30,TPRN,1,"B",BQDATE,""))
I $G(TPRD)="" D
. D TOTP
. S TPRN=$O(^BQIPROV(BQIPROV,30,"B","IPC_TOTP",""))
. I TPRN'="" S TPRD=$O(^BQIPROV(BQIPROV,30,TPRN,1,"B",BQDATE,""))
S GPRN=$O(^BQIPROV(BQIPROV,30,"B",YEAR_"_2452",""))
I GPRN'="" S GPRD=$O(^BQIPROV(BQIPROV,30,GPRN,1,"B",BQDATE,""))
I TPRN'="",TPRD'="" S DEN=$P(^BQIPROV(BQIPROV,30,TPRN,1,TPRD,0),U,2)
I GPRN'="",GPRD'="" S $P(^BQIPROV(BQIPROV,30,GPRN,1,GPRD,0),U,2)=DEN
S $P(^BQIPROV(BQIPROV,2),U,3)=$$NOW^XLFDT()
;
; Update the MU bundles
NEW MPRN,IPRN,IPRD,DEN,NUM,MCOD,MPRD,MBUN
S MPRN=$O(^BQIPROV(BQIPROV,30,"B","IPC_WGT",""))
I MPRN'="" S MPRD=$O(^BQIPROV(BQIPROV,30,MPRN,1,"B",BQDATE,""))
K MBUN
F MCOD="MU_8","MU_6","MU_7" D
. S IPRN=$O(^BQIPROV(BQIPROV,30,"B",MCOD,"")) I IPRN="" Q
. S IPRD=$O(^BQIPROV(BQIPROV,30,IPRN,1,"B",BQDATE,"")) I IPRD="" Q
. S DEN=$P(^BQIPROV(BQIPROV,30,IPRN,1,IPRD,0),U,2),NUM=$P(^(0),U,3)
. S MBUN(+DEN)=+NUM
S DEN=$O(MBUN(""))
S:DEN="" NUM="" S:DEN'="" NUM=MBUN(DEN)
I MPRN'="",MPRD'="" D
. S $P(^BQIPROV(BQIPROV,30,MPRN,1,MPRD,0),U,2)=DEN,$P(^BQIPROV(BQIPROV,30,MPRN,1,MPRD,0),U,3)=NUM
Q
;
NCLC ; No calculation possible
Q
;
CRS ; Get values from BQIPAT
S PRV=BQIPROV,TDEN=0,TNUM=0
S DFN="",PDEN=0,PNUM=0
F S DFN=$O(^AUPNPAT("AK",PRV,DFN)) Q:DFN="" D
. I '$$HRN^BQIUL1(DFN) Q
. S IEN=$O(^BQIPAT(DFN,30,"B",CODE,"")) I IEN="" Q
. S PNUM=PNUM+$P(^BQIPAT(DFN,30,IEN,0),U,3)
. S PDEN=PDEN+$P(^BQIPAT(DFN,30,IEN,0),U,4)
D STORP^BQIIPUTL(PRV,CODE,BQDATE,PDEN,PNUM)
Q
;
MU ; Get values for MU measures
S PRV=BQIPROV,TDEN=0,TNUM=0
NEW BGPBEN,BGPRTYPE,BGP0RPTH,BGPMUT,BGPMUYF,BGPBD,BGPED,BGPTP,BGPINDT
NEW BQTDT,BQTMN,BQIGREF,DFN,CDEN,CNUM,CEXC,NUM,BQTN,MUIND,MUI
S PDEN=0,PNUM=0
; Current
S BGPBEN=3
S BGPRTYPE=4,BGP0RPTH="A",BGPMUT="P",BGPMUYF=90595.11
S (BGPBD,BGPED,BGPTP,BGPINDT)=""
S BGPBD=BEGDT,BGPED=ENDT
S BGPPBD="",BGPPED=""
; Baseline
S BGPBBD=BGPPBD,BGPBED=BGPPED
S BQIGREF=$NA(^TMP("BQICQM",$J)) K @BQIGREF
S MUIND=$P($G(^BGPMUIND(90596.11,$P(CODE,"_",2),0)),U,1) I MUIND="" Q
S BGPIND(MUIND)="",BGPPROV=PRV,MUI=$P(CODE,"_",2)
D BQI^BGPMUEPD(.BQIGREF,BGPPROV)
K CDEN,CNUM,CEXC,NUM
S DFN=""
F S DFN=$O(@BQIGREF@(BGPPROV,DFN)) Q:DFN="" D
. S CDEN=$P($G(@BQIGREF@(BGPPROV,DFN,"C",MUI)),U,1)
. S NUM=$P($G(@BQIGREF@(BGPPROV,DFN,"C",MUI)),U,2)
. I NUM>1,$$FMTE^BQIUL1(NUM)'?.N S NUM=1
. S CNUM=NUM
. S CEXC=$P($G(@BQIGREF@(BGPPROV,DFN,"C",MUI)),U,3)
. S PDEN=PDEN+$G(CDEN),PNUM=PNUM+$G(CNUM)
D STORP^BQIIPUTL(PRV,CODE,BQDATE,PDEN,PNUM)
K BQIND
Q
;
TOTP ;
NEW BQITOTP
S BQITOTP=0
S PIEN="" F S PIEN=$O(^AUPNPAT("AK",BQIPROV,PIEN)) Q:PIEN="" D
. ;I '$$HRN^BQIUL1(PIEN) Q
. S BQITOTP=BQITOTP+1
D STORP^BQIIPUTL(BQIPROV,"IPC_TOTP",BQDATE,BQITOTP,0)
Q
;
MEAS(CRN,MSN,PROV,TEAM,BQDATE,BQFROM,BQTHRU) ;EP - Update a Measure
I $G(BQDATE)'="" S WEEK=""
I $G(BQFROM)'="" S WEEK=1
S DEBUG=1
S IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
S CODE=$P(IDATA,U,1),TYP=$P(IDATA,U,2)
; If inactive, quit
I $P(IDATA,U,7)=1 Q
; If type is non calculable
I TYP="N" Q
; If type is RPMS
I TYP="R" D Q
. S EXEC=$G(^BQI(90508,1,22,CRN,1,MSN,1)) I EXEC="" Q
. X EXEC
. K DEBUG
; If type is CRS
I TYP="G" D Q
. I $G(PROV)'=""!($G(FAC)'="") D Q
.. S BQIPROV="",FDEN=0,FNUM=0
.. F S BQIPROV=$O(^AUPNPAT("AK",BQIPROV)) Q:BQIPROV="" D
... I $P(^VA(200,BQIPROV,0),U,13)'="" Q
... S TDEN=0,TNUM=0
... S BDFN="" F S BDFN=$O(^AUPNPAT("AK",BQIPROV,BDFN)) Q:BDFN="" D
.... S PN=$O(^BQIPAT(BDFN,30,"B",CODE,"")) I PN="" Q
.... S NUM=$P(^BQIPAT(BDFN,30,PN,0),"^",3),DEN=$P(^(0),"^",4)
.... S TDEN=TDEN+DEN,TNUM=TNUM+NUM,FDEN=FDEN+DEN,FNUM=FNUM+NUM
... W !,BQIPROV,"|",CODE,"|",TNUM,"|",TDEN
... ;I WEEK'=1 D STORP^BQIIPUTL(BQIPROV,CODE,BQDATE,TDEN,TNUM)
... ;I WEEK=1 D STORPW^BQIIPUTL(BQIPROV,CODE,BQFROM,BQTHRU,TDEN,TNUM)
.. I $G(FAC)'="" D
... S FAC=$$HME^BQIGPUTL()
... W !!,FAC,"|",CODE,"|",FNUM,"|",FDEN,!!
... ;I WEEK'=1 D STORF^BQIIPUTL(FAC,CODE,BQDATE,FDEN,FNUM)
... ;I WEEK=1 D STORFW^BQIIPUTL(FAC,CODE,BQFROM,BQTHRU,FDEN,FNUM)
. I $G(TEAM)'="" D
.. I TEAM'?.N S TMN=$O(^BSDPCT("B",TEAM,"")) I TMN="" Q
.. I TEAM?.N S TMN=TEAM,TEAM=$P(^BSDPCT(TMN,0),"^",1)
.. S TMM="",PDEN=0,PNUM=0 F S TMM=$O(^BSDPCT(TMN,1,"B",TMM)) Q:TMM="" D
... S DFN="" I $O(^AUPNPAT("AK",TMM,DFN))="" Q
... F S DFN=$O(^AUPNPAT("AK",TMM,DFN)) Q:DFN="" D
.... S PN=$O(^BQIPAT(DFN,30,"B",CODE,"")) I PN="" Q
.... S NUM=$P(^BQIPAT(DFN,30,PN,0),"^",3),DEN=$P(^(0),"^",4)
.... S PDEN=PDEN+DEN,PNUM=PNUM+NUM
.. W !,TMN,"|",CODE,"|",PNUM,"|",PDEN
.. ;I WEEK'=1 D STORT^BQIIPUTL(TEAM,CODE,BQDATE,PDEN,PNUM)
.. ;I WEEK=1 D STORTW^BQIIPUTL(TEAM,CODE,BQFROM,BQTHRU,PDEN,PNUM)
Q
BQIIPSNG ;GDIT/HS/ALA-Update a Single Provider ; 06 Dec 2012 1:18 PM
+1 ;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23
+2 ;
EN(BQIPROV,BQDATE,CRIPC) ;EP - Monthly
+1 ; Get current IPC
+2 SET CRIPC=$GET(CRIPC,"")
+3 IF CRIPC=""
SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
+4 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
QUIT
+5 ; Calculate the IPC measures
+6 SET MSN=0
+7 FOR
SET MSN=$ORDER(^BQI(90508,1,22,CRN,1,MSN))
IF 'MSN
QUIT
Begin DoDot:1
+8 SET IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
+9 SET CODE=$PIECE(IDATA,U,1)
SET TYP=$PIECE(IDATA,U,2)
+10 ; If inactive, quit
+11 IF $PIECE(IDATA,U,7)=1
QUIT
+12 ; If type is non calculable
+13 IF TYP="N"
DO NCLC
QUIT
+14 ; If type is RPMS
+15 IF TYP="R"
QUIT
+16 ; If type is CRS
+17 IF TYP="G"
DO CRS
QUIT
+18 IF TYP="M"
DO MU
End DoDot:1
+19 ;
+20 ; Update the Goal Set
+21 NEW TPRN,PRV,TPRD,GPRN,GPRD,DEN,FAC,YEAR
+22 SET YEAR=$$GET1^DIQ(90508,1_",",2,"E")
+23 SET TPRN=$ORDER(^BQIPROV(BQIPROV,30,"B","IPC_TOTP",""))
+24 IF TPRN=""
DO TOTP
+25 IF TPRN'=""
SET TPRD=$ORDER(^BQIPROV(BQIPROV,30,TPRN,1,"B",BQDATE,""))
+26 IF $GET(TPRD)=""
Begin DoDot:1
+27 DO TOTP
+28 SET TPRN=$ORDER(^BQIPROV(BQIPROV,30,"B","IPC_TOTP",""))
+29 IF TPRN'=""
SET TPRD=$ORDER(^BQIPROV(BQIPROV,30,TPRN,1,"B",BQDATE,""))
End DoDot:1
+30 SET GPRN=$ORDER(^BQIPROV(BQIPROV,30,"B",YEAR_"_2452",""))
+31 IF GPRN'=""
SET GPRD=$ORDER(^BQIPROV(BQIPROV,30,GPRN,1,"B",BQDATE,""))
+32 IF TPRN'=""
IF TPRD'=""
SET DEN=$PIECE(^BQIPROV(BQIPROV,30,TPRN,1,TPRD,0),U,2)
+33 IF GPRN'=""
IF GPRD'=""
SET $PIECE(^BQIPROV(BQIPROV,30,GPRN,1,GPRD,0),U,2)=DEN
+34 SET $PIECE(^BQIPROV(BQIPROV,2),U,3)=$$NOW^XLFDT()
+35 ;
+36 ; Update the MU bundles
+37 NEW MPRN,IPRN,IPRD,DEN,NUM,MCOD,MPRD,MBUN
+38 SET MPRN=$ORDER(^BQIPROV(BQIPROV,30,"B","IPC_WGT",""))
+39 IF MPRN'=""
SET MPRD=$ORDER(^BQIPROV(BQIPROV,30,MPRN,1,"B",BQDATE,""))
+40 KILL MBUN
+41 FOR MCOD="MU_8","MU_6","MU_7"
Begin DoDot:1
+42 SET IPRN=$ORDER(^BQIPROV(BQIPROV,30,"B",MCOD,""))
IF IPRN=""
QUIT
+43 SET IPRD=$ORDER(^BQIPROV(BQIPROV,30,IPRN,1,"B",BQDATE,""))
IF IPRD=""
QUIT
+44 SET DEN=$PIECE(^BQIPROV(BQIPROV,30,IPRN,1,IPRD,0),U,2)
SET NUM=$PIECE(^(0),U,3)
+45 SET MBUN(+DEN)=+NUM
End DoDot:1
+46 SET DEN=$ORDER(MBUN(""))
+47 IF DEN=""
SET NUM=""
IF DEN'=""
SET NUM=MBUN(DEN)
+48 IF MPRN'=""
IF MPRD'=""
Begin DoDot:1
+49 SET $PIECE(^BQIPROV(BQIPROV,30,MPRN,1,MPRD,0),U,2)=DEN
SET $PIECE(^BQIPROV(BQIPROV,30,MPRN,1,MPRD,0),U,3)=NUM
End DoDot:1
+50 QUIT
+51 ;
NCLC ; No calculation possible
+1 QUIT
+2 ;
CRS ; Get values from BQIPAT
+1 SET PRV=BQIPROV
SET TDEN=0
SET TNUM=0
+2 SET DFN=""
SET PDEN=0
SET PNUM=0
+3 FOR
SET DFN=$ORDER(^AUPNPAT("AK",PRV,DFN))
IF DFN=""
QUIT
Begin DoDot:1
+4 IF '$$HRN^BQIUL1(DFN)
QUIT
+5 SET IEN=$ORDER(^BQIPAT(DFN,30,"B",CODE,""))
IF IEN=""
QUIT
+6 SET PNUM=PNUM+$PIECE(^BQIPAT(DFN,30,IEN,0),U,3)
+7 SET PDEN=PDEN+$PIECE(^BQIPAT(DFN,30,IEN,0),U,4)
End DoDot:1
+8 DO STORP^BQIIPUTL(PRV,CODE,BQDATE,PDEN,PNUM)
+9 QUIT
+10 ;
MU ; Get values for MU measures
+1 SET PRV=BQIPROV
SET TDEN=0
SET TNUM=0
+2 NEW BGPBEN,BGPRTYPE,BGP0RPTH,BGPMUT,BGPMUYF,BGPBD,BGPED,BGPTP,BGPINDT
+3 NEW BQTDT,BQTMN,BQIGREF,DFN,CDEN,CNUM,CEXC,NUM,BQTN,MUIND,MUI
+4 SET PDEN=0
SET PNUM=0
+5 ; Current
+6 SET BGPBEN=3
+7 SET BGPRTYPE=4
SET BGP0RPTH="A"
SET BGPMUT="P"
SET BGPMUYF=90595.11
+8 SET (BGPBD,BGPED,BGPTP,BGPINDT)=""
+9 SET BGPBD=BEGDT
SET BGPED=ENDT
+10 SET BGPPBD=""
SET BGPPED=""
+11 ; Baseline
+12 SET BGPBBD=BGPPBD
SET BGPBED=BGPPED
+13 SET BQIGREF=$NAME(^TMP("BQICQM",$JOB))
KILL @BQIGREF
+14 SET MUIND=$PIECE($GET(^BGPMUIND(90596.11,$PIECE(CODE,"_",2),0)),U,1)
IF MUIND=""
QUIT
+15 SET BGPIND(MUIND)=""
SET BGPPROV=PRV
SET MUI=$PIECE(CODE,"_",2)
+16 DO BQI^BGPMUEPD(.BQIGREF,BGPPROV)
+17 KILL CDEN,CNUM,CEXC,NUM
+18 SET DFN=""
+19 FOR
SET DFN=$ORDER(@BQIGREF@(BGPPROV,DFN))
IF DFN=""
QUIT
Begin DoDot:1
+20 SET CDEN=$PIECE($GET(@BQIGREF@(BGPPROV,DFN,"C",MUI)),U,1)
+21 SET NUM=$PIECE($GET(@BQIGREF@(BGPPROV,DFN,"C",MUI)),U,2)
+22 IF NUM>1
IF $$FMTE^BQIUL1(NUM)'?.N
SET NUM=1
+23 SET CNUM=NUM
+24 SET CEXC=$PIECE($GET(@BQIGREF@(BGPPROV,DFN,"C",MUI)),U,3)
+25 SET PDEN=PDEN+$GET(CDEN)
SET PNUM=PNUM+$GET(CNUM)
End DoDot:1
+26 DO STORP^BQIIPUTL(PRV,CODE,BQDATE,PDEN,PNUM)
+27 KILL BQIND
+28 QUIT
+29 ;
TOTP ;
+1 NEW BQITOTP
+2 SET BQITOTP=0
+3 SET PIEN=""
FOR
SET PIEN=$ORDER(^AUPNPAT("AK",BQIPROV,PIEN))
IF PIEN=""
QUIT
Begin DoDot:1
+4 ;I '$$HRN^BQIUL1(PIEN) Q
+5 SET BQITOTP=BQITOTP+1
End DoDot:1
+6 DO STORP^BQIIPUTL(BQIPROV,"IPC_TOTP",BQDATE,BQITOTP,0)
+7 QUIT
+8 ;
MEAS(CRN,MSN,PROV,TEAM,BQDATE,BQFROM,BQTHRU) ;EP - Update a Measure
+1 IF $GET(BQDATE)'=""
SET WEEK=""
+2 IF $GET(BQFROM)'=""
SET WEEK=1
+3 SET DEBUG=1
+4 SET IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
+5 SET CODE=$PIECE(IDATA,U,1)
SET TYP=$PIECE(IDATA,U,2)
+6 ; If inactive, quit
+7 IF $PIECE(IDATA,U,7)=1
QUIT
+8 ; If type is non calculable
+9 IF TYP="N"
QUIT
+10 ; If type is RPMS
+11 IF TYP="R"
Begin DoDot:1
+12 SET EXEC=$GET(^BQI(90508,1,22,CRN,1,MSN,1))
IF EXEC=""
QUIT
+13 XECUTE EXEC
+14 KILL DEBUG
End DoDot:1
QUIT
+15 ; If type is CRS
+16 IF TYP="G"
Begin DoDot:1
+17 IF $GET(PROV)'=""!($GET(FAC)'="")
Begin DoDot:2
+18 SET BQIPROV=""
SET FDEN=0
SET FNUM=0
+19 FOR
SET BQIPROV=$ORDER(^AUPNPAT("AK",BQIPROV))
IF BQIPROV=""
QUIT
Begin DoDot:3
+20 IF $PIECE(^VA(200,BQIPROV,0),U,13)'=""
QUIT
+21 SET TDEN=0
SET TNUM=0
+22 SET BDFN=""
FOR
SET BDFN=$ORDER(^AUPNPAT("AK",BQIPROV,BDFN))
IF BDFN=""
QUIT
Begin DoDot:4
+23 SET PN=$ORDER(^BQIPAT(BDFN,30,"B",CODE,""))
IF PN=""
QUIT
+24 SET NUM=$PIECE(^BQIPAT(BDFN,30,PN,0),"^",3)
SET DEN=$PIECE(^(0),"^",4)
+25 SET TDEN=TDEN+DEN
SET TNUM=TNUM+NUM
SET FDEN=FDEN+DEN
SET FNUM=FNUM+NUM
End DoDot:4
+26 WRITE !,BQIPROV,"|",CODE,"|",TNUM,"|",TDEN
+27 ;I WEEK'=1 D STORP^BQIIPUTL(BQIPROV,CODE,BQDATE,TDEN,TNUM)
+28 ;I WEEK=1 D STORPW^BQIIPUTL(BQIPROV,CODE,BQFROM,BQTHRU,TDEN,TNUM)
End DoDot:3
+29 IF $GET(FAC)'=""
Begin DoDot:3
+30 SET FAC=$$HME^BQIGPUTL()
+31 WRITE !!,FAC,"|",CODE,"|",FNUM,"|",FDEN,!!
+32 ;I WEEK'=1 D STORF^BQIIPUTL(FAC,CODE,BQDATE,FDEN,FNUM)
+33 ;I WEEK=1 D STORFW^BQIIPUTL(FAC,CODE,BQFROM,BQTHRU,FDEN,FNUM)
End DoDot:3
End DoDot:2
QUIT
+34 IF $GET(TEAM)'=""
Begin DoDot:2
+35 IF TEAM'?.N
SET TMN=$ORDER(^BSDPCT("B",TEAM,""))
IF TMN=""
QUIT
+36 IF TEAM?.N
SET TMN=TEAM
SET TEAM=$PIECE(^BSDPCT(TMN,0),"^",1)
+37 SET TMM=""
SET PDEN=0
SET PNUM=0
FOR
SET TMM=$ORDER(^BSDPCT(TMN,1,"B",TMM))
IF TMM=""
QUIT
Begin DoDot:3
+38 SET DFN=""
IF $ORDER(^AUPNPAT("AK",TMM,DFN))=""
QUIT
+39 FOR
SET DFN=$ORDER(^AUPNPAT("AK",TMM,DFN))
IF DFN=""
QUIT
Begin DoDot:4
+40 SET PN=$ORDER(^BQIPAT(DFN,30,"B",CODE,""))
IF PN=""
QUIT
+41 SET NUM=$PIECE(^BQIPAT(DFN,30,PN,0),"^",3)
SET DEN=$PIECE(^(0),"^",4)
+42 SET PDEN=PDEN+DEN
SET PNUM=PNUM+NUM
End DoDot:4
End DoDot:3
+43 WRITE !,TMN,"|",CODE,"|",PNUM,"|",PDEN
+44 ;I WEEK'=1 D STORT^BQIIPUTL(TEAM,CODE,BQDATE,PDEN,PNUM)
+45 ;I WEEK=1 D STORTW^BQIIPUTL(TEAM,CODE,BQFROM,BQTHRU,PDEN,PNUM)
End DoDot:2
End DoDot:1
QUIT
+46 QUIT
