BQITASK ;PRXM/HC/ALA-Scheduled Task Program ; 20 Dec 2006 4:56 PM
;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
Q
;
EN ;EP - Entry point
NEW UID
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQI1POJB"
;
D DXC
D GPR
;
K BQIUPD,INSTALL,UID,STAT
Q
;
DXC ;EP - Tag the diagnosis categories
; Variables
; BQDEF - Diag Cat Definition Name
; BQEXEC - Diag Cat special executable program
; BQPRG - Diag Cat standard executable program
; BQREF - Taxonomy array reference
; BQGLB - Temporary global reference
; BQORD - Order that the category must be determined
; (Some categories depend upon a patient not being
; in another category)
; BQTN - Diag Cat internal entry number
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
;
; Set the DATE/TIME DXN CATEGORY STARTED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",4.01)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",4.03)=1
S BQIUPD(90508,DA_",",24.04)=$G(ZTSK)
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
NEW BQTN,BQDEF,BQORD,IEN
S BQORD=""
F S BQORD=$O(^BQI(90506.2,"AC",BQORD)) Q:BQORD="" D
. S BQTN=0
. F S BQTN=$O(^BQI(90506.2,"AC",BQORD,BQTN)) Q:'BQTN D
.. ; If the category is marked as inactive, ignore it
.. ;I $$GET1^DIQ(90506.2,BQTN_",",.03,"I") Q
.. I $P($G(^BQI(90506.2,BQTN,0)),"^",3)'="" Q
.. ; If the category is a subdefinition, ignore it
.. ;I $$GET1^DIQ(90506.2,BQTN_",",.05,"I")=1 Q
.. I $P($G(^BQI(90506.2,BQTN,0)),"^",5)=1 Q
.. ;S BQDEF=$$GET1^DIQ(90506.2,BQTN_",",.01,"E")
.. S BQDEF=$P($G(^BQI(90506.2,BQTN,0)),"^",1)
.. ;S BQPRG=$$GET1^DIQ(90506.2,BQTN_",",.04,"E")
.. S BQPRG=$P($G(^BQI(90506.2,BQTN,0)),"^",4)
.. ;S BQEXEC=$$GET1^DIQ(90506.2,BQTN_",",1,"E")
.. S BQEXEC=$G(^BQI(90506.2,BQTN,1))
.. ;
.. ; Set the taxonomy array from the file definition
.. S BQREF="BQIRY" K @BQREF
.. D ARY^BQITUTL(BQDEF,BQREF)
.. S BQGLB=$NA(^TMP(UID,"BQIPOP"))
.. K @BQGLB
.. ;
.. ; Call the populate category code
.. S PRGM="POP^"_BQPRG_"(BQREF,BQGLB)"
.. D @PRGM
.. ;
.. ; Check if patient tagged but not found in criteria anymore
.. S IEN=""
.. F S IEN=$O(^BQIREG("B",BQTN,IEN)) Q:IEN="" D
... S DFN=$P(^BQIREG(IEN,0),U,2)
... I '$D(@BQGLB@(DFN)) D
.... D NCR^BQITDUTL(DFN,BQTN)
.... ; Remove previous criteria
.... NEW DA,DIK
.... S DA(2)=DFN,DA(1)=BQTN,DA=0,DIK="^BQIPAT("_DA(2)_",20,"_DA(1)_",1,"
.... F S DA=$O(^BQIPAT(DFN,20,BQTN,1,DA)) Q:'DA D ^DIK
.... K ^BQIPAT(DFN,20,BQTN,1,"B")
.. ; File the patients who met criteria
.. S DFN=0
.. F S DFN=$O(@BQGLB@(DFN)) Q:DFN="" D FIL(BQGLB,DFN)
.. Q
;
K @BQGLB,AGE,BQEXEC,BQDEF,BQPRG,@BQREF,BQREF,BQGLB,DFN,PRGM
K SEX,TXDXCN,TXDXCT,TXT,Y
;
; Set the DATE/TIME DXN CATEGORY STOPPED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",4.02)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",4.03)="@"
S BQIUPD(90508,DA_",",24.04)="@"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
Q
;
GPR ;EP - Entry point to get GPRA values for all users
;
;Variables
; BQIGREF - Temporary global reference that returns the raw GPRA data
; BQIDATA - Global reference for iCare Patients.
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
;
NEW BGP3YE,BGPB3YE,BGPBBD,BGPBD,BGPBED,BGPED,BGPIND,BGPP3YE,BGPPBD,BGPPED
NEW BGPQTR,BGPRPT,BGPRTYPE,BQIDATA,BQIGREF,BQIH,BQIINDG,BQIPUP,BQIROU,BQIY
NEW BQIYR,IND,MCT,MEAS,SIND,BGPPER,BQIDFN,CT,GPMEAS,BQIMEASG,CRDT
;
NEW UID
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
;
; Check if new version of CRS has been loaded
D GCHK^BQIGPUPD(0)
;
; Set the DATE/TIME GPRA STARTED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",4.04)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",4.06)=1
S BQIUPD(90508,DA_",",24.05)=$G(ZTSK)
D FILE^DIE("","BQIUPD")
K BQIUPD
;
NEW DFN
S BQIGREF=$NA(^TMP(UID,"BQIGPRA"))
K @BQIGREF
S BQIDATA=$NA(^BQIPAT)
;
; Initialize data
D INP^BQINIGHT
; If the routine is not defined, quit
I $G(BQIROU)="" G EXIT
;
; If the tag is not defined, quit
I $T(@("BQI^"_BQIROU))="" G EXIT
;
; 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 BGPBD=3160731,BGPED=3170731
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
;
; For every patient in the database, call the GPRA API
S BQIDFN=0
F S BQIDFN=$O(^AUPNPAT(BQIDFN)) Q:'BQIDFN D
. ; Remove any previous GPRA data
. K @BQIDATA@(BQIDFN,30)
. ;
. ; If patient is deceased, don't calculate
. I $P($G(^DPT(BQIDFN,.35)),U,1)'="" Q
. ; If patient has no active HRNs, quit
. I '$$HRN^BQIUL1(BQIDFN) Q
. ; If patient has no visits in past 3 years, quit
. I '$$VTHR^BQIUL1(BQIDFN) Q
. ;I '$$VTWR^BQIUL1(BQIDFN) Q
. I $P($G(^AUPNPAT(BQIDFN,0)),U,1)="" Q
. ; if the patient doesn't already exist in the iCare Patient file, add them
. I $G(^BQIPAT(BQIDFN,0))="" D NPT(BQIDFN)
. I $P($G(^BQIPAT(BQIDFN,0)),"^",1)="" S $P(^BQIPAT(BQIDFN,0),"^",1)=BQIDFN,^BQIPAT("B",BQIDFN,BQIDFN)=""
. ;
. ;S CRDT=$P($G(^BQIPAT(BQIDFN,0)),"^",5)
. ;I $$FMDIFF^XLFDT(DT,CRDT\1)<7 Q
. ;
. D @("BQI^"_BQIROU_"(BQIDFN,.BQIGREF)")
. ; if the patient doesn't meet any GPRA logic, quit
. I '$D(@BQIGREF@(BQIDFN)) Q
. ;
. S @BQIDATA@(BQIDFN,30,0)="^90507.53^^"
. ;
. ; set the year of the GPRA and the begin/end dates
. S BQIPUP(90507.5,BQIDFN_",",.02)=BQIYR
. S BQIPUP(90507.5,BQIDFN_",",.03)=BGPBD
. S BQIPUP(90507.5,BQIDFN_",",.04)=BGPED
. S BQIPUP(90507.5,BQIDFN_",",.05)=$$NOW^XLFDT()
. D FILE^DIE("","BQIPUP","ERROR")
. K BQIPUP
. ;
. ; initialize the summary indicators for the patient
. S CT=0,SIND=""
. 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@(BQIDFN,30,CT,0)=$P(^BQI(90506.1,SIND,0),U,1)
.. S @BQIDATA@(BQIDFN,30,"B",$P(^BQI(90506.1,SIND,0),U,1),CT)=""
. ;
. S IND=0
. F S IND=$O(@BQIGREF@(BQIDFN,IND)) Q:IND="" D
.. S MEAS=0
.. F S MEAS=$O(@BQIGREF@(BQIDFN,IND,MEAS)) Q:MEAS="" D
... S GPMEAS=BQIYR_"_"_MEAS
... S MCT=$O(^BQIPAT(BQIDFN,30,"B",GPMEAS,"")) I MCT="" Q
... S $P(@BQIDATA@(BQIDFN,30,MCT,0),U,2)=$P(@BQIGREF@(BQIDFN,IND),U,2)
... S $P(@BQIDATA@(BQIDFN,30,MCT,0),U,3)=$P(@BQIGREF@(BQIDFN,IND,MEAS),U,2)
... S $P(@BQIDATA@(BQIDFN,30,MCT,0),U,4)=$P(@BQIGREF@(BQIDFN,IND,MEAS),U,3)
. K @BQIGREF
. ; reindex the patient record
. ;NEW DA,DIK
. ;S DA=BQIDFN,DIK="^BQIPAT(" D IX1^DIK
;
K ^XTMP("BGP15TAX",$J),^XTMP("BGPSNOMEDSUBSET",$J)
;
EXIT ; Set the DATE/TIME GPRA STOPPED
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",4.05)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",4.06)="@"
S BQIUPD(90508,DA_",",24.05)="@"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
Q
;
FIL(BQGLB,DFN) ;EP - File diagnosis category
NEW DA,IENS,DIC,X,DLAYGO,DINUM,EVN,TXN,TYP,MEVN,TGDATA,CSTAT,RIEN,TXT,TXN,QFL
NEW THCFL
; Exclude deceased patients
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 past 3 years, quit
;I BQDEF'="ASCVD Known",'$$VTHR^BQIUL1(DFN) Q
;
; Check on status of current record
S RIEN=$O(^BQIREG("C",DFN,BQTN,""))
; If patient is in BQIREG with accepted status, no need to do anything
I RIEN'="" S QFL=0 D Q:QFL
. S CSTAT=$P(^BQIREG(RIEN,0),U,3)
. I CSTAT="A" S QFL=1
. I CSTAT="N",BQTN'=3 S QFL=1
; if the patient doesn't already exist in the iCare Patient file, add them
I $G(^BQIPAT(DFN,0))="" D NPT(DFN)
;
S DA(1)=DFN
I '$D(^BQIPAT(DFN,20,0)) S ^BQIPAT(DFN,20,0)="^90507.52P^^"
S (X,DINUM)=BQTN,DIC(0)="L",DIC="^BQIPAT("_DA(1)_",20,",DLAYGO=90507.52,DIC("P")=DLAYGO
K DO,DD D FILE^DICN
S DA=+Y S:DA=-1 DA=BQTN
S IENS=$$IENS^DILF(.DA)
S BQIUPD(90507.52,IENS,.02)=$$NOW^XLFDT()
S BQIUPD(90507.5,DFN_",",.06)=$$NOW^XLFDT()
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
; Remove previous criteria
D DEL
;
; Add the criteria on why patient met diagnosis category
S TXT=""
F S TXT=$O(@BQGLB@(DFN,"CRITERIA",TXT)) Q:TXT="" D
. I '$D(^BQIPAT(DFN,20,BQTN,1,0)) S ^BQIPAT(DFN,20,BQTN,1,0)="^90507.521^^"
. NEW DA
. S DA(2)=DFN,DA(1)=BQTN,X=TXT,DIC(0)="L"
. S DIC="^BQIPAT("_DA(2)_",20,"_DA(1)_",1,",DLAYGO=90507.521
. K DO,DD D FILE^DICN
. S TXN=+Y
. I '$D(^BQIPAT(DFN,20,BQTN,1,TXN,1,0)) S ^BQIPAT(DFN,20,BQTN,1,TXN,1,0)="^90507.5211^^"
. F TYP="P" S EVN=0 D
.. F S EVN=$O(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN)) Q:EVN="" D
... NEW DA,IENS
... S DA(3)=DFN,DA(2)=BQTN,DA(1)=TXN,DIC(0)="L",DLAYGO=90507.5211,X=TYP_EVN
... S DIC="^BQIPAT("_DA(3)_",20,"_DA(2)_",1,"_DA(1)_",1,"
... D ^DIC
... S DA=+Y,IENS=$$IENS^DILF(.DA)
... S BQIUPD(90507.5211,IENS,.02)=$P(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN),U,1)
... I $P(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN),U,2)'="" S BQIUPD(90507.5211,IENS,.03)=$P(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN),U,2)
... I $P(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN),U,3)'="" S BQIUPD(90507.5211,IENS,.04)=$P(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN),U,3)
... I $P(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN),U,4)'="" S BQIUPD(90507.5211,IENS,.05)=$P(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN),U,4)
... D FILE^DIE("","BQIUPD","ERROR")
... K BQIUPD
. F TYP="V" S EVN="" D
.. F S EVN=$O(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN)) Q:EVN="" D
... S MEVN=""
... F S MEVN=$O(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN)) Q:MEVN="" D
.... NEW DA,IENS
.... S DA(3)=DFN,DA(2)=BQTN,DA(1)=TXN,DIC(0)="L",DLAYGO=90507.5211,X=TYP_EVN
.... S DIC="^BQIPAT("_DA(3)_",20,"_DA(2)_",1,"_DA(1)_",1,"
.... D ^DIC
.... I $P(Y,U,3)'=1 D
..... I Y=-1 K DO,DD D FILE^DICN Q
..... I $P(^BQIPAT(DFN,20,BQTN,1,TXN,1,+Y,0),U,4)'=MEVN K DO,DD D FILE^DICN
.... S DA=+Y,IENS=$$IENS^DILF(.DA)
.... S BQIUPD(90507.5211,IENS,.02)=$P(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,1)
.... I $P(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,2)'="" S BQIUPD(90507.5211,IENS,.03)=$P(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,2)
.... I $P(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,3)'="" S BQIUPD(90507.5211,IENS,.04)=$P(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,3)
.... I $P(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,4)'="" S BQIUPD(90507.5211,IENS,.05)=$P(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,4)
.... D FILE^DIE("","BQIUPD","ERROR")
.... K BQIUPD
;
K @BQGLB@(DFN)
; Check on status of current record
S RIEN=$O(^BQIREG("C",DFN,BQTN,""))
; If no record found, then it's a new record
I RIEN="" D Q
. ; if patient is in a register, check status to determine "A" else "P"
. I $$REG^BQITDUTL(DFN,BQTN)=1 D EN^BQITDPRC(.TGDATA,DFN,BQTN,"A",,"SYSTEM UPDATE",8) Q
. I $$REG^BQITDUTL(DFN,BQTN)=2 D EN^BQITDPRC(.TGDATA,DFN,BQTN,"P",,"SYSTEM UPDATE",8) Q
. D EN^BQITDPRC(.TGDATA,DFN,BQTN,"P",,"SYSTEM UPDATE",5)
;
; If a record was found, check its current status and hierarchy
S CSTAT=$P(^BQIREG(RIEN,0),U,3)
I CSTAT="P" D RCHK Q
;
I CSTAT="V"!(CSTAT="S") D EN^BQITDPRC(.TGDATA,DFN,BQTN,"P",,"SYSTEM UPDATE",5) Q
; Check for new factors, if none, quit
I '$$CMP^BQITDUTL(DFN,BQTN) D DEL^BQITASK Q
D EN^BQITDPRC(.TGDATA,DFN,BQTN,"P",,"SYSTEM UPDATE",5)
Q
;
NPT(DFN) ;EP - New patient
; if the patient doesn't already exist in the iCare Patient file, add them
NEW DIC,X,DINUM,DLAYGO
S (X,DINUM)=DFN,DLAYGO=90507.5,DIC="^BQIPAT(",DIC(0)="L",DIC("P")=DLAYGO
K DO,DD D FILE^DICN
Q
;
DEL ;EP - Delete criteria
NEW DA,DIK
S DA(2)=DFN,DA(1)=BQTN,DA=0,DIK="^BQIPAT("_DA(2)_",20,"_DA(1)_",1,"
F S DA=$O(^BQIPAT(DFN,20,BQTN,1,DA)) Q:'DA D ^DIK
K ^BQIPAT(DFN,20,BQTN,1,"B")
Q
;
RCHK ; Register check
; if patient is in a register, check status to determine "A" else "P"
I $$REG^BQITDUTL(DFN,BQTN)=1 D EN^BQITDPRC(.TGDATA,DFN,BQTN,"A",,"SYSTEM UPDATE",8) Q
Q
BQITASK ;PRXM/HC/ALA-Scheduled Task Program ; 20 Dec 2006 4:56 PM
+1 ;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
+2 QUIT
+3 ;
EN ;EP - Entry point
+1 NEW UID
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 ;
+4 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQI1POJB"
+5 ;
+6 DO DXC
+7 DO GPR
+8 ;
+9 KILL BQIUPD,INSTALL,UID,STAT
+10 QUIT
+11 ;
DXC ;EP - Tag the diagnosis categories
+1 ; Variables
+2 ; BQDEF - Diag Cat Definition Name
+3 ; BQEXEC - Diag Cat special executable program
+4 ; BQPRG - Diag Cat standard executable program
+5 ; BQREF - Taxonomy array reference
+6 ; BQGLB - Temporary global reference
+7 ; BQORD - Order that the category must be determined
+8 ; (Some categories depend upon a patient not being
+9 ; in another category)
+10 ; BQTN - Diag Cat internal entry number
+11 ;
+12 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
+13 ;
+14 ; Set the DATE/TIME DXN CATEGORY STARTED field
+15 NEW DA
+16 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+17 SET BQIUPD(90508,DA_",",4.01)=$$NOW^XLFDT()
+18 SET BQIUPD(90508,DA_",",4.03)=1
+19 SET BQIUPD(90508,DA_",",24.04)=$GET(ZTSK)
+20 DO FILE^DIE("","BQIUPD","ERROR")
+21 KILL BQIUPD
+22 ;
+23 NEW BQTN,BQDEF,BQORD,IEN
+24 SET BQORD=""
+25 FOR
SET BQORD=$ORDER(^BQI(90506.2,"AC",BQORD))
IF BQORD=""
QUIT
Begin DoDot:1
+26 SET BQTN=0
+27 FOR
SET BQTN=$ORDER(^BQI(90506.2,"AC",BQORD,BQTN))
IF 'BQTN
QUIT
Begin DoDot:2
+28 ; If the category is marked as inactive, ignore it
+29 ;I $$GET1^DIQ(90506.2,BQTN_",",.03,"I") Q
+30 IF $PIECE($GET(^BQI(90506.2,BQTN,0)),"^",3)'=""
QUIT
+31 ; If the category is a subdefinition, ignore it
+32 ;I $$GET1^DIQ(90506.2,BQTN_",",.05,"I")=1 Q
+33 IF $PIECE($GET(^BQI(90506.2,BQTN,0)),"^",5)=1
QUIT
+34 ;S BQDEF=$$GET1^DIQ(90506.2,BQTN_",",.01,"E")
+35 SET BQDEF=$PIECE($GET(^BQI(90506.2,BQTN,0)),"^",1)
+36 ;S BQPRG=$$GET1^DIQ(90506.2,BQTN_",",.04,"E")
+37 SET BQPRG=$PIECE($GET(^BQI(90506.2,BQTN,0)),"^",4)
+38 ;S BQEXEC=$$GET1^DIQ(90506.2,BQTN_",",1,"E")
+39 SET BQEXEC=$GET(^BQI(90506.2,BQTN,1))
+40 ;
+41 ; Set the taxonomy array from the file definition
+42 SET BQREF="BQIRY"
KILL @BQREF
+43 DO ARY^BQITUTL(BQDEF,BQREF)
+44 SET BQGLB=$NAME(^TMP(UID,"BQIPOP"))
+45 KILL @BQGLB
+46 ;
+47 ; Call the populate category code
+48 SET PRGM="POP^"_BQPRG_"(BQREF,BQGLB)"
+49 DO @PRGM
+50 ;
+51 ; Check if patient tagged but not found in criteria anymore
+52 SET IEN=""
+53 FOR
SET IEN=$ORDER(^BQIREG("B",BQTN,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+54 SET DFN=$PIECE(^BQIREG(IEN,0),U,2)
+55 IF '$DATA(@BQGLB@(DFN))
Begin DoDot:4
+56 DO NCR^BQITDUTL(DFN,BQTN)
+57 ; Remove previous criteria
+58 NEW DA,DIK
+59 SET DA(2)=DFN
SET DA(1)=BQTN
SET DA=0
SET DIK="^BQIPAT("_DA(2)_",20,"_DA(1)_",1,"
+60 FOR
SET DA=$ORDER(^BQIPAT(DFN,20,BQTN,1,DA))
IF 'DA
QUIT
DO ^DIK
+61 KILL ^BQIPAT(DFN,20,BQTN,1,"B")
End DoDot:4
End DoDot:3
+62 ; File the patients who met criteria
+63 SET DFN=0
+64 FOR
SET DFN=$ORDER(@BQGLB@(DFN))
IF DFN=""
QUIT
DO FIL(BQGLB,DFN)
+65 QUIT
End DoDot:2
End DoDot:1
+66 ;
+67 KILL @BQGLB,AGE,BQEXEC,BQDEF,BQPRG,@BQREF,BQREF,BQGLB,DFN,PRGM
+68 KILL SEX,TXDXCN,TXDXCT,TXT,Y
+69 ;
+70 ; Set the DATE/TIME DXN CATEGORY STOPPED field
+71 NEW DA
+72 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+73 SET BQIUPD(90508,DA_",",4.02)=$$NOW^XLFDT()
+74 SET BQIUPD(90508,DA_",",4.03)="@"
+75 SET BQIUPD(90508,DA_",",24.04)="@"
+76 DO FILE^DIE("","BQIUPD","ERROR")
+77 KILL BQIUPD
+78 QUIT
+79 ;
GPR ;EP - Entry point to get GPRA values for all users
+1 ;
+2 ;Variables
+3 ; BQIGREF - Temporary global reference that returns the raw GPRA data
+4 ; BQIDATA - Global reference for iCare Patients.
+5 ;
+6 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
+7 ;
+8 NEW BGP3YE,BGPB3YE,BGPBBD,BGPBD,BGPBED,BGPED,BGPIND,BGPP3YE,BGPPBD,BGPPED
+9 NEW BGPQTR,BGPRPT,BGPRTYPE,BQIDATA,BQIGREF,BQIH,BQIINDG,BQIPUP,BQIROU,BQIY
+10 NEW BQIYR,IND,MCT,MEAS,SIND,BGPPER,BQIDFN,CT,GPMEAS,BQIMEASG,CRDT
+11 ;
+12 NEW UID
+13 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+14 ;
+15 ; Check if new version of CRS has been loaded
+16 DO GCHK^BQIGPUPD(0)
+17 ;
+18 ; Set the DATE/TIME GPRA STARTED field
+19 NEW DA
+20 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+21 SET BQIUPD(90508,DA_",",4.04)=$$NOW^XLFDT()
+22 SET BQIUPD(90508,DA_",",4.06)=1
+23 SET BQIUPD(90508,DA_",",24.05)=$GET(ZTSK)
+24 DO FILE^DIE("","BQIUPD")
+25 KILL BQIUPD
+26 ;
+27 NEW DFN
+28 SET BQIGREF=$NAME(^TMP(UID,"BQIGPRA"))
+29 KILL @BQIGREF
+30 SET BQIDATA=$NAME(^BQIPAT)
+31 ;
+32 ; Initialize data
+33 DO INP^BQINIGHT
+34 ; If the routine is not defined, quit
+35 IF $GET(BQIROU)=""
GOTO EXIT
+36 ;
+37 ; If the tag is not defined, quit
+38 IF $TEXT(@("BQI^"_BQIROU))=""
GOTO EXIT
+39 ;
+40 ; Initialize GPRA variables
+41 NEW VER,BQX,XN
+42 SET VER=$$VERSION^XPDUTL("BGP")
+43 ;
+44 IF VER>7.0
Begin DoDot:1
+45 SET BQX=""
+46 FOR
SET BQX=$ORDER(^BQI(90506.1,"AC","G",BQX))
IF BQX=""
QUIT
Begin DoDot:2
+47 IF $PIECE(^BQI(90506.1,BQX,0),U,10)=1
QUIT
+48 SET X=$PIECE(^BQI(90506.1,BQX,0),U,1)
SET XN=$PIECE(X,"_",2)
+49 SET X=$PIECE($GET(@BQIMEASG@(XN,0)),U,1)
IF X'=""
SET BGPIND(X)=""
End DoDot:2
End DoDot:1
+50 ;
+51 ; Define the time frame for the patient
+52 SET BGPBD=$$DATE^BQIUL1("T-12M")
SET BGPED=DT
+53 ;S BGPBD=3160731,BGPED=3170731
+54 SET BGPBBD="300"_$EXTRACT(BGPBD,4,7)
SET BGPBED="300"_$EXTRACT(BGPED,4,7)
+55 SET BGPPBD=$$DATE^BQIUL1("T-24M")
SET BGPPED=$$DATE^BQIUL1("T-12M")
+56 SET BGPPER=$EXTRACT($$DT^XLFDT(),1,3)_"0000"
+57 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
)
+58 SET BGPRTYPE=4
SET BGPRPT=4
+59 SET BGP3YE=$$FMADD^XLFDT(BGPED,-1096)
+60 SET BGPP3YE=$$FMADD^XLFDT(BGPPED,-1096)
+61 SET BGPB3YE=$$FMADD^XLFDT(BGPBED,-1096)
+62 ;
+63 ; Setup taxonomies
+64 IF VER>14.1
Begin DoDot:1
+65 IF $TEXT(UNFOLDTX^BGP8UTL2)=""
QUIT
+66 DO UNFOLDTX^BGP8UTL2
End DoDot:1
+67 ;
+68 ; For every patient in the database, call the GPRA API
+69 SET BQIDFN=0
+70 FOR
SET BQIDFN=$ORDER(^AUPNPAT(BQIDFN))
IF 'BQIDFN
QUIT
Begin DoDot:1
+71 ; Remove any previous GPRA data
+72 KILL @BQIDATA@(BQIDFN,30)
+73 ;
+74 ; If patient is deceased, don't calculate
+75 IF $PIECE($GET(^DPT(BQIDFN,.35)),U,1)'=""
QUIT
+76 ; If patient has no active HRNs, quit
+77 IF '$$HRN^BQIUL1(BQIDFN)
QUIT
+78 ; If patient has no visits in past 3 years, quit
+79 IF '$$VTHR^BQIUL1(BQIDFN)
QUIT
+80 ;I '$$VTWR^BQIUL1(BQIDFN) Q
+81 IF $PIECE($GET(^AUPNPAT(BQIDFN,0)),U,1)=""
QUIT
+82 ; if the patient doesn't already exist in the iCare Patient file, add them
+83 IF $GET(^BQIPAT(BQIDFN,0))=""
DO NPT(BQIDFN)
+84 IF $PIECE($GET(^BQIPAT(BQIDFN,0)),"^",1)=""
SET $PIECE(^BQIPAT(BQIDFN,0),"^",1)=BQIDFN
SET ^BQIPAT("B",BQIDFN,BQIDFN)=""
+85 ;
+86 ;S CRDT=$P($G(^BQIPAT(BQIDFN,0)),"^",5)
+87 ;I $$FMDIFF^XLFDT(DT,CRDT\1)<7 Q
+88 ;
+89 DO @("BQI^"_BQIROU_"(BQIDFN,.BQIGREF)")
+90 ; if the patient doesn't meet any GPRA logic, quit
+91 IF '$DATA(@BQIGREF@(BQIDFN))
QUIT
+92 ;
+93 SET @BQIDATA@(BQIDFN,30,0)="^90507.53^^"
+94 ;
+95 ; set the year of the GPRA and the begin/end dates
+96 SET BQIPUP(90507.5,BQIDFN_",",.02)=BQIYR
+97 SET BQIPUP(90507.5,BQIDFN_",",.03)=BGPBD
+98 SET BQIPUP(90507.5,BQIDFN_",",.04)=BGPED
+99 SET BQIPUP(90507.5,BQIDFN_",",.05)=$$NOW^XLFDT()
+100 DO FILE^DIE("","BQIPUP","ERROR")
+101 KILL BQIPUP
+102 ;
+103 ; initialize the summary indicators for the patient
+104 SET CT=0
SET SIND=""
+105 FOR
SET SIND=$ORDER(^BQI(90506.1,"AC","G",SIND))
IF SIND=""
QUIT
Begin DoDot:2
+106 SET CT=CT+1
+107 IF $PIECE(^BQI(90506.1,SIND,0),U,10)=1
QUIT
+108 SET @BQIDATA@(BQIDFN,30,CT,0)=$PIECE(^BQI(90506.1,SIND,0),U,1)
+109 SET @BQIDATA@(BQIDFN,30,"B",$PIECE(^BQI(90506.1,SIND,0),U,1),CT)=""
End DoDot:2
+110 ;
+111 SET IND=0
+112 FOR
SET IND=$ORDER(@BQIGREF@(BQIDFN,IND))
IF IND=""
QUIT
Begin DoDot:2
+113 SET MEAS=0
+114 FOR
SET MEAS=$ORDER(@BQIGREF@(BQIDFN,IND,MEAS))
IF MEAS=""
QUIT
Begin DoDot:3
+115 SET GPMEAS=BQIYR_"_"_MEAS
+116 SET MCT=$ORDER(^BQIPAT(BQIDFN,30,"B",GPMEAS,""))
IF MCT=""
QUIT
+117 SET $PIECE(@BQIDATA@(BQIDFN,30,MCT,0),U,2)=$PIECE(@BQIGREF@(BQIDFN,IND),U,2)
+118 SET $PIECE(@BQIDATA@(BQIDFN,30,MCT,0),U,3)=$PIECE(@BQIGREF@(BQIDFN,IND,MEAS),U,2)
+119 SET $PIECE(@BQIDATA@(BQIDFN,30,MCT,0),U,4)=$PIECE(@BQIGREF@(BQIDFN,IND,MEAS),U,3)
End DoDot:3
End DoDot:2
+120 KILL @BQIGREF
+121 ; reindex the patient record
+122 ;NEW DA,DIK
+123 ;S DA=BQIDFN,DIK="^BQIPAT(" D IX1^DIK
End DoDot:1
+124 ;
+125 KILL ^XTMP("BGP15TAX",$JOB),^XTMP("BGPSNOMEDSUBSET",$JOB)
+126 ;
EXIT ; Set the DATE/TIME GPRA STOPPED
+1 NEW DA
+2 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+3 SET BQIUPD(90508,DA_",",4.05)=$$NOW^XLFDT()
+4 SET BQIUPD(90508,DA_",",4.06)="@"
+5 SET BQIUPD(90508,DA_",",24.05)="@"
+6 DO FILE^DIE("","BQIUPD","ERROR")
+7 KILL BQIUPD
+8 QUIT
+9 ;
FIL(BQGLB,DFN) ;EP - File diagnosis category
+1 NEW DA,IENS,DIC,X,DLAYGO,DINUM,EVN,TXN,TYP,MEVN,TGDATA,CSTAT,RIEN,TXT,TXN,QFL
+2 NEW THCFL
+3 ; Exclude deceased patients
+4 IF $PIECE($GET(^DPT(DFN,.35)),U,1)'=""
QUIT
+5 ; If patient has no active HRNs, quit
+6 ;I '$$HRN^BQIUL1(DFN) Q
+7 ; If patient has no visit in past 3 years, quit
+8 ;I BQDEF'="ASCVD Known",'$$VTHR^BQIUL1(DFN) Q
+9 ;
+10 ; Check on status of current record
+11 SET RIEN=$ORDER(^BQIREG("C",DFN,BQTN,""))
+12 ; If patient is in BQIREG with accepted status, no need to do anything
+13 IF RIEN'=""
SET QFL=0
Begin DoDot:1
+14 SET CSTAT=$PIECE(^BQIREG(RIEN,0),U,3)
+15 IF CSTAT="A"
SET QFL=1
+16 IF CSTAT="N"
IF BQTN'=3
SET QFL=1
End DoDot:1
IF QFL
QUIT
+17 ; if the patient doesn't already exist in the iCare Patient file, add them
+18 IF $GET(^BQIPAT(DFN,0))=""
DO NPT(DFN)
+19 ;
+20 SET DA(1)=DFN
+21 IF '$DATA(^BQIPAT(DFN,20,0))
SET ^BQIPAT(DFN,20,0)="^90507.52P^^"
+22 SET (X,DINUM)=BQTN
SET DIC(0)="L"
SET DIC="^BQIPAT("_DA(1)_",20,"
SET DLAYGO=90507.52
SET DIC("P")=DLAYGO
+23 KILL DO,DD
DO FILE^DICN
+24 SET DA=+Y
IF DA=-1
SET DA=BQTN
+25 SET IENS=$$IENS^DILF(.DA)
+26 SET BQIUPD(90507.52,IENS,.02)=$$NOW^XLFDT()
+27 SET BQIUPD(90507.5,DFN_",",.06)=$$NOW^XLFDT()
+28 DO FILE^DIE("","BQIUPD","ERROR")
+29 KILL BQIUPD
+30 ;
+31 ; Remove previous criteria
+32 DO DEL
+33 ;
+34 ; Add the criteria on why patient met diagnosis category
+35 SET TXT=""
+36 FOR
SET TXT=$ORDER(@BQGLB@(DFN,"CRITERIA",TXT))
IF TXT=""
QUIT
Begin DoDot:1
+37 IF '$DATA(^BQIPAT(DFN,20,BQTN,1,0))
SET ^BQIPAT(DFN,20,BQTN,1,0)="^90507.521^^"
+38 NEW DA
+39 SET DA(2)=DFN
SET DA(1)=BQTN
SET X=TXT
SET DIC(0)="L"
+40 SET DIC="^BQIPAT("_DA(2)_",20,"_DA(1)_",1,"
SET DLAYGO=90507.521
+41 KILL DO,DD
DO FILE^DICN
+42 SET TXN=+Y
+43 IF '$DATA(^BQIPAT(DFN,20,BQTN,1,TXN,1,0))
SET ^BQIPAT(DFN,20,BQTN,1,TXN,1,0)="^90507.5211^^"
+44 FOR TYP="P"
SET EVN=0
Begin DoDot:2
+45 FOR
SET EVN=$ORDER(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN))
IF EVN=""
QUIT
Begin DoDot:3
+46 NEW DA,IENS
+47 SET DA(3)=DFN
SET DA(2)=BQTN
SET DA(1)=TXN
SET DIC(0)="L"
SET DLAYGO=90507.5211
SET X=TYP_EVN
+48 SET DIC="^BQIPAT("_DA(3)_",20,"_DA(2)_",1,"_DA(1)_",1,"
+49 DO ^DIC
+50 SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+51 SET BQIUPD(90507.5211,IENS,.02)=$PIECE(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN),U,1)
+52 IF $PIECE(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN),U,2)'=""
SET BQIUPD(90507.5211,IENS,.03)=$PIECE(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN),U,2)
+53 IF $PIECE(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN),U,3)'=""
SET BQIUPD(90507.5211,IENS,.04)=$PIECE(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN),U,3)
+54 IF $PIECE(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN),U,4)'=""
SET BQIUPD(90507.5211,IENS,.05)=$PIECE(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN),U,4)
+55 DO FILE^DIE("","BQIUPD","ERROR")
+56 KILL BQIUPD
End DoDot:3
End DoDot:2
+57 FOR TYP="V"
SET EVN=""
Begin DoDot:2
+58 FOR
SET EVN=$ORDER(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN))
IF EVN=""
QUIT
Begin DoDot:3
+59 SET MEVN=""
+60 FOR
SET MEVN=$ORDER(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN))
IF MEVN=""
QUIT
Begin DoDot:4
+61 NEW DA,IENS
+62 SET DA(3)=DFN
SET DA(2)=BQTN
SET DA(1)=TXN
SET DIC(0)="L"
SET DLAYGO=90507.5211
SET X=TYP_EVN
+63 SET DIC="^BQIPAT("_DA(3)_",20,"_DA(2)_",1,"_DA(1)_",1,"
+64 DO ^DIC
+65 IF $PIECE(Y,U,3)'=1
Begin DoDot:5
+66 IF Y=-1
KILL DO,DD
DO FILE^DICN
QUIT
+67 IF $PIECE(^BQIPAT(DFN,20,BQTN,1,TXN,1,+Y,0),U,4)'=MEVN
KILL DO,DD
DO FILE^DICN
End DoDot:5
+68 SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+69 SET BQIUPD(90507.5211,IENS,.02)=$PIECE(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,1)
+70 IF $PIECE(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,2)'=""
SET BQIUPD(90507.5211,IENS,.03)=$PIECE(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,2)
+71 IF $PIECE(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,3)'=""
SET BQIUPD(90507.5211,IENS,.04)=$PIECE(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,3)
+72 IF $PIECE(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,4)'=""
SET BQIUPD(90507.5211,IENS,.05)=$PIECE(@BQGLB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,4)
+73 DO FILE^DIE("","BQIUPD","ERROR")
+74 KILL BQIUPD
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+75 ;
+76 KILL @BQGLB@(DFN)
+77 ; Check on status of current record
+78 SET RIEN=$ORDER(^BQIREG("C",DFN,BQTN,""))
+79 ; If no record found, then it's a new record
+80 IF RIEN=""
Begin DoDot:1
+81 ; if patient is in a register, check status to determine "A" else "P"
+82 IF $$REG^BQITDUTL(DFN,BQTN)=1
DO EN^BQITDPRC(.TGDATA,DFN,BQTN,"A",,"SYSTEM UPDATE",8)
QUIT
+83 IF $$REG^BQITDUTL(DFN,BQTN)=2
DO EN^BQITDPRC(.TGDATA,DFN,BQTN,"P",,"SYSTEM UPDATE",8)
QUIT
+84 DO EN^BQITDPRC(.TGDATA,DFN,BQTN,"P",,"SYSTEM UPDATE",5)
End DoDot:1
QUIT
+85 ;
+86 ; If a record was found, check its current status and hierarchy
+87 SET CSTAT=$PIECE(^BQIREG(RIEN,0),U,3)
+88 IF CSTAT="P"
DO RCHK
QUIT
+89 ;
+90 IF CSTAT="V"!(CSTAT="S")
DO EN^BQITDPRC(.TGDATA,DFN,BQTN,"P",,"SYSTEM UPDATE",5)
QUIT
+91 ; Check for new factors, if none, quit
+92 IF '$$CMP^BQITDUTL(DFN,BQTN)
DO DEL^BQITASK
QUIT
+93 DO EN^BQITDPRC(.TGDATA,DFN,BQTN,"P",,"SYSTEM UPDATE",5)
+94 QUIT
+95 ;
NPT(DFN) ;EP - New patient
+1 ; if the patient doesn't already exist in the iCare Patient file, add them
+2 NEW DIC,X,DINUM,DLAYGO
+3 SET (X,DINUM)=DFN
SET DLAYGO=90507.5
SET DIC="^BQIPAT("
SET DIC(0)="L"
SET DIC("P")=DLAYGO
+4 KILL DO,DD
DO FILE^DICN
+5 QUIT
+6 ;
DEL ;EP - Delete criteria
+1 NEW DA,DIK
+2 SET DA(2)=DFN
SET DA(1)=BQTN
SET DA=0
SET DIK="^BQIPAT("_DA(2)_",20,"_DA(1)_",1,"
+3 FOR
SET DA=$ORDER(^BQIPAT(DFN,20,BQTN,1,DA))
IF 'DA
QUIT
DO ^DIK
+4 KILL ^BQIPAT(DFN,20,BQTN,1,"B")
+5 QUIT
+6 ;
RCHK ; Register check
+1 ; if patient is in a register, check status to determine "A" else "P"
+2 IF $$REG^BQITDUTL(DFN,BQTN)=1
DO EN^BQITDPRC(.TGDATA,DFN,BQTN,"A",,"SYSTEM UPDATE",8)
QUIT
+3 QUIT
