BQINIGHT ;PRXM/HC/ALA-Nightly Background Job ; 05 Jan 2006 1:31 PM
;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
;
;
EN ;EP - Entry point
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQI1POJB"
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
;
S BQIUPD(90508,"1,",24.01)=$G(ZTSK)
D FILE^DIE("","BQIUPD","ERROR")
;
;D EN^BQIMUUPD
D ARM^BQINIGH2
D IMM^BQINIGH2
D PRN^BQINIGH2
D PED^BQINIGH2
D HCV^BQINIGH2
D DMA^BQINIGH2
;D CQ^BQIMUMON("")
;D PF^BQIMUMON("")
;D JBC^BQINIGH3
D MEAS^BQINIGH1
D PRF^BQINIGH2
D FLG
D CMA^BQINIGH2
D DXC
D CRS
;Run IPC
D IJB^BQINIGH3("")
D WK^BQINIGH3
;D NUM^BQIMUSIT
; Reminders
D REM
K DLAYGO
; Best Practice prompts
D TRT
; Register updates
D REG^BQINIGH4
; Care Mgmt
D AST^BQINIGH1
; Run CMET
D EN^BTPWPFND("Nightly")
; Run Autopopulate
D NGHT^BQINIGH2
;
S BQIUPD(90508,"1,",24.01)="@"
D FILE^DIE("","BQIUPD","ERROR")
;
; Clean up any remaining TMPs
NEW BQTSK,TSK,TUID
S TSK="BQI",BQTSK=TSK
F S BQTSK=$O(^TMP(BQTSK)) Q:$E(BQTSK,1,3)'=TSK S TUID="" F S TUID=$O(^TMP(BQTSK,TUID)) Q:TUID="" I $E(TUID,1,1)="Z" K ^TMP(BQTSK,TUID)
Q
;
FLG ;EP - Flag updates
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
;
; Set the DATE/TIME FLAG STARTED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",3.01)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",3.03)=1
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
; Find all flags for patients
D FND^BQIFLG
;
; Set the DATE/TIME FLAG STOPPED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",3.02)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",3.03)="@"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
; Get a list of all patients who have had visits or problems
; entered into RPMS since the last visit or problem IENs.
; Set into temporary global XTMP. This list is the subset of
; patients used to update.
;
NEW BQIDA,VLIEN,PRIEN,DFN,LMDT
S BQIDA=$$SPM^BQIGPUTL()
S VLIEN=$$GET1^DIQ(90508,BQIDA,1,"E")
S PRIEN=$$GET1^DIQ(90508,BQIDA,3,"E")
S BQIUPD(90508,BQIDA_",",1)=$O(^AUPNVSIT("A"),-1)
S BQIUPD(90508,BQIDA_",",3)=$O(^AUPNPROB("A"),-1)
D FILE^DIE("","BQIUPD","ERROR")
;
K ^XTMP("BQINIGHT")
S ^XTMP("BQINIGHT",0)=$$FMADD^XLFDT(DT,1)_U_$$DT^XLFDT()
F S VLIEN=$O(^AUPNVSIT(VLIEN)) Q:'VLIEN D
. ; If visit has been deleted, don't include
. I $P($G(^AUPNVSIT(VLIEN,0)),"^",11)=1 Q
. I $P($G(^AUPNVSIT(VLIEN,0)),"^",9)=1 Q
. Q:"DXCTI"[$P(^AUPNVSIT(VLIEN,0),U,7)
. S DFN=$P(^AUPNVSIT(VLIEN,0),U,5) I DFN="" Q
. S ^XTMP("BQINIGHT",DFN)=""
;
F S PRIEN=$O(^AUPNPROB(PRIEN)) Q:'PRIEN D
. S DFN=$P(^AUPNPROB(PRIEN,0),U,2)
. I $P(^AUPNPROB(PRIEN,0),U,12)'="A" Q
. S ^XTMP("BQINIGHT",DFN)=""
;
Q
;
DXC ;EP - Update Diagnosis Categories
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
;
; Set the DATE/TIME DXN CATEGORY STARTED field
NEW DA,DATA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",3.04)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",3.06)=1
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
S DFN=0
F S DFN=$O(^XTMP("BQINIGHT",DFN)) Q:'DFN D
. D PAT^BQITDPAT(.DATA,DFN)
. Q
;
I $G(BQGLB)'="" K @BQGLB,BQGLB
I $G(BQPGLB)'="" K @BQPGLB,BQPGLB
K AGE,BQEXEC,BQDEF,BQPRG,DFN,PRGM,SEX,TXDXCN,TXDXCT,TXT,Y
;
; Set the DATE/TIME DXN CATEGORY STOPPED field
NEW DA,BQTSK
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",3.05)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",3.06)="@"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
F BQTSK="BQIBMI","BQIBP","BQIPREG","BQITAX","BQITAX1","BQITDPRC","BQITMPO","BQITDPAT" K ^TMP(BQTSK,UID)
Q
;
CRS ;EP - Find all GPRA indicators
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
;
; Check if new version of CRS has been loaded
D GCHK^BQIGPUPD()
;
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",3.07)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",3.09)=1
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
NEW DFN,GPMEAS,CT
S BQIGREF=$NA(^TMP(UID,"BQIGPRA"))
K @BQIGREF
S BQIDATA=$NA(^BQIPAT)
;
D INP
; If the routine is not defined, quit
I $G(BQIROU)="" Q
;
; If the tag is not defined, quit
I $T(@("BQI^"_BQIROU))="" Q
;
; Initialize GPRA variables
NEW VER,BQX,XN
S VER=$$VERSION^XPDUTL("BGP")
;
I VER>7.0 D
. S BQX=""
. F S BQX=$O(^BQI(90506.1,"AC","G",BQX)) Q:BQX="" D
.. I $P(^BQI(90506.1,BQX,0),U,10)=1 Q
.. S X=$P(^BQI(90506.1,BQX,0),U,1),XN=$P(X,"_",2)
.. S X=$P($G(@BQIMEASG@(XN,0)),U,1) I X'="" S BGPIND(X)=""
;
; Define the time frame for the patient
S BGPBD=$$DATE^BQIUL1("T-12M"),BGPED=DT
S BGPBBD="300"_$E(BGPBD,4,7),BGPBED="300"_$E(BGPED,4,7)
S BGPPBD=$$DATE^BQIUL1("T-24M"),BGPPED=$$DATE^BQIUL1("T-12M")
S BGPPER=$E($$DT^XLFDT(),1,3)_"0000"
S BGPQTR=$S(BGPBD>($E(BGPBD,1,3)_"0101")&(BGPBD<($E(BGPBD,1,3)_"0331")):1,BGPBD>($E(BGPBD,1,3)_"0401")&(BGPBD<($E(BGPBD,1,3)_"0630")):2,BGPBD>($E(BGPBD,1,3)_"0701")&(BGPBD<($E(BGPBD,1,3)_"0930")):3,1:4)
S BGPRTYPE=4,BGPRPT=4
S BGP3YE=$$FMADD^XLFDT(BGPED,-1096)
S BGPP3YE=$$FMADD^XLFDT(BGPPED,-1096)
S BGPB3YE=$$FMADD^XLFDT(BGPBED,-1096)
;
; Setup taxonomies
I VER>14.1 D
. I $T(UNFOLDTX^BGP8UTL2)="" Q
. D UNFOLDTX^BGP8UTL2
;
S DFN=0
F S DFN=$O(^XTMP("BQINIGHT",DFN)) Q:'DFN D
. ; Remove any previous GPRA data
. K @BQIDATA@(DFN,30)
. S @BQIDATA@(DFN,30,0)="^90507.53^^"
. ; If patient is deceased, don't calculate
. I $P($G(^DPT(DFN,.35)),U,1)'="" Q
. ; If patient has no active HRNs, quit
. I '$$HRN^BQIUL1(DFN) Q
. ; If patient has no visit in last 2 years, quit
. ;I '$$VTHR^BQIUL1(DFN) Q
. I '$$VTWR^BQIUL1(DFN) Q
. ; If new patient add to BQIPAT
. I $G(^BQIPAT(DFN,0))="" D NPT^BQITASK(DFN)
. I $P($G(^BQIPAT(DFN,0)),"^",1)="" S $P(^BQIPAT(DFN,0),"^",1)=DFN,^BQIPAT("B",DFN,DFN)=""
. S BQIPUP(90507.5,DFN_",",.02)=BQIYR
. S BQIPUP(90507.5,DFN_",",.03)=BGPBD
. S BQIPUP(90507.5,DFN_",",.04)=BGPED
. S BQIPUP(90507.5,DFN_",",.05)=$$NOW^XLFDT()
. D FILE^DIE("","BQIPUP","ERROR")
. K BQIPUP
. D @("BQI^"_BQIROU_"(DFN,.BQIGREF)")
. ;
. NEW DA
. S DA(1)=DFN,DA=0,DIK="^BQIPAT("_DA(1)_",30,"
. F S DA=$O(@BQIDATA@(DFN,30,DA)) Q:'DA D ^DIK
. ;
. ; if the patient doesn't meet any GPRA logic, quit
. I '$D(@BQIGREF@(DFN)) Q
. ;
. I '$D(@BQIDATA@(DFN,30,0)) S @BQIDATA@(DFN,30,0)="^90507.53^^"
. ;
. S SIND="",CT=0
. F S SIND=$O(^BQI(90506.1,"AC","G",SIND)) Q:SIND="" D
.. S CT=CT+1
.. I $P(^BQI(90506.1,SIND,0),U,10)=1 Q
.. S @BQIDATA@(DFN,30,CT,0)=$P(^BQI(90506.1,SIND,0),U,1)
.. S @BQIDATA@(DFN,30,"B",$P(^BQI(90506.1,SIND,0),U,1),CT)=""
. ;
. S IND=0
. F S IND=$O(@BQIGREF@(DFN,IND)) Q:IND="" D
.. S MEAS=0
.. F S MEAS=$O(@BQIGREF@(DFN,IND,MEAS)) Q:MEAS="" D
... ;Q:'$$SUM^BQIGPUTL(BQIYR,MEAS)
... S GPMEAS=BQIYR_"_"_MEAS
... S MCT=$O(^BQIPAT(DFN,30,"B",GPMEAS,"")) I MCT="" Q
... S $P(@BQIDATA@(DFN,30,MCT,0),U,2)=$P(@BQIGREF@(DFN,IND),U,2)
... S $P(@BQIDATA@(DFN,30,MCT,0),U,3)=$P(@BQIGREF@(DFN,IND,MEAS),U,2)
... S $P(@BQIDATA@(DFN,30,MCT,0),U,4)=$P(@BQIGREF@(DFN,IND,MEAS),U,3)
. K @BQIGREF
. NEW DA,DIK
. S DA=DFN,DIK="^BQIPAT(" D IX1^DIK
;
K ^XTMP("BGP15TAX",$J),^XTMP("BGPSNOMEDSUBSET",$J)
;
; Compile Main view data
D COMP^BQIGPRA5
;
; Set the DATE/TIME GPRA STOPPED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",3.08)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",3.09)="@"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
K MEAS,DFN,IND,BGPIND,BGPBD,BGPED,BGPBBD,BGPBED,BGPPBD,BGPPED
K BGPQTR,BGPRTYPE,BGPRPT,BGP3YE,BGPP3YE,BGPB3YE,BGPHOME,BHM
K BQIDATA,BQIH,BQIINDF,BQIINDG,BQIMEASF,BQIMEASG,BQIROU,BQIY,BQIYR
K @BQIGREF,BQIUPD,MCT,SIND,VLIEN,VOK,X,BQIGREF,BGPPER
;
Q
;
REM ;EP - Find any new reminders
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
;
; Set the DATE/TIME REMINDERS STARTED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",3.1)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",3.12)=1
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
; Re-evaluate reminders
D CHK^BQIRMDR("Nightly")
; Check for new CMET followups and recalculate their reminders
NEW CMDT,IEN,BKDFN
S CMDT=$$FMADD^XLFDT(DT,-1)-.005
F S CMDT=$O(^BTPWP("AU",CMDT)) Q:CMDT="" D
. S IEN=""
. F S IEN=$O(^BTPWP("AU",CMDT,IEN)) Q:IEN="" D
.. S BKDFN=$P(^BTPWP(IEN,0),U,2),^XTMP("BQINIGHT",BKDFN)=""
; Check for DUZ
D DZ^BQITASK1
;
; Check for Appointments
D APT^BQIRMIZ
; Reset Reminders
NEW BKDFN
S BKDFN=0,ERRCNT=0
F S BKDFN=$O(^XTMP("BQINIGHT",BKDFN)) Q:'BKDFN D Q:ERRCNT>100
. I $G(^BQIPAT(BKDFN,0))="" D NPT^BQITASK(BKDFN)
. I $P($G(^BQIPAT(BKDFN,0)),"^",1)="" S $P(^BQIPAT(BKDFN,0),"^",1)=BKDFN,^BQIPAT("B",BKDFN,BKDFN)=""
. D PAT^BQIRMDR(BKDFN)
;
; Set the DATE/TIME REMINDERS STOPPED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",3.11)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",3.12)="@"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD,ERRCNT
Q
;
TRT ;EP - Update treatment prompts
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
; Set the DATE/TIME TREATMENT STARTED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",3.13)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",3.15)=1
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
NEW BKDFN
S BKDFN=0
F S BKDFN=$O(^XTMP("BQINIGHT",BKDFN)) Q:'BKDFN D
. I $G(^BQIPAT(BKDFN,0))="" D NPT^BQITASK(BKDFN)
. I $P($G(^BQIPAT(BKDFN,0)),"^",1)="" S $P(^BQIPAT(BKDFN,0),"^",1)=BKDFN,^BQIPAT("B",BKDFN,BKDFN)=""
. D PAT^BQITRMT(BKDFN)
; Set the DATE/TIME TREATMENT STOPPED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",3.14)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",3.15)="@"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
Q
;
INP ;EP - Initialize GPRA variables
NEW DA,IENS
I $G(U)="" D DT^DICRW
;
; Get the internal entry value from the site parameters
S BQIH=$$SPM^BQIGPUTL()
S BGPHOME=$$HME^BQIGPUTL()
;
; get the current year for CRS
S BQIYR=$$GET1^DIQ(90508,BQIH,2,"E")
I BQIYR="" S BQIYR=$P($$FMTE^XLFDT(DT,7),"/",1)
S BQIY=$$LKP^BQIGPUTL(BQIYR)
; if the current year is not defined yet, get the previous year
I BQIY=-1 S BQIYR=BQIYR-1,BQIY=$$LKP^BQIGPUTL(BQIYR) I BQIY=-1 Q
;
; get the global references for the corresponding CRS year
S DA(1)=BQIH,DA=BQIY
S IENS=$$IENS^DILF(.DA)
S BQIINDF=$$GET1^DIQ(90508.01,IENS,.02,"E")
S BQIINDG=$$ROOT^DILFD(BQIINDF,"",1)
S BQIMEASF=$$GET1^DIQ(90508.01,IENS,.03,"E")
S BQIMEASG=$$ROOT^DILFD(BQIMEASF,"",1)
S BQIROU=$$GET1^DIQ(90508.01,IENS,.04,"E")
Q
BQINIGHT ;PRXM/HC/ALA-Nightly Background Job ; 05 Jan 2006 1:31 PM
+1 ;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
+2 ;
+3 ;
EN ;EP - Entry point
+1 ;
+2 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQI1POJB"
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 ;
+5 SET BQIUPD(90508,"1,",24.01)=$GET(ZTSK)
+6 DO FILE^DIE("","BQIUPD","ERROR")
+7 ;
+8 ;D EN^BQIMUUPD
+9 DO ARM^BQINIGH2
+10 DO IMM^BQINIGH2
+11 DO PRN^BQINIGH2
+12 DO PED^BQINIGH2
+13 DO HCV^BQINIGH2
+14 DO DMA^BQINIGH2
+15 ;D CQ^BQIMUMON("")
+16 ;D PF^BQIMUMON("")
+17 ;D JBC^BQINIGH3
+18 DO MEAS^BQINIGH1
+19 DO PRF^BQINIGH2
+20 DO FLG
+21 DO CMA^BQINIGH2
+22 DO DXC
+23 DO CRS
+24 ;Run IPC
+25 DO IJB^BQINIGH3("")
+26 DO WK^BQINIGH3
+27 ;D NUM^BQIMUSIT
+28 ; Reminders
+29 DO REM
+30 KILL DLAYGO
+31 ; Best Practice prompts
+32 DO TRT
+33 ; Register updates
+34 DO REG^BQINIGH4
+35 ; Care Mgmt
+36 DO AST^BQINIGH1
+37 ; Run CMET
+38 DO EN^BTPWPFND("Nightly")
+39 ; Run Autopopulate
+40 DO NGHT^BQINIGH2
+41 ;
+42 SET BQIUPD(90508,"1,",24.01)="@"
+43 DO FILE^DIE("","BQIUPD","ERROR")
+44 ;
+45 ; Clean up any remaining TMPs
+46 NEW BQTSK,TSK,TUID
+47 SET TSK="BQI"
SET BQTSK=TSK
+48 FOR
SET BQTSK=$ORDER(^TMP(BQTSK))
IF $EXTRACT(BQTSK,1,3)'=TSK
QUIT
SET TUID=""
FOR
SET TUID=$ORDER(^TMP(BQTSK,TUID))
IF TUID=""
QUIT
IF $EXTRACT(TUID,1,1)="Z"
KILL ^TMP(BQTSK,TUID)
+49 QUIT
+50 ;
FLG ;EP - Flag updates
+1 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
+2 ;
+3 ; Set the DATE/TIME FLAG STARTED field
+4 NEW DA
+5 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+6 SET BQIUPD(90508,DA_",",3.01)=$$NOW^XLFDT()
+7 SET BQIUPD(90508,DA_",",3.03)=1
+8 DO FILE^DIE("","BQIUPD","ERROR")
+9 KILL BQIUPD
+10 ;
+11 ; Find all flags for patients
+12 DO FND^BQIFLG
+13 ;
+14 ; Set the DATE/TIME FLAG STOPPED field
+15 NEW DA
+16 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+17 SET BQIUPD(90508,DA_",",3.02)=$$NOW^XLFDT()
+18 SET BQIUPD(90508,DA_",",3.03)="@"
+19 DO FILE^DIE("","BQIUPD","ERROR")
+20 KILL BQIUPD
+21 ;
+22 ; Get a list of all patients who have had visits or problems
+23 ; entered into RPMS since the last visit or problem IENs.
+24 ; Set into temporary global XTMP. This list is the subset of
+25 ; patients used to update.
+26 ;
+27 NEW BQIDA,VLIEN,PRIEN,DFN,LMDT
+28 SET BQIDA=$$SPM^BQIGPUTL()
+29 SET VLIEN=$$GET1^DIQ(90508,BQIDA,1,"E")
+30 SET PRIEN=$$GET1^DIQ(90508,BQIDA,3,"E")
+31 SET BQIUPD(90508,BQIDA_",",1)=$ORDER(^AUPNVSIT("A"),-1)
+32 SET BQIUPD(90508,BQIDA_",",3)=$ORDER(^AUPNPROB("A"),-1)
+33 DO FILE^DIE("","BQIUPD","ERROR")
+34 ;
+35 KILL ^XTMP("BQINIGHT")
+36 SET ^XTMP("BQINIGHT",0)=$$FMADD^XLFDT(DT,1)_U_$$DT^XLFDT()
+37 FOR
SET VLIEN=$ORDER(^AUPNVSIT(VLIEN))
IF 'VLIEN
QUIT
Begin DoDot:1
+38 ; If visit has been deleted, don't include
+39 IF $PIECE($GET(^AUPNVSIT(VLIEN,0)),"^",11)=1
QUIT
+40 IF $PIECE($GET(^AUPNVSIT(VLIEN,0)),"^",9)=1
QUIT
+41 IF "DXCTI"[$PIECE(^AUPNVSIT(VLIEN,0),U,7)
QUIT
+42 SET DFN=$PIECE(^AUPNVSIT(VLIEN,0),U,5)
IF DFN=""
QUIT
+43 SET ^XTMP("BQINIGHT",DFN)=""
End DoDot:1
+44 ;
+45 FOR
SET PRIEN=$ORDER(^AUPNPROB(PRIEN))
IF 'PRIEN
QUIT
Begin DoDot:1
+46 SET DFN=$PIECE(^AUPNPROB(PRIEN,0),U,2)
+47 IF $PIECE(^AUPNPROB(PRIEN,0),U,12)'="A"
QUIT
+48 SET ^XTMP("BQINIGHT",DFN)=""
End DoDot:1
+49 ;
+50 QUIT
+51 ;
DXC ;EP - Update Diagnosis Categories
+1 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
+2 ;
+3 ; Set the DATE/TIME DXN CATEGORY STARTED field
+4 NEW DA,DATA
+5 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+6 SET BQIUPD(90508,DA_",",3.04)=$$NOW^XLFDT()
+7 SET BQIUPD(90508,DA_",",3.06)=1
+8 DO FILE^DIE("","BQIUPD","ERROR")
+9 KILL BQIUPD
+10 ;
+11 SET DFN=0
+12 FOR
SET DFN=$ORDER(^XTMP("BQINIGHT",DFN))
IF 'DFN
QUIT
Begin DoDot:1
+13 DO PAT^BQITDPAT(.DATA,DFN)
+14 QUIT
End DoDot:1
+15 ;
+16 IF $GET(BQGLB)'=""
KILL @BQGLB,BQGLB
+17 IF $GET(BQPGLB)'=""
KILL @BQPGLB,BQPGLB
+18 KILL AGE,BQEXEC,BQDEF,BQPRG,DFN,PRGM,SEX,TXDXCN,TXDXCT,TXT,Y
+19 ;
+20 ; Set the DATE/TIME DXN CATEGORY STOPPED field
+21 NEW DA,BQTSK
+22 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+23 SET BQIUPD(90508,DA_",",3.05)=$$NOW^XLFDT()
+24 SET BQIUPD(90508,DA_",",3.06)="@"
+25 DO FILE^DIE("","BQIUPD","ERROR")
+26 KILL BQIUPD
+27 FOR BQTSK="BQIBMI","BQIBP","BQIPREG","BQITAX","BQITAX1","BQITDPRC","BQITMPO","BQITDPAT"
KILL ^TMP(BQTSK,UID)
+28 QUIT
+29 ;
CRS ;EP - Find all GPRA indicators
+1 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
+2 ;
+3 ; Check if new version of CRS has been loaded
+4 DO GCHK^BQIGPUPD()
+5 ;
+6 NEW DA
+7 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+8 SET BQIUPD(90508,DA_",",3.07)=$$NOW^XLFDT()
+9 SET BQIUPD(90508,DA_",",3.09)=1
+10 DO FILE^DIE("","BQIUPD","ERROR")
+11 KILL BQIUPD
+12 ;
+13 NEW DFN,GPMEAS,CT
+14 SET BQIGREF=$NAME(^TMP(UID,"BQIGPRA"))
+15 KILL @BQIGREF
+16 SET BQIDATA=$NAME(^BQIPAT)
+17 ;
+18 DO INP
+19 ; If the routine is not defined, quit
+20 IF $GET(BQIROU)=""
QUIT
+21 ;
+22 ; If the tag is not defined, quit
+23 IF $TEXT(@("BQI^"_BQIROU))=""
QUIT
+24 ;
+25 ; Initialize GPRA variables
+26 NEW VER,BQX,XN
+27 SET VER=$$VERSION^XPDUTL("BGP")
+28 ;
+29 IF VER>7.0
Begin DoDot:1
+30 SET BQX=""
+31 FOR
SET BQX=$ORDER(^BQI(90506.1,"AC","G",BQX))
IF BQX=""
QUIT
Begin DoDot:2
+32 IF $PIECE(^BQI(90506.1,BQX,0),U,10)=1
QUIT
+33 SET X=$PIECE(^BQI(90506.1,BQX,0),U,1)
SET XN=$PIECE(X,"_",2)
+34 SET X=$PIECE($GET(@BQIMEASG@(XN,0)),U,1)
IF X'=""
SET BGPIND(X)=""
End DoDot:2
End DoDot:1
+35 ;
+36 ; Define the time frame for the patient
+37 SET BGPBD=$$DATE^BQIUL1("T-12M")
SET BGPED=DT
+38 SET BGPBBD="300"_$EXTRACT(BGPBD,4,7)
SET BGPBED="300"_$EXTRACT(BGPED,4,7)
+39 SET BGPPBD=$$DATE^BQIUL1("T-24M")
SET BGPPED=$$DATE^BQIUL1("T-12M")
+40 SET BGPPER=$EXTRACT($$DT^XLFDT(),1,3)_"0000"
+41 SET BGPQTR=$SELECT(BGPBD>($EXTRACT(BGPBD,1,3)_"0101")&(BGPBD<($EXTRACT(BGPBD,1,3)_"0331")):1,BGPBD>($EXTRACT(BGPBD,1,3)_"0401")&(BGPBD<($EXTRACT(BGPBD,1,3)_"0630")):2,BGPBD>($EXTRACT(BGPBD,1,3)_"0701")&(BGPBD<($EXTRACT(BGPBD,1,3)_"0930")):3,1:4
)
+42 SET BGPRTYPE=4
SET BGPRPT=4
+43 SET BGP3YE=$$FMADD^XLFDT(BGPED,-1096)
+44 SET BGPP3YE=$$FMADD^XLFDT(BGPPED,-1096)
+45 SET BGPB3YE=$$FMADD^XLFDT(BGPBED,-1096)
+46 ;
+47 ; Setup taxonomies
+48 IF VER>14.1
Begin DoDot:1
+49 IF $TEXT(UNFOLDTX^BGP8UTL2)=""
QUIT
+50 DO UNFOLDTX^BGP8UTL2
End DoDot:1
+51 ;
+52 SET DFN=0
+53 FOR
SET DFN=$ORDER(^XTMP("BQINIGHT",DFN))
IF 'DFN
QUIT
Begin DoDot:1
+54 ; Remove any previous GPRA data
+55 KILL @BQIDATA@(DFN,30)
+56 SET @BQIDATA@(DFN,30,0)="^90507.53^^"
+57 ; If patient is deceased, don't calculate
+58 IF $PIECE($GET(^DPT(DFN,.35)),U,1)'=""
QUIT
+59 ; If patient has no active HRNs, quit
+60 IF '$$HRN^BQIUL1(DFN)
QUIT
+61 ; If patient has no visit in last 2 years, quit
+62 ;I '$$VTHR^BQIUL1(DFN) Q
+63 IF '$$VTWR^BQIUL1(DFN)
QUIT
+64 ; If new patient add to BQIPAT
+65 IF $GET(^BQIPAT(DFN,0))=""
DO NPT^BQITASK(DFN)
+66 IF $PIECE($GET(^BQIPAT(DFN,0)),"^",1)=""
SET $PIECE(^BQIPAT(DFN,0),"^",1)=DFN
SET ^BQIPAT("B",DFN,DFN)=""
+67 SET BQIPUP(90507.5,DFN_",",.02)=BQIYR
+68 SET BQIPUP(90507.5,DFN_",",.03)=BGPBD
+69 SET BQIPUP(90507.5,DFN_",",.04)=BGPED
+70 SET BQIPUP(90507.5,DFN_",",.05)=$$NOW^XLFDT()
+71 DO FILE^DIE("","BQIPUP","ERROR")
+72 KILL BQIPUP
+73 DO @("BQI^"_BQIROU_"(DFN,.BQIGREF)")
+74 ;
+75 NEW DA
+76 SET DA(1)=DFN
SET DA=0
SET DIK="^BQIPAT("_DA(1)_",30,"
+77 FOR
SET DA=$ORDER(@BQIDATA@(DFN,30,DA))
IF 'DA
QUIT
DO ^DIK
+78 ;
+79 ; if the patient doesn't meet any GPRA logic, quit
+80 IF '$DATA(@BQIGREF@(DFN))
QUIT
+81 ;
+82 IF '$DATA(@BQIDATA@(DFN,30,0))
SET @BQIDATA@(DFN,30,0)="^90507.53^^"
+83 ;
+84 SET SIND=""
SET CT=0
+85 FOR
SET SIND=$ORDER(^BQI(90506.1,"AC","G",SIND))
IF SIND=""
QUIT
Begin DoDot:2
+86 SET CT=CT+1
+87 IF $PIECE(^BQI(90506.1,SIND,0),U,10)=1
QUIT
+88 SET @BQIDATA@(DFN,30,CT,0)=$PIECE(^BQI(90506.1,SIND,0),U,1)
+89 SET @BQIDATA@(DFN,30,"B",$PIECE(^BQI(90506.1,SIND,0),U,1),CT)=""
End DoDot:2
+90 ;
+91 SET IND=0
+92 FOR
SET IND=$ORDER(@BQIGREF@(DFN,IND))
IF IND=""
QUIT
Begin DoDot:2
+93 SET MEAS=0
+94 FOR
SET MEAS=$ORDER(@BQIGREF@(DFN,IND,MEAS))
IF MEAS=""
QUIT
Begin DoDot:3
+95 ;Q:'$$SUM^BQIGPUTL(BQIYR,MEAS)
+96 SET GPMEAS=BQIYR_"_"_MEAS
+97 SET MCT=$ORDER(^BQIPAT(DFN,30,"B",GPMEAS,""))
IF MCT=""
QUIT
+98 SET $PIECE(@BQIDATA@(DFN,30,MCT,0),U,2)=$PIECE(@BQIGREF@(DFN,IND),U,2)
+99 SET $PIECE(@BQIDATA@(DFN,30,MCT,0),U,3)=$PIECE(@BQIGREF@(DFN,IND,MEAS),U,2)
+100 SET $PIECE(@BQIDATA@(DFN,30,MCT,0),U,4)=$PIECE(@BQIGREF@(DFN,IND,MEAS),U,3)
End DoDot:3
End DoDot:2
+101 KILL @BQIGREF
+102 NEW DA,DIK
+103 SET DA=DFN
SET DIK="^BQIPAT("
DO IX1^DIK
End DoDot:1
+104 ;
+105 KILL ^XTMP("BGP15TAX",$JOB),^XTMP("BGPSNOMEDSUBSET",$JOB)
+106 ;
+107 ; Compile Main view data
+108 DO COMP^BQIGPRA5
+109 ;
+110 ; Set the DATE/TIME GPRA STOPPED field
+111 NEW DA
+112 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+113 SET BQIUPD(90508,DA_",",3.08)=$$NOW^XLFDT()
+114 SET BQIUPD(90508,DA_",",3.09)="@"
+115 DO FILE^DIE("","BQIUPD","ERROR")
+116 KILL BQIUPD
+117 ;
+118 KILL MEAS,DFN,IND,BGPIND,BGPBD,BGPED,BGPBBD,BGPBED,BGPPBD,BGPPED
+119 KILL BGPQTR,BGPRTYPE,BGPRPT,BGP3YE,BGPP3YE,BGPB3YE,BGPHOME,BHM
+120 KILL BQIDATA,BQIH,BQIINDF,BQIINDG,BQIMEASF,BQIMEASG,BQIROU,BQIY,BQIYR
+121 KILL @BQIGREF,BQIUPD,MCT,SIND,VLIEN,VOK,X,BQIGREF,BGPPER
+122 ;
+123 QUIT
+124 ;
REM ;EP - Find any new reminders
+1 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
+2 ;
+3 ; Set the DATE/TIME REMINDERS STARTED field
+4 NEW DA
+5 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+6 SET BQIUPD(90508,DA_",",3.1)=$$NOW^XLFDT()
+7 SET BQIUPD(90508,DA_",",3.12)=1
+8 DO FILE^DIE("","BQIUPD","ERROR")
+9 KILL BQIUPD
+10 ; Re-evaluate reminders
+11 DO CHK^BQIRMDR("Nightly")
+12 ; Check for new CMET followups and recalculate their reminders
+13 NEW CMDT,IEN,BKDFN
+14 SET CMDT=$$FMADD^XLFDT(DT,-1)-.005
+15 FOR
SET CMDT=$ORDER(^BTPWP("AU",CMDT))
IF CMDT=""
QUIT
Begin DoDot:1
+16 SET IEN=""
+17 FOR
SET IEN=$ORDER(^BTPWP("AU",CMDT,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+18 SET BKDFN=$PIECE(^BTPWP(IEN,0),U,2)
SET ^XTMP("BQINIGHT",BKDFN)=""
End DoDot:2
End DoDot:1
+19 ; Check for DUZ
+20 DO DZ^BQITASK1
+21 ;
+22 ; Check for Appointments
+23 DO APT^BQIRMIZ
+24 ; Reset Reminders
+25 NEW BKDFN
+26 SET BKDFN=0
SET ERRCNT=0
+27 FOR
SET BKDFN=$ORDER(^XTMP("BQINIGHT",BKDFN))
IF 'BKDFN
QUIT
Begin DoDot:1
+28 IF $GET(^BQIPAT(BKDFN,0))=""
DO NPT^BQITASK(BKDFN)
+29 IF $PIECE($GET(^BQIPAT(BKDFN,0)),"^",1)=""
SET $PIECE(^BQIPAT(BKDFN,0),"^",1)=BKDFN
SET ^BQIPAT("B",BKDFN,BKDFN)=""
+30 DO PAT^BQIRMDR(BKDFN)
End DoDot:1
IF ERRCNT>100
QUIT
+31 ;
+32 ; Set the DATE/TIME REMINDERS STOPPED field
+33 NEW DA
+34 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+35 SET BQIUPD(90508,DA_",",3.11)=$$NOW^XLFDT()
+36 SET BQIUPD(90508,DA_",",3.12)="@"
+37 DO FILE^DIE("","BQIUPD","ERROR")
+38 KILL BQIUPD,ERRCNT
+39 QUIT
+40 ;
TRT ;EP - Update treatment prompts
+1 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
+2 ; Set the DATE/TIME TREATMENT STARTED field
+3 NEW DA
+4 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+5 SET BQIUPD(90508,DA_",",3.13)=$$NOW^XLFDT()
+6 SET BQIUPD(90508,DA_",",3.15)=1
+7 DO FILE^DIE("","BQIUPD","ERROR")
+8 KILL BQIUPD
+9 NEW BKDFN
+10 SET BKDFN=0
+11 FOR
SET BKDFN=$ORDER(^XTMP("BQINIGHT",BKDFN))
IF 'BKDFN
QUIT
Begin DoDot:1
+12 IF $GET(^BQIPAT(BKDFN,0))=""
DO NPT^BQITASK(BKDFN)
+13 IF $PIECE($GET(^BQIPAT(BKDFN,0)),"^",1)=""
SET $PIECE(^BQIPAT(BKDFN,0),"^",1)=BKDFN
SET ^BQIPAT("B",BKDFN,BKDFN)=""
+14 DO PAT^BQITRMT(BKDFN)
End DoDot:1
+15 ; Set the DATE/TIME TREATMENT STOPPED field
+16 NEW DA
+17 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+18 SET BQIUPD(90508,DA_",",3.14)=$$NOW^XLFDT()
+19 SET BQIUPD(90508,DA_",",3.15)="@"
+20 DO FILE^DIE("","BQIUPD","ERROR")
+21 KILL BQIUPD
+22 QUIT
+23 ;
INP ;EP - Initialize GPRA variables
+1 NEW DA,IENS
+2 IF $GET(U)=""
DO DT^DICRW
+3 ;
+4 ; Get the internal entry value from the site parameters
+5 SET BQIH=$$SPM^BQIGPUTL()
+6 SET BGPHOME=$$HME^BQIGPUTL()
+7 ;
+8 ; get the current year for CRS
+9 SET BQIYR=$$GET1^DIQ(90508,BQIH,2,"E")
+10 IF BQIYR=""
SET BQIYR=$PIECE($$FMTE^XLFDT(DT,7),"/",1)
+11 SET BQIY=$$LKP^BQIGPUTL(BQIYR)
+12 ; if the current year is not defined yet, get the previous year
+13 IF BQIY=-1
SET BQIYR=BQIYR-1
SET BQIY=$$LKP^BQIGPUTL(BQIYR)
IF BQIY=-1
QUIT
+14 ;
+15 ; get the global references for the corresponding CRS year
+16 SET DA(1)=BQIH
SET DA=BQIY
+17 SET IENS=$$IENS^DILF(.DA)
+18 SET BQIINDF=$$GET1^DIQ(90508.01,IENS,.02,"E")
+19 SET BQIINDG=$$ROOT^DILFD(BQIINDF,"",1)
+20 SET BQIMEASF=$$GET1^DIQ(90508.01,IENS,.03,"E")
+21 SET BQIMEASG=$$ROOT^DILFD(BQIMEASF,"",1)
+22 SET BQIROU=$$GET1^DIQ(90508.01,IENS,.04,"E")
+23 QUIT
