Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BQIIPSNG

BQIIPSNG.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. EN(BQIPROV,BQDATE,CRIPC) ;EP - Monthly
  1.  ; Get current IPC
  1.  S CRIPC=$G(CRIPC,"")
  1.  I CRIPC="" S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
  1.  S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
  1.  ; Calculate the IPC measures
  1.  S MSN=0
  1.  F  S MSN=$O(^BQI(90508,1,22,CRN,1,MSN)) Q:'MSN  D
  1.  . S IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
  1.  . S CODE=$P(IDATA,U,1),TYP=$P(IDATA,U,2)
  1.  . ; If inactive, quit
  1.  . I $P(IDATA,U,7)=1 Q
  1.  . ; If type is non calculable
  1.  . I TYP="N" D NCLC Q
  1.  . ; If type is RPMS
  1.  . I TYP="R" Q
  1.  . ; If type is CRS
  1.  . I TYP="G" D CRS Q
  1.  . I TYP="M" D MU
  1.  ;
  1.  ; Update the Goal Set
  1.  NEW TPRN,PRV,TPRD,GPRN,GPRD,DEN,FAC,YEAR
  1.  S YEAR=$$GET1^DIQ(90508,1_",",2,"E")
  1.  S TPRN=$O(^BQIPROV(BQIPROV,30,"B","IPC_TOTP",""))
  1.  I TPRN="" D TOTP
  1.  I TPRN'="" S TPRD=$O(^BQIPROV(BQIPROV,30,TPRN,1,"B",BQDATE,""))
  1.  I $G(TPRD)="" D
  1.  . D TOTP
  1.  . S TPRN=$O(^BQIPROV(BQIPROV,30,"B","IPC_TOTP",""))
  1.  . I TPRN'="" S TPRD=$O(^BQIPROV(BQIPROV,30,TPRN,1,"B",BQDATE,""))
  1.  S GPRN=$O(^BQIPROV(BQIPROV,30,"B",YEAR_"_2452",""))
  1.  I GPRN'="" S GPRD=$O(^BQIPROV(BQIPROV,30,GPRN,1,"B",BQDATE,""))
  1.  I TPRN'="",TPRD'="" S DEN=$P(^BQIPROV(BQIPROV,30,TPRN,1,TPRD,0),U,2)
  1.  I GPRN'="",GPRD'="" S $P(^BQIPROV(BQIPROV,30,GPRN,1,GPRD,0),U,2)=DEN
  1.  S $P(^BQIPROV(BQIPROV,2),U,3)=$$NOW^XLFDT()
  1.  ;
  1.  ; Update the MU bundles
  1.  NEW MPRN,IPRN,IPRD,DEN,NUM,MCOD,MPRD,MBUN
  1.  S MPRN=$O(^BQIPROV(BQIPROV,30,"B","IPC_WGT",""))
  1.  I MPRN'="" S MPRD=$O(^BQIPROV(BQIPROV,30,MPRN,1,"B",BQDATE,""))
  1.  K MBUN
  1.  F MCOD="MU_8","MU_6","MU_7" D
  1.  . S IPRN=$O(^BQIPROV(BQIPROV,30,"B",MCOD,"")) I IPRN="" Q
  1.  . S IPRD=$O(^BQIPROV(BQIPROV,30,IPRN,1,"B",BQDATE,"")) I IPRD="" Q
  1.  . S DEN=$P(^BQIPROV(BQIPROV,30,IPRN,1,IPRD,0),U,2),NUM=$P(^(0),U,3)
  1.  . S MBUN(+DEN)=+NUM
  1.  S DEN=$O(MBUN(""))
  1.  S:DEN="" NUM="" S:DEN'="" NUM=MBUN(DEN)
  1.  I MPRN'="",MPRD'="" D
  1.  . S $P(^BQIPROV(BQIPROV,30,MPRN,1,MPRD,0),U,2)=DEN,$P(^BQIPROV(BQIPROV,30,MPRN,1,MPRD,0),U,3)=NUM
  1.  Q
  1.  ;
  1. NCLC ; No calculation possible
  1.  Q
  1.  ;
  1. CRS ; Get values from BQIPAT
  1.  S PRV=BQIPROV,TDEN=0,TNUM=0
  1.  S DFN="",PDEN=0,PNUM=0
  1.  F  S DFN=$O(^AUPNPAT("AK",PRV,DFN)) Q:DFN=""  D
  1.  . I '$$HRN^BQIUL1(DFN) Q
  1.  . S IEN=$O(^BQIPAT(DFN,30,"B",CODE,"")) I IEN="" Q
  1.  . S PNUM=PNUM+$P(^BQIPAT(DFN,30,IEN,0),U,3)
  1.  . S PDEN=PDEN+$P(^BQIPAT(DFN,30,IEN,0),U,4)
  1.  D STORP^BQIIPUTL(PRV,CODE,BQDATE,PDEN,PNUM)
  1.  Q
  1.  ;
  1. MU ; Get values for MU measures
  1.  S PRV=BQIPROV,TDEN=0,TNUM=0
  1.  NEW BGPBEN,BGPRTYPE,BGP0RPTH,BGPMUT,BGPMUYF,BGPBD,BGPED,BGPTP,BGPINDT
  1.  NEW BQTDT,BQTMN,BQIGREF,DFN,CDEN,CNUM,CEXC,NUM,BQTN,MUIND,MUI
  1.  S PDEN=0,PNUM=0
  1.  ; Current
  1.  S BGPBEN=3
  1.  S BGPRTYPE=4,BGP0RPTH="A",BGPMUT="P",BGPMUYF=90595.11
  1.  S (BGPBD,BGPED,BGPTP,BGPINDT)=""
  1.  S BGPBD=BEGDT,BGPED=ENDT
  1.  S BGPPBD="",BGPPED=""
  1.  ; Baseline
  1.  S BGPBBD=BGPPBD,BGPBED=BGPPED
  1.  S BQIGREF=$NA(^TMP("BQICQM",$J)) K @BQIGREF
  1.  S MUIND=$P($G(^BGPMUIND(90596.11,$P(CODE,"_",2),0)),U,1) I MUIND="" Q
  1.  S BGPIND(MUIND)="",BGPPROV=PRV,MUI=$P(CODE,"_",2)
  1.  D BQI^BGPMUEPD(.BQIGREF,BGPPROV)
  1.  K CDEN,CNUM,CEXC,NUM
  1.  S DFN=""
  1.  F  S DFN=$O(@BQIGREF@(BGPPROV,DFN)) Q:DFN=""  D
  1.  . S CDEN=$P($G(@BQIGREF@(BGPPROV,DFN,"C",MUI)),U,1)
  1.  . S NUM=$P($G(@BQIGREF@(BGPPROV,DFN,"C",MUI)),U,2)
  1.  . I NUM>1,$$FMTE^BQIUL1(NUM)'?.N S NUM=1
  1.  . S CNUM=NUM
  1.  . S CEXC=$P($G(@BQIGREF@(BGPPROV,DFN,"C",MUI)),U,3)
  1.  . S PDEN=PDEN+$G(CDEN),PNUM=PNUM+$G(CNUM)
  1.  D STORP^BQIIPUTL(PRV,CODE,BQDATE,PDEN,PNUM)
  1.  K BQIND
  1.  Q
  1.  ;
  1. TOTP ;
  1.  NEW BQITOTP
  1.  S BQITOTP=0
  1.  S PIEN="" F  S PIEN=$O(^AUPNPAT("AK",BQIPROV,PIEN)) Q:PIEN=""  D
  1.  . ;I '$$HRN^BQIUL1(PIEN) Q
  1.  . S BQITOTP=BQITOTP+1
  1.  D STORP^BQIIPUTL(BQIPROV,"IPC_TOTP",BQDATE,BQITOTP,0)
  1.  Q
  1.  ;
  1. MEAS(CRN,MSN,PROV,TEAM,BQDATE,BQFROM,BQTHRU) ;EP - Update a Measure
  1.  I $G(BQDATE)'="" S WEEK=""
  1.  I $G(BQFROM)'="" S WEEK=1
  1.  S DEBUG=1
  1.  S IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
  1.  S CODE=$P(IDATA,U,1),TYP=$P(IDATA,U,2)
  1.  ; If inactive, quit
  1.  I $P(IDATA,U,7)=1 Q
  1.  ; If type is non calculable
  1.  I TYP="N" Q
  1.  ; If type is RPMS
  1.  I TYP="R" D  Q
  1.  . S EXEC=$G(^BQI(90508,1,22,CRN,1,MSN,1)) I EXEC="" Q
  1.  . X EXEC
  1.  . K DEBUG
  1.  ; If type is CRS
  1.  I TYP="G" D  Q
  1.  . I $G(PROV)'=""!($G(FAC)'="") D  Q
  1.  .. S BQIPROV="",FDEN=0,FNUM=0
  1.  .. F  S BQIPROV=$O(^AUPNPAT("AK",BQIPROV)) Q:BQIPROV=""  D
  1.  ... I $P(^VA(200,BQIPROV,0),U,13)'="" Q
  1.  ... S TDEN=0,TNUM=0
  1.  ... S BDFN="" F  S BDFN=$O(^AUPNPAT("AK",BQIPROV,BDFN)) Q:BDFN=""  D
  1.  .... S PN=$O(^BQIPAT(BDFN,30,"B",CODE,"")) I PN="" Q
  1.  .... S NUM=$P(^BQIPAT(BDFN,30,PN,0),"^",3),DEN=$P(^(0),"^",4)
  1.  .... S TDEN=TDEN+DEN,TNUM=TNUM+NUM,FDEN=FDEN+DEN,FNUM=FNUM+NUM
  1.  ... W !,BQIPROV,"|",CODE,"|",TNUM,"|",TDEN
  1.  ... ;I WEEK'=1 D STORP^BQIIPUTL(BQIPROV,CODE,BQDATE,TDEN,TNUM)
  1.  ... ;I WEEK=1 D STORPW^BQIIPUTL(BQIPROV,CODE,BQFROM,BQTHRU,TDEN,TNUM)
  1.  .. I $G(FAC)'="" D
  1.  ... S FAC=$$HME^BQIGPUTL()
  1.  ... W !!,FAC,"|",CODE,"|",FNUM,"|",FDEN,!!
  1.  ... ;I WEEK'=1 D STORF^BQIIPUTL(FAC,CODE,BQDATE,FDEN,FNUM)
  1.  ... ;I WEEK=1 D STORFW^BQIIPUTL(FAC,CODE,BQFROM,BQTHRU,FDEN,FNUM)
  1.  . I $G(TEAM)'="" D
  1.  .. I TEAM'?.N S TMN=$O(^BSDPCT("B",TEAM,"")) I TMN="" Q
  1.  .. I TEAM?.N S TMN=TEAM,TEAM=$P(^BSDPCT(TMN,0),"^",1)
  1.  .. S TMM="",PDEN=0,PNUM=0 F  S TMM=$O(^BSDPCT(TMN,1,"B",TMM)) Q:TMM=""  D
  1.  ... S DFN="" I $O(^AUPNPAT("AK",TMM,DFN))="" Q
  1.  ... F  S DFN=$O(^AUPNPAT("AK",TMM,DFN)) Q:DFN=""  D
  1.  .... S PN=$O(^BQIPAT(DFN,30,"B",CODE,"")) I PN="" Q
  1.  .... S NUM=$P(^BQIPAT(DFN,30,PN,0),"^",3),DEN=$P(^(0),"^",4)
  1.  .... S PDEN=PDEN+DEN,PNUM=PNUM+NUM
  1.  .. W !,TMN,"|",CODE,"|",PNUM,"|",PDEN
  1.  .. ;I WEEK'=1 D STORT^BQIIPUTL(TEAM,CODE,BQDATE,PDEN,PNUM)
  1.  .. ;I WEEK=1 D STORTW^BQIIPUTL(TEAM,CODE,BQFROM,BQTHRU,PDEN,PNUM)
  1.  Q