BQIFLG.m

BQIFLG ;PRXM/HC/ALA-Get flags for all patients in panels ; 13 Dec 2005  9:28 PM

 ;;2.4;ICARE MANAGEMENT SYSTEM;**2**;Apr 01, 2015;Build 10

 ;

 Q

 ;

FND ;EP - Find all flags for a patient

 ;

 ;Description

 ;  This program should be run nightly to determine all the flags that any patient

 ;  found in the BQICARE file has

 ;Parameters

 ;  PPIEN = Definition internal entry number

 ;  EXEC  = Executable code

 ;  PORD  = Flag order

 ;

 ;  Purge flags older than 7 months

 NEW DFN,FLG,DTM,PRGDT,REC

 S DFN=0,PRGDT=$$DATE^BQIUL1("T-7M")

 F  S DFN=$O(^BQIPAT(DFN)) Q:'DFN  D

 . S FLG=0

 . F  S FLG=$O(^BQIPAT(DFN,10,FLG)) Q:'FLG  D

 .. S DTM=""

 .. F  S DTM=$O(^BQIPAT(DFN,10,FLG,5,"AC",DTM)) Q:DTM=""  D

 ... S REC=""

 ... F  S REC=$O(^BQIPAT(DFN,10,FLG,5,"AC",DTM,REC)) Q:REC=""  D

 .... NEW DA,DIK

 .... S DA(2)=DFN,DA(1)=FLG,DA=REC

 .... S DIK="^BQIPAT("_DA(2)_",10,"_DA(1)_",5," D ^DIK

 ;

 S PORD=""

 F  S PORD=$O(^BQI(90506,"AC",PORD)) Q:PORD=""  D

 . S PPIEN=0

 . F  S PPIEN=$O(^BQI(90506,"AC",PORD,PPIEN)) Q:'PPIEN  D

 .. ; if the definition is inactive, quit

 .. ;Q:$$GET1^DIQ(90506,PPIEN_",",.02,"I")=1

 .. I $P($G(^BQI(90506,PPIEN,0)),"^",2)=1 Q

 .. ; if the definition is not a flag definition, quit

 .. ;Q:$$GET1^DIQ(90506,PPIEN_",",.04,"I")'="A"

 .. I $P($G(^BQI(90506,PPIEN,0)),"^",4)'="A" Q

 .. S EXEC=$$GET1^DIQ(90506,PPIEN_",",2,"E")

 .. S EXEC=$G(^BQI(90506,PPIEN,2)) I EXEC="" Q

 .. ;Q:EXEC=""

 .. ; define time frame for the largest valid range

 .. ;S PARMS("TMFRAME")="T-6M"

 .. S PARMS("TMFRAME")="T-2M"

 .. X EXEC

 .. Q:'$D(@GLREF)

 .. NEW DFN,VIEN

 .. S DFN=""

 .. F  S DFN=$O(@GLREF@(DFN)) Q:DFN=""  D

 ... ;  if the patient is not in the ICARE PATIENT INDEX 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",DIC("P")=DLAYGO

 .... K DO,DD D FILE^DICN

 ... ;  add the flag definition for the patient

 ... NEW DIC,X,DINUM,DLAYGO,DA

 ... S (X,DINUM)=PPIEN,DLAYGO=90507.51,DA(1)=DFN

 ... I '$D(^BQIPAT(DA(1),10,0)) S ^BQIPAT(DA(1),10,0)="^90507.51P^^"

 ... S DIC="^BQIPAT("_DA(1)_",10,",DIC(0)="L"

 ... K DO,DD D FILE^DICN

 ... ;  for each record, if it isn't already in the file, add it as a flag record

 ... S RCIEN=""

 ... F  S RCIEN=$O(@GLREF@(DFN,RCIEN)) Q:RCIEN=""  D

 .... NEW DIC,DA,IENS,NFLG

 .... S DA(2)=DFN,DA(1)=PPIEN,X=RCIEN,NFLG=0

 .... I '$D(^BQIPAT(DA(2),10,DA(1),5,0)) S ^BQIPAT(DA(2),10,DA(1),5,0)="^90507.515^^"

 .... S DIC="^BQIPAT("_DA(2)_",10,"_DA(1)_",5,",DIC(0)="LXZ"

 .... D ^DIC

 .... S (DA,RIEN)=+Y S:$P(Y,U,3)=1 NFLG=1

 .... S IENS=$$IENS^DILF(.DA)

 .... ; set the date of the visit

 .... S BQIUPD(90507.515,IENS,.02)=$P(@GLREF@(DFN,RCIEN),U,2)

 .... S BQIUPD(90507.515,IENS,.04)=$P(@GLREF@(DFN,RCIEN),U,1)

 .... I NFLG S BQIUPD(90507.515,IENS,.03)=$$NOW^XLFDT()

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

 .... K BQIUPD

 .... ;

 .... NEW DIC,DA,DLAYGO,X,DINUM

 .... S DA(3)=DFN,DA(2)=PPIEN,DA(1)=RIEN

 .... I '$D(^BQIPAT(DA(3),10,DA(2),5,DA(1),1,0)) S ^BQIPAT(DA(3),10,DA(2),5,DA(1),1,0)="^90507.5151P^^"

 .... ;  for each user that has this patient in a panel, add a user record so

 .... ;  that each user's action/status for this patient and flag can be recorded

 .... S USR=""

 .... F  S USR=$O(^BQICARE("AB",DFN,USR)) Q:USR=""  D

 ..... S (X,DINUM)=USR,DIC="^BQIPAT("_DA(3)_",10,"_DA(2)_",5,"_DA(1)_",1,"

 ..... S DIC(0)="L",DLAYGO=90507.5151,DIC("P")=DLAYGO

 ..... K DO,DD D FILE^DICN

 ..... S UIEN=+Y Q:UIEN<1

 ..... D FND^BQIFLFLG(USR,DFN)

 ..... ;

 ..... ;  Make sure that Shared users can see the flags as well

 ..... S SHRU=""

 ..... F  S SHRU=$O(^BQICARE("C",SHRU)) Q:SHRU=""  D

 ...... I '$D(^BQICARE("C",SHRU,USR)) Q

 ...... S PLIEN=""

 ...... F  S PLIEN=$O(^BQICARE("C",SHRU,USR,PLIEN)) Q:PLIEN=""  D

 ....... I '$D(^BQICARE(USR,1,PLIEN,40,"B",DFN)) Q

 ....... I $P(^BQICARE(USR,1,PLIEN,40,DFN,0),U,2)="R" Q

 ....... D UPU^BQIFLAG(DFN,SHRU)

 .. K @GLREF

 ;

 S USR=0

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

 . S PLIEN=0

 . F  S PLIEN=$O(^BQICARE(USR,1,PLIEN)) Q:'PLIEN  D CNTP(USR,PLIEN)

 ;

 K Y,X,USR,UIEN,TMFRAME,SSN,SEX,RIEN,PPIEN,PARMS,DOB,DA,AUPNSEX,AUPNPAT

 K AUPNDOD,AUPNDOB,AUPNDAYS,AGE,ABNFL,OWNR,PLIEN,RCIEN,EXEC,GLREF,PORD

 K SHRU

 Q

 ;

