BQITASK6 ;GDIT/HS/ALA-MU CQ Job ; 30 Sep 2011 1:06 PM
;;2.3;ICARE MANAGEMENT SYSTEM;**1,3,4**;Apr 18, 2012;Build 66
;
NIN ;EP -- BQI UPDATE MU CQM 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)+3>6,$E(BQIMUTIM,1,2)+3<18 D Q
. S ZTDTH=BQIMUDT_".183"
. S ZTDESC="MU CQ Monthly Compile",ZTRTN="NIN^BQITASK6",ZTIO=""
. D ^%ZTLOAD
. S BQIUPD(90508,"1,",12.05)=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_",",4.19)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",4.21)=1
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
K ^XTMP("BQIMUMON")
S ^XTMP("BQIMUMON",0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"Monthly MU Provider List"
;
I $O(^XTMP("BQIMCQMPT",0))="" S ^XTMP("BQICQMPT",0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"MU CQ Patients"
S BGPPROV=$P(^BQI(90508,1,12),U,3),BCJOB=$P(^BQI(90508,1,12),U,5)
S STOP=0
F S BGPPROV=$O(^BQI(90508,1,14,"B",BGPPROV)) Q:BGPPROV="" D Q:STOP
. D MON^BQIMUPRS(BGPPROV)
. S $P(^BQI(90508,1,12),U,3)=BGPPROV
. S ^XTMP("BQIMUMON",BGPPROV)=$P(^BQI(90508,1,12),U,8)_U_$P(^BQI(90508,1,12),U,9)
. ; 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 CQ Continue Monthly Compile",ZTRTN="NIN^BQITASK6",ZTIO=""
. D ^%ZTLOAD
. S BQIUPD(90508,"1,",12.05)=ZTSK
. D FILE^DIE("","BQIUPD","ERROR")
. K ZTDESC,ZTRTN,ZTIO,ZTDTH,ZTSK
;
HOS ; Hospital CQ
I $P(^BQI(90508,1,0),U,6)=1 D
. NEW BGPINDT,BGPMUYF,BGPRTYPE,BGP0RPTH,BGPBEN,X,BQIGREF,FAC,BQTDT,BQTMN,BGPBD,BGPED
. K BGPIND
. S BGPINDT=""
. S BGPMUYF="90595.11"
. S BGPRTYPE=4,BGP0RPTH="A"
. S BGPMUT="H" ; BGPMU Hospital Measures
. S BGPRTYPE=4,BGP0RPTH="A"
. S BGPBEN=3
. S X=0 F S X=$O(^BGPMUIND(BGPMUYF,X)) Q:'X I $P(^BGPMUIND(BGPMUYF,X,0),U,4)="H" S BGPIND(X)=""
. S BQIGREF=$NA(^TMP("BQICQMH9",$J)) K @BQIGREF
. ;
. S FAC=$$HME^BQIGPUTL()
. S BGPBD=$P(^BQI(90508,1,12),U,8),BGPED=$P(^BQI(90508,1,12),U,9)
. S BQTDT=$E(BGPBD,1,5)_"00"
. S BQTMN=$O(^BQIFAC(FAC,50,"B",BQTDT,""))
. I BQTMN="" D UPH
. ; Already data there, don't recalculate and quit
. ;I $G(^BQIFAC(FAC,50,BQTMN,1,1,0))'="" Q
. S BGPBD=$P(^BQI(90508,1,12),U,8),BGPED=$P(^BQI(90508,1,12),U,9)
. ; Previous
. S BGPPBD="",BGPPED=""
. ; Baseline
. S BGPBBD=BGPPBD,BGPBED=BGPPED
. D BQI^BGPMUEHD(.BQIGREF)
. K CDEN,CNUM,CEXC,PDEN,PNUM,PEXC,CSORT,PSORT,MTOT
. S BN=""
. F S BN=$O(@BQIGREF@(BN)) Q:BN="" D
.. S I=""
.. F S I=$O(@BQIGREF@(BN,"C",I)) Q:I="" D
... I $P($G(^BGPMUIND(90596.11,I,0)),U,4)[".ED." D Q
.... S MTOT=$P(@BQIGREF@(BN,"C",I),U,2)/60
.... S CSORT(I,MTOT,BN)="",CSORT(I)=$G(CSORT(I))+1
... S CDEN(I)=$G(CDEN(I))+$P($G(@BQIGREF@(BN,"C",I)),U,1)
... S CNUM(I)=$G(CNUM(I))+$P($G(@BQIGREF@(BN,"C",I)),U,2)
... S CEXC(I)=$G(CEXC(I))+$P($G(@BQIGREF@(BN,"C",I)),U,3)
. D STORH(50)
. K @BQIGREF,CSORT,PSORT
;
; Set the DATE/TIME MU STOPPED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",4.2)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",4.21)="@"
S BQIUPD(90508,DA_",",12.03)=+BGPPROV
I +BGPPROV=0 D
. S BMDT=$P(^BQI(90508,1,12),U,9),BMDT=$$FMADD^XLFDT(BMDT,1)
. S BMDT=$E(BMDT,1,5)_"00"
. I $D(^XTMP("BQIMMON",BMDT)) K ^XTMP("BQIMMON",BMDT)
. S BQIUPD(90508,DA_",",12.05)="@"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
; Create and send export files
D EN^BQIMUEXP
D HOS^BQIMUEXP
Q
;
STORH(NODE) ;
NEW CVALUE,PVALUE,CT,I,MSN,FAC
I '$D(@BQIGREF) Q
S FAC=$$HME^BQIGPUTL()
I NODE=60 D Q
. S $P(^BQIFAC(FAC,2),U,1)=$$NOW^XLFDT()
. S CT=0
. S I=0 F S I=$O(^BGPMUIND(90596.11,I)) Q:'I D
.. S MSN=$P(^BGPMUIND(90596.11,I,0),U,1)
.. I $G(^BGPMUIND(90595.11,MSN,0))="" Q
.. I $P(^BGPMUIND(90595.11,MSN,0),U,4)'="H" Q
.. S CT=CT+1,^BQIFAC(FAC,NODE,BQTMN,10,CT,0)=$P(^BGPMUIND(90596.11,I,0),"^",4)_U_$G(CDEN(I))_U_$G(CNUM(I))_U_$G(CEXC(I))
.. S ^BQIFAC(FAC,NODE,BQTMN,10,"B",$P(^BGPMUIND(90596.11,I,0),"^",4),CT)=""
;
I NODE=50 D Q
. S $P(^BQIFAC(FAC,2),U,1)=$$NOW^XLFDT()
. S CT=0
. S I=0 F S I=$O(^BGPMUIND(90596.11,I)) Q:'I D
.. S MSN=$P(^BGPMUIND(90596.11,I,0),U,1)
.. I $G(^BGPMUIND(90595.11,MSN,0))="" Q
.. I $P(^BGPMUIND(90595.11,MSN,0),U,4)'="H" Q
.. S CT=CT+1,^BQIFAC(FAC,NODE,BQTMN,1,CT,0)=$P(^BGPMUIND(90596.11,I,0),"^",4)_U_$G(CDEN(I))_U_$G(CNUM(I))_U_$G(CEXC(I))
.. S ^BQIFAC(FAC,NODE,BQTMN,1,"B",$P(^BGPMUIND(90596.11,I,0),"^",4),CT)=""
;
K ^BQIFAC(FAC,NODE),^BQIFAC(FAC,NODE,"B")
I NODE=11 S $P(^BQIFAC(FAC,1),U,1,4)=BGPBD_U_BGPED_U_BGPPBD_U_BGPPED
I NODE=21 S $P(^BQIFAC(FAC,1),U,5,8)=BGPBD_U_BGPED_U_BGPPBD_U_BGPPED
S CT=0
S I=0 F S I=$O(^BGPMUIND(90596.11,I)) Q:'I D
. S MSN=$P(^BGPMUIND(90596.11,I,0),U,1)
. I $G(^BGPMUIND(90595.11,MSN,0))="" Q
. I $P(^BGPMUIND(90595.11,MSN,0),U,4)'="H" Q
. I $P($G(^BGPMUIND(90596.11,I,0)),U,4)[".ED." D
.. S CVALUE=$$MED(I,.CSORT),PVALUE=$$MED(I,.PSORT)
.. S CT=CT+1,^BQIFAC(FAC,NODE,CT,0)=$P(^BGPMUIND(90596.11,I,0),"^",4)_U_$P(CVALUE,U,1)_U_$P(CVALUE,U,2)_U_$G(CEXC(I))_U_$P(PVALUE,U,1)_U_$P(PVALUE,U,2)_U_$G(PEXC(I))
. I $P($G(^BGPMUIND(90596.11,I,0)),U,4)'[".ED." D
.. S CT=CT+1,^BQIFAC(FAC,NODE,CT,0)=$P(^BGPMUIND(90596.11,I,0),"^",4)_U_$G(CDEN(I))_U_$G(CNUM(I))_U_$G(CEXC(I))_U_$G(PDEN(I))_U_$G(PNUM(I))_U_$G(PEXC(I))
. S ^BQIFAC(FAC,NODE,"B",$P(^BGPMUIND(90596.11,I,0),"^",4),CT)=""
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,12)),U,8),ENDT=$P($G(^BQI(90508,1,12)),U,9)
;S TMFRAME=$$FMTE^BQIUL1(BEGDT)_" - "_$$FMTE^BQIUL1(ENDT)
;
I $G(^BQIFAC(FAC,50,0))="" S ^BQIFAC(FAC,50,0)="^90505.66D^^"
S BQDATE=$E(BEGDT,1,5)_"00"
NEW DA,X,IENS
S DA(1)=FAC,DIC="^BQIFAC("_DA(1)_",50,",X=BQDATE,DIC(0)="LNZ",DLAYGO=90505.66,DIC("P")=DLAYGO
D ^DIC
S DA=+Y I DA=-1 Q
S BQTMN=DA
Q
BQITASK6 ;GDIT/HS/ALA-MU CQ Job ; 30 Sep 2011 1:06 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;**1,3,4**;Apr 18, 2012;Build 66
+2 ;
NIN ;EP -- BQI UPDATE MU CQM 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)+3>6
IF $EXTRACT(BQIMUTIM,1,2)+3<18
Begin DoDot:1
+10 SET ZTDTH=BQIMUDT_".183"
+11 SET ZTDESC="MU CQ Monthly Compile"
SET ZTRTN="NIN^BQITASK6"
SET ZTIO=""
+12 DO ^%ZTLOAD
+13 SET BQIUPD(90508,"1,",12.05)=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_",",4.19)=$$NOW^XLFDT()
+21 SET BQIUPD(90508,DA_",",4.21)=1
+22 DO FILE^DIE("","BQIUPD","ERROR")
+23 KILL BQIUPD
+24 KILL ^XTMP("BQIMUMON")
+25 SET ^XTMP("BQIMUMON",0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"Monthly MU Provider List"
+26 ;
+27 IF $ORDER(^XTMP("BQIMCQMPT",0))=""
SET ^XTMP("BQICQMPT",0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"MU CQ Patients"
+28 SET BGPPROV=$PIECE(^BQI(90508,1,12),U,3)
SET BCJOB=$PIECE(^BQI(90508,1,12),U,5)
+29 SET STOP=0
+30 FOR
SET BGPPROV=$ORDER(^BQI(90508,1,14,"B",BGPPROV))
IF BGPPROV=""
QUIT
Begin DoDot:1
+31 DO MON^BQIMUPRS(BGPPROV)
+32 SET $PIECE(^BQI(90508,1,12),U,3)=BGPPROV
+33 SET ^XTMP("BQIMUMON",BGPPROV)=$PIECE(^BQI(90508,1,12),U,8)_U_$PIECE(^BQI(90508,1,12),U,9)
+34 ; If not prohibited, keep running
+35 SET BQPROH=+$PIECE(^BQI(90508,1,12),U,7)
+36 IF 'BQPROH
QUIT
+37 ; If prohibited, check the date and time to see if the job needs to stop
+38 SET BQIMUDTM=$$NOW^XLFDT()
SET BQIMUDT=$PIECE(BQIMUDTM,".",1)
SET BQIMUTIM=$PIECE(BQIMUDTM,".",2)
+39 ; if it is a holiday, keep running
+40 IF $DATA(^HOLIDAY("B",DT))
QUIT
+41 SET CDOW=$$DOW^XLFDT(BQIMUDT,1)
+42 ; If day of week is Saturday, keeping running even if prohibited
+43 IF CDOW=6
QUIT
+44 ; If day of week is Sunday, keeping running even if prohibited
+45 IF CDOW=0
QUIT
+46 ;If the time plus 3 hours is less than 6 am or greater than 6 pm keep going
+47 IF $EXTRACT(BQIMUTIM,1,2)+3<6
QUIT
+48 IF $EXTRACT(BQIMUTIM,1,2)+3>18
QUIT
+49 SET STOP=1
+50 SET ZTDTH=BQIMUDT_".183"
+51 SET ZTDESC="MU CQ Continue Monthly Compile"
SET ZTRTN="NIN^BQITASK6"
SET ZTIO=""
+52 DO ^%ZTLOAD
+53 SET BQIUPD(90508,"1,",12.05)=ZTSK
+54 DO FILE^DIE("","BQIUPD","ERROR")
+55 KILL ZTDESC,ZTRTN,ZTIO,ZTDTH,ZTSK
End DoDot:1
IF STOP
QUIT
+56 ;
HOS ; Hospital CQ
+1 IF $PIECE(^BQI(90508,1,0),U,6)=1
Begin DoDot:1
+2 NEW BGPINDT,BGPMUYF,BGPRTYPE,BGP0RPTH,BGPBEN,X,BQIGREF,FAC,BQTDT,BQTMN,BGPBD,BGPED
+3 KILL BGPIND
+4 SET BGPINDT=""
+5 SET BGPMUYF="90595.11"
+6 SET BGPRTYPE=4
SET BGP0RPTH="A"
+7 ; BGPMU Hospital Measures
SET BGPMUT="H"
+8 SET BGPRTYPE=4
SET BGP0RPTH="A"
+9 SET BGPBEN=3
+10 SET X=0
FOR
SET X=$ORDER(^BGPMUIND(BGPMUYF,X))
IF 'X
QUIT
IF $PIECE(^BGPMUIND(BGPMUYF,X,0),U,4)="H"
SET BGPIND(X)=""
+11 SET BQIGREF=$NAME(^TMP("BQICQMH9",$JOB))
KILL @BQIGREF
+12 ;
+13 SET FAC=$$HME^BQIGPUTL()
+14 SET BGPBD=$PIECE(^BQI(90508,1,12),U,8)
SET BGPED=$PIECE(^BQI(90508,1,12),U,9)
+15 SET BQTDT=$EXTRACT(BGPBD,1,5)_"00"
+16 SET BQTMN=$ORDER(^BQIFAC(FAC,50,"B",BQTDT,""))
+17 IF BQTMN=""
DO UPH
+18 ; Already data there, don't recalculate and quit
+19 ;I $G(^BQIFAC(FAC,50,BQTMN,1,1,0))'="" Q
+20 SET BGPBD=$PIECE(^BQI(90508,1,12),U,8)
SET BGPED=$PIECE(^BQI(90508,1,12),U,9)
+21 ; Previous
+22 SET BGPPBD=""
SET BGPPED=""
+23 ; Baseline
+24 SET BGPBBD=BGPPBD
SET BGPBED=BGPPED
+25 DO BQI^BGPMUEHD(.BQIGREF)
+26 KILL CDEN,CNUM,CEXC,PDEN,PNUM,PEXC,CSORT,PSORT,MTOT
+27 SET BN=""
+28 FOR
SET BN=$ORDER(@BQIGREF@(BN))
IF BN=""
QUIT
Begin DoDot:2
+29 SET I=""
+30 FOR
SET I=$ORDER(@BQIGREF@(BN,"C",I))
IF I=""
QUIT
Begin DoDot:3
+31 IF $PIECE($GET(^BGPMUIND(90596.11,I,0)),U,4)[".ED."
Begin DoDot:4
+32 SET MTOT=$PIECE(@BQIGREF@(BN,"C",I),U,2)/60
+33 SET CSORT(I,MTOT,BN)=""
SET CSORT(I)=$GET(CSORT(I))+1
End DoDot:4
QUIT
+34 SET CDEN(I)=$GET(CDEN(I))+$PIECE($GET(@BQIGREF@(BN,"C",I)),U,1)
+35 SET CNUM(I)=$GET(CNUM(I))+$PIECE($GET(@BQIGREF@(BN,"C",I)),U,2)
+36 SET CEXC(I)=$GET(CEXC(I))+$PIECE($GET(@BQIGREF@(BN,"C",I)),U,3)
End DoDot:3
End DoDot:2
+37 DO STORH(50)
+38 KILL @BQIGREF,CSORT,PSORT
End DoDot:1
+39 ;
+40 ; Set the DATE/TIME MU STOPPED field
+41 NEW DA
+42 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+43 SET BQIUPD(90508,DA_",",4.2)=$$NOW^XLFDT()
+44 SET BQIUPD(90508,DA_",",4.21)="@"
+45 SET BQIUPD(90508,DA_",",12.03)=+BGPPROV
+46 IF +BGPPROV=0
Begin DoDot:1
+47 SET BMDT=$PIECE(^BQI(90508,1,12),U,9)
SET BMDT=$$FMADD^XLFDT(BMDT,1)
+48 SET BMDT=$EXTRACT(BMDT,1,5)_"00"
+49 IF $DATA(^XTMP("BQIMMON",BMDT))
KILL ^XTMP("BQIMMON",BMDT)
+50 SET BQIUPD(90508,DA_",",12.05)="@"
End DoDot:1
+51 DO FILE^DIE("","BQIUPD","ERROR")
+52 KILL BQIUPD
+53 ; Create and send export files
+54 DO EN^BQIMUEXP
+55 DO HOS^BQIMUEXP
+56 QUIT
+57 ;
STORH(NODE) ;
+1 NEW CVALUE,PVALUE,CT,I,MSN,FAC
+2 IF '$DATA(@BQIGREF)
QUIT
+3 SET FAC=$$HME^BQIGPUTL()
+4 IF NODE=60
Begin DoDot:1
+5 SET $PIECE(^BQIFAC(FAC,2),U,1)=$$NOW^XLFDT()
+6 SET CT=0
+7 SET I=0
FOR
SET I=$ORDER(^BGPMUIND(90596.11,I))
IF 'I
QUIT
Begin DoDot:2
+8 SET MSN=$PIECE(^BGPMUIND(90596.11,I,0),U,1)
+9 IF $GET(^BGPMUIND(90595.11,MSN,0))=""
QUIT
+10 IF $PIECE(^BGPMUIND(90595.11,MSN,0),U,4)'="H"
QUIT
+11 SET CT=CT+1
SET ^BQIFAC(FAC,NODE,BQTMN,10,CT,0)=$PIECE(^BGPMUIND(90596.11,I,0),"^",4)_U_$GET(CDEN(I))_U_$GET(CNUM(I))_U_$GET(CEXC(I))
+12 SET ^BQIFAC(FAC,NODE,BQTMN,10,"B",$PIECE(^BGPMUIND(90596.11,I,0),"^",4),CT)=""
End DoDot:2
End DoDot:1
QUIT
+13 ;
+14 IF NODE=50
Begin DoDot:1
+15 SET $PIECE(^BQIFAC(FAC,2),U,1)=$$NOW^XLFDT()
+16 SET CT=0
+17 SET I=0
FOR
SET I=$ORDER(^BGPMUIND(90596.11,I))
IF 'I
QUIT
Begin DoDot:2
+18 SET MSN=$PIECE(^BGPMUIND(90596.11,I,0),U,1)
+19 IF $GET(^BGPMUIND(90595.11,MSN,0))=""
QUIT
+20 IF $PIECE(^BGPMUIND(90595.11,MSN,0),U,4)'="H"
QUIT
+21 SET CT=CT+1
SET ^BQIFAC(FAC,NODE,BQTMN,1,CT,0)=$PIECE(^BGPMUIND(90596.11,I,0),"^",4)_U_$GET(CDEN(I))_U_$GET(CNUM(I))_U_$GET(CEXC(I))
+22 SET ^BQIFAC(FAC,NODE,BQTMN,1,"B",$PIECE(^BGPMUIND(90596.11,I,0),"^",4),CT)=""
End DoDot:2
End DoDot:1
QUIT
+23 ;
+24 KILL ^BQIFAC(FAC,NODE),^BQIFAC(FAC,NODE,"B")
+25 IF NODE=11
SET $PIECE(^BQIFAC(FAC,1),U,1,4)=BGPBD_U_BGPED_U_BGPPBD_U_BGPPED
+26 IF NODE=21
SET $PIECE(^BQIFAC(FAC,1),U,5,8)=BGPBD_U_BGPED_U_BGPPBD_U_BGPPED
+27 SET CT=0
+28 SET I=0
FOR
SET I=$ORDER(^BGPMUIND(90596.11,I))
IF 'I
QUIT
Begin DoDot:1
+29 SET MSN=$PIECE(^BGPMUIND(90596.11,I,0),U,1)
+30 IF $GET(^BGPMUIND(90595.11,MSN,0))=""
QUIT
+31 IF $PIECE(^BGPMUIND(90595.11,MSN,0),U,4)'="H"
QUIT
+32 IF $PIECE($GET(^BGPMUIND(90596.11,I,0)),U,4)[".ED."
Begin DoDot:2
+33 SET CVALUE=$$MED(I,.CSORT)
SET PVALUE=$$MED(I,.PSORT)
+34 SET CT=CT+1
SET ^BQIFAC(FAC,NODE,CT,0)=$PIECE(^BGPMUIND(90596.11,I,0),"^",4)_U_$PIECE(CVALUE,U,1)_U_$PIECE(CVALUE,U,2)_U_$GET(CEXC(I))_U_$PIECE(PVALUE,U,1)_U_$PIECE(PVALUE,U,2)_U_$GET(PEXC(I))
End DoDot:2
+35 IF $PIECE($GET(^BGPMUIND(90596.11,I,0)),U,4)'[".ED."
Begin DoDot:2
+36 SET CT=CT+1
SET ^BQIFAC(FAC,NODE,CT,0)=$PIECE(^BGPMUIND(90596.11,I,0),"^",4)_U_$GET(CDEN(I))_U_$GET(CNUM(I))_U_$GET(CEXC(I))_U_$GET(PDEN(I))_U_$GET(PNUM(I))_U_$GET(PEXC(I))
End DoDot:2
+37 SET ^BQIFAC(FAC,NODE,"B",$PIECE(^BGPMUIND(90596.11,I,0),"^",4),CT)=""
End DoDot:1
+38 QUIT
+39 ;
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,12)),U,8)
SET ENDT=$PIECE($GET(^BQI(90508,1,12)),U,9)
+3 ;S TMFRAME=$$FMTE^BQIUL1(BEGDT)_" - "_$$FMTE^BQIUL1(ENDT)
+4 ;
+5 IF $GET(^BQIFAC(FAC,50,0))=""
SET ^BQIFAC(FAC,50,0)="^90505.66D^^"
+6 SET BQDATE=$EXTRACT(BEGDT,1,5)_"00"
+7 NEW DA,X,IENS
+8 SET DA(1)=FAC
SET DIC="^BQIFAC("_DA(1)_",50,"
SET X=BQDATE
SET DIC(0)="LNZ"
SET DLAYGO=90505.66
SET DIC("P")=DLAYGO
+9 DO ^DIC
+10 SET DA=+Y
IF DA=-1
QUIT
+11 SET BQTMN=DA
+12 QUIT
