ONCORISD ;HINES OIFO/RTK - OncoTrax Data to ORIS ;07/02/25
;;2.2;ONCOLOGY;**23**;Jul 31, 2013;Build 6
;
;This routine will generate/display a list of all the files migrating
;to ORIS, and for each file it will list each field number, field
;name, sub-field (for multiples), data type and (if applicable) file
;pointed-to.
;
GEN ;
;
;first do KILL to clear out file #160.9 and build it from scratch
I '$D(ZTQUEUED) W !!?4,"Building ONCOLOGY MIGRATION File..."
D KILL
;
;first do all of the ONCOLOGY (ONC 160-160.99/164-169.99) files
S FILENUM=159.999 F S FILENUM=$O(^ONCO(FILENUM)) Q:FILENUM'>0 D
.K DD,DO
.S DIC="^ONCO(160.9,",DIC(0)="Z" S X=FILENUM D FILE^DICN ;creates the file#
.D GETDDS
;
;next do all of the files external to ONC files
;
;F FILENUM=2,5,67,200 D ; only do these 4 external fields for now
;F FILENUM=2,4,4.11,5,5.11,10,11,11.99,20,20.11,21,40.8,45.7,50,67,75.1,80,200,771.7,9000010 D ; this was the original list; pared down 3/31/26
F FILENUM=2,5,67,200 D ; only do these 4 external fields for now
.K DD,DO
.S DIC="^ONCO(160.9,",DIC(0)="Z" S X=FILENUM D FILE^DICN ;creates the file#
.D GETDDS
I '$D(ZTQUEUED) W !?4,"...done",!
Q
;
GETDDS ;get the fields and data types for each file
N ONCFLNM
S ONCFLNM=$P($G(^DIC(FILENUM,0)),"^",1)
;W !!,"--------------------------------------------------------------------------------"
;W !,"FILE NUMBER: ",FILENUM," ",ONCFLNM
I FILENUM="" Q
N DDNUM,ONCEXCTY
S ONCEXCTY=""
;W !!?18,"SUB-",?71,"POINTED"
;W !,"FILE #",?8,"FIELD #",?18,"FLD #",?24,"FIELD NAME",?55,"DATA TYPE",?71,"TO FILE"
;W !,"=======",?8,"========",?18,"=====",?24,"==========",?55,"=========",?71,"========"
S DDNUM=0 F S DDNUM=$O(^DD(FILENUM,DDNUM)) Q:DDNUM'>0 D
.I (FILENUM=165.5)&((DDNUM>299.99)&(DDNUM<957)) Q ; skip these in file 165.5
.I (FILENUM=165.5)&((DDNUM>999.99)&(DDNUM<1423)) Q
.I (FILENUM=165.5)&((DDNUM>1423.4)&(DDNUM<1580)) Q
.S DDSKIP=1 I FILENUM=2 D I DDSKIP=1 Q ; only include these for file 2
..I (DDNUM=".01")!(DDNUM=".02")!(DDNUM=".021")!(DDNUM=".03")!(DDNUM=".031")!(DDNUM=".05")!(DDNUM=".06")!(DDNUM=".07")!(DDNUM=".09")!(DDNUM=".104")!(DDNUM=".1041")!(DDNUM=".111") S DDSKIP=0 Q
..I (DDNUM=".1112")!(DDNUM=".1118")!(DDNUM=".112")!(DDNUM=".113")!(DDNUM=".114")!(DDNUM=".115")!(DDNUM=".1151")!(DDNUM=".1152")!(DDNUM=".1153")!(DDNUM=".1154")!(DDNUM=".1155")!(DDNUM=".1156") S DDSKIP=0 Q
..I (DDNUM=".1157")!(DDNUM=".11571")!(DDNUM=".11572")!(DDNUM=".11573")!(DDNUM=".1158")!(DDNUM=".11581")!(DDNUM=".11582")!(DDNUM=".11583")!(DDNUM=".1159")!(DDNUM=".116")!(DDNUM=".117")!(DDNUM=".1171") S DDSKIP=0 Q
..I (DDNUM=".1172")!(DDNUM=".1173")!(DDNUM=".3121")!(DDNUM=".32102")!(DDNUM=".32103")!(DDNUM=".32107")!(DDNUM=".32108")!(DDNUM=".32109")!(DDNUM=".3211")!(DDNUM=".32111")!(DDNUM=".32116")!(DDNUM=".32117") S DDSKIP=0 Q
..I (DDNUM=".3212")!(DDNUM=".3213")!(DDNUM=".321701")!(DDNUM=".321702")!(DDNUM=".321703")!(DDNUM=".321704")!(DDNUM=".32201")!(DDNUM=".322011")!(DDNUM=".322012")!(DDNUM=".351")!(DDNUM=".352")!(DDNUM=1) S DDSKIP=0 Q
..I (DDNUM=2)!(DDNUM=6)!(DDNUM=991.01)!(DDNUM=991.02)!(DDNUM=991.11)!(DDNUM=1901) S DDSKIP=0 Q
.S DDSKIP=1 I FILENUM=200 D I DDSKIP=1 Q ; only include these for file 200
..I (DDNUM=".01")!(DDNUM=".151")!(DDNUM=1)!(DDNUM=9.2)!(DDNUM=10)!(DDNUM=10.1)!(DDNUM=13)!(DDNUM=16)!(DDNUM=30)!(DDNUM=42)!(DDNUM=654.1) S DDSKIP=0 Q
.N NODEPC1,NODEPC2,NODEPC3,NODEPC4
.S NODEPC1=$P($G(^DD(FILENUM,DDNUM,0)),"^",1) ;field name
.S NODEPC2=$P($G(^DD(FILENUM,DDNUM,0)),"^",2) ;data type +
.S NODEPC3=$P($G(^DD(FILENUM,DDNUM,0)),"^",3) ;pntd-to file # or set of codes
.S NODEPC4=$P($G(^DD(FILENUM,DDNUM,0)),"^",4) ;position
.I NODEPC4=" ; " Q ;skip computed fields
.I $P(NODEPC4,";",2)=0 D FLDTYP D SETMAP Q ; determine if MULT or WP field
.I FILENUM=4,DDNUM=.01 S ONCEXCTY="FREE TEXT"
.I FILENUM=5,DDNUM=.01 S ONCEXCTY="FREE TEXT"
.I FILENUM=164.4,DDNUM=.01 S ONCEXCTY="FREE TEXT"
.I NODEPC2["D" S ONCEXCTY="DATE/TIME"
.I NODEPC2["N" S ONCEXCTY="NUMERIC"
.I NODEPC2["S" S ONCEXCTY="SET OF CODES"
.I NODEPC2["F" S ONCEXCTY="FREE TEXT"
.I NODEPC2["P" S ONCEXCTY="POINTER TO FILE"
.I NODEPC2["V" S ONCEXCTY="VARIABLE-PNTR"
.I NODEPC2["B" S ONCEXCTY="BOOLEAN"
.I NODEPC2["T" S ONCEXCTY="TIME"
.I NODEPC2["Y" S ONCEXCTY="YEAR"
.I ONCEXCTY="" Q
.;W !,FILENUM,?8,DDNUM,?24,NODEPC1,?55,ONCEXCTY D
.;.I ($E(ONCEXCTY,1)="P") S ONCTMPZ=$P(NODEPC2,"P",2) W ?71,+ONCTMPZ
.;.I ($E(ONCEXCTY,1)="V") S ONCTMPZ=$P(NODEPC2,"P",2) D
.;..F VN=0:0 S VN=$O(^DD(FILENUM,DDNUM,"V",VN)) Q:VN'>0 D
.;...W ?71,$P($G(^DD(FILENUM,DDNUM,"V",VN,0)),"^",1)," > "
.D SETMAP
.Q
;
Q
;
FLDTYP ;determine if field is a word processing or multiple field
; if a word processing field return "W", if multiple field return "M"
S ONCEXCTY="MULTIPLE"
S DDSUB=+$P($G(^DD(FILENUM,DDNUM,0)),"^",2)
I $P($G(^DD(DDSUB,.01,0)),"^",2)["W" S ONCEXCTY="WORD-PROCESSING"
;W !,FILENUM,?8,DDNUM,?24,NODEPC1,?55,ONCEXCTY
I ONCEXCTY="MULTIPLE" D
.N SUBFN,SUBFNAM,SUBFTYP,SUBPOSN,SBTYDISP
.F SUBFN=0:0 S SUBFN=$O(^DD(DDSUB,SUBFN)) Q:SUBFN'>0 D
..S SUBFNAM=$P($G(^DD(DDSUB,SUBFN,0)),"^",1)
..S SUBFTYP=$P($G(^DD(DDSUB,SUBFN,0)),"^",2)
..S SUBPOSN=$P($G(^DD(DDSUB,SUBFN,0)),"^",4) ;position
..I SUBPOSN=" ; " Q ;skip computed fields
..I $P(SUBPOSN,";",2)=0 Q ; determine if MULT or WP field/QUIT for now
..I SUBFTYP["D" S SBTYDISP="DATE/TIME"
..I SUBFTYP["N" S SBTYDISP="NUMERIC"
..I SUBFTYP["S" S SBTYDISP="SET OF CODES"
..I SUBFTYP["F" S SBTYDISP="FREE TEXT"
..I SUBFTYP["P" S SBTYDISP="POINTER TO FILE"
..I SUBFTYP["V" S SBTYDISP="VARIABLE-PNTR"
..I SUBFTYP["B" S SBTYDISP="BOOLEAN"
..I SUBFTYP["T" S SBTYDISP="TIME"
..I SUBFTYP["Y" S SBTYDISP="YEAR"
..I SBTYDISP="" Q
..;W !?18,SUBFN,?24,SUBFNAM,?55,SBTYDISP
..;I ($E(SBTYDISP,1)="P") S ONCTMPZ=$P(SUBFTYP,"P",2) W ?71,+ONCTMPZ
Q
;
SETMAP ;set the field multiple for the file map in file #160.9
S ONC1609=$O(^ONCO(160.9,"B",FILENUM,"")) I ONC1609="" Q
S DA(1)=ONC1609,DIC="^ONCO(160.9,"_DA(1)_",1,",DIC(0)="L" S X=DDNUM
D FILE^DICN ;create the new field in the multiple
S DA=+Y
S DA(1)=ONC1609
S DIE="^ONCO(160.9,"_DA(1)_",1,"
S DR="1///^S X=ONCEXCTY"
D ^DIE ;set the data type for the field
K DA,DIE,DR
Q
;
KILL ;kill existing entries and clean out file #160.9
S IEN1609=0 F S IEN1609=$O(^ONCO(160.9,IEN1609)) Q:IEN1609'>0 D
.;W !,"KILL ",IEN1609,": ",$P($G(^ONCO(160.9,IEN1609,0)),"^",1)
.S DA=IEN1609,DIK="^ONCO(160.9," D ^DIK
Q
;
GET200 ;
N ONCCIEN,ONCNIEN,ONCPIEN,ONCSIEN,ONCNSUB,ONCSSUB
K ONCAR200
;
S ONCPIEN=0 F S ONCPIEN=$O(^ONCO(165.5,ONCPIEN)) Q:ONCPIEN'>0 D
.S ONC200=$P($G(^ONCO(165.5,ONCPIEN,7)),"^",3) D
..I ONC200'="" I '$D(ONCAR200(ONC200)) S ONCAR200(ONC200)=ONC200
.S ONC200=$P($G(^ONCO(165.5,ONCPIEN,7)),"^",18) D
..I ONC200'="" I '$D(ONCAR200(ONC200)) S ONCAR200(ONC200)=ONC200
.S ONC200=$P($G(^ONCO(165.5,ONCPIEN,7)),"^",22) D
..I ONC200'="" I '$D(ONCAR200(ONC200)) S ONCAR200(ONC200)=ONC200
.S ONC200=$P($G(^ONCO(165.5,ONCPIEN,2.3)),"^",10) D
..I ONC200'="" I '$D(ONCAR200(ONC200)) S ONCAR200(ONC200)=ONC200
;
S ONCCIEN=0 F S ONCCIEN=$O(^ONCO(165,ONCCIEN)) Q:ONCCIEN'>0 D
.S ONC200=$P($G(^ONCO(165,ONCCIEN,"VA")),"^",1) D
..I ONC200'="" I '$D(ONCAR200(ONC200)) S ONCAR200(ONC200)=ONC200
;
S ONCNIEN=0 F S ONCNIEN=$O(^ONCO(160,ONCNIEN)) Q:ONCNIEN'>0 D
.S ONCNSUB=0 F S ONCNSUB=$O(^ONCO(160,ONCNIEN,"F",ONCNSUB)) Q:ONCNSUB'>0 D
..S ONC200=$P($G(^ONCO(160,ONCNIEN,"F",ONCNSUB,0)),"^",10) D
...I ONC200'="" I '$D(ONCAR200(ONC200)) S ONCAR200(ONC200)=ONC200
;
S ONCSIEN=0 F S ONCSIEN=$O(^ONCO(160.1,ONCSIEN)) Q:ONCSIEN'>0 D
.S ONCSSUB=0 F S ONCSSUB=$O(^ONCO(160.1,ONCSIEN,"QAU",ONCSSUB)) Q:ONCSSUB'>0 D
..S ONC200=$P($G(^ONCO(160.1,ONCSIEN,"QAU",ONCSSUB,0)),"^",1) D
...I ONC200'="" I '$D(ONCAR200(ONC200)) S ONCAR200(ONC200)=ONC200
S ONCSIEN=0 F S ONCSIEN=$O(^ONCO(160.1,ONCSIEN)) Q:ONCSIEN'>0 D
.S ONCSSUB=0 F S ONCSSUB=$O(^ONCO(160.1,ONCSIEN,"REG",ONCSSUB)) Q:ONCSSUB'>0 D
..S ONC200=$P($G(^ONCO(160.1,ONCSIEN,"REG",ONCSSUB,0)),"^",1) D
...I ONC200'="" I '$D(ONCAR200(ONC200)) S ONCAR200(ONC200)=ONC200
;
Q
;
TESTSUM ;
S NUMZY=0,NUMDEC=0
S ONCMAPN=0 F S ONCMAPN=$O(^ONCO(160.9,ONCMAPN)) Q:ONCMAPN'>0 D
.S FILENUM=$P($G(^ONCO(160.9,ONCMAPN,0)),"^",1)
.S ONCFDMUL=0 F S ONCFDMUL=$O(^ONCO(160.9,ONCMAPN,1,ONCFDMUL)) Q:ONCFDMUL'>0 D
..S FEELNUM=$P($G(^ONCO(160.9,ONCMAPN,1,ONCFDMUL,0)),"^",1)
..S NUMZY=NUMZY+1
..W !,NUMZY," ","FIELD # = ",FEELNUM
..I FEELNUM?1".".N S NUMDEC=NUMDEC+1 W "**********"
W !!,"TOTAL NUMBER = ",NUMDEC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCORISD 8703 printed Jul 22, 2026@15:33:35 Page 2
ONCORISD ;HINES OIFO/RTK - OncoTrax Data to ORIS ;07/02/25
+1 ;;2.2;ONCOLOGY;**23**;Jul 31, 2013;Build 6
+2 ;
+3 ;This routine will generate/display a list of all the files migrating
+4 ;to ORIS, and for each file it will list each field number, field
+5 ;name, sub-field (for multiples), data type and (if applicable) file
+6 ;pointed-to.
+7 ;
GEN ;
+1 ;
+2 ;first do KILL to clear out file #160.9 and build it from scratch
+3 IF '$DATA(ZTQUEUED)
WRITE !!?4,"Building ONCOLOGY MIGRATION File..."
+4 DO KILL
+5 ;
+6 ;first do all of the ONCOLOGY (ONC 160-160.99/164-169.99) files
+7 SET FILENUM=159.999
FOR
SET FILENUM=$ORDER(^ONCO(FILENUM))
if FILENUM'>0
QUIT
Begin DoDot:1
+8 KILL DD,DO
+9 ;creates the file#
SET DIC="^ONCO(160.9,"
SET DIC(0)="Z"
SET X=FILENUM
DO FILE^DICN
+10 DO GETDDS
End DoDot:1
+11 ;
+12 ;next do all of the files external to ONC files
+13 ;
+14 ;F FILENUM=2,5,67,200 D ; only do these 4 external fields for now
+15 ;F FILENUM=2,4,4.11,5,5.11,10,11,11.99,20,20.11,21,40.8,45.7,50,67,75.1,80,200,771.7,9000010 D ; this was the original list; pared down 3/31/26
+16 ; only do these 4 external fields for now
FOR FILENUM=2,5,67,200
Begin DoDot:1
+17 KILL DD,DO
+18 ;creates the file#
SET DIC="^ONCO(160.9,"
SET DIC(0)="Z"
SET X=FILENUM
DO FILE^DICN
+19 DO GETDDS
End DoDot:1
+20 IF '$DATA(ZTQUEUED)
WRITE !?4,"...done",!
+21 QUIT
+22 ;
GETDDS ;get the fields and data types for each file
+1 NEW ONCFLNM
+2 SET ONCFLNM=$PIECE($GET(^DIC(FILENUM,0)),"^",1)
+3 ;W !!,"--------------------------------------------------------------------------------"
+4 ;W !,"FILE NUMBER: ",FILENUM," ",ONCFLNM
+5 IF FILENUM=""
QUIT
+6 NEW DDNUM,ONCEXCTY
+7 SET ONCEXCTY=""
+8 ;W !!?18,"SUB-",?71,"POINTED"
+9 ;W !,"FILE #",?8,"FIELD #",?18,"FLD #",?24,"FIELD NAME",?55,"DATA TYPE",?71,"TO FILE"
+10 ;W !,"=======",?8,"========",?18,"=====",?24,"==========",?55,"=========",?71,"========"
+11 SET DDNUM=0
FOR
SET DDNUM=$ORDER(^DD(FILENUM,DDNUM))
if DDNUM'>0
QUIT
Begin DoDot:1
+12 ; skip these in file 165.5
IF (FILENUM=165.5)&((DDNUM>299.99)&(DDNUM<957))
QUIT
+13 IF (FILENUM=165.5)&((DDNUM>999.99)&(DDNUM<1423))
QUIT
+14 IF (FILENUM=165.5)&((DDNUM>1423.4)&(DDNUM<1580))
QUIT
+15 ; only include these for file 2
SET DDSKIP=1
IF FILENUM=2
Begin DoDot:2
+16 IF (DDNUM=".01")!(DDNUM=".02")!(DDNUM=".021")!(DDNUM=".03")!(DDNUM=".031")!(DDNUM=".05")!(DDNUM=".06")!(DDNUM=".07")!(DDNUM=".09")!(DDNUM=".104")!(DDNUM=".1041")!(DDNUM=".111")
SET DDSKIP=0
QUIT
+17 IF (DDNUM=".1112")!(DDNUM=".1118")!(DDNUM=".112")!(DDNUM=".113")!(DDNUM=".114")!(DDNUM=".115")!(DDNUM=".1151")!(DDNUM=".1152")!(DDNUM=".1153")!(DDNUM=".1154")!(DDNUM=".1155")!(DDNUM=".1156")
SET DDSKIP=0
QUIT
+18 IF (DDNUM=".1157")!(DDNUM=".11571")!(DDNUM=".11572")!(DDNUM=".11573")!(DDNUM=".1158")!(DDNUM=".11581")!(DDNUM=".11582")!(DDNUM=".11583")!(DDNUM=".1159")!(DDNUM=".116")!(DDNUM=".117")!(DDNUM=".1171")
SET DDSKIP=0
QUIT
+19 IF (DDNUM=".1172")!(DDNUM=".1173")!(DDNUM=".3121")!(DDNUM=".32102")!(DDNUM=".32103")!(DDNUM=".32107")!(DDNUM=".32108")!(DDNUM=".32109")!(DDNUM=".3211")!(DDNUM=".32111")!(DDNUM=".32116")!(DDNUM=".32117")
SET DDSKIP=0
QUIT
+20 IF (DDNUM=".3212")!(DDNUM=".3213")!(DDNUM=".321701")!(DDNUM=".321702")!(DDNUM=".321703")!(DDNUM=".321704")!(DDNUM=".32201")!(DDNUM=".322011")!(DDNUM=".322012")!(DDNUM=".351")!(DDNUM=".352")!(DDNUM=1)
SET DDSKIP=0
QUIT
+21 IF (DDNUM=2)!(DDNUM=6)!(DDNUM=991.01)!(DDNUM=991.02)!(DDNUM=991.11)!(DDNUM=1901)
SET DDSKIP=0
QUIT
End DoDot:2
IF DDSKIP=1
QUIT
+22 ; only include these for file 200
SET DDSKIP=1
IF FILENUM=200
Begin DoDot:2
+23 IF (DDNUM=".01")!(DDNUM=".151")!(DDNUM=1)!(DDNUM=9.2)!(DDNUM=10)!(DDNUM=10.1)!(DDNUM=13)!(DDNUM=16)!(DDNUM=30)!(DDNUM=42)!(DDNUM=654.1)
SET DDSKIP=0
QUIT
End DoDot:2
IF DDSKIP=1
QUIT
+24 NEW NODEPC1,NODEPC2,NODEPC3,NODEPC4
+25 ;field name
SET NODEPC1=$PIECE($GET(^DD(FILENUM,DDNUM,0)),"^",1)
+26 ;data type +
SET NODEPC2=$PIECE($GET(^DD(FILENUM,DDNUM,0)),"^",2)
+27 ;pntd-to file # or set of codes
SET NODEPC3=$PIECE($GET(^DD(FILENUM,DDNUM,0)),"^",3)
+28 ;position
SET NODEPC4=$PIECE($GET(^DD(FILENUM,DDNUM,0)),"^",4)
+29 ;skip computed fields
IF NODEPC4=" ; "
QUIT
+30 ; determine if MULT or WP field
IF $PIECE(NODEPC4,";",2)=0
DO FLDTYP
DO SETMAP
QUIT
+31 IF FILENUM=4
IF DDNUM=.01
SET ONCEXCTY="FREE TEXT"
+32 IF FILENUM=5
IF DDNUM=.01
SET ONCEXCTY="FREE TEXT"
+33 IF FILENUM=164.4
IF DDNUM=.01
SET ONCEXCTY="FREE TEXT"
+34 IF NODEPC2["D"
SET ONCEXCTY="DATE/TIME"
+35 IF NODEPC2["N"
SET ONCEXCTY="NUMERIC"
+36 IF NODEPC2["S"
SET ONCEXCTY="SET OF CODES"
+37 IF NODEPC2["F"
SET ONCEXCTY="FREE TEXT"
+38 IF NODEPC2["P"
SET ONCEXCTY="POINTER TO FILE"
+39 IF NODEPC2["V"
SET ONCEXCTY="VARIABLE-PNTR"
+40 IF NODEPC2["B"
SET ONCEXCTY="BOOLEAN"
+41 IF NODEPC2["T"
SET ONCEXCTY="TIME"
+42 IF NODEPC2["Y"
SET ONCEXCTY="YEAR"
+43 IF ONCEXCTY=""
QUIT
+44 ;W !,FILENUM,?8,DDNUM,?24,NODEPC1,?55,ONCEXCTY D
+45 ;.I ($E(ONCEXCTY,1)="P") S ONCTMPZ=$P(NODEPC2,"P",2) W ?71,+ONCTMPZ
+46 ;.I ($E(ONCEXCTY,1)="V") S ONCTMPZ=$P(NODEPC2,"P",2) D
+47 ;..F VN=0:0 S VN=$O(^DD(FILENUM,DDNUM,"V",VN)) Q:VN'>0 D
+48 ;...W ?71,$P($G(^DD(FILENUM,DDNUM,"V",VN,0)),"^",1)," > "
+49 DO SETMAP
+50 QUIT
End DoDot:1
+51 ;
+52 QUIT
+53 ;
FLDTYP ;determine if field is a word processing or multiple field
+1 ; if a word processing field return "W", if multiple field return "M"
+2 SET ONCEXCTY="MULTIPLE"
+3 SET DDSUB=+$PIECE($GET(^DD(FILENUM,DDNUM,0)),"^",2)
+4 IF $PIECE($GET(^DD(DDSUB,.01,0)),"^",2)["W"
SET ONCEXCTY="WORD-PROCESSING"
+5 ;W !,FILENUM,?8,DDNUM,?24,NODEPC1,?55,ONCEXCTY
+6 IF ONCEXCTY="MULTIPLE"
Begin DoDot:1
+7 NEW SUBFN,SUBFNAM,SUBFTYP,SUBPOSN,SBTYDISP
+8 FOR SUBFN=0:0
SET SUBFN=$ORDER(^DD(DDSUB,SUBFN))
if SUBFN'>0
QUIT
Begin DoDot:2
+9 SET SUBFNAM=$PIECE($GET(^DD(DDSUB,SUBFN,0)),"^",1)
+10 SET SUBFTYP=$PIECE($GET(^DD(DDSUB,SUBFN,0)),"^",2)
+11 ;position
SET SUBPOSN=$PIECE($GET(^DD(DDSUB,SUBFN,0)),"^",4)
+12 ;skip computed fields
IF SUBPOSN=" ; "
QUIT
+13 ; determine if MULT or WP field/QUIT for now
IF $PIECE(SUBPOSN,";",2)=0
QUIT
+14 IF SUBFTYP["D"
SET SBTYDISP="DATE/TIME"
+15 IF SUBFTYP["N"
SET SBTYDISP="NUMERIC"
+16 IF SUBFTYP["S"
SET SBTYDISP="SET OF CODES"
+17 IF SUBFTYP["F"
SET SBTYDISP="FREE TEXT"
+18 IF SUBFTYP["P"
SET SBTYDISP="POINTER TO FILE"
+19 IF SUBFTYP["V"
SET SBTYDISP="VARIABLE-PNTR"
+20 IF SUBFTYP["B"
SET SBTYDISP="BOOLEAN"
+21 IF SUBFTYP["T"
SET SBTYDISP="TIME"
+22 IF SUBFTYP["Y"
SET SBTYDISP="YEAR"
+23 IF SBTYDISP=""
QUIT
+24 ;W !?18,SUBFN,?24,SUBFNAM,?55,SBTYDISP
+25 ;I ($E(SBTYDISP,1)="P") S ONCTMPZ=$P(SUBFTYP,"P",2) W ?71,+ONCTMPZ
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
SETMAP ;set the field multiple for the file map in file #160.9
+1 SET ONC1609=$ORDER(^ONCO(160.9,"B",FILENUM,""))
IF ONC1609=""
QUIT
+2 SET DA(1)=ONC1609
SET DIC="^ONCO(160.9,"_DA(1)_",1,"
SET DIC(0)="L"
SET X=DDNUM
+3 ;create the new field in the multiple
DO FILE^DICN
+4 SET DA=+Y
+5 SET DA(1)=ONC1609
+6 SET DIE="^ONCO(160.9,"_DA(1)_",1,"
+7 SET DR="1///^S X=ONCEXCTY"
+8 ;set the data type for the field
DO ^DIE
+9 KILL DA,DIE,DR
+10 QUIT
+11 ;
KILL ;kill existing entries and clean out file #160.9
+1 SET IEN1609=0
FOR
SET IEN1609=$ORDER(^ONCO(160.9,IEN1609))
if IEN1609'>0
QUIT
Begin DoDot:1
+2 ;W !,"KILL ",IEN1609,": ",$P($G(^ONCO(160.9,IEN1609,0)),"^",1)
+3 SET DA=IEN1609
SET DIK="^ONCO(160.9,"
DO ^DIK
End DoDot:1
+4 QUIT
+5 ;
GET200 ;
+1 NEW ONCCIEN,ONCNIEN,ONCPIEN,ONCSIEN,ONCNSUB,ONCSSUB
+2 KILL ONCAR200
+3 ;
+4 SET ONCPIEN=0
FOR
SET ONCPIEN=$ORDER(^ONCO(165.5,ONCPIEN))
if ONCPIEN'>0
QUIT
Begin DoDot:1
+5 SET ONC200=$PIECE($GET(^ONCO(165.5,ONCPIEN,7)),"^",3)
Begin DoDot:2
+6 IF ONC200'=""
IF '$DATA(ONCAR200(ONC200))
SET ONCAR200(ONC200)=ONC200
End DoDot:2
+7 SET ONC200=$PIECE($GET(^ONCO(165.5,ONCPIEN,7)),"^",18)
Begin DoDot:2
+8 IF ONC200'=""
IF '$DATA(ONCAR200(ONC200))
SET ONCAR200(ONC200)=ONC200
End DoDot:2
+9 SET ONC200=$PIECE($GET(^ONCO(165.5,ONCPIEN,7)),"^",22)
Begin DoDot:2
+10 IF ONC200'=""
IF '$DATA(ONCAR200(ONC200))
SET ONCAR200(ONC200)=ONC200
End DoDot:2
+11 SET ONC200=$PIECE($GET(^ONCO(165.5,ONCPIEN,2.3)),"^",10)
Begin DoDot:2
+12 IF ONC200'=""
IF '$DATA(ONCAR200(ONC200))
SET ONCAR200(ONC200)=ONC200
End DoDot:2
End DoDot:1
+13 ;
+14 SET ONCCIEN=0
FOR
SET ONCCIEN=$ORDER(^ONCO(165,ONCCIEN))
if ONCCIEN'>0
QUIT
Begin DoDot:1
+15 SET ONC200=$PIECE($GET(^ONCO(165,ONCCIEN,"VA")),"^",1)
Begin DoDot:2
+16 IF ONC200'=""
IF '$DATA(ONCAR200(ONC200))
SET ONCAR200(ONC200)=ONC200
End DoDot:2
End DoDot:1
+17 ;
+18 SET ONCNIEN=0
FOR
SET ONCNIEN=$ORDER(^ONCO(160,ONCNIEN))
if ONCNIEN'>0
QUIT
Begin DoDot:1
+19 SET ONCNSUB=0
FOR
SET ONCNSUB=$ORDER(^ONCO(160,ONCNIEN,"F",ONCNSUB))
if ONCNSUB'>0
QUIT
Begin DoDot:2
+20 SET ONC200=$PIECE($GET(^ONCO(160,ONCNIEN,"F",ONCNSUB,0)),"^",10)
Begin DoDot:3
+21 IF ONC200'=""
IF '$DATA(ONCAR200(ONC200))
SET ONCAR200(ONC200)=ONC200
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;
+23 SET ONCSIEN=0
FOR
SET ONCSIEN=$ORDER(^ONCO(160.1,ONCSIEN))
if ONCSIEN'>0
QUIT
Begin DoDot:1
+24 SET ONCSSUB=0
FOR
SET ONCSSUB=$ORDER(^ONCO(160.1,ONCSIEN,"QAU",ONCSSUB))
if ONCSSUB'>0
QUIT
Begin DoDot:2
+25 SET ONC200=$PIECE($GET(^ONCO(160.1,ONCSIEN,"QAU",ONCSSUB,0)),"^",1)
Begin DoDot:3
+26 IF ONC200'=""
IF '$DATA(ONCAR200(ONC200))
SET ONCAR200(ONC200)=ONC200
End DoDot:3
End DoDot:2
End DoDot:1
+27 SET ONCSIEN=0
FOR
SET ONCSIEN=$ORDER(^ONCO(160.1,ONCSIEN))
if ONCSIEN'>0
QUIT
Begin DoDot:1
+28 SET ONCSSUB=0
FOR
SET ONCSSUB=$ORDER(^ONCO(160.1,ONCSIEN,"REG",ONCSSUB))
if ONCSSUB'>0
QUIT
Begin DoDot:2
+29 SET ONC200=$PIECE($GET(^ONCO(160.1,ONCSIEN,"REG",ONCSSUB,0)),"^",1)
Begin DoDot:3
+30 IF ONC200'=""
IF '$DATA(ONCAR200(ONC200))
SET ONCAR200(ONC200)=ONC200
End DoDot:3
End DoDot:2
End DoDot:1
+31 ;
+32 QUIT
+33 ;
TESTSUM ;
+1 SET NUMZY=0
SET NUMDEC=0
+2 SET ONCMAPN=0
FOR
SET ONCMAPN=$ORDER(^ONCO(160.9,ONCMAPN))
if ONCMAPN'>0
QUIT
Begin DoDot:1
+3 SET FILENUM=$PIECE($GET(^ONCO(160.9,ONCMAPN,0)),"^",1)
+4 SET ONCFDMUL=0
FOR
SET ONCFDMUL=$ORDER(^ONCO(160.9,ONCMAPN,1,ONCFDMUL))
if ONCFDMUL'>0
QUIT
Begin DoDot:2
+5 SET FEELNUM=$PIECE($GET(^ONCO(160.9,ONCMAPN,1,ONCFDMUL,0)),"^",1)
+6 SET NUMZY=NUMZY+1
+7 WRITE !,NUMZY," ","FIELD # = ",FEELNUM
+8 IF FEELNUM?1".".N
SET NUMDEC=NUMDEC+1
WRITE "**********"
End DoDot:2
End DoDot:1
+9 WRITE !!,"TOTAL NUMBER = ",NUMDEC
+10 QUIT
