BQIIPWKL ;GDIT/HCSD/ALA-Update Weekly ; 18 Sep 2017 9:04 AM
;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
;
;
EN ;EP - IPC calculations
;
NEW BQMON,CYR,PYR,YR,TMFRAME,CRIPC,CRN,MSN,IDATA,CODE,TYP,BARDUZ2
NEW BCODE,BCT,BEGDT,BN,BQDTE,CD,CNT,DEN,DFN,EDAY,ENDT,EXEC,FAC,IEN
NEW NUM,PCT,PDEN,PNUM,PRV,QFL,TDEN,TNUM,TP,XX,Y,CRST,BQDA,PROW
NEW CDOW,BQFROM,BQTHRU
;
S QFL=0
;
; Get current IPC
S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
;I CRIPC'="IPCMH" Q
S CRIPC="IPCMH"
S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" G CHK
;
; Set the WEEKLY Date Range
S CDOW=$$DOW^XLFDT(DT,1) I CDOW'=0 G CHK
S BQFROM=$$FMADD^XLFDT(DT,-7),BQTHRU=DT,WEEK=1
;
BEG ; Set the DATE/TIME STARTED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA G CHK
S BQIUPD(90508,DA_",",8.04)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",8.06)=1
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
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
. ; If type is RPMS
. I TYP="R" D Q
.. S EXEC=$G(^BQI(90508,1,22,CRN,1,MSN,1)) I EXEC="" Q
.. X EXEC
. ;
. S BQIPROV="",FDEN=0,FNUM=0
. F S BQIPROV=$O(^AUPNPAT("AK",BQIPROV)) Q:BQIPROV="" D
.. I $P(^VA(200,BQIPROV,0),U,13)'="" Q
.. S TDEN=0,TNUM=0
.. S BDFN="" F S BDFN=$O(^AUPNPAT("AK",BQIPROV,BDFN)) Q:BDFN="" D
... S PN=$O(^BQIPAT(BDFN,30,"B",CODE,"")) I PN="" Q
... S NUM=$P(^BQIPAT(BDFN,30,PN,0),"^",3),DEN=$P(^(0),"^",4)
... S TDEN=TDEN+DEN,TNUM=TNUM+NUM,FDEN=FDEN+DEN,FNUM=FNUM+NUM
.. I $G(DEBUG)=1 W !,BQIPROV,"|",CODE,"|",TNUM,"|",TDEN
.. D STORPW^BQIIPUTL(BQIPROV,CODE,BQFROM,BQTHRU,TDEN,TNUM)
. S FAC=$$HME^BQIGPUTL()
. I $G(DEBUG)=1 W !!,FAC,"|",CODE,"|",FNUM,"|",FDEN,!!
. D STORFW^BQIIPUTL(FAC,CODE,BQFROM,BQTHRU,FDEN,FNUM)
;
TEM ;EP - Process teams
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
. ; 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 PN=$O(^BQIPROV(TMM,30,"B",CODE,"")) I PN="" Q
... S WKN=$O(^BQIPROV(TMM,30,PN,2,"AC",BQTHRU,"")) I WKN="" Q
... S NUM=$P(^BQIPROV(TMM,30,PN,2,WKN,0),"^",3),DEN=$P(^(0),"^",2)
... S PDEN=PDEN+DEN,PNUM=PNUM+NUM
.. I $G(DEBUG)=1 W !,TMN,"|",CODE,"|",PNUM,"|",PDEN
.. D STORTW^BQIIPUTL(TEAM,CODE,BQFROM,BQTHRU,PDEN,PNUM)
;
FIN ;EP - Set the DATE/TIME FLAG ENDED field
NEW DA
S DA=$$SPM^BQIGPUTL()
S BQIUPD(90508,DA_",",8.05)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",8.06)="@"
S BQIUPD(90508,"1,",11.06)="@"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
K WEEK
Q
;
CHK ; EP - quit and delete task
S BQIUPD(90508,"1,",11.06)="@"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
Q
BQIIPWKL ;GDIT/HCSD/ALA-Update Weekly ; 18 Sep 2017 9:04 AM
+1 ;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
+2 ;
+3 ;
EN ;EP - IPC calculations
+1 ;
+2 NEW BQMON,CYR,PYR,YR,TMFRAME,CRIPC,CRN,MSN,IDATA,CODE,TYP,BARDUZ2
+3 NEW BCODE,BCT,BEGDT,BN,BQDTE,CD,CNT,DEN,DFN,EDAY,ENDT,EXEC,FAC,IEN
+4 NEW NUM,PCT,PDEN,PNUM,PRV,QFL,TDEN,TNUM,TP,XX,Y,CRST,BQDA,PROW
+5 NEW CDOW,BQFROM,BQTHRU
+6 ;
+7 SET QFL=0
+8 ;
+9 ; Get current IPC
+10 SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
+11 ;I CRIPC'="IPCMH" Q
+12 SET CRIPC="IPCMH"
+13 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
GOTO CHK
+14 ;
+15 ; Set the WEEKLY Date Range
+16 SET CDOW=$$DOW^XLFDT(DT,1)
IF CDOW'=0
GOTO CHK
+17 SET BQFROM=$$FMADD^XLFDT(DT,-7)
SET BQTHRU=DT
SET WEEK=1
+18 ;
BEG ; Set the DATE/TIME STARTED field
+1 NEW DA
+2 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
GOTO CHK
+3 SET BQIUPD(90508,DA_",",8.04)=$$NOW^XLFDT()
+4 SET BQIUPD(90508,DA_",",8.06)=1
+5 DO FILE^DIE("","BQIUPD","ERROR")
+6 KILL BQIUPD
+7 ;
+8 SET MSN=0
+9 FOR
SET MSN=$ORDER(^BQI(90508,1,22,CRN,1,MSN))
IF 'MSN
QUIT
Begin DoDot:1
+10 SET IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
+11 SET CODE=$PIECE(IDATA,U,1)
SET TYP=$PIECE(IDATA,U,2)
+12 ; If inactive, quit
+13 IF $PIECE(IDATA,U,7)=1
QUIT
+14 ; If type is RPMS
+15 IF TYP="R"
Begin DoDot:2
+16 SET EXEC=$GET(^BQI(90508,1,22,CRN,1,MSN,1))
IF EXEC=""
QUIT
+17 XECUTE EXEC
End DoDot:2
QUIT
+18 ;
+19 SET BQIPROV=""
SET FDEN=0
SET FNUM=0
+20 FOR
SET BQIPROV=$ORDER(^AUPNPAT("AK",BQIPROV))
IF BQIPROV=""
QUIT
Begin DoDot:2
+21 IF $PIECE(^VA(200,BQIPROV,0),U,13)'=""
QUIT
+22 SET TDEN=0
SET TNUM=0
+23 SET BDFN=""
FOR
SET BDFN=$ORDER(^AUPNPAT("AK",BQIPROV,BDFN))
IF BDFN=""
QUIT
Begin DoDot:3
+24 SET PN=$ORDER(^BQIPAT(BDFN,30,"B",CODE,""))
IF PN=""
QUIT
+25 SET NUM=$PIECE(^BQIPAT(BDFN,30,PN,0),"^",3)
SET DEN=$PIECE(^(0),"^",4)
+26 SET TDEN=TDEN+DEN
SET TNUM=TNUM+NUM
SET FDEN=FDEN+DEN
SET FNUM=FNUM+NUM
End DoDot:3
+27 IF $GET(DEBUG)=1
WRITE !,BQIPROV,"|",CODE,"|",TNUM,"|",TDEN
+28 DO STORPW^BQIIPUTL(BQIPROV,CODE,BQFROM,BQTHRU,TDEN,TNUM)
End DoDot:2
+29 SET FAC=$$HME^BQIGPUTL()
+30 IF $GET(DEBUG)=1
WRITE !!,FAC,"|",CODE,"|",FNUM,"|",FDEN,!!
+31 DO STORFW^BQIIPUTL(FAC,CODE,BQFROM,BQTHRU,FDEN,FNUM)
End DoDot:1
+32 ;
TEM ;EP - Process teams
+1 SET MSN=0
+2 FOR
SET MSN=$ORDER(^BQI(90508,1,22,CRN,1,MSN))
IF 'MSN
QUIT
Begin DoDot:1
+3 SET IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
+4 SET CODE=$PIECE(IDATA,U,1)
SET TYP=$PIECE(IDATA,U,2)
+5 ; If inactive, quit
+6 IF $PIECE(IDATA,U,7)=1
QUIT
+7 IF CODE="IPC_CCPR"!(CODE="IPC_PEMP")!(CODE="IPC_CCTM")
QUIT
+8 ; Update the team
+9 NEW TMN,TEAM,TMM,OK,TDEN,TNUM,IPRN,IPRD,DEN,NUM
+10 SET TMN=0
+11 FOR
SET TMN=$ORDER(^BSDPCT(TMN))
IF 'TMN
QUIT
Begin DoDot:2
+12 SET TEAM=$PIECE(^BSDPCT(TMN,0),"^",1)
+13 SET TMM=""
SET PDEN=0
SET PNUM=0
FOR
SET TMM=$ORDER(^BSDPCT(TMN,1,"B",TMM))
IF TMM=""
QUIT
Begin DoDot:3
+14 SET PN=$ORDER(^BQIPROV(TMM,30,"B",CODE,""))
IF PN=""
QUIT
+15 SET WKN=$ORDER(^BQIPROV(TMM,30,PN,2,"AC",BQTHRU,""))
IF WKN=""
QUIT
+16 SET NUM=$PIECE(^BQIPROV(TMM,30,PN,2,WKN,0),"^",3)
SET DEN=$PIECE(^(0),"^",2)
+17 SET PDEN=PDEN+DEN
SET PNUM=PNUM+NUM
End DoDot:3
+18 IF $GET(DEBUG)=1
WRITE !,TMN,"|",CODE,"|",PNUM,"|",PDEN
+19 DO STORTW^BQIIPUTL(TEAM,CODE,BQFROM,BQTHRU,PDEN,PNUM)
End DoDot:2
End DoDot:1
+20 ;
FIN ;EP - Set the DATE/TIME FLAG ENDED field
+1 NEW DA
+2 SET DA=$$SPM^BQIGPUTL()
+3 SET BQIUPD(90508,DA_",",8.05)=$$NOW^XLFDT()
+4 SET BQIUPD(90508,DA_",",8.06)="@"
+5 SET BQIUPD(90508,"1,",11.06)="@"
+6 DO FILE^DIE("","BQIUPD","ERROR")
+7 KILL BQIUPD
+8 KILL WEEK
+9 QUIT
+10 ;
CHK ; EP - quit and delete task
+1 SET BQIUPD(90508,"1,",11.06)="@"
+2 DO FILE^DIE("","BQIUPD","ERROR")
+3 KILL BQIUPD
+4 QUIT
