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
