ONCOCRF ;HINES OIFO/GWB - FOLLOW-UP ;07/13/00
;;2.2;ONCOLOGY;**1,5,13**;Jul 31, 2013;Build 7
;
LD ;DATE OF LAST CONTACT OR DEATH (160.04,.01)
N O1,O2,STOP S LD="",STOP=0
S O1=""
F S O1=$O(^ONCO(160,XD0,"F","B",O1)) Q:'O1 D Q:STOP
.S O2=""
.F S O2=$O(^ONCO(160,XD0,"F","B",O1,O2)) Q:'O2 D Q:STOP
..S LD=$G(^ONCO(160,XD0,"F",O2,0))
..I $P(LD,U,2)=0 S STOP=1 ;VITAL STATUS (160.04,1)="Dead"
Q
;
R1 ;Kill STATUS (160,15) "AS" and DUE FOLLOW-UP (160,27) "AD"
;cross-references
S XD=$G(^ONCO(160,XD0,1)) Q:XD=""
S OS=$P(XD,U,1) K:OS'="" ^ONCO(160,"AS",OS,XD0)
S OD=$P(XD,U,2) K:OD'="" ^ONCO(160,"AD",OD,XD0)
Q
;
LDXT ;Return follow-up record for last date of contact excluding this one
S LD=$O(^ONCO(160,XD0,"F","AA",0)) I LD'="" S:$D(^(LD,DA)) LD=$O(^ONCO(160,XD0,"F","AA",LD)) I LD'="" S LD=+$O(^(LD,0)),LD=$G(^ONCO(160,XD0,"F",LD,0))
Q
;
SLF ;Set DATE OF LAST CONTACT OR DEATH (160.04,.01) "AA" cross-reference
;Set REGISTRAR (160.04,11) and DATE ENTERED (160.04)
N ONCDUZ,ONCDT
S XD0=DA(1),X1=9999999-X,^ONCO(160,XD0,"F","AA",X1,DA)=""
S ONCDUZ=DUZ
S ONCDT=DT
S:$P(^ONCO(160,XD0,"F",DA,0),U,10)="" $P(^ONCO(160,XD0,"F",DA,0),U,10)=ONCDUZ
S:$P(^ONCO(160,XD0,"F",DA,0),U,11)="" $P(^ONCO(160,XD0,"F",DA,0),U,11)=ONCDT
G EX
;
KLF ;Kill .01 of FOLLOW-UP MULTIPLE-RESETS: #16(1;2), STATUS #15(1;1), FOLLOWUP STATUS #15.2(1;7), DUE FOLLOW-UP #27(2;3), if alive, DATE DEATH #29 (1;8)
;CODE MODIFIED TO ELIMINATE FM RE-INDEXING DATA LOSS
;CHANGE MADE TO PREVENT DELETING DEATH DATA, IN FM CROSS-REFERENCING
S XD0=DA(1),X1=9999999-X K ^ONCO(160,XD0,"F","AA",X1,DA) G EX
;
SVS ;VITAL STATUS->STATUS (160,15) trigger AND UPDATE DUE FOLLOW-UP IF DEAD
;Invoked by "AC" xref on VITAL STATUS sub-field (160.04,1)
S XD0=DA(1) D LD ;get the last sub-record alive (or the first dead)
D UVS^ONCOCRFA ;update vital status
Q
;
KVS ;Kill: reset STATUS
S XD0=DA(1) D LDXT ;get the last sub-record (excluding this one)
D UVS^ONCOCRFA ;update vital status
Q
;
NF ;Set DUE FOLLOW-UP (160,27)
S NF=$S(FS=0:"",1:$E(LC,1,3)+1_$E(LC,4,5)_"00")
S $P(^ONCO(160,XD0,1),U,2)=NF
I NF'="" S ^ONCO(160,"AD",NF,XD0)=""
Q
;
UPD ;Update the following fields with the most recent FOLLOW-UP (160,400)
;data:
;STATUS (160,15) 1;1
;FOLLOW-UP STATUS (160,15.2) 1;7
;ICD REVSION (160,20) 1;4
;DUE FOLLOW-UP (160,27) 1;2
;DATE@TIME OF DEATH (160,29) 1;8
I '$D(XD0) Q:'$D(D0) S XD0=D0
D LD,R1 G EX:LD=""
S LC=$P(LD,U,1),ONCOVS=$P(LD,U,2),NM=$P(LD,U,6)
S FS=0 D SGPRCOC I DNTSKP=1 S FS=$S(NM="":1,NM<8:1,ONCOVS=0:0,1:0)
I FS S X1=DT,X2=LC D ^%DTC S FS=$S(X>456.25:8,1:FS)
S DIE="^ONCO(160,",DA=XD0,DR="15///"_ONCOVS_";15.2///"_FS D ^DIE
K DIE,DR
S $P(^ONCO(160,XD0,1),U,4)=$S(ONCOVS=0:9,1:0)
D NF I FS S Y=NF D DD^%DT W !!?20,"Due follow-up: ",Y G EX
S:ONCOVS=0 $P(^ONCO(160,XD0,1),U,8)=LC
W !!," Patient not followed"
G EX
;
SGPRCOC ;CHECK IF PATIENT HAS SINGLE PRIMARY ONLY & CLASS OF CASE 00 OR 30-99
;called from UDP above when setting FS for Follow-Up Source
; don't set FS to 1 (Active) or 8 (LTF) if single primary, COC 00,30-99
S DNTSKP=1
S PRI=0,PRICNT=0 F S PRI=$O(^ONCO(165.5,"C",XD0,PRI)) Q:PRI'>0 I $P($G(^ONCO(165.5,PRI,"DIV")),U,1)=DUZ(2) D
.S PRICNT=PRICNT+1
I PRICNT=1 D ; if patient has exactly 1 primary
.S ZZPRENT=$O(^ONCO(165.5,"C",XD0,0)) Q:ZZPRENT'>0 ; get primary IEN
.S ZZPRCOC=$P($G(^ONCO(165.5,ZZPRENT,0)),"^",4) ; get the COC
.I ZZPRCOC=1!(ZZPRCOC>9) S DNTSKP=0
K PRI,PRICNT,ZZPRENT,ZZPRCOC
Q
CHKDT04 ;
N X S X=$P($G(^ONCO(165.5,D0,0)),"^",16) I X>3031231 D
.S ONCSITGP=$P($G(^ONCO(165.5,D0,0)),"^",1) W ?48,$E($P($G(^ONCO(164.2,ONCSITGP,0)),"^",1),1,20) D DATEOT^ONCOES W ?69,X
Q
LFU ;LAST FOLLOW-UP SUMMARY-SELECTED DATA from Last Follow-up
S XD0=D0 D GD I X="" W !?10,"NO Last Contact Information on Patient",! G EX
DLC ;DATE LAST CONTACT (160,16) from "AF" cross-reference
S XD0=D0 D GD G EX
;
CAS ;CANCER STATUS Last Date Contact
DOD ;computed Date of Death
I $D(^ONCO(160,D0,1)),$P(^(1),U,1)=0 G DLC
S X="" G EX
GD ;DATE LAST CONTACT (160,16)
S X=$S('$D(^ONCO(160,XD0,"F","AA")):"",1:9999999-$O(^ONCO(160,XD0,"F","AA",0)))
Q
;
PDLC ;DATE LAST CONTACT (165.5,200)
S X=$S('$D(^ONCO(165.5,D0,"TS","AA")):"",1:9999999-$O(^ONCO(165.5,D0,"TS","AA",0))) G EX
;
PDLC1 ;DATE LAST CONTACT FILMANAGER FORMAT
D P0 G EX:XD0="" D GD G EX
;
P0 S XD0=$P($G(^ONCO(165.5,D0,0)),U,2)
Q
;
SDA ;SURVIVAL DAYS
D P0 G EX:XD0="" D SD G EX ;PRESENTS SURVIVAL IN DAYS
;
SUR ;SURVIVAL (MONTHS)
D P0 G EX:XD0="" D SD G EX:X="" S X=X/30.4375 G EX
;
SYR ;SURVIVAL YEARS
D P0 G EX:XD0="" D SD G EX:X="" S X=X/365.25 G EX
;
SWK ;WEEKS FOLLOWUP
D P0 G EX:XD0="" D SD G EX:X="" S X=X/7 G EX
;
SD S XDX=$P(^ONCO(165.5,D0,0),U,16) D GD,DC
Q
DC ;DATE COMPARE
S X2=XDX,X1=X S X=$S(X2="":"",X1="":"",1:0) Q:X="" I X2>X1 S X="" Q
D ^%DTC Q
DD ;DATE FORMATING
S XD=$S(XD="":"",$E(XD,6,7)="00":$E(XD,4,5)_"/"_($E(XD,1,3)+1700),1:$E(XD,4,5)_"/"_$E(XD,6,7)_"/"_($E(XD,1,3)+1700))
Q
SDF ;DUE FOLLOW-UP-TIGGERED BY NEXT FOLLOW-UP METHOD of FOLLOW-UP MULTIPLE
Q
KDF ;KILL DUE FOLLOW-UP
Q
;
EX ;KILL variables
K DNTSKP,FS,LC,LD,NF,NM,OD,ONCDT,ONCDUZ,ONCVS,OS,X1,X2,XD,XD0,XDX,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOCRF 5322 printed Oct 16, 2024@18:25:25 Page 2
ONCOCRF ;HINES OIFO/GWB - FOLLOW-UP ;07/13/00
+1 ;;2.2;ONCOLOGY;**1,5,13**;Jul 31, 2013;Build 7
+2 ;
LD ;DATE OF LAST CONTACT OR DEATH (160.04,.01)
+1 NEW O1,O2,STOP
SET LD=""
SET STOP=0
+2 SET O1=""
+3 FOR
SET O1=$ORDER(^ONCO(160,XD0,"F","B",O1))
if 'O1
QUIT
Begin DoDot:1
+4 SET O2=""
+5 FOR
SET O2=$ORDER(^ONCO(160,XD0,"F","B",O1,O2))
if 'O2
QUIT
Begin DoDot:2
+6 SET LD=$GET(^ONCO(160,XD0,"F",O2,0))
+7 ;VITAL STATUS (160.04,1)="Dead"
IF $PIECE(LD,U,2)=0
SET STOP=1
End DoDot:2
if STOP
QUIT
End DoDot:1
if STOP
QUIT
+8 QUIT
+9 ;
R1 ;Kill STATUS (160,15) "AS" and DUE FOLLOW-UP (160,27) "AD"
+1 ;cross-references
+2 SET XD=$GET(^ONCO(160,XD0,1))
if XD=""
QUIT
+3 SET OS=$PIECE(XD,U,1)
if OS'=""
KILL ^ONCO(160,"AS",OS,XD0)
+4 SET OD=$PIECE(XD,U,2)
if OD'=""
KILL ^ONCO(160,"AD",OD,XD0)
+5 QUIT
+6 ;
LDXT ;Return follow-up record for last date of contact excluding this one
+1 SET LD=$ORDER(^ONCO(160,XD0,"F","AA",0))
IF LD'=""
if $DATA(^(LD,DA))
SET LD=$ORDER(^ONCO(160,XD0,"F","AA",LD))
IF LD'=""
SET LD=+$ORDER(^(LD,0))
SET LD=$GET(^ONCO(160,XD0,"F",LD,0))
+2 QUIT
+3 ;
SLF ;Set DATE OF LAST CONTACT OR DEATH (160.04,.01) "AA" cross-reference
+1 ;Set REGISTRAR (160.04,11) and DATE ENTERED (160.04)
+2 NEW ONCDUZ,ONCDT
+3 SET XD0=DA(1)
SET X1=9999999-X
SET ^ONCO(160,XD0,"F","AA",X1,DA)=""
+4 SET ONCDUZ=DUZ
+5 SET ONCDT=DT
+6 if $PIECE(^ONCO(160,XD0,"F",DA,0),U,10)=""
SET $PIECE(^ONCO(160,XD0,"F",DA,0),U,10)=ONCDUZ
+7 if $PIECE(^ONCO(160,XD0,"F",DA,0),U,11)=""
SET $PIECE(^ONCO(160,XD0,"F",DA,0),U,11)=ONCDT
+8 GOTO EX
+9 ;
KLF ;Kill .01 of FOLLOW-UP MULTIPLE-RESETS: #16(1;2), STATUS #15(1;1), FOLLOWUP STATUS #15.2(1;7), DUE FOLLOW-UP #27(2;3), if alive, DATE DEATH #29 (1;8)
+1 ;CODE MODIFIED TO ELIMINATE FM RE-INDEXING DATA LOSS
+2 ;CHANGE MADE TO PREVENT DELETING DEATH DATA, IN FM CROSS-REFERENCING
+3 SET XD0=DA(1)
SET X1=9999999-X
KILL ^ONCO(160,XD0,"F","AA",X1,DA)
GOTO EX
+4 ;
SVS ;VITAL STATUS->STATUS (160,15) trigger AND UPDATE DUE FOLLOW-UP IF DEAD
+1 ;Invoked by "AC" xref on VITAL STATUS sub-field (160.04,1)
+2 ;get the last sub-record alive (or the first dead)
SET XD0=DA(1)
DO LD
+3 ;update vital status
DO UVS^ONCOCRFA
+4 QUIT
+5 ;
KVS ;Kill: reset STATUS
+1 ;get the last sub-record (excluding this one)
SET XD0=DA(1)
DO LDXT
+2 ;update vital status
DO UVS^ONCOCRFA
+3 QUIT
+4 ;
NF ;Set DUE FOLLOW-UP (160,27)
+1 SET NF=$SELECT(FS=0:"",1:$EXTRACT(LC,1,3)+1_$EXTRACT(LC,4,5)_"00")
+2 SET $PIECE(^ONCO(160,XD0,1),U,2)=NF
+3 IF NF'=""
SET ^ONCO(160,"AD",NF,XD0)=""
+4 QUIT
+5 ;
UPD ;Update the following fields with the most recent FOLLOW-UP (160,400)
+1 ;data:
+2 ;STATUS (160,15) 1;1
+3 ;FOLLOW-UP STATUS (160,15.2) 1;7
+4 ;ICD REVSION (160,20) 1;4
+5 ;DUE FOLLOW-UP (160,27) 1;2
+6 ;DATE@TIME OF DEATH (160,29) 1;8
+7 IF '$DATA(XD0)
if '$DATA(D0)
QUIT
SET XD0=D0
+8 DO LD
DO R1
if LD=""
GOTO EX
+9 SET LC=$PIECE(LD,U,1)
SET ONCOVS=$PIECE(LD,U,2)
SET NM=$PIECE(LD,U,6)
+10 SET FS=0
DO SGPRCOC
IF DNTSKP=1
SET FS=$SELECT(NM="":1,NM<8:1,ONCOVS=0:0,1:0)
+11 IF FS
SET X1=DT
SET X2=LC
DO ^%DTC
SET FS=$SELECT(X>456.25:8,1:FS)
+12 SET DIE="^ONCO(160,"
SET DA=XD0
SET DR="15///"_ONCOVS_";15.2///"_FS
DO ^DIE
+13 KILL DIE,DR
+14 SET $PIECE(^ONCO(160,XD0,1),U,4)=$SELECT(ONCOVS=0:9,1:0)
+15 DO NF
IF FS
SET Y=NF
DO DD^%DT
WRITE !!?20,"Due follow-up: ",Y
GOTO EX
+16 if ONCOVS=0
SET $PIECE(^ONCO(160,XD0,1),U,8)=LC
+17 WRITE !!," Patient not followed"
+18 GOTO EX
+19 ;
SGPRCOC ;CHECK IF PATIENT HAS SINGLE PRIMARY ONLY & CLASS OF CASE 00 OR 30-99
+1 ;called from UDP above when setting FS for Follow-Up Source
+2 ; don't set FS to 1 (Active) or 8 (LTF) if single primary, COC 00,30-99
+3 SET DNTSKP=1
+4 SET PRI=0
SET PRICNT=0
FOR
SET PRI=$ORDER(^ONCO(165.5,"C",XD0,PRI))
if PRI'>0
QUIT
IF $PIECE($GET(^ONCO(165.5,PRI,"DIV")),U,1)=DUZ(2)
Begin DoDot:1
+5 SET PRICNT=PRICNT+1
End DoDot:1
+6 ; if patient has exactly 1 primary
IF PRICNT=1
Begin DoDot:1
+7 ; get primary IEN
SET ZZPRENT=$ORDER(^ONCO(165.5,"C",XD0,0))
if ZZPRENT'>0
QUIT
+8 ; get the COC
SET ZZPRCOC=$PIECE($GET(^ONCO(165.5,ZZPRENT,0)),"^",4)
+9 IF ZZPRCOC=1!(ZZPRCOC>9)
SET DNTSKP=0
End DoDot:1
+10 KILL PRI,PRICNT,ZZPRENT,ZZPRCOC
+11 QUIT
CHKDT04 ;
+1 NEW X
SET X=$PIECE($GET(^ONCO(165.5,D0,0)),"^",16)
IF X>3031231
Begin DoDot:1
+2 SET ONCSITGP=$PIECE($GET(^ONCO(165.5,D0,0)),"^",1)
WRITE ?48,$EXTRACT($PIECE($GET(^ONCO(164.2,ONCSITGP,0)),"^",1),1,20)
DO DATEOT^ONCOES
WRITE ?69,X
End DoDot:1
+3 QUIT
LFU ;LAST FOLLOW-UP SUMMARY-SELECTED DATA from Last Follow-up
+1 SET XD0=D0
DO GD
IF X=""
WRITE !?10,"NO Last Contact Information on Patient",!
GOTO EX
DLC ;DATE LAST CONTACT (160,16) from "AF" cross-reference
+1 SET XD0=D0
DO GD
GOTO EX
+2 ;
CAS ;CANCER STATUS Last Date Contact
DOD ;computed Date of Death
+1 IF $DATA(^ONCO(160,D0,1))
IF $PIECE(^(1),U,1)=0
GOTO DLC
+2 SET X=""
GOTO EX
GD ;DATE LAST CONTACT (160,16)
+1 SET X=$SELECT('$DATA(^ONCO(160,XD0,"F","AA")):"",1:9999999-$ORDER(^ONCO(160,XD0,"F","AA",0)))
+2 QUIT
+3 ;
PDLC ;DATE LAST CONTACT (165.5,200)
+1 SET X=$SELECT('$DATA(^ONCO(165.5,D0,"TS","AA")):"",1:9999999-$ORDER(^ONCO(165.5,D0,"TS","AA",0)))
GOTO EX
+2 ;
PDLC1 ;DATE LAST CONTACT FILMANAGER FORMAT
+1 DO P0
if XD0=""
GOTO EX
DO GD
GOTO EX
+2 ;
P0 SET XD0=$PIECE($GET(^ONCO(165.5,D0,0)),U,2)
+1 QUIT
+2 ;
SDA ;SURVIVAL DAYS
+1 ;PRESENTS SURVIVAL IN DAYS
DO P0
if XD0=""
GOTO EX
DO SD
GOTO EX
+2 ;
SUR ;SURVIVAL (MONTHS)
+1 DO P0
if XD0=""
GOTO EX
DO SD
if X=""
GOTO EX
SET X=X/30.4375
GOTO EX
+2 ;
SYR ;SURVIVAL YEARS
+1 DO P0
if XD0=""
GOTO EX
DO SD
if X=""
GOTO EX
SET X=X/365.25
GOTO EX
+2 ;
SWK ;WEEKS FOLLOWUP
+1 DO P0
if XD0=""
GOTO EX
DO SD
if X=""
GOTO EX
SET X=X/7
GOTO EX
+2 ;
SD SET XDX=$PIECE(^ONCO(165.5,D0,0),U,16)
DO GD
DO DC
+1 QUIT
DC ;DATE COMPARE
+1 SET X2=XDX
SET X1=X
SET X=$SELECT(X2="":"",X1="":"",1:0)
if X=""
QUIT
IF X2>X1
SET X=""
QUIT
+2 DO ^%DTC
QUIT
DD ;DATE FORMATING
+1 SET XD=$SELECT(XD="":"",$EXTRACT(XD,6,7)="00":$EXTRACT(XD,4,5)_"/"_($EXTRACT(XD,1,3)+1700),1:$EXTRACT(XD,4,5)_"/"_$EXTRACT(XD,6,7)_"/"_($EXTRACT(XD,1,3)+1700))
+2 QUIT
SDF ;DUE FOLLOW-UP-TIGGERED BY NEXT FOLLOW-UP METHOD of FOLLOW-UP MULTIPLE
+1 QUIT
KDF ;KILL DUE FOLLOW-UP
+1 QUIT
+2 ;
EX ;KILL variables
+1 KILL DNTSKP,FS,LC,LD,NF,NM,OD,ONCDT,ONCDUZ,ONCVS,OS,X1,X2,XD,XD0,XDX,Y
+2 QUIT
