ONCOU55B ;WISC/MLH-UTILITY ROUTINE #3 for ONCOLOGY PRIMARY File (#165.5) ;9/10/93 10:08
;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
;
RXTS ; reindex TUMOR STATUS (#73) on ONCOLOGY PRIMARY (#165.5) - called by RXTS^ONCOU55
; should only be run after re-indexing follow-up (RXFU^ONCOU0)
N KT,DA
N KTS S KTS=0
W:'$D(ZTQUEUED) !!,"Re-indexing TUMOR STATUS" S DA(1)=0
F KT=1:1 S DA(1)=$O(^ONCO(165.5,DA(1))) Q:'DA(1) D RXTSD
;END FOR
;
W:'$D(ZTQUEUED) !,KT," primaries processed.",!,KTS," tumor statuses deleted lacking corresponding followups.",!!
Q
;
RXTSD ; check FU tumor statuses for a primary - called by RXTS
S DA=0
F S DA=$O(^ONCO(165.5,DA(1),"TS",DA)) Q:'DA D RXTSD1 ; check a single follow up
;
; re-index all xrefs on the .01 field
N DIK S DIK="^ONCO(165.5,"_DA(1)_",""TS"",",DIK(1)=.01
K ^ONCO(165.5,DA(1),"TS","AA"),^("B")
D ENALL^DIK,LTS^ONCOU55(DA(1))
I '$D(ZTQUEUED) W:$R(100)=0 "."
Q
;
RXTSD1 ; check a single follow up, delete if dangling - called by RXTSD
N TSDAT S TSDAT=$P($G(^ONCO(165.5,DA(1),"TS",DA,0)),U,1)
N PAT S PAT=$P($G(^ONCO(165.5,DA(1),0)),U,2)
I TSDAT,PAT,$D(^ONCO(160,PAT,"F","B",TSDAT)) ; all OK
E K ^ONCO(165.5,DA(1),"TS",DA) W "*" S KTS=KTS+1 ; no match - delete
Q
;
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOU55B 1293 printed Nov 22, 2024@17:36:10 Page 2
ONCOU55B ;WISC/MLH-UTILITY ROUTINE #3 for ONCOLOGY PRIMARY File (#165.5) ;9/10/93 10:08
+1 ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
+2 ;
RXTS ; reindex TUMOR STATUS (#73) on ONCOLOGY PRIMARY (#165.5) - called by RXTS^ONCOU55
+1 ; should only be run after re-indexing follow-up (RXFU^ONCOU0)
+2 NEW KT,DA
+3 NEW KTS
SET KTS=0
+4 if '$DATA(ZTQUEUED)
WRITE !!,"Re-indexing TUMOR STATUS"
SET DA(1)=0
+5 FOR KT=1:1
SET DA(1)=$ORDER(^ONCO(165.5,DA(1)))
if 'DA(1)
QUIT
DO RXTSD
+6 ;END FOR
+7 ;
+8 if '$DATA(ZTQUEUED)
WRITE !,KT," primaries processed.",!,KTS," tumor statuses deleted lacking corresponding followups.",!!
+9 QUIT
+10 ;
RXTSD ; check FU tumor statuses for a primary - called by RXTS
+1 SET DA=0
+2 ; check a single follow up
FOR
SET DA=$ORDER(^ONCO(165.5,DA(1),"TS",DA))
if 'DA
QUIT
DO RXTSD1
+3 ;
+4 ; re-index all xrefs on the .01 field
+5 NEW DIK
SET DIK="^ONCO(165.5,"_DA(1)_",""TS"","
SET DIK(1)=.01
+6 KILL ^ONCO(165.5,DA(1),"TS","AA"),^("B")
+7 DO ENALL^DIK
DO LTS^ONCOU55(DA(1))
+8 IF '$DATA(ZTQUEUED)
if $RANDOM(100)=0
WRITE "."
+9 QUIT
+10 ;
RXTSD1 ; check a single follow up, delete if dangling - called by RXTSD
+1 NEW TSDAT
SET TSDAT=$PIECE($GET(^ONCO(165.5,DA(1),"TS",DA,0)),U,1)
+2 NEW PAT
SET PAT=$PIECE($GET(^ONCO(165.5,DA(1),0)),U,2)
+3 ; all OK
IF TSDAT
IF PAT
IF $DATA(^ONCO(160,PAT,"F","B",TSDAT))
+4 ; no match - delete
IF '$TEST
KILL ^ONCO(165.5,DA(1),"TS",DA)
WRITE "*"
SET KTS=KTS+1
+5 QUIT
+6 ;
+7 QUIT
