Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BQIMUUPD

BQIMUUPD.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. EN ;EP
  1.  I '$$PATCH^XPDUTL("APCM*1.0*2") Q
  1.  NEW CURR
  1.  S CURR=$P($G(^BQI(90508,1,9)),U,3)
  1.  I CURR="" D
  1.  . S CURR="INTERIM STAGE 1 2013"
  1.  . I '$D(^APCMMUCN("B",CURR)) Q
  1.  . D UP
  1.  . I $P($G(^BQI(90508,1,9)),U,3)="" S $P(^BQI(90508,1,9),U,3)=CURR
  1.  NEW DIK
  1.  S DIK="^BQIPROV(" D IXALL^DIK
  1.  S DIK="^BQIFAC(" D IXALL^DIK
  1.  Q
  1.  ;
  1. UP ;EP - Facility
  1.  NEW FAC,FN,MN
  1.  S FAC=0
  1.  F  S FAC=$O(^BQIFAC(FAC)) Q:'FAC  D
  1.  . S FN=0
  1.  . F  S FN=$O(^BQIFAC(FAC,40,FN)) Q:'FN  D
  1.  .. S MN=0
  1.  .. F  S MN=$O(^BQIFAC(FAC,40,FN,1,MN)) Q:'MN  D
  1.  ... NEW DA,IENS
  1.  ... S DA(2)=FAC,DA(1)=FN,DA=MN,IENS=$$IENS^DILF(.DA)
  1.  ... I $$GET1^DIQ(90505.641,IENS,.04,"E")="" S BQIUPD(90505.641,IENS,.04)=CURR
  1.  . S FN=0
  1.  . F  S FN=$O(^BQIFAC(FAC,70,FN)) Q:'FN  D
  1.  .. S MN=0
  1.  .. F  S MN=$O(^BQIFAC(FAC,70,FN,1,MN)) Q:'MN  D
  1.  ... NEW DA,IENS
  1.  ... S DA(2)=FAC,DA(1)=FN,DA=MN,IENS=$$IENS^DILF(.DA)
  1.  ... I $$GET1^DIQ(90505.671,IENS,.04,"E")="" S BQIUPD(90505.671,IENS,.04)=CURR
  1.  I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
  1.  ;
  1.  ;Provider
  1.  NEW PRV,FN,MN
  1.  S PRV=0
  1.  F  S PRV=$O(^BQIPROV(PRV)) Q:'PRV  D
  1.  . S FN=0
  1.  . F  S FN=$O(^BQIPROV(PRV,40,FN)) Q:'FN  D
  1.  .. S MN=0
  1.  .. F  S MN=$O(^BQIPROV(PRV,40,FN,1,MN)) Q:'MN  D
  1.  ... NEW DA,IENS
  1.  ... S DA(2)=PRV,DA(1)=FN,DA=MN,IENS=$$IENS^DILF(.DA)
  1.  ... I $$GET1^DIQ(90505.441,IENS,.04,"E")="" S BQIUPD(90505.441,IENS,.04)=CURR
  1.  I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
  1.  Q
  1.  ;
  1. SXRF ; Set cross-reference
  1.  I $G(^BQIPROV(DA(2),40,DA(1),0))'="" S ^BQIPROV("AC",X,^BQIPROV(DA(2),40,DA(1),0),DA(2))=""
  1.  Q
  1.  ;
  1. KXRF ; Kill cross-reference
  1.  I $G(^BQIPROV(DA(2),40,DA(1),0))'="" K ^BQIPROV("AC",X,^BQIPROV(DA(2),40,DA(1),0),DA(2))
  1.  Q
  1.  ;
  1. SHRF ; Set hospital cross-reference
  1.  I $G(^BQIFAC(DA(2),40,DA(1),0))'="" S ^BQIFAC("AC",X,^BQIFAC(DA(2),40,DA(1),0),DA(2))=""
  1.  Q
  1.  ;
  1. KHRF ; Kill hospital
  1.  I $G(^BQIFAC(DA(2),40,DA(1),0))'="" K ^BQIFAC("AC",X,^BQIFAC(DA(2),40,DA(1),0),DA(2))
  1.  Q
  1.  ;
  1. P3 ;EP - Patch 3 update CQ data by division
  1.  ; Clean up and reset to zero
  1.  S DV=0
  1.  F  S DV=$O(^BQIFAC(DV)) Q:'DV  D
  1.  . S BQDTMN=0
  1.  . F  S BQDTMN=$O(^BQIFAC(DV,80,BQDTMN)) Q:'BQDTMN  D
  1.  .. S DN=0
  1.  .. F  S DN=$O(^BQIFAC(DV,80,BQDTMN,1,DN)) Q:'DN  D
  1.  ... S $P(^BQIFAC(DV,80,BQDTMN,1,DN,0),U,2)=0,$P(^(0),U,3)=0,$P(^(0),U,4)=0
  1.  ;
  1.  ; Update by provider
  1.  S BGPPROV=0
  1.  F  S BGPPROV=$O(^BQIPROV(BGPPROV)) Q:'BGPPROV  D
  1.  . S BQTMN=0
  1.  . F  S BQTMN=$O(^BQIPROV(BGPPROV,50,BQTMN)) Q:'BQTMN  D
  1.  .. S BQDATE=^BQIPROV(BGPPROV,50,BQTMN,0)
  1.  .. S BQID=0
  1.  .. F  S BQID=$O(^BQIPROV(BGPPROV,50,BQTMN,1,BQID)) Q:'BQID  D
  1.  ... 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)
  1.  ... S DV=0,NODE=80
  1.  ... F  S DV=$O(^VA(200,BGPPROV,2,DV)) Q:'DV  D
  1.  .... I $G(^BQIFAC(DV,0))="" S ^BQIFAC(DV,0)=DV,^BQIFAC("B",DV,DV)=""
  1.  .... S FAC=DV D UPD
  1.  .... S DN=$O(^BQIFAC(DV,NODE,BQDTMN,1,"B",ID,"")) I DN="" S DN=BQID
  1.  .... 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)=""
  1.  .... S $P(^BQIFAC(DV,NODE,BQDTMN,1,DN,0),U,2)=$P($G(^BQIFAC(DV,NODE,BQDTMN,1,DN,0)),U,2)+$G(CDEN)
  1.  .... S $P(^BQIFAC(DV,NODE,BQDTMN,1,DN,0),U,3)=$P($G(^BQIFAC(DV,NODE,BQDTMN,1,DN,0)),U,3)+$G(CNUM)
  1.  .... S $P(^BQIFAC(DV,NODE,BQDTMN,1,DN,0),U,4)=$P($G(^BQIFAC(DV,NODE,BQDTMN,1,DN,0)),U,4)+$G(CEXC)
  1.  Q
  1.  ;
  1. UPD ;EP
  1.  I $G(^BQIFAC(FAC,80,0))="" S ^BQIFAC(FAC,80,0)="^90505.68D^^"
  1.  ;
  1.  NEW DA,X,IENS,Y,DIC,DLAYGO
  1.  S DA(1)=FAC,DIC="^BQIFAC("_DA(1)_",80,",X=BQDATE,DIC(0)="LNZ",DLAYGO=90505.68,DIC("P")=DLAYGO
  1.  D ^DIC
  1.  S DA=+Y I DA=-1 Q
  1.  S BQDTMN=DA
  1.  Q