BQITASK7.m

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