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

BQIIPMON.m

Go to the documentation of this file. 
  1. BQIIPMON ;VNGT/HS/ALA-IPC Monthly Calculation ; 26 May 2011  8:11 AM
  1.  ;;2.3;ICARE MANAGEMENT SYSTEM;**1,3,4**;Apr 18, 2012;Build 66
  1.  ;
  1.  ;
  1. EN ;EP - IPC calculations
  1.  ; 
  1.  NEW BQMON,CYR,PYR,YR,TMFRAME,CRIPC,CRN,MSN,IDATA,CODE,TYP,BARDUZ2
  1.  NEW BCODE,BCT,BEGDT,BN,BQDTE,CD,CNT,DEN,DFN,EDAY,ENDT,EXEC,FAC,IEN
  1.  NEW NUM,PCT,PDEN,PNUM,PRV,QFL,TDEN,TNUM,TP,XX,Y,CRST,BQDA,PROW
  1.  S QFL=0
  1.  S CRST=$P($G(^BQI(90508,1,11)),U,2) S:CRST="" CRST=1
  1.  S CRST="0"_CRST
  1.  ;
  1.  ; If passing a date in
  1.  I $G(BQDATE)'="" D
  1.  . S BEGDT=$E(BQDATE,1,5)_"01",CYR=$E(BQDATE,1,3),BQMON=$E(BQDATE,4,5)
  1.  . I $L(BQMON)=1 S BQMON="0"_BQMON
  1.  . S EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
  1.  . S ENDT=$E(BQDATE,1,5)_$P(EDAY,U,+BQMON)
  1.  ;
  1.  ; If no date, then if not the designated day of the month, quit
  1.  I $G(BQDATE)="" D  Q:QFL
  1.  . I $E(DT,6,7)'=CRST D CHK Q:QFL
  1.  . S BQMON=$E(DT,4,5),CYR=$E(DT,1,3),PYR=CYR-1
  1.  . S BQDTE=$P($T(BQM+BQMON),";;",2)
  1.  . S BQMON=$P(BQDTE,U,1)
  1.  . I $L(BQMON)=1 S BQMON="0"_BQMON
  1.  . S BEGDT=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_"01"
  1.  . S EDAY="31^"_($$LEAP^XLFDT2($P(BQDTE,U,2))+28)_"^31^30^31^30^31^31^30^31^30^31"
  1.  . S ENDT=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_$P(EDAY,U,+$P(BQDTE,U,1))
  1.  . ;S BQDATE=$S(BQMON="01":PYR,1:CYR)_BQMON_"00"
  1.  . S BQDATE=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_"00"
  1.  ;
  1.  S BQIUPD(90508,"1,",11.05)=BQDATE
  1.  D FILE^DIE("","BQIUPD","ERROR")
  1.  ;
  1.  ; Get current IPC
  1.  S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
  1.  S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
  1.  ;
  1.  ; Set the date
  1.  NEW DA,DIC,X,PRDTE,PRN,ROW,FROW,QFL,RMON,RYEAR,RROW
  1.  I $G(^BQI(90508,1,22,CRN,3,0))="" S ^BQI(90508,1,22,CRN,3,0)="^90508.223D^^"
  1.  S DA(2)=1,DA(1)=CRN,DIC(0)="LMNZ",DLAYGO=90508.223,X=$S($L(BQDATE)=5:BQDATE_"00",1:BQDATE)
  1.  S DIC="^BQI(90508,"_DA(2)_",22,"_DA(1)_",3,"
  1.  D ^DIC
  1.  I Y=-1 K DO,DD D FILE^DICN
  1.  S BQDA=+Y
  1.  S PRDTE=$O(^BQI(90508,1,22,CRN,3,"B",X),-1)
  1.  ;
  1.  S QFL=0 F BI=1:1:13 S FROW=$P($T(ROW+BI),";;",2) D  Q:QFL
  1.  . S RMON=$P(FROW,U,1),RYEAR=$P(FROW,U,2),RROW=$P(FROW,U,3)
  1.  . I $E(BQDATE,1,3)=RYEAR,$E(BQDATE,4,5)=RMON D  Q
  1.  .. S ROW=RROW,QFL=1
  1.  .. S $P(^BQI(90508,1,22,CRN,3,BQDA,0),U,2)=ROW
  1.  I 'QFL D
  1.  . S PRN=$O(^BQI(90508,1,22,CRN,3,"B",PRDTE,""))
  1.  . S PROW=$P(^BQI(90508,1,22,CRN,3,PRN,0),U,2)
  1.  . S ROW=PROW+1
  1.  . S $P(^BQI(90508,1,22,CRN,3,BQDA,0),U,2)=ROW
  1.  ;
  1.  ;  Set the DATE/TIME FLAG STARTED field
  1.  NEW DA
  1.  S DA=$O(^BQI(90508,0)) I 'DA Q
  1.  S BQIUPD(90508,DA_",",8.1)=$$NOW^XLFDT()
  1.  S BQIUPD(90508,DA_",",8.12)=1
  1.  S BQIUPD(90508,DA_",",24.08)=$G(ZTSK)
  1.  D FILE^DIE("","BQIUPD","ERROR")
  1.  K BQIUPD
  1.  ;
  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" D  Q
  1.  .. S EXEC=$G(^BQI(90508,1,22,CRN,1,MSN,1)) I EXEC="" Q
  1.  .. X EXEC
  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 PRV="",YEAR=$$GET1^DIQ(90508,1_",",2,"E")
  1.  F  S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV=""  D
  1.  . I $P(^VA(200,PRV,0),U,13)'="" Q
  1.  . S TPRN=$O(^BQIPROV(PRV,30,"B","IPC_TOTP","")) I TPRN="" Q
  1.  . S TPRD=$O(^BQIPROV(PRV,30,TPRN,1,"B",BQDATE,"")) I TPRD="" Q
  1.  . S GPRN=$O(^BQIPROV(PRV,30,"B",YEAR_"_2452","")) I GPRN="" Q
  1.  . S GPRD=$O(^BQIPROV(PRV,30,GPRN,1,"B",BQDATE,"")) I GPRD="" Q
  1.  . S DEN=$P(^BQIPROV(PRV,30,TPRN,1,TPRD,0),U,2)
  1.  . S $P(^BQIPROV(PRV,30,GPRN,1,GPRD,0),U,2)=DEN
  1.  . S $P(^BQIPROV(PRV,2),U,3)=$$NOW^XLFDT()
  1.  . ; Update the MU bundles
  1.  . NEW MPRN,IPRN,IPRD,DEN,NUM,MCOD,MPRD,MBUN
  1.  . S MPRN=$O(^BQIPROV(PRV,30,"B","IPC_WGT","")) I MPRN="" Q
  1.  . S MPRD=$O(^BQIPROV(PRV,30,MPRN,1,"B",BQDATE,"")) I MPRD="" Q
  1.  . K MBUN
  1.  . F MCOD="MU_6","MU_6","MU_7" D
  1.  .. S IPRN=$O(^BQIPROV(PRV,30,"B",MCOD,"")) I IPRN="" Q
  1.  .. S IPRD=$O(^BQIPROV(PRV,30,IPRN,1,"B",BQDATE,"")) I IPRD="" Q
  1.  .. S DEN=$P(^BQIPROV(PRV,30,IPRN,1,IPRD,0),U,2),NUM=$P(^(0),U,3)
  1.  .. S MBUN(+DEN)=+NUM
  1.  . S DEN=$O(MBUN("")),NUM=MBUN(DEN)
  1.  . S $P(^BQIPROV(PRV,30,MPRN,1,MPRD,0),U,2)=DEN,$P(^BQIPROV(PRV,30,MPRN,1,MPRD,0),U,3)=NUM
  1.  ;
  1.  S FAC=$$HME^BQIGPUTL()
  1.  S TPRN=$O(^BQIFAC(FAC,30,"B","IPC_TOTP","")) I TPRN="" Q
  1.  S TPRD=$O(^BQIFAC(FAC,30,TPRN,1,"B",BQDATE,"")) I TPRD="" Q
  1.  S GPRN=$O(^BQIFAC(FAC,30,"B",YEAR_"_2452","")) I GPRN="" Q
  1.  S GPRD=$O(^BQIFAC(FAC,30,GPRN,1,"B",BQDATE,"")) I GPRD="" Q
  1.  S DEN=$P(^BQIFAC(FAC,30,TPRN,1,TPRD,0),U,2)
  1.  S $P(^BQIFAC(FAC,30,GPRN,1,GPRD,0),U,2)=DEN
  1.  ;
  1.  ;  Set the DATE/TIME FLAG ENDED field
  1.  NEW DA
  1.  S DA=$O(^BQI(90508,0)) I 'DA Q
  1.  S BQIUPD(90508,DA_",",8.11)=$$NOW^XLFDT()
  1.  S BQIUPD(90508,DA_",",8.12)="@"
  1.  S BQIUPD(90508,DA_",",24.08)="@"
  1.  D FILE^DIE("","BQIUPD","ERROR")
  1.  K BQIUPD
  1.  Q
  1.  ;
  1. NCLC ; No calculation possible
  1.  Q
  1.  ;
  1. CRS ; Get values from BQIPAT
  1.  S PRV="",TDEN=0,TNUM=0
  1.  F  S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV=""  D
  1.  . I $P(^VA(200,PRV,0),U,13)'="" Q
  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.  . S TNUM=TNUM+PNUM,TDEN=TDEN+PDEN
  1.  S FAC=$$HME^BQIGPUTL()
  1.  D STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
  1.  Q
  1.  ;
  1. MU ; Get values for MU measures
  1.  S PRV="",TDEN=0,TNUM=0
  1.  F  S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV=""  D
  1.  . I $P(^VA(200,PRV,0),U,13)'="" Q
  1.  . NEW BGPBEN,BGPRTYPE,BGP0RPTH,BGPMUT,BGPMUYF,BGPBD,BGPED,BGPTP,BGPINDT
  1.  . NEW BQTDT,BQTMN,BQIGREF,DFN,CDEN,CNUM,CEXC,NUM,BQTN,MUIND
  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
  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 I=""
  1.  .. F  S I=$O(@BQIGREF@(BGPPROV,DFN,"C",I)) Q:I=""  D
  1.  ... S CDEN=$G(CDEN)+$P($G(@BQIGREF@(BGPPROV,DFN,"C",I)),U,1)
  1.  ... S NUM=$P($G(@BQIGREF@(BGPPROV,DFN,"C",I)),U,2)
  1.  ... I NUM>1,$$FMTE^BQIUL1(NUM)'?.N S NUM=1
  1.  ... S CNUM=$G(CNUM)+NUM
  1.  ... S CEXC=$G(CEXC)+$P($G(@BQIGREF@(BGPPROV,DFN,"C",I)),U,3)
  1.  . S PDEN=PDEN+$G(CDEN),PNUM=PNUM+$G(CNUM),TDEN=TDEN+PDEN,TNUM=TNUM+PNUM
  1.  . D STORP^BQIIPUTL(PRV,CODE,BQDATE,PDEN,PNUM)
  1.  S FAC=$$HME^BQIGPUTL()
  1.  D STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
  1.  K BQIND
  1.  Q
  1.  ;
  1. CHK ; EP - Check whether the IPC data ran or not
  1.  NEW LPRV
  1.  S QFL=1
  1.  I $E(DT,6,7)<CRST Q
  1.  S BQMON=$E(DT,4,5),CYR=$E(DT,1,3),PYR=CYR-1
  1.  S BQDTE=$P($T(BQM+BQMON),";;",2)
  1.  S BQMON=$P(BQDTE,U,1)
  1.  I $L(BQMON)=1 S BQMON="0"_BQMON
  1.  S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
  1.  S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
  1.  S BQDATE=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_"00"
  1.  I $D(^BQI(90508,1,22,CRN,3,"B",BQDATE)) Q
  1.  S LPRV=$O(^AUPNPAT("AK",""),-1)
  1.  I $D(^BQIPROV(LPRV,30,"AB",BQDATE)) Q
  1.  S QFL=0
  1.  Q
  1.  ;
  1. NMS(CDE) ; New measure
  1.  Q
  1.  ;
  1. NTM(PROV) ; New timeframe
  1.  Q
  1.  ;
  1. ROW ;
  1.  ;;08^312^49
  1.  ;;09^312^50
  1.  ;;10^312^51
  1.  ;;11^312^52
  1.  ;;12^312^53
  1.  ;;01^313^54
  1.  ;;02^313^55
  1.  ;;03^313^56
  1.  ;;04^313^57
  1.  ;;05^313^58
  1.  ;;06^313^59
  1.  ;;07^313^60
  1.  ;;08^313^61
  1.  ;;09^313^62
  1.  ;;10^313^63
  1.  ;;11^313^64
  1.  ;;12^313^65
  1.  Q
  1.  ;
  1. BQM ;
  1.  ;;12^PYR
  1.  ;;01^CYR
  1.  ;;02^CYR
  1.  ;;03^CYR
  1.  ;;04^CYR
  1.  ;;05^CYR
  1.  ;;06^CYR
  1.  ;;07^CYR
  1.  ;;08^CYR
  1.  ;;09^CYR
  1.  ;;10^CYR
  1.  ;;11^CYR