ONCACD1 ;HINES OIFO/GWB - Extract NAACCR/STATE/VACCR data ;09/06/11
;;2.2;ONCOLOGY;**1,4,5,8,9,13,14,15,17,18**;Jul 31, 2013;Build 5
;
;P5 added in RQRS the Analytic Cases selection.
;P8 allows BLANK in TNM Clin/Path data fields & others.
;P9 discard in State Extract - COC=34 & Analytic=NO
EN1 ;Entry point
K ^TMP($J)
N EXPORT,PAGE,STOPDT,OIEN,ZTREQ
;P18
I $D(EDT),($P(EDT,".",2))="" S EDT=EDT_.2500
I $D(DATE1),($P(DATE1,".",2))="" S DATE1=DATE1_.2500
S PAGE=1,OIEN=0
S EXPORT="YES"
D SETUP
I 'DEVICE W $C(26) H 30
Q
;
SETUP ;Loop through appropriate cross-reference
I 'DEVICE S X=0 X ^%ZOSF("RM") ;Disable autowrap
N BLANK,DCLC,FDNUM,IEN,NC,NINE,TPG,ZERO,ZNINE,X
S BLANK=" "
S (IEN,ZERO)=0
S NINE=9,ZNINE="09"
S OUT=$G(OUT,0)
;P14
N ONCX21,ONCDTNW,ONCDT,ONCPRNT,ONCIE160,ONCTZONE
S ONCPRNT=0
I ('DEVICE),((EXTRACT=3)!(EXTRACT=5)!(EXTRACT=6)!(EXTRACT=7)) D
.N ONC11,ONC22,ONC33,ONC44,ONC55,ONCNN,ONCPP,ONCTT,ONCDTIME,ONCDIC,ONCTYPE,ONCXPRT,ONCTHR,ONCTMN,ONCTSN
.S ONCT=$$NOW^XLFDT()
.S ONCTZONE=$$TZ^XLFDT()
.S ONCTHR=$E(ONCT,9,10),ONCTMN=$E(ONCT,11,12),ONCTSN=$E(ONCT,13,14)
.S:ONCTSN="" ONCTSN="00"
.S:($L(ONCTSN)=1) ONCTSN="0"_ONCTSN
.S ONCTSN=ONCTSN_".000"_$E(ONCTZONE,1,3)_":"_$E(ONCTZONE,4,5)
.S ONCDTNW=""""_(1700+$E(ONCT,1,3))_"-"_$E(ONCT,4,5)_"-"_$E(ONCT,6,7)_"T"_ONCTHR_":"_ONCTMN_":"_ONCTSN_""""
.S ONCX21=1
.S ONCTYPE="""A"""
.I EXTRACT=7 S ONCTYPE="""I"""
.S ONCDIC="""http://naaccr.org/naaccrxml/naaccr-dictionary-220.xml"""
.S ONC11=" baseDictionaryUri="
.S ONC22=" recordType=",ONC33=" timeGenerated=",ONC44=" specificationVersion="
.W "<?xml version=""1.0"" encoding=""UTF-8""?>",!
.W "<NaaccrData xmlns=""http://naaccr.org/naaccrxml""",ONC11,ONCDIC,!
.W ONC22,ONCTYPE,ONC33,ONCDTNW,ONC44,"""1.4""",">"
.S ONCXPRT=1
;
;NCDB EXTRACT
;Loop through DATE DX (165.5,3) "ADX" cross-reference
S ONCDT=DATE
I STEXT=0 F S ONCDT=$O(^ONCO(165.5,"ADX",ONCDT)) Q:(ONCDT>DATE1)!(ONCDT="") S IEN=0 F S IEN=$O(^ONCO(165.5,"ADX",ONCDT,IEN)) Q:IEN="" I $$DIV^ONCFUNC(IEN)=DUZ(2) D Q:OUT
.I $G(NCDB)=2 S DCLC=$P($G(^ONCO(165.5,IEN,7)),U,21) Q:(DCLC<SDT)!(DCLC>EDT)
.I $G(NCDB)=3 S ACCN=$P($G(^ONCO(165.5,IEN,0)),U,5) Q:(ACCN<SDT)!(ACCN>EDT)
.D LOOP
;
;VACCR/STATE EXTRACT
;Loop through DATE CASE COMPLETED (165.5,90) "AAD" cross-reference
I ($G(STEXT)=1),($G(ONCLDT)=1) S SDT=SDT-.00001 F S SDT=$O(^ONCO(165.5,"AAD",SDT)) Q:(SDT<1)!(SDT>EDT)!(OUT=1) F S IEN=$O(^ONCO(165.5,"AAD",SDT,IEN)) Q:IEN<1 I $$DIV^ONCFUNC(IEN)=DUZ(2) D Q:OUT
.Q:$G(^ONCO(165.5,IEN,0))=""
.D LOOP
;Loop through DATE CASE LAST CHANGED (165.5,198) "AAE" cross-reference
I ($G(STEXT)=1),($G(ONCLDT)=2) S SDT=SDT-.00001 F S SDT=$O(^ONCO(165.5,"AAE",SDT)) Q:(SDT<1)!(SDT>EDT)!(OUT=1) F S IEN=$O(^ONCO(165.5,"AAE",SDT,IEN)) Q:IEN<1 I $$DIV^ONCFUNC(IEN)=DUZ(2) D Q:OUT
.Q:$G(^ONCO(165.5,IEN,0))=""
.D LOOP
;Loop through ACCESSION NUMBER (165.5,.05) "AA" cross-reference
I ($G(STEXT)=1),($G(ONCLDT)=3) S SDT=SDT-1 F S SDT=$O(^ONCO(165.5,"AA",SDT)) Q:(SDT<1)!(SDT>EDT)!(OUT=1) F S IEN=$O(^ONCO(165.5,"AA",SDT,IEN)) Q:IEN<1 I $$DIV^ONCFUNC(IEN)=DUZ(2) D Q:OUT
.Q:$G(^ONCO(165.5,IEN,0))=""
.D LOOP
;
;VACCR/STATE EXTRACT
;Loop through DATE CASE LAST CHANGED (165.5,198) "AAE" cross-reference
I ($G(STEXT)=2) S SDT=SDT-1 F S SDT=$O(^ONCO(165.5,"AAE",SDT)) Q:(SDT<1)!(SDT>EDT)!(OUT=1) F S IEN=$O(^ONCO(165.5,"AAE",SDT,IEN)) Q:IEN<1 I $$DIV^ONCFUNC(IEN)=DUZ(2) D Q:OUT
.Q:$G(^ONCO(165.5,IEN,0))=""
.D LOOP
;
;RQRS EXTRACT
;Loop through DATE DX (165.5,3) "ADX" cross-reference
I ($G(STEXT)=3),($G(ONCLDT)=1) S SDT=SDT-1 F S SDT=$O(^ONCO(165.5,"ADX",SDT)) Q:(SDT<1)!(SDT>EDT)!(OUT=1) F S IEN=$O(^ONCO(165.5,"ADX",SDT,IEN)) Q:IEN<1 I $$DIV^ONCFUNC(IEN)=DUZ(2) D Q:OUT
.Q:$G(^ONCO(165.5,IEN,0))=""
.S TPG=$P($G(^ONCO(165.5,IEN,2)),U,1)
.S NC=0
.F FDNUM=.03,.05,.06,3,20,22.3 I $$GET1^DIQ(165.5,IEN,FDNUM,"I")="" S NC=1
.Q:NC=1
.S ONCCLCA=$E($$GET1^DIQ(165.5,IEN,.04),1,2)
.I ($G(ONCR12)=2),(ONCCLCA<23) D LOOP Q
.I ($G(ONCR12)=1),(($E(TPG,3,4)=50)!($E(TPG,3,4)=18)!($E(TPG,3,4)=20))&(TPG'=67181) D LOOP ; screen out 67181 (appendix) cases - p2.2*4
;
;Loop through DATE CASE LAST CHANGED (165.5,198) "AAE" cross-reference
;Quit if "ADX" is before 2008 - p2.2*4
I ($G(STEXT)=3),($G(ONCLDT)=2) S SDT=SDT-.00001 F S SDT=$O(^ONCO(165.5,"AAE",SDT)) Q:(SDT<1)!(SDT>EDT)!(OUT=1) F S IEN=$O(^ONCO(165.5,"AAE",SDT,IEN)) Q:IEN<1 I $$DIV^ONCFUNC(IEN)=DUZ(2) D Q:OUT
.Q:$G(^ONCO(165.5,IEN,0))=""
.Q:$P($G(^ONCO(165.5,IEN,0)),U,16)<3060101
.S TPG=$P($G(^ONCO(165.5,IEN,2)),U,1)
.S NC=0
.F FDNUM=.03,.05,.06,3,20,22.3 I $$GET1^DIQ(165.5,IEN,FDNUM,"I")="" S NC=1
.Q:NC=1
.S ONCCLCA=$E($$GET1^DIQ(165.5,IEN,.04),1,2)
.I ($G(ONCR12)=2),(ONCCLCA<23) D LOOP Q
.I ($G(ONCR12)=1),($E(TPG,3,4)=50)!($E(TPG,3,4)=18)!($E(TPG,3,4)=20)&(TPG'=67181) D LOOP
;
;Loop through ACCESSION NUMBER (165.5,.05) "AA" cross-reference
I ($G(STEXT)=3),($G(ONCLDT)=3) S SDT=SDT-1 F S SDT=$O(^ONCO(165.5,"AA",SDT)) Q:(SDT<1)!(SDT>EDT)!(OUT=1) F S IEN=$O(^ONCO(165.5,"AA",SDT,IEN)) Q:IEN<1 I $$DIV^ONCFUNC(IEN)=DUZ(2) D Q:OUT
.Q:$G(^ONCO(165.5,IEN,0))=""
.Q:$P($G(^ONCO(165.5,IEN,0)),U,16)<3060101
.S TPG=$P($G(^ONCO(165.5,IEN,2)),U,1)
.S NC=0
.F FDNUM=.03,.05,.06,3,20,22.3 I $$GET1^DIQ(165.5,IEN,FDNUM,"I")="" S NC=1
.Q:NC=1
.S ONCCLCA=$E($$GET1^DIQ(165.5,IEN,.04),1,2)
.I ($G(ONCR12)=2),(ONCCLCA<23) D LOOP Q
.I ($G(ONCR12)=1),($E(TPG,3,4)=50)!($E(TPG,3,4)=18)!($E(TPG,3,4)=20)&(TPG'=67181) D LOOP
I ('DEVICE),$G(ONCPRNT)>20,((EXTRACT=3)!(EXTRACT=5)!(EXTRACT=6)!(EXTRACT=7)) D
.W !,?5,"</Tumor>"
.W !,?3,"</Patient>"
.W !,"</NaaccrData>",!
Q
;
LOOP ;Apply extract selection rules
;P#9
;P#13
Q:OUT
I ($G(EXTRACT)=2)!($G(EXTRACT)=5),($E($$GET1^DIQ(165.5,IEN,.04),1,2)=34),($G(ACO)=0) Q
N LINE,RULES,VALID,JUMP
S RULES=0
F S RULES=$O(^ONCO(160.16,EXTRACT,"RULES",RULES)) Q:RULES<1 D
.S LINE=^ONCO(160.16,EXTRACT,"RULES",RULES,0)
.X LINE
Q:'VALID
S ^TMP($J,IEN)=""
D OUTPUT(IEN,EXTRACT,JUMP,.OUT)
;I 'DEVICE W !
Q
;
OUTPUT(IEN,EXTRACT,JUMP,OUT) ;Output
S ACD160=$P(^ONCO(165.5,IEN,0),U,2)
I DEVICE D HEAD(IEN,.OUT) Q:OUT
N POS S POS=0
;P14 xml format
I $G(ONCX21)=1 D Q
.Q:$D(ONCIE160(IEN))
.W:$G(ONCPRNT)>20 !,?5,"</Tumor>"
.W:$G(ONCPRNT)>20 !,?3,"</Patient>"
.D XML21
.;S ONCPRNT=1
.S ONCXPRT=1
.Q
F S POS=$O(^ONCO(160.16,EXTRACT,"FIELD","B",POS)) Q:POS<1 D Q:OUT
.N NODE S NODE=0
.F S NODE=$O(^ONCO(160.16,EXTRACT,"FIELD","B",POS,NODE)) Q:NODE<1 D Q:OUT
..N STRING,DEFAULT,FILL,LEN
..Q:$G(^ONCO(160.16,EXTRACT,"FIELD",NODE,0))=""
..D DISPLAY(DEVICE,$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,1)_U_$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,4),.OUT)
..Q:OUT
..S LEN=$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,2)
..S STRING=$TR(^ONCO(160.16,EXTRACT,"FIELD",NODE,1),"~","^")
..S DEFAULT=$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,2),U,1)
..S FILL=$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,3),U,1)
..D DATA(IEN,ACD160,STRING,DEFAULT,FILL,LEN,JUMP,NODE,POS)
..;=========================================================
..; This Code supports the PCE Extracts (currently disabled)
..;=========================================================
..I $G(^ONCO(160.16,EXTRACT,0))["ZZNCDB" D
...I $O(^ONCO(160.16,EXTRACT,"FIELD","B",POS))>1 Q ;QUIT if not end
...N EXTRACT,NODE,POS
...S EXTRACT=100,JUMP=0
...;S:$D(^ONCO(165.5,"APCE","BLA",IEN)) EXTRACT=1
...; ^==== Bladder 95,90,85
...;S:$D(^ONCO(165.5,"APCE","THY",IEN)) EXTRACT=2
...; ^==== Thyroid 96,91,86
...;S:$D(^ONCO(165.5,"APCE","STS",IEN)) EXTRACT=3
...; ^==== Soft Tissue 96,91,86
...;S:$D(^ONCO(165.5,"APCE","COL",IEN)) EXTRACT=4
...; ^==== Colorectal 97,92,87
...;S:$D(^ONCO(165.5,"APCE","NHL",IEN)) EXTRACT=5
...; ^==== Non-Hodgkins 97,92,87
...;S:$D(^ONCO(165.5,"APCE","BRE",IEN)) EXTRACT=6
...; ^==== Breast 98,93,88
...;S:$D(^ONCO(165.5,"APCE","PRO2",IEN)) EXTRACT=7
...; ^==== Prostate 98,93,88
...;S:$D(^ONCO(165.5,"APCE","MEL",IEN)) EXTRACT=8
...; ^==== Melanoma 99,94,89
...;S:$D(^ONCO(165.5,"APCE","HEP",IEN)) EXTRACT=9
...; ^==== Hepatocellular Cancers 00,95,90
...;S:$D(^ONCO(165.5,"APCE","CNS",IEN)) EXTRACT=10
...; ^==== Primary Intracranial/CNS Tumors 00,95,90
...;S:$D(^ONCO(165.5,"APCE","LNG",IEN)) EXTRACT=11
...; ^==== Lung (NSCLC) 01,96,91
...;S:$D(^ONCO(165.5,"APCE","GAS",IEN)) EXTRACT=12
...; ^==== Gastric Cancers 01,96,91
...S POS=0
...F S POS=$O(^ONCO(160.17,EXTRACT,"FIELD","B",POS)) Q:POS<1 D Q:OUT
....N NODE S NODE=0
....F S NODE=$O(^ONCO(160.17,EXTRACT,"FIELD","B",POS,NODE)) Q:NODE<1 D Q:OUT
.....N DEFAULT,FILL,LEN,STRING
.....Q:$G(^ONCO(160.17,EXTRACT,"FIELD",NODE,0))=""
.....D DISPLAY(DEVICE,$P(^ONCO(160.17,EXTRACT,"FIELD",NODE,0),U,1)_U_$P(^ONCO(160.17,EXTRACT,"FIELD",NODE,0),U,4),.OUT)
.....Q:OUT
.....S STRING=$TR(^ONCO(160.17,EXTRACT,"FIELD",NODE,1),"~","^")
.....S DEFAULT=^ONCO(160.17,EXTRACT,"FIELD",NODE,2)
.....S FILL=^ONCO(160.17,EXTRACT,"FIELD",NODE,3)
.....S LEN=$P(^ONCO(160.17,EXTRACT,"FIELD",NODE,0),U,2)
.....D DATA(IEN,ACD160,STRING,DEFAULT,FILL,LEN,JUMP,NODE,POS)
Q
;
HEAD(IEN,OUT) ;Preview End-of-Page
N FLG
I IEN=OIEN S FLG=0
I IEN'=OIEN S OIEN=IEN,FLG=1
I 'FLG Q:$Y+4<IOSL
I PAGE'=1 D Q:OUT
.Q:$E(IOST,1,2)'="C-"
.N DIR,Y
.S DIR(0)="E" D ^DIR
.I 'Y S OUT=1 Q
D HEADER
Q
;
I PAGE'=1 W @IOF
I PAGE=1,$E(IOST,1,2)="C-" W @IOF
I STEXT=3 W !,"RCRS EXTRACT",?70,"Page: ",PAGE S PAGE=PAGE+1
E W !,$P(^ONCO(160.16,EXTRACT,0),U),?70,"Page: ",PAGE S PAGE=PAGE+1
W !,"Patient: ",$$GET1^DIQ(160,ACD160,.01,"E")
W ?55,"SSN: ",$$GET1^DIQ(160,ACD160,2,"E")
W !,"Col#",?5,"Item name",?51,"Value",!
F I=1:1:79 W "="
Q
XML21 ;P14
N ONCRTYP,ONCOLD,ONCPOS
S ONCOLD="TEST",(ONCPOS,POS)="A",ONCRTYP=""
S ONCIE160(IEN)=IEN
F S POS=$O(^ONCO(160.16,EXTRACT,"FIELD","D",POS)) Q:POS="" D Q:OUT
.N NODE,ONCXDATA S NODE=0
.;I POS="N" S ONCRTYP="<NaaccrData>"
.I POS="P" S ONCRTYP="<Patient>"
.I POS="T" S ONCRTYP="<Tumor>"
.F S NODE=$O(^ONCO(160.16,EXTRACT,"FIELD","D",POS,NODE)) Q:NODE<1 D Q:OUT
..N STRING,DEFAULT,FILL,LEN,ONCXDATA
..Q:$G(^ONCO(160.16,EXTRACT,"FIELD",NODE,0))=""
..S ONCXDATA=$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,5)
..Q:ONCXDATA=""
..I (POS'=ONCPOS),(ONCOLD'=ONCRTYP),(ONCRTYP'="") D
...W:POS="P" !,?3,ONCRTYP
...W:POS="T" !,?5,ONCRTYP
...S ONCOLD=ONCRTYP,ONCPOS=POS
..;D DISPLAY(DEVICE,$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,1)_U_$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,4),.OUT)
..;Q:OUT
..S LEN=$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,2)
..S STRING=$TR(^ONCO(160.16,EXTRACT,"FIELD",NODE,1),"~","^")
..S DEFAULT=$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,2),U,1)
..S FILL=$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,3),U,1)
..D DATA(IEN,ACD160,STRING,DEFAULT,FILL,LEN,JUMP,NODE,POS)
.S ONCXPRT=1
Q
;
DISPLAY(DEVICE,WRITE,OUT) ; Display preview
Q:'DEVICE
N DOTS,COL,ITEM
I DEVICE,($Y+5)>IOSL D HEAD(0,.OUT) Q:OUT
S COL=$P(WRITE,U,1)
S COL=$S($L(COL)=1:" "_COL,$L(COL)=2:" "_COL,$L(COL)=3:" "_COL,1:COL)
S ITEM=$P(WRITE,U,2),ITEM=$E(ITEM,1,45)
S DOTS=(46-$L(ITEM))
W !,COL,?5,ITEM
F I=1:1:DOTS W "."
Q
;
DATA(IEN,ACD160,STRING,DEFAULT,FILL,LEN,JUMP,NODE,POS) ;Compute extract value
N ACDANS,EXIT S EXIT=0
I $G(ONCX21)=1 D Q
.I $G(ONCPRNT)>20,(POS="N") Q
.X STRING
.;If value = "", extract DEFAULT value
.I (ACDANS=""),(DEFAULT="BLANK") Q
.N I,X S X=""
.I DEFAULT=8 D
..F I=1:1:LEN S ACDANS=ACDANS_@DEFAULT
.I @DEFAULT="09" S ACDANS=@DEFAULT
.;F I=1:1:LEN S ACDANS=ACDANS_@DEFAULT
.I (ACDANS["&")!(ACDANS["<")!(ACDANS[">") D STRIP
.D XFILL
.I ('DEVICE),(ACDANS=""),((EXTRACT=3)!(EXTRACT=5)!(EXTRACT=6)!(EXTRACT=7)) Q
.W:POS="N" !,?2
.W:POS="P" !,?5
.W:POS="T" !,?7
.W "<Item naaccrId=""",ONCXDATA,""">",ACDANS,"</Item>"
.S ONCPRNT=ONCPRNT+1
.Q
I JUMP'="0" D
.I POS<$P(JUMP,U) Q
.I POS>$P(JUMP,U,2) Q
.N I
.S EXIT=1
.F I=1:1:LEN W BLANK
Q:EXIT
X STRING
;
;If value = "", extract DEFAULT value
I ACDANS="" D Q
.N I,X S X=""
.I DEFAULT=8 D Q
..F I=1:1:LEN W DEFAULT
.I @DEFAULT="09" W @DEFAULT Q
.F I=1:1:LEN W @DEFAULT
;
;If value too long, truncate to LENGTH (160.161,1)
;If value too short, pad with FILL (160.161,6)
I $L(ACDANS)=LEN W ACDANS Q
I $L(ACDANS)>LEN W $E(ACDANS,1,LEN) Q
E D Q
.N JUST,STUFF,I,REM,CAL
.S JUST=$P(FILL,","),STUFF=$P(FILL,",",2)
.S REM=LEN-$L(ACDANS)
.I JUST="R" W ACDANS
.F I=1:1:REM W @STUFF
.I JUST="L" W ACDANS
Q
XFILL ;Truncate or pad xml fields
I $L(ACDANS)=LEN Q
I $L(ACDANS)>LEN S ACDANS=$E(ACDANS,1,LEN) Q
E D Q
.N JUST,STUFF,I,REM,CAL,LACDANS
.S LACDANS=""
.S JUST=$P(FILL,","),STUFF=$P(FILL,",",2),STUFF=$P(STUFF,"^")
.Q:STUFF="BLANK"
.S:STUFF="ZERO" STUFF=0
.S:STUFF="NINE" STUFF=9
.S REM=LEN-$L(ACDANS)
.F I=1:1:REM S:JUST="R" ACDANS=ACDANS_STUFF S:JUST="L" LACDANS=LACDANS_STUFF
.I JUST="L" S ACDANS=LACDANS_ACDANS
Q
STRIP ;replace special characters
N AA,BB,X1
S BB=""
F I=1:1:($L(ACDANS)) Q:I'>0 D
.S (AA,X1)=$E(ACDANS,I)
.S:X1="&" AA=" and "
.S:X1=">" AA=" GT "
.S:X1="<" AA=" LT "
.S:X1="$" AA=" "
.S BB=BB_AA
S ACDANS=BB
Q
RCRS ;RCRS exeption rules
I ($P(TPG,3,4)=44),((MPGH>79999)&(MPGH<81109)) S VALID=0
I (MPGH=80772),(($P(TPG,3,5)=619)!($P(TPG,3,5)=529)) S VALID=0
I (MPGH=80772),(($P(TPG,3,4)=51)!($P(TPG,3,4)=21)!$P(TPG,3,4)=32) S VALID=0
I (DATEDX>3220000),(($P(TPG,3,5)>159)&($P(TPG,3,5)<167)),((MPGH=82112)!(MPGHD=82612)!(MPGH=82632)) S VALID=0
I (DATEDX>3220000),(($P(TPG,3,5)>167)&($P(TPG,3,5)<174)),((MPGH=82112)!(MPGHD=82612)!(MPGH=82632)) S VALID=0
I (DATEDX>3220000),(($P(TPG,3,5)>177)&($P(TPG,3,5)<180)),((MPGH=82112)!(MPGHD=82612)!(MPGH=82632)) S VALID=0
I (DATEDX>3220000),($P(TPG,3,5)=53),((MPGH=84832)!(MPGHD=84842)) S VALID=0
Q
;
CLEANUP ;Cleanup
K DATE,EDT,NCDB,SDT,STEXT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCACD1 14048 printed Oct 16, 2024@18:22:42 Page 2
ONCACD1 ;HINES OIFO/GWB - Extract NAACCR/STATE/VACCR data ;09/06/11
+1 ;;2.2;ONCOLOGY;**1,4,5,8,9,13,14,15,17,18**;Jul 31, 2013;Build 5
+2 ;
+3 ;P5 added in RQRS the Analytic Cases selection.
+4 ;P8 allows BLANK in TNM Clin/Path data fields & others.
+5 ;P9 discard in State Extract - COC=34 & Analytic=NO
EN1 ;Entry point
+1 KILL ^TMP($JOB)
+2 NEW EXPORT,PAGE,STOPDT,OIEN,ZTREQ
+3 ;P18
+4 IF $DATA(EDT)
IF ($PIECE(EDT,".",2))=""
SET EDT=EDT_.2500
+5 IF $DATA(DATE1)
IF ($PIECE(DATE1,".",2))=""
SET DATE1=DATE1_.2500
+6 SET PAGE=1
SET OIEN=0
+7 SET EXPORT="YES"
+8 DO SETUP
+9 IF 'DEVICE
WRITE $CHAR(26)
HANG 30
+10 QUIT
+11 ;
SETUP ;Loop through appropriate cross-reference
+1 ;Disable autowrap
IF 'DEVICE
SET X=0
XECUTE ^%ZOSF("RM")
+2 NEW BLANK,DCLC,FDNUM,IEN,NC,NINE,TPG,ZERO,ZNINE,X
+3 SET BLANK=" "
+4 SET (IEN,ZERO)=0
+5 SET NINE=9
SET ZNINE="09"
+6 SET OUT=$GET(OUT,0)
+7 ;P14
+8 NEW ONCX21,ONCDTNW,ONCDT,ONCPRNT,ONCIE160,ONCTZONE
+9 SET ONCPRNT=0
+10 IF ('DEVICE)
IF ((EXTRACT=3)!(EXTRACT=5)!(EXTRACT=6)!(EXTRACT=7))
Begin DoDot:1
+11 NEW ONC11,ONC22,ONC33,ONC44,ONC55,ONCNN,ONCPP,ONCTT,ONCDTIME,ONCDIC,ONCTYPE,ONCXPRT,ONCTHR,ONCTMN,ONCTSN
+12 SET ONCT=$$NOW^XLFDT()
+13 SET ONCTZONE=$$TZ^XLFDT()
+14 SET ONCTHR=$EXTRACT(ONCT,9,10)
SET ONCTMN=$EXTRACT(ONCT,11,12)
SET ONCTSN=$EXTRACT(ONCT,13,14)
+15 if ONCTSN=""
SET ONCTSN="00"
+16 if ($LENGTH(ONCTSN)=1)
SET ONCTSN="0"_ONCTSN
+17 SET ONCTSN=ONCTSN_".000"_$EXTRACT(ONCTZONE,1,3)_":"_$EXTRACT(ONCTZONE,4,5)
+18 SET ONCDTNW=""""_(1700+$EXTRACT(ONCT,1,3))_"-"_$EXTRACT(ONCT,4,5)_"-"_$EXTRACT(ONCT,6,7)_"T"_ONCTHR_":"_ONCTMN_":"_ONCTSN_""""
+19 SET ONCX21=1
+20 SET ONCTYPE="""A"""
+21 IF EXTRACT=7
SET ONCTYPE="""I"""
+22 SET ONCDIC="""http://naaccr.org/naaccrxml/naaccr-dictionary-220.xml"""
+23 SET ONC11=" baseDictionaryUri="
+24 SET ONC22=" recordType="
SET ONC33=" timeGenerated="
SET ONC44=" specificationVersion="
+25 WRITE "<?xml version=""1.0"" encoding=""UTF-8""?>",!
+26 WRITE "<NaaccrData xmlns=""http://naaccr.org/naaccrxml""",ONC11,ONCDIC,!
+27 WRITE ONC22,ONCTYPE,ONC33,ONCDTNW,ONC44,"""1.4""",">"
+28 SET ONCXPRT=1
End DoDot:1
+29 ;
+30 ;NCDB EXTRACT
+31 ;Loop through DATE DX (165.5,3) "ADX" cross-reference
+32 SET ONCDT=DATE
+33 IF STEXT=0
FOR
SET ONCDT=$ORDER(^ONCO(165.5,"ADX",ONCDT))
if (ONCDT>DATE1)!(ONCDT="")
QUIT
SET IEN=0
FOR
SET IEN=$ORDER(^ONCO(165.5,"ADX",ONCDT,IEN))
if IEN=""
QUIT
IF $$DIV^ONCFUNC(IEN)=DUZ(2)
Begin DoDot:1
+34 IF $GET(NCDB)=2
SET DCLC=$PIECE($GET(^ONCO(165.5,IEN,7)),U,21)
if (DCLC<SDT)!(DCLC>EDT)
QUIT
+35 IF $GET(NCDB)=3
SET ACCN=$PIECE($GET(^ONCO(165.5,IEN,0)),U,5)
if (ACCN<SDT)!(ACCN>EDT)
QUIT
+36 DO LOOP
End DoDot:1
if OUT
QUIT
+37 ;
+38 ;VACCR/STATE EXTRACT
+39 ;Loop through DATE CASE COMPLETED (165.5,90) "AAD" cross-reference
+40 IF ($GET(STEXT)=1)
IF ($GET(ONCLDT)=1)
SET SDT=SDT-.00001
FOR
SET SDT=$ORDER(^ONCO(165.5,"AAD",SDT))
if (SDT<1)!(SDT>EDT)!(OUT=1)
QUIT
FOR
SET IEN=$ORDER(^ONCO(165.5,"AAD",SDT,IEN))
if IEN<1
QUIT
IF $$DIV^ONCFUNC(IEN)=DUZ(2)
Begin DoDot:1
+41 if $GET(^ONCO(165.5,IEN,0))=""
QUIT
+42 DO LOOP
End DoDot:1
if OUT
QUIT
+43 ;Loop through DATE CASE LAST CHANGED (165.5,198) "AAE" cross-reference
+44 IF ($GET(STEXT)=1)
IF ($GET(ONCLDT)=2)
SET SDT=SDT-.00001
FOR
SET SDT=$ORDER(^ONCO(165.5,"AAE",SDT))
if (SDT<1)!(SDT>EDT)!(OUT=1)
QUIT
FOR
SET IEN=$ORDER(^ONCO(165.5,"AAE",SDT,IEN))
if IEN<1
QUIT
IF $$DIV^ONCFUNC(IEN)=DUZ(2)
Begin DoDot:1
+45 if $GET(^ONCO(165.5,IEN,0))=""
QUIT
+46 DO LOOP
End DoDot:1
if OUT
QUIT
+47 ;Loop through ACCESSION NUMBER (165.5,.05) "AA" cross-reference
+48 IF ($GET(STEXT)=1)
IF ($GET(ONCLDT)=3)
SET SDT=SDT-1
FOR
SET SDT=$ORDER(^ONCO(165.5,"AA",SDT))
if (SDT<1)!(SDT>EDT)!(OUT=1)
QUIT
FOR
SET IEN=$ORDER(^ONCO(165.5,"AA",SDT,IEN))
if IEN<1
QUIT
IF $$DIV^ONCFUNC(IEN)=DUZ(2)
Begin DoDot:1
+49 if $GET(^ONCO(165.5,IEN,0))=""
QUIT
+50 DO LOOP
End DoDot:1
if OUT
QUIT
+51 ;
+52 ;VACCR/STATE EXTRACT
+53 ;Loop through DATE CASE LAST CHANGED (165.5,198) "AAE" cross-reference
+54 IF ($GET(STEXT)=2)
SET SDT=SDT-1
FOR
SET SDT=$ORDER(^ONCO(165.5,"AAE",SDT))
if (SDT<1)!(SDT>EDT)!(OUT=1)
QUIT
FOR
SET IEN=$ORDER(^ONCO(165.5,"AAE",SDT,IEN))
if IEN<1
QUIT
IF $$DIV^ONCFUNC(IEN)=DUZ(2)
Begin DoDot:1
+55 if $GET(^ONCO(165.5,IEN,0))=""
QUIT
+56 DO LOOP
End DoDot:1
if OUT
QUIT
+57 ;
+58 ;RQRS EXTRACT
+59 ;Loop through DATE DX (165.5,3) "ADX" cross-reference
+60 IF ($GET(STEXT)=3)
IF ($GET(ONCLDT)=1)
SET SDT=SDT-1
FOR
SET SDT=$ORDER(^ONCO(165.5,"ADX",SDT))
if (SDT<1)!(SDT>EDT)!(OUT=1)
QUIT
FOR
SET IEN=$ORDER(^ONCO(165.5,"ADX",SDT,IEN))
if IEN<1
QUIT
IF $$DIV^ONCFUNC(IEN)=DUZ(2)
Begin DoDot:1
+61 if $GET(^ONCO(165.5,IEN,0))=""
QUIT
+62 SET TPG=$PIECE($GET(^ONCO(165.5,IEN,2)),U,1)
+63 SET NC=0
+64 FOR FDNUM=.03,.05,.06,3,20,22.3
IF $$GET1^DIQ(165.5,IEN,FDNUM,"I")=""
SET NC=1
+65 if NC=1
QUIT
+66 SET ONCCLCA=$EXTRACT($$GET1^DIQ(165.5,IEN,.04),1,2)
+67 IF ($GET(ONCR12)=2)
IF (ONCCLCA<23)
DO LOOP
QUIT
+68 ; screen out 67181 (appendix) cases - p2.2*4
IF ($GET(ONCR12)=1)
IF (($EXTRACT(TPG,3,4)=50)!($EXTRACT(TPG,3,4)=18)!($EXTRACT(TPG,3,4)=20))&(TPG'=67181)
DO LOOP
End DoDot:1
if OUT
QUIT
+69 ;
+70 ;Loop through DATE CASE LAST CHANGED (165.5,198) "AAE" cross-reference
+71 ;Quit if "ADX" is before 2008 - p2.2*4
+72 IF ($GET(STEXT)=3)
IF ($GET(ONCLDT)=2)
SET SDT=SDT-.00001
FOR
SET SDT=$ORDER(^ONCO(165.5,"AAE",SDT))
if (SDT<1)!(SDT>EDT)!(OUT=1)
QUIT
FOR
SET IEN=$ORDER(^ONCO(165.5,"AAE",SDT,IEN))
if IEN<1
QUIT
IF $$DIV^ONCFUNC(IEN)=DUZ(2)
Begin DoDot:1
+73 if $GET(^ONCO(165.5,IEN,0))=""
QUIT
+74 if $PIECE($GET(^ONCO(165.5,IEN,0)),U,16)<3060101
QUIT
+75 SET TPG=$PIECE($GET(^ONCO(165.5,IEN,2)),U,1)
+76 SET NC=0
+77 FOR FDNUM=.03,.05,.06,3,20,22.3
IF $$GET1^DIQ(165.5,IEN,FDNUM,"I")=""
SET NC=1
+78 if NC=1
QUIT
+79 SET ONCCLCA=$EXTRACT($$GET1^DIQ(165.5,IEN,.04),1,2)
+80 IF ($GET(ONCR12)=2)
IF (ONCCLCA<23)
DO LOOP
QUIT
+81 IF ($GET(ONCR12)=1)
IF ($EXTRACT(TPG,3,4)=50)!($EXTRACT(TPG,3,4)=18)!($EXTRACT(TPG,3,4)=20)&(TPG'=67181)
DO LOOP
End DoDot:1
if OUT
QUIT
+82 ;
+83 ;Loop through ACCESSION NUMBER (165.5,.05) "AA" cross-reference
+84 IF ($GET(STEXT)=3)
IF ($GET(ONCLDT)=3)
SET SDT=SDT-1
FOR
SET SDT=$ORDER(^ONCO(165.5,"AA",SDT))
if (SDT<1)!(SDT>EDT)!(OUT=1)
QUIT
FOR
SET IEN=$ORDER(^ONCO(165.5,"AA",SDT,IEN))
if IEN<1
QUIT
IF $$DIV^ONCFUNC(IEN)=DUZ(2)
Begin DoDot:1
+85 if $GET(^ONCO(165.5,IEN,0))=""
QUIT
+86 if $PIECE($GET(^ONCO(165.5,IEN,0)),U,16)<3060101
QUIT
+87 SET TPG=$PIECE($GET(^ONCO(165.5,IEN,2)),U,1)
+88 SET NC=0
+89 FOR FDNUM=.03,.05,.06,3,20,22.3
IF $$GET1^DIQ(165.5,IEN,FDNUM,"I")=""
SET NC=1
+90 if NC=1
QUIT
+91 SET ONCCLCA=$EXTRACT($$GET1^DIQ(165.5,IEN,.04),1,2)
+92 IF ($GET(ONCR12)=2)
IF (ONCCLCA<23)
DO LOOP
QUIT
+93 IF ($GET(ONCR12)=1)
IF ($EXTRACT(TPG,3,4)=50)!($EXTRACT(TPG,3,4)=18)!($EXTRACT(TPG,3,4)=20)&(TPG'=67181)
DO LOOP
End DoDot:1
if OUT
QUIT
+94 IF ('DEVICE)
IF $GET(ONCPRNT)>20
IF ((EXTRACT=3)!(EXTRACT=5)!(EXTRACT=6)!(EXTRACT=7))
Begin DoDot:1
+95 WRITE !,?5,"</Tumor>"
+96 WRITE !,?3,"</Patient>"
+97 WRITE !,"</NaaccrData>",!
End DoDot:1
+98 QUIT
+99 ;
LOOP ;Apply extract selection rules
+1 ;P#9
+2 ;P#13
+3 if OUT
QUIT
+4 IF ($GET(EXTRACT)=2)!($GET(EXTRACT)=5)
IF ($EXTRACT($$GET1^DIQ(165.5,IEN,.04),1,2)=34)
IF ($GET(ACO)=0)
QUIT
+5 NEW LINE,RULES,VALID,JUMP
+6 SET RULES=0
+7 FOR
SET RULES=$ORDER(^ONCO(160.16,EXTRACT,"RULES",RULES))
if RULES<1
QUIT
Begin DoDot:1
+8 SET LINE=^ONCO(160.16,EXTRACT,"RULES",RULES,0)
+9 XECUTE LINE
End DoDot:1
+10 if 'VALID
QUIT
+11 SET ^TMP($JOB,IEN)=""
+12 DO OUTPUT(IEN,EXTRACT,JUMP,.OUT)
+13 ;I 'DEVICE W !
+14 QUIT
+15 ;
OUTPUT(IEN,EXTRACT,JUMP,OUT) ;Output
+1 SET ACD160=$PIECE(^ONCO(165.5,IEN,0),U,2)
+2 IF DEVICE
DO HEAD(IEN,.OUT)
if OUT
QUIT
+3 NEW POS
SET POS=0
+4 ;P14 xml format
+5 IF $GET(ONCX21)=1
Begin DoDot:1
+6 if $DATA(ONCIE160(IEN))
QUIT
+7 if $GET(ONCPRNT)>20
WRITE !,?5,"</Tumor>"
+8 if $GET(ONCPRNT)>20
WRITE !,?3,"</Patient>"
+9 DO XML21
+10 ;S ONCPRNT=1
+11 SET ONCXPRT=1
+12 QUIT
End DoDot:1
QUIT
+13 FOR
SET POS=$ORDER(^ONCO(160.16,EXTRACT,"FIELD","B",POS))
if POS<1
QUIT
Begin DoDot:1
+14 NEW NODE
SET NODE=0
+15 FOR
SET NODE=$ORDER(^ONCO(160.16,EXTRACT,"FIELD","B",POS,NODE))
if NODE<1
QUIT
Begin DoDot:2
+16 NEW STRING,DEFAULT,FILL,LEN
+17 if $GET(^ONCO(160.16,EXTRACT,"FIELD",NODE,0))=""
QUIT
+18 DO DISPLAY(DEVICE,$PIECE(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,1)_U_$PIECE(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,4),.OUT)
+19 if OUT
QUIT
+20 SET LEN=$PIECE(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,2)
+21 SET STRING=$TRANSLATE(^ONCO(160.16,EXTRACT,"FIELD",NODE,1),"~","^")
+22 SET DEFAULT=$PIECE(^ONCO(160.16,EXTRACT,"FIELD",NODE,2),U,1)
+23 SET FILL=$PIECE(^ONCO(160.16,EXTRACT,"FIELD",NODE,3),U,1)
+24 DO DATA(IEN,ACD160,STRING,DEFAULT,FILL,LEN,JUMP,NODE,POS)
+25 ;=========================================================
+26 ; This Code supports the PCE Extracts (currently disabled)
+27 ;=========================================================
+28 IF $GET(^ONCO(160.16,EXTRACT,0))["ZZNCDB"
Begin DoDot:3
+29 ;QUIT if not end
IF $ORDER(^ONCO(160.16,EXTRACT,"FIELD","B",POS))>1
QUIT
+30 NEW EXTRACT,NODE,POS
+31 SET EXTRACT=100
SET JUMP=0
+32 ;S:$D(^ONCO(165.5,"APCE","BLA",IEN)) EXTRACT=1
+33 ; ^==== Bladder 95,90,85
+34 ;S:$D(^ONCO(165.5,"APCE","THY",IEN)) EXTRACT=2
+35 ; ^==== Thyroid 96,91,86
+36 ;S:$D(^ONCO(165.5,"APCE","STS",IEN)) EXTRACT=3
+37 ; ^==== Soft Tissue 96,91,86
+38 ;S:$D(^ONCO(165.5,"APCE","COL",IEN)) EXTRACT=4
+39 ; ^==== Colorectal 97,92,87
+40 ;S:$D(^ONCO(165.5,"APCE","NHL",IEN)) EXTRACT=5
+41 ; ^==== Non-Hodgkins 97,92,87
+42 ;S:$D(^ONCO(165.5,"APCE","BRE",IEN)) EXTRACT=6
+43 ; ^==== Breast 98,93,88
+44 ;S:$D(^ONCO(165.5,"APCE","PRO2",IEN)) EXTRACT=7
+45 ; ^==== Prostate 98,93,88
+46 ;S:$D(^ONCO(165.5,"APCE","MEL",IEN)) EXTRACT=8
+47 ; ^==== Melanoma 99,94,89
+48 ;S:$D(^ONCO(165.5,"APCE","HEP",IEN)) EXTRACT=9
+49 ; ^==== Hepatocellular Cancers 00,95,90
+50 ;S:$D(^ONCO(165.5,"APCE","CNS",IEN)) EXTRACT=10
+51 ; ^==== Primary Intracranial/CNS Tumors 00,95,90
+52 ;S:$D(^ONCO(165.5,"APCE","LNG",IEN)) EXTRACT=11
+53 ; ^==== Lung (NSCLC) 01,96,91
+54 ;S:$D(^ONCO(165.5,"APCE","GAS",IEN)) EXTRACT=12
+55 ; ^==== Gastric Cancers 01,96,91
+56 SET POS=0
+57 FOR
SET POS=$ORDER(^ONCO(160.17,EXTRACT,"FIELD","B",POS))
if POS<1
QUIT
Begin DoDot:4
+58 NEW NODE
SET NODE=0
+59 FOR
SET NODE=$ORDER(^ONCO(160.17,EXTRACT,"FIELD","B",POS,NODE))
if NODE<1
QUIT
Begin DoDot:5
+60 NEW DEFAULT,FILL,LEN,STRING
+61 if $GET(^ONCO(160.17,EXTRACT,"FIELD",NODE,0))=""
QUIT
+62 DO DISPLAY(DEVICE,$PIECE(^ONCO(160.17,EXTRACT,"FIELD",NODE,0),U,1)_U_$PIECE(^ONCO(160.17,EXTRACT,"FIELD",NODE,0),U,4),.OUT)
+63 if OUT
QUIT
+64 SET STRING=$TRANSLATE(^ONCO(160.17,EXTRACT,"FIELD",NODE,1),"~","^")
+65 SET DEFAULT=^ONCO(160.17,EXTRACT,"FIELD",NODE,2)
+66 SET FILL=^ONCO(160.17,EXTRACT,"FIELD",NODE,3)
+67 SET LEN=$PIECE(^ONCO(160.17,EXTRACT,"FIELD",NODE,0),U,2)
+68 DO DATA(IEN,ACD160,STRING,DEFAULT,FILL,LEN,JUMP,NODE,POS)
End DoDot:5
if OUT
QUIT
End DoDot:4
if OUT
QUIT
End DoDot:3
End DoDot:2
if OUT
QUIT
End DoDot:1
if OUT
QUIT
+69 QUIT
+70 ;
HEAD(IEN,OUT) ;Preview End-of-Page
+1 NEW FLG
+2 IF IEN=OIEN
SET FLG=0
+3 IF IEN'=OIEN
SET OIEN=IEN
SET FLG=1
+4 IF 'FLG
if $Y+4<IOSL
QUIT
+5 IF PAGE'=1
Begin DoDot:1
+6 if $EXTRACT(IOST,1,2)'="C-"
QUIT
+7 NEW DIR,Y
+8 SET DIR(0)="E"
DO ^DIR
+9 IF 'Y
SET OUT=1
QUIT
End DoDot:1
if OUT
QUIT
+10 DO HEADER
+11 QUIT
+12 ;
+1 IF PAGE'=1
WRITE @IOF
+2 IF PAGE=1
IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+3 IF STEXT=3
WRITE !,"RCRS EXTRACT",?70,"Page: ",PAGE
SET PAGE=PAGE+1
+4 IF '$TEST
WRITE !,$PIECE(^ONCO(160.16,EXTRACT,0),U),?70,"Page: ",PAGE
SET PAGE=PAGE+1
+5 WRITE !,"Patient: ",$$GET1^DIQ(160,ACD160,.01,"E")
+6 WRITE ?55,"SSN: ",$$GET1^DIQ(160,ACD160,2,"E")
+7 WRITE !,"Col#",?5,"Item name",?51,"Value",!
+8 FOR I=1:1:79
WRITE "="
+9 QUIT
XML21 ;P14
+1 NEW ONCRTYP,ONCOLD,ONCPOS
+2 SET ONCOLD="TEST"
SET (ONCPOS,POS)="A"
SET ONCRTYP=""
+3 SET ONCIE160(IEN)=IEN
+4 FOR
SET POS=$ORDER(^ONCO(160.16,EXTRACT,"FIELD","D",POS))
if POS=""
QUIT
Begin DoDot:1
+5 NEW NODE,ONCXDATA
SET NODE=0
+6 ;I POS="N" S ONCRTYP="<NaaccrData>"
+7 IF POS="P"
SET ONCRTYP="<Patient>"
+8 IF POS="T"
SET ONCRTYP="<Tumor>"
+9 FOR
SET NODE=$ORDER(^ONCO(160.16,EXTRACT,"FIELD","D",POS,NODE))
if NODE<1
QUIT
Begin DoDot:2
+10 NEW STRING,DEFAULT,FILL,LEN,ONCXDATA
+11 if $GET(^ONCO(160.16,EXTRACT,"FIELD",NODE,0))=""
QUIT
+12 SET ONCXDATA=$PIECE(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,5)
+13 if ONCXDATA=""
QUIT
+14 IF (POS'=ONCPOS)
IF (ONCOLD'=ONCRTYP)
IF (ONCRTYP'="")
Begin DoDot:3
+15 if POS="P"
WRITE !,?3,ONCRTYP
+16 if POS="T"
WRITE !,?5,ONCRTYP
+17 SET ONCOLD=ONCRTYP
SET ONCPOS=POS
End DoDot:3
+18 ;D DISPLAY(DEVICE,$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,1)_U_$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,4),.OUT)
+19 ;Q:OUT
+20 SET LEN=$PIECE(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,2)
+21 SET STRING=$TRANSLATE(^ONCO(160.16,EXTRACT,"FIELD",NODE,1),"~","^")
+22 SET DEFAULT=$PIECE(^ONCO(160.16,EXTRACT,"FIELD",NODE,2),U,1)
+23 SET FILL=$PIECE(^ONCO(160.16,EXTRACT,"FIELD",NODE,3),U,1)
+24 DO DATA(IEN,ACD160,STRING,DEFAULT,FILL,LEN,JUMP,NODE,POS)
End DoDot:2
if OUT
QUIT
+25 SET ONCXPRT=1
End DoDot:1
if OUT
QUIT
+26 QUIT
+27 ;
DISPLAY(DEVICE,WRITE,OUT) ; Display preview
+1 if 'DEVICE
QUIT
+2 NEW DOTS,COL,ITEM
+3 IF DEVICE
IF ($Y+5)>IOSL
DO HEAD(0,.OUT)
if OUT
QUIT
+4 SET COL=$PIECE(WRITE,U,1)
+5 SET COL=$SELECT($LENGTH(COL)=1:" "_COL,$LENGTH(COL)=2:" "_COL,$LENGTH(COL)=3:" "_COL,1:COL)
+6 SET ITEM=$PIECE(WRITE,U,2)
SET ITEM=$EXTRACT(ITEM,1,45)
+7 SET DOTS=(46-$LENGTH(ITEM))
+8 WRITE !,COL,?5,ITEM
+9 FOR I=1:1:DOTS
WRITE "."
+10 QUIT
+11 ;
DATA(IEN,ACD160,STRING,DEFAULT,FILL,LEN,JUMP,NODE,POS) ;Compute extract value
+1 NEW ACDANS,EXIT
SET EXIT=0
+2 IF $GET(ONCX21)=1
Begin DoDot:1
+3 IF $GET(ONCPRNT)>20
IF (POS="N")
QUIT
+4 XECUTE STRING
+5 ;If value = "", extract DEFAULT value
+6 IF (ACDANS="")
IF (DEFAULT="BLANK")
QUIT
+7 NEW I,X
SET X=""
+8 IF DEFAULT=8
Begin DoDot:2
+9 FOR I=1:1:LEN
SET ACDANS=ACDANS_@DEFAULT
End DoDot:2
+10 IF @DEFAULT="09"
SET ACDANS=@DEFAULT
+11 ;F I=1:1:LEN S ACDANS=ACDANS_@DEFAULT
+12 IF (ACDANS["&")!(ACDANS["<")!(ACDANS[">")
DO STRIP
+13 DO XFILL
+14 IF ('DEVICE)
IF (ACDANS="")
IF ((EXTRACT=3)!(EXTRACT=5)!(EXTRACT=6)!(EXTRACT=7))
QUIT
+15 if POS="N"
WRITE !,?2
+16 if POS="P"
WRITE !,?5
+17 if POS="T"
WRITE !,?7
+18 WRITE "<Item naaccrId=""",ONCXDATA,""">",ACDANS,"</Item>"
+19 SET ONCPRNT=ONCPRNT+1
+20 QUIT
End DoDot:1
QUIT
+21 IF JUMP'="0"
Begin DoDot:1
+22 IF POS<$PIECE(JUMP,U)
QUIT
+23 IF POS>$PIECE(JUMP,U,2)
QUIT
+24 NEW I
+25 SET EXIT=1
+26 FOR I=1:1:LEN
WRITE BLANK
End DoDot:1
+27 if EXIT
QUIT
+28 XECUTE STRING
+29 ;
+30 ;If value = "", extract DEFAULT value
+31 IF ACDANS=""
Begin DoDot:1
+32 NEW I,X
SET X=""
+33 IF DEFAULT=8
Begin DoDot:2
+34 FOR I=1:1:LEN
WRITE DEFAULT
End DoDot:2
QUIT
+35 IF @DEFAULT="09"
WRITE @DEFAULT
QUIT
+36 FOR I=1:1:LEN
WRITE @DEFAULT
End DoDot:1
QUIT
+37 ;
+38 ;If value too long, truncate to LENGTH (160.161,1)
+39 ;If value too short, pad with FILL (160.161,6)
+40 IF $LENGTH(ACDANS)=LEN
WRITE ACDANS
QUIT
+41 IF $LENGTH(ACDANS)>LEN
WRITE $EXTRACT(ACDANS,1,LEN)
QUIT
+42 IF '$TEST
Begin DoDot:1
+43 NEW JUST,STUFF,I,REM,CAL
+44 SET JUST=$PIECE(FILL,",")
SET STUFF=$PIECE(FILL,",",2)
+45 SET REM=LEN-$LENGTH(ACDANS)
+46 IF JUST="R"
WRITE ACDANS
+47 FOR I=1:1:REM
WRITE @STUFF
+48 IF JUST="L"
WRITE ACDANS
End DoDot:1
QUIT
+49 QUIT
XFILL ;Truncate or pad xml fields
+1 IF $LENGTH(ACDANS)=LEN
QUIT
+2 IF $LENGTH(ACDANS)>LEN
SET ACDANS=$EXTRACT(ACDANS,1,LEN)
QUIT
+3 IF '$TEST
Begin DoDot:1
+4 NEW JUST,STUFF,I,REM,CAL,LACDANS
+5 SET LACDANS=""
+6 SET JUST=$PIECE(FILL,",")
SET STUFF=$PIECE(FILL,",",2)
SET STUFF=$PIECE(STUFF,"^")
+7 if STUFF="BLANK"
QUIT
+8 if STUFF="ZERO"
SET STUFF=0
+9 if STUFF="NINE"
SET STUFF=9
+10 SET REM=LEN-$LENGTH(ACDANS)
+11 FOR I=1:1:REM
if JUST="R"
SET ACDANS=ACDANS_STUFF
if JUST="L"
SET LACDANS=LACDANS_STUFF
+12 IF JUST="L"
SET ACDANS=LACDANS_ACDANS
End DoDot:1
QUIT
+13 QUIT
STRIP ;replace special characters
+1 NEW AA,BB,X1
+2 SET BB=""
+3 FOR I=1:1:($LENGTH(ACDANS))
if I'>0
QUIT
Begin DoDot:1
+4 SET (AA,X1)=$EXTRACT(ACDANS,I)
+5 if X1="&"
SET AA=" and "
+6 if X1=">"
SET AA=" GT "
+7 if X1="<"
SET AA=" LT "
+8 if X1="$"
SET AA=" "
+9 SET BB=BB_AA
End DoDot:1
+10 SET ACDANS=BB
+11 QUIT
RCRS ;RCRS exeption rules
+1 IF ($PIECE(TPG,3,4)=44)
IF ((MPGH>79999)&(MPGH<81109))
SET VALID=0
+2 IF (MPGH=80772)
IF (($PIECE(TPG,3,5)=619)!($PIECE(TPG,3,5)=529))
SET VALID=0
+3 IF (MPGH=80772)
IF (($PIECE(TPG,3,4)=51)!($PIECE(TPG,3,4)=21)!$PIECE(TPG,3,4)=32)
SET VALID=0
+4 IF (DATEDX>3220000)
IF (($PIECE(TPG,3,5)>159)&($PIECE(TPG,3,5)<167))
IF ((MPGH=82112)!(MPGHD=82612)!(MPGH=82632))
SET VALID=0
+5 IF (DATEDX>3220000)
IF (($PIECE(TPG,3,5)>167)&($PIECE(TPG,3,5)<174))
IF ((MPGH=82112)!(MPGHD=82612)!(MPGH=82632))
SET VALID=0
+6 IF (DATEDX>3220000)
IF (($PIECE(TPG,3,5)>177)&($PIECE(TPG,3,5)<180))
IF ((MPGH=82112)!(MPGHD=82612)!(MPGH=82632))
SET VALID=0
+7 IF (DATEDX>3220000)
IF ($PIECE(TPG,3,5)=53)
IF ((MPGH=84832)!(MPGHD=84842))
SET VALID=0
+8 QUIT
+9 ;
CLEANUP ;Cleanup
+1 KILL DATE,EDT,NCDB,SDT,STEXT
