ONCOCOF ;Hines OIFO/GWB - [RS Registry Summary Reports - Follow Up] ;06/23/10
;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
;
FR ;[RS Registry Summary Reports - Follow Up]
N AA,AB,AC,AD,AE,AF,AG,AN,AS,BEH,CC,MO,ONCODF,PA,PB,PC,PD,PE,PL,PP,PSFC
N SFC,SITECODE,SITENAME,SUMSTG,T,VV,P100
F SITENAME="CERVIX","SKIN" D
.S DIC=164.2,DIC(0)="O",X=SITENAME
.D ^DIC K DIC,X
.S SITECODE(SITENAME)=+Y
K ^TMP($J)
S (T,AB,AC,AS,AF,AN,AA,CC,P100)=0
D TOTCASE
S T=AA+AN
S X0=0 F S X0=$O(^TMP($J,X0)) Q:X0'>0 D
.S ST=$P($G(^ONCO(165.5,X0,0)),U)
.S MO=$$HIST^ONCFUNC(X0)
.S SUMSTG=$P($G(^ONCO(165.5,X0,2)),U,17)
.S BEH=$E(MO,5)
.D SUB
S AA=AA-AB-AC-AS-CC-P100
S FR=T_U_AB_U_AC_U_AS
S (AB,AC,AD,AE,AF)=0
S X0=0 F S X0=$O(^TMP($J,X0)) Q:X0'>0 S PP=$P(^ONCO(165.5,X0,0),U,2),VV=$G(^ONCO(160,PP,1)),ONCODF=$P(VV,U,2),AS=$P(VV,U,7),VV=$P(VV,U) D F
S AC=AA-AB
I AA S PB=$J(AB/AA,0,2)*100,PC=$J(AC/AA,0,2)*100,PD=$J(AD/AA,0,2)*100,PE=$J(AE/AA,0,2)*100
E S (PB,PC,PD,PE)="N/A" ;avoid division by zero
I AC S PA=$J(AD/AC,0,2)*100,PL=$J(AE/AC,0,2)*100
E S (PA,PL)="N/A" ;avoid division by zero
S SFC=AA-AE
I AA S PSFC=$J(SFC/AA,0,2)*100 ;avoid division by zero
E S PSFC="N/A"
S FR=FR_U_AF_U_AN_U_AA_U_AB_U_AC_U_PC_U_PB_U_AD_U_PD_U_AE_U_PE_U_PA_U_PL_U_SFC_U_PSFC_U_CC_U_P100
S AS=$O(^ONCO(160.1,"C",DUZ(2),0))
I AS="" S AS=$O(^ONCO(160.1,0))
S ^ONCO(160.1,AS,"FR")=FR
N IOP
I ONCOS("F")=1 S DIC=160.2,DIC(0)="",X="FOLLOWUP RATE REPORT 1" D ^DIC K DIC,X
I ONCOS("F")=2 S DIC=160.2,DIC(0)="",X="FOLLOWUP RATE REPORT" D ^DIC K DIC,X
S IOP=ION
S DIWF="^ONCO(160.2,"_(+Y)_",1,",DIWF(1)="160.1"
S BY="NUMBER"
S (FR,TO)=$O(^ONCO(160.1,"C",DUZ(2),0))
I FR="" S (FR,TO)=$O(^ONCO(160.1,0))
W !!
D EN2^DIWF K DIWF,BY,FR,TO S IOP=ION D ^%ZIS
K PA,PB,PC,PD,PE,PL,X0
Q
;
TOTCASE ;AA = Analytic (CLASS OF CASE 00-22)
;AN = Non-analytic (CLASS OF CASE 23-99)
N COC,DATEDX,EOF,MINUS5,ONCOPARS,REFDATE,VASITE,XD0,XD1
S VASITE=$O(^ONCO(160.1,"C",DUZ(2),0))
I VASITE="" S VASITE=$O(^ONCO(160.1,0))
S ONCOPARS=$G(^ONCO(160.1,VASITE,0))
S REFDATE=$P(ONCOPARS,U,4)
S XD0=REFDATE,EOF=0
S MINUS5=DT-50000
I ONCOS("F")=2,MINUS5>REFDATE S XD0=MINUS5
F D Q:EOF
.S XD1=""
.F S XD1=$O(^ONCO(165.5,"ADX",XD0,XD1)) Q:'XD1 I $$DIV^ONCFUNC(XD1)=DUZ(2) D
..I $P($G(^ONCO(165.5,XD1,7)),U,2)="A" Q
..S DATEDX=$P($G(^ONCO(165.5,XD1,0)),U,16)
..S COC=$E($$GET1^DIQ(165.5,XD1,.04),1,2)
..I COC>22 S AN=AN+1
..E S AA=AA+1,^TMP($J,XD1)=""
.S XD0=$O(^ONCO(165.5,"ADX",XD0))
.I 'XD0 S EOF=1
Q
;
SUB ;Subtract non-reportables
;P57 added, COC=00 and ptage>100
N ONCAGE,ONCPT
I ST="" S AA=AA-1 D KILL Q ;No SITE/GP
S DATEDX=$P($G(^ONCO(165.5,X0,0)),U,16)
S COC=$E($$GET1^DIQ(165.5,X0,.04),1,2)
I COC="00" S CC=CC+1 D KILL Q
S ONCPT=$P(^ONCO(160,$P(^ONCO(165.5,X0,0),U,2),0),";",1)
S ONCAGE=$$PTAGE(ONCPT,DATEDX) I ONCAGE>100 S P100=P100+1 D KILL Q
I BEH=0!(BEH=1) S AB=AB+1 D KILL Q
I ST=SITECODE("CERVIX"),BEH=2 S AC=AC+1 D KILL Q
I ST=SITECODE("SKIN"),MO>80699,MO<80944,(BEH=0)!(BEH=1)!(BEH=2)!(BEH=3),(SUMSTG=0)!(SUMSTG=1) S AS=AS+1 D KILL
Q
;
PTAGE(DFN,ONCDT) ;get pt age, supported IA=#10061
N ONCDAY,VADM
S:ONCDT="" ONCDT=$$DT^XLFDT()
D DEM^VADPT
S ONCDAY=$$FMDIFF^XLFDT(ONCDT,$P(VADM(3),"^"),3)
Q ONCDAY\365.25
;
F ;Subtract NEXT FOLLOW-UP SOURCE (160.04,6) = 8
;Foreign residents (not followed)
;Subtract STATUS = 0 (Dead) and LTF (Lost to follow-up)
N FS,LC,X1,X2
I VV&'AS S X1=$O(^ONCO(160,PP,"F","AA",0)) I X1'="" S LC=$O(^(X1,0)),FS=$P(^ONCO(160,PP,"F",LC,0),U,6) I FS=8 S AF=AF+1,AA=AA-1 D KILL Q
I 'VV S AB=AB+1 D KILL Q
S X2=ONCODF,X1=DT D ^%DTC I X<91.25 S AD=AD+1 Q
S AE=AE+1
Q
;
KILL ;Remove non-reportable entry
K ^TMP($J,X0)
Q
;
MTS ;MULTIPLE TUMOR STATUS (DEATH) (160,70) 'COMPUTED-FIELD' EXPRESSION
;MULTIPLE PRIMARY STATUS (160.04,9) 'COMPUTED-FIELD' EXPRESSION
;Displays SITE/GP (165.5,.01): LAST TUMOR STATUS (165.5,95)
Q:$P($G(^ONCO(160,D0,1)),U,1)
N PD0,ST,TS
I '$D(^ONCO(165.5,"C",D0)) W !,"No primaries for this patient" Q
S PD0=0
F S PD0=$O(^ONCO(165.5,"C",D0,PD0)) Q:PD0'>0 I $$DIV^ONCFUNC(PD0)=DUZ(2) D
.S ST=$P(^ONCO(164.2,$P(^ONCO(165.5,PD0,0),U,1),0),U,1)
.S TS=+$P($G(^ONCO(165.5,PD0,7)),U,6)
.S TS=$P($G(^ONCO(164.42,TS,0)),U,1)
.W !,ST_": "_TS
Q
;
NM ;HOSPITAL NAME (160,1000) 'COMPUTED-FIELD' EXPRESSION
N XD0
S XD0=$O(^ONCO(160.1,"C",DUZ(2),0))
I XD0="" S XD0=$O(^ONCO(160.1,0))
I XD0'="" S X=$P(^ONCO(160.1,XD0,0),U,1)
Q
;
ADD ;HOSPITAL STREET ADDRESS (160,1001) 'COMPUTED-FIELD' EXPRESSION
N XD0
S XD0=$O(^ONCO(160.1,"C",DUZ(2),0))
I XD0="" S XD0=$O(^ONCO(160.1,0))
I XD0'="" S X=$P(^ONCO(160.1,XD0,0),U,2)
Q
;
ZIP ;HOSPITAL CITY,ST ZIP (160,1002) 'COMPUTED-FIELD' EXPRESSION
N CITY,STATE,STP,XD0,ZIP
S XD0=$O(^ONCO(160.1,"C",DUZ(2),0))
I XD0="" S XD0=$O(^ONCO(160.1,0))
I XD0'="" D
.S ZIP=$P(^ONCO(160.1,XD0,0),U,3)
.S ZIP1=$$GET1^DIQ(160.1,XD0,.03)
.S CITY=$$GET1^DIQ(5.11,ZIP,1)
.S STATE=$$GET1^DIQ(5.11,ZIP,3)
.S X=CITY_", "_STATE_" "_ZIP1
Q
;
ZIP1 ;CITY,ST ZIP (160.1,.031) 'COMPUTED-FIELD' EXPRESSION
N CITY,STATE,ZIP,ZIP1
S ZIP=$P(^ONCO(160.1,D0,0),U,3)
S ZIP1=$$GET1^DIQ(160.1,D0,.03)
S CITY=$$GET1^DIQ(5.11,ZIP,1)
S STATE=$$GET1^DIQ(5.11,ZIP,3)
S X=CITY_", "_STATE_" "_ZIP1
Q
;
CLEANUP ;Cleanup
K D0,DATEDX,ONCOS,Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOCOF 5404 printed Oct 14, 2021@15:49:02 Page 2
ONCOCOF ;Hines OIFO/GWB - [RS Registry Summary Reports - Follow Up] ;06/23/10
+1 ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
+2 ;
FR ;[RS Registry Summary Reports - Follow Up]
+1 NEW AA,AB,AC,AD,AE,AF,AG,AN,AS,BEH,CC,MO,ONCODF,PA,PB,PC,PD,PE,PL,PP,PSFC
+2 NEW SFC,SITECODE,SITENAME,SUMSTG,T,VV,P100
+3 FOR SITENAME="CERVIX","SKIN"
Begin DoDot:1
+4 SET DIC=164.2
SET DIC(0)="O"
SET X=SITENAME
+5 DO ^DIC
KILL DIC,X
+6 SET SITECODE(SITENAME)=+Y
End DoDot:1
+7 KILL ^TMP($JOB)
+8 SET (T,AB,AC,AS,AF,AN,AA,CC,P100)=0
+9 DO TOTCASE
+10 SET T=AA+AN
+11 SET X0=0
FOR
SET X0=$ORDER(^TMP($JOB,X0))
if X0'>0
QUIT
Begin DoDot:1
+12 SET ST=$PIECE($GET(^ONCO(165.5,X0,0)),U)
+13 SET MO=$$HIST^ONCFUNC(X0)
+14 SET SUMSTG=$PIECE($GET(^ONCO(165.5,X0,2)),U,17)
+15 SET BEH=$EXTRACT(MO,5)
+16 DO SUB
End DoDot:1
+17 SET AA=AA-AB-AC-AS-CC-P100
+18 SET FR=T_U_AB_U_AC_U_AS
+19 SET (AB,AC,AD,AE,AF)=0
+20 SET X0=0
FOR
SET X0=$ORDER(^TMP($JOB,X0))
if X0'>0
QUIT
SET PP=$PIECE(^ONCO(165.5,X0,0),U,2)
SET VV=$GET(^ONCO(160,PP,1))
SET ONCODF=$PIECE(VV,U,2)
SET AS=$PIECE(VV,U,7)
SET VV=$PIECE(VV,U)
DO F
+21 SET AC=AA-AB
+22 IF AA
SET PB=$JUSTIFY(AB/AA,0,2)*100
SET PC=$JUSTIFY(AC/AA,0,2)*100
SET PD=$JUSTIFY(AD/AA,0,2)*100
SET PE=$JUSTIFY(AE/AA,0,2)*100
+23 ;avoid division by zero
IF '$TEST
SET (PB,PC,PD,PE)="N/A"
+24 IF AC
SET PA=$JUSTIFY(AD/AC,0,2)*100
SET PL=$JUSTIFY(AE/AC,0,2)*100
+25 ;avoid division by zero
IF '$TEST
SET (PA,PL)="N/A"
+26 SET SFC=AA-AE
+27 ;avoid division by zero
IF AA
SET PSFC=$JUSTIFY(SFC/AA,0,2)*100
+28 IF '$TEST
SET PSFC="N/A"
+29 SET FR=FR_U_AF_U_AN_U_AA_U_AB_U_AC_U_PC_U_PB_U_AD_U_PD_U_AE_U_PE_U_PA_U_PL_U_SFC_U_PSFC_U_CC_U_P100
+30 SET AS=$ORDER(^ONCO(160.1,"C",DUZ(2),0))
+31 IF AS=""
SET AS=$ORDER(^ONCO(160.1,0))
+32 SET ^ONCO(160.1,AS,"FR")=FR
+33 NEW IOP
+34 IF ONCOS("F")=1
SET DIC=160.2
SET DIC(0)=""
SET X="FOLLOWUP RATE REPORT 1"
DO ^DIC
KILL DIC,X
+35 IF ONCOS("F")=2
SET DIC=160.2
SET DIC(0)=""
SET X="FOLLOWUP RATE REPORT"
DO ^DIC
KILL DIC,X
+36 SET IOP=ION
+37 SET DIWF="^ONCO(160.2,"_(+Y)_",1,"
SET DIWF(1)="160.1"
+38 SET BY="NUMBER"
+39 SET (FR,TO)=$ORDER(^ONCO(160.1,"C",DUZ(2),0))
+40 IF FR=""
SET (FR,TO)=$ORDER(^ONCO(160.1,0))
+41 WRITE !!
+42 DO EN2^DIWF
KILL DIWF,BY,FR,TO
SET IOP=ION
DO ^%ZIS
+43 KILL PA,PB,PC,PD,PE,PL,X0
+44 QUIT
+45 ;
TOTCASE ;AA = Analytic (CLASS OF CASE 00-22)
+1 ;AN = Non-analytic (CLASS OF CASE 23-99)
+2 NEW COC,DATEDX,EOF,MINUS5,ONCOPARS,REFDATE,VASITE,XD0,XD1
+3 SET VASITE=$ORDER(^ONCO(160.1,"C",DUZ(2),0))
+4 IF VASITE=""
SET VASITE=$ORDER(^ONCO(160.1,0))
+5 SET ONCOPARS=$GET(^ONCO(160.1,VASITE,0))
+6 SET REFDATE=$PIECE(ONCOPARS,U,4)
+7 SET XD0=REFDATE
SET EOF=0
+8 SET MINUS5=DT-50000
+9 IF ONCOS("F")=2
IF MINUS5>REFDATE
SET XD0=MINUS5
+10 FOR
Begin DoDot:1
+11 SET XD1=""
+12 FOR
SET XD1=$ORDER(^ONCO(165.5,"ADX",XD0,XD1))
if 'XD1
QUIT
IF $$DIV^ONCFUNC(XD1)=DUZ(2)
Begin DoDot:2
+13 IF $PIECE($GET(^ONCO(165.5,XD1,7)),U,2)="A"
QUIT
+14 SET DATEDX=$PIECE($GET(^ONCO(165.5,XD1,0)),U,16)
+15 SET COC=$EXTRACT($$GET1^DIQ(165.5,XD1,.04),1,2)
+16 IF COC>22
SET AN=AN+1
+17 IF '$TEST
SET AA=AA+1
SET ^TMP($JOB,XD1)=""
End DoDot:2
+18 SET XD0=$ORDER(^ONCO(165.5,"ADX",XD0))
+19 IF 'XD0
SET EOF=1
End DoDot:1
if EOF
QUIT
+20 QUIT
+21 ;
SUB ;Subtract non-reportables
+1 ;P57 added, COC=00 and ptage>100
+2 NEW ONCAGE,ONCPT
+3 ;No SITE/GP
IF ST=""
SET AA=AA-1
DO KILL
QUIT
+4 SET DATEDX=$PIECE($GET(^ONCO(165.5,X0,0)),U,16)
+5 SET COC=$EXTRACT($$GET1^DIQ(165.5,X0,.04),1,2)
+6 IF COC="00"
SET CC=CC+1
DO KILL
QUIT
+7 SET ONCPT=$PIECE(^ONCO(160,$PIECE(^ONCO(165.5,X0,0),U,2),0),";",1)
+8 SET ONCAGE=$$PTAGE(ONCPT,DATEDX)
IF ONCAGE>100
SET P100=P100+1
DO KILL
QUIT
+9 IF BEH=0!(BEH=1)
SET AB=AB+1
DO KILL
QUIT
+10 IF ST=SITECODE("CERVIX")
IF BEH=2
SET AC=AC+1
DO KILL
QUIT
+11 IF ST=SITECODE("SKIN")
IF MO>80699
IF MO<80944
IF (BEH=0)!(BEH=1)!(BEH=2)!(BEH=3)
IF (SUMSTG=0)!(SUMSTG=1)
SET AS=AS+1
DO KILL
+12 QUIT
+13 ;
PTAGE(DFN,ONCDT) ;get pt age, supported IA=#10061
+1 NEW ONCDAY,VADM
+2 if ONCDT=""
SET ONCDT=$$DT^XLFDT()
+3 DO DEM^VADPT
+4 SET ONCDAY=$$FMDIFF^XLFDT(ONCDT,$PIECE(VADM(3),"^"),3)
+5 QUIT ONCDAY\365.25
+6 ;
F ;Subtract NEXT FOLLOW-UP SOURCE (160.04,6) = 8
+1 ;Foreign residents (not followed)
+2 ;Subtract STATUS = 0 (Dead) and LTF (Lost to follow-up)
+3 NEW FS,LC,X1,X2
+4 IF VV&'AS
SET X1=$ORDER(^ONCO(160,PP,"F","AA",0))
IF X1'=""
SET LC=$ORDER(^(X1,0))
SET FS=$PIECE(^ONCO(160,PP,"F",LC,0),U,6)
IF FS=8
SET AF=AF+1
SET AA=AA-1
DO KILL
QUIT
+5 IF 'VV
SET AB=AB+1
DO KILL
QUIT
+6 SET X2=ONCODF
SET X1=DT
DO ^%DTC
IF X<91.25
SET AD=AD+1
QUIT
+7 SET AE=AE+1
+8 QUIT
+9 ;
KILL ;Remove non-reportable entry
+1 KILL ^TMP($JOB,X0)
+2 QUIT
+3 ;
MTS ;MULTIPLE TUMOR STATUS (DEATH) (160,70) 'COMPUTED-FIELD' EXPRESSION
+1 ;MULTIPLE PRIMARY STATUS (160.04,9) 'COMPUTED-FIELD' EXPRESSION
+2 ;Displays SITE/GP (165.5,.01): LAST TUMOR STATUS (165.5,95)
+3 if $PIECE($GET(^ONCO(160,D0,1)),U,1)
QUIT
+4 NEW PD0,ST,TS
+5 IF '$DATA(^ONCO(165.5,"C",D0))
WRITE !,"No primaries for this patient"
QUIT
+6 SET PD0=0
+7 FOR
SET PD0=$ORDER(^ONCO(165.5,"C",D0,PD0))
if PD0'>0
QUIT
IF $$DIV^ONCFUNC(PD0)=DUZ(2)
Begin DoDot:1
+8 SET ST=$PIECE(^ONCO(164.2,$PIECE(^ONCO(165.5,PD0,0),U,1),0),U,1)
+9 SET TS=+$PIECE($GET(^ONCO(165.5,PD0,7)),U,6)
+10 SET TS=$PIECE($GET(^ONCO(164.42,TS,0)),U,1)
+11 WRITE !,ST_": "_TS
End DoDot:1
+12 QUIT
+13 ;
NM ;HOSPITAL NAME (160,1000) 'COMPUTED-FIELD' EXPRESSION
+1 NEW XD0
+2 SET XD0=$ORDER(^ONCO(160.1,"C",DUZ(2),0))
+3 IF XD0=""
SET XD0=$ORDER(^ONCO(160.1,0))
+4 IF XD0'=""
SET X=$PIECE(^ONCO(160.1,XD0,0),U,1)
+5 QUIT
+6 ;
ADD ;HOSPITAL STREET ADDRESS (160,1001) 'COMPUTED-FIELD' EXPRESSION
+1 NEW XD0
+2 SET XD0=$ORDER(^ONCO(160.1,"C",DUZ(2),0))
+3 IF XD0=""
SET XD0=$ORDER(^ONCO(160.1,0))
+4 IF XD0'=""
SET X=$PIECE(^ONCO(160.1,XD0,0),U,2)
+5 QUIT
+6 ;
ZIP ;HOSPITAL CITY,ST ZIP (160,1002) 'COMPUTED-FIELD' EXPRESSION
+1 NEW CITY,STATE,STP,XD0,ZIP
+2 SET XD0=$ORDER(^ONCO(160.1,"C",DUZ(2),0))
+3 IF XD0=""
SET XD0=$ORDER(^ONCO(160.1,0))
+4 IF XD0'=""
Begin DoDot:1
+5 SET ZIP=$PIECE(^ONCO(160.1,XD0,0),U,3)
+6 SET ZIP1=$$GET1^DIQ(160.1,XD0,.03)
+7 SET CITY=$$GET1^DIQ(5.11,ZIP,1)
+8 SET STATE=$$GET1^DIQ(5.11,ZIP,3)
+9 SET X=CITY_", "_STATE_" "_ZIP1
End DoDot:1
+10 QUIT
+11 ;
ZIP1 ;CITY,ST ZIP (160.1,.031) 'COMPUTED-FIELD' EXPRESSION
+1 NEW CITY,STATE,ZIP,ZIP1
+2 SET ZIP=$PIECE(^ONCO(160.1,D0,0),U,3)
+3 SET ZIP1=$$GET1^DIQ(160.1,D0,.03)
+4 SET CITY=$$GET1^DIQ(5.11,ZIP,1)
+5 SET STATE=$$GET1^DIQ(5.11,ZIP,3)
+6 SET X=CITY_", "_STATE_" "_ZIP1
+7 QUIT
+8 ;
CLEANUP ;Cleanup
+1 KILL D0,DATEDX,ONCOS,Y
