BQITASK.m

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))