- 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,20**;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-230.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 14051 printed Feb 18, 2025@23:48:22 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,20**;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-230.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