- 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 Jan 18, 2025@03:25:55 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