ONCORIS1 ;HINES OIFO/RTK - ONCORIS MIGRATION NON-ONC MULTIPLES ;11/18/25
;;2.2;ONCOLOGY;**23**;Jul 31, 2013;Build 6
;
MULT2 ;Handle multiples for file #2
S ONCMUFLG=""
S DDSUB=+$P($G(^DD(FILENUM,DDNUM,0)),"^",2)
S SUBNODEN=$P($G(^DD(FILENUM,DDNUM,0)),"^",4)
S SUBNODE=$P(SUBNODEN,";",1)
I $O(^DPT(RECNUM,SUBNODE,0))="" Q
W "," ;write the comma for previous field; assume first field not MULT/WP
W !," "_ONCQ_DDNUM_ONCQ_" :"
W !," {"
S SBRECNUM=0 F S SBRECNUM=$O(^DPT(RECNUM,SUBNODE,SBRECNUM)) Q:SBRECNUM'>0 D
.I $P($G(^DPT(RECNUM,SUBNODE,SBRECNUM,0)),"^",1)="" Q
.S ONCMUFLG=""
.W !," "_ONCQ_SBRECNUM_ONCQ_" :"
.W !," {"
.S DDSUBNUM=0 F S DDSUBNUM=$O(^DD(DDSUB,DDSUBNUM)) Q:DDSUBNUM'>0 D
..N DATYPE,FDNAME,NODE,NODEPC,PIECE,RECDATA
..S FDNAME=$P($G(^DD(DDSUB,DDSUBNUM,0)),"^",1) ;sub-field name
..S DATYPE=$P($G(^DD(DDSUB,DDSUBNUM,0)),"^",2) ;sub-field data type
..S NODEPC=$P($G(^DD(DDSUB,DDSUBNUM,0)),"^",4) ;sub-field position
..I NODEPC=" ; " Q ; skip multiples within multiples
..S NODE=$P(NODEPC,";",1),PIECE=$P(NODEPC,";",2)
..I $P(NODEPC,";",2)=0 Q ; skip word processing within multiples
..S RECDATA=$P($G(^DPT(RECNUM,SUBNODE,SBRECNUM,NODE)),"^",PIECE)
..I RECDATA="" Q
..I ONCMUFLG'="" W ","
..S ONCMUFLG=1
..I DATYPE["F" S OLDLINE=RECDATA D ESCAPE^ONCORIS S RECDATA=NEWLINE
..I DATYPE'["N" W !," "_ONCQ_DDSUBNUM_ONCQ_" : "_ONCQ_RECDATA_ONCQ
..I DATYPE["N" D
...S RECDATA=+RECDATA
...I RECDATA?1".".N S RECDATA="0"_RECDATA
...W !," "_ONCQ_DDSUBNUM_ONCQ_" : "_RECDATA
..Q
.W !," }" I $O(^DPT(RECNUM,SUBNODE,SBRECNUM))>0 W ","
W !," }"
Q
;
MULT200 ;Handle multiples for file #200
S ONCMUFLG=""
S DDSUB=+$P($G(^DD(FILENUM,DDNUM,0)),"^",2)
S SUBNODEN=$P($G(^DD(FILENUM,DDNUM,0)),"^",4)
S SUBNODE=$P(SUBNODEN,";",1)
I $O(^VA(200,RECNUM,SUBNODE,0))="" Q
W "," ;write the comma for previous field; assume first field not MULT/WP
W !," "_ONCQ_DDNUM_ONCQ_" :"
W !," {"
S SBRECNUM=0 F S SBRECNUM=$O(^VA(200,RECNUM,SUBNODE,SBRECNUM)) Q:SBRECNUM'>0 D
.I $P($G(^VA(200,RECNUM,SUBNODE,SBRECNUM,0)),"^",1)="" Q
.S ONCMUFLG=""
.W !," "_ONCQ_SBRECNUM_ONCQ_" :"
.W !," {"
.S DDSUBNUM=0 F S DDSUBNUM=$O(^DD(DDSUB,DDSUBNUM)) Q:DDSUBNUM'>0 D
..N DATYPE,FDNAME,NODE,NODEPC,PIECE,RECDATA
..S FDNAME=$P($G(^DD(DDSUB,DDSUBNUM,0)),"^",1) ;sub-field name
..S DATYPE=$P($G(^DD(DDSUB,DDSUBNUM,0)),"^",2) ;sub-field data type
..S NODEPC=$P($G(^DD(DDSUB,DDSUBNUM,0)),"^",4) ;sub-field position
..I NODEPC=" ; " Q ; skip multiple within multiple
..S NODE=$P(NODEPC,";",1),PIECE=$P(NODEPC,";",2)
..I $P(NODEPC,";",2)=0 Q ; skip word processing within multiples
..S RECDATA=$P($G(^VA(200,RECNUM,SUBNODE,SBRECNUM,NODE)),"^",PIECE)
..I RECDATA="" Q
..I ONCMUFLG'="" W ","
..S ONCMUFLG=1
..I DATYPE["F" S OLDLINE=RECDATA D ESCAPE^ONCORIS S RECDATA=NEWLINE
..I DATYPE'["N" W !," "_ONCQ_DDSUBNUM_ONCQ_" : "_ONCQ_RECDATA_ONCQ
..I DATYPE["N" D
...S RECDATA=+RECDATA
...I RECDATA?1".".N S RECDATA="0"_RECDATA
...W !," "_ONCQ_DDSUBNUM_ONCQ_" : "_RECDATA
..Q
.W !," }" I $O(^VA(200,RECNUM,SUBNODE,SBRECNUM))>0 W ","
W !," }"
Q
;
MULT5 ;Handle multiples for file #5
S ONCMUFLG=""
S DDSUB=+$P($G(^DD(FILENUM,DDNUM,0)),"^",2)
S SUBNODEN=$P($G(^DD(FILENUM,DDNUM,0)),"^",4)
S SUBNODE=$P(SUBNODEN,";",1)
I $O(^DIC(5,RECNUM,SUBNODE,0))="" Q
W "," ;write the comma for previous field; assume first field not MULT/WP
W !," "_ONCQ_DDNUM_ONCQ_" :"
W !," {"
S SBRECNUM=0 F S SBRECNUM=$O(^DIC(5,RECNUM,SUBNODE,SBRECNUM)) Q:SBRECNUM'>0 D
.S ONCMUFLG=""
.W !," "_ONCQ_SBRECNUM_ONCQ_" :"
.W !," {"
.S DDSUBNUM=0 F S DDSUBNUM=$O(^DD(DDSUB,DDSUBNUM)) Q:DDSUBNUM'>0 D
..N DATYPE,FDNAME,NODE,NODEPC,PIECE,RECDATA
..S FDNAME=$P($G(^DD(DDSUB,DDSUBNUM,0)),"^",1) ;sub-field name
..S DATYPE=$P($G(^DD(DDSUB,DDSUBNUM,0)),"^",2) ;sub-field data type
..S NODEPC=$P($G(^DD(DDSUB,DDSUBNUM,0)),"^",4) ;sub-field position
..I NODEPC=" ; " Q ; skip multiples within multiples
..S NODE=$P(NODEPC,";",1),PIECE=$P(NODEPC,";",2)
..I $P(NODEPC,";",2)=0 Q ; skip word processing within multiples
..S RECDATA=$P($G(^DIC(5,RECNUM,SUBNODE,SBRECNUM,NODE)),"^",PIECE)
..I RECDATA="" Q
..I ONCMUFLG'="" W ","
..S ONCMUFLG=1
..I DATYPE["F" S OLDLINE=RECDATA D ESCAPE^ONCORIS S RECDATA=NEWLINE
..I DATYPE'["N" W !," "_ONCQ_DDSUBNUM_ONCQ_" : "_ONCQ_RECDATA_ONCQ
..I DATYPE["N" D
...S RECDATA=+RECDATA
...I RECDATA?1".".N S RECDATA="0"_RECDATA
...W !," "_ONCQ_DDSUBNUM_ONCQ_" : "_RECDATA
..Q
.W !," }" I $O(^DIC(5,RECNUM,SUBNODE,SBRECNUM))>0 W ","
W !," }"
Q
;
MULT50 ;Handle multiples for file #50
S ONCMUFLG=""
S DDSUB=+$P($G(^DD(FILENUM,DDNUM,0)),"^",2)
S SUBNODEN=$P($G(^DD(FILENUM,DDNUM,0)),"^",4)
S SUBNODE=$P(SUBNODEN,";",1)
I $O(^PSDRUG(RECNUM,SUBNODE,0))="" Q
W "," ;write the comma for previous field; assume first field not MULT/WP
W !," "_ONCQ_DDNUM_ONCQ_" :"
W !," {"
S SBRECNUM=0 F S SBRECNUM=$O(^PSDRUG(RECNUM,SUBNODE,SBRECNUM)) Q:SBRECNUM'>0 D
.S ONCMUFLG=""
.W !," "_ONCQ_SBRECNUM_ONCQ_" :"
.W !," {"
.S DDSUBNUM=0 F S DDSUBNUM=$O(^DD(DDSUB,DDSUBNUM)) Q:DDSUBNUM'>0 D
..N DATYPE,FDNAME,NODE,NODEPC,PIECE,RECDATA
..S FDNAME=$P($G(^DD(DDSUB,DDSUBNUM,0)),"^",1) ;sub-field name
..S DATYPE=$P($G(^DD(DDSUB,DDSUBNUM,0)),"^",2) ;sub-field data type
..S NODEPC=$P($G(^DD(DDSUB,DDSUBNUM,0)),"^",4) ;sub-field position
..I NODEPC=" ; " Q ; skip multiples within multiples
..S NODE=$P(NODEPC,";",1),PIECE=$P(NODEPC,";",2)
..I $P(NODEPC,";",2)=0 Q ; skip word processing within multiples
..S RECDATA=$P($G(^PSDRUG(RECNUM,SUBNODE,SBRECNUM,NODE)),"^",PIECE)
..I RECDATA="" Q
..I ONCMUFLG'="" W ","
..S ONCMUFLG=1
..I DATYPE["F" S OLDLINE=RECDATA D ESCAPE^ONCORIS S RECDATA=NEWLINE
..I DATYPE'["N" W !," "_ONCQ_DDSUBNUM_ONCQ_" : "_ONCQ_RECDATA_ONCQ
..I DATYPE["N" D
...S RECDATA=+RECDATA
...I RECDATA?1".".N S RECDATA="0"_RECDATA
...W !," "_ONCQ_DDSUBNUM_ONCQ_" : "_RECDATA
..Q
.W !," }" I $O(^PSDRUG(RECNUM,SUBNODE,SBRECNUM))>0 W ","
W !," }"
Q
;
Q ;exit
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCORIS1 6331 printed Jul 22, 2026@15:33:34 Page 2
ONCORIS1 ;HINES OIFO/RTK - ONCORIS MIGRATION NON-ONC MULTIPLES ;11/18/25
+1 ;;2.2;ONCOLOGY;**23**;Jul 31, 2013;Build 6
+2 ;
MULT2 ;Handle multiples for file #2
+1 SET ONCMUFLG=""
+2 SET DDSUB=+$PIECE($GET(^DD(FILENUM,DDNUM,0)),"^",2)
+3 SET SUBNODEN=$PIECE($GET(^DD(FILENUM,DDNUM,0)),"^",4)
+4 SET SUBNODE=$PIECE(SUBNODEN,";",1)
+5 IF $ORDER(^DPT(RECNUM,SUBNODE,0))=""
QUIT
+6 ;write the comma for previous field; assume first field not MULT/WP
WRITE ","
+7 WRITE !," "_ONCQ_DDNUM_ONCQ_" :"
+8 WRITE !," {"
+9 SET SBRECNUM=0
FOR
SET SBRECNUM=$ORDER(^DPT(RECNUM,SUBNODE,SBRECNUM))
if SBRECNUM'>0
QUIT
Begin DoDot:1
+10 IF $PIECE($GET(^DPT(RECNUM,SUBNODE,SBRECNUM,0)),"^",1)=""
QUIT
+11 SET ONCMUFLG=""
+12 WRITE !," "_ONCQ_SBRECNUM_ONCQ_" :"
+13 WRITE !," {"
+14 SET DDSUBNUM=0
FOR
SET DDSUBNUM=$ORDER(^DD(DDSUB,DDSUBNUM))
if DDSUBNUM'>0
QUIT
Begin DoDot:2
+15 NEW DATYPE,FDNAME,NODE,NODEPC,PIECE,RECDATA
+16 ;sub-field name
SET FDNAME=$PIECE($GET(^DD(DDSUB,DDSUBNUM,0)),"^",1)
+17 ;sub-field data type
SET DATYPE=$PIECE($GET(^DD(DDSUB,DDSUBNUM,0)),"^",2)
+18 ;sub-field position
SET NODEPC=$PIECE($GET(^DD(DDSUB,DDSUBNUM,0)),"^",4)
+19 ; skip multiples within multiples
IF NODEPC=" ; "
QUIT
+20 SET NODE=$PIECE(NODEPC,";",1)
SET PIECE=$PIECE(NODEPC,";",2)
+21 ; skip word processing within multiples
IF $PIECE(NODEPC,";",2)=0
QUIT
+22 SET RECDATA=$PIECE($GET(^DPT(RECNUM,SUBNODE,SBRECNUM,NODE)),"^",PIECE)
+23 IF RECDATA=""
QUIT
+24 IF ONCMUFLG'=""
WRITE ","
+25 SET ONCMUFLG=1
+26 IF DATYPE["F"
SET OLDLINE=RECDATA
DO ESCAPE^ONCORIS
SET RECDATA=NEWLINE
+27 IF DATYPE'["N"
WRITE !," "_ONCQ_DDSUBNUM_ONCQ_" : "_ONCQ_RECDATA_ONCQ
+28 IF DATYPE["N"
Begin DoDot:3
+29 SET RECDATA=+RECDATA
+30 IF RECDATA?1".".N
SET RECDATA="0"_RECDATA
+31 WRITE !," "_ONCQ_DDSUBNUM_ONCQ_" : "_RECDATA
End DoDot:3
+32 QUIT
End DoDot:2
+33 WRITE !," }"
IF $ORDER(^DPT(RECNUM,SUBNODE,SBRECNUM))>0
WRITE ","
End DoDot:1
+34 WRITE !," }"
+35 QUIT
+36 ;
MULT200 ;Handle multiples for file #200
+1 SET ONCMUFLG=""
+2 SET DDSUB=+$PIECE($GET(^DD(FILENUM,DDNUM,0)),"^",2)
+3 SET SUBNODEN=$PIECE($GET(^DD(FILENUM,DDNUM,0)),"^",4)
+4 SET SUBNODE=$PIECE(SUBNODEN,";",1)
+5 IF $ORDER(^VA(200,RECNUM,SUBNODE,0))=""
QUIT
+6 ;write the comma for previous field; assume first field not MULT/WP
WRITE ","
+7 WRITE !," "_ONCQ_DDNUM_ONCQ_" :"
+8 WRITE !," {"
+9 SET SBRECNUM=0
FOR
SET SBRECNUM=$ORDER(^VA(200,RECNUM,SUBNODE,SBRECNUM))
if SBRECNUM'>0
QUIT
Begin DoDot:1
+10 IF $PIECE($GET(^VA(200,RECNUM,SUBNODE,SBRECNUM,0)),"^",1)=""
QUIT
+11 SET ONCMUFLG=""
+12 WRITE !," "_ONCQ_SBRECNUM_ONCQ_" :"
+13 WRITE !," {"
+14 SET DDSUBNUM=0
FOR
SET DDSUBNUM=$ORDER(^DD(DDSUB,DDSUBNUM))
if DDSUBNUM'>0
QUIT
Begin DoDot:2
+15 NEW DATYPE,FDNAME,NODE,NODEPC,PIECE,RECDATA
+16 ;sub-field name
SET FDNAME=$PIECE($GET(^DD(DDSUB,DDSUBNUM,0)),"^",1)
+17 ;sub-field data type
SET DATYPE=$PIECE($GET(^DD(DDSUB,DDSUBNUM,0)),"^",2)
+18 ;sub-field position
SET NODEPC=$PIECE($GET(^DD(DDSUB,DDSUBNUM,0)),"^",4)
+19 ; skip multiple within multiple
IF NODEPC=" ; "
QUIT
+20 SET NODE=$PIECE(NODEPC,";",1)
SET PIECE=$PIECE(NODEPC,";",2)
+21 ; skip word processing within multiples
IF $PIECE(NODEPC,";",2)=0
QUIT
+22 SET RECDATA=$PIECE($GET(^VA(200,RECNUM,SUBNODE,SBRECNUM,NODE)),"^",PIECE)
+23 IF RECDATA=""
QUIT
+24 IF ONCMUFLG'=""
WRITE ","
+25 SET ONCMUFLG=1
+26 IF DATYPE["F"
SET OLDLINE=RECDATA
DO ESCAPE^ONCORIS
SET RECDATA=NEWLINE
+27 IF DATYPE'["N"
WRITE !," "_ONCQ_DDSUBNUM_ONCQ_" : "_ONCQ_RECDATA_ONCQ
+28 IF DATYPE["N"
Begin DoDot:3
+29 SET RECDATA=+RECDATA
+30 IF RECDATA?1".".N
SET RECDATA="0"_RECDATA
+31 WRITE !," "_ONCQ_DDSUBNUM_ONCQ_" : "_RECDATA
End DoDot:3
+32 QUIT
End DoDot:2
+33 WRITE !," }"
IF $ORDER(^VA(200,RECNUM,SUBNODE,SBRECNUM))>0
WRITE ","
End DoDot:1
+34 WRITE !," }"
+35 QUIT
+36 ;
MULT5 ;Handle multiples for file #5
+1 SET ONCMUFLG=""
+2 SET DDSUB=+$PIECE($GET(^DD(FILENUM,DDNUM,0)),"^",2)
+3 SET SUBNODEN=$PIECE($GET(^DD(FILENUM,DDNUM,0)),"^",4)
+4 SET SUBNODE=$PIECE(SUBNODEN,";",1)
+5 IF $ORDER(^DIC(5,RECNUM,SUBNODE,0))=""
QUIT
+6 ;write the comma for previous field; assume first field not MULT/WP
WRITE ","
+7 WRITE !," "_ONCQ_DDNUM_ONCQ_" :"
+8 WRITE !," {"
+9 SET SBRECNUM=0
FOR
SET SBRECNUM=$ORDER(^DIC(5,RECNUM,SUBNODE,SBRECNUM))
if SBRECNUM'>0
QUIT
Begin DoDot:1
+10 SET ONCMUFLG=""
+11 WRITE !," "_ONCQ_SBRECNUM_ONCQ_" :"
+12 WRITE !," {"
+13 SET DDSUBNUM=0
FOR
SET DDSUBNUM=$ORDER(^DD(DDSUB,DDSUBNUM))
if DDSUBNUM'>0
QUIT
Begin DoDot:2
+14 NEW DATYPE,FDNAME,NODE,NODEPC,PIECE,RECDATA
+15 ;sub-field name
SET FDNAME=$PIECE($GET(^DD(DDSUB,DDSUBNUM,0)),"^",1)
+16 ;sub-field data type
SET DATYPE=$PIECE($GET(^DD(DDSUB,DDSUBNUM,0)),"^",2)
+17 ;sub-field position
SET NODEPC=$PIECE($GET(^DD(DDSUB,DDSUBNUM,0)),"^",4)
+18 ; skip multiples within multiples
IF NODEPC=" ; "
QUIT
+19 SET NODE=$PIECE(NODEPC,";",1)
SET PIECE=$PIECE(NODEPC,";",2)
+20 ; skip word processing within multiples
IF $PIECE(NODEPC,";",2)=0
QUIT
+21 SET RECDATA=$PIECE($GET(^DIC(5,RECNUM,SUBNODE,SBRECNUM,NODE)),"^",PIECE)
+22 IF RECDATA=""
QUIT
+23 IF ONCMUFLG'=""
WRITE ","
+24 SET ONCMUFLG=1
+25 IF DATYPE["F"
SET OLDLINE=RECDATA
DO ESCAPE^ONCORIS
SET RECDATA=NEWLINE
+26 IF DATYPE'["N"
WRITE !," "_ONCQ_DDSUBNUM_ONCQ_" : "_ONCQ_RECDATA_ONCQ
+27 IF DATYPE["N"
Begin DoDot:3
+28 SET RECDATA=+RECDATA
+29 IF RECDATA?1".".N
SET RECDATA="0"_RECDATA
+30 WRITE !," "_ONCQ_DDSUBNUM_ONCQ_" : "_RECDATA
End DoDot:3
+31 QUIT
End DoDot:2
+32 WRITE !," }"
IF $ORDER(^DIC(5,RECNUM,SUBNODE,SBRECNUM))>0
WRITE ","
End DoDot:1
+33 WRITE !," }"
+34 QUIT
+35 ;
MULT50 ;Handle multiples for file #50
+1 SET ONCMUFLG=""
+2 SET DDSUB=+$PIECE($GET(^DD(FILENUM,DDNUM,0)),"^",2)
+3 SET SUBNODEN=$PIECE($GET(^DD(FILENUM,DDNUM,0)),"^",4)
+4 SET SUBNODE=$PIECE(SUBNODEN,";",1)
+5 IF $ORDER(^PSDRUG(RECNUM,SUBNODE,0))=""
QUIT
+6 ;write the comma for previous field; assume first field not MULT/WP
WRITE ","
+7 WRITE !," "_ONCQ_DDNUM_ONCQ_" :"
+8 WRITE !," {"
+9 SET SBRECNUM=0
FOR
SET SBRECNUM=$ORDER(^PSDRUG(RECNUM,SUBNODE,SBRECNUM))
if SBRECNUM'>0
QUIT
Begin DoDot:1
+10 SET ONCMUFLG=""
+11 WRITE !," "_ONCQ_SBRECNUM_ONCQ_" :"
+12 WRITE !," {"
+13 SET DDSUBNUM=0
FOR
SET DDSUBNUM=$ORDER(^DD(DDSUB,DDSUBNUM))
if DDSUBNUM'>0
QUIT
Begin DoDot:2
+14 NEW DATYPE,FDNAME,NODE,NODEPC,PIECE,RECDATA
+15 ;sub-field name
SET FDNAME=$PIECE($GET(^DD(DDSUB,DDSUBNUM,0)),"^",1)
+16 ;sub-field data type
SET DATYPE=$PIECE($GET(^DD(DDSUB,DDSUBNUM,0)),"^",2)
+17 ;sub-field position
SET NODEPC=$PIECE($GET(^DD(DDSUB,DDSUBNUM,0)),"^",4)
+18 ; skip multiples within multiples
IF NODEPC=" ; "
QUIT
+19 SET NODE=$PIECE(NODEPC,";",1)
SET PIECE=$PIECE(NODEPC,";",2)
+20 ; skip word processing within multiples
IF $PIECE(NODEPC,";",2)=0
QUIT
+21 SET RECDATA=$PIECE($GET(^PSDRUG(RECNUM,SUBNODE,SBRECNUM,NODE)),"^",PIECE)
+22 IF RECDATA=""
QUIT
+23 IF ONCMUFLG'=""
WRITE ","
+24 SET ONCMUFLG=1
+25 IF DATYPE["F"
SET OLDLINE=RECDATA
DO ESCAPE^ONCORIS
SET RECDATA=NEWLINE
+26 IF DATYPE'["N"
WRITE !," "_ONCQ_DDSUBNUM_ONCQ_" : "_ONCQ_RECDATA_ONCQ
+27 IF DATYPE["N"
Begin DoDot:3
+28 SET RECDATA=+RECDATA
+29 IF RECDATA?1".".N
SET RECDATA="0"_RECDATA
+30 WRITE !," "_ONCQ_DDSUBNUM_ONCQ_" : "_RECDATA
End DoDot:3
+31 QUIT
End DoDot:2
+32 WRITE !," }"
IF $ORDER(^PSDRUG(RECNUM,SUBNODE,SBRECNUM))>0
WRITE ","
End DoDot:1
+33 WRITE !," }"
+34 QUIT
+35 ;
+36 ;exit
QUIT
