BQI23POS ;VNGT/HS/ALA - Version 2.3 PostInstall ; 20 May 2011 2:00 PM
;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
;
;
EN ;
;Set the version number
NEW DA
S DA=$O(^BQI(90508,0))
S BQIUPD(90508,DA_",",.08)="2.3.0.26"
S BQIUPD(90508,DA_",",.09)="2.3.0T26"
S BQIUPD(90508,DA_",",11)="IPC3"
S BQIUPD(90508,DA_",",11.02)=1
S BQIUPD(90508,DA_",",.07)=1
I $G(^BQI(90508,DA,16))="" S BQIUPD(90508,DA_",",16.01)="L"
;
;Set the timeout values
S BQIUPD(90508,DA_",",.21)="60"
S BQIUPD(90508,DA_",",.22)="5"
S BQIUPD(90508,DA_",",.23)="60"
;
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
NEW NDZ
S NDZ=0
F S NDZ=$O(^BQICARE(NDZ)) Q:'NDZ D
. I $P($G(^BQICARE(NDZ,2)),U,5)="" D
.. S BQIUPD(90505,NDZ_",",2.05)=$$FIND1^DIC(90506.4,"","BX","Patient List","","","ERROR")
.. S BQIUPD(90505,NDZ_",",2.06)="N"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
;Set the group order parm to no
NEW DA,BQIUPD,ERROR
S DA=$$SPM^BQIGPUTL()
S BQIUPD(90508,DA_",",.2)="@"
I $D(BQIUPD) D FILE^DIE("E","BQIUPD","ERROR")
K DA,BQIUPD,ERROR
;
;For CANES 2.0
;D DX^BQI202PU
;
; Set BTPWRPC into BQIRPC
NEW IEN,DA,X,DIC,Y
S DA(1)=$$FIND1^DIC(19,"","B","BQIRPC","","","ERROR"),DIC="^DIC(19,"_DA(1)_",10,",DIC(0)="LMNZ"
I $G(^DIC(19,DA(1),10,0))="" S ^DIC(19,DA(1),10,0)="^19.01IP^^"
S X="BTPWRPC"
D ^DIC I +Y<1 K DO,DD D FILE^DICN
;
; Add reports to menu
S X=$$ADD^XPDMENU("APCL IPC REPORTS MENU","BQI IPC MISMATCH PROV","MIS")
S X=$$ADD^XPDMENU("APCL IPC REPORTS MENU","BQI IPC PROVIDER COUNT","CNT")
;
; Convert pointers to codes
NEW NDZ,NPL,CRN,OVL,OVAL,SHZ
S NDZ=0
F S NDZ=$O(^BQICARE(NDZ)) Q:'NDZ D
. I $G(^BQICARE(NDZ,0))="" K ^BQICARE(NDZ) Q
. S NPL=0
. F S NPL=$O(^BQICARE(NDZ,1,NPL)) Q:'NPL D
.. S CRN=0
.. F S CRN=$O(^BQICARE(NDZ,1,NPL,20,CRN)) Q:'CRN D
... S OVAL=$P(^BQICARE(NDZ,1,NPL,20,CRN,0),"^",1)
... I OVAL'?.N Q
... NEW DA,IENS
... S DA(2)=NDZ,DA(1)=NPL,DA=CRN,IENS=$$IENS^DILF(.DA)
... S BQIUPD(90505.05,IENS,.01)=$P(^BQI(90506.1,OVAL,0),U,1)
.. S CRN=0
.. F S CRN=$O(^BQICARE(NDZ,1,NPL,23,CRN)) Q:'CRN D
... S IEN=0
... F S IEN=$O(^BQICARE(NDZ,1,NPL,23,CRN,1,IEN)) Q:'IEN D
.... S OVAL=$P(^BQICARE(NDZ,1,NPL,23,CRN,1,IEN,0),"^",1)
.... I OVAL'?.N Q
.... NEW DA,IENS
.... S DA(3)=NDZ,DA(2)=NPL,DA(1)=CRN,DA=IEN,IENS=$$IENS^DILF(.DA)
.... S BQIUPD(90505.1231,IENS,.01)=$P(^BQI(90506.1,OVAL,0),U,1)
.. S SHZ=0
.. F S SHZ=$O(^BQICARE(NDZ,1,NPL,30,SHZ)) Q:'SHZ D
... S CRN=0
... F S CRN=$O(^BQICARE(NDZ,1,NPL,30,SHZ,20,CRN)) Q:'CRN D
.... S OVAL=$P(^BQICARE(NDZ,1,NPL,30,SHZ,20,CRN,0),"^",1)
.... I OVAL'?.N Q
.... NEW DA,IENS
.... S DA(3)=NDZ,DA(2)=NPL,DA(1)=SHZ,DA=CRN,IENS=$$IENS^DILF(.DA)
.... S BQIUPD(90505.06,IENS,.01)=$P(^BQI(90506.1,OVAL,0),U,1)
... S CRN=0
... F S CRN=$O(^BQICARE(NDZ,1,NPL,30,SHZ,23,CRN)) Q:'CRN D
.... S IEN=0
.... F S IEN=$O(^BQICARE(NDZ,1,NPL,30,SHZ,23,CRN,1,IEN)) Q:'IEN D
..... S OVAL=$P(^BQICARE(NDZ,1,NPL,30,SHZ,23,CRN,1,IEN,0),"^",1)
..... I OVAL'?.N Q
..... NEW DA,IENS
..... S DA(4)=NDZ,DA(3)=NPL,DA(2)=SHZ,DA(1)=CRN,DA=IEN,IENS=$$IENS^DILF(.DA)
..... S BQIUPD(90505.3231,IENS,.01)=$P(^BQI(90506.1,OVAL,0),U,1)
. I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
;
; Add new patient entries to 90506.1
NEW BI,BJ,BK,BN,BQIUPD,ERROR,IEN,ND,NDATA,TEXT,VAL
F BI=1:1 S TEXT=$P($T(LYT+BI),";;",2) Q:TEXT="" D
. F BJ=1:1:$L(TEXT,"~") D
.. S NDATA=$P(TEXT,"~",BJ)
.. S ND=$P(NDATA,"|",1),VAL=$P(NDATA,"|",2)
.. I ND=0 D
... NEW DIC,X,Y
... S DIC(0)="LQZ",DIC="^BQI(90506.1,",X=$P(VAL,U,1)
... D ^DIC
... S IEN=+Y
... I IEN=-1 K DO,DD D FILE^DICN S IEN=+Y
.. I ND=1 S BQIUPD(90506.1,IEN_",",1)=VAL Q
.. F BK=1:1:$L(VAL,"^") D
... S BN=$O(^DD(90506.1,"GL",ND,BK,"")) I BN="" Q
... I $P(VAL,"^",BK)'="" S BQIUPD(90506.1,IEN_",",BN)=$P(VAL,"^",BK) Q
... I $P(VAL,"^",BK)="" S BQIUPD(90506.1,IEN_",",BN)="@"
. D FILE^DIE("","BQIUPD","ERROR")
;
; Re-Index File
K ^BQI(90506.1,"AC"),^BQI(90506.1,"AD")
NEW DIK
S DIK="^BQI(90506.1,",DIK(1)=3.01
D ENALL^DIK
;
; Update IPC measures
D ^BQI23PU
;
; Fix Template Pointer Issues
D FIX()
;
;Regenerate Panel Descriptions
D PDESC()
;
;Make Reproductive Factors Definition fields Active/Inactive
D UVDEF^BQIPTRP1()
;
IP ; Fix Outcome Bundle update
I $D(^BQI(90508,1,22,1,3,"B",3120200)) D
. D DM^BQIIPOTC(1,32,3120200,"IPC_DMCTRL","")
. D LD^BQIIPOTC(1,57,3120200,"IPC_LDCTRL","")
. D BP^BQIIPOTC(1,58,3120200,"IPC_BPCTRL","")
. D EN^BQIIPOTC(3120200)
. D GS(3120200)
;
I $D(^BQI(90508,1,22,1,3,"B",3120300)) D
. D DM^BQIIPOTC(1,32,3120300,"IPC_DMCTRL","")
. D LD^BQIIPOTC(1,57,3120300,"IPC_LDCTRL","")
. D BP^BQIIPOTC(1,58,3120300,"IPC_BPCTRL","")
. D EN^BQIIPOTC(3120300)
. D GS(3120300)
;
MU ; Run MU Provider data for first Monthly periods
; Clean up old data
S PRV=0 F S PRV=$O(^BQIPROV(PRV)) Q:'PRV K ^BQIPROV(PRV,11),^BQIPROV(PRV,21),^BQIPROV(PRV,60),^BQIPROV(PRV,50)
S FAC=$O(^BQIFAC(0)) I FAC'="" K ^BQIFAC(FAC,11),^BQIFAC(FAC,21),^BQIFAC(FAC,60),^BQIFAC(FAC,50)
;
D
. NEW BQDT,FAC,BQTMN,BQNO,CDTM
. S BQDT=$E(DT,1,5)_"00"
. S FAC=$$HME^BQIGPUTL()
. S BQTMN=$O(^BQIFAC(FAC,50,"B",BQDT,""))
. D CKM
. I BQTMN="",'BQNO D EN^BQIMUMON($E(DT,1,5)_"01")
. I BQTMN="",BQNO S ^XTMP("BQIMMON",$E(DT,1,5)_"01")=""
. S ^XTMP("BQIMMON",0)=$$FMADD^XLFDT(DT,365)_U_DT_U_"Month list"
. S CDTM=$E(DT,4,5)
. F BI=7:1:12 S ^XTMP("BQIMMON","311"_$S(BI<10:"0"_BI,1:BI)_"01")=""
. I $E(DT,1,3)>311 F BI=1:1:CDTM S ^XTMP("BQIMMON","312"_$S(BI<10:"0"_BI,1:BI)_"01")=""
;
RSC ; Remove the scheduled tasks
NEW RPC,OPTN,OPN,LIST,ZTSK
F RPC="BQI UPDATE MU CQM 1 YEAR","BQI UPDATE MU CQM 90 DAYS" D
. S OPTN=$$FIND^BQISCHED(RPC)
. I OPTN'>0 Q
. S OPN=$O(^DIC(19.2,"B",OPTN,""))
. I OPN'="" D
.. NEW DA,DIK
.. S DIK="^DIC(19.2,",DA=OPN D ^DIK
. NEW DA,DIK
. S DA=OPTN,DIK="^DIC(19," D ^DIK
. K LIST
. D OPTION^%ZTLOAD(RPC,.LIST)
. S ZTSK=""
. F S ZTSK=$O(@LIST@(ZTSK)) Q:ZTSK="" D
.. D PCLEAR^%ZTLOAD(ZTSK)
.. D KILL^%ZTLOAD
Q
;
GS(BQDATE) ; Update the Goal Set
NEW TPRN,PRV,TPRD,GPRN,GPRD,DEN,FAC,YEAR
S PRV="",YEAR=$$GET1^DIQ(90508,1_",",2,"E")
F S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV="" D
. S TPRN=$O(^BQIPROV(PRV,30,"B","IPC_TOTP","")) I TPRN="" Q
. S TPRD=$O(^BQIPROV(PRV,30,TPRN,1,"B",BQDATE,"")) I TPRD="" Q
. S GPRN=$O(^BQIPROV(PRV,30,"B",YEAR_"_2452","")) I GPRN="" Q
. S GPRD=$O(^BQIPROV(PRV,30,GPRN,1,"B",BQDATE,"")) I GPRD="" Q
. S DEN=$P(^BQIPROV(PRV,30,TPRN,1,TPRD,0),U,2)
. S $P(^BQIPROV(PRV,30,GPRN,1,GPRD,0),U,2)=DEN
S FAC=$$HME^BQIGPUTL()
S TPRN=$O(^BQIFAC(FAC,30,"B","IPC_TOTP","")) I TPRN="" Q
S TPRD=$O(^BQIFAC(FAC,30,TPRN,1,"B",BQDATE,"")) I TPRD="" Q
S GPRN=$O(^BQIFAC(FAC,30,"B",YEAR_"_2452","")) I GPRN="" Q
S GPRD=$O(^BQIFAC(FAC,30,GPRN,1,"B",BQDATE,"")) I GPRD="" Q
S DEN=$P(^BQIFAC(FAC,30,TPRN,1,TPRD,0),U,2)
S $P(^BQIFAC(FAC,30,GPRN,1,GPRD,0),U,2)=DEN
Q
;
PDESC() ;EP - Regenerate Panel Descriptions
NEW USER,PLIEN
S USER=0 F S USER=$O(^BQICARE(USER)) Q:'USER D
. S PLIEN=0 F S PLIEN=$O(^BQICARE(USER,1,PLIEN)) Q:'PLIEN D
.. NEW DESC,DA,IENS
.. S DA(1)=USER,DA=PLIEN,IENS=$$IENS^DILF(.DA)
.. D DESC^BQIPDSCM(USER,PLIEN,.DESC)
.. D WP^DIE(90505.01,IENS,5,"","DESC")
Q
;
FIX() ;EP - FIX INVALID TEMPLATE POINTERS
;
NEW USER,PLIEN,TIEN,SHR
S USER=0 F S USER=$O(^BQICARE(USER)) Q:'USER D
. S PLIEN=0 F S PLIEN=$O(^BQICARE(USER,1,PLIEN)) Q:'PLIEN D
.. S TIEN=0 F S TIEN=$O(^BQICARE(USER,1,PLIEN,4,TIEN)) Q:'TIEN D
... NEW DA,IENS,TEMPL,DIC,X,Y,DIK
... S DA(2)=USER,DA(1)=PLIEN,DA=TIEN,IENS=$$IENS^DILF(.DA)
... S TEMPL=$$GET1^DIQ(90505.14,IENS,.01,"I")
... S X=TEMPL,DIC="^BQICARE("_USER_",15,",DIC(0)="X"
... D ^DIC
... I +Y>0 Q
... S DIK="^BQICARE("_DA(2)_",1,"_DA(1)_",4,"
... D ^DIK
.. ;
.. ;Look for templates in use in shared panels
.. S SHR=0 F S SHR=$O(^BQICARE(USER,1,PLIEN,30,SHR)) Q:'SHR D
... S TIEN=0 F S TIEN=$O(^BQICARE(USER,1,PLIEN,30,SHR,4,TIEN)) Q:'TIEN D
.... NEW DA,IENS,TEMPL,DIC,X,Y,DIK
.... S DA(3)=USER,DA(2)=PLIEN,DA(1)=SHR,DA=TIEN,IENS=$$IENS^DILF(.DA)
.... S TEMPL=$$GET1^DIQ(90505.34,IENS,.01,"I")
.... S X=TEMPL,DIC="^BQICARE("_USER_",15,",DIC(0)="X"
.... D ^DIC
.... I +Y>0 Q
.... S DIK="^BQICARE("_DA(3)_",1,"_DA(2)_",30,"_DA(1)_",4,"
.... D ^DIK
;
Q
;
CKM ;EP - Check for existing job
NEW LIST,TSK,ZTSK
D DESC^%ZTLOAD("MU CQ Monthly Compile",.LIST)
S TSK="",BQNO=0
F S TSK=$O(@LIST@(TSK)) Q:TSK="" S ZTSK=TSK D STAT^%ZTLOAD I ZTSK(2)["Active" S BQNO=1
Q
;
LYT ;EP - Layout items
;;0|EMPL^^Employer^^9000001^.19^^T00060EMPL~1|~3|1^^Other Patient Data^O^42^^^^^BQIZEMPHLTH~5|
;;0|LVDPCP^^Last Visit Date w DPCP^^^^^D00030LVDPCP~1|S VAL=$$LVDPCP^BQIULPT(DFN)~3|1^^Visit Related^O^16^^^D~5|
;;
BQI23POS ;VNGT/HS/ALA - Version 2.3 PostInstall ; 20 May 2011 2:00 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
+2 ;
+3 ;
EN ;
+1 ;Set the version number
+2 NEW DA
+3 SET DA=$ORDER(^BQI(90508,0))
+4 SET BQIUPD(90508,DA_",",.08)="2.3.0.26"
+5 SET BQIUPD(90508,DA_",",.09)="2.3.0T26"
+6 SET BQIUPD(90508,DA_",",11)="IPC3"
+7 SET BQIUPD(90508,DA_",",11.02)=1
+8 SET BQIUPD(90508,DA_",",.07)=1
+9 IF $GET(^BQI(90508,DA,16))=""
SET BQIUPD(90508,DA_",",16.01)="L"
+10 ;
+11 ;Set the timeout values
+12 SET BQIUPD(90508,DA_",",.21)="60"
+13 SET BQIUPD(90508,DA_",",.22)="5"
+14 SET BQIUPD(90508,DA_",",.23)="60"
+15 ;
+16 DO FILE^DIE("","BQIUPD","ERROR")
+17 KILL BQIUPD
+18 ;
+19 NEW NDZ
+20 SET NDZ=0
+21 FOR
SET NDZ=$ORDER(^BQICARE(NDZ))
IF 'NDZ
QUIT
Begin DoDot:1
+22 IF $PIECE($GET(^BQICARE(NDZ,2)),U,5)=""
Begin DoDot:2
+23 SET BQIUPD(90505,NDZ_",",2.05)=$$FIND1^DIC(90506.4,"","BX","Patient List","","","ERROR")
+24 SET BQIUPD(90505,NDZ_",",2.06)="N"
End DoDot:2
End DoDot:1
+25 DO FILE^DIE("","BQIUPD","ERROR")
+26 KILL BQIUPD
+27 ;
+28 ;Set the group order parm to no
+29 NEW DA,BQIUPD,ERROR
+30 SET DA=$$SPM^BQIGPUTL()
+31 SET BQIUPD(90508,DA_",",.2)="@"
+32 IF $DATA(BQIUPD)
DO FILE^DIE("E","BQIUPD","ERROR")
+33 KILL DA,BQIUPD,ERROR
+34 ;
+35 ;For CANES 2.0
+36 ;D DX^BQI202PU
+37 ;
+38 ; Set BTPWRPC into BQIRPC
+39 NEW IEN,DA,X,DIC,Y
+40 SET DA(1)=$$FIND1^DIC(19,"","B","BQIRPC","","","ERROR")
SET DIC="^DIC(19,"_DA(1)_",10,"
SET DIC(0)="LMNZ"
+41 IF $GET(^DIC(19,DA(1),10,0))=""
SET ^DIC(19,DA(1),10,0)="^19.01IP^^"
+42 SET X="BTPWRPC"
+43 DO ^DIC
IF +Y<1
KILL DO,DD
DO FILE^DICN
+44 ;
+45 ; Add reports to menu
+46 SET X=$$ADD^XPDMENU("APCL IPC REPORTS MENU","BQI IPC MISMATCH PROV","MIS")
+47 SET X=$$ADD^XPDMENU("APCL IPC REPORTS MENU","BQI IPC PROVIDER COUNT","CNT")
+48 ;
+49 ; Convert pointers to codes
+50 NEW NDZ,NPL,CRN,OVL,OVAL,SHZ
+51 SET NDZ=0
+52 FOR
SET NDZ=$ORDER(^BQICARE(NDZ))
IF 'NDZ
QUIT
Begin DoDot:1
+53 IF $GET(^BQICARE(NDZ,0))=""
KILL ^BQICARE(NDZ)
QUIT
+54 SET NPL=0
+55 FOR
SET NPL=$ORDER(^BQICARE(NDZ,1,NPL))
IF 'NPL
QUIT
Begin DoDot:2
+56 SET CRN=0
+57 FOR
SET CRN=$ORDER(^BQICARE(NDZ,1,NPL,20,CRN))
IF 'CRN
QUIT
Begin DoDot:3
+58 SET OVAL=$PIECE(^BQICARE(NDZ,1,NPL,20,CRN,0),"^",1)
+59 IF OVAL'?.N
QUIT
+60 NEW DA,IENS
+61 SET DA(2)=NDZ
SET DA(1)=NPL
SET DA=CRN
SET IENS=$$IENS^DILF(.DA)
+62 SET BQIUPD(90505.05,IENS,.01)=$PIECE(^BQI(90506.1,OVAL,0),U,1)
End DoDot:3
+63 SET CRN=0
+64 FOR
SET CRN=$ORDER(^BQICARE(NDZ,1,NPL,23,CRN))
IF 'CRN
QUIT
Begin DoDot:3
+65 SET IEN=0
+66 FOR
SET IEN=$ORDER(^BQICARE(NDZ,1,NPL,23,CRN,1,IEN))
IF 'IEN
QUIT
Begin DoDot:4
+67 SET OVAL=$PIECE(^BQICARE(NDZ,1,NPL,23,CRN,1,IEN,0),"^",1)
+68 IF OVAL'?.N
QUIT
+69 NEW DA,IENS
+70 SET DA(3)=NDZ
SET DA(2)=NPL
SET DA(1)=CRN
SET DA=IEN
SET IENS=$$IENS^DILF(.DA)
+71 SET BQIUPD(90505.1231,IENS,.01)=$PIECE(^BQI(90506.1,OVAL,0),U,1)
End DoDot:4
End DoDot:3
+72 SET SHZ=0
+73 FOR
SET SHZ=$ORDER(^BQICARE(NDZ,1,NPL,30,SHZ))
IF 'SHZ
QUIT
Begin DoDot:3
+74 SET CRN=0
+75 FOR
SET CRN=$ORDER(^BQICARE(NDZ,1,NPL,30,SHZ,20,CRN))
IF 'CRN
QUIT
Begin DoDot:4
+76 SET OVAL=$PIECE(^BQICARE(NDZ,1,NPL,30,SHZ,20,CRN,0),"^",1)
+77 IF OVAL'?.N
QUIT
+78 NEW DA,IENS
+79 SET DA(3)=NDZ
SET DA(2)=NPL
SET DA(1)=SHZ
SET DA=CRN
SET IENS=$$IENS^DILF(.DA)
+80 SET BQIUPD(90505.06,IENS,.01)=$PIECE(^BQI(90506.1,OVAL,0),U,1)
End DoDot:4
+81 SET CRN=0
+82 FOR
SET CRN=$ORDER(^BQICARE(NDZ,1,NPL,30,SHZ,23,CRN))
IF 'CRN
QUIT
Begin DoDot:4
+83 SET IEN=0
+84 FOR
SET IEN=$ORDER(^BQICARE(NDZ,1,NPL,30,SHZ,23,CRN,1,IEN))
IF 'IEN
QUIT
Begin DoDot:5
+85 SET OVAL=$PIECE(^BQICARE(NDZ,1,NPL,30,SHZ,23,CRN,1,IEN,0),"^",1)
+86 IF OVAL'?.N
QUIT
+87 NEW DA,IENS
+88 SET DA(4)=NDZ
SET DA(3)=NPL
SET DA(2)=SHZ
SET DA(1)=CRN
SET DA=IEN
SET IENS=$$IENS^DILF(.DA)
+89 SET BQIUPD(90505.3231,IENS,.01)=$PIECE(^BQI(90506.1,OVAL,0),U,1)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+90 IF $DATA(BQIUPD)
DO FILE^DIE("","BQIUPD","ERROR")
End DoDot:1
+91 ;
+92 ; Add new patient entries to 90506.1
+93 NEW BI,BJ,BK,BN,BQIUPD,ERROR,IEN,ND,NDATA,TEXT,VAL
+94 FOR BI=1:1
SET TEXT=$PIECE($TEXT(LYT+BI),";;",2)
IF TEXT=""
QUIT
Begin DoDot:1
+95 FOR BJ=1:1:$LENGTH(TEXT,"~")
Begin DoDot:2
+96 SET NDATA=$PIECE(TEXT,"~",BJ)
+97 SET ND=$PIECE(NDATA,"|",1)
SET VAL=$PIECE(NDATA,"|",2)
+98 IF ND=0
Begin DoDot:3
+99 NEW DIC,X,Y
+100 SET DIC(0)="LQZ"
SET DIC="^BQI(90506.1,"
SET X=$PIECE(VAL,U,1)
+101 DO ^DIC
+102 SET IEN=+Y
+103 IF IEN=-1
KILL DO,DD
DO FILE^DICN
SET IEN=+Y
End DoDot:3
+104 IF ND=1
SET BQIUPD(90506.1,IEN_",",1)=VAL
QUIT
+105 FOR BK=1:1:$LENGTH(VAL,"^")
Begin DoDot:3
+106 SET BN=$ORDER(^DD(90506.1,"GL",ND,BK,""))
IF BN=""
QUIT
+107 IF $PIECE(VAL,"^",BK)'=""
SET BQIUPD(90506.1,IEN_",",BN)=$PIECE(VAL,"^",BK)
QUIT
+108 IF $PIECE(VAL,"^",BK)=""
SET BQIUPD(90506.1,IEN_",",BN)="@"
End DoDot:3
End DoDot:2
+109 DO FILE^DIE("","BQIUPD","ERROR")
End DoDot:1
+110 ;
+111 ; Re-Index File
+112 KILL ^BQI(90506.1,"AC"),^BQI(90506.1,"AD")
+113 NEW DIK
+114 SET DIK="^BQI(90506.1,"
SET DIK(1)=3.01
+115 DO ENALL^DIK
+116 ;
+117 ; Update IPC measures
+118 DO ^BQI23PU
+119 ;
+120 ; Fix Template Pointer Issues
+121 DO FIX()
+122 ;
+123 ;Regenerate Panel Descriptions
+124 DO PDESC()
+125 ;
+126 ;Make Reproductive Factors Definition fields Active/Inactive
+127 DO UVDEF^BQIPTRP1()
+128 ;
IP ; Fix Outcome Bundle update
+1 IF $DATA(^BQI(90508,1,22,1,3,"B",3120200))
Begin DoDot:1
+2 DO DM^BQIIPOTC(1,32,3120200,"IPC_DMCTRL","")
+3 DO LD^BQIIPOTC(1,57,3120200,"IPC_LDCTRL","")
+4 DO BP^BQIIPOTC(1,58,3120200,"IPC_BPCTRL","")
+5 DO EN^BQIIPOTC(3120200)
+6 DO GS(3120200)
End DoDot:1
+7 ;
+8 IF $DATA(^BQI(90508,1,22,1,3,"B",3120300))
Begin DoDot:1
+9 DO DM^BQIIPOTC(1,32,3120300,"IPC_DMCTRL","")
+10 DO LD^BQIIPOTC(1,57,3120300,"IPC_LDCTRL","")
+11 DO BP^BQIIPOTC(1,58,3120300,"IPC_BPCTRL","")
+12 DO EN^BQIIPOTC(3120300)
+13 DO GS(3120300)
End DoDot:1
+14 ;
MU ; Run MU Provider data for first Monthly periods
+1 ; Clean up old data
+2 SET PRV=0
FOR
SET PRV=$ORDER(^BQIPROV(PRV))
IF 'PRV
QUIT
KILL ^BQIPROV(PRV,11),^BQIPROV(PRV,21),^BQIPROV(PRV,60),^BQIPROV(PRV,50)
+3 SET FAC=$ORDER(^BQIFAC(0))
IF FAC'=""
KILL ^BQIFAC(FAC,11),^BQIFAC(FAC,21),^BQIFAC(FAC,60),^BQIFAC(FAC,50)
+4 ;
+5 Begin DoDot:1
+6 NEW BQDT,FAC,BQTMN,BQNO,CDTM
+7 SET BQDT=$EXTRACT(DT,1,5)_"00"
+8 SET FAC=$$HME^BQIGPUTL()
+9 SET BQTMN=$ORDER(^BQIFAC(FAC,50,"B",BQDT,""))
+10 DO CKM
+11 IF BQTMN=""
IF 'BQNO
DO EN^BQIMUMON($EXTRACT(DT,1,5)_"01")
+12 IF BQTMN=""
IF BQNO
SET ^XTMP("BQIMMON",$EXTRACT(DT,1,5)_"01")=""
+13 SET ^XTMP("BQIMMON",0)=$$FMADD^XLFDT(DT,365)_U_DT_U_"Month list"
+14 SET CDTM=$EXTRACT(DT,4,5)
+15 FOR BI=7:1:12
SET ^XTMP("BQIMMON","311"_$SELECT(BI<10:"0"_BI,1:BI)_"01")=""
+16 IF $EXTRACT(DT,1,3)>311
FOR BI=1:1:CDTM
SET ^XTMP("BQIMMON","312"_$SELECT(BI<10:"0"_BI,1:BI)_"01")=""
End DoDot:1
+17 ;
RSC ; Remove the scheduled tasks
+1 NEW RPC,OPTN,OPN,LIST,ZTSK
+2 FOR RPC="BQI UPDATE MU CQM 1 YEAR","BQI UPDATE MU CQM 90 DAYS"
Begin DoDot:1
+3 SET OPTN=$$FIND^BQISCHED(RPC)
+4 IF OPTN'>0
QUIT
+5 SET OPN=$ORDER(^DIC(19.2,"B",OPTN,""))
+6 IF OPN'=""
Begin DoDot:2
+7 NEW DA,DIK
+8 SET DIK="^DIC(19.2,"
SET DA=OPN
DO ^DIK
End DoDot:2
+9 NEW DA,DIK
+10 SET DA=OPTN
SET DIK="^DIC(19,"
DO ^DIK
+11 KILL LIST
+12 DO OPTION^%ZTLOAD(RPC,.LIST)
+13 SET ZTSK=""
+14 FOR
SET ZTSK=$ORDER(@LIST@(ZTSK))
IF ZTSK=""
QUIT
Begin DoDot:2
+15 DO PCLEAR^%ZTLOAD(ZTSK)
+16 DO KILL^%ZTLOAD
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
GS(BQDATE) ; Update the Goal Set
+1 NEW TPRN,PRV,TPRD,GPRN,GPRD,DEN,FAC,YEAR
+2 SET PRV=""
SET YEAR=$$GET1^DIQ(90508,1_",",2,"E")
+3 FOR
SET PRV=$ORDER(^AUPNPAT("AK",PRV))
IF PRV=""
QUIT
Begin DoDot:1
+4 SET TPRN=$ORDER(^BQIPROV(PRV,30,"B","IPC_TOTP",""))
IF TPRN=""
QUIT
+5 SET TPRD=$ORDER(^BQIPROV(PRV,30,TPRN,1,"B",BQDATE,""))
IF TPRD=""
QUIT
+6 SET GPRN=$ORDER(^BQIPROV(PRV,30,"B",YEAR_"_2452",""))
IF GPRN=""
QUIT
+7 SET GPRD=$ORDER(^BQIPROV(PRV,30,GPRN,1,"B",BQDATE,""))
IF GPRD=""
QUIT
+8 SET DEN=$PIECE(^BQIPROV(PRV,30,TPRN,1,TPRD,0),U,2)
+9 SET $PIECE(^BQIPROV(PRV,30,GPRN,1,GPRD,0),U,2)=DEN
End DoDot:1
+10 SET FAC=$$HME^BQIGPUTL()
+11 SET TPRN=$ORDER(^BQIFAC(FAC,30,"B","IPC_TOTP",""))
IF TPRN=""
QUIT
+12 SET TPRD=$ORDER(^BQIFAC(FAC,30,TPRN,1,"B",BQDATE,""))
IF TPRD=""
QUIT
+13 SET GPRN=$ORDER(^BQIFAC(FAC,30,"B",YEAR_"_2452",""))
IF GPRN=""
QUIT
+14 SET GPRD=$ORDER(^BQIFAC(FAC,30,GPRN,1,"B",BQDATE,""))
IF GPRD=""
QUIT
+15 SET DEN=$PIECE(^BQIFAC(FAC,30,TPRN,1,TPRD,0),U,2)
+16 SET $PIECE(^BQIFAC(FAC,30,GPRN,1,GPRD,0),U,2)=DEN
+17 QUIT
+18 ;
PDESC() ;EP - Regenerate Panel Descriptions
+1 NEW USER,PLIEN
+2 SET USER=0
FOR
SET USER=$ORDER(^BQICARE(USER))
IF 'USER
QUIT
Begin DoDot:1
+3 SET PLIEN=0
FOR
SET PLIEN=$ORDER(^BQICARE(USER,1,PLIEN))
IF 'PLIEN
QUIT
Begin DoDot:2
+4 NEW DESC,DA,IENS
+5 SET DA(1)=USER
SET DA=PLIEN
SET IENS=$$IENS^DILF(.DA)
+6 DO DESC^BQIPDSCM(USER,PLIEN,.DESC)
+7 DO WP^DIE(90505.01,IENS,5,"","DESC")
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
FIX() ;EP - FIX INVALID TEMPLATE POINTERS
+1 ;
+2 NEW USER,PLIEN,TIEN,SHR
+3 SET USER=0
FOR
SET USER=$ORDER(^BQICARE(USER))
IF 'USER
QUIT
Begin DoDot:1
+4 SET PLIEN=0
FOR
SET PLIEN=$ORDER(^BQICARE(USER,1,PLIEN))
IF 'PLIEN
QUIT
Begin DoDot:2
+5 SET TIEN=0
FOR
SET TIEN=$ORDER(^BQICARE(USER,1,PLIEN,4,TIEN))
IF 'TIEN
QUIT
Begin DoDot:3
+6 NEW DA,IENS,TEMPL,DIC,X,Y,DIK
+7 SET DA(2)=USER
SET DA(1)=PLIEN
SET DA=TIEN
SET IENS=$$IENS^DILF(.DA)
+8 SET TEMPL=$$GET1^DIQ(90505.14,IENS,.01,"I")
+9 SET X=TEMPL
SET DIC="^BQICARE("_USER_",15,"
SET DIC(0)="X"
+10 DO ^DIC
+11 IF +Y>0
QUIT
+12 SET DIK="^BQICARE("_DA(2)_",1,"_DA(1)_",4,"
+13 DO ^DIK
End DoDot:3
+14 ;
+15 ;Look for templates in use in shared panels
+16 SET SHR=0
FOR
SET SHR=$ORDER(^BQICARE(USER,1,PLIEN,30,SHR))
IF 'SHR
QUIT
Begin DoDot:3
+17 SET TIEN=0
FOR
SET TIEN=$ORDER(^BQICARE(USER,1,PLIEN,30,SHR,4,TIEN))
IF 'TIEN
QUIT
Begin DoDot:4
+18 NEW DA,IENS,TEMPL,DIC,X,Y,DIK
+19 SET DA(3)=USER
SET DA(2)=PLIEN
SET DA(1)=SHR
SET DA=TIEN
SET IENS=$$IENS^DILF(.DA)
+20 SET TEMPL=$$GET1^DIQ(90505.34,IENS,.01,"I")
+21 SET X=TEMPL
SET DIC="^BQICARE("_USER_",15,"
SET DIC(0)="X"
+22 DO ^DIC
+23 IF +Y>0
QUIT
+24 SET DIK="^BQICARE("_DA(3)_",1,"_DA(2)_",30,"_DA(1)_",4,"
+25 DO ^DIK
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+26 ;
+27 QUIT
+28 ;
CKM ;EP - Check for existing job
+1 NEW LIST,TSK,ZTSK
+2 DO DESC^%ZTLOAD("MU CQ Monthly Compile",.LIST)
+3 SET TSK=""
SET BQNO=0
+4 FOR
SET TSK=$ORDER(@LIST@(TSK))
IF TSK=""
QUIT
SET ZTSK=TSK
DO STAT^%ZTLOAD
IF ZTSK(2)["Active"
SET BQNO=1
+5 QUIT
+6 ;
LYT ;EP - Layout items
+1 ;;0|EMPL^^Employer^^9000001^.19^^T00060EMPL~1|~3|1^^Other Patient Data^O^42^^^^^BQIZEMPHLTH~5|
+2 ;;0|LVDPCP^^Last Visit Date w DPCP^^^^^D00030LVDPCP~1|S VAL=$$LVDPCP^BQIULPT(DFN)~3|1^^Visit Related^O^16^^^D~5|
+3 ;;
