ONCOCOF ;HINES OIFO/GWB - [RS Registry Summary Reports - Follow Up] ;06/23/10
;;2.2;ONCOLOGY;**1,13,17**;Jul 31, 2013;Build 6
;
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,ONCFDT,ROLDT
S DIC=164.2,DIC(0)="O"
D ^DIC K DIC,X
K ^TMP($J)
S (T,AB,AC,AD,AS,AF,AN,AA,CC,P100,AE)=0
D TOTCASE
S CC=AA
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 DATEDX=$P($G(^ONCO(165.5,X0,0)),U,16)
.D SUB
S (AB,AC,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 T=CC-AF-P100 ;patch #17, total cases minus foreign res minus pat > 100 y/o
S FR=T_U_AB_U_AC_U_AS
S SFC=AB+AD,AC=T-AB,AE=AC-AD
I T S PB=$J(AB/T,0,2)*100,PL=$J(AE/T,0,2)*100
E S (PB,PC,PL)="N/A" ;avoid division by zero
I T S PC=$J(AC/T,0,2)*100
E S PC="N/A" ;avoid division by zero
I T S PA=$J(AE/T,0,2)*100
E S PA="N/A"
;S AD=AD-AB-AF-P100
I T S PD=$J(AD/T,0,2)*100
E S PD="N/A"
S SFC=AB+AD
I T S PSFC=$J(SFC/T,0,2)*100 ;avoid division by zero
E S PSFC="N/A"
S AE=AC-AD
I T S PE=$J(AE/T,0,2)*100
E S PE="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 IOPH
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
I $E(IOST,1,2)="C-" W ! K DIR S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR ; I 'Y S EX=U Q
K EROLDT,SROLDT,COCDATE,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,ONCOCDT,ONCORDT,ONCOCOC,ONCOCDTP,ONCORDTP
S VASITE=$O(^ONCO(160.1,"C",DUZ(2),0))
I VASITE="" S VASITE=$O(^ONCO(160.1,0))
S (ONCOCDT,ONCOCDTP,ONCORDTP,ONCORDT,SROLDT,EROLDT)=""
S ONCOCOC=$G(^ONCO(160.1,VASITE,7))
S (ROLDT,ONCOCDT,COCDATE)=$P(ONCOCOC,U,3)
S:$G(COCDATE) ONCOCDTP=$E(ONCOCDT,4,5)_"/"_$E(ONCOCDT,6,7)_"/"_($E(ONCOCDT,1,3)+1700)
I COCDATE="" S ONCOPARS=$G(^ONCO(160.1,VASITE,0)),(ROLDT,ONCOCDT,ONCORDT)=$P(ONCOPARS,U,4)
S:$G(ONCORDT) ONCORDTP=$E(ONCORDT,4,5)_"/"_$E(ONCORDT,6,7)_"/"_($E(ONCORDT,1,3)+1700)
S ROLDT=$E(ROLDT,1,1)_$E(ROLDT,2,3)_"0000"
S SROLDT=DT-170000,EROLDT=DT-20000
S SROLDT=$E(SROLDT,1,1)_$E(SROLDT,2,3)_"0000"
I ROLDT>SROLDT S SROLDT=ROLDT
S EROLDT=$E(EROLDT,1,1)_$E(EROLDT,2,3)_"0000"
I ONCOS("F")=2 D
.S SROLDT=DT-70000,SROLDT=$E(SROLDT,1,1)_$E(SROLDT,2,3)_"0000"
.I ROLDT>SROLDT S SROLDT=ROLDT
S XD0=SROLDT,EOF=0
;
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)'=3 Q ;patch #17, only process completed cases.
..S DATEDX=$P($G(^ONCO(165.5,XD1,0)),U,16)
..I ((DATEDX<SROLDT)!(DATEDX>EROLDT)) Q
..S COC=$E($$GET1^DIQ(165.5,XD1,.04),1,2)
..I (((COC<10)!((COC>14)&(COC<20)))!(COC>23)) Q ;P17, only class of case 10-14 and 20-22 included.
..E S AA=AA+1,^TMP($J,XD1)=""
.S XD0=$O(^ONCO(165.5,"ADX",XD0)),CC=AA
.I 'XD0 S EOF=1
Q
;
SUB ;Subtract patient > 100 y/o
;
N ONCAGE,ONCPT,LY,L365,IE160
S (LY,L365)=0
S IE160=$P(^ONCO(165.5,X0,0),U,2)
S ONCPT=$P(^ONCO(160,IE160,0),";",1)
S ONCAGE=$$PTAGE(ONCPT,DT) I ONCAGE>100 S P100=P100+1 D KILL Q
Q
;
PTAGE(DFN,DT) ;get pt age, supported IA=#10061
N ONCDAY,VADM
S:DT="" DT=$$DT^XLFDT()
D DEM^VADPT
S ONCDAY=$$FMDIFF^XLFDT(DT,$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 IE160=$P(^ONCO(165.5,X0,0),U,2)
S X1=$O(^ONCO(160,IE160,"F","AA",0)) I X1'="" S LC=$O(^(X1,0)),LY=$P(^ONCO(160,IE160,"F",LC,0),U,1)
I $G(LY) S X2=LY,X1=DT D ^%DTC S L365=X
I $G(L365) I (L365<456) S AD=AD+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 6234 printed May 21, 2025@23:43:44 Page 2
ONCOCOF ;HINES OIFO/GWB - [RS Registry Summary Reports - Follow Up] ;06/23/10
+1 ;;2.2;ONCOLOGY;**1,13,17**;Jul 31, 2013;Build 6
+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,ONCFDT,ROLDT
+3 SET DIC=164.2
SET DIC(0)="O"
+4 DO ^DIC
KILL DIC,X
+5 KILL ^TMP($JOB)
+6 SET (T,AB,AC,AD,AS,AF,AN,AA,CC,P100,AE)=0
+7 DO TOTCASE
+8 SET CC=AA
+9 SET X0=0
FOR
SET X0=$ORDER(^TMP($JOB,X0))
if X0'>0
QUIT
Begin DoDot:1
+10 SET ST=$PIECE($GET(^ONCO(165.5,X0,0)),U)
+11 SET MO=$$HIST^ONCFUNC(X0)
+12 SET DATEDX=$PIECE($GET(^ONCO(165.5,X0,0)),U,16)
+13 DO SUB
End DoDot:1
+14 SET (AB,AC,AE,AF)=0
+15 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
+16 ;patch #17, total cases minus foreign res minus pat > 100 y/o
SET T=CC-AF-P100
+17 SET FR=T_U_AB_U_AC_U_AS
+18 SET SFC=AB+AD
SET AC=T-AB
SET AE=AC-AD
+19 IF T
SET PB=$JUSTIFY(AB/T,0,2)*100
SET PL=$JUSTIFY(AE/T,0,2)*100
+20 ;avoid division by zero
IF '$TEST
SET (PB,PC,PL)="N/A"
+21 IF T
SET PC=$JUSTIFY(AC/T,0,2)*100
+22 ;avoid division by zero
IF '$TEST
SET PC="N/A"
+23 IF T
SET PA=$JUSTIFY(AE/T,0,2)*100
+24 IF '$TEST
SET PA="N/A"
+25 ;S AD=AD-AB-AF-P100
+26 IF T
SET PD=$JUSTIFY(AD/T,0,2)*100
+27 IF '$TEST
SET PD="N/A"
+28 SET SFC=AB+AD
+29 ;avoid division by zero
IF T
SET PSFC=$JUSTIFY(SFC/T,0,2)*100
+30 IF '$TEST
SET PSFC="N/A"
+31 SET AE=AC-AD
+32 IF T
SET PE=$JUSTIFY(AE/T,0,2)*100
+33 IF '$TEST
SET PE="N/A"
+34 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
+35 SET AS=$ORDER(^ONCO(160.1,"C",DUZ(2),0))
+36 IF AS=""
SET AS=$ORDER(^ONCO(160.1,0))
+37 SET ^ONCO(160.1,AS,"FR")=FR
+38 NEW IOPH
+39 IF ONCOS("F")=1
SET DIC=160.2
SET DIC(0)=""
SET X="FOLLOWUP RATE REPORT 1"
DO ^DIC
KILL DIC,X
+40 IF ONCOS("F")=2
SET DIC=160.2
SET DIC(0)=""
SET X="FOLLOWUP RATE REPORT"
DO ^DIC
KILL DIC,X
+41 SET IOP=ION
+42 SET DIWF="^ONCO(160.2,"_(+Y)_",1,"
SET DIWF(1)="160.1"
+43 SET BY="NUMBER"
+44 SET (FR,TO)=$ORDER(^ONCO(160.1,"C",DUZ(2),0))
+45 IF FR=""
SET (FR,TO)=$ORDER(^ONCO(160.1,0))
+46 WRITE !!
+47 DO EN2^DIWF
KILL DIWF,BY,FR,TO
SET IOP=ION
DO ^%ZIS
+48 ; I 'Y S EX=U Q
IF $EXTRACT(IOST,1,2)="C-"
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Enter RETURN to continue"
DO ^DIR
+49 KILL EROLDT,SROLDT,COCDATE,PA,PB,PC,PD,PE,PL,X0
+50 QUIT
+51 ;
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,ONCOCDT,ONCORDT,ONCOCOC,ONCOCDTP,ONCORDTP
+3 SET VASITE=$ORDER(^ONCO(160.1,"C",DUZ(2),0))
+4 IF VASITE=""
SET VASITE=$ORDER(^ONCO(160.1,0))
+5 SET (ONCOCDT,ONCOCDTP,ONCORDTP,ONCORDT,SROLDT,EROLDT)=""
+6 SET ONCOCOC=$GET(^ONCO(160.1,VASITE,7))
+7 SET (ROLDT,ONCOCDT,COCDATE)=$PIECE(ONCOCOC,U,3)
+8 if $GET(COCDATE)
SET ONCOCDTP=$EXTRACT(ONCOCDT,4,5)_"/"_$EXTRACT(ONCOCDT,6,7)_"/"_($EXTRACT(ONCOCDT,1,3)+1700)
+9 IF COCDATE=""
SET ONCOPARS=$GET(^ONCO(160.1,VASITE,0))
SET (ROLDT,ONCOCDT,ONCORDT)=$PIECE(ONCOPARS,U,4)
+10 if $GET(ONCORDT)
SET ONCORDTP=$EXTRACT(ONCORDT,4,5)_"/"_$EXTRACT(ONCORDT,6,7)_"/"_($EXTRACT(ONCORDT,1,3)+1700)
+11 SET ROLDT=$EXTRACT(ROLDT,1,1)_$EXTRACT(ROLDT,2,3)_"0000"
+12 SET SROLDT=DT-170000
SET EROLDT=DT-20000
+13 SET SROLDT=$EXTRACT(SROLDT,1,1)_$EXTRACT(SROLDT,2,3)_"0000"
+14 IF ROLDT>SROLDT
SET SROLDT=ROLDT
+15 SET EROLDT=$EXTRACT(EROLDT,1,1)_$EXTRACT(EROLDT,2,3)_"0000"
+16 IF ONCOS("F")=2
Begin DoDot:1
+17 SET SROLDT=DT-70000
SET SROLDT=$EXTRACT(SROLDT,1,1)_$EXTRACT(SROLDT,2,3)_"0000"
+18 IF ROLDT>SROLDT
SET SROLDT=ROLDT
End DoDot:1
+19 SET XD0=SROLDT
SET EOF=0
+20 ;
+21 FOR
Begin DoDot:1
+22 SET XD1=""
+23 FOR
SET XD1=$ORDER(^ONCO(165.5,"ADX",XD0,XD1))
if 'XD1
QUIT
IF $$DIV^ONCFUNC(XD1)=DUZ(2)
Begin DoDot:2
+24 ;patch #17, only process completed cases.
IF $PIECE($GET(^ONCO(165.5,XD1,7)),U,2)'=3
QUIT
+25 SET DATEDX=$PIECE($GET(^ONCO(165.5,XD1,0)),U,16)
+26 IF ((DATEDX<SROLDT)!(DATEDX>EROLDT))
QUIT
+27 SET COC=$EXTRACT($$GET1^DIQ(165.5,XD1,.04),1,2)
+28 ;P17, only class of case 10-14 and 20-22 included.
IF (((COC<10)!((COC>14)&(COC<20)))!(COC>23))
QUIT
+29 IF '$TEST
SET AA=AA+1
SET ^TMP($JOB,XD1)=""
End DoDot:2
+30 SET XD0=$ORDER(^ONCO(165.5,"ADX",XD0))
SET CC=AA
+31 IF 'XD0
SET EOF=1
End DoDot:1
if EOF
QUIT
+32 QUIT
+33 ;
SUB ;Subtract patient > 100 y/o
+1 ;
+2 NEW ONCAGE,ONCPT,LY,L365,IE160
+3 SET (LY,L365)=0
+4 SET IE160=$PIECE(^ONCO(165.5,X0,0),U,2)
+5 SET ONCPT=$PIECE(^ONCO(160,IE160,0),";",1)
+6 SET ONCAGE=$$PTAGE(ONCPT,DT)
IF ONCAGE>100
SET P100=P100+1
DO KILL
QUIT
+7 QUIT
+8 ;
PTAGE(DFN,DT) ;get pt age, supported IA=#10061
+1 NEW ONCDAY,VADM
+2 if DT=""
SET DT=$$DT^XLFDT()
+3 DO DEM^VADPT
+4 SET ONCDAY=$$FMDIFF^XLFDT(DT,$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 IE160=$PIECE(^ONCO(165.5,X0,0),U,2)
+7 SET X1=$ORDER(^ONCO(160,IE160,"F","AA",0))
IF X1'=""
SET LC=$ORDER(^(X1,0))
SET LY=$PIECE(^ONCO(160,IE160,"F",LC,0),U,1)
+8 IF $GET(LY)
SET X2=LY
SET X1=DT
DO ^%DTC
SET L365=X
+9 IF $GET(L365)
IF (L365<456)
SET AD=AD+1
+10 QUIT
+11 ;
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
