BQITRMT ;PRXM/HC/ALA - Find Treatment Prompts ; 24 Apr 2007 12:29 PM
;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17
Q
;
EN ;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
D POP
Q
;
POP ; Find all Treatment Prompts for CVD tagged patients
; Parameters
; BQTDN - Tag IEN
; PRI - Treatment priority for the tag
; BQTIEN - Treatment IEN
; BQIDFN - Patient IEN
;
NEW BQTDN,BQRIEN
S BQTDN=""
F S BQTDN=$O(^BQI(90508.5,"AD",BQTDN)) Q:BQTDN="" D
. ;
. ; For every patient with this tag
. S BQRIEN=""
. F S BQRIEN=$O(^BQIREG("B",BQTDN,BQRIEN)) Q:BQRIEN="" D
.. S BQIDFN=$P(^BQIREG(BQRIEN,0),U,2),STAT=$P(^(0),U,3)
.. ; Remove treatment prompt
.. D DEL(BQIDFN)
.. ; If the tag status is not an active status, quit
.. I '$$ACST^BQITDUTL(STAT) Q
.. ; If no active HRNS, quit
.. I '$$HRN^BQIUL1(BQIDFN) Q
.. ; If no visit in last 3 years, quit
.. ;I '$$VTHR^BQIUL1(BQIDFN) Q
.. ; Set the date/time last updated
.. I $G(^BQIPAT(BQIDFN,0))'="" S $P(^BQIPAT(BQIDFN,0),U,7)=$$NOW^XLFDT()
.. ;
.. S PRI=""
.. F S PRI=$O(^BQI(90508.5,"AD",BQTDN,PRI)) Q:PRI="" D
... S BQTIEN=""
... F S BQTIEN=$O(^BQI(90508.5,"AD",BQTDN,PRI,BQTIEN)) Q:BQTIEN="" D
.... I $P(^BQI(90508.5,BQTIEN,0),U,4)=1 Q
.... ; Set the treatment remarks into array
.... K BQIRMK
.... S BK=0
.... F S BK=$O(^BQI(90508.5,BQTIEN,1,BK)) Q:'BK S BQIRMK(BK)=^BQI(90508.5,BQTIEN,1,BK,0)
.... ;
.... ; Determine if this patient meets this treatment prompt definition,
.... ; if they do, store the remarks into the iCare Patient file
.... I $$FND^BQITRPPT(BQTIEN,"BQITEST",BQIDFN,.BQIRMK) D FILE
.... Q
... Q
.. Q
. Q
Q
;
PAT(BQIDFN) ;EP - Find treatment prompts for one patient
; Remove treatment prompt for this patient
I $G(UID)="" S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
;
D DEL(BQIDFN)
; If no active HRNS, quit
I '$$HRN^BQIUL1(BQIDFN) Q
; If no visit in last 3 years, quit
;I '$$VTHR^BQIUL1(BQIDFN) Q
; Set the date/time last updated
I $G(^BQIPAT(BQIDFN,0))'="" S $P(^BQIPAT(BQIDFN,0),U,7)=$$NOW^XLFDT()
;
S BQTDN=0
F S BQTDN=$O(^BQIREG("C",BQIDFN,BQTDN)) Q:BQTDN="" D
. ; If tag has no associated treatment prompts, quit
. I $O(^BQI(90508.5,"AD",BQTDN,""))="" Q
. S RCIEN=$O(^BQIREG("C",BQIDFN,BQTDN,"")) I RCIEN="" Q
. S STAT=$P(^BQIREG(RCIEN,0),U,3)
. ; If the tag status is not accepted or proposed, quit
. I '$$ACST^BQITDUTL(STAT) Q
. S PRI=""
. F S PRI=$O(^BQI(90508.5,"AD",BQTDN,PRI)) Q:PRI="" D
.. S BQTIEN=""
.. F S BQTIEN=$O(^BQI(90508.5,"AD",BQTDN,PRI,BQTIEN)) Q:BQTIEN="" D
... I $P(^BQI(90508.5,BQTIEN,0),U,4)=1 Q
... ;
... ; Set up the treatment remarks into array
... K BQIRMK
... S BK=0
... F S BK=$O(^BQI(90508.5,BQTIEN,1,BK)) Q:'BK S BQIRMK(BK)=^BQI(90508.5,BQTIEN,1,BK,0)
... ;
... ; Determine if this patient meets this treatment prompt definition,
... ; if they do, store the remarks into the iCare Patient file
... I $$FND^BQITRPPT(BQTIEN,"BQITEST",BQIDFN,.BQIRMK) D FILE
... Q
.. Q
. Q
Q
;
FILE ;EP - File a record
NEW DA,DIC,DINUM,X,DLAYGO,Y
S DA(1)=BQIDFN,(DINUM,X)=BQTIEN,DIC="^BQIPAT("_DA(1)_",50,",DIC(0)="L"
S DLAYGO=90507.55,DIC("P")=DLAYGO
I $G(^BQIPAT(BQIDFN,50,0))="" S ^BQIPAT(BQIDFN,50,0)="^90507.55P^^"
K DO,DD D FILE^DICN
S DA=+Y
S IENS=$$IENS^DILF(.DA)
S BQIUPD(90507.55,IENS,.02)=DT
D FILE^DIE("","BQIUPD","ERROR")
;
D WP^DIE(90507.55,IENS,1,"","BQIRMK","ERROR")
K BQIRMK
Q
;
DEL(BQDFN) ;EP - Delete treatment prompts
NEW BQIUPD
I $P($G(^BQIPAT(BQDFN,0)),"^",1)="" S $P(^BQIPAT(BQDFN,0),"^",1)=BQDFN,^BQIPAT("B",BQDFN,BQDFN)=""
S BQIUPD(90507.5,BQDFN_",",.07)="@"
D FILE^DIE("","BQIUPD","ERROR")
NEW DIK,DA
S DA(1)=BQDFN,DIK="^BQIPAT("_DA(1)_",50,"
S DA=0 F S DA=$O(^BQIPAT(DA(1),50,DA)) Q:'DA D ^DIK
Q
BQITRMT ;PRXM/HC/ALA - Find Treatment Prompts ; 24 Apr 2007 12:29 PM
+1 ;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17
+2 QUIT
+3 ;
EN ;
+1 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+2 DO POP
+3 QUIT
+4 ;
POP ; Find all Treatment Prompts for CVD tagged patients
+1 ; Parameters
+2 ; BQTDN - Tag IEN
+3 ; PRI - Treatment priority for the tag
+4 ; BQTIEN - Treatment IEN
+5 ; BQIDFN - Patient IEN
+6 ;
+7 NEW BQTDN,BQRIEN
+8 SET BQTDN=""
+9 FOR
SET BQTDN=$ORDER(^BQI(90508.5,"AD",BQTDN))
IF BQTDN=""
QUIT
Begin DoDot:1
+10 ;
+11 ; For every patient with this tag
+12 SET BQRIEN=""
+13 FOR
SET BQRIEN=$ORDER(^BQIREG("B",BQTDN,BQRIEN))
IF BQRIEN=""
QUIT
Begin DoDot:2
+14 SET BQIDFN=$PIECE(^BQIREG(BQRIEN,0),U,2)
SET STAT=$PIECE(^(0),U,3)
+15 ; Remove treatment prompt
+16 DO DEL(BQIDFN)
+17 ; If the tag status is not an active status, quit
+18 IF '$$ACST^BQITDUTL(STAT)
QUIT
+19 ; If no active HRNS, quit
+20 IF '$$HRN^BQIUL1(BQIDFN)
QUIT
+21 ; If no visit in last 3 years, quit
+22 ;I '$$VTHR^BQIUL1(BQIDFN) Q
+23 ; Set the date/time last updated
+24 IF $GET(^BQIPAT(BQIDFN,0))'=""
SET $PIECE(^BQIPAT(BQIDFN,0),U,7)=$$NOW^XLFDT()
+25 ;
+26 SET PRI=""
+27 FOR
SET PRI=$ORDER(^BQI(90508.5,"AD",BQTDN,PRI))
IF PRI=""
QUIT
Begin DoDot:3
+28 SET BQTIEN=""
+29 FOR
SET BQTIEN=$ORDER(^BQI(90508.5,"AD",BQTDN,PRI,BQTIEN))
IF BQTIEN=""
QUIT
Begin DoDot:4
+30 IF $PIECE(^BQI(90508.5,BQTIEN,0),U,4)=1
QUIT
+31 ; Set the treatment remarks into array
+32 KILL BQIRMK
+33 SET BK=0
+34 FOR
SET BK=$ORDER(^BQI(90508.5,BQTIEN,1,BK))
IF 'BK
QUIT
SET BQIRMK(BK)=^BQI(90508.5,BQTIEN,1,BK,0)
+35 ;
+36 ; Determine if this patient meets this treatment prompt definition,
+37 ; if they do, store the remarks into the iCare Patient file
+38 IF $$FND^BQITRPPT(BQTIEN,"BQITEST",BQIDFN,.BQIRMK)
DO FILE
+39 QUIT
End DoDot:4
+40 QUIT
End DoDot:3
+41 QUIT
End DoDot:2
+42 QUIT
End DoDot:1
+43 QUIT
+44 ;
PAT(BQIDFN) ;EP - Find treatment prompts for one patient
+1 ; Remove treatment prompt for this patient
+2 IF $GET(UID)=""
SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 ;
+4 DO DEL(BQIDFN)
+5 ; If no active HRNS, quit
+6 IF '$$HRN^BQIUL1(BQIDFN)
QUIT
+7 ; If no visit in last 3 years, quit
+8 ;I '$$VTHR^BQIUL1(BQIDFN) Q
+9 ; Set the date/time last updated
+10 IF $GET(^BQIPAT(BQIDFN,0))'=""
SET $PIECE(^BQIPAT(BQIDFN,0),U,7)=$$NOW^XLFDT()
+11 ;
+12 SET BQTDN=0
+13 FOR
SET BQTDN=$ORDER(^BQIREG("C",BQIDFN,BQTDN))
IF BQTDN=""
QUIT
Begin DoDot:1
+14 ; If tag has no associated treatment prompts, quit
+15 IF $ORDER(^BQI(90508.5,"AD",BQTDN,""))=""
QUIT
+16 SET RCIEN=$ORDER(^BQIREG("C",BQIDFN,BQTDN,""))
IF RCIEN=""
QUIT
+17 SET STAT=$PIECE(^BQIREG(RCIEN,0),U,3)
+18 ; If the tag status is not accepted or proposed, quit
+19 IF '$$ACST^BQITDUTL(STAT)
QUIT
+20 SET PRI=""
+21 FOR
SET PRI=$ORDER(^BQI(90508.5,"AD",BQTDN,PRI))
IF PRI=""
QUIT
Begin DoDot:2
+22 SET BQTIEN=""
+23 FOR
SET BQTIEN=$ORDER(^BQI(90508.5,"AD",BQTDN,PRI,BQTIEN))
IF BQTIEN=""
QUIT
Begin DoDot:3
+24 IF $PIECE(^BQI(90508.5,BQTIEN,0),U,4)=1
QUIT
+25 ;
+26 ; Set up the treatment remarks into array
+27 KILL BQIRMK
+28 SET BK=0
+29 FOR
SET BK=$ORDER(^BQI(90508.5,BQTIEN,1,BK))
IF 'BK
QUIT
SET BQIRMK(BK)=^BQI(90508.5,BQTIEN,1,BK,0)
+30 ;
+31 ; Determine if this patient meets this treatment prompt definition,
+32 ; if they do, store the remarks into the iCare Patient file
+33 IF $$FND^BQITRPPT(BQTIEN,"BQITEST",BQIDFN,.BQIRMK)
DO FILE
+34 QUIT
End DoDot:3
+35 QUIT
End DoDot:2
+36 QUIT
End DoDot:1
+37 QUIT
+38 ;
FILE ;EP - File a record
+1 NEW DA,DIC,DINUM,X,DLAYGO,Y
+2 SET DA(1)=BQIDFN
SET (DINUM,X)=BQTIEN
SET DIC="^BQIPAT("_DA(1)_",50,"
SET DIC(0)="L"
+3 SET DLAYGO=90507.55
SET DIC("P")=DLAYGO
+4 IF $GET(^BQIPAT(BQIDFN,50,0))=""
SET ^BQIPAT(BQIDFN,50,0)="^90507.55P^^"
+5 KILL DO,DD
DO FILE^DICN
+6 SET DA=+Y
+7 SET IENS=$$IENS^DILF(.DA)
+8 SET BQIUPD(90507.55,IENS,.02)=DT
+9 DO FILE^DIE("","BQIUPD","ERROR")
+10 ;
+11 DO WP^DIE(90507.55,IENS,1,"","BQIRMK","ERROR")
+12 KILL BQIRMK
+13 QUIT
+14 ;
DEL(BQDFN) ;EP - Delete treatment prompts
+1 NEW BQIUPD
+2 IF $PIECE($GET(^BQIPAT(BQDFN,0)),"^",1)=""
SET $PIECE(^BQIPAT(BQDFN,0),"^",1)=BQDFN
SET ^BQIPAT("B",BQDFN,BQDFN)=""
+3 SET BQIUPD(90507.5,BQDFN_",",.07)="@"
+4 DO FILE^DIE("","BQIUPD","ERROR")
+5 NEW DIK,DA
+6 SET DA(1)=BQDFN
SET DIK="^BQIPAT("_DA(1)_",50,"
+7 SET DA=0
FOR
SET DA=$ORDER(^BQIPAT(DA(1),50,DA))
IF 'DA
QUIT
DO ^DIK
+8 QUIT
