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

BQIIPMNU.m

Go to the documentation of this file. 
  1. BQIIPMNU ;GDIT/HS/ALA-Update Monthly ; 24 Jun 2013  8:43 AM
  1.  ;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
  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=@($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.  ;  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.  ; 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.  D PROC
  1.  ;
  1.  I CRIPC="IPC4/IPC5" D
  1.  . S CRIPC="IPCMH",CRN=3 D PROC
  1.  ;
  1.  ; Send the files to the Data Warehouse
  1.  ; Provider List
  1.  D PROV^BQIIPCMF
  1.  ; Measure List
  1.  D MEAS^BQIIPCMF
  1.  ; Data
  1.  D RET^BQIIPCME(.DATA,BQDATE,"")
  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.  S BQIUPD(90508,"1,",11.04)="@"
  1.  D FILE^DIE("","BQIUPD","ERROR")
  1.  K BQIUPD
  1.  Q
  1.  ;
  1. PROC ;EP - Process the data
  1.  I $G(DEBUG)=1 W !,CRIPC
  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.  I CRIPC'="IPCMH" D
  1.  . S QFL=0 F BI=1:1:16 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.  . ;
  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.  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) I $G(DEBUG)=1 W !,IDATA
  1.  . ; If inactive, quit
  1.  . I $P(IDATA,U,7)=1 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.  . ;
  1.  . S BQIPROV=$P($G(^BQI(90508,1,11)),U,3)
  1.  . S TDEN=0,TNUM=0
  1.  . F  S BQIPROV=$O(^AUPNPAT("AK",BQIPROV)) Q:BQIPROV=""  D
  1.  .. I $P(^VA(200,BQIPROV,0),U,13)'="" Q
  1.  .. S MSNN=MSN
  1.  .. D EN^BQIIPSNG(BQIPROV,BQDATE,CRIPC)
  1.  .. S $P(^BQI(90508,1,11),U,3)=BQIPROV,MSN=MSNN
  1.  ;
  1.  S $P(^BQI(90508,1,11),U,3)=""
  1.  ;
  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 CRS, update the facility
  1.  . ;I TYP'="G" Q
  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 IPRN=$O(^BQIPROV(PRV,30,"B",CODE,"")) 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 TNUM=TNUM+NUM,TDEN=TDEN+DEN
  1.  . S FAC=$$HME^BQIGPUTL()
  1.  . I $G(DEBUG)=1 W !,FAC,"|",CODE,"|",BQDATE,"|",TDEN,"|",TNUM
  1.  . D STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
  1.  ;
  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.  . I CODE="IPC_CCPR"!(CODE="IPC_PEMP") Q
  1.  . NEW TMN,TEAM,TMM,OK,TDEN,TNUM,IPRN,IPRD,DEN,NUM
  1.  . S TMN=0
  1.  . F  S TMN=$O(^BSDPCT(TMN)) Q:'TMN  D
  1.  .. ; Check inactivation date
  1.  .. I $P(^BSDPCT(TMN,0),"^",3)'="" Q
  1.  .. S TEAM=$P(^BSDPCT(TMN,0),"^",1)
  1.  .. ; Check if the team members has at least one member with patients assigned to them
  1.  .. S OK=0
  1.  .. S TMM="" F  S TMM=$O(^BSDPCT(TMN,1,"B",TMM)) Q:TMM=""  I $O(^AUPNPAT("AK",TMM,""))'="" S OK=1
  1.  .. I 'OK Q
  1.  .. I CODE="IPC_CCTM" D  Q
  1.  ... S EXEC=$G(^BQI(90508,1,22,CRN,1,MSN,1)) I EXEC="" Q
  1.  ... X EXEC
  1.  .. S TDEN=0,TNUM=0
  1.  .. S TMM="" F  S TMM=$O(^BSDPCT(TMN,1,"B",TMM)) Q:TMM=""  I $O(^AUPNPAT("AK",TMM,""))'="" D
  1.  ... I $P(^VA(200,TMM,0),U,13)'="" Q
  1.  ... S IPRN=$O(^BQIPROV(TMM,30,"B",CODE,"")) I IPRN="" Q
  1.  ... S IPRD=$O(^BQIPROV(TMM,30,IPRN,1,"B",BQDATE,"")) I IPRD="" Q
  1.  ... S DEN=$P(^BQIPROV(TMM,30,IPRN,1,IPRD,0),U,2),NUM=$P(^(0),U,3)
  1.  ... S TNUM=TNUM+NUM,TDEN=TDEN+DEN
  1.  .. I $G(DEBUG)=1 W !,TEAM,"|",CODE,"|",TDEN,"|",TNUM
  1.  .. D STORT^BQIIPUTL(TEAM,CODE,BQDATE,TDEN,TNUM)
  1.  ;
  1. TOT ;EP total up values for MU
  1.  I CRIPC'="IPCMH" D
  1.  . NEW MCOD
  1.  . F MCOD="MU_2","MU_6","MU_7","MU_3","MU_5","MU_8","MU_55","MU_56","MU_57" D
  1.  .. NEW PRV,TDEN,TNUM,IPRN,IPRD,DEN,NUM
  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 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 TDEN=TDEN+DEN,TNUM=TNUM+NUM
  1.  .. S FAC=$$HME^BQIGPUTL()
  1.  .. D STORF^BQIIPUTL(FAC,MCOD,BQDATE,TDEN,TNUM)
  1.  . ;
  1.  . S YEAR=$$GET1^DIQ(90508,1_",",2,"E")
  1.  . S FAC=$$HME^BQIGPUTL()
  1.  . S TPRN=$O(^BQIFAC(FAC,30,"B","IPC_TOTP",""))
  1.  . I TPRN'="" S TPRD=$O(^BQIFAC(FAC,30,TPRN,1,"B",BQDATE,""))
  1.  . S GPRN=$O(^BQIFAC(FAC,30,"B",YEAR_"_2452","")),GPRD=""
  1.  . I GPRN'="" S GPRD=$O(^BQIFAC(FAC,30,GPRN,1,"B",BQDATE,""))
  1.  . I TPRN'="",TPRD'="" D
  1.  .. S DEN=$P(^BQIFAC(FAC,30,TPRN,1,TPRD,0),U,2)
  1.  .. I GPRN=""!(GPRD="") Q
  1.  .. S $P(^BQIFAC(FAC,30,GPRN,1,GPRD,0),U,2)=DEN
  1.  ;
  1.  Q
  1.  ;
  1. CHK ; EP - Check whether the IPC data ran or not
  1.  NEW LPRV,PRDTE
  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.  S PRDTE=$O(^BQI(90508,1,22,CRN,3,"B",BQDATE),-1)
  1.  ; if date has already been set and last provider done
  1.  S LPRV=$O(^AUPNPAT("AK",""),-1)
  1.  I $D(^BQIPROV(LPRV,30,"AB",BQDATE)),$D(^BQI(90508,1,22,CRN,3,"B",BQDATE)) Q
  1.  ; If date not set up
  1.  I '$D(BQI(90508,1,22,CRN,3,"B",BQDATE)) D
  1.  . ; If a provider is still in the queue and the date is the previous date
  1.  . I $P(^BQI(90508,1,11),U,3)="",$P(^BQI(90508,1,11),U,5)=PRDTE S QFL=0 Q
  1.  Q
  1.  ;
  1. ROW ;
  1.  ;;06^314^71
  1.  ;;07^314^72
  1.  ;;08^314^73
  1.  ;;09^314^74
  1.  ;;10^314^75
  1.  ;;11^314^76
  1.  ;;12^314^77
  1.  ;;01^315^78
  1.  ;;02^315^79
  1.  ;;03^315^80
  1.  ;;04^315^81
  1.  ;;05^315^82
  1.  ;;06^315^83
  1.  ;;07^315^84
  1.  ;;08^315^85
  1.  ;;09^315^86
  1.  ;;10^315^87
  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