BQI1POJB ;PRXM/HC/ALA-Ver 1.0 Post Install Task Job ; 02 Mar 2006 9:52 AM
;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
Q
;
ENT ;EP - Entry point for all tagging
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQI1POJB"
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
D FLG
D DXC
D GPR
;
NEW DIC,DIE,DR,DA
S DIC="^BQI(90508,",DA=$O(^BQI(90508,0))
I 'DA Q
S DR=".1///^S X=""@""",DIE=DIC D ^DIE
K INSTALL,UID
Q
;
FLG ; Entry point to tag all users with flags
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
I $G(DT)="" D DT^DICRW
; Set the DATE/TIME FLAG STARTED field
NEW DIC,DIE,DR,DA
S DIC="^BQI(90508,",DA=$O(^BQI(90508,0))
I 'DA Q
S DR=".02///^S X="_$$NOW^XLFDT(),DIE=DIC D ^DIE
;
; Find all flags for patients
S INSTALL=1
D FND^BQIFLG
;
; Set the DATE/TIME FLAG STOPPED field
NEW DIC,DIE,DR,DA
S DIC="^BQI(90508,",DA=$O(^BQI(90508,0))
I 'DA Q
S DR=".03///^S X="_$$NOW^XLFDT(),DIE=DIC D ^DIE
Q
;
DXC ; 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
; BQGLBB - 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 DIC,DIE,DR,DA
S DIC="^BQI(90508,",DA=$O(^BQI(90508,0)) I 'DA Q
S DR=".06///^S X="_$$NOW^XLFDT(),DIE=DIC D ^DIE
;
NEW BQTN,BQDEF,BQORD
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
.. ; If the category is a subdefinition, ignore it
.. I $$GET1^DIQ(90506.2,BQTN_",",.05,"I")=1 Q
.. S BQDEF=$$GET1^DIQ(90506.2,BQTN_",",.01,"E")
.. S BQEXEC=$$GET1^DIQ(90506.2,BQTN_",",1,"E")
.. S BQPRG=$$GET1^DIQ(90506.2,BQTN_",",.04,"E")
.. ;
.. ; Set the taxonomy array from the file definition
.. S BQREF="BQIRY" K @BQREF
.. D ARY^BQITUTL(BQDEF,BQREF)
.. S BQGLBB=$NA(^TMP("BQIPOP",UID))
.. K @BQGLBB
.. ;
.. ; Call the populate category code
.. S PRGM="POP^"_BQPRG_"(BQREF,BQGLBB)"
.. D @PRGM
.. ;
.. ; File the returned patients
.. S DFN=0
.. F S DFN=$O(@BQGLBB@(DFN)) Q:DFN="" D FIL(BQGLBB)
.. Q
;
K @BQGLBB,AGE,BQEXEC,BQDEF,BQPRG,@BQREF,BQREF,BQGLBB,DFN,PRGM
K SEX,TXDXCN,TXDXCT,TXT,Y
;
; Set the DATE/TIME DXN CATEGORY STOPPED field
NEW DIC,DIE,DR,DA
S DIC="^BQI(90508,",DA=$O(^BQI(90508,0)) I 'DA Q
S DR=".07///^S X="_$$NOW^XLFDT(),DIE=DIC D ^DIE
Q
;
GPR ; 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
NEW DIC,DIE,DR,DA
;
; Set the DATE/TIME GPRA STARTED field
S DIC="^BQI(90508,",DA=$O(^BQI(90508,0)) I 'DA Q
S DR=".04///^S X="_$$NOW^XLFDT(),DIE=DIC D ^DIE
;
NEW DFN
S BQIGREF=$NA(^TMP("BQIGPRA",UID))
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
S X=0 F S X=$O(@BQIINDG@("GPRA",1,X)) Q:X'=+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)
;
; For every patient in the database, call the GPRA API
S BQIDFN=0
F S BQIDFN=$O(^AUPNPAT(BQIDFN)) Q:'BQIDFN D
. ; 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 3 years, quit
. I '$$VTHR^BQIUL1(BQIDFN) Q
. ;
. D @("BQI^"_BQIROU_"(BQIDFN,.BQIGREF)")
. ;
. ; if the patient doesn't already exist in the iCare Patient file, add them
. I $G(^BQIPAT(BQIDFN,0))="" D
.. NEW DIC,X,DINUM,DLAYGO
.. S (X,DINUM)=BQIDFN,DLAYGO=90507.5,DIC="^BQIPAT(",DIC(0)="L"
.. K DO,DD D FILE^DICN
. ; Remove any previous GPRA data
. K @BQIDATA@(BQIDFN,30)
. S @BQIDATA@(BQIDFN,30,0)="^90507.53^^"
. ;
. ; if the patient doesn't meet any GPRA logic, quit
. I '$D(@BQIGREF@(BQIDFN)) Q
. ;
. ; 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
;
EXIT ; Set the DATE/TIME GPRA STOPPED
NEW DIC,DIE,DR,DA
S DIC="^BQI(90508,",DA=$O(^BQI(90508,0)) I 'DA Q
S DR=".05///^S X="_$$NOW^XLFDT(),DIE=DIC D ^DIE
Q
;
FIL(BQGLBB) ;EP - File diagnosis category
NEW DA,IENS,DIC,X,DLAYGO,DINUM,EVN,TXN,TYP
; Exclude deceased patients
I $P($G(^DPT(DFN,.35)),U,1)'="" Q
; if the patient doesn't already exist in the iCare Patient file, add them
I $G(^BQIPAT(DFN,0))="" D
. NEW DIC,X,DINUM,DLAYGO
. S (X,DINUM)=DFN,DLAYGO=90507.5,DIC="^BQIPAT(",DIC(0)="L"
. K DO,DD D FILE^DICN
;
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
K DO,DD D FILE^DICN
S DA=+Y,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
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")
;
; Add the criteria on why patient met diagnosis category
S TXT=""
F S TXT=$O(@BQGLBB@(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="" D
.. F S EVN=$O(@BQGLBB@(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(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN),U,1)
... I $P(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN),U,2)'="" S BQIUPD(90507.5211,IENS,.03)=$P(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN),U,2)
... I $P(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN),U,3)'="" S BQIUPD(90507.5211,IENS,.04)=$P(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN),U,3)
... I $P(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN),U,4)'="" S BQIUPD(90507.5211,IENS,.05)=$P(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN),U,4)
... D FILE^DIE("","BQIUPD","ERROR")
... K BQIUPD
. F TYP="V" S EVN="" D
.. F S EVN=$O(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN)) Q:EVN="" D
... S MEVN=""
... F S MEVN=$O(@BQGLBB@(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(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,1)
.... I $P(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,2)'="" S BQIUPD(90507.5211,IENS,.03)=$P(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,2)
.... I $P(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,3)'="" S BQIUPD(90507.5211,IENS,.04)=$P(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,3)
.... I $P(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,4)'="" S BQIUPD(90507.5211,IENS,.05)=$P(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,4)
.... D FILE^DIE("","BQIUPD","ERROR")
.... K BQIUPD
Q
;
ERR ; Error trapping
S BQIUPD(90508,"1,",.1)="@"
S BQIUPD(90508,"1,",.14)="@"
D FILE^DIE("","BQIUPD","ERROR")
D ^%ZTER
Q
BQI1POJB ;PRXM/HC/ALA-Ver 1.0 Post Install Task Job ; 02 Mar 2006 9:52 AM
+1 ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
+2 QUIT
+3 ;
ENT ;EP - Entry point for all tagging
+1 ;
+2 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQI1POJB"
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 DO FLG
+5 DO DXC
+6 DO GPR
+7 ;
+8 NEW DIC,DIE,DR,DA
+9 SET DIC="^BQI(90508,"
SET DA=$ORDER(^BQI(90508,0))
+10 IF 'DA
QUIT
+11 SET DR=".1///^S X=""@"""
SET DIE=DIC
DO ^DIE
+12 KILL INSTALL,UID
+13 QUIT
+14 ;
FLG ; Entry point to tag all users with flags
+1 ;
+2 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
+3 IF $GET(DT)=""
DO DT^DICRW
+4 ; Set the DATE/TIME FLAG STARTED field
+5 NEW DIC,DIE,DR,DA
+6 SET DIC="^BQI(90508,"
SET DA=$ORDER(^BQI(90508,0))
+7 IF 'DA
QUIT
+8 SET DR=".02///^S X="_$$NOW^XLFDT()
SET DIE=DIC
DO ^DIE
+9 ;
+10 ; Find all flags for patients
+11 SET INSTALL=1
+12 DO FND^BQIFLG
+13 ;
+14 ; Set the DATE/TIME FLAG STOPPED field
+15 NEW DIC,DIE,DR,DA
+16 SET DIC="^BQI(90508,"
SET DA=$ORDER(^BQI(90508,0))
+17 IF 'DA
QUIT
+18 SET DR=".03///^S X="_$$NOW^XLFDT()
SET DIE=DIC
DO ^DIE
+19 QUIT
+20 ;
DXC ; 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 ; BQGLBB - 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 ; Set the DATE/TIME DXN CATEGORY STARTED field
+14 NEW DIC,DIE,DR,DA
+15 SET DIC="^BQI(90508,"
SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+16 SET DR=".06///^S X="_$$NOW^XLFDT()
SET DIE=DIC
DO ^DIE
+17 ;
+18 NEW BQTN,BQDEF,BQORD
+19 SET BQORD=""
+20 FOR
SET BQORD=$ORDER(^BQI(90506.2,"AC",BQORD))
IF BQORD=""
QUIT
Begin DoDot:1
+21 SET BQTN=0
+22 FOR
SET BQTN=$ORDER(^BQI(90506.2,"AC",BQORD,BQTN))
IF 'BQTN
QUIT
Begin DoDot:2
+23 ; If the category is marked as inactive, ignore it
+24 IF $$GET1^DIQ(90506.2,BQTN_",",.03,"I")
QUIT
+25 ; If the category is a subdefinition, ignore it
+26 IF $$GET1^DIQ(90506.2,BQTN_",",.05,"I")=1
QUIT
+27 SET BQDEF=$$GET1^DIQ(90506.2,BQTN_",",.01,"E")
+28 SET BQEXEC=$$GET1^DIQ(90506.2,BQTN_",",1,"E")
+29 SET BQPRG=$$GET1^DIQ(90506.2,BQTN_",",.04,"E")
+30 ;
+31 ; Set the taxonomy array from the file definition
+32 SET BQREF="BQIRY"
KILL @BQREF
+33 DO ARY^BQITUTL(BQDEF,BQREF)
+34 SET BQGLBB=$NAME(^TMP("BQIPOP",UID))
+35 KILL @BQGLBB
+36 ;
+37 ; Call the populate category code
+38 SET PRGM="POP^"_BQPRG_"(BQREF,BQGLBB)"
+39 DO @PRGM
+40 ;
+41 ; File the returned patients
+42 SET DFN=0
+43 FOR
SET DFN=$ORDER(@BQGLBB@(DFN))
IF DFN=""
QUIT
DO FIL(BQGLBB)
+44 QUIT
End DoDot:2
End DoDot:1
+45 ;
+46 KILL @BQGLBB,AGE,BQEXEC,BQDEF,BQPRG,@BQREF,BQREF,BQGLBB,DFN,PRGM
+47 KILL SEX,TXDXCN,TXDXCT,TXT,Y
+48 ;
+49 ; Set the DATE/TIME DXN CATEGORY STOPPED field
+50 NEW DIC,DIE,DR,DA
+51 SET DIC="^BQI(90508,"
SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+52 SET DR=".07///^S X="_$$NOW^XLFDT()
SET DIE=DIC
DO ^DIE
+53 QUIT
+54 ;
GPR ; 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
+11 NEW DIC,DIE,DR,DA
+12 ;
+13 ; Set the DATE/TIME GPRA STARTED field
+14 SET DIC="^BQI(90508,"
SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+15 SET DR=".04///^S X="_$$NOW^XLFDT()
SET DIE=DIC
DO ^DIE
+16 ;
+17 NEW DFN
+18 SET BQIGREF=$NAME(^TMP("BQIGPRA",UID))
+19 KILL @BQIGREF
+20 SET BQIDATA=$NAME(^BQIPAT)
+21 ;
+22 ; Initialize data
+23 DO INP^BQINIGHT
+24 ; If the routine is not defined, quit
+25 IF $GET(BQIROU)=""
GOTO EXIT
+26 ;
+27 ; If the tag is not defined, quit
+28 IF $TEXT(@("BQI^"_BQIROU))=""
GOTO EXIT
+29 ;
+30 ; Initialize GPRA variables
+31 SET X=0
FOR
SET X=$ORDER(@BQIINDG@("GPRA",1,X))
IF X'=+X
QUIT
SET BGPIND(X)=""
+32 ;
+33 ; Define the time frame for the patient
+34 SET BGPBD=$$DATE^BQIUL1("T-12M")
SET BGPED=DT
+35 SET BGPBBD="300"_$EXTRACT(BGPBD,4,7)
SET BGPBED="300"_$EXTRACT(BGPED,4,7)
+36 SET BGPPBD=$$DATE^BQIUL1("T-24M")
SET BGPPED=$$DATE^BQIUL1("T-12M")
+37 SET BGPPER=$EXTRACT($$DT^XLFDT(),1,3)_"0000"
+38 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
)
+39 SET BGPRTYPE=4
SET BGPRPT=4
+40 SET BGP3YE=$$FMADD^XLFDT(BGPED,-1096)
+41 SET BGPP3YE=$$FMADD^XLFDT(BGPPED,-1096)
+42 SET BGPB3YE=$$FMADD^XLFDT(BGPBED,-1096)
+43 ;
+44 ; For every patient in the database, call the GPRA API
+45 SET BQIDFN=0
+46 FOR
SET BQIDFN=$ORDER(^AUPNPAT(BQIDFN))
IF 'BQIDFN
QUIT
Begin DoDot:1
+47 ; If patient is deceased, don't calculate
+48 IF $PIECE($GET(^DPT(BQIDFN,.35)),U,1)'=""
QUIT
+49 ; If patient has no active HRNs, quit
+50 IF '$$HRN^BQIUL1(BQIDFN)
QUIT
+51 ; If patient has no visits in 3 years, quit
+52 IF '$$VTHR^BQIUL1(BQIDFN)
QUIT
+53 ;
+54 DO @("BQI^"_BQIROU_"(BQIDFN,.BQIGREF)")
+55 ;
+56 ; if the patient doesn't already exist in the iCare Patient file, add them
+57 IF $GET(^BQIPAT(BQIDFN,0))=""
Begin DoDot:2
+58 NEW DIC,X,DINUM,DLAYGO
+59 SET (X,DINUM)=BQIDFN
SET DLAYGO=90507.5
SET DIC="^BQIPAT("
SET DIC(0)="L"
+60 KILL DO,DD
DO FILE^DICN
End DoDot:2
+61 ; Remove any previous GPRA data
+62 KILL @BQIDATA@(BQIDFN,30)
+63 SET @BQIDATA@(BQIDFN,30,0)="^90507.53^^"
+64 ;
+65 ; if the patient doesn't meet any GPRA logic, quit
+66 IF '$DATA(@BQIGREF@(BQIDFN))
QUIT
+67 ;
+68 ; set the year of the GPRA and the begin/end dates
+69 SET BQIPUP(90507.5,BQIDFN_",",.02)=BQIYR
+70 SET BQIPUP(90507.5,BQIDFN_",",.03)=BGPBD
+71 SET BQIPUP(90507.5,BQIDFN_",",.04)=BGPED
+72 SET BQIPUP(90507.5,BQIDFN_",",.05)=$$NOW^XLFDT()
+73 DO FILE^DIE("","BQIPUP","ERROR")
+74 KILL BQIPUP
+75 ;
+76 ; initialize the summary indicators for the patient
+77 SET CT=0
SET SIND=""
+78 FOR
SET SIND=$ORDER(^BQI(90506.1,"AC","G",SIND))
IF SIND=""
QUIT
Begin DoDot:2
+79 SET CT=CT+1
+80 IF $PIECE(^BQI(90506.1,SIND,0),U,10)=1
QUIT
+81 SET @BQIDATA@(BQIDFN,30,CT,0)=$PIECE(^BQI(90506.1,SIND,0),U,1)
+82 SET @BQIDATA@(BQIDFN,30,"B",$PIECE(^BQI(90506.1,SIND,0),U,1),CT)=""
End DoDot:2
+83 ;
+84 SET IND=0
+85 FOR
SET IND=$ORDER(@BQIGREF@(BQIDFN,IND))
IF IND=""
QUIT
Begin DoDot:2
+86 SET MEAS=0
+87 FOR
SET MEAS=$ORDER(@BQIGREF@(BQIDFN,IND,MEAS))
IF MEAS=""
QUIT
Begin DoDot:3
+88 SET GPMEAS=BQIYR_"_"_MEAS
+89 SET MCT=$ORDER(^BQIPAT(BQIDFN,30,"B",GPMEAS,""))
IF MCT=""
QUIT
+90 SET $PIECE(@BQIDATA@(BQIDFN,30,MCT,0),U,2)=$PIECE(@BQIGREF@(BQIDFN,IND),U,2)
+91 SET $PIECE(@BQIDATA@(BQIDFN,30,MCT,0),U,3)=$PIECE(@BQIGREF@(BQIDFN,IND,MEAS),U,2)
+92 SET $PIECE(@BQIDATA@(BQIDFN,30,MCT,0),U,4)=$PIECE(@BQIGREF@(BQIDFN,IND,MEAS),U,3)
End DoDot:3
End DoDot:2
+93 KILL @BQIGREF
+94 ; reindex the patient record
+95 NEW DA,DIK
+96 SET DA=BQIDFN
SET DIK="^BQIPAT("
DO IX1^DIK
End DoDot:1
+97 ;
EXIT ; Set the DATE/TIME GPRA STOPPED
+1 NEW DIC,DIE,DR,DA
+2 SET DIC="^BQI(90508,"
SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+3 SET DR=".05///^S X="_$$NOW^XLFDT()
SET DIE=DIC
DO ^DIE
+4 QUIT
+5 ;
FIL(BQGLBB) ;EP - File diagnosis category
+1 NEW DA,IENS,DIC,X,DLAYGO,DINUM,EVN,TXN,TYP
+2 ; Exclude deceased patients
+3 IF $PIECE($GET(^DPT(DFN,.35)),U,1)'=""
QUIT
+4 ; if the patient doesn't already exist in the iCare Patient file, add them
+5 IF $GET(^BQIPAT(DFN,0))=""
Begin DoDot:1
+6 NEW DIC,X,DINUM,DLAYGO
+7 SET (X,DINUM)=DFN
SET DLAYGO=90507.5
SET DIC="^BQIPAT("
SET DIC(0)="L"
+8 KILL DO,DD
DO FILE^DICN
End DoDot:1
+9 ;
+10 SET DA(1)=DFN
+11 IF '$DATA(^BQIPAT(DFN,20,0))
SET ^BQIPAT(DFN,20,0)="^90507.52P^^"
+12 SET (X,DINUM)=BQTN
SET DIC(0)="L"
SET DIC="^BQIPAT("_DA(1)_",20,"
SET DLAYGO=90507.52
+13 KILL DO,DD
DO FILE^DICN
+14 SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+15 SET BQIUPD(90507.52,IENS,.02)=$$NOW^XLFDT()
+16 SET BQIUPD(90507.5,DFN_",",.06)=$$NOW^XLFDT()
+17 DO FILE^DIE("","BQIUPD","ERROR")
+18 KILL BQIUPD
+19 ;
+20 ; Remove previous criteria
+21 NEW DA,DIK
+22 SET DA(2)=DFN
SET DA(1)=BQTN
SET DA=0
SET DIK="^BQIPAT("_DA(2)_",20,"_DA(1)_",1,"
+23 FOR
SET DA=$ORDER(^BQIPAT(DFN,20,BQTN,1,DA))
IF 'DA
QUIT
DO ^DIK
+24 KILL ^BQIPAT(DFN,20,BQTN,1,"B")
+25 ;
+26 ; Add the criteria on why patient met diagnosis category
+27 SET TXT=""
+28 FOR
SET TXT=$ORDER(@BQGLBB@(DFN,"CRITERIA",TXT))
IF TXT=""
QUIT
Begin DoDot:1
+29 IF '$DATA(^BQIPAT(DFN,20,BQTN,1,0))
SET ^BQIPAT(DFN,20,BQTN,1,0)="^90507.521^^"
+30 NEW DA
+31 SET DA(2)=DFN
SET DA(1)=BQTN
SET X=TXT
SET DIC(0)="L"
+32 SET DIC="^BQIPAT("_DA(2)_",20,"_DA(1)_",1,"
SET DLAYGO=90507.521
+33 KILL DO,DD
DO FILE^DICN
+34 SET TXN=+Y
+35 IF '$DATA(^BQIPAT(DFN,20,BQTN,1,TXN,1,0))
SET ^BQIPAT(DFN,20,BQTN,1,TXN,1,0)="^90507.5211^^"
+36 FOR TYP="P"
SET EVN=""
Begin DoDot:2
+37 FOR
SET EVN=$ORDER(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN))
IF EVN=""
QUIT
Begin DoDot:3
+38 NEW DA,IENS
+39 SET DA(3)=DFN
SET DA(2)=BQTN
SET DA(1)=TXN
SET DIC(0)="L"
SET DLAYGO=90507.5211
SET X=TYP_EVN
+40 SET DIC="^BQIPAT("_DA(3)_",20,"_DA(2)_",1,"_DA(1)_",1,"
+41 DO ^DIC
+42 SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+43 SET BQIUPD(90507.5211,IENS,.02)=$PIECE(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN),U,1)
+44 IF $PIECE(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN),U,2)'=""
SET BQIUPD(90507.5211,IENS,.03)=$PIECE(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN),U,2)
+45 IF $PIECE(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN),U,3)'=""
SET BQIUPD(90507.5211,IENS,.04)=$PIECE(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN),U,3)
+46 IF $PIECE(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN),U,4)'=""
SET BQIUPD(90507.5211,IENS,.05)=$PIECE(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN),U,4)
+47 DO FILE^DIE("","BQIUPD","ERROR")
+48 KILL BQIUPD
End DoDot:3
End DoDot:2
+49 FOR TYP="V"
SET EVN=""
Begin DoDot:2
+50 FOR
SET EVN=$ORDER(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN))
IF EVN=""
QUIT
Begin DoDot:3
+51 SET MEVN=""
+52 FOR
SET MEVN=$ORDER(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN))
IF MEVN=""
QUIT
Begin DoDot:4
+53 NEW DA,IENS
+54 SET DA(3)=DFN
SET DA(2)=BQTN
SET DA(1)=TXN
SET DIC(0)="L"
SET DLAYGO=90507.5211
SET X=TYP_EVN
+55 SET DIC="^BQIPAT("_DA(3)_",20,"_DA(2)_",1,"_DA(1)_",1,"
+56 DO ^DIC
+57 IF $PIECE(Y,U,3)'=1
Begin DoDot:5
+58 IF Y=-1
KILL DO,DD
DO FILE^DICN
QUIT
+59 IF $PIECE(^BQIPAT(DFN,20,BQTN,1,TXN,1,+Y,0),U,4)'=MEVN
KILL DO,DD
DO FILE^DICN
End DoDot:5
+60 SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+61 SET BQIUPD(90507.5211,IENS,.02)=$PIECE(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,1)
+62 IF $PIECE(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,2)'=""
SET BQIUPD(90507.5211,IENS,.03)=$PIECE(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,2)
+63 IF $PIECE(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,3)'=""
SET BQIUPD(90507.5211,IENS,.04)=$PIECE(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,3)
+64 IF $PIECE(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,4)'=""
SET BQIUPD(90507.5211,IENS,.05)=$PIECE(@BQGLBB@(DFN,"CRITERIA",TXT,TYP,EVN,MEVN),U,4)
+65 DO FILE^DIE("","BQIUPD","ERROR")
+66 KILL BQIUPD
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+67 QUIT
+68 ;
ERR ; Error trapping
+1 SET BQIUPD(90508,"1,",.1)="@"
+2 SET BQIUPD(90508,"1,",.14)="@"
+3 DO FILE^DIE("","BQIUPD","ERROR")
+4 DO ^%ZTER
+5 QUIT