CNTP(OWNR,PLIEN) ;EP - Count patients' flags and file the result for panel

 ;

 ;Input

 ;  OWNR  - Owner of the panel

 ;  PLIEN - Panel internal entry number

 ;

 NEW DA,PIENS,DFN,DFN,IENS,CNT,BQIUP

 S DA(1)=OWNR,DA=PLIEN,PIENS=$$IENS^DILF(.DA)

 S DFN=0,CNT=0

 F  S DFN=$O(^BQICARE(OWNR,1,PLIEN,40,DFN)) Q:'DFN  D  Q:CNT

 . ;S DA(2)=OWNR,DA(1)=PLIEN,DA=DFN,IENS=$$IENS^DILF(.DA)

 . ;I $$GET1^DIQ(90505.04,IENS,.02,"I")="R" Q

 . I $P($G(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",2)="R" Q

 . ;S CNT=CNT+$$GET1^DIQ(90505.04,IENS,.08,"I")

 . S CNT=CNT+$P($G(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",8)

 ;

 I CNT>0 S BQIUP(90505.01,PIENS,.12)="Y"

 I CNT=0 S BQIUP(90505.01,PIENS,.12)="N"

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

 Q

BQIFLG    ;PRXM/HC/ALA-Get flags for all patients in panels ; 13 Dec 2005  9:28 PM

 +1       ;;2.4;ICARE MANAGEMENT SYSTEM;**2**;Apr 01, 2015;Build 10

 +2       ;

 +3        QUIT 

 +4       ;

FND       ;EP - Find all flags for a patient

 +1       ;

 +2       ;Description

 +3       ;  This program should be run nightly to determine all the flags that any patient

 +4       ;  found in the BQICARE file has

 +5       ;Parameters

 +6       ;  PPIEN = Definition internal entry number

 +7       ;  EXEC  = Executable code

 +8       ;  PORD  = Flag order

 +9       ;

 +10      ;  Purge flags older than 7 months

 +11       NEW DFN,FLG,DTM,PRGDT,REC

 +12       SET DFN=0

           SET PRGDT=$$DATE^BQIUL1("T-7M")

 +13       FOR 

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

               IF 'DFN

                   QUIT 

               Begin DoDot:1

 +14               SET FLG=0

 +15               FOR 

                       SET FLG=$ORDER(^BQIPAT(DFN,10,FLG))

                       IF 'FLG

                           QUIT 

                       Begin DoDot:2

 +16                       SET DTM=""

 +17                       FOR 

                               SET DTM=$ORDER(^BQIPAT(DFN,10,FLG,5,"AC",DTM))

                               IF DTM=""

                                   QUIT 

                               Begin DoDot:3

 +18                               SET REC=""

 +19                               FOR 

                                       SET REC=$ORDER(^BQIPAT(DFN,10,FLG,5,"AC",DTM,REC))

                                       IF REC=""

                                           QUIT 

                                       Begin DoDot:4

 +20                                       NEW DA,DIK

 +21                                       SET DA(2)=DFN

                                           SET DA(1)=FLG

                                           SET DA=REC

 +22                                       SET DIK="^BQIPAT("_DA(2)_",10,"_DA(1)_",5,"

                                           DO ^DIK

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +23      ;

 +24       SET PORD=""

 +25       FOR 

               SET PORD=$ORDER(^BQI(90506,"AC",PORD))

               IF PORD=""

                   QUIT 

               Begin DoDot:1

 +26               SET PPIEN=0

 +27               FOR 

                       SET PPIEN=$ORDER(^BQI(90506,"AC",PORD,PPIEN))

                       IF 'PPIEN

                           QUIT 

                       Begin DoDot:2

 +28      ; if the definition is inactive, quit

 +29      ;Q:$$GET1^DIQ(90506,PPIEN_",",.02,"I")=1

 +30                       IF $PIECE($GET(^BQI(90506,PPIEN,0)),"^",2)=1

                               QUIT 

 +31      ; if the definition is not a flag definition, quit

 +32      ;Q:$$GET1^DIQ(90506,PPIEN_",",.04,"I")'="A"

 +33                       IF $PIECE($GET(^BQI(90506,PPIEN,0)),"^",4)'="A"

                               QUIT 

 +34                       SET EXEC=$$GET1^DIQ(90506,PPIEN_",",2,"E")

 +35                       SET EXEC=$GET(^BQI(90506,PPIEN,2))

                           IF EXEC=""

                               QUIT 

 +36      ;Q:EXEC=""

 +37      ; define time frame for the largest valid range

 +38      ;S PARMS("TMFRAME")="T-6M"

 +39                       SET PARMS("TMFRAME")="T-2M"

 +40                       XECUTE EXEC

 +41                       IF '$DATA(@GLREF)

                               QUIT 

 +42                       NEW DFN,VIEN

 +43                       SET DFN=""

 +44                       FOR 

                               SET DFN=$ORDER(@GLREF@(DFN))

                               IF DFN=""

                                   QUIT 

                               Begin DoDot:3

 +45      ;  if the patient is not in the ICARE PATIENT INDEX file, add them

 +46                               IF $GET(^BQIPAT(DFN,0))=""

                                       Begin DoDot:4

 +47                                       NEW DIC,X,DINUM,DLAYGO

 +48                                       SET (X,DINUM)=DFN

                                           SET DLAYGO=90507.5

                                           SET DIC="^BQIPAT("

                                           SET DIC(0)="L"

                                           SET DIC("P")=DLAYGO

 +49                                       KILL DO,DD

                                           DO FILE^DICN

                                       End DoDot:4

 +50      ;  add the flag definition for the patient

 +51                               NEW DIC,X,DINUM,DLAYGO,DA

 +52                               SET (X,DINUM)=PPIEN

                                   SET DLAYGO=90507.51

                                   SET DA(1)=DFN

 +53                               IF '$DATA(^BQIPAT(DA(1),10,0))

                                       SET ^BQIPAT(DA(1),10,0)="^90507.51P^^"

 +54                               SET DIC="^BQIPAT("_DA(1)_",10,"

                                   SET DIC(0)="L"

 +55                               KILL DO,DD

                                   DO FILE^DICN

 +56      ;  for each record, if it isn't already in the file, add it as a flag record

 +57                               SET RCIEN=""

 +58                               FOR 

                                       SET RCIEN=$ORDER(@GLREF@(DFN,RCIEN))

                                       IF RCIEN=""

                                           QUIT 

                                       Begin DoDot:4

 +59                                       NEW DIC,DA,IENS,NFLG

 +60                                       SET DA(2)=DFN

                                           SET DA(1)=PPIEN

                                           SET X=RCIEN

                                           SET NFLG=0

 +61                                       IF '$DATA(^BQIPAT(DA(2),10,DA(1),5,0))

                                               SET ^BQIPAT(DA(2),10,DA(1),5,0)="^90507.515^^"

 +62                                       SET DIC="^BQIPAT("_DA(2)_",10,"_DA(1)_",5,"

                                           SET DIC(0)="LXZ"

 +63                                       DO ^DIC

 +64                                       SET (DA,RIEN)=+Y

                                           IF $PIECE(Y,U,3)=1

                                               SET NFLG=1

 +65                                       SET IENS=$$IENS^DILF(.DA)

 +66      ; set the date of the visit

 +67                                       SET BQIUPD(90507.515,IENS,.02)=$PIECE(@GLREF@(DFN,RCIEN),U,2)

 +68                                       SET BQIUPD(90507.515,IENS,.04)=$PIECE(@GLREF@(DFN,RCIEN),U,1)

 +69                                       IF NFLG

                                               SET BQIUPD(90507.515,IENS,.03)=$$NOW^XLFDT()

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

 +71                                       KILL BQIUPD

 +72      ;

 +73                                       NEW DIC,DA,DLAYGO,X,DINUM

 +74                                       SET DA(3)=DFN

                                           SET DA(2)=PPIEN

                                           SET DA(1)=RIEN

 +75                                       IF '$DATA(^BQIPAT(DA(3),10,DA(2),5,DA(1),1,0))

                                               SET ^BQIPAT(DA(3),10,DA(2),5,DA(1),1,0)="^90507.5151P^^"

 +76      ;  for each user that has this patient in a panel, add a user record so

 +77      ;  that each user's action/status for this patient and flag can be recorded

 +78                                       SET USR=""

 +79                                       FOR 

                                               SET USR=$ORDER(^BQICARE("AB",DFN,USR))

                                               IF USR=""

                                                   QUIT 

                                               Begin DoDot:5

 +80                                               SET (X,DINUM)=USR

                                                   SET DIC="^BQIPAT("_DA(3)_",10,"_DA(2)_",5,"_DA(1)_",1,"

 +81                                               SET DIC(0)="L"

                                                   SET DLAYGO=90507.5151

                                                   SET DIC("P")=DLAYGO

 +82                                               KILL DO,DD

                                                   DO FILE^DICN

 +83                                               SET UIEN=+Y

                                                   IF UIEN<1

                                                       QUIT 

 +84                                               DO FND^BQIFLFLG(USR,DFN)

 +85      ;

 +86      ;  Make sure that Shared users can see the flags as well

 +87                                               SET SHRU=""

 +88                                               FOR 

                                                       SET SHRU=$ORDER(^BQICARE("C",SHRU))

                                                       IF SHRU=""

                                                           QUIT 

                                                       Begin DoDot:6

 +89                                                       IF '$DATA(^BQICARE("C",SHRU,USR))

                                                               QUIT 

 +90                                                       SET PLIEN=""

 +91                                                       FOR 

                                                               SET PLIEN=$ORDER(^BQICARE("C",SHRU,USR,PLIEN))

                                                               IF PLIEN=""

                                                                   QUIT 

                                                               Begin DoDot:7

 +92                                                               IF '$DATA(^BQICARE(USR,1,PLIEN,40,"B",DFN))

                                                                       QUIT 

 +93                                                               IF $PIECE(^BQICARE(USR,1,PLIEN,40,DFN,0),U,2)="R"

                                                                       QUIT 

 +94                                                               DO UPU^BQIFLAG(DFN,SHRU)

                                                               End DoDot:7

                                                       End DoDot:6

                                               End DoDot:5

                                       End DoDot:4

                               End DoDot:3

 +95                       KILL @GLREF

                       End DoDot:2

               End DoDot:1

 +96      ;

 +97       SET USR=0

 +98       FOR 

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

               IF 'USR

                   QUIT 

               Begin DoDot:1

 +99               SET PLIEN=0

 +100              FOR 

                       SET PLIEN=$ORDER(^BQICARE(USR,1,PLIEN))

                       IF 'PLIEN

                           QUIT 

                       DO CNTP(USR,PLIEN)

               End DoDot:1

 +101     ;

 +102      KILL Y,X,USR,UIEN,TMFRAME,SSN,SEX,RIEN,PPIEN,PARMS,DOB,DA,AUPNSEX,AUPNPAT

 +103      KILL AUPNDOD,AUPNDOB,AUPNDAYS,AGE,ABNFL,OWNR,PLIEN,RCIEN,EXEC,GLREF,PORD

 +104      KILL SHRU

 +105      QUIT 

 +106     ;

CNTP(OWNR,PLIEN) ;EP - Count patients' flags and file the result for panel

 +1       ;

 +2       ;Input

 +3       ;  OWNR  - Owner of the panel

 +4       ;  PLIEN - Panel internal entry number

 +5       ;

 +6        NEW DA,PIENS,DFN,DFN,IENS,CNT,BQIUP

 +7        SET DA(1)=OWNR

           SET DA=PLIEN

           SET PIENS=$$IENS^DILF(.DA)

 +8        SET DFN=0

           SET CNT=0

 +9        FOR 

               SET DFN=$ORDER(^BQICARE(OWNR,1,PLIEN,40,DFN))

               IF 'DFN

                   QUIT 

               Begin DoDot:1

 +10      ;S DA(2)=OWNR,DA(1)=PLIEN,DA=DFN,IENS=$$IENS^DILF(.DA)

 +11      ;I $$GET1^DIQ(90505.04,IENS,.02,"I")="R" Q

 +12               IF $PIECE($GET(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",2)="R"

                       QUIT 

 +13      ;S CNT=CNT+$$GET1^DIQ(90505.04,IENS,.08,"I")

 +14               SET CNT=CNT+$PIECE($GET(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",8)

               End DoDot:1

               IF CNT

                   QUIT 

 +15      ;

 +16       IF CNT>0

               SET BQIUP(90505.01,PIENS,.12)="Y"

 +17       IF CNT=0

               SET BQIUP(90505.01,PIENS,.12)="N"

 +18       DO FILE^DIE("I","BQIUP")

 +19       QUIT