BQITASK7 ;GDIT/HS/ALA-MU Performance Job ; 30 Sep 2011 1:06 PM
;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
;
NIN ;EP -- BQI UPDATE MU Performance monthly
;
I $G(DUZ(2))="" D
. D DZ^BQITASK1 M DUZ=^XTMP("BQIRMDR","DUZ")
;
NEW DESC,BJOB,BCJOB,BQPROH
S BQPROH=+$P(^BQI(90508,1,12),U,7)
S BQIMUDTM=$$NOW^XLFDT(),BQIMUDT=$P(BQIMUDTM,".",1),BQIMUTIM=$P(BQIMUDTM,".",2)
S CDOW=$$DOW^XLFDT(BQIMUDT,1)
I CDOW'=6,CDOW'=0,BQPROH,$E(BQIMUTIM,1,2)+1>6,$E(BQIMUTIM,1,2)+1<18 D Q
. S ZTDTH=BQIMUDT_".183"
. S ZTDESC="MU Performance Monthly Compile",ZTRTN="NIN^BQITASK7",ZTIO=""
. D ^%ZTLOAD
. S BQIUPD(90508,"1,",12.06)=ZTSK
. D FILE^DIE("","BQIUPD","ERROR")
. K ZTDESC,ZTRTN,ZTIO,ZTDTH,ZTSK
;
; Set the DATE/TIME MU STARTED field
NEW DA,BQIMUTIM,BQIMUDT,CDOW,BQIMUDTM,STOP
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",8.04)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",8.06)=1
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
K ^XTMP("BQIMUMNPP")
S ^XTMP("BQIMUMNPP",0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"Monthly MU Performance Provider List"
;
S BGPPROV=$P(^BQI(90508,1,12),U,4),BCJOB=$P(^BQI(90508,1,12),U,6)
S STOP=0
F S BGPPROV=$O(^BQI(90508,1,14,"B",BGPPROV)) Q:BGPPROV="" D Q:STOP
. D PMON^BQIMUPRS(BGPPROV)
. S $P(^BQI(90508,1,12),U,4)=BGPPROV
. S ^XTMP("BQIMUMNPP",BGPPROV)=$P(^BQI(90508,1,9),U,1)_U_$P(^BQI(90508,1,9),U,2)
. ; If not prohibited, keep running
. S BQPROH=+$P(^BQI(90508,1,12),U,7)
. I 'BQPROH Q
. ; If prohibited, check the date and time to see if the job needs to stop
. S BQIMUDTM=$$NOW^XLFDT(),BQIMUDT=$P(BQIMUDTM,".",1),BQIMUTIM=$P(BQIMUDTM,".",2)
. ; If it is a holiday, keep running
. I $D(^HOLIDAY("B",DT)) Q
. S CDOW=$$DOW^XLFDT(BQIMUDT,1)
. ; If day of week is Saturday, keeping running even if prohibited
. I CDOW=6 Q
. ; If day of week is Sunday, keeping running even if prohibited
. I CDOW=0 Q
. ;If the time plus 3 hours is less than 6 am or greater than 6 pm keep going
. I $E(BQIMUTIM,1,2)+3<6 Q
. I $E(BQIMUTIM,1,2)+3>18 Q
. S STOP=1
. S ZTDTH=BQIMUDT_".183"
. S ZTDESC="MU Performance Continue Monthly Compile",ZTRTN="NIN^BQITASK7",ZTIO=""
. D ^%ZTLOAD
. S BQIUPD(90508,"1,",12.06)=ZTSK
. D FILE^DIE("","BQIUPD","ERROR")
. K ZTDESC,ZTRTN,ZTIO,ZTDTH,ZTSK
;
HOS ; Hospital CQ
NEW APCMFAC,PGLOB,PROU
S GLOBAL=$NA(^TMP("BQIMUP",$J)) K @GLOBAL
S BGPBD=$P(^BQI(90508,1,9),U,1),BGPED=$P(^BQI(90508,1,9),U,2)
S APCMED=BGPED,APCMBD=BGPBD,APCMRPT=1
S APCMPED=$$FMADD^XLFDT(BGPED,-30),APCMPBD=$$FMADD^XLFDT(BGPBD,-60)
K APCMATTE,APCMIND
S APCMFAC=$$HME^BQIGPUTL(),BQIPROV(APCMFAC)="",APCMRPTT=2,APCMDEMO="E"
K APCMATTE,APCMIND
;F X="S1.009.H","S1.012.H","S1.013.H","S1.014.H","S1.018.H","S1.022.H","S1.023.H","S1.024.H" S APCMATTE(X,APCMFAC)=""
;gather up measures for this report
S PGLOB=$$CURPGL^BQIMUTAB()
S PROU=$$CURPRT^BQIMUTAB()
S X=0 F S X=$O(@PGLOB@(X)) Q:X'=+X I $P(@PGLOB@(X,0),U,2)="H" D
. S ID=$P(@PGLOB@(X,0),U,1)
. I $P(@PGLOB@(X,0),U,6)'="R" Q
. S @GLOBAL@(APCMFAC,ID,"CURR")="",@GLOBAL@(APCMFAC,ID,"PREV")="",APCMATTE(ID,APCMFAC)=""
. S APCMIND(X)=""
;
; Check if connection to server is working
S CONN=1
I PGLOB="^APCM24OB" D PHRC^BQIMUPRS I 'CONN D
. NEW MN
. S MN=$O(@PGLOB@("B","S2.025.H",""))
. I MN'="" K APCMIND(MN)
;
S APCMWPP=1,APCMMETH="E"
;I $T(BQI^APCM11E1)'="" D BQI^APCM11E1(.GLOBAL,.BQIPROV)
D @("BQI^"_PROU_"(.GLOBAL,.BQIPROV)")
;
S FAC=$$HME^BQIGPUTL()
S BGPBD=$P(^BQI(90508,1,9),U,1),BGPED=$P(^BQI(90508,1,9),U,2)
S BQTDT=$E(BGPBD,1,5)_"00"
S BQTMN=$O(^BQIFAC(FAC,40,"B",BQTDT,""))
I BQTMN="" D UPH
; Already data there, don't recalculate and quit
;I $G(^BQIFAC(FAC,40,BQTMN,1,1,0))'="" Q
K CDEN,CNUM,CEXC,PDEN,PNUM,PEXC,CSORT,PSORT,MTOT
D STORH(40)
K @GLOBAL,CSORT,PSORT
;
; Set the DATE/TIME MU STOPPED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",8.05)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",8.06)="@"
S BQIUPD(90508,DA_",",12.04)=+BGPPROV
I +BGPPROV=0 D
. S BMDT=$P(^BQI(90508,1,9),U,1),BMDT=$$FMADD^XLFDT(BMDT,1)
. S BMDT=$E(BMDT,1,5)_"00"
. I $D(^XTMP("BQIMMONP",BMDT)) K ^XTMP("BQIMMONP",BMDT)
. S BQIUPD(90508,DA_",",12.06)="@"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD,APCMMETH
; Create and send export files
Q
;
STORH(NODE) ;
NEW CVALUE,PVALUE,CT,I,MSN,FAC,PGLOB
I '$D(@GLOBAL) Q
S FAC=$$HME^BQIGPUTL()
S PGLOB=$$CURPGL^BQIMUTAB()
;
I NODE=40 D Q
. S ID="",CT=0
. F S ID=$O(@GLOBAL@(FAC,ID)) Q:ID="" D
.. S IIEN=$O(@PGLOB@("B",ID,"")) I IIEN="" Q
.. I $P(@PGLOB@(IIEN,0),"^",2)'="H" Q
.. S CDEN=$P($G(@GLOBAL@(FAC,ID,"CURR")),"^",1),CNUM=$P($G(@GLOBAL@(FAC,ID,"CURR")),"^",2)
.. S CEXC=$P($G(@GLOBAL@(FAC,ID,"CURR")),"^",3)
.. S CT=CT+1,^BQIFAC(FAC,NODE,BQTMN,1,CT,0)=ID_U_CDEN_U_CNUM_U_$$CURREP^BQIMUTAB()
.. I CEXC'="" S ^BQIFAC(FAC,NODE,BQTMN,1,CT,1)=CEXC
.. S ^BQIFAC(FAC,NODE,BQTMN,1,"B",ID,CT)=""
. NEW DIK,DA
. S DIK="^BQIFAC(",DA=FAC D IX^DIK
Q
;
MED(ITM,LIST) ;EP - Find Median for LIST
; Input
; ITM - Which measure to check list for
; LIST - By ITM, the list of sorted values
NEW CNT,MID,CT,PVAL,VAL,TOT,DFN,MED
S CNT=$G(LIST(ITM))
I CNT=1 Q $O(LIST(ITM,""))_U_1
I CNT=2 D Q (TOT/CNT)_U_CNT
. S TOT=0,VAL=""
. F S VAL=$O(LIST(ITM,VAL)) Q:VAL="" D
.. S DFN="" F S DFN=$O(LIST(ITM,VAL,DFN)) Q:DFN="" S TOT=TOT+VAL
;
;S MID=(CNT+1)\2
S MID=CNT\2
S CT=0,VAL="",QFL=0,MED="",TOT=0
F S VAL=$O(LIST(ITM,VAL)) Q:VAL="" D Q:QFL
. S DFN=""
. F S DFN=$O(LIST(ITM,VAL,DFN)) Q:DFN="" D
.. S CT=CT+1,NVAL=$O(LIST(ITM,VAL))
.. I CT=MID S TOT=TOT+VAL+NVAL,MED=(TOT/2),QFL=1 Q
.. S PVAL=VAL
Q MED_U_CNT
;
UPH ;EP Update Hospital
NEW BEGDT,ENDT,TMFRAME,XX,V,I,ERROR,BQIUPD
S BEGDT=$P($G(^BQI(90508,1,9)),U,1),ENDT=$P($G(^BQI(90508,1,9)),U,2)
;
I $G(^BQIFAC(FAC,40,0))="" S ^BQIFAC(FAC,40,0)="^90505.64D^^"
S BQDATE=$E(BEGDT,1,5)_"00"
NEW DA,X,IENS
S DA(1)=FAC,DIC="^BQIFAC("_DA(1)_",40,",X=BQDATE,DIC(0)="LNZ",DLAYGO=90505.64,DIC("P")=DLAYGO
D ^DIC
S DA=+Y I DA=-1 Q
S BQTMN=DA
Q
BQITASK7 ;GDIT/HS/ALA-MU Performance Job ; 30 Sep 2011 1:06 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
+2 ;
NIN ;EP -- BQI UPDATE MU Performance monthly
+1 ;
+2 IF $GET(DUZ(2))=""
Begin DoDot:1
+3 DO DZ^BQITASK1
MERGE DUZ=^XTMP("BQIRMDR","DUZ")
End DoDot:1
+4 ;
+5 NEW DESC,BJOB,BCJOB,BQPROH
+6 SET BQPROH=+$PIECE(^BQI(90508,1,12),U,7)
+7 SET BQIMUDTM=$$NOW^XLFDT()
SET BQIMUDT=$PIECE(BQIMUDTM,".",1)
SET BQIMUTIM=$PIECE(BQIMUDTM,".",2)
+8 SET CDOW=$$DOW^XLFDT(BQIMUDT,1)
+9 IF CDOW'=6
IF CDOW'=0
IF BQPROH
IF $EXTRACT(BQIMUTIM,1,2)+1>6
IF $EXTRACT(BQIMUTIM,1,2)+1<18
Begin DoDot:1
+10 SET ZTDTH=BQIMUDT_".183"
+11 SET ZTDESC="MU Performance Monthly Compile"
SET ZTRTN="NIN^BQITASK7"
SET ZTIO=""
+12 DO ^%ZTLOAD
+13 SET BQIUPD(90508,"1,",12.06)=ZTSK
+14 DO FILE^DIE("","BQIUPD","ERROR")
+15 KILL ZTDESC,ZTRTN,ZTIO,ZTDTH,ZTSK
End DoDot:1
QUIT
+16 ;
+17 ; Set the DATE/TIME MU STARTED field
+18 NEW DA,BQIMUTIM,BQIMUDT,CDOW,BQIMUDTM,STOP
+19 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+20 SET BQIUPD(90508,DA_",",8.04)=$$NOW^XLFDT()
+21 SET BQIUPD(90508,DA_",",8.06)=1
+22 DO FILE^DIE("","BQIUPD","ERROR")
+23 KILL BQIUPD
+24 KILL ^XTMP("BQIMUMNPP")
+25 SET ^XTMP("BQIMUMNPP",0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"Monthly MU Performance Provider List"
+26 ;
+27 SET BGPPROV=$PIECE(^BQI(90508,1,12),U,4)
SET BCJOB=$PIECE(^BQI(90508,1,12),U,6)
+28 SET STOP=0
+29 FOR
SET BGPPROV=$ORDER(^BQI(90508,1,14,"B",BGPPROV))
IF BGPPROV=""
QUIT
Begin DoDot:1
+30 DO PMON^BQIMUPRS(BGPPROV)
+31 SET $PIECE(^BQI(90508,1,12),U,4)=BGPPROV
+32 SET ^XTMP("BQIMUMNPP",BGPPROV)=$PIECE(^BQI(90508,1,9),U,1)_U_$PIECE(^BQI(90508,1,9),U,2)
+33 ; If not prohibited, keep running
+34 SET BQPROH=+$PIECE(^BQI(90508,1,12),U,7)
+35 IF 'BQPROH
QUIT
+36 ; If prohibited, check the date and time to see if the job needs to stop
+37 SET BQIMUDTM=$$NOW^XLFDT()
SET BQIMUDT=$PIECE(BQIMUDTM,".",1)
SET BQIMUTIM=$PIECE(BQIMUDTM,".",2)
+38 ; If it is a holiday, keep running
+39 IF $DATA(^HOLIDAY("B",DT))
QUIT
+40 SET CDOW=$$DOW^XLFDT(BQIMUDT,1)
+41 ; If day of week is Saturday, keeping running even if prohibited
+42 IF CDOW=6
QUIT
+43 ; If day of week is Sunday, keeping running even if prohibited
+44 IF CDOW=0
QUIT
+45 ;If the time plus 3 hours is less than 6 am or greater than 6 pm keep going
+46 IF $EXTRACT(BQIMUTIM,1,2)+3<6
QUIT
+47 IF $EXTRACT(BQIMUTIM,1,2)+3>18
QUIT
+48 SET STOP=1
+49 SET ZTDTH=BQIMUDT_".183"
+50 SET ZTDESC="MU Performance Continue Monthly Compile"
SET ZTRTN="NIN^BQITASK7"
SET ZTIO=""
+51 DO ^%ZTLOAD
+52 SET BQIUPD(90508,"1,",12.06)=ZTSK
+53 DO FILE^DIE("","BQIUPD","ERROR")
+54 KILL ZTDESC,ZTRTN,ZTIO,ZTDTH,ZTSK
End DoDot:1
IF STOP
QUIT
+55 ;
HOS ; Hospital CQ
+1 NEW APCMFAC,PGLOB,PROU
+2 SET GLOBAL=$NAME(^TMP("BQIMUP",$JOB))
KILL @GLOBAL
+3 SET BGPBD=$PIECE(^BQI(90508,1,9),U,1)
SET BGPED=$PIECE(^BQI(90508,1,9),U,2)
+4 SET APCMED=BGPED
SET APCMBD=BGPBD
SET APCMRPT=1
+5 SET APCMPED=$$FMADD^XLFDT(BGPED,-30)
SET APCMPBD=$$FMADD^XLFDT(BGPBD,-60)
+6 KILL APCMATTE,APCMIND
+7 SET APCMFAC=$$HME^BQIGPUTL()
SET BQIPROV(APCMFAC)=""
SET APCMRPTT=2
SET APCMDEMO="E"
+8 KILL APCMATTE,APCMIND
+9 ;F X="S1.009.H","S1.012.H","S1.013.H","S1.014.H","S1.018.H","S1.022.H","S1.023.H","S1.024.H" S APCMATTE(X,APCMFAC)=""
+10 ;gather up measures for this report
+11 SET PGLOB=$$CURPGL^BQIMUTAB()
+12 SET PROU=$$CURPRT^BQIMUTAB()
+13 SET X=0
FOR
SET X=$ORDER(@PGLOB@(X))
IF X'=+X
QUIT
IF $PIECE(@PGLOB@(X,0),U,2)="H"
Begin DoDot:1
+14 SET ID=$PIECE(@PGLOB@(X,0),U,1)
+15 IF $PIECE(@PGLOB@(X,0),U,6)'="R"
QUIT
+16 SET @GLOBAL@(APCMFAC,ID,"CURR")=""
SET @GLOBAL@(APCMFAC,ID,"PREV")=""
SET APCMATTE(ID,APCMFAC)=""
+17 SET APCMIND(X)=""
End DoDot:1
+18 ;
+19 ; Check if connection to server is working
+20 SET CONN=1
+21 IF PGLOB="^APCM24OB"
DO PHRC^BQIMUPRS
IF 'CONN
Begin DoDot:1
+22 NEW MN
+23 SET MN=$ORDER(@PGLOB@("B","S2.025.H",""))
+24 IF MN'=""
KILL APCMIND(MN)
End DoDot:1
+25 ;
+26 SET APCMWPP=1
SET APCMMETH="E"
+27 ;I $T(BQI^APCM11E1)'="" D BQI^APCM11E1(.GLOBAL,.BQIPROV)
+28 DO @("BQI^"_PROU_"(.GLOBAL,.BQIPROV)")
+29 ;
+30 SET FAC=$$HME^BQIGPUTL()
+31 SET BGPBD=$PIECE(^BQI(90508,1,9),U,1)
SET BGPED=$PIECE(^BQI(90508,1,9),U,2)
+32 SET BQTDT=$EXTRACT(BGPBD,1,5)_"00"
+33 SET BQTMN=$ORDER(^BQIFAC(FAC,40,"B",BQTDT,""))
+34 IF BQTMN=""
DO UPH
+35 ; Already data there, don't recalculate and quit
+36 ;I $G(^BQIFAC(FAC,40,BQTMN,1,1,0))'="" Q
+37 KILL CDEN,CNUM,CEXC,PDEN,PNUM,PEXC,CSORT,PSORT,MTOT
+38 DO STORH(40)
+39 KILL @GLOBAL,CSORT,PSORT
+40 ;
+41 ; Set the DATE/TIME MU STOPPED field
+42 NEW DA
+43 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+44 SET BQIUPD(90508,DA_",",8.05)=$$NOW^XLFDT()
+45 SET BQIUPD(90508,DA_",",8.06)="@"
+46 SET BQIUPD(90508,DA_",",12.04)=+BGPPROV
+47 IF +BGPPROV=0
Begin DoDot:1
+48 SET BMDT=$PIECE(^BQI(90508,1,9),U,1)
SET BMDT=$$FMADD^XLFDT(BMDT,1)
+49 SET BMDT=$EXTRACT(BMDT,1,5)_"00"
+50 IF $DATA(^XTMP("BQIMMONP",BMDT))
KILL ^XTMP("BQIMMONP",BMDT)
+51 SET BQIUPD(90508,DA_",",12.06)="@"
End DoDot:1
+52 DO FILE^DIE("","BQIUPD","ERROR")
+53 KILL BQIUPD,APCMMETH
+54 ; Create and send export files
+55 QUIT
+56 ;
STORH(NODE) ;
+1 NEW CVALUE,PVALUE,CT,I,MSN,FAC,PGLOB
+2 IF '$DATA(@GLOBAL)
QUIT
+3 SET FAC=$$HME^BQIGPUTL()
+4 SET PGLOB=$$CURPGL^BQIMUTAB()
+5 ;
+6 IF NODE=40
Begin DoDot:1
+7 SET ID=""
SET CT=0
+8 FOR
SET ID=$ORDER(@GLOBAL@(FAC,ID))
IF ID=""
QUIT
Begin DoDot:2
+9 SET IIEN=$ORDER(@PGLOB@("B",ID,""))
IF IIEN=""
QUIT
+10 IF $PIECE(@PGLOB@(IIEN,0),"^",2)'="H"
QUIT
+11 SET CDEN=$PIECE($GET(@GLOBAL@(FAC,ID,"CURR")),"^",1)
SET CNUM=$PIECE($GET(@GLOBAL@(FAC,ID,"CURR")),"^",2)
+12 SET CEXC=$PIECE($GET(@GLOBAL@(FAC,ID,"CURR")),"^",3)
+13 SET CT=CT+1
SET ^BQIFAC(FAC,NODE,BQTMN,1,CT,0)=ID_U_CDEN_U_CNUM_U_$$CURREP^BQIMUTAB()
+14 IF CEXC'=""
SET ^BQIFAC(FAC,NODE,BQTMN,1,CT,1)=CEXC
+15 SET ^BQIFAC(FAC,NODE,BQTMN,1,"B",ID,CT)=""
End DoDot:2
+16 NEW DIK,DA
+17 SET DIK="^BQIFAC("
SET DA=FAC
DO IX^DIK
End DoDot:1
QUIT
+18 QUIT
+19 ;
MED(ITM,LIST) ;EP - Find Median for LIST
+1 ; Input
+2 ; ITM - Which measure to check list for
+3 ; LIST - By ITM, the list of sorted values
+4 NEW CNT,MID,CT,PVAL,VAL,TOT,DFN,MED
+5 SET CNT=$GET(LIST(ITM))
+6 IF CNT=1
QUIT $ORDER(LIST(ITM,""))_U_1
+7 IF CNT=2
Begin DoDot:1
+8 SET TOT=0
SET VAL=""
+9 FOR
SET VAL=$ORDER(LIST(ITM,VAL))
IF VAL=""
QUIT
Begin DoDot:2
+10 SET DFN=""
FOR
SET DFN=$ORDER(LIST(ITM,VAL,DFN))
IF DFN=""
QUIT
SET TOT=TOT+VAL
End DoDot:2
End DoDot:1
QUIT (TOT/CNT)_U_CNT
+11 ;
+12 ;S MID=(CNT+1)\2
+13 SET MID=CNT\2
+14 SET CT=0
SET VAL=""
SET QFL=0
SET MED=""
SET TOT=0
+15 FOR
SET VAL=$ORDER(LIST(ITM,VAL))
IF VAL=""
QUIT
Begin DoDot:1
+16 SET DFN=""
+17 FOR
SET DFN=$ORDER(LIST(ITM,VAL,DFN))
IF DFN=""
QUIT
Begin DoDot:2
+18 SET CT=CT+1
SET NVAL=$ORDER(LIST(ITM,VAL))
+19 IF CT=MID
SET TOT=TOT+VAL+NVAL
SET MED=(TOT/2)
SET QFL=1
QUIT
+20 SET PVAL=VAL
End DoDot:2
End DoDot:1
IF QFL
QUIT
+21 QUIT MED_U_CNT
+22 ;
UPH ;EP Update Hospital
+1 NEW BEGDT,ENDT,TMFRAME,XX,V,I,ERROR,BQIUPD
+2 SET BEGDT=$PIECE($GET(^BQI(90508,1,9)),U,1)
SET ENDT=$PIECE($GET(^BQI(90508,1,9)),U,2)
+3 ;
+4 IF $GET(^BQIFAC(FAC,40,0))=""
SET ^BQIFAC(FAC,40,0)="^90505.64D^^"
+5 SET BQDATE=$EXTRACT(BEGDT,1,5)_"00"
+6 NEW DA,X,IENS
+7 SET DA(1)=FAC
SET DIC="^BQIFAC("_DA(1)_",40,"
SET X=BQDATE
SET DIC(0)="LNZ"
SET DLAYGO=90505.64
SET DIC("P")=DLAYGO
+8 DO ^DIC
+9 SET DA=+Y
IF DA=-1
QUIT
+10 SET BQTMN=DA
+11 QUIT
