BQITDTG ;VNGT/HS/ALA-Update one tag ; 18 Aug 2008 12:15 PM
;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
;
POP(TAG) ;EP - Update a tag by population
;
S TAG=$G(TAG,""),UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
I TAG'?.N S TAG=$$GDXN^BQITUTL(TAG)
S BQTN=TAG
S THCFL=+$P(^BQI(90506.2,BQTN,0),U,10)
; If hierachical, need to redo the higher order tags because
; the actual tag being recalculated is dependent on whether
; there is a higher active tag or not.
I THCFL D
. S HCIEN=$O(^BQI(90506.2,BQTN,4,"B",BQTN,""))
. S ORD=$P(^BQI(90506.2,BQTN,4,HCIEN,0),U,2),HORD=ORD,QFL=0
. F S HORD=$O(^BQI(90506.2,BQTN,4,"AC",HORD)) Q:HORD=ORD D Q:QFL
.. S HIEN=$O(^BQI(90506.2,BQTN,4,"AC",HORD,""))
.. S HTAG=$P(^BQI(90506.2,BQTN,4,HIEN,0),U,1)
.. D PTAG(HTAG)
I 'THCFL D PTAG(TAG)
Q
;
PTAG(BQTN) ; EP
; If the category is marked as inactive, ignore it
I $$GET1^DIQ(90506.2,BQTN_",",.03,"I") Q
; If the category is a subdefinition, ignore it
I $$GET1^DIQ(90506.2,BQTN_",",.05,"I")=1 Q
S BQDEF=$$GET1^DIQ(90506.2,BQTN_",",.01,";E")
S BQEXEC=$$GET1^DIQ(90506.2,BQTN_",",1,"E")
S BQPRG=$$GET1^DIQ(90506.2,BQTN_",",.04,"E")
;
; Set the taxonomy array from the file definition
S BQREF="BQIRY" K @BQREF
D ARY^BQITUTL(BQDEF,BQREF)
S BQGLB=$NA(^TMP("BQIPOP",UID))
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,TAG,1,DA)) Q:'DA D ^DIK
; File the patients who met criteria
S DFN=0
F S DFN=$O(@BQGLB@(DFN)) Q:DFN="" D FIL^BQITASK(BQGLB,DFN)
Q
;
PAT(TAG,DFN) ; EP - Update a tag by patient
S TAG=$G(TAG,""),UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
I TAG'?.N S TAG=$$GDXN^BQITUTL(TAG)
S BQTN=TAG
S THCFL=+$P(^BQI(90506.2,BQTN,0),U,10)
; If hierachical, need to redo the higher order tags because
; the actual tag being recalculated is dependent on whether
; there is a higher active tag or not.
I THCFL D
. S HCIEN=$O(^BQI(90506.2,BQTN,4,"B",BQTN,""))
. S ORD=$P(^BQI(90506.2,BQTN,4,HCIEN,0),U,2),HORD=ORD,QFL=0
. F S HORD=$O(^BQI(90506.2,BQTN,4,"AC",HORD)) Q:HORD=ORD D Q:QFL
.. S HIEN=$O(^BQI(90506.2,BQTN,4,"AC",HORD,""))
.. S HTAG=$P(^BQI(90506.2,BQTN,4,HIEN,0),U,1)
.. D ITAG(HTAG,DFN)
I 'THCFL D ITAG(TAG,DFN)
Q
;
ITAG(BQTN,DFN) ; EP
; If the category is marked as inactive, ignore it
I $$GET1^DIQ(90506.2,BQTN_",",.03,"I") Q
; If the category is a subdefinition, ignore it
I $$GET1^DIQ(90506.2,BQTN_",",.05,"I")=1 Q
S BQDEF=$$GET1^DIQ(90506.2,BQTN_",",.01,"E")
S BQEXEC=$$GET1^DIQ(90506.2,BQTN_",",1,"E")
S BQPRG=$$GET1^DIQ(90506.2,BQTN_",",.04,"E")
;
S BQTGLB=$NA(^TMP("BQIPDXC",UID))
K @BQTGLB
;
; Call the individual patient dx category code
S PRGM="S VOK=""$$PAT^""_BQPRG_""(BQDEF,.BQTGLB,DFN)"""
X PRGM
;
; File the returned data
D CHK^BQITDPAT(BQTGLB,DFN)
Q
BQITDTG ;VNGT/HS/ALA-Update one tag ; 18 Aug 2008 12:15 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
+2 ;
POP(TAG) ;EP - Update a tag by population
+1 ;
+2 SET TAG=$GET(TAG,"")
SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 IF TAG'?.N
SET TAG=$$GDXN^BQITUTL(TAG)
+4 SET BQTN=TAG
+5 SET THCFL=+$PIECE(^BQI(90506.2,BQTN,0),U,10)
+6 ; If hierachical, need to redo the higher order tags because
+7 ; the actual tag being recalculated is dependent on whether
+8 ; there is a higher active tag or not.
+9 IF THCFL
Begin DoDot:1
+10 SET HCIEN=$ORDER(^BQI(90506.2,BQTN,4,"B",BQTN,""))
+11 SET ORD=$PIECE(^BQI(90506.2,BQTN,4,HCIEN,0),U,2)
SET HORD=ORD
SET QFL=0
+12 FOR
SET HORD=$ORDER(^BQI(90506.2,BQTN,4,"AC",HORD))
IF HORD=ORD
QUIT
Begin DoDot:2
+13 SET HIEN=$ORDER(^BQI(90506.2,BQTN,4,"AC",HORD,""))
+14 SET HTAG=$PIECE(^BQI(90506.2,BQTN,4,HIEN,0),U,1)
+15 DO PTAG(HTAG)
End DoDot:2
IF QFL
QUIT
End DoDot:1
+16 IF 'THCFL
DO PTAG(TAG)
+17 QUIT
+18 ;
PTAG(BQTN) ; EP
+1 ; If the category is marked as inactive, ignore it
+2 IF $$GET1^DIQ(90506.2,BQTN_",",.03,"I")
QUIT
+3 ; If the category is a subdefinition, ignore it
+4 IF $$GET1^DIQ(90506.2,BQTN_",",.05,"I")=1
QUIT
+5 SET BQDEF=$$GET1^DIQ(90506.2,BQTN_",",.01,";E")
+6 SET BQEXEC=$$GET1^DIQ(90506.2,BQTN_",",1,"E")
+7 SET BQPRG=$$GET1^DIQ(90506.2,BQTN_",",.04,"E")
+8 ;
+9 ; Set the taxonomy array from the file definition
+10 SET BQREF="BQIRY"
KILL @BQREF
+11 DO ARY^BQITUTL(BQDEF,BQREF)
+12 SET BQGLB=$NAME(^TMP("BQIPOP",UID))
+13 KILL @BQGLB
+14 ;
+15 ; Call the populate category code
+16 SET PRGM="POP^"_BQPRG_"(BQREF,BQGLB)"
+17 DO @PRGM
+18 ;
+19 ; Check if patient tagged but not found in criteria anymore
+20 SET IEN=""
+21 FOR
SET IEN=$ORDER(^BQIREG("B",BQTN,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+22 SET DFN=$PIECE(^BQIREG(IEN,0),U,2)
+23 IF '$DATA(@BQGLB@(DFN))
Begin DoDot:2
+24 DO NCR^BQITDUTL(DFN,BQTN)
+25 ; Remove previous criteria
+26 NEW DA,DIK
+27 SET DA(2)=DFN
SET DA(1)=BQTN
SET DA=0
SET DIK="^BQIPAT("_DA(2)_",20,"_DA(1)_",1,"
+28 FOR
SET DA=$ORDER(^BQIPAT(DFN,20,TAG,1,DA))
IF 'DA
QUIT
DO ^DIK
End DoDot:2
End DoDot:1
+29 ; File the patients who met criteria
+30 SET DFN=0
+31 FOR
SET DFN=$ORDER(@BQGLB@(DFN))
IF DFN=""
QUIT
DO FIL^BQITASK(BQGLB,DFN)
+32 QUIT
+33 ;
PAT(TAG,DFN) ; EP - Update a tag by patient
+1 SET TAG=$GET(TAG,"")
SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+2 IF TAG'?.N
SET TAG=$$GDXN^BQITUTL(TAG)
+3 SET BQTN=TAG
+4 SET THCFL=+$PIECE(^BQI(90506.2,BQTN,0),U,10)
+5 ; If hierachical, need to redo the higher order tags because
+6 ; the actual tag being recalculated is dependent on whether
+7 ; there is a higher active tag or not.
+8 IF THCFL
Begin DoDot:1
+9 SET HCIEN=$ORDER(^BQI(90506.2,BQTN,4,"B",BQTN,""))
+10 SET ORD=$PIECE(^BQI(90506.2,BQTN,4,HCIEN,0),U,2)
SET HORD=ORD
SET QFL=0
+11 FOR
SET HORD=$ORDER(^BQI(90506.2,BQTN,4,"AC",HORD))
IF HORD=ORD
QUIT
Begin DoDot:2
+12 SET HIEN=$ORDER(^BQI(90506.2,BQTN,4,"AC",HORD,""))
+13 SET HTAG=$PIECE(^BQI(90506.2,BQTN,4,HIEN,0),U,1)
+14 DO ITAG(HTAG,DFN)
End DoDot:2
IF QFL
QUIT
End DoDot:1
+15 IF 'THCFL
DO ITAG(TAG,DFN)
+16 QUIT
+17 ;
ITAG(BQTN,DFN) ; EP
+1 ; If the category is marked as inactive, ignore it
+2 IF $$GET1^DIQ(90506.2,BQTN_",",.03,"I")
QUIT
+3 ; If the category is a subdefinition, ignore it
+4 IF $$GET1^DIQ(90506.2,BQTN_",",.05,"I")=1
QUIT
+5 SET BQDEF=$$GET1^DIQ(90506.2,BQTN_",",.01,"E")
+6 SET BQEXEC=$$GET1^DIQ(90506.2,BQTN_",",1,"E")
+7 SET BQPRG=$$GET1^DIQ(90506.2,BQTN_",",.04,"E")
+8 ;
+9 SET BQTGLB=$NAME(^TMP("BQIPDXC",UID))
+10 KILL @BQTGLB
+11 ;
+12 ; Call the individual patient dx category code
+13 SET PRGM="S VOK=""$$PAT^""_BQPRG_""(BQDEF,.BQTGLB,DFN)"""
+14 XECUTE PRGM
+15 ;
+16 ; File the returned data
+17 DO CHK^BQITDPAT(BQTGLB,DFN)
+18 QUIT
