BQI25P1.m

BQI25P1 ;GDHS/HCS/ALA-Version 2.5 Patch 1 ; 13 Apr 2016  9:14 AM

 ;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17

 ;

 ;

PRE ;EP

 NEW DA,DIK

 S DIK="^BQI(90506,",DA=0

 F  S DA=$O(^BQI(90506,DA)) Q:'DA  D ^DIK

 S DIK="^BQI(90506.3,",DA=0

 F  S DA=$O(^BQI(90506.3,DA)) Q:'DA  D ^DIK

 S DIK="^BQI(90507.8,",DA=0

 F  S DA=$O(^BQI(90507.8,DA)) Q:'DA  D ^DIK

 S DIK="^BQI(90509.9,",DA=0

 F  S DA=$O(^BQI(90509.9,DA)) Q:'DA  D ^DIK

 S DIK="^BQI(90505.2,",DA=0

 F  S DA=$O(^BQI(90505.2,DA)) Q:'DA  D ^DIK

 ;

 ; Move Accepted CVD Known patients

 K ^XTMP("BQITMP")

 D MOV

 ; Inactivate the 4 current CVD tags

 D IAC

 ;

 NEW DA,DIK

 S DIK="^BQI(90506.2,",DA=0

 F  S DA=$O(^BQI(90506.2,DA)) Q:'DA  D ^DIK

 S DIK="^BQI(90508.5,",DA=0

 F  S DA=$O(^BQI(90508.5,DA)) Q:'DA  D ^DIK

 Q

 ;

MOV ;EP Move Accepted CVD Known to ASCVD Known

 NEW OTAG,NTAG,RIEN,RSTAT,DFN

 S OTAG=6,NTAG=17

 S RIEN=""

 F  S RIEN=$O(^BQIREG("B",OTAG,RIEN)) Q:RIEN=""  D

 . S RSTAT=$P(^BQIREG(RIEN,0),U,3),DFN=$P(^BQIREG(RIEN,0),"^",2)

 . I RSTAT'="A" Q

 . M ^XTMP("BQITMP","REG",RIEN)=^BQIREG(RIEN)

 Q

 ;

