Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ONCACDU2

ONCACDU2.m

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