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

BQI27POS.m

Go to the documentation of this file. 
  1. BQI27POS ;GDIT/HCD/ALA-Version 2.7 PostInstall ; 20 Jun 2017  11:39 AM
  1.  ;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23
  1.  ;
  1.  ;
  1. EN ;EP
  1.  NEW DA,DIK
  1.  ; Delete Data Dictionary fields
  1.  F DA=.02,.03,.04,.05,.06,.07,.08,.09,1.01,1.02,1.03,1.04,1.05,1.06,1.07,1.08,2.01,2.02 S DIK="^DD(90505.4,",DA(1)=90505.4 D ^DIK
  1.  ;
  1.  F DA=.02,.03,.04,.05,.06,.07,.08,.09,1.01,1.02,1.03,1.04,1.05,1.06,1.07,1.08,2.01,3.01 S DIK="^DD(90505.6,",DA(1)=90505.6 D ^DIK
  1.  ;
  1.  ;Reindex BQIPROV and BQIFAC
  1.  S DIK="^BQIPROV(" D IXALL^DIK
  1.  S DIK="^BQIFAC(" D IXALL^DIK
  1.  ;
  1.  ; Change current IPC to IPC4/IPC5,update Executables
  1.  NEW DA,IENS
  1.  S DA(1)=1,DA=2,IENS=$$IENS^DILF(.DA)
  1.  S BQIUP(90508.022,IENS,.01)="IPC4/IPC5"
  1.  S BQIUP(90508,"1,",11)="IPC4/IPC5"
  1.  D FILE^DIE("","BQIUP","ERROR")
  1.  S ^BQI(90508,1,22,2,1,2,1)="D EN^BQIIPCCP($G(BQDATE),$G(BQFROM),$G(BQTHRU))"
  1.  S ^BQI(90508,1,22,2,1,3,1)="D EN^BQIIPEMP($G(BQDATE),$G(BQFROM),$G(BQTHRU))"
  1.  S ^BQI(90508,1,22,2,1,4,1)="D EN^BQIIPBNL(CRN,MSN,$G(BQDATE),CODE,$G(BQFROM),$G(BQTHRU))"
  1.  S ^BQI(90508,1,22,2,1,5,1)="D EN^BQIIPBNL(CRN,MSN,$G(BQDATE),CODE,$G(BQFROM),$G(BQTHRU))"
  1.  S ^BQI(90508,1,22,2,1,51,1)="D EN^BQIIPBNL(CRN,MSN,$G(BQDATE),CODE,$G(BQFROM),$G(BQTHRU))"
  1.  S ^BQI(90508,1,22,2,1,56,1)="D EN^BQIIPBNL(CRN,MSN,$G(BQDATE),CODE,$G(BQFROM),$G(BQTHRU))"
  1.  S ^BQI(90508,1,22,2,1,59,1)="D EN^BQIIPBNL(CRN,MSN,$G(BQDATE),CODE,$G(BQFROM),$G(BQTHRU))"
  1.  ;
  1.  ; Set BTPWRPC and BUSARPC into BQIRPC
  1.  NEW IEN,DA,X,DIC,Y
  1.  S DA(1)=$$FIND1^DIC(19,"","B","BQIRPC","","","ERROR"),DIC="^DIC(19,"_DA(1)_",10,",DIC(0)="LMNZ"
  1.  I $G(^DIC(19,DA(1),10,0))="" S ^DIC(19,DA(1),10,0)="^19.01IP^^"
  1.  S X="BTPWRPC"
  1.  D ^DIC I +Y<1 K DO,DD D FILE^DICN
  1.  NEW IEN,DA,X,DIC,Y
  1.  S DA(1)=$$FIND1^DIC(19,"","B","BQIRPC","","","ERROR"),DIC="^DIC(19,"_DA(1)_",10,",DIC(0)="LMNZ"
  1.  I $G(^DIC(19,DA(1),10,0))="" S ^DIC(19,DA(1),10,0)="^19.01IP^^"
  1.  S X="BUSARPC"
  1.  D ^DIC I +Y<1 K DO,DD D FILE^DICN
  1.  ;
  1.  ;Add new IPC Medical Home
  1.  D ^BQIIPCHM
  1.  ;Set the version number
  1.  NEW DA
  1.  S DA=$O(^BQI(90508,0))
  1.  S BQIUPD(90508,DA_",",.08)="2.7.0.5"
  1.  S BQIUPD(90508,DA_",",.09)="2.7.0.5"
  1.  D FILE^DIE("","BQIUPD","ERROR")
  1.  K BQIUPD
  1.  ;
  1. GLS ;Update glossary
  1.  NEW GN,GNM,GSN,BQIUPD
  1.  S GN=0
  1.  F  S GN=$O(^BQI(90509.9,GN)) Q:'GN  D
  1.  . S GNM=$P(^BQI(90509.9,GN,0),U,1)
  1.  . S GSN=$O(^BQI(90508.2,"B",GNM,"")) Q:GSN=""
  1.  . S BQIUPD(90508.2,GSN_",",1)="@"
  1.  . D FILE^DIE("","BQIUPD","ERROR")
  1.  . M ^BQI(90508.2,GSN,1)=^BQI(90509.9,GN,1)
  1.  ;
  1. JBW ; Job off weekly data for the past week
  1.  NEW ZTDTH,ZTDESC,ZTRTN,ZTIO,ZTSAVE,BQIUPD
  1.  S ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT(),,,3)
  1.  S ZTDESC="IPC Weekly Compile",ZTRTN="WEEK^BQI27POS",ZTIO=""
  1.  D ^%ZTLOAD
  1.  S BQIUPD(90508,"1,",11.06)=ZTSK
  1.  D FILE^DIE("","BQIUPD","ERROR")
  1.  Q
  1.  ;
  1. WEEK ;EP - Set up the most recent past week of data
  1.  S CRIPC="IPCMH"
  1.  S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
  1.  ;
  1.  ; Set the WEEKLY Date Range for the previous week
  1.  S CDOW=$$DOW^XLFDT(DT,1) I CDOW'=0 D
  1.  . S DFL=0
  1.  . F I=1:1 Q:DFL  D  Q:DFL
  1.  .. S WDATE=$$FMADD^XLFDT(DT,-I),CDOW=$$DOW^XLFDT(WDATE,1)
  1.  .. I CDOW=0 S BQTHRU=WDATE,BQFROM=$$FMADD^XLFDT(WDATE,-7),DFL=1
  1.  ;
  1.  I $D(^BQITEAM("AC",BQTHRU)) Q
  1.  ;
  1.  S WEEK=1
  1.  S MSN=0 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")!(CODE="IPC_CCTM") 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 DFN="",PDEN=0,PNUM=0
  1.  .. F  S DFN=$O(^AUPNPAT("AK",PRV,DFN)) Q:DFN=""  D
  1.  ... S IPRN=$O(^BQIPAT(DFN,30,"B",CODE,"")) I IPRN="" Q
  1.  ... S DEN=$P(^BQIPAT(DFN,30,IPRN,0),U,4),NUM=$P(^(0),U,3)
  1.  ... S PNUM=PNUM+NUM,PDEN=PDEN+DEN,TDEN=TDEN+DEN,TNUM=TNUM+NUM
  1.  .. I $G(DEBUG)=1 W !,PRV,"|",CODE,"|",PDEN,"|",PNUM
  1.  .. D STORPW^BQIIPUTL(PRV,CODE,BQFROM,BQTHRU,PDEN,PNUM)
  1.  . S FAC=$$HME^BQIGPUTL()
  1.  . D STORFW^BQIIPUTL(FAC,CODE,BQFROM,BQTHRU,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.  . I CODE="IPC_CCTM" S WEEK=1 D EN^BQIIPCCT($G(BQDATE),$G(BQFROM),$G(BQTHRU)) Q
  1.  . ; Update the team
  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.  .. S TEAM=$P(^BSDPCT(TMN,0),"^",1)
  1.  .. S TMM="",PDEN=0,PNUM=0
  1.  .. F  S TMM=$O(^BSDPCT(TMN,1,"B",TMM)) Q:TMM=""  D
  1.  ... S DFN="" F  S DFN=$O(^AUPNPAT("AK",TMM,DFN)) Q:DFN=""  D
  1.  .... I $P(IDATA,"^",5)="B" D  Q
  1.  ..... S VALUE=$$PT^BQIIPBNL(DFN,CRN,MSN)
  1.  ..... I VALUE="YES" S PDEN=PDEN+1,PNUM=PNUM+1 Q
  1.  ..... I VALUE="NO" S PDEN=PDEN+1,PNUM=PNUM+0 Q
  1.  .... S IPRN=$O(^BQIPAT(DFN,30,"B",CODE,"")) I IPRN="" Q
  1.  .... S DEN=$P(^BQIPAT(DFN,30,IPRN,0),U,4),NUM=$P(^(0),U,3)
  1.  .... S PDEN=PDEN+DEN,PNUM=PNUM+NUM
  1.  .. I $G(DEBUG)=1 W !,TEAM,"|",CODE,"|",PNUM,"|",PDEN
  1.  .. D STORTW^BQIIPUTL(TEAM,CODE,BQFROM,BQTHRU,PDEN,PNUM)
  1.  K WEEK
  1.  ;
  1. MON ;Monthy update
  1.  S BQDATE=$O(^BQI(90508,1,22,2,3,"B",""),-1)
  1.  F CRN=2,3 D
  1.  . S MSN=0 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")!(CODE="IPC_CCTM") 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 DFN="",PDEN=0,PNUM=0
  1.  ... F  S DFN=$O(^AUPNPAT("AK",PRV,DFN)) Q:DFN=""  D
  1.  .... S IPRN=$O(^BQIPAT(DFN,30,"B",CODE,"")) I IPRN="" Q
  1.  .... S DEN=$P(^BQIPAT(DFN,30,IPRN,0),U,4),NUM=$P(^(0),U,3)
  1.  .... S PNUM=PNUM+NUM,PDEN=PDEN+DEN,TDEN=TDEN+DEN,TNUM=TNUM+NUM
  1.  ... I $G(DEBUG)=1 W !,PRV,"|",CODE,"|",PDEN,"|",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.  . ;
  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")!(CODE="IPC_CCTM") 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.  ... 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,"|",BQDATE,"|",TNUM_"/"_TDEN
  1.  ... D STORT^BQIIPUTL(TEAM,CODE,BQDATE,TDEN,TNUM)
  1.  Q