BQIIPUTL ;VNGT/HS/ALA-utility program for IPC ; 05 May 2011 12:55 PM
;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23
;
;
STORF(FAC,ID,BQDATE,DEN,NUM) ;EP - Store facility data Monthly
; Input parameters
; FAC - Facility IEN
; ID - Measure ID
; BQDATE - Month and Year date
; DEN - Denominator value
; NUM - Numerator value
;
NEW DA,DIC,DLAYGO,MSRN,X
I '$D(^BQIFAC(FAC,30,0)) S ^BQIFAC(FAC,30,0)="^90505.63^^"
S DA(1)=FAC,DIC(0)="LMNXZ",DLAYGO=90505.63,X=ID,DIC="^BQIFAC("_DA(1)_",30,"
D ^DIC I Y=-1 K DO,DD D FILE^DICN
S MSRN=+Y
I '$D(^BQIFAC(FAC,30,MSRN,1,0)) S ^BQIFAC(FAC,30,MSRN,1,0)="^90505.631D^^"
S DA(2)=FAC,DA(1)=MSRN,DIC(0)="LMNZ",DLAYGO=90505.631,X=$S($L(BQDATE)=5:BQDATE_"00",1:BQDATE)
S DIC="^BQIFAC("_DA(2)_",30,"_DA(1)_",1,"
D ^DIC I Y=-1 K DO,DD D FILE^DICN
S DA=+Y
S $P(^BQIFAC(FAC,30,MSRN,1,DA,0),U,2,3)=DEN_U_NUM
Q
;
STORP(PROV,ID,BQDATE,DEN,NUM) ;EP - Store for provider Monthly
; PROV - Provider IEN
; ID - Measure ID
; BQDATE - Month and Year date
; DEN - Denominator value
; NUM - Numerator value
;
NEW DA,DIC,MSRN,DLAYGO,X
I $G(^BQIPROV(PROV,0))="" D NPR(PROV)
I '$D(^BQIPROV(PROV,30,0)) S ^BQIPROV(PROV,30,0)="^90505.43^^"
S DA(1)=PROV,DIC(0)="LMNXZ",DLAYGO=90505.43,X=ID,DIC="^BQIPROV("_DA(1)_",30,"
D ^DIC I Y=-1 K DO,DD D FILE^DICN
S MSRN=+Y
I '$D(^BQIPROV(PROV,30,MSRN,1,0)) S ^BQIPROV(PROV,30,MSRN,1,0)="^90505.431D^^"
S DA(2)=PROV,DA(1)=MSRN,DIC(0)="LMNZ",DLAYGO=90505.431,X=$S($L(BQDATE)=5:BQDATE_"00",1:BQDATE)
S DIC="^BQIPROV("_DA(2)_",30,"_DA(1)_",1,"
D ^DIC I Y=-1 K DO,DD D FILE^DICN
S DA=+Y
S $P(^BQIPROV(PROV,30,MSRN,1,DA,0),U,2,3)=DEN_U_NUM
Q
;
STORT(TEAM,ID,BQDATE,DEN,NUM) ;EP - Store for team Monthly
; Team - Team Name
; ID - Measure ID
; BQDATE - Month and Year date
; DEN - Denominator value
; NUM - Numerator value
;
NEW DA,DIC,MSRN,DLAYGO,X,TMN
S TMN=$O(^BQITEAM("B",TEAM,"")) I TMN="" D NTM(TEAM)
I '$D(^BQITEAM(TMN,10,0)) S ^BQITEAM(TMN,10,0)="^90505.801^^"
S DA(1)=TMN,DIC(0)="LMNXZ",DLAYGO=90505.801,X=ID,DIC="^BQITEAM("_DA(1)_",10,"
D ^DIC I Y=-1 K DO,DD D FILE^DICN
S MSRN=+Y
I '$D(^BQITEAM(TMN,10,MSRN,10,0)) S ^BQITEAM(TMN,10,MSRN,10,0)="^90505.802^^"
S DA(2)=TMN,DA(1)=MSRN,DIC(0)="LMNZ",DLAYGO=90505.802,X=$S($L(BQDATE)=5:BQDATE_"00",1:BQDATE)
S DIC="^BQITEAM("_DA(2)_",10,"_DA(1)_",10,"
D ^DIC I Y=-1 K DO,DD D FILE^DICN
S (DA,WDA)=+Y
S $P(^BQITEAM(TMN,10,MSRN,10,DA,0),U,2,3)=DEN_U_NUM
;
;Add Team Members
I '$D(^BQITEAM(TMN,10,MSRN,10,WDA,30,0)) S ^BQITEAM(TMN,10,MSRN,10,WDA,30,0)="^90505.804P^^"
S PTMN=$O(^BSDPCT("B",TEAM,"")) I PTMN="" Q
S TMM="" F S TMM=$O(^BSDPCT(PTMN,1,"B",TMM)) Q:TMM="" D
. NEW DA,DIC,DLAYGO,X
. S DA(3)=TMN,DA(2)=MSRN,DA(1)=WDA,X=$P(^VA(200,TMM,0),"^",1),DIC(0)="LMNZ",DLAYGO=90505.804
. S DIC="^BQITEAM("_DA(3)_",10,"_DA(2)_",10,"_DA(1)_",30,"
. D ^DIC I Y=-1 K DO,DD D FILE^DICN
. S DA=+Y
Q
;
STORPW(PROV,ID,BQFROM,BQTHRU,DEN,NUM) ;EP - Store for provider Weekly
; PROV - Provider IEN
; ID - Measure ID
; BQFROM - Week From Date
; BQTHRU - Week Thru Date
; DEN - Denominator value
; NUM - Numerator value
;
NEW DA,DIC,MSRN,DLAYGO,X,BQIUPD
I $G(^BQIPROV(PROV,0))="" D NPR(PROV)
I '$D(^BQIPROV(PROV,30,0)) S ^BQIPROV(PROV,30,0)="^90505.43^^"
S DA(1)=PROV,DIC(0)="LMNXZ",DLAYGO=90505.43,X=ID,DIC="^BQIPROV("_DA(1)_",30,"
D ^DIC I Y=-1 K DO,DD D FILE^DICN
S MSRN=+Y
I '$D(^BQIPROV(PROV,30,MSRN,2,0)) S ^BQIPROV(PROV,30,MSRN,2,0)="^90505.432^^"
S DA(2)=PROV,DA(1)=MSRN,DIC(0)="LMNZ",DLAYGO=90505.432
S DA=$O(^BQIPROV(PROV,30,MSRN,2,"AC",BQTHRU,""))
I DA="" D
. S X=0,LX=0 F S X=$O(^BQIPROV(PROV,30,MSRN,2,X)) Q:'X S LX=X
. S X=LX+1
. S DIC="^BQIPROV("_DA(2)_",30,"_DA(1)_",2,"
. D ^DIC I Y=-1 K DO,DD D FILE^DICN
. S DA=+Y
NEW IENS
S DA(2)=PROV,DA(1)=MSRN,IENS=$$IENS^DILF(.DA)
S BQIUPD(90505.432,IENS,.02)=DEN
S BQIUPD(90505.432,IENS,.03)=NUM
S BQIUPD(90505.432,IENS,.04)=BQFROM
S BQIUPD(90505.432,IENS,.05)=BQTHRU
;S $P(^BQIPROV(PROV,30,MSRN,2,DA,0),U,2,3)=DEN_U_NUM_U_BQFROM_U_BQTHRU
D FILE^DIE("","BQIUPD","ERROR")
Q
;
STORTW(TEAM,ID,BQFROM,BQTHRU,DEN,NUM) ;EP - Store for team Weekly
; Team - Team Name
; ID - Measure ID
; BQFROM - Week From Date
; BQTHRU - Week Thru Date
; DEN - Denominator value
; NUM - Numerator value
;
NEW DA,DIC,MSRN,DLAYGO,X,TMN
S TMN=$O(^BQITEAM("B",TEAM,"")) I TMN="" D NTM(TEAM)
I '$D(^BQITEAM(TMN,10,0)) S ^BQITEAM(TMN,10,0)="^90505.801^^"
S DA(1)=TMN,DIC(0)="LMNXZ",DLAYGO=90505.801,X=ID,DIC="^BQITEAM("_DA(1)_",10,"
D ^DIC I Y=-1 K DO,DD D FILE^DICN
S MSRN=+Y
I '$D(^BQITEAM(TMN,10,MSRN,20,0)) S ^BQITEAM(TMN,10,MSRN,20,0)="^90505.803^^"
S DA(2)=TMN,DA(1)=MSRN,DIC(0)="LMNZ",DLAYGO=90505.803
S WDA=$O(^BQITEAM(TMN,10,MSRN,20,"AC",BQTHRU,"")),DA=WDA
I WDA="" D
. S X=0,LX=0 F S X=$O(^BQITEAM(TMN,10,MSRN,20,X)) Q:'X S LX=X
. S X=LX+1
. S DIC="^BQITEAM("_DA(2)_",10,"_DA(1)_",20,"
. D ^DIC I Y=-1 K DO,DD D FILE^DICN
. S (DA,WDA)=+Y
;S $P(^BQITEAM(TMN,10,MSRN,20,DA,0),U,2,3)=DEN_U_NUM_U_BQFROM_U_BQTHRU
NEW IENS
S DA(2)=TMN,DA(1)=MSRN,IENS=$$IENS^DILF(.DA)
S BQIUPD(90505.803,IENS,.02)=DEN
S BQIUPD(90505.803,IENS,.03)=NUM
S BQIUPD(90505.803,IENS,.04)=BQFROM
S BQIUPD(90505.803,IENS,.05)=BQTHRU
D FILE^DIE("","BQIUPD","ERROR")
;
;Add Team Members
I '$D(^BQITEAM(TMN,10,MSRN,20,WDA,30,0)) S ^BQITEAM(TMN,10,MSRN,20,WDA,30,0)="^90505.805P^^"
S PTMN=$O(^BSDPCT("B",TEAM,"")) I PTMN="" Q
S TMM="" F S TMM=$O(^BSDPCT(PTMN,1,"B",TMM)) Q:TMM="" D
. NEW DA,DIC,DLAYGO,X
. S DA(3)=TMN,DA(2)=MSRN,DA(1)=WDA,X=$P(^VA(200,TMM,0),"^",1),DIC(0)="LMNZ",DLAYGO=90505.805
. S DIC="^BQITEAM("_DA(3)_",10,"_DA(2)_",20,"_DA(1)_",30,"
. D ^DIC I Y=-1 K DO,DD D FILE^DICN
. S DA=+Y
Q
;
STORFW(FAC,ID,BQFROM,BQTHRU,DEN,NUM) ;EP - Store facility data Weekly
; Input parameters
; FAC - Facility IEN
; ID - Measure ID
; BQFROM - Week From Date
; BQTHRU - Week Thru Date
; DEN - Denominator value
; NUM - Numerator value
;
NEW DA,DIC,DLAYGO,MSRN,X
I '$D(^BQIFAC(FAC,30,0)) S ^BQIFAC(FAC,30,0)="^90505.63^^"
S DA(1)=FAC,DIC(0)="LMNXZ",DLAYGO=90505.63,X=ID,DIC="^BQIFAC("_DA(1)_",30,"
D ^DIC I Y=-1 K DO,DD D FILE^DICN
S MSRN=+Y
I '$D(^BQIFAC(FAC,30,MSRN,2,0)) S ^BQIFAC(FAC,30,MSRN,2,0)="^90505.632^^"
S DA(2)=FAC,DA(1)=MSRN,DIC(0)="LMNZ",DLAYGO=90505.632
S DA=$O(^BQIFAC(FAC,30,MSRN,2,"AC",BQTHRU,""))
I DA="" D
. S X=0,LX=0 F S X=$O(^BQIFAC(FAC,30,MSRN,2,X)) Q:'X S LX=X
. S X=LX+1
. S DIC="^BQIFAC("_DA(2)_",30,"_DA(1)_",2,"
. D ^DIC I Y=-1 K DO,DD D FILE^DICN
. S DA=+Y
NEW IENS
S DA(2)=FAC,DA(1)=MSRN,IENS=$$IENS^DILF(.DA)
S BQIUPD(90505.632,IENS,.02)=DEN
S BQIUPD(90505.632,IENS,.03)=NUM
S BQIUPD(90505.632,IENS,.04)=BQFROM
S BQIUPD(90505.632,IENS,.05)=BQTHRU
D FILE^DIE("","BQIUPD","ERROR")
Q
;
NPR(PROV) ; EP - Add a new provider
NEW DA,DIC,X,DINUM,Y
S (DINUM,X)=PROV,DIC(0)="L",DIC="^BQIPROV("
K DO,DD D FILE^DICN
Q
;
NTM(TEAM) ;EP - Add a team
NEW DA,DIC,X,Y
S X=TEAM,DIC(0)="L",DIC="^BQITEAM("
K DO,DD D FILE^DICN
S TMN=+Y
Q
;
VIEW(DATA,FAKE) ;EP - BQI GET IPC VIEW
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIIPCV",UID))
K @DATA
S II=0
S @DATA@(II)="T00010VIEW"_$C(30)
S II=II+1,@DATA@(II)="MONTHLY"_$C(30)
S II=II+1,@DATA@(II)="WEEKLY"_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
TBL(DATA,FAKE) ;EP - BQI GET IPC RELEASES
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIIPCR",UID))
K @DATA
S II=0
S @DATA@(II)="T00010CODE"_$C(30)
S II=II+1,@DATA@(II)="IPC4/IPC5"_$C(30)
S II=II+1,@DATA@(II)="IPCMH"_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
CIPC(DATA,FAKE) ;EP - BQI GET IPC VERSION
NEW IDATA,DATM
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIIPCV",UID))
K @DATA
S II=0
S @DATA@(II)="T00010IPC_VERSION^D00010WHEN^T00035WHO"_$C(30)
S IDATA=$G(^BQI(90508,1,11))
S DATM=$$GET1^DIQ(90508,"1,",11.09,"I"),DATM=$$FMTMDY^BQIUL1(DATM)
S II=II+1,@DATA@(II)=$P(IDATA,"^",1)_"^"_DATM_"^"_$$GET1^DIQ(90508,"1,",11.1,"E")_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
SIPC(DATA,VERS) ;EP - BQI SAVE IPC VERSION
NEW II,OK,BQIDA,BQIUPD,CRIPC,MSG,ERROR,SFL
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIIPCS",UID))
K @DATA
S II=0,OK=0
S @DATA@(II)="I00010RESULT^T00080MESSAGE"_$C(30)
;
S CRIPC=$P($G(^BQI(90508,1,11)),U,1),SFL=+$P($G(^BQI(90508,1,11)),U,8)
I 'SFL S OK=1,MSG=""
I SFL S OK=0,MSG="Cannot return to the previous version"
I OK D
. S BQIDA=$$SPM^BQIGPUTL()
. S BQIUPD(90508,BQIDA_",",11)=VERS,BQIUPD(90508,BQIDA_",",11.08)=1,BQIUPD(90508,BQIDA_",",11.09)=$$NOW^XLFDT()
. S BQIUPD(90508,BQIDA_",",11.1)=DUZ
. D FILE^DIE("","BQIUPD","ERROR")
. K BQIUPD
. I $D(ERROR) S MSG=$G(ERROR("DIERR",1,"TEXT",1)),OK=0
S II=II+1
I '$D(ERROR) S @DATA@(II)="1^"_MSG_$C(30)
I 'OK S @DATA@(II)="-1^"_MSG_$C(30)
;
S II=II+1,@DATA@(II)=$C(31)
Q
;
RESET ;reset IPC version
S $P(^BQI(90508,1,11),"^",1)="IPC4/IPC5",$P(^(11),"^",8)="",$P(^(11),"^",9)="",$P(^(11),"^",10)=""
Q
;
MON ;EP - Months
;;JAN
;;FEB
;;MAR
;;APR
;;MAY
;;JUN
;;JUL
;;AUG
;;SEP
;;OCT
;;NOV
;;DEC
BQIIPUTL ;VNGT/HS/ALA-utility program for IPC ; 05 May 2011 12:55 PM
+1 ;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23
+2 ;
+3 ;
STORF(FAC,ID,BQDATE,DEN,NUM) ;EP - Store facility data Monthly
+1 ; Input parameters
+2 ; FAC - Facility IEN
+3 ; ID - Measure ID
+4 ; BQDATE - Month and Year date
+5 ; DEN - Denominator value
+6 ; NUM - Numerator value
+7 ;
+8 NEW DA,DIC,DLAYGO,MSRN,X
+9 IF '$DATA(^BQIFAC(FAC,30,0))
SET ^BQIFAC(FAC,30,0)="^90505.63^^"
+10 SET DA(1)=FAC
SET DIC(0)="LMNXZ"
SET DLAYGO=90505.63
SET X=ID
SET DIC="^BQIFAC("_DA(1)_",30,"
+11 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+12 SET MSRN=+Y
+13 IF '$DATA(^BQIFAC(FAC,30,MSRN,1,0))
SET ^BQIFAC(FAC,30,MSRN,1,0)="^90505.631D^^"
+14 SET DA(2)=FAC
SET DA(1)=MSRN
SET DIC(0)="LMNZ"
SET DLAYGO=90505.631
SET X=$SELECT($LENGTH(BQDATE)=5:BQDATE_"00",1:BQDATE)
+15 SET DIC="^BQIFAC("_DA(2)_",30,"_DA(1)_",1,"
+16 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+17 SET DA=+Y
+18 SET $PIECE(^BQIFAC(FAC,30,MSRN,1,DA,0),U,2,3)=DEN_U_NUM
+19 QUIT
+20 ;
STORP(PROV,ID,BQDATE,DEN,NUM) ;EP - Store for provider Monthly
+1 ; PROV - Provider IEN
+2 ; ID - Measure ID
+3 ; BQDATE - Month and Year date
+4 ; DEN - Denominator value
+5 ; NUM - Numerator value
+6 ;
+7 NEW DA,DIC,MSRN,DLAYGO,X
+8 IF $GET(^BQIPROV(PROV,0))=""
DO NPR(PROV)
+9 IF '$DATA(^BQIPROV(PROV,30,0))
SET ^BQIPROV(PROV,30,0)="^90505.43^^"
+10 SET DA(1)=PROV
SET DIC(0)="LMNXZ"
SET DLAYGO=90505.43
SET X=ID
SET DIC="^BQIPROV("_DA(1)_",30,"
+11 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+12 SET MSRN=+Y
+13 IF '$DATA(^BQIPROV(PROV,30,MSRN,1,0))
SET ^BQIPROV(PROV,30,MSRN,1,0)="^90505.431D^^"
+14 SET DA(2)=PROV
SET DA(1)=MSRN
SET DIC(0)="LMNZ"
SET DLAYGO=90505.431
SET X=$SELECT($LENGTH(BQDATE)=5:BQDATE_"00",1:BQDATE)
+15 SET DIC="^BQIPROV("_DA(2)_",30,"_DA(1)_",1,"
+16 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+17 SET DA=+Y
+18 SET $PIECE(^BQIPROV(PROV,30,MSRN,1,DA,0),U,2,3)=DEN_U_NUM
+19 QUIT
+20 ;
STORT(TEAM,ID,BQDATE,DEN,NUM) ;EP - Store for team Monthly
+1 ; Team - Team Name
+2 ; ID - Measure ID
+3 ; BQDATE - Month and Year date
+4 ; DEN - Denominator value
+5 ; NUM - Numerator value
+6 ;
+7 NEW DA,DIC,MSRN,DLAYGO,X,TMN
+8 SET TMN=$ORDER(^BQITEAM("B",TEAM,""))
IF TMN=""
DO NTM(TEAM)
+9 IF '$DATA(^BQITEAM(TMN,10,0))
SET ^BQITEAM(TMN,10,0)="^90505.801^^"
+10 SET DA(1)=TMN
SET DIC(0)="LMNXZ"
SET DLAYGO=90505.801
SET X=ID
SET DIC="^BQITEAM("_DA(1)_",10,"
+11 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+12 SET MSRN=+Y
+13 IF '$DATA(^BQITEAM(TMN,10,MSRN,10,0))
SET ^BQITEAM(TMN,10,MSRN,10,0)="^90505.802^^"
+14 SET DA(2)=TMN
SET DA(1)=MSRN
SET DIC(0)="LMNZ"
SET DLAYGO=90505.802
SET X=$SELECT($LENGTH(BQDATE)=5:BQDATE_"00",1:BQDATE)
+15 SET DIC="^BQITEAM("_DA(2)_",10,"_DA(1)_",10,"
+16 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+17 SET (DA,WDA)=+Y
+18 SET $PIECE(^BQITEAM(TMN,10,MSRN,10,DA,0),U,2,3)=DEN_U_NUM
+19 ;
+20 ;Add Team Members
+21 IF '$DATA(^BQITEAM(TMN,10,MSRN,10,WDA,30,0))
SET ^BQITEAM(TMN,10,MSRN,10,WDA,30,0)="^90505.804P^^"
+22 SET PTMN=$ORDER(^BSDPCT("B",TEAM,""))
IF PTMN=""
QUIT
+23 SET TMM=""
FOR
SET TMM=$ORDER(^BSDPCT(PTMN,1,"B",TMM))
IF TMM=""
QUIT
Begin DoDot:1
+24 NEW DA,DIC,DLAYGO,X
+25 SET DA(3)=TMN
SET DA(2)=MSRN
SET DA(1)=WDA
SET X=$PIECE(^VA(200,TMM,0),"^",1)
SET DIC(0)="LMNZ"
SET DLAYGO=90505.804
+26 SET DIC="^BQITEAM("_DA(3)_",10,"_DA(2)_",10,"_DA(1)_",30,"
+27 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+28 SET DA=+Y
End DoDot:1
+29 QUIT
+30 ;
STORPW(PROV,ID,BQFROM,BQTHRU,DEN,NUM) ;EP - Store for provider Weekly
+1 ; PROV - Provider IEN
+2 ; ID - Measure ID
+3 ; BQFROM - Week From Date
+4 ; BQTHRU - Week Thru Date
+5 ; DEN - Denominator value
+6 ; NUM - Numerator value
+7 ;
+8 NEW DA,DIC,MSRN,DLAYGO,X,BQIUPD
+9 IF $GET(^BQIPROV(PROV,0))=""
DO NPR(PROV)
+10 IF '$DATA(^BQIPROV(PROV,30,0))
SET ^BQIPROV(PROV,30,0)="^90505.43^^"
+11 SET DA(1)=PROV
SET DIC(0)="LMNXZ"
SET DLAYGO=90505.43
SET X=ID
SET DIC="^BQIPROV("_DA(1)_",30,"
+12 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+13 SET MSRN=+Y
+14 IF '$DATA(^BQIPROV(PROV,30,MSRN,2,0))
SET ^BQIPROV(PROV,30,MSRN,2,0)="^90505.432^^"
+15 SET DA(2)=PROV
SET DA(1)=MSRN
SET DIC(0)="LMNZ"
SET DLAYGO=90505.432
+16 SET DA=$ORDER(^BQIPROV(PROV,30,MSRN,2,"AC",BQTHRU,""))
+17 IF DA=""
Begin DoDot:1
+18 SET X=0
SET LX=0
FOR
SET X=$ORDER(^BQIPROV(PROV,30,MSRN,2,X))
IF 'X
QUIT
SET LX=X
+19 SET X=LX+1
+20 SET DIC="^BQIPROV("_DA(2)_",30,"_DA(1)_",2,"
+21 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+22 SET DA=+Y
End DoDot:1
+23 NEW IENS
+24 SET DA(2)=PROV
SET DA(1)=MSRN
SET IENS=$$IENS^DILF(.DA)
+25 SET BQIUPD(90505.432,IENS,.02)=DEN
+26 SET BQIUPD(90505.432,IENS,.03)=NUM
+27 SET BQIUPD(90505.432,IENS,.04)=BQFROM
+28 SET BQIUPD(90505.432,IENS,.05)=BQTHRU
+29 ;S $P(^BQIPROV(PROV,30,MSRN,2,DA,0),U,2,3)=DEN_U_NUM_U_BQFROM_U_BQTHRU
+30 DO FILE^DIE("","BQIUPD","ERROR")
+31 QUIT
+32 ;
STORTW(TEAM,ID,BQFROM,BQTHRU,DEN,NUM) ;EP - Store for team Weekly
+1 ; Team - Team Name
+2 ; ID - Measure ID
+3 ; BQFROM - Week From Date
+4 ; BQTHRU - Week Thru Date
+5 ; DEN - Denominator value
+6 ; NUM - Numerator value
+7 ;
+8 NEW DA,DIC,MSRN,DLAYGO,X,TMN
+9 SET TMN=$ORDER(^BQITEAM("B",TEAM,""))
IF TMN=""
DO NTM(TEAM)
+10 IF '$DATA(^BQITEAM(TMN,10,0))
SET ^BQITEAM(TMN,10,0)="^90505.801^^"
+11 SET DA(1)=TMN
SET DIC(0)="LMNXZ"
SET DLAYGO=90505.801
SET X=ID
SET DIC="^BQITEAM("_DA(1)_",10,"
+12 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+13 SET MSRN=+Y
+14 IF '$DATA(^BQITEAM(TMN,10,MSRN,20,0))
SET ^BQITEAM(TMN,10,MSRN,20,0)="^90505.803^^"
+15 SET DA(2)=TMN
SET DA(1)=MSRN
SET DIC(0)="LMNZ"
SET DLAYGO=90505.803
+16 SET WDA=$ORDER(^BQITEAM(TMN,10,MSRN,20,"AC",BQTHRU,""))
SET DA=WDA
+17 IF WDA=""
Begin DoDot:1
+18 SET X=0
SET LX=0
FOR
SET X=$ORDER(^BQITEAM(TMN,10,MSRN,20,X))
IF 'X
QUIT
SET LX=X
+19 SET X=LX+1
+20 SET DIC="^BQITEAM("_DA(2)_",10,"_DA(1)_",20,"
+21 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+22 SET (DA,WDA)=+Y
End DoDot:1
+23 ;S $P(^BQITEAM(TMN,10,MSRN,20,DA,0),U,2,3)=DEN_U_NUM_U_BQFROM_U_BQTHRU
+24 NEW IENS
+25 SET DA(2)=TMN
SET DA(1)=MSRN
SET IENS=$$IENS^DILF(.DA)
+26 SET BQIUPD(90505.803,IENS,.02)=DEN
+27 SET BQIUPD(90505.803,IENS,.03)=NUM
+28 SET BQIUPD(90505.803,IENS,.04)=BQFROM
+29 SET BQIUPD(90505.803,IENS,.05)=BQTHRU
+30 DO FILE^DIE("","BQIUPD","ERROR")
+31 ;
+32 ;Add Team Members
+33 IF '$DATA(^BQITEAM(TMN,10,MSRN,20,WDA,30,0))
SET ^BQITEAM(TMN,10,MSRN,20,WDA,30,0)="^90505.805P^^"
+34 SET PTMN=$ORDER(^BSDPCT("B",TEAM,""))
IF PTMN=""
QUIT
+35 SET TMM=""
FOR
SET TMM=$ORDER(^BSDPCT(PTMN,1,"B",TMM))
IF TMM=""
QUIT
Begin DoDot:1
+36 NEW DA,DIC,DLAYGO,X
+37 SET DA(3)=TMN
SET DA(2)=MSRN
SET DA(1)=WDA
SET X=$PIECE(^VA(200,TMM,0),"^",1)
SET DIC(0)="LMNZ"
SET DLAYGO=90505.805
+38 SET DIC="^BQITEAM("_DA(3)_",10,"_DA(2)_",20,"_DA(1)_",30,"
+39 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+40 SET DA=+Y
End DoDot:1
+41 QUIT
+42 ;
STORFW(FAC,ID,BQFROM,BQTHRU,DEN,NUM) ;EP - Store facility data Weekly
+1 ; Input parameters
+2 ; FAC - Facility IEN
+3 ; ID - Measure ID
+4 ; BQFROM - Week From Date
+5 ; BQTHRU - Week Thru Date
+6 ; DEN - Denominator value
+7 ; NUM - Numerator value
+8 ;
+9 NEW DA,DIC,DLAYGO,MSRN,X
+10 IF '$DATA(^BQIFAC(FAC,30,0))
SET ^BQIFAC(FAC,30,0)="^90505.63^^"
+11 SET DA(1)=FAC
SET DIC(0)="LMNXZ"
SET DLAYGO=90505.63
SET X=ID
SET DIC="^BQIFAC("_DA(1)_",30,"
+12 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+13 SET MSRN=+Y
+14 IF '$DATA(^BQIFAC(FAC,30,MSRN,2,0))
SET ^BQIFAC(FAC,30,MSRN,2,0)="^90505.632^^"
+15 SET DA(2)=FAC
SET DA(1)=MSRN
SET DIC(0)="LMNZ"
SET DLAYGO=90505.632
+16 SET DA=$ORDER(^BQIFAC(FAC,30,MSRN,2,"AC",BQTHRU,""))
+17 IF DA=""
Begin DoDot:1
+18 SET X=0
SET LX=0
FOR
SET X=$ORDER(^BQIFAC(FAC,30,MSRN,2,X))
IF 'X
QUIT
SET LX=X
+19 SET X=LX+1
+20 SET DIC="^BQIFAC("_DA(2)_",30,"_DA(1)_",2,"
+21 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+22 SET DA=+Y
End DoDot:1
+23 NEW IENS
+24 SET DA(2)=FAC
SET DA(1)=MSRN
SET IENS=$$IENS^DILF(.DA)
+25 SET BQIUPD(90505.632,IENS,.02)=DEN
+26 SET BQIUPD(90505.632,IENS,.03)=NUM
+27 SET BQIUPD(90505.632,IENS,.04)=BQFROM
+28 SET BQIUPD(90505.632,IENS,.05)=BQTHRU
+29 DO FILE^DIE("","BQIUPD","ERROR")
+30 QUIT
+31 ;
NPR(PROV) ; EP - Add a new provider
+1 NEW DA,DIC,X,DINUM,Y
+2 SET (DINUM,X)=PROV
SET DIC(0)="L"
SET DIC="^BQIPROV("
+3 KILL DO,DD
DO FILE^DICN
+4 QUIT
+5 ;
NTM(TEAM) ;EP - Add a team
+1 NEW DA,DIC,X,Y
+2 SET X=TEAM
SET DIC(0)="L"
SET DIC="^BQITEAM("
+3 KILL DO,DD
DO FILE^DICN
+4 SET TMN=+Y
+5 QUIT
+6 ;
VIEW(DATA,FAKE) ;EP - BQI GET IPC VIEW
+1 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+2 SET DATA=$NAME(^TMP("BQIIPCV",UID))
+3 KILL @DATA
+4 SET II=0
+5 SET @DATA@(II)="T00010VIEW"_$CHAR(30)
+6 SET II=II+1
SET @DATA@(II)="MONTHLY"_$CHAR(30)
+7 SET II=II+1
SET @DATA@(II)="WEEKLY"_$CHAR(30)
+8 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+9 QUIT
+10 ;
TBL(DATA,FAKE) ;EP - BQI GET IPC RELEASES
+1 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+2 SET DATA=$NAME(^TMP("BQIIPCR",UID))
+3 KILL @DATA
+4 SET II=0
+5 SET @DATA@(II)="T00010CODE"_$CHAR(30)
+6 SET II=II+1
SET @DATA@(II)="IPC4/IPC5"_$CHAR(30)
+7 SET II=II+1
SET @DATA@(II)="IPCMH"_$CHAR(30)
+8 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+9 QUIT
+10 ;
CIPC(DATA,FAKE) ;EP - BQI GET IPC VERSION
+1 NEW IDATA,DATM
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQIIPCV",UID))
+4 KILL @DATA
+5 SET II=0
+6 SET @DATA@(II)="T00010IPC_VERSION^D00010WHEN^T00035WHO"_$CHAR(30)
+7 SET IDATA=$GET(^BQI(90508,1,11))
+8 SET DATM=$$GET1^DIQ(90508,"1,",11.09,"I")
SET DATM=$$FMTMDY^BQIUL1(DATM)
+9 SET II=II+1
SET @DATA@(II)=$PIECE(IDATA,"^",1)_"^"_DATM_"^"_$$GET1^DIQ(90508,"1,",11.1,"E")_$CHAR(30)
+10 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+11 QUIT
+12 ;
SIPC(DATA,VERS) ;EP - BQI SAVE IPC VERSION
+1 NEW II,OK,BQIDA,BQIUPD,CRIPC,MSG,ERROR,SFL
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQIIPCS",UID))
+4 KILL @DATA
+5 SET II=0
SET OK=0
+6 SET @DATA@(II)="I00010RESULT^T00080MESSAGE"_$CHAR(30)
+7 ;
+8 SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
SET SFL=+$PIECE($GET(^BQI(90508,1,11)),U,8)
+9 IF 'SFL
SET OK=1
SET MSG=""
+10 IF SFL
SET OK=0
SET MSG="Cannot return to the previous version"
+11 IF OK
Begin DoDot:1
+12 SET BQIDA=$$SPM^BQIGPUTL()
+13 SET BQIUPD(90508,BQIDA_",",11)=VERS
SET BQIUPD(90508,BQIDA_",",11.08)=1
SET BQIUPD(90508,BQIDA_",",11.09)=$$NOW^XLFDT()
+14 SET BQIUPD(90508,BQIDA_",",11.1)=DUZ
+15 DO FILE^DIE("","BQIUPD","ERROR")
+16 KILL BQIUPD
+17 IF $DATA(ERROR)
SET MSG=$GET(ERROR("DIERR",1,"TEXT",1))
SET OK=0
End DoDot:1
+18 SET II=II+1
+19 IF '$DATA(ERROR)
SET @DATA@(II)="1^"_MSG_$CHAR(30)
+20 IF 'OK
SET @DATA@(II)="-1^"_MSG_$CHAR(30)
+21 ;
+22 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+23 QUIT
+24 ;
RESET ;reset IPC version
+1 SET $PIECE(^BQI(90508,1,11),"^",1)="IPC4/IPC5"
SET $PIECE(^(11),"^",8)=""
SET $PIECE(^(11),"^",9)=""
SET $PIECE(^(11),"^",10)=""
+2 QUIT
+3 ;
MON ;EP - Months
+1 ;;JAN
+2 ;;FEB
+3 ;;MAR
+4 ;;APR
+5 ;;MAY
+6 ;;JUN
+7 ;;JUL
+8 ;;AUG
+9 ;;SEP
+10 ;;OCT
+11 ;;NOV
+12 ;;DEC
