BQI27POS ;GDIT/HCD/ALA-Version 2.7 PostInstall ; 20 Jun 2017 11:39 AM
;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23
;
;
EN ;EP
NEW DA,DIK
; Delete Data Dictionary fields
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
;
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
;
;Reindex BQIPROV and BQIFAC
S DIK="^BQIPROV(" D IXALL^DIK
S DIK="^BQIFAC(" D IXALL^DIK
;
; Change current IPC to IPC4/IPC5,update Executables
NEW DA,IENS
S DA(1)=1,DA=2,IENS=$$IENS^DILF(.DA)
S BQIUP(90508.022,IENS,.01)="IPC4/IPC5"
S BQIUP(90508,"1,",11)="IPC4/IPC5"
D FILE^DIE("","BQIUP","ERROR")
S ^BQI(90508,1,22,2,1,2,1)="D EN^BQIIPCCP($G(BQDATE),$G(BQFROM),$G(BQTHRU))"
S ^BQI(90508,1,22,2,1,3,1)="D EN^BQIIPEMP($G(BQDATE),$G(BQFROM),$G(BQTHRU))"
S ^BQI(90508,1,22,2,1,4,1)="D EN^BQIIPBNL(CRN,MSN,$G(BQDATE),CODE,$G(BQFROM),$G(BQTHRU))"
S ^BQI(90508,1,22,2,1,5,1)="D EN^BQIIPBNL(CRN,MSN,$G(BQDATE),CODE,$G(BQFROM),$G(BQTHRU))"
S ^BQI(90508,1,22,2,1,51,1)="D EN^BQIIPBNL(CRN,MSN,$G(BQDATE),CODE,$G(BQFROM),$G(BQTHRU))"
S ^BQI(90508,1,22,2,1,56,1)="D EN^BQIIPBNL(CRN,MSN,$G(BQDATE),CODE,$G(BQFROM),$G(BQTHRU))"
S ^BQI(90508,1,22,2,1,59,1)="D EN^BQIIPBNL(CRN,MSN,$G(BQDATE),CODE,$G(BQFROM),$G(BQTHRU))"
;
; Set BTPWRPC and BUSARPC into BQIRPC
NEW IEN,DA,X,DIC,Y
S DA(1)=$$FIND1^DIC(19,"","B","BQIRPC","","","ERROR"),DIC="^DIC(19,"_DA(1)_",10,",DIC(0)="LMNZ"
I $G(^DIC(19,DA(1),10,0))="" S ^DIC(19,DA(1),10,0)="^19.01IP^^"
S X="BTPWRPC"
D ^DIC I +Y<1 K DO,DD D FILE^DICN
NEW IEN,DA,X,DIC,Y
S DA(1)=$$FIND1^DIC(19,"","B","BQIRPC","","","ERROR"),DIC="^DIC(19,"_DA(1)_",10,",DIC(0)="LMNZ"
I $G(^DIC(19,DA(1),10,0))="" S ^DIC(19,DA(1),10,0)="^19.01IP^^"
S X="BUSARPC"
D ^DIC I +Y<1 K DO,DD D FILE^DICN
;
;Add new IPC Medical Home
D ^BQIIPCHM
;Set the version number
NEW DA
S DA=$O(^BQI(90508,0))
S BQIUPD(90508,DA_",",.08)="2.7.0.5"
S BQIUPD(90508,DA_",",.09)="2.7.0.5"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
GLS ;Update glossary
NEW GN,GNM,GSN,BQIUPD
S GN=0
F S GN=$O(^BQI(90509.9,GN)) Q:'GN D
. S GNM=$P(^BQI(90509.9,GN,0),U,1)
. S GSN=$O(^BQI(90508.2,"B",GNM,"")) Q:GSN=""
. S BQIUPD(90508.2,GSN_",",1)="@"
. D FILE^DIE("","BQIUPD","ERROR")
. M ^BQI(90508.2,GSN,1)=^BQI(90509.9,GN,1)
;
JBW ; Job off weekly data for the past week
NEW ZTDTH,ZTDESC,ZTRTN,ZTIO,ZTSAVE,BQIUPD
S ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT(),,,3)
S ZTDESC="IPC Weekly Compile",ZTRTN="WEEK^BQI27POS",ZTIO=""
D ^%ZTLOAD
S BQIUPD(90508,"1,",11.06)=ZTSK
D FILE^DIE("","BQIUPD","ERROR")
Q
;
WEEK ;EP - Set up the most recent past week of data
S CRIPC="IPCMH"
S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
;
; Set the WEEKLY Date Range for the previous week
S CDOW=$$DOW^XLFDT(DT,1) I CDOW'=0 D
. S DFL=0
. F I=1:1 Q:DFL D Q:DFL
.. S WDATE=$$FMADD^XLFDT(DT,-I),CDOW=$$DOW^XLFDT(WDATE,1)
.. I CDOW=0 S BQTHRU=WDATE,BQFROM=$$FMADD^XLFDT(WDATE,-7),DFL=1
;
I $D(^BQITEAM("AC",BQTHRU)) Q
;
S WEEK=1
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
. I CODE="IPC_CCPR"!(CODE="IPC_PEMP")!(CODE="IPC_CCTM") Q
. S PRV="",TDEN=0,TNUM=0
. F S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV="" D
.. I $P(^VA(200,PRV,0),U,13)'="" Q
.. S DFN="",PDEN=0,PNUM=0
.. F S DFN=$O(^AUPNPAT("AK",PRV,DFN)) Q:DFN="" D
... S IPRN=$O(^BQIPAT(DFN,30,"B",CODE,"")) I IPRN="" Q
... S DEN=$P(^BQIPAT(DFN,30,IPRN,0),U,4),NUM=$P(^(0),U,3)
... S PNUM=PNUM+NUM,PDEN=PDEN+DEN,TDEN=TDEN+DEN,TNUM=TNUM+NUM
.. I $G(DEBUG)=1 W !,PRV,"|",CODE,"|",PDEN,"|",PNUM
.. D STORPW^BQIIPUTL(PRV,CODE,BQFROM,BQTHRU,PDEN,PNUM)
. S FAC=$$HME^BQIGPUTL()
. D STORFW^BQIIPUTL(FAC,CODE,BQFROM,BQTHRU,TDEN,TNUM)
;
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
. I CODE="IPC_CCPR"!(CODE="IPC_PEMP") Q
. I CODE="IPC_CCTM" S WEEK=1 D EN^BQIIPCCT($G(BQDATE),$G(BQFROM),$G(BQTHRU)) Q
. ; Update the team
. NEW TMN,TEAM,TMM,OK,TDEN,TNUM,IPRN,IPRD,DEN,NUM
. S TMN=0
. F S TMN=$O(^BSDPCT(TMN)) Q:'TMN D
.. S 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="" F S DFN=$O(^AUPNPAT("AK",TMM,DFN)) Q:DFN="" D
.... I $P(IDATA,"^",5)="B" D Q
..... S VALUE=$$PT^BQIIPBNL(DFN,CRN,MSN)
..... I VALUE="YES" S PDEN=PDEN+1,PNUM=PNUM+1 Q
..... I VALUE="NO" S PDEN=PDEN+1,PNUM=PNUM+0 Q
.... S IPRN=$O(^BQIPAT(DFN,30,"B",CODE,"")) I IPRN="" Q
.... S DEN=$P(^BQIPAT(DFN,30,IPRN,0),U,4),NUM=$P(^(0),U,3)
.... S PDEN=PDEN+DEN,PNUM=PNUM+NUM
.. I $G(DEBUG)=1 W !,TEAM,"|",CODE,"|",PNUM,"|",PDEN
.. D STORTW^BQIIPUTL(TEAM,CODE,BQFROM,BQTHRU,PDEN,PNUM)
K WEEK
;
MON ;Monthy update
S BQDATE=$O(^BQI(90508,1,22,2,3,"B",""),-1)
F CRN=2,3 D
. 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
.. I CODE="IPC_CCPR"!(CODE="IPC_PEMP")!(CODE="IPC_CCTM") Q
.. S PRV="",TDEN=0,TNUM=0
.. F S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV="" D
... I $P(^VA(200,PRV,0),U,13)'="" Q
... S DFN="",PDEN=0,PNUM=0
... F S DFN=$O(^AUPNPAT("AK",PRV,DFN)) Q:DFN="" D
.... S IPRN=$O(^BQIPAT(DFN,30,"B",CODE,"")) I IPRN="" Q
.... S DEN=$P(^BQIPAT(DFN,30,IPRN,0),U,4),NUM=$P(^(0),U,3)
.... S PNUM=PNUM+NUM,PDEN=PDEN+DEN,TDEN=TDEN+DEN,TNUM=TNUM+NUM
... I $G(DEBUG)=1 W !,PRV,"|",CODE,"|",PDEN,"|",PNUM
... D STORP^BQIIPUTL(PRV,CODE,BQDATE,PDEN,PNUM)
.. S FAC=$$HME^BQIGPUTL()
.. D STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
. ;
. 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
.. I CODE="IPC_CCPR"!(CODE="IPC_PEMP")!(CODE="IPC_CCTM") Q
.. NEW TMN,TEAM,TMM,OK,TDEN,TNUM,IPRN,IPRD,DEN,NUM
.. S TMN=0
.. F S TMN=$O(^BSDPCT(TMN)) Q:'TMN D
... ; Check inactivation date
... I $P(^BSDPCT(TMN,0),"^",3)'="" Q
... S TEAM=$P(^BSDPCT(TMN,0),"^",1)
... ; Check if the team members has at least one member with patients assigned to them
... S OK=0
... S TMM="" F S TMM=$O(^BSDPCT(TMN,1,"B",TMM)) Q:TMM="" I $O(^AUPNPAT("AK",TMM,""))'="" S OK=1
... I 'OK Q
... S TDEN=0,TNUM=0
... S TMM="" F S TMM=$O(^BSDPCT(TMN,1,"B",TMM)) Q:TMM="" I $O(^AUPNPAT("AK",TMM,""))'="" D
.... I $P(^VA(200,TMM,0),U,13)'="" Q
.... S IPRN=$O(^BQIPROV(TMM,30,"B",CODE,"")) I IPRN="" Q
.... S IPRD=$O(^BQIPROV(TMM,30,IPRN,1,"B",BQDATE,"")) I IPRD="" Q
.... S DEN=$P(^BQIPROV(TMM,30,IPRN,1,IPRD,0),U,2),NUM=$P(^(0),U,3)
.... S TNUM=TNUM+NUM,TDEN=TDEN+DEN
... I $G(DEBUG)=1 W !,TEAM,"|",CODE,"|",BQDATE,"|",TNUM_"/"_TDEN
... D STORT^BQIIPUTL(TEAM,CODE,BQDATE,TDEN,TNUM)
Q
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
+2 ;
+3 ;
EN ;EP
+1 NEW DA,DIK
+2 ; Delete Data Dictionary fields
+3 FOR 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
SET DIK="^DD(90505.4,"
SET DA(1)=90505.4
DO ^DIK
+4 ;
+5 FOR 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
SET DIK="^DD(90505.6,"
SET DA(1)=90505.6
DO ^DIK
+6 ;
+7 ;Reindex BQIPROV and BQIFAC
+8 SET DIK="^BQIPROV("
DO IXALL^DIK
+9 SET DIK="^BQIFAC("
DO IXALL^DIK
+10 ;
+11 ; Change current IPC to IPC4/IPC5,update Executables
+12 NEW DA,IENS
+13 SET DA(1)=1
SET DA=2
SET IENS=$$IENS^DILF(.DA)
+14 SET BQIUP(90508.022,IENS,.01)="IPC4/IPC5"
+15 SET BQIUP(90508,"1,",11)="IPC4/IPC5"
+16 DO FILE^DIE("","BQIUP","ERROR")
+17 SET ^BQI(90508,1,22,2,1,2,1)="D EN^BQIIPCCP($G(BQDATE),$G(BQFROM),$G(BQTHRU))"
+18 SET ^BQI(90508,1,22,2,1,3,1)="D EN^BQIIPEMP($G(BQDATE),$G(BQFROM),$G(BQTHRU))"
+19 SET ^BQI(90508,1,22,2,1,4,1)="D EN^BQIIPBNL(CRN,MSN,$G(BQDATE),CODE,$G(BQFROM),$G(BQTHRU))"
+20 SET ^BQI(90508,1,22,2,1,5,1)="D EN^BQIIPBNL(CRN,MSN,$G(BQDATE),CODE,$G(BQFROM),$G(BQTHRU))"
+21 SET ^BQI(90508,1,22,2,1,51,1)="D EN^BQIIPBNL(CRN,MSN,$G(BQDATE),CODE,$G(BQFROM),$G(BQTHRU))"
+22 SET ^BQI(90508,1,22,2,1,56,1)="D EN^BQIIPBNL(CRN,MSN,$G(BQDATE),CODE,$G(BQFROM),$G(BQTHRU))"
+23 SET ^BQI(90508,1,22,2,1,59,1)="D EN^BQIIPBNL(CRN,MSN,$G(BQDATE),CODE,$G(BQFROM),$G(BQTHRU))"
+24 ;
+25 ; Set BTPWRPC and BUSARPC into BQIRPC
+26 NEW IEN,DA,X,DIC,Y
+27 SET DA(1)=$$FIND1^DIC(19,"","B","BQIRPC","","","ERROR")
SET DIC="^DIC(19,"_DA(1)_",10,"
SET DIC(0)="LMNZ"
+28 IF $GET(^DIC(19,DA(1),10,0))=""
SET ^DIC(19,DA(1),10,0)="^19.01IP^^"
+29 SET X="BTPWRPC"
+30 DO ^DIC
IF +Y<1
KILL DO,DD
DO FILE^DICN
+31 NEW IEN,DA,X,DIC,Y
+32 SET DA(1)=$$FIND1^DIC(19,"","B","BQIRPC","","","ERROR")
SET DIC="^DIC(19,"_DA(1)_",10,"
SET DIC(0)="LMNZ"
+33 IF $GET(^DIC(19,DA(1),10,0))=""
SET ^DIC(19,DA(1),10,0)="^19.01IP^^"
+34 SET X="BUSARPC"
+35 DO ^DIC
IF +Y<1
KILL DO,DD
DO FILE^DICN
+36 ;
+37 ;Add new IPC Medical Home
+38 DO ^BQIIPCHM
+39 ;Set the version number
+40 NEW DA
+41 SET DA=$ORDER(^BQI(90508,0))
+42 SET BQIUPD(90508,DA_",",.08)="2.7.0.5"
+43 SET BQIUPD(90508,DA_",",.09)="2.7.0.5"
+44 DO FILE^DIE("","BQIUPD","ERROR")
+45 KILL BQIUPD
+46 ;
GLS ;Update glossary
+1 NEW GN,GNM,GSN,BQIUPD
+2 SET GN=0
+3 FOR
SET GN=$ORDER(^BQI(90509.9,GN))
IF 'GN
QUIT
Begin DoDot:1
+4 SET GNM=$PIECE(^BQI(90509.9,GN,0),U,1)
+5 SET GSN=$ORDER(^BQI(90508.2,"B",GNM,""))
IF GSN=""
QUIT
+6 SET BQIUPD(90508.2,GSN_",",1)="@"
+7 DO FILE^DIE("","BQIUPD","ERROR")
+8 MERGE ^BQI(90508.2,GSN,1)=^BQI(90509.9,GN,1)
End DoDot:1
+9 ;
JBW ; Job off weekly data for the past week
+1 NEW ZTDTH,ZTDESC,ZTRTN,ZTIO,ZTSAVE,BQIUPD
+2 SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT(),,,3)
+3 SET ZTDESC="IPC Weekly Compile"
SET ZTRTN="WEEK^BQI27POS"
SET ZTIO=""
+4 DO ^%ZTLOAD
+5 SET BQIUPD(90508,"1,",11.06)=ZTSK
+6 DO FILE^DIE("","BQIUPD","ERROR")
+7 QUIT
+8 ;
WEEK ;EP - Set up the most recent past week of data
+1 SET CRIPC="IPCMH"
+2 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
QUIT
+3 ;
+4 ; Set the WEEKLY Date Range for the previous week
+5 SET CDOW=$$DOW^XLFDT(DT,1)
IF CDOW'=0
Begin DoDot:1
+6 SET DFL=0
+7 FOR I=1:1
IF DFL
QUIT
Begin DoDot:2
+8 SET WDATE=$$FMADD^XLFDT(DT,-I)
SET CDOW=$$DOW^XLFDT(WDATE,1)
+9 IF CDOW=0
SET BQTHRU=WDATE
SET BQFROM=$$FMADD^XLFDT(WDATE,-7)
SET DFL=1
End DoDot:2
IF DFL
QUIT
End DoDot:1
+10 ;
+11 IF $DATA(^BQITEAM("AC",BQTHRU))
QUIT
+12 ;
+13 SET WEEK=1
+14 SET MSN=0
FOR
SET MSN=$ORDER(^BQI(90508,1,22,CRN,1,MSN))
IF 'MSN
QUIT
Begin DoDot:1
+15 SET IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
+16 SET CODE=$PIECE(IDATA,U,1)
SET TYP=$PIECE(IDATA,U,2)
+17 ; If inactive, quit
+18 IF $PIECE(IDATA,U,7)=1
QUIT
+19 IF CODE="IPC_CCPR"!(CODE="IPC_PEMP")!(CODE="IPC_CCTM")
QUIT
+20 SET PRV=""
SET TDEN=0
SET TNUM=0
+21 FOR
SET PRV=$ORDER(^AUPNPAT("AK",PRV))
IF PRV=""
QUIT
Begin DoDot:2
+22 IF $PIECE(^VA(200,PRV,0),U,13)'=""
QUIT
+23 SET DFN=""
SET PDEN=0
SET PNUM=0
+24 FOR
SET DFN=$ORDER(^AUPNPAT("AK",PRV,DFN))
IF DFN=""
QUIT
Begin DoDot:3
+25 SET IPRN=$ORDER(^BQIPAT(DFN,30,"B",CODE,""))
IF IPRN=""
QUIT
+26 SET DEN=$PIECE(^BQIPAT(DFN,30,IPRN,0),U,4)
SET NUM=$PIECE(^(0),U,3)
+27 SET PNUM=PNUM+NUM
SET PDEN=PDEN+DEN
SET TDEN=TDEN+DEN
SET TNUM=TNUM+NUM
End DoDot:3
+28 IF $GET(DEBUG)=1
WRITE !,PRV,"|",CODE,"|",PDEN,"|",PNUM
+29 DO STORPW^BQIIPUTL(PRV,CODE,BQFROM,BQTHRU,PDEN,PNUM)
End DoDot:2
+30 SET FAC=$$HME^BQIGPUTL()
+31 DO STORFW^BQIIPUTL(FAC,CODE,BQFROM,BQTHRU,TDEN,TNUM)
End DoDot:1
+32 ;
+33 SET MSN=0
+34 FOR
SET MSN=$ORDER(^BQI(90508,1,22,CRN,1,MSN))
IF 'MSN
QUIT
Begin DoDot:1
+35 SET IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
+36 SET CODE=$PIECE(IDATA,U,1)
SET TYP=$PIECE(IDATA,U,2)
+37 ; If inactive, quit
+38 IF $PIECE(IDATA,U,7)=1
QUIT
+39 IF CODE="IPC_CCPR"!(CODE="IPC_PEMP")
QUIT
+40 IF CODE="IPC_CCTM"
SET WEEK=1
DO EN^BQIIPCCT($GET(BQDATE),$GET(BQFROM),$GET(BQTHRU))
QUIT
+41 ; Update the team
+42 NEW TMN,TEAM,TMM,OK,TDEN,TNUM,IPRN,IPRD,DEN,NUM
+43 SET TMN=0
+44 FOR
SET TMN=$ORDER(^BSDPCT(TMN))
IF 'TMN
QUIT
Begin DoDot:2
+45 SET TEAM=$PIECE(^BSDPCT(TMN,0),"^",1)
+46 SET TMM=""
SET PDEN=0
SET PNUM=0
+47 FOR
SET TMM=$ORDER(^BSDPCT(TMN,1,"B",TMM))
IF TMM=""
QUIT
Begin DoDot:3
+48 SET DFN=""
FOR
SET DFN=$ORDER(^AUPNPAT("AK",TMM,DFN))
IF DFN=""
QUIT
Begin DoDot:4
+49 IF $PIECE(IDATA,"^",5)="B"
Begin DoDot:5
+50 SET VALUE=$$PT^BQIIPBNL(DFN,CRN,MSN)
+51 IF VALUE="YES"
SET PDEN=PDEN+1
SET PNUM=PNUM+1
QUIT
+52 IF VALUE="NO"
SET PDEN=PDEN+1
SET PNUM=PNUM+0
QUIT
End DoDot:5
QUIT
+53 SET IPRN=$ORDER(^BQIPAT(DFN,30,"B",CODE,""))
IF IPRN=""
QUIT
+54 SET DEN=$PIECE(^BQIPAT(DFN,30,IPRN,0),U,4)
SET NUM=$PIECE(^(0),U,3)
+55 SET PDEN=PDEN+DEN
SET PNUM=PNUM+NUM
End DoDot:4
End DoDot:3
+56 IF $GET(DEBUG)=1
WRITE !,TEAM,"|",CODE,"|",PNUM,"|",PDEN
+57 DO STORTW^BQIIPUTL(TEAM,CODE,BQFROM,BQTHRU,PDEN,PNUM)
End DoDot:2
End DoDot:1
+58 KILL WEEK
+59 ;
MON ;Monthy update
+1 SET BQDATE=$ORDER(^BQI(90508,1,22,2,3,"B",""),-1)
+2 FOR CRN=2,3
Begin DoDot:1
+3 SET MSN=0
FOR
SET MSN=$ORDER(^BQI(90508,1,22,CRN,1,MSN))
IF 'MSN
QUIT
Begin DoDot:2
+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 CODE="IPC_CCPR"!(CODE="IPC_PEMP")!(CODE="IPC_CCTM")
QUIT
+9 SET PRV=""
SET TDEN=0
SET TNUM=0
+10 FOR
SET PRV=$ORDER(^AUPNPAT("AK",PRV))
IF PRV=""
QUIT
Begin DoDot:3
+11 IF $PIECE(^VA(200,PRV,0),U,13)'=""
QUIT
+12 SET DFN=""
SET PDEN=0
SET PNUM=0
+13 FOR
SET DFN=$ORDER(^AUPNPAT("AK",PRV,DFN))
IF DFN=""
QUIT
Begin DoDot:4
+14 SET IPRN=$ORDER(^BQIPAT(DFN,30,"B",CODE,""))
IF IPRN=""
QUIT
+15 SET DEN=$PIECE(^BQIPAT(DFN,30,IPRN,0),U,4)
SET NUM=$PIECE(^(0),U,3)
+16 SET PNUM=PNUM+NUM
SET PDEN=PDEN+DEN
SET TDEN=TDEN+DEN
SET TNUM=TNUM+NUM
End DoDot:4
+17 IF $GET(DEBUG)=1
WRITE !,PRV,"|",CODE,"|",PDEN,"|",PNUM
+18 DO STORP^BQIIPUTL(PRV,CODE,BQDATE,PDEN,PNUM)
End DoDot:3
+19 SET FAC=$$HME^BQIGPUTL()
+20 DO STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
End DoDot:2
+21 ;
+22 SET MSN=0
+23 FOR
SET MSN=$ORDER(^BQI(90508,1,22,CRN,1,MSN))
IF 'MSN
QUIT
Begin DoDot:2
+24 SET IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
+25 SET CODE=$PIECE(IDATA,U,1)
SET TYP=$PIECE(IDATA,U,2)
+26 ; If inactive, quit
+27 IF $PIECE(IDATA,U,7)=1
QUIT
+28 IF CODE="IPC_CCPR"!(CODE="IPC_PEMP")!(CODE="IPC_CCTM")
QUIT
+29 NEW TMN,TEAM,TMM,OK,TDEN,TNUM,IPRN,IPRD,DEN,NUM
+30 SET TMN=0
+31 FOR
SET TMN=$ORDER(^BSDPCT(TMN))
IF 'TMN
QUIT
Begin DoDot:3
+32 ; Check inactivation date
+33 IF $PIECE(^BSDPCT(TMN,0),"^",3)'=""
QUIT
+34 SET TEAM=$PIECE(^BSDPCT(TMN,0),"^",1)
+35 ; Check if the team members has at least one member with patients assigned to them
+36 SET OK=0
+37 SET TMM=""
FOR
SET TMM=$ORDER(^BSDPCT(TMN,1,"B",TMM))
IF TMM=""
QUIT
IF $ORDER(^AUPNPAT("AK",TMM,""))'=""
SET OK=1
+38 IF 'OK
QUIT
+39 SET TDEN=0
SET TNUM=0
+40 SET TMM=""
FOR
SET TMM=$ORDER(^BSDPCT(TMN,1,"B",TMM))
IF TMM=""
QUIT
IF $ORDER(^AUPNPAT("AK",TMM,""))'=""
Begin DoDot:4
+41 IF $PIECE(^VA(200,TMM,0),U,13)'=""
QUIT
+42 SET IPRN=$ORDER(^BQIPROV(TMM,30,"B",CODE,""))
IF IPRN=""
QUIT
+43 SET IPRD=$ORDER(^BQIPROV(TMM,30,IPRN,1,"B",BQDATE,""))
IF IPRD=""
QUIT
+44 SET DEN=$PIECE(^BQIPROV(TMM,30,IPRN,1,IPRD,0),U,2)
SET NUM=$PIECE(^(0),U,3)
+45 SET TNUM=TNUM+NUM
SET TDEN=TDEN+DEN
End DoDot:4
+46 IF $GET(DEBUG)=1
WRITE !,TEAM,"|",CODE,"|",BQDATE,"|",TNUM_"/"_TDEN
+47 DO STORT^BQIIPUTL(TEAM,CODE,BQDATE,TDEN,TNUM)
End DoDot:3
End DoDot:2
End DoDot:1
+48 QUIT