IAC ;EP Inactivate CVD

 NEW BQITAG,BQIDFN,MESG

 ; Inactivate the 4 current tags

 F BQITAG=6,7,8,9 S BQIUPD(90506.2,BQITAG_",",.03)=1

 ; Inactivate the Best Practice Prompts

 S N=0 F  S N=$O(^BQI(90508.5,N)) Q:'N  S BQIUPD(90508.5,N_",",.04)=1

 D FILE^DIE("","BQIUPD","ERROR")

 ; Set to NLV (no longer valid, CVD Significant Risk, CVD Highest Risk and CVD At Risk

 F BQITAG=6,7,8,9 D

 . S THCFL=+$P(^BQI(90506.2,BQITAG,0),U,10)

 . S RIEN=""

 . F  S RIEN=$O(^BQIREG("B",BQITAG,RIEN)) Q:RIEN=""  D

 .. S RSTAT=$P(^BQIREG(RIEN,0),U,3),BQIDFN=$P(^BQIREG(RIEN,0),"^",2)

 .. ; If status is Not Accepted or No Longer Valid or Superceded, quit

 .. I RSTAT="N"!(RSTAT="V")!(RSTAT="S") Q

 .. ; if the current status is 'Proposed', move the factors before setting the

 .. ; current status to 'No Longer Valid' or 'Superseded'

 .. I RSTAT="P" D MOV^BQITDPRC(BQIDFN,BQITAG)

 .. S MESG="CVD LOGIC UPDATE"

 .. D EN^BQITDPRC(.TGDATA,BQIDFN,BQITAG,"V",,MESG,3)

 ;

 ; Delete Best Practice Prompts

 S DFN=0

 F  S DFN=$O(^BQIPAT(DFN)) Q:'DFN  K ^BQIPAT(DFN,50)

 ;

NOT ;Send notification if a panel is using one of the CVD tags

 NEW PDZ,PL,DN,DCAT,CT,BTEXT,PLNM

 S PDZ=0 F  S PDZ=$O(^BQICARE(PDZ)) Q:'PDZ  D

 . S PL=0,CT=2 K BTEXT

 . S BTEXT(1,0)="CVD Tags have changed.  You may need to update the following"

 . S BTEXT(2,0)="panels which use CVD Tag in the panel definition."_$C(10)_$C(13)

 . F  S PL=$O(^BQICARE(PDZ,1,PL)) Q:'PL  D

 .. S DN=$O(^BQICARE(PDZ,1,PL,15,"B","DXCAT","")) I DN="" Q

 .. S DCAT=$P(^BQICARE(PDZ,1,PL,15,DN,0),"^",3)

 .. I DCAT'=6,DCAT'=7,DCAT'=8,DCAT'=9 Q

 .. S PLNM=$P(^BQICARE(PDZ,1,PL,0),"^",1)

 .. S CT=CT+1,BTEXT(CT,0)="     Panel:  "_PLNM_$C(10)_$C(13)

 . I CT>2 D ADD^BQINOTF("",PDZ_$C(28),"Correct Panel Definitions",.BTEXT,1)

 Q

 ;

POS ;EP

 ;Set the version number

 NEW DA

 S DA=$O(^BQI(90508,0))

 S BQIUPD(90508,DA_",",.08)="2.5.1.5"

 S BQIUPD(90508,DA_",",.09)="2.5.1.5"

 D FILE^DIE("","BQIUPD","ERROR")

 ;

 D ^BQIATX

 D ^BQITAXXU

 D ^BQIUSRC

 D ^BQIULAY

 ;

 ; Fix if default view is MU

 NEW DZ

 S DZ=0

 F  S DZ=$O(^BQICARE(DZ)) Q:'DZ  D

 . I $$GET1^DIQ(90505,DZ_",",.02,"E")["MU" S BQIUPD(90505,DZ_",",.02)="@"

 I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")

 ;

GLS ;EP Update glossary

 NEW GN,GNM,GSN,BQIUPD

 S GN=0

 F  S GN=$O(^BQI(90509.9,GN)) Q:'GN  D

 . S GNM=$P(^BQI(90509.9,GN,0),U,1)

 . S GSN=$O(^BQI(90508.2,"B",GNM,"")) Q:GSN=""

 . S BQIUPD(90508.2,GSN_",",1)="@"

 . D FILE^DIE("","BQIUPD","ERROR")

 . M ^BQI(90508.2,GSN,1)=^BQI(90509.9,GN,1)

 ;

 ; Set BTPWRPC and BUSARPC into BQIRPC

 NEW IEN,DA,X,DIC,Y

 S DA(1)=$$FIND1^DIC(19,"","B","BQIRPC","","","ERROR"),DIC="^DIC(19,"_DA(1)_",10,",DIC(0)="LMNZ"

 I $G(^DIC(19,DA(1),10,0))="" S ^DIC(19,DA(1),10,0)="^19.01IP^^"

 S X="BTPWRPC"

 D ^DIC I +Y<1 K DO,DD D FILE^DICN

 NEW IEN,DA,X,DIC,Y

 S DA(1)=$$FIND1^DIC(19,"","B","BQIRPC","","","ERROR"),DIC="^DIC(19,"_DA(1)_",10,",DIC(0)="LMNZ"

 I $G(^DIC(19,DA(1),10,0))="" S ^DIC(19,DA(1),10,0)="^19.01IP^^"

 S X="BUSARPC"

 D ^DIC I +Y<1 K DO,DD D FILE^DICN

 ;

 F DA=4,7,25,26 S BQIUP(90506.5,DA_",",.18)=1

 D FILE^DIE("","BQIUP","ERROR")

 ;

 ; Inactivate the 4 current tags

 F BQITAG=6,7,8,9 S BQIUPD(90506.2,BQITAG_",",.03)=1

 F BQITAG=17,18 S BQIUPD(90506.2,BQITAG_",",.03)="@"

 D FILE^DIE("","BQIUPD","ERROR")

 ;

 ;Update any "accepted" CVD Knowns to ASCVD Known

 NEW RIEN,NTAG

 S NTAG=17,RIEN=""

 F  S RIEN=$O(^XMP("BQITMP","REG",RIEN)) Q:RIEN=""  D

 . S BQIUPD(90509,RIEN_",",.01)=NTAG

 . S CF=0 F  S CF=$O(^BQIREG(RIEN,5,CF)) Q:'CF  D

 .. S BQIUPD(90509.5,CF_",",.03)=NTAG

 I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")

 ;

BP ;Removed from HEALTH SUMMARY MAINT ITEM and add new BPs

 D CBP^BQITRUPD

 ;

 NEW NAME,TEXT

 S NAME="Missing ASCVD Risk" D

 . S TEXT(1)="This patient does not have an ASCVD risk assessment documented. Consider"

 . S TEXT(2)="assessing the ASCVD risk at next opportunity."

 . D NON^BQITRUPD(NAME,.TEXT)

 ;

 ;Update Tags and Best Practice Prompts

 NEW ZTDTH,ZTDESC,ZTRTN,ZTIO,ZTSAVE,NOW

 S NOW=$$NOW^XLFDT(),ZTDTH=DT_".19"

 I $$FMDIFF^XLFDT(ZTDTH,NOW,2)<60 S ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT(),,,15)

 S ZTDESC="Update CVD Tags/Best Practice",ZTRTN="TAG^BQI25P1",ZTIO=""

 D ^%ZTLOAD

 K ZTDESC,ZTRTN,ZTIO,ZTDTH,ZTSK

 ;

 Q

 ;

TAG ;EP

 NEW TAG

 F TAG="ASCVD Known","ASCVD At Risk" D EN^BQITASK4(TAG)

 Q

BQI25P1   ;GDHS/HCS/ALA-Version 2.5 Patch 1 ; 13 Apr 2016  9:14 AM

 +1       ;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17

 +2       ;

 +3       ;

PRE       ;EP

 +1        NEW DA,DIK

 +2        SET DIK="^BQI(90506,"

           SET DA=0

 +3        FOR 

               SET DA=$ORDER(^BQI(90506,DA))

               IF 'DA

                   QUIT 

               DO ^DIK

 +4        SET DIK="^BQI(90506.3,"

           SET DA=0

 +5        FOR 

               SET DA=$ORDER(^BQI(90506.3,DA))

               IF 'DA

                   QUIT 

               DO ^DIK

 +6        SET DIK="^BQI(90507.8,"

           SET DA=0

 +7        FOR 

               SET DA=$ORDER(^BQI(90507.8,DA))

               IF 'DA

                   QUIT 

               DO ^DIK

 +8        SET DIK="^BQI(90509.9,"

           SET DA=0

 +9        FOR 

               SET DA=$ORDER(^BQI(90509.9,DA))

               IF 'DA

                   QUIT 

               DO ^DIK

 +10       SET DIK="^BQI(90505.2,"

           SET DA=0

 +11       FOR 

               SET DA=$ORDER(^BQI(90505.2,DA))

               IF 'DA

                   QUIT 

               DO ^DIK

 +12      ;

 +13      ; Move Accepted CVD Known patients

 +14       KILL ^XTMP("BQITMP")

 +15       DO MOV

 +16      ; Inactivate the 4 current CVD tags

 +17       DO IAC

 +18      ;

 +19       NEW DA,DIK

 +20       SET DIK="^BQI(90506.2,"

           SET DA=0

 +21       FOR 

               SET DA=$ORDER(^BQI(90506.2,DA))

               IF 'DA

                   QUIT 

               DO ^DIK

 +22       SET DIK="^BQI(90508.5,"

           SET DA=0

 +23       FOR 

               SET DA=$ORDER(^BQI(90508.5,DA))

               IF 'DA

                   QUIT 

               DO ^DIK

 +24       QUIT 

 +25      ;

MOV       ;EP Move Accepted CVD Known to ASCVD Known

 +1        NEW OTAG,NTAG,RIEN,RSTAT,DFN

 +2        SET OTAG=6

           SET NTAG=17

 +3        SET RIEN=""

 +4        FOR 

               SET RIEN=$ORDER(^BQIREG("B",OTAG,RIEN))

               IF RIEN=""

                   QUIT 

               Begin DoDot:1

 +5                SET RSTAT=$PIECE(^BQIREG(RIEN,0),U,3)

                   SET DFN=$PIECE(^BQIREG(RIEN,0),"^",2)

 +6                IF RSTAT'="A"

                       QUIT 

 +7                MERGE ^XTMP("BQITMP","REG",RIEN)=^BQIREG(RIEN)

               End DoDot:1

 +8        QUIT 

 +9       ;

IAC       ;EP Inactivate CVD

 +1        NEW BQITAG,BQIDFN,MESG

 +2       ; Inactivate the 4 current tags

 +3        FOR BQITAG=6,7,8,9

               SET BQIUPD(90506.2,BQITAG_",",.03)=1

 +4       ; Inactivate the Best Practice Prompts

 +5        SET N=0

           FOR 

               SET N=$ORDER(^BQI(90508.5,N))

               IF 'N

                   QUIT 

               SET BQIUPD(90508.5,N_",",.04)=1

 +6        DO FILE^DIE("","BQIUPD","ERROR")

 +7       ; Set to NLV (no longer valid, CVD Significant Risk, CVD Highest Risk and CVD At Risk

 +8        FOR BQITAG=6,7,8,9

               Begin DoDot:1

 +9                SET THCFL=+$PIECE(^BQI(90506.2,BQITAG,0),U,10)

 +10               SET RIEN=""

 +11               FOR 

                       SET RIEN=$ORDER(^BQIREG("B",BQITAG,RIEN))

                       IF RIEN=""

                           QUIT 

                       Begin DoDot:2

 +12                       SET RSTAT=$PIECE(^BQIREG(RIEN,0),U,3)

                           SET BQIDFN=$PIECE(^BQIREG(RIEN,0),"^",2)

 +13      ; If status is Not Accepted or No Longer Valid or Superceded, quit

 +14                       IF RSTAT="N"!(RSTAT="V")!(RSTAT="S")

                               QUIT 

 +15      ; if the current status is 'Proposed', move the factors before setting the

 +16      ; current status to 'No Longer Valid' or 'Superseded'

 +17                       IF RSTAT="P"

                               DO MOV^BQITDPRC(BQIDFN,BQITAG)

 +18                       SET MESG="CVD LOGIC UPDATE"

 +19                       DO EN^BQITDPRC(.TGDATA,BQIDFN,BQITAG,"V",,MESG,3)

                       End DoDot:2

               End DoDot:1

 +20      ;

 +21      ; Delete Best Practice Prompts

 +22       SET DFN=0

 +23       FOR 

               SET DFN=$ORDER(^BQIPAT(DFN))

               IF 'DFN

                   QUIT 

               KILL ^BQIPAT(DFN,50)

 +24      ;

NOT       ;Send notification if a panel is using one of the CVD tags

 +1        NEW PDZ,PL,DN,DCAT,CT,BTEXT,PLNM

 +2        SET PDZ=0

           FOR 

               SET PDZ=$ORDER(^BQICARE(PDZ))

               IF 'PDZ

                   QUIT 

               Begin DoDot:1

 +3                SET PL=0

                   SET CT=2

                   KILL BTEXT

 +4                SET BTEXT(1,0)="CVD Tags have changed.  You may need to update the following"

 +5                SET BTEXT(2,0)="panels which use CVD Tag in the panel definition."_$CHAR(10)_$CHAR(13)

 +6                FOR 

                       SET PL=$ORDER(^BQICARE(PDZ,1,PL))

                       IF 'PL

                           QUIT 

                       Begin DoDot:2

 +7                        SET DN=$ORDER(^BQICARE(PDZ,1,PL,15,"B","DXCAT",""))

                           IF DN=""

                               QUIT 

 +8                        SET DCAT=$PIECE(^BQICARE(PDZ,1,PL,15,DN,0),"^",3)

 +9                        IF DCAT'=6

                               IF DCAT'=7

                                   IF DCAT'=8

                                       IF DCAT'=9

                                           QUIT 

 +10                       SET PLNM=$PIECE(^BQICARE(PDZ,1,PL,0),"^",1)

 +11                       SET CT=CT+1

                           SET BTEXT(CT,0)="     Panel:  "_PLNM_$CHAR(10)_$CHAR(13)

                       End DoDot:2

 +12               IF CT>2

                       DO ADD^BQINOTF("",PDZ_$CHAR(28),"Correct Panel Definitions",.BTEXT,1)

               End DoDot:1

 +13       QUIT 

 +14      ;

POS       ;EP

 +1       ;Set the version number

 +2        NEW DA

 +3        SET DA=$ORDER(^BQI(90508,0))

 +4        SET BQIUPD(90508,DA_",",.08)="2.5.1.5"

 +5        SET BQIUPD(90508,DA_",",.09)="2.5.1.5"

 +6        DO FILE^DIE("","BQIUPD","ERROR")

 +7       ;

 +8        DO ^BQIATX

 +9        DO ^BQITAXXU

 +10       DO ^BQIUSRC

 +11       DO ^BQIULAY

 +12      ;

 +13      ; Fix if default view is MU

 +14       NEW DZ

 +15       SET DZ=0

 +16       FOR 

               SET DZ=$ORDER(^BQICARE(DZ))

               IF 'DZ

                   QUIT 

               Begin DoDot:1

 +17               IF $$GET1^DIQ(90505,DZ_",",.02,"E")["MU"

                       SET BQIUPD(90505,DZ_",",.02)="@"

               End DoDot:1

 +18       IF $DATA(BQIUPD)

               DO FILE^DIE("","BQIUPD","ERROR")

 +19      ;

GLS       ;EP Update glossary

 +1        NEW GN,GNM,GSN,BQIUPD

 +2        SET GN=0

 +3        FOR 

               SET GN=$ORDER(^BQI(90509.9,GN))

               IF 'GN

                   QUIT 

               Begin DoDot:1

 +4                SET GNM=$PIECE(^BQI(90509.9,GN,0),U,1)

 +5                SET GSN=$ORDER(^BQI(90508.2,"B",GNM,""))

                   IF GSN=""

                       QUIT 

 +6                SET BQIUPD(90508.2,GSN_",",1)="@"

 +7                DO FILE^DIE("","BQIUPD","ERROR")

 +8                MERGE ^BQI(90508.2,GSN,1)=^BQI(90509.9,GN,1)

               End DoDot:1

 +9       ;

 +10      ; Set BTPWRPC and BUSARPC into BQIRPC

 +11       NEW IEN,DA,X,DIC,Y

 +12       SET DA(1)=$$FIND1^DIC(19,"","B","BQIRPC","","","ERROR")

           SET DIC="^DIC(19,"_DA(1)_",10,"

           SET DIC(0)="LMNZ"

 +13       IF $GET(^DIC(19,DA(1),10,0))=""

               SET ^DIC(19,DA(1),10,0)="^19.01IP^^"

 +14       SET X="BTPWRPC"

 +15       DO ^DIC

           IF +Y<1

               KILL DO,DD

               DO FILE^DICN

 +16       NEW IEN,DA,X,DIC,Y

 +17       SET DA(1)=$$FIND1^DIC(19,"","B","BQIRPC","","","ERROR")

           SET DIC="^DIC(19,"_DA(1)_",10,"

           SET DIC(0)="LMNZ"

 +18       IF $GET(^DIC(19,DA(1),10,0))=""

               SET ^DIC(19,DA(1),10,0)="^19.01IP^^"

 +19       SET X="BUSARPC"

 +20       DO ^DIC

           IF +Y<1

               KILL DO,DD

               DO FILE^DICN

 +21      ;

 +22       FOR DA=4,7,25,26

               SET BQIUP(90506.5,DA_",",.18)=1

 +23       DO FILE^DIE("","BQIUP","ERROR")

 +24      ;

 +25      ; Inactivate the 4 current tags

 +26       FOR BQITAG=6,7,8,9

               SET BQIUPD(90506.2,BQITAG_",",.03)=1

 +27       FOR BQITAG=17,18

               SET BQIUPD(90506.2,BQITAG_",",.03)="@"

 +28       DO FILE^DIE("","BQIUPD","ERROR")

 +29      ;

 +30      ;Update any "accepted" CVD Knowns to ASCVD Known

 +31       NEW RIEN,NTAG

 +32       SET NTAG=17

           SET RIEN=""

 +33       FOR 

               SET RIEN=$ORDER(^XMP("BQITMP","REG",RIEN))

               IF RIEN=""

                   QUIT 

               Begin DoDot:1

 +34               SET BQIUPD(90509,RIEN_",",.01)=NTAG

 +35               SET CF=0

                   FOR 

                       SET CF=$ORDER(^BQIREG(RIEN,5,CF))

                       IF 'CF

                           QUIT 

                       Begin DoDot:2

 +36                       SET BQIUPD(90509.5,CF_",",.03)=NTAG

                       End DoDot:2

               End DoDot:1

 +37       IF $DATA(BQIUPD)

               DO FILE^DIE("","BQIUPD","ERROR")

 +38      ;

BP        ;Removed from HEALTH SUMMARY MAINT ITEM and add new BPs

 +1        DO CBP^BQITRUPD

 +2       ;

 +3        NEW NAME,TEXT

 +4        SET NAME="Missing ASCVD Risk"

           Begin DoDot:1

 +5            SET TEXT(1)="This patient does not have an ASCVD risk assessment documented. Consider"

 +6            SET TEXT(2)="assessing the ASCVD risk at next opportunity."

 +7            DO NON^BQITRUPD(NAME,.TEXT)

           End DoDot:1

 +8       ;

 +9       ;Update Tags and Best Practice Prompts

 +10       NEW ZTDTH,ZTDESC,ZTRTN,ZTIO,ZTSAVE,NOW

 +11       SET NOW=$$NOW^XLFDT()

           SET ZTDTH=DT_".19"

 +12       IF $$FMDIFF^XLFDT(ZTDTH,NOW,2)<60

               SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT(),,,15)

 +13       SET ZTDESC="Update CVD Tags/Best Practice"

           SET ZTRTN="TAG^BQI25P1"

           SET ZTIO=""

 +14       DO ^%ZTLOAD

 +15       KILL ZTDESC,ZTRTN,ZTIO,ZTDTH,ZTSK

 +16      ;

 +17       QUIT 

 +18      ;

TAG       ;EP

 +1        NEW TAG

 +2        FOR TAG="ASCVD Known","ASCVD At Risk"

               DO EN^BQITASK4(TAG)

 +3        QUIT