ONCACDU2 ;Hines OIFO/GWB - Utility routine ;05/03/12
;;2.2;ONCOLOGY;**1,4,7,5,6**;Jul 31, 2013;Build 10
;
VAFLD(ACDANS) ;Convert data to NAACCR format
I ACDANS="N" S ACDANS=0
I ACDANS="Y" S ACDANS=1
I ACDANS="U" S ACDANS=9
Q ACDANS
;
ICN(ACD160) ;Patient ICN (2,991.01 & 991.02) [72-94]
; ICN OR X =999999999999V999999 format
N X,ONC201,ONCPT01
S X=""
I ACD160="" Q X
S ONC201=$P($G(^ONCO(160,ACD160,0)),U,1)
S ONCPT01=$P(ONC201,";",1)
S X=$$GETICN^MPIF001(ONCPT01)
I $P(X,U,1)="-1" S X=""
Q X
;
VASIT() ;VISN (160.1,7) [2340-2341]
N X
S OSPIEN=$O(^ONCO(160.1,0))
S X=$P($G(^ONCO(160.1,OSPIEN,1)),U,7)
K OSPIEN
Q X
;
COCACC() ;COC ACCREDITATION (160.1,68) [2547-2548]
N X
S OSPIEN=$O(^ONCO(160.1,0))
S X=$P($G(^ONCO(160.1,OSPIEN,7)),U,2)
K OSPIEN
Q X
;
SNCNT(IEN) ;Sequence Number--Central [380] 281-282
N BEHAV,DATEDX,HIST,PRIMST,X
S DATEDX=$E($$GET1^DIQ(165.5,IEN,3,"I"),1,3)
S PRIMST=$$GET1^DIQ(165.5,IEN,20,"I")
S HIST=$E($$GET1^DIQ(165.5,IEN,22.3,"I"),1,4)
S BEHAV=$E($$GET1^DIQ(165.5,IEN,22.3,"I"),5)
S X=""
I DATEDX>295,DATEDX<303,$E(PRIMST,3,4)=53,HIST<9590,BEHAV=2 S X=98
Q X
;
COCO(IEN) ;COC Coding Sys--Original [2150] 1202-1203
N X
S DATEDX=$$GET1^DIQ(165.5,IEN,3,"I")
S X=$S(DATEDX>3021231:"08",DATEDX>2951231:"07",1:"05")
Q X
;
VENDOR() ;Vendor Name [2170] 1204-1213
N X,VERSION,EXTR,SUFFIX
S EXTR=$G(^ONCO(160.16,EXTRACT,0))
S SUFFIX=$S(EXTR["VACCR":"A",EXTR["STATE":"B",1:"")
S VERSION=$P($G(^ONCO(160.16,EXTRACT,0))," ",3)
S X="VA"_VERSION_$E($T(LOGO+3^ONCODIS),62,64)_SUFFIX
Q X
;
WORD(IEN,NODE,LEN) ;Get word processing data
N X
S X=""
I $D(^ONCO(165.5,IEN,NODE,0)) D
.N CNT,LINE,ONCLINE
.S CNT=0
.S (LINE,ONCLINE)=""
.F S CNT=$O(^ONCO(165.5,IEN,NODE,CNT)) Q:CNT<1 D Q:($L(ONCLINE)>LEN)
..Q:'$D(^ONCO(165.5,IEN,NODE,CNT,0))
..S ONCLINE=LINE_^ONCO(165.5,IEN,NODE,CNT,0)_" "
..I ($L(ONCLINE)>LEN) S LINE=$E(ONCLINE,1,LEN) Q
..S LINE=LINE_^ONCO(165.5,IEN,NODE,CNT,0)_" "
.S X=LINE
S X=$TR(X,$C(10,12,13)," ")
Q X
;
STAGE(IEN,TYPE) ;TNM Descriptors
;TNM Path Descriptor [910] 956-956
;TNM Clin Descriptor [980] 974-974
N CD,LOC,PD,X
S X=""
S CD=$$GET1^DIQ(165.5,IEN,241,"I")
S PD=$$GET1^DIQ(165.5,IEN,242,"I")
I TYPE="C",CD'="" S X=CD G STAGEEX
I TYPE="P",PD'="" S X=PD G STAGEEX
S LOC=$S(TYPE="P":89.1,TYPE="C":37,1:"")
I TYPE'="" D
.N STRING
.S STRING=$$GET1^DIQ(165.5,IEN,LOC,"E")
.I ($P(STRING," ")["m")&($P(STRING," ")["y") S X=6 Q
.I $P(STRING," ")["m" S X=3 Q
.I TYPE="P",$P(STRING," ")["y" S X=4 Q
STAGEEX Q X
;
CCOUNTY(ACD160) ;County--Current [1840] 2192-2194
I $$DPTLRT^ONCOES(ACD160)="LRT" S X="" G CCEX
N DPT,DPTPNT,X
S DPT=$$GET1^DIQ(160,ACD160,.01,"I")
S DPTPNT=$P(DPT,";",1)
S X=$$GET1^DIQ(2,DPTPNT,.117)
CCEX Q X
;
SUB(IEN,CNT,FIELD) ;
;Subsq RX 2nd Course Date [1660] 988-995
N HEMA,HEMAPT,I,X
S CNT=CNT-1
S X=""
I $O(^ONCO(165.5,IEN,4,0)) D
.N IENS,SUB,SUBFLD,ENTRY,SUBIEN
.S SUBIEN=0 F I=1:1 S SUBIEN=$O(^ONCO(165.5,IEN,4,SUBIEN)) Q:(I=CNT)!(SUBIEN'>0)
.I SUBIEN="" S X="" Q
.S IENS=SUBIEN_","_IEN
.S ENTRY=$$GET1^DIQ(165.51,IENS,FIELD,"I") I ENTRY="",FIELD'=".07",FIELD'=".08" S X="" Q
.S HEMA=""
.S HEMAPT=$$GET1^DIQ(165.51,IENS,.02,"I")
.S:HEMAPT'="" HEMA=$P($G(^ONCO(167,HEMAPT,0)),U,1)
.I $S(FIELD=".01":1,FIELD=".05":1,FIELD=".06":1,FIELD=".07":1,FIELD=".08":1,FIELD=".09":1,FIELD="37":1,FIELD=".041":1,FIELD=".051":1,FIELD=".061":1,FIELD=".071":1,FIELD=".081":1,FIELD=".091":1,1:0) D Q
..I FIELD=".06" S X=$S(ENTRY="01":1,ENTRY="02":2,ENTRY="03":3,$E(ENTRY,1)=8:0,1:ENTRY) Q
..I FIELD=".07" S X=$S(ENTRY="00":0,ENTRY="01":1,$E(ENTRY,1)=8:0,ENTRY=99:9,1:"") Q:X'="" S X=$S(HEMA=30:2,HEMA=40:2,1:"") Q
..I FIELD=".08" S X=$S(ENTRY="01":1,ENTRY=87:7,ENTRY=88:8,$E(ENTRY,1)=8:0,ENTRY=99:9,1:ENTRY) Q:X'="" S X=$S(HEMA=10:4,HEMA=11:2,HEMA=12:3,HEMA=20:5,1:"") Q
..S X=ENTRY
.I $$GET1^DIQ(165.5,IEN,3,"I")<2980000 S X=ENTRY Q
.S SUBFLD=$S(FIELD=33:"RR5",FIELD=35:"SC5",FIELD=36:"SO5",FIELD=.04:"SPS",1:"") I SUBFLD="" S X="" Q
.S X=$$SUB164^ONCACDU2(IEN,SUBFLD,ENTRY)
I FIELD=.04,$L(X)=1 S X="0"_X
Q X
;
SUB164(IEN,SUBFLD,ENTRY) ;ICDO TOPOGRAPHY (164)
N X,TOP1,TOP2
S X=""
S TOP1=$$GET1^DIQ(165.5,IEN,20,"I") D:TOP1'=""
.S TOP2=$$GET1^DIQ(164,TOP1,107,"I")
.I (TOP1=67420)!(TOP1=67421)!(TOP1=67423)!(TOP1=67424)!($E(TOP1,3,4)=76)!(TOP1=67809),($G(FIELD)=58.6)!($G(FIELD)=58.7) S TOP2=67420
.I ($G(FIELD)=58.2)!($G(FIELD)=50.2)!($G(FIELD)=138)!($G(FIELD)=138.1)!($G(FIELD)=139)!($G(FIELD)=139.1)!($G(FIELD)=74)!($G(FIELD)=23),($E(TOP1,3,4)=76)!(TOP1=67809)!(TOP1=67420)!(TOP1=67421)!(TOP1=67423)!(TOP1=67424) S TOP2=67141
.I $$HEMATO^ONCFUNC(IEN),TOP1=67179 S TOP2=67420 ;p5 item#18
.I ($G(FIELD)=58.2)!($G(FIELD)=50.2),TOP1=67422 S TOP2=67770
.I $G(SUBFLD)="SUA",($E(TOP1,3,4)=77) S TOP2=67141
.D:TOP2'=""
..S X=$P($G(^ONCO(164,TOP2,SUBFLD,ENTRY,0)),U,2)
Q X
;
RXPRI(IEN,FIELD,SUBFLD) ;
;RX Hosp--Surg Prim Site [670] 457-458
;RX Hosp--Surg Site 98-02 [746] 478-479
;RX Hosp--Scope Reg 98-02 [747] 480-480
;RX Hosp--Surg Oth 98-02 [748] 481-481
;RX Summ--Surg Prim Site [1290] 859-860
;RX Summ--Surgical Approch [1310] 865-865
;RX Summ--Reconstruct 1st [1330] 867-867
;RX Summ--Surg Site 98-02 [1646] 939-940
;RX Summ--Scope Reg 98-02 [1647] 941-941
;RX Summ--Surg Oth 98-02 [1648] 942-942
N X,ENTRY
S X=""
S TOP1=$$GET1^DIQ(165.5,IEN,20,"I")
S ENTRY=$$GET1^DIQ(165.5,IEN,FIELD,"I") D:ENTRY'=""
.I (TOP1=67420)!(TOP1=67421)!(TOP1=67423)!(TOP1=67424)!($E(TOP1,3,4)=76)!(TOP1=67809),($G(FIELD)=58.6)!($G(FIELD)=58.7) S X=$$SUB164^ONCACDU2(IEN,SUBFLD,ENTRY) Q
.I $$GET1^DIQ(165.5,IEN,3,"I")<2980000,(FIELD=23)!(FIELD=74)!(FIELD=50.2)!(FIELD=58.2)!(FIELD=58.6)!(FIELD=58.7) S X=$S(FIELD=23:$$GET1^DIQ(160.4,ENTRY,.01,"I"),FIELD=74:$$GET1^DIQ(160.6,ENTRY,.01,"I"),1:ENTRY) Q
.S X=$$SUB164^ONCACDU2(IEN,SUBFLD,ENTRY)
Q X
;
FNODE(ACD160,FIELD) ;FOLLOW-UP (160,400)
;Date of Last Contact [1750] 1294-1301
;Vital Status [1760] 1302-1302
;Quality of Survival [1780] 1304-1304
;Follow-Up Source [1790] 1305-1305
;Next Follow-Up Source [1800] 1306-1306
;Unusual Follow-Up Method [1850] 1341-1341
;Following Registry [2440] 2475-2484
N FNODE,X
S FNODE=$$LAST(ACD160),X=""
I FNODE'="" D
.N IENS
.S IENS=FNODE_","_ACD160_","
.S X=$$GET1^DIQ(160.04,IENS,FIELD,"I")
Q X
;
LAST(ACD160) ;Get last FOLLOW-UP(160,400)
N DLC
S X="",DLC=0
S DLC=$O(^ONCO(160,ACD160,"F","AA",DLC))
S:DLC'="" X=$O(^ONCO(160,ACD160,"F","AA",DLC,0))
I X'>0 S X=""
Q X
;
FCNODE(ACD160,FIELD,IE) ;FOLLOW-UP CONTACT (160,420)
;Follow-Up Contact--City [1842] 1357-1376
;Follow-Up Contact--State [1844] 1377-1378
;Follow-Up Contact--Postal[1846] 1379-1387
;Follow-Up Contact--Name [2394] 2284-2313
;Follow-Up Contact--No&St [2392] 2314-2353
;Follow-Up Contact--Suppl [2393] 2354-2393
N CONTACT,FCNODE,X
S X=""
S FCNODE=$O(^ONCO(160,ACD160,"C","B"),-1)
I FCNODE'="" D
.N IENS
.S IENS=FCNODE_","_ACD160_","
.S CONTACT=$$GET1^DIQ(160.03,IENS,1,"I")
I $G(CONTACT) S X=$$GET1^DIQ(165,CONTACT,FIELD,IE)
Q X
;
CS(IEN) ;Cancer Status [1770] 1303-1303
N X,Z,FNODE
S FNODE=0
S X=""
S FNODE=$O(^ONCO(165.5,IEN,"TS",FNODE))
I FNODE>0 D
.N IENS,PT
.S FNODE=$O(^ONCO(165.5,IEN,"TS"," "),-1)
.Q:FNODE<1
.S IENS=FNODE_","_IEN_","
.S PT=$$GET1^DIQ(165.573,IENS,.02,"I")
.Q:PT<1
.S X=$$GET1^DIQ(164.42,PT,1,"I")
Q X
;
CCTST(ACD160) ;
;Addr Current--City [1810] 1307-1326
N D0,PT,X
S D0=ACD160
S X="" S PT=$P($G(^ONCO(160,D0,0)),";",1)
I $$DPTLRT^ONCOES(D0)="LRT" S X=$$GET1^DIQ(67,PT,.114,"E")
I $$DPTLRT^ONCOES(D0)="DPT" S X=$$GET1^DIQ(2,PT,.114,"E")
S X=$$STRIP^XLFSTR(X,"!""""#$%&'()*+,-./:;<=>?[>]^_\{|}~`")
Q X
;
CSTST(ACD160) ;
;Addr Current--State [1820] 1327-1328
N ONCX,XPT,XX,PT
S (XPT,XX)=""
S ITEM=1820 D CHKADDS^ONCACDU1 I ONCADDF'="" Q ONCADDF ;check override
S ONCX=$$GET1^DIQ(160,ACD160,.115,"E")
;S X=$S(X="CANAD":"CD",X="EU":"YY",X="MX":"XX",X="NF":"NL",X="PH":"XX",X="UN":"ZZ",1:X)
I ONCX="" S PT=$P($G(^ONCO(160,ACD160,0)),";",1) D
.I $$DPTLRT(ACD160)="LRT" S XPT=$$GET1^DIQ(67,PT,.115,"I") S:$G(XPT) XX=$$GET1^DIQ(5,XPT,1,"E")
.I $$DPTLRT(ACD160)="DPT" S XPT=$$GET1^DIQ(2,PT,.1173,"I") S:$G(XPT) XX=$$GET1^DIQ(779.004,XPT,.01,"E") D:XPT=""
..S XPT=$$GET1^DIQ(2,PT,.115,"I") S:$G(XPT) XX=$$GET1^DIQ(5,XPT,1,"E")
I (ONCX=""),(XX'=""),(XX'="USA"),(XX'="CAN") S ONCX="XX"
I (ONCX=""),(XX="") S ONCX="YY"
I (ONCX=""),(XX="USA") S ONCX="US"
I (ONCX=""),(XX="CAN") S ONCX="CD"
I ONCX="UN" S ONCX="ZZ"
Q ONCX
;
ADDCTRY(IEN,ITEM) ;
;Addr at DX--Country [102] 436-438
;Addr Current--Country [1832] 439-441
;Followup Contact--Country [1847] 447-449
; Value derived from:
; ITEM #102 - STATE AT DX (#165.5,16) pointer to File #5
; ITEM #1832 - COUNTRY FILE (#2,.1173) pointer to File #779.004 or State File (#2,.115) to File #5
; ITEM #1847 - ZIP CODE (#165,.119 --> #5.11,3) pointer to File #5
;
; IF VALUE IS NOT FILLED IN OR NOT FOUND, DEFAULT TO "ZZU" (UNKNOWN)
;
N XX
D CHKADDS^ONCACDU1 I ONCADDF'="" Q ONCADDF ;check override
S ACDANS="USA"
I ITEM=102 S XX=$S($$GET1^DIQ(165.5,IEN,16,"I")'="":$$GET1^DIQ(5,$$GET1^DIQ(165.5,IEN,16,"I"),1,"I"),1:"")
I ITEM=1832 D
.S (X,XX)="" S PT=$P($G(^ONCO(160,ACD160,0)),";",1)
.I $$DPTLRT(ACD160)="LRT" S X=$$GET1^DIQ(67,PT,.115,"I") S:$G(X) XX=$$GET1^DIQ(5,X,1,"E")
.I $$DPTLRT(ACD160)="DPT" S X=$$GET1^DIQ(2,PT,.1173,"I") S:$G(X) (XX,ACDANS)=$$GET1^DIQ(779.004,X,.01,"E")
.S X=$$GET1^DIQ(2,PT,.115,"I") S:$G(X) XX=$$GET1^DIQ(5,X,1,"E")
I ITEM=1847 S XX="",VICPNT=$$FCNODE^ONCACDU2(ACD160,.119,"I") S:$G(VICPNT) STATE=$P($G(^VIC(5.11,VICPNT,0)),U,4) S:$G(STATE)'="" XX=$$GET1^DIQ(5,STATE,1,"I") K STATE,VICPNT
I XX="QC"!(XX="AB")!(XX="ZZMB")!(XX="NB")!(XX="NF")!(XX="NS")!(XX="NT")!(XX="ON")!(XX="PE")!(XX="SK")!(XX="YT")!(XX="CANAD")!(XX="MB")!(XX="NU")!(XX="BC") S ACDANS="CAN"
I XX="FM" S ACDANS="FSM"
I XX="GU" S ACDANS="GUM"
I XX="MH" S ACDANS="MHL"
I XX="MP" S ACDANS="MNP"
I XX="PW" S ACDANS="PWL"
I XX="UM" S ACDANS="UMI"
I XX="FG" S ACDANS="ZZX"
I XX="MX" S ACDANS="MEX"
I XX="EU" S ACDANS="ZZE"
I XX="PH" S ACDANS="PHL"
I XX="AS" S ACDANS="ASM"
I XX="PR" S ACDANS="PRI"
I XX="VI" S ACDANS="VIR"
I XX="ZZEQ" S ACDANS="KIR"
I XX="ZZIQ" S ACDANS="ZZP"
I XX="ZZYQ" S ACDANS="JPN"
I XX="UN"!(XX="") S ACDANS="ZZU"
Q ACDANS
;
DPTLRT(ACD160) ;check if pt from Patient or Referral file
N DPTLRT
S DPTLRT=""
I $P($G(^ONCO(160,ACD160,0)),U,1)["LRT" S DPTLRT="LRT"
I $P($G(^ONCO(160,ACD160,0)),U,1)["DPT" S DPTLRT="DPT"
Q DPTLRT
;
ICD(ICD) ;ICD Code
;Use ICD API (IA #3990) instead of direct global read.
N X
S ICD=$S(ICD'="":$$GET1^DIQ(80,ICD,.01),1:"0000")
I ICD["." S ICD=$P(ICD,".")_$P(ICD,".",2)
S:$L(ICD)=3 ICD=ICD_9
S:$L(ICD)<4 ICD=$E("0000",1,4-$L(ICD))_ICD
S:$L(ICD)>4 ICD=$E(ICD,1,4)
I $E(ICD,4)="X"!($E(ICD,4)="-") S ICD=$E(ICD,1,3)_9
Q ICD
;
ICDR(ICD) ;ICD Revision Number [1920] 1392-1392
N ICDR
S ICD=$$ICD(ICD)
S ICDR=$S(ICD=" ":0,1:$$GET1^DIQ(160,ACD160,20,"I"))
S:ICDR="" ICDR=0
Q ICDR
;
PPAY(IEN) ;PRIMARY PAYER AT DX (165.5,18)
N X
S X=$$GET1^DIQ(165.5,IEN,18,"I")
S X=$$GET1^DIQ(160.3,$S(X'="":X,1:99),.01,"I")
S X=$S(X<42:X,X>47:X,1:X-1)
Q X
;
DS(IEN) ;RX Date--Surgery [1200] 755-762
N X
S X=$$GET1^DIQ(165.5,IEN,50,"I") I X'="" S SURGDT(X)=""
S X=$$GET1^DIQ(165.5,IEN,138.2,"I") I X'="" S SURGDT(X)=""
S X=$$GET1^DIQ(165.5,IEN,139.2,"I") I X'="" S SURGDT(X)=""
S SURGDT=$O(SURGDT(0))
S X=$$DATE^ONCACDU1(SURGDT)
K SURGDT
Q X
STRIP ;Replace punctuation marks with spaces
S ACDANS=$TR(ACDANS,"!""""@#$%&'()*+,-./:;<=>?[>]^_\{|}~`"," ")
S ACDANS=$$TRIM^XLFSTR(ACDANS)
Q
;
STRIP1 ;Strip out punctuation marks
S ACDANS=$$STRIP^XLFSTR(ACDANS,"!""""#$%&'()*+,-./:;<=>?[>]^_\{|}~`")
Q
;
STNUM ;get 3-digit state number for state extract. reporting facility must be the same w/ 160.1 entry.
;if no 3-digit number, use the initial from file #200
N ONC3DIG,ONC1601,ONC3IEN,ONC16019
S ONC3DIG=""
S ONC16019=$$GET1^DIQ(165.5,IEN,.03,"I"),ONC1601=0
F S ONC1601=$O(^ONCO(160.1,"D",ACDANS,ONC1601)) Q:ONC1601'>0 D
.I $D(^ONCO(160.1,ONC1601,1)),$P(^(1),U,4)'=ONC16019 Q
.S ONC3IEN=$O(^ONCO(160.1,"D",ACDANS,ONC1601,0)) S:$G(ONC3IEN) ONC3DIG=$P(^ONCO(160.1,ONC1601,"REG",ONC3IEN,0),U,2)
S:ONC3DIG="" ACDANS=$E($$GET1^DIQ(200,ACDANS,1,"I"),1,3)
I ONC3DIG'="" S ACDANS=$S($L(ONC3DIG)=1:"00"_ONC3DIG,$L(ONC3DIG)=2:"0"_ONC3DIG,1:ONC3DIG)
Q
;
CLEANUP ;Cleanup
K EXTRACT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCACDU2 12778 printed Apr 09, 2024@21:31 Page 2
ONCACDU2 ;Hines OIFO/GWB - Utility routine ;05/03/12
+1 ;;2.2;ONCOLOGY;**1,4,7,5,6**;Jul 31, 2013;Build 10
+2 ;
VAFLD(ACDANS) ;Convert data to NAACCR format
+1 IF ACDANS="N"
SET ACDANS=0
+2 IF ACDANS="Y"
SET ACDANS=1
+3 IF ACDANS="U"
SET ACDANS=9
+4 QUIT ACDANS
+5 ;
ICN(ACD160) ;Patient ICN (2,991.01 & 991.02) [72-94]
+1 ; ICN OR X =999999999999V999999 format
+2 NEW X,ONC201,ONCPT01
+3 SET X=""
+4 IF ACD160=""
QUIT X
+5 SET ONC201=$PIECE($GET(^ONCO(160,ACD160,0)),U,1)
+6 SET ONCPT01=$PIECE(ONC201,";",1)
+7 SET X=$$GETICN^MPIF001(ONCPT01)
+8 IF $PIECE(X,U,1)="-1"
SET X=""
+9 QUIT X
+10 ;
VASIT() ;VISN (160.1,7) [2340-2341]
+1 NEW X
+2 SET OSPIEN=$ORDER(^ONCO(160.1,0))
+3 SET X=$PIECE($GET(^ONCO(160.1,OSPIEN,1)),U,7)
+4 KILL OSPIEN
+5 QUIT X
+6 ;
COCACC() ;COC ACCREDITATION (160.1,68) [2547-2548]
+1 NEW X
+2 SET OSPIEN=$ORDER(^ONCO(160.1,0))
+3 SET X=$PIECE($GET(^ONCO(160.1,OSPIEN,7)),U,2)
+4 KILL OSPIEN
+5 QUIT X
+6 ;
SNCNT(IEN) ;Sequence Number--Central [380] 281-282
+1 NEW BEHAV,DATEDX,HIST,PRIMST,X
+2 SET DATEDX=$EXTRACT($$GET1^DIQ(165.5,IEN,3,"I"),1,3)
+3 SET PRIMST=$$GET1^DIQ(165.5,IEN,20,"I")
+4 SET HIST=$EXTRACT($$GET1^DIQ(165.5,IEN,22.3,"I"),1,4)
+5 SET BEHAV=$EXTRACT($$GET1^DIQ(165.5,IEN,22.3,"I"),5)
+6 SET X=""
+7 IF DATEDX>295
IF DATEDX<303
IF $EXTRACT(PRIMST,3,4)=53
IF HIST<9590
IF BEHAV=2
SET X=98
+8 QUIT X
+9 ;
COCO(IEN) ;COC Coding Sys--Original [2150] 1202-1203
+1 NEW X
+2 SET DATEDX=$$GET1^DIQ(165.5,IEN,3,"I")
+3 SET X=$SELECT(DATEDX>3021231:"08",DATEDX>2951231:"07",1:"05")
+4 QUIT X
+5 ;
VENDOR() ;Vendor Name [2170] 1204-1213
+1 NEW X,VERSION,EXTR,SUFFIX
+2 SET EXTR=$GET(^ONCO(160.16,EXTRACT,0))
+3 SET SUFFIX=$SELECT(EXTR["VACCR":"A",EXTR["STATE":"B",1:"")
+4 SET VERSION=$PIECE($GET(^ONCO(160.16,EXTRACT,0))," ",3)
+5 SET X="VA"_VERSION_$EXTRACT($TEXT(LOGO+3^ONCODIS),62,64)_SUFFIX
+6 QUIT X
+7 ;
WORD(IEN,NODE,LEN) ;Get word processing data
+1 NEW X
+2 SET X=""
+3 IF $DATA(^ONCO(165.5,IEN,NODE,0))
Begin DoDot:1
+4 NEW CNT,LINE,ONCLINE
+5 SET CNT=0
+6 SET (LINE,ONCLINE)=""
+7 FOR
SET CNT=$ORDER(^ONCO(165.5,IEN,NODE,CNT))
if CNT<1
QUIT
Begin DoDot:2
+8 if '$DATA(^ONCO(165.5,IEN,NODE,CNT,0))
QUIT
+9 SET ONCLINE=LINE_^ONCO(165.5,IEN,NODE,CNT,0)_" "
+10 IF ($LENGTH(ONCLINE)>LEN)
SET LINE=$EXTRACT(ONCLINE,1,LEN)
QUIT
+11 SET LINE=LINE_^ONCO(165.5,IEN,NODE,CNT,0)_" "
End DoDot:2
if ($LENGTH(ONCLINE)>LEN)
QUIT
+12 SET X=LINE
End DoDot:1
+13 SET X=$TRANSLATE(X,$CHAR(10,12,13)," ")
+14 QUIT X
+15 ;
STAGE(IEN,TYPE) ;TNM Descriptors
+1 ;TNM Path Descriptor [910] 956-956
+2 ;TNM Clin Descriptor [980] 974-974
+3 NEW CD,LOC,PD,X
+4 SET X=""
+5 SET CD=$$GET1^DIQ(165.5,IEN,241,"I")
+6 SET PD=$$GET1^DIQ(165.5,IEN,242,"I")
+7 IF TYPE="C"
IF CD'=""
SET X=CD
GOTO STAGEEX
+8 IF TYPE="P"
IF PD'=""
SET X=PD
GOTO STAGEEX
+9 SET LOC=$SELECT(TYPE="P":89.1,TYPE="C":37,1:"")
+10 IF TYPE'=""
Begin DoDot:1
+11 NEW STRING
+12 SET STRING=$$GET1^DIQ(165.5,IEN,LOC,"E")
+13 IF ($PIECE(STRING," ")["m")&($PIECE(STRING," ")["y")
SET X=6
QUIT
+14 IF $PIECE(STRING," ")["m"
SET X=3
QUIT
+15 IF TYPE="P"
IF $PIECE(STRING," ")["y"
SET X=4
QUIT
End DoDot:1
STAGEEX QUIT X
+1 ;
CCOUNTY(ACD160) ;County--Current [1840] 2192-2194
+1 IF $$DPTLRT^ONCOES(ACD160)="LRT"
SET X=""
GOTO CCEX
+2 NEW DPT,DPTPNT,X
+3 SET DPT=$$GET1^DIQ(160,ACD160,.01,"I")
+4 SET DPTPNT=$PIECE(DPT,";",1)
+5 SET X=$$GET1^DIQ(2,DPTPNT,.117)
CCEX QUIT X
+1 ;
SUB(IEN,CNT,FIELD) ;
+1 ;Subsq RX 2nd Course Date [1660] 988-995
+2 NEW HEMA,HEMAPT,I,X
+3 SET CNT=CNT-1
+4 SET X=""
+5 IF $ORDER(^ONCO(165.5,IEN,4,0))
Begin DoDot:1
+6 NEW IENS,SUB,SUBFLD,ENTRY,SUBIEN
+7 SET SUBIEN=0
FOR I=1:1
SET SUBIEN=$ORDER(^ONCO(165.5,IEN,4,SUBIEN))
if (I=CNT)!(SUBIEN'>0)
QUIT
+8 IF SUBIEN=""
SET X=""
QUIT
+9 SET IENS=SUBIEN_","_IEN
+10 SET ENTRY=$$GET1^DIQ(165.51,IENS,FIELD,"I")
IF ENTRY=""
IF FIELD'=".07"
IF FIELD'=".08"
SET X=""
QUIT
+11 SET HEMA=""
+12 SET HEMAPT=$$GET1^DIQ(165.51,IENS,.02,"I")
+13 if HEMAPT'=""
SET HEMA=$PIECE($GET(^ONCO(167,HEMAPT,0)),U,1)
+14 IF $SELECT(FIELD=".01":1,FIELD=".05":1,FIELD=".06":1,FIELD=".07":1,FIELD=".08":1,FIELD=".09":1,FIELD="37":1,FIELD=".041":1,FIELD=".051":1,FIELD=".061":1,FIELD=".071":1,FIELD=".081":1,FIELD=".091":1,1:0)
Begin DoDot:2
+15 IF FIELD=".06"
SET X=$SELECT(ENTRY="01":1,ENTRY="02":2,ENTRY="03":3,$EXTRACT(ENTRY,1)=8:0,1:ENTRY)
QUIT
+16 IF FIELD=".07"
SET X=$SELECT(ENTRY="00":0,ENTRY="01":1,$EXTRACT(ENTRY,1)=8:0,ENTRY=99:9,1:"")
if X'=""
QUIT
SET X=$SELECT(HEMA=30:2,HEMA=40:2,1:"")
QUIT
+17 IF FIELD=".08"
SET X=$SELECT(ENTRY="01":1,ENTRY=87:7,ENTRY=88:8,$EXTRACT(ENTRY,1)=8:0,ENTRY=99:9,1:ENTRY)
if X'=""
QUIT
SET X=$SELECT(HEMA=10:4,HEMA=11:2,HEMA=12:3,HEMA=20:5,1:"")
QUIT
+18 SET X=ENTRY
End DoDot:2
QUIT
+19 IF $$GET1^DIQ(165.5,IEN,3,"I")<2980000
SET X=ENTRY
QUIT
+20 SET SUBFLD=$SELECT(FIELD=33:"RR5",FIELD=35:"SC5",FIELD=36:"SO5",FIELD=.04:"SPS",1:"")
IF SUBFLD=""
SET X=""
QUIT
+21 SET X=$$SUB164^ONCACDU2(IEN,SUBFLD,ENTRY)
End DoDot:1
+22 IF FIELD=.04
IF $LENGTH(X)=1
SET X="0"_X
+23 QUIT X
+24 ;
SUB164(IEN,SUBFLD,ENTRY) ;ICDO TOPOGRAPHY (164)
+1 NEW X,TOP1,TOP2
+2 SET X=""
+3 SET TOP1=$$GET1^DIQ(165.5,IEN,20,"I")
if TOP1'=""
Begin DoDot:1
+4 SET TOP2=$$GET1^DIQ(164,TOP1,107,"I")
+5 IF (TOP1=67420)!(TOP1=67421)!(TOP1=67423)!(TOP1=67424)!($EXTRACT(TOP1,3,4)=76)!(TOP1=67809)
IF ($GET(FIELD)=58.6)!($GET(FIELD)=58.7)
SET TOP2=67420
+6 IF ($GET(FIELD)=58.2)!($GET(FIELD)=50.2)!($GET(FIELD)=138)!($GET(FIELD)=138.1)!($GET(FIELD)=139)!($GET(FIELD)=139.1)!($GET(FIELD)=74)!($GET(FIELD)=23)
IF ($EXTRACT(TOP1,3,4)=76)!(TOP1=67809)!(TOP1=67420)!(TOP1=67421)!(TOP1=67423)!(TOP1=67424)
SET TOP2=67141
+7 ;p5 item#18
IF $$HEMATO^ONCFUNC(IEN)
IF TOP1=67179
SET TOP2=67420
+8 IF ($GET(FIELD)=58.2)!($GET(FIELD)=50.2)
IF TOP1=67422
SET TOP2=67770
+9 IF $GET(SUBFLD)="SUA"
IF ($EXTRACT(TOP1,3,4)=77)
SET TOP2=67141
+10 if TOP2'=""
Begin DoDot:2
+11 SET X=$PIECE($GET(^ONCO(164,TOP2,SUBFLD,ENTRY,0)),U,2)
End DoDot:2
End DoDot:1
+12 QUIT X
+13 ;
RXPRI(IEN,FIELD,SUBFLD) ;
+1 ;RX Hosp--Surg Prim Site [670] 457-458
+2 ;RX Hosp--Surg Site 98-02 [746] 478-479
+3 ;RX Hosp--Scope Reg 98-02 [747] 480-480
+4 ;RX Hosp--Surg Oth 98-02 [748] 481-481
+5 ;RX Summ--Surg Prim Site [1290] 859-860
+6 ;RX Summ--Surgical Approch [1310] 865-865
+7 ;RX Summ--Reconstruct 1st [1330] 867-867
+8 ;RX Summ--Surg Site 98-02 [1646] 939-940
+9 ;RX Summ--Scope Reg 98-02 [1647] 941-941
+10 ;RX Summ--Surg Oth 98-02 [1648] 942-942
+11 NEW X,ENTRY
+12 SET X=""
+13 SET TOP1=$$GET1^DIQ(165.5,IEN,20,"I")
+14 SET ENTRY=$$GET1^DIQ(165.5,IEN,FIELD,"I")
if ENTRY'=""
Begin DoDot:1
+15 IF (TOP1=67420)!(TOP1=67421)!(TOP1=67423)!(TOP1=67424)!($EXTRACT(TOP1,3,4)=76)!(TOP1=67809)
IF ($GET(FIELD)=58.6)!($GET(FIELD)=58.7)
SET X=$$SUB164^ONCACDU2(IEN,SUBFLD,ENTRY)
QUIT
+16 IF $$GET1^DIQ(165.5,IEN,3,"I")<2980000
IF (FIELD=23)!(FIELD=74)!(FIELD=50.2)!(FIELD=58.2)!(FIELD=58.6)!(FIELD=58.7)
SET X=$SELECT(FIELD=23:$$GET1^DIQ(160.4,ENTRY,.01,"I"),FIELD=74:$$GET1^DIQ(160.6,ENTRY,.01,"I"),1:ENTRY)
QUIT
+17 SET X=$$SUB164^ONCACDU2(IEN,SUBFLD,ENTRY)
End DoDot:1
+18 QUIT X
+19 ;
FNODE(ACD160,FIELD) ;FOLLOW-UP (160,400)
+1 ;Date of Last Contact [1750] 1294-1301
+2 ;Vital Status [1760] 1302-1302
+3 ;Quality of Survival [1780] 1304-1304
+4 ;Follow-Up Source [1790] 1305-1305
+5 ;Next Follow-Up Source [1800] 1306-1306
+6 ;Unusual Follow-Up Method [1850] 1341-1341
+7 ;Following Registry [2440] 2475-2484
+8 NEW FNODE,X
+9 SET FNODE=$$LAST(ACD160)
SET X=""
+10 IF FNODE'=""
Begin DoDot:1
+11 NEW IENS
+12 SET IENS=FNODE_","_ACD160_","
+13 SET X=$$GET1^DIQ(160.04,IENS,FIELD,"I")
End DoDot:1
+14 QUIT X
+15 ;
LAST(ACD160) ;Get last FOLLOW-UP(160,400)
+1 NEW DLC
+2 SET X=""
SET DLC=0
+3 SET DLC=$ORDER(^ONCO(160,ACD160,"F","AA",DLC))
+4 if DLC'=""
SET X=$ORDER(^ONCO(160,ACD160,"F","AA",DLC,0))
+5 IF X'>0
SET X=""
+6 QUIT X
+7 ;
FCNODE(ACD160,FIELD,IE) ;FOLLOW-UP CONTACT (160,420)
+1 ;Follow-Up Contact--City [1842] 1357-1376
+2 ;Follow-Up Contact--State [1844] 1377-1378
+3 ;Follow-Up Contact--Postal[1846] 1379-1387
+4 ;Follow-Up Contact--Name [2394] 2284-2313
+5 ;Follow-Up Contact--No&St [2392] 2314-2353
+6 ;Follow-Up Contact--Suppl [2393] 2354-2393
+7 NEW CONTACT,FCNODE,X
+8 SET X=""
+9 SET FCNODE=$ORDER(^ONCO(160,ACD160,"C","B"),-1)
+10 IF FCNODE'=""
Begin DoDot:1
+11 NEW IENS
+12 SET IENS=FCNODE_","_ACD160_","
+13 SET CONTACT=$$GET1^DIQ(160.03,IENS,1,"I")
End DoDot:1
+14 IF $GET(CONTACT)
SET X=$$GET1^DIQ(165,CONTACT,FIELD,IE)
+15 QUIT X
+16 ;
CS(IEN) ;Cancer Status [1770] 1303-1303
+1 NEW X,Z,FNODE
+2 SET FNODE=0
+3 SET X=""
+4 SET FNODE=$ORDER(^ONCO(165.5,IEN,"TS",FNODE))
+5 IF FNODE>0
Begin DoDot:1
+6 NEW IENS,PT
+7 SET FNODE=$ORDER(^ONCO(165.5,IEN,"TS"," "),-1)
+8 if FNODE<1
QUIT
+9 SET IENS=FNODE_","_IEN_","
+10 SET PT=$$GET1^DIQ(165.573,IENS,.02,"I")
+11 if PT<1
QUIT
+12 SET X=$$GET1^DIQ(164.42,PT,1,"I")
End DoDot:1
+13 QUIT X
+14 ;
CCTST(ACD160) ;
+1 ;Addr Current--City [1810] 1307-1326
+2 NEW D0,PT,X
+3 SET D0=ACD160
+4 SET X=""
SET PT=$PIECE($GET(^ONCO(160,D0,0)),";",1)
+5 IF $$DPTLRT^ONCOES(D0)="LRT"
SET X=$$GET1^DIQ(67,PT,.114,"E")
+6 IF $$DPTLRT^ONCOES(D0)="DPT"
SET X=$$GET1^DIQ(2,PT,.114,"E")
+7 SET X=$$STRIP^XLFSTR(X,"!""""#$%&'()*+,-./:;<=>?[>]^_\{|}~`")
+8 QUIT X
+9 ;
CSTST(ACD160) ;
+1 ;Addr Current--State [1820] 1327-1328
+2 NEW ONCX,XPT,XX,PT
+3 SET (XPT,XX)=""
+4 ;check override
SET ITEM=1820
DO CHKADDS^ONCACDU1
IF ONCADDF'=""
QUIT ONCADDF
+5 SET ONCX=$$GET1^DIQ(160,ACD160,.115,"E")
+6 ;S X=$S(X="CANAD":"CD",X="EU":"YY",X="MX":"XX",X="NF":"NL",X="PH":"XX",X="UN":"ZZ",1:X)
+7 IF ONCX=""
SET PT=$PIECE($GET(^ONCO(160,ACD160,0)),";",1)
Begin DoDot:1
+8 IF $$DPTLRT(ACD160)="LRT"
SET XPT=$$GET1^DIQ(67,PT,.115,"I")
if $GET(XPT)
SET XX=$$GET1^DIQ(5,XPT,1,"E")
+9 IF $$DPTLRT(ACD160)="DPT"
SET XPT=$$GET1^DIQ(2,PT,.1173,"I")
if $GET(XPT)
SET XX=$$GET1^DIQ(779.004,XPT,.01,"E")
if XPT=""
Begin DoDot:2
+10 SET XPT=$$GET1^DIQ(2,PT,.115,"I")
if $GET(XPT)
SET XX=$$GET1^DIQ(5,XPT,1,"E")
End DoDot:2
End DoDot:1
+11 IF (ONCX="")
IF (XX'="")
IF (XX'="USA")
IF (XX'="CAN")
SET ONCX="XX"
+12 IF (ONCX="")
IF (XX="")
SET ONCX="YY"
+13 IF (ONCX="")
IF (XX="USA")
SET ONCX="US"
+14 IF (ONCX="")
IF (XX="CAN")
SET ONCX="CD"
+15 IF ONCX="UN"
SET ONCX="ZZ"
+16 QUIT ONCX
+17 ;
ADDCTRY(IEN,ITEM) ;
+1 ;Addr at DX--Country [102] 436-438
+2 ;Addr Current--Country [1832] 439-441
+3 ;Followup Contact--Country [1847] 447-449
+4 ; Value derived from:
+5 ; ITEM #102 - STATE AT DX (#165.5,16) pointer to File #5
+6 ; ITEM #1832 - COUNTRY FILE (#2,.1173) pointer to File #779.004 or State File (#2,.115) to File #5
+7 ; ITEM #1847 - ZIP CODE (#165,.119 --> #5.11,3) pointer to File #5
+8 ;
+9 ; IF VALUE IS NOT FILLED IN OR NOT FOUND, DEFAULT TO "ZZU" (UNKNOWN)
+10 ;
+11 NEW XX
+12 ;check override
DO CHKADDS^ONCACDU1
IF ONCADDF'=""
QUIT ONCADDF
+13 SET ACDANS="USA"
+14 IF ITEM=102
SET XX=$SELECT($$GET1^DIQ(165.5,IEN,16,"I")'="":$$GET1^DIQ(5,$$GET1^DIQ(165.5,IEN,16,"I"),1,"I"),1:"")
+15 IF ITEM=1832
Begin DoDot:1
+16 SET (X,XX)=""
SET PT=$PIECE($GET(^ONCO(160,ACD160,0)),";",1)
+17 IF $$DPTLRT(ACD160)="LRT"
SET X=$$GET1^DIQ(67,PT,.115,"I")
if $GET(X)
SET XX=$$GET1^DIQ(5,X,1,"E")
+18 IF $$DPTLRT(ACD160)="DPT"
SET X=$$GET1^DIQ(2,PT,.1173,"I")
if $GET(X)
SET (XX,ACDANS)=$$GET1^DIQ(779.004,X,.01,"E")
+19 SET X=$$GET1^DIQ(2,PT,.115,"I")
if $GET(X)
SET XX=$$GET1^DIQ(5,X,1,"E")
End DoDot:1
+20 IF ITEM=1847
SET XX=""
SET VICPNT=$$FCNODE^ONCACDU2(ACD160,.119,"I")
if $GET(VICPNT)
SET STATE=$PIECE($GET(^VIC(5.11,VICPNT,0)),U,4)
if $GET(STATE)'=""
SET XX=$$GET1^DIQ(5,STATE,1,"I")
KILL STATE,VICPNT
+21 IF XX="QC"!(XX="AB")!(XX="ZZMB")!(XX="NB")!(XX="NF")!(XX="NS")!(XX="NT")!(XX="ON")!(XX="PE")!(XX="SK")!(XX="YT")!(XX="CANAD")!(XX="MB")!(XX="NU")!(XX="BC")
SET ACDANS="CAN"
+22 IF XX="FM"
SET ACDANS="FSM"
+23 IF XX="GU"
SET ACDANS="GUM"
+24 IF XX="MH"
SET ACDANS="MHL"
+25 IF XX="MP"
SET ACDANS="MNP"
+26 IF XX="PW"
SET ACDANS="PWL"
+27 IF XX="UM"
SET ACDANS="UMI"
+28 IF XX="FG"
SET ACDANS="ZZX"
+29 IF XX="MX"
SET ACDANS="MEX"
+30 IF XX="EU"
SET ACDANS="ZZE"
+31 IF XX="PH"
SET ACDANS="PHL"
+32 IF XX="AS"
SET ACDANS="ASM"
+33 IF XX="PR"
SET ACDANS="PRI"
+34 IF XX="VI"
SET ACDANS="VIR"
+35 IF XX="ZZEQ"
SET ACDANS="KIR"
+36 IF XX="ZZIQ"
SET ACDANS="ZZP"
+37 IF XX="ZZYQ"
SET ACDANS="JPN"
+38 IF XX="UN"!(XX="")
SET ACDANS="ZZU"
+39 QUIT ACDANS
+40 ;
DPTLRT(ACD160) ;check if pt from Patient or Referral file
+1 NEW DPTLRT
+2 SET DPTLRT=""
+3 IF $PIECE($GET(^ONCO(160,ACD160,0)),U,1)["LRT"
SET DPTLRT="LRT"
+4 IF $PIECE($GET(^ONCO(160,ACD160,0)),U,1)["DPT"
SET DPTLRT="DPT"
+5 QUIT DPTLRT
+6 ;
ICD(ICD) ;ICD Code
+1 ;Use ICD API (IA #3990) instead of direct global read.
+2 NEW X
+3 SET ICD=$SELECT(ICD'="":$$GET1^DIQ(80,ICD,.01),1:"0000")
+4 IF ICD["."
SET ICD=$PIECE(ICD,".")_$PIECE(ICD,".",2)
+5 if $LENGTH(ICD)=3
SET ICD=ICD_9
+6 if $LENGTH(ICD)<4
SET ICD=$EXTRACT("0000",1,4-$LENGTH(ICD))_ICD
+7 if $LENGTH(ICD)>4
SET ICD=$EXTRACT(ICD,1,4)
+8 IF $EXTRACT(ICD,4)="X"!($EXTRACT(ICD,4)="-")
SET ICD=$EXTRACT(ICD,1,3)_9
+9 QUIT ICD
+10 ;
ICDR(ICD) ;ICD Revision Number [1920] 1392-1392
+1 NEW ICDR
+2 SET ICD=$$ICD(ICD)
+3 SET ICDR=$SELECT(ICD=" ":0,1:$$GET1^DIQ(160,ACD160,20,"I"))
+4 if ICDR=""
SET ICDR=0
+5 QUIT ICDR
+6 ;
PPAY(IEN) ;PRIMARY PAYER AT DX (165.5,18)
+1 NEW X
+2 SET X=$$GET1^DIQ(165.5,IEN,18,"I")
+3 SET X=$$GET1^DIQ(160.3,$SELECT(X'="":X,1:99),.01,"I")
+4 SET X=$SELECT(X<42:X,X>47:X,1:X-1)
+5 QUIT X
+6 ;
DS(IEN) ;RX Date--Surgery [1200] 755-762
+1 NEW X
+2 SET X=$$GET1^DIQ(165.5,IEN,50,"I")
IF X'=""
SET SURGDT(X)=""
+3 SET X=$$GET1^DIQ(165.5,IEN,138.2,"I")
IF X'=""
SET SURGDT(X)=""
+4 SET X=$$GET1^DIQ(165.5,IEN,139.2,"I")
IF X'=""
SET SURGDT(X)=""
+5 SET SURGDT=$ORDER(SURGDT(0))
+6 SET X=$$DATE^ONCACDU1(SURGDT)
+7 KILL SURGDT
+8 QUIT X
STRIP ;Replace punctuation marks with spaces
+1 SET ACDANS=$TRANSLATE(ACDANS,"!""""@#$%&'()*+,-./:;<=>?[>]^_\{|}~`"," ")
+2 SET ACDANS=$$TRIM^XLFSTR(ACDANS)
+3 QUIT
+4 ;
STRIP1 ;Strip out punctuation marks
+1 SET ACDANS=$$STRIP^XLFSTR(ACDANS,"!""""#$%&'()*+,-./:;<=>?[>]^_\{|}~`")
+2 QUIT
+3 ;
STNUM ;get 3-digit state number for state extract. reporting facility must be the same w/ 160.1 entry.
+1 ;if no 3-digit number, use the initial from file #200
+2 NEW ONC3DIG,ONC1601,ONC3IEN,ONC16019
+3 SET ONC3DIG=""
+4 SET ONC16019=$$GET1^DIQ(165.5,IEN,.03,"I")
SET ONC1601=0
+5 FOR
SET ONC1601=$ORDER(^ONCO(160.1,"D",ACDANS,ONC1601))
if ONC1601'>0
QUIT
Begin DoDot:1
+6 IF $DATA(^ONCO(160.1,ONC1601,1))
IF $PIECE(^(1),U,4)'=ONC16019
QUIT
+7 SET ONC3IEN=$ORDER(^ONCO(160.1,"D",ACDANS,ONC1601,0))
if $GET(ONC3IEN)
SET ONC3DIG=$PIECE(^ONCO(160.1,ONC1601,"REG",ONC3IEN,0),U,2)
End DoDot:1
+8 if ONC3DIG=""
SET ACDANS=$EXTRACT($$GET1^DIQ(200,ACDANS,1,"I"),1,3)
+9 IF ONC3DIG'=""
SET ACDANS=$SELECT($LENGTH(ONC3DIG)=1:"00"_ONC3DIG,$LENGTH(ONC3DIG)=2:"0"_ONC3DIG,1:ONC3DIG)
+10 QUIT
+11 ;
CLEANUP ;Cleanup
+1 KILL EXTRACT
