BQIMUUPD ;GDIT/HS/ALA-Update MU Performance version ; 01 Mar 2013 3:34 PM
;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
;
EN ;EP
I '$$PATCH^XPDUTL("APCM*1.0*2") Q
NEW CURR
S CURR=$P($G(^BQI(90508,1,9)),U,3)
I CURR="" D
. S CURR="INTERIM STAGE 1 2013"
. I '$D(^APCMMUCN("B",CURR)) Q
. D UP
. I $P($G(^BQI(90508,1,9)),U,3)="" S $P(^BQI(90508,1,9),U,3)=CURR
NEW DIK
S DIK="^BQIPROV(" D IXALL^DIK
S DIK="^BQIFAC(" D IXALL^DIK
Q
;
UP ;EP - Facility
NEW FAC,FN,MN
S FAC=0
F S FAC=$O(^BQIFAC(FAC)) Q:'FAC D
. S FN=0
. F S FN=$O(^BQIFAC(FAC,40,FN)) Q:'FN D
.. S MN=0
.. F S MN=$O(^BQIFAC(FAC,40,FN,1,MN)) Q:'MN D
... NEW DA,IENS
... S DA(2)=FAC,DA(1)=FN,DA=MN,IENS=$$IENS^DILF(.DA)
... I $$GET1^DIQ(90505.641,IENS,.04,"E")="" S BQIUPD(90505.641,IENS,.04)=CURR
. S FN=0
. F S FN=$O(^BQIFAC(FAC,70,FN)) Q:'FN D
.. S MN=0
.. F S MN=$O(^BQIFAC(FAC,70,FN,1,MN)) Q:'MN D
... NEW DA,IENS
... S DA(2)=FAC,DA(1)=FN,DA=MN,IENS=$$IENS^DILF(.DA)
... I $$GET1^DIQ(90505.671,IENS,.04,"E")="" S BQIUPD(90505.671,IENS,.04)=CURR
I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
;
;Provider
NEW PRV,FN,MN
S PRV=0
F S PRV=$O(^BQIPROV(PRV)) Q:'PRV D
. S FN=0
. F S FN=$O(^BQIPROV(PRV,40,FN)) Q:'FN D
.. S MN=0
.. F S MN=$O(^BQIPROV(PRV,40,FN,1,MN)) Q:'MN D
... NEW DA,IENS
... S DA(2)=PRV,DA(1)=FN,DA=MN,IENS=$$IENS^DILF(.DA)
... I $$GET1^DIQ(90505.441,IENS,.04,"E")="" S BQIUPD(90505.441,IENS,.04)=CURR
I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
Q
;
SXRF ; Set cross-reference
I $G(^BQIPROV(DA(2),40,DA(1),0))'="" S ^BQIPROV("AC",X,^BQIPROV(DA(2),40,DA(1),0),DA(2))=""
Q
;
KXRF ; Kill cross-reference
I $G(^BQIPROV(DA(2),40,DA(1),0))'="" K ^BQIPROV("AC",X,^BQIPROV(DA(2),40,DA(1),0),DA(2))
Q
;
SHRF ; Set hospital cross-reference
I $G(^BQIFAC(DA(2),40,DA(1),0))'="" S ^BQIFAC("AC",X,^BQIFAC(DA(2),40,DA(1),0),DA(2))=""
Q
;
KHRF ; Kill hospital
I $G(^BQIFAC(DA(2),40,DA(1),0))'="" K ^BQIFAC("AC",X,^BQIFAC(DA(2),40,DA(1),0),DA(2))
Q
;
P3 ;EP - Patch 3 update CQ data by division
; Clean up and reset to zero
S DV=0
F S DV=$O(^BQIFAC(DV)) Q:'DV D
. S BQDTMN=0
. F S BQDTMN=$O(^BQIFAC(DV,80,BQDTMN)) Q:'BQDTMN D
.. S DN=0
.. F S DN=$O(^BQIFAC(DV,80,BQDTMN,1,DN)) Q:'DN D
... S $P(^BQIFAC(DV,80,BQDTMN,1,DN,0),U,2)=0,$P(^(0),U,3)=0,$P(^(0),U,4)=0
;
; Update by provider
S BGPPROV=0
F S BGPPROV=$O(^BQIPROV(BGPPROV)) Q:'BGPPROV D
. S BQTMN=0
. F S BQTMN=$O(^BQIPROV(BGPPROV,50,BQTMN)) Q:'BQTMN D
.. S BQDATE=^BQIPROV(BGPPROV,50,BQTMN,0)
.. S BQID=0
.. F S BQID=$O(^BQIPROV(BGPPROV,50,BQTMN,1,BQID)) Q:'BQID D
... S ID=$P(^BQIPROV(BGPPROV,50,BQTMN,1,BQID,0),U,1),CDEN=$P(^(0),U,2),CNUM=$P(^(0),U,3),CEXC=$P(^(0),U,4)
... S DV=0,NODE=80
... F S DV=$O(^VA(200,BGPPROV,2,DV)) Q:'DV D
.... I $G(^BQIFAC(DV,0))="" S ^BQIFAC(DV,0)=DV,^BQIFAC("B",DV,DV)=""
.... S FAC=DV D UPD
.... S DN=$O(^BQIFAC(DV,NODE,BQDTMN,1,"B",ID,"")) I DN="" S DN=BQID
.... I $G(^BQIFAC(DV,NODE,BQDTMN,1,DN,0))="" S ^BQIFAC(DV,NODE,BQDTMN,1,DN,0)=ID,^BQIFAC(DV,NODE,BQDTMN,1,"B",ID,DN)=""
.... S $P(^BQIFAC(DV,NODE,BQDTMN,1,DN,0),U,2)=$P($G(^BQIFAC(DV,NODE,BQDTMN,1,DN,0)),U,2)+$G(CDEN)
.... S $P(^BQIFAC(DV,NODE,BQDTMN,1,DN,0),U,3)=$P($G(^BQIFAC(DV,NODE,BQDTMN,1,DN,0)),U,3)+$G(CNUM)
.... S $P(^BQIFAC(DV,NODE,BQDTMN,1,DN,0),U,4)=$P($G(^BQIFAC(DV,NODE,BQDTMN,1,DN,0)),U,4)+$G(CEXC)
Q
;
UPD ;EP
I $G(^BQIFAC(FAC,80,0))="" S ^BQIFAC(FAC,80,0)="^90505.68D^^"
;
NEW DA,X,IENS,Y,DIC,DLAYGO
S DA(1)=FAC,DIC="^BQIFAC("_DA(1)_",80,",X=BQDATE,DIC(0)="LNZ",DLAYGO=90505.68,DIC("P")=DLAYGO
D ^DIC
S DA=+Y I DA=-1 Q
S BQDTMN=DA
Q
BQIMUUPD ;GDIT/HS/ALA-Update MU Performance version ; 01 Mar 2013 3:34 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
+2 ;
EN ;EP
+1 IF '$$PATCH^XPDUTL("APCM*1.0*2")
QUIT
+2 NEW CURR
+3 SET CURR=$PIECE($GET(^BQI(90508,1,9)),U,3)
+4 IF CURR=""
Begin DoDot:1
+5 SET CURR="INTERIM STAGE 1 2013"
+6 IF '$DATA(^APCMMUCN("B",CURR))
QUIT
+7 DO UP
+8 IF $PIECE($GET(^BQI(90508,1,9)),U,3)=""
SET $PIECE(^BQI(90508,1,9),U,3)=CURR
End DoDot:1
+9 NEW DIK
+10 SET DIK="^BQIPROV("
DO IXALL^DIK
+11 SET DIK="^BQIFAC("
DO IXALL^DIK
+12 QUIT
+13 ;
UP ;EP - Facility
+1 NEW FAC,FN,MN
+2 SET FAC=0
+3 FOR
SET FAC=$ORDER(^BQIFAC(FAC))
IF 'FAC
QUIT
Begin DoDot:1
+4 SET FN=0
+5 FOR
SET FN=$ORDER(^BQIFAC(FAC,40,FN))
IF 'FN
QUIT
Begin DoDot:2
+6 SET MN=0
+7 FOR
SET MN=$ORDER(^BQIFAC(FAC,40,FN,1,MN))
IF 'MN
QUIT
Begin DoDot:3
+8 NEW DA,IENS
+9 SET DA(2)=FAC
SET DA(1)=FN
SET DA=MN
SET IENS=$$IENS^DILF(.DA)
+10 IF $$GET1^DIQ(90505.641,IENS,.04,"E")=""
SET BQIUPD(90505.641,IENS,.04)=CURR
End DoDot:3
End DoDot:2
+11 SET FN=0
+12 FOR
SET FN=$ORDER(^BQIFAC(FAC,70,FN))
IF 'FN
QUIT
Begin DoDot:2
+13 SET MN=0
+14 FOR
SET MN=$ORDER(^BQIFAC(FAC,70,FN,1,MN))
IF 'MN
QUIT
Begin DoDot:3
+15 NEW DA,IENS
+16 SET DA(2)=FAC
SET DA(1)=FN
SET DA=MN
SET IENS=$$IENS^DILF(.DA)
+17 IF $$GET1^DIQ(90505.671,IENS,.04,"E")=""
SET BQIUPD(90505.671,IENS,.04)=CURR
End DoDot:3
End DoDot:2
End DoDot:1
+18 IF $DATA(BQIUPD)
DO FILE^DIE("","BQIUPD","ERROR")
+19 ;
+20 ;Provider
+21 NEW PRV,FN,MN
+22 SET PRV=0
+23 FOR
SET PRV=$ORDER(^BQIPROV(PRV))
IF 'PRV
QUIT
Begin DoDot:1
+24 SET FN=0
+25 FOR
SET FN=$ORDER(^BQIPROV(PRV,40,FN))
IF 'FN
QUIT
Begin DoDot:2
+26 SET MN=0
+27 FOR
SET MN=$ORDER(^BQIPROV(PRV,40,FN,1,MN))
IF 'MN
QUIT
Begin DoDot:3
+28 NEW DA,IENS
+29 SET DA(2)=PRV
SET DA(1)=FN
SET DA=MN
SET IENS=$$IENS^DILF(.DA)
+30 IF $$GET1^DIQ(90505.441,IENS,.04,"E")=""
SET BQIUPD(90505.441,IENS,.04)=CURR
End DoDot:3
End DoDot:2
End DoDot:1
+31 IF $DATA(BQIUPD)
DO FILE^DIE("","BQIUPD","ERROR")
+32 QUIT
+33 ;
SXRF ; Set cross-reference
+1 IF $GET(^BQIPROV(DA(2),40,DA(1),0))'=""
SET ^BQIPROV("AC",X,^BQIPROV(DA(2),40,DA(1),0),DA(2))=""
+2 QUIT
+3 ;
KXRF ; Kill cross-reference
+1 IF $GET(^BQIPROV(DA(2),40,DA(1),0))'=""
KILL ^BQIPROV("AC",X,^BQIPROV(DA(2),40,DA(1),0),DA(2))
+2 QUIT
+3 ;
SHRF ; Set hospital cross-reference
+1 IF $GET(^BQIFAC(DA(2),40,DA(1),0))'=""
SET ^BQIFAC("AC",X,^BQIFAC(DA(2),40,DA(1),0),DA(2))=""
+2 QUIT
+3 ;
KHRF ; Kill hospital
+1 IF $GET(^BQIFAC(DA(2),40,DA(1),0))'=""
KILL ^BQIFAC("AC",X,^BQIFAC(DA(2),40,DA(1),0),DA(2))
+2 QUIT
+3 ;
P3 ;EP - Patch 3 update CQ data by division
+1 ; Clean up and reset to zero
+2 SET DV=0
+3 FOR
SET DV=$ORDER(^BQIFAC(DV))
IF 'DV
QUIT
Begin DoDot:1
+4 SET BQDTMN=0
+5 FOR
SET BQDTMN=$ORDER(^BQIFAC(DV,80,BQDTMN))
IF 'BQDTMN
QUIT
Begin DoDot:2
+6 SET DN=0
+7 FOR
SET DN=$ORDER(^BQIFAC(DV,80,BQDTMN,1,DN))
IF 'DN
QUIT
Begin DoDot:3
+8 SET $PIECE(^BQIFAC(DV,80,BQDTMN,1,DN,0),U,2)=0
SET $PIECE(^(0),U,3)=0
SET $PIECE(^(0),U,4)=0
End DoDot:3
End DoDot:2
End DoDot:1
+9 ;
+10 ; Update by provider
+11 SET BGPPROV=0
+12 FOR
SET BGPPROV=$ORDER(^BQIPROV(BGPPROV))
IF 'BGPPROV
QUIT
Begin DoDot:1
+13 SET BQTMN=0
+14 FOR
SET BQTMN=$ORDER(^BQIPROV(BGPPROV,50,BQTMN))
IF 'BQTMN
QUIT
Begin DoDot:2
+15 SET BQDATE=^BQIPROV(BGPPROV,50,BQTMN,0)
+16 SET BQID=0
+17 FOR
SET BQID=$ORDER(^BQIPROV(BGPPROV,50,BQTMN,1,BQID))
IF 'BQID
QUIT
Begin DoDot:3
+18 SET ID=$PIECE(^BQIPROV(BGPPROV,50,BQTMN,1,BQID,0),U,1)
SET CDEN=$PIECE(^(0),U,2)
SET CNUM=$PIECE(^(0),U,3)
SET CEXC=$PIECE(^(0),U,4)
+19 SET DV=0
SET NODE=80
+20 FOR
SET DV=$ORDER(^VA(200,BGPPROV,2,DV))
IF 'DV
QUIT
Begin DoDot:4
+21 IF $GET(^BQIFAC(DV,0))=""
SET ^BQIFAC(DV,0)=DV
SET ^BQIFAC("B",DV,DV)=""
+22 SET FAC=DV
DO UPD
+23 SET DN=$ORDER(^BQIFAC(DV,NODE,BQDTMN,1,"B",ID,""))
IF DN=""
SET DN=BQID
+24 IF $GET(^BQIFAC(DV,NODE,BQDTMN,1,DN,0))=""
SET ^BQIFAC(DV,NODE,BQDTMN,1,DN,0)=ID
SET ^BQIFAC(DV,NODE,BQDTMN,1,"B",ID,DN)=""
+25 SET $PIECE(^BQIFAC(DV,NODE,BQDTMN,1,DN,0),U,2)=$PIECE($GET(^BQIFAC(DV,NODE,BQDTMN,1,DN,0)),U,2)+$GET(CDEN)
+26 SET $PIECE(^BQIFAC(DV,NODE,BQDTMN,1,DN,0),U,3)=$PIECE($GET(^BQIFAC(DV,NODE,BQDTMN,1,DN,0)),U,3)+$GET(CNUM)
+27 SET $PIECE(^BQIFAC(DV,NODE,BQDTMN,1,DN,0),U,4)=$PIECE($GET(^BQIFAC(DV,NODE,BQDTMN,1,DN,0)),U,4)+$GET(CEXC)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+28 QUIT
+29 ;
UPD ;EP
+1 IF $GET(^BQIFAC(FAC,80,0))=""
SET ^BQIFAC(FAC,80,0)="^90505.68D^^"
+2 ;
+3 NEW DA,X,IENS,Y,DIC,DLAYGO
+4 SET DA(1)=FAC
SET DIC="^BQIFAC("_DA(1)_",80,"
SET X=BQDATE
SET DIC(0)="LNZ"
SET DLAYGO=90505.68
SET DIC("P")=DLAYGO
+5 DO ^DIC
+6 SET DA=+Y
IF DA=-1
QUIT
+7 SET BQDTMN=DA
+8 QUIT
