INHSYS05 ;slt,JPD,WOM; 15 Jun 99 16:27;gis sys con data installation utility
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;CHCS TOOLS_460; GEN 5; 6-OCT-1997
;COPYRIGHT 1994 SAIC
Q
INST(%DRVR,%PASS,INREPRT) ;installation utility entry point
;input:
; %DRVR - Internal installation driver routine
; %PASS - 0 or null - display report only
; 1 - save off old files - create required fields
; 2 - populate rest of file
; INREPRT - 0 or null - off 1 - on
;local:
; %LINE - file information stored in ";;" comment form
; %FNUM - file number
; %ROOT - global root
;
N B,%FNUM,%FLDS,%ROOT,%OIEN,%XNODE,%UNQ,Y,DA,%FILES,AA,%SAV
N DIC,X,DLAYGO,QT,I,%RQ,%MSG,%MSG2,%OMT,%FILES,%DIC0,%GLB
S INREPRT=$G(INREPRT),%PASS=$G(%PASS),(%MSG,%MSG2)=0
I '%PASS X "D EN^@%DRVR" ;used eXecute so that ^TCQ program does not crash!
I INREPRT U IO D HEAD^INHSYSUT(%PASS)
;set up variables
D RQ^INHSYSUT(.%RQ),OMT^INHSYSUT(.%OMT),SAVE^INHSYSUT(.%SAV),XRF^INHSYSUT(.%FILES)
S QT=$C(34)
;Get each cross reference
F AA=1:1 S %FNUM=$P(%FILES,U,AA) Q:%FNUM="" D
.;get root name of file
.;Cant do exact match lookup since names>30 in length
.S %ROOT=$G(^DIC(%FNUM,0,"GL")),%DIC0="X"
.I %ROOT="" W !,"Note .. DD file "_%FNUM_" is missing." Q
.I %PASS S %DIC0="LX"
.;loop thru utility using cross reference to get ien
.S %OIEN="" F S %OIEN=$O(^UTILITY("INHSYS",$J,%FNUM,%OIEN)) Q:'%OIEN D
..N DA,DINUM
..S %XNODE=^UTILITY("INHSYS",$J,%FNUM,%OIEN,0)
..;if Transaction Type file
..I %FNUM=4000,$P(%XNODE,U,4)]"" D
...;get unique identifier
...S %UNQ=$P(%XNODE,U,4),%GLB=$$RUT^INHSYSUT(%ROOT),Y=$O(@%GLB@("ID",%UNQ,""))
...;If no unique ID laygo the file
...I 'Y S Y=$$DIC(%ROOT,$P(%XNODE,U),%FNUM,%DIC0) D:Y<0 MSG^INHSYSUT(%XNODE,%FNUM,.%MSG,0,%PASS) Q
...E S Y=Y_U_$P(%XNODE,U)
..E S Y=$$DIC(%ROOT,$P(%XNODE,U),%FNUM,%DIC0) D:Y<0 MSG^INHSYSUT(%XNODE,%FNUM,.%MSG,0,%PASS)
..I INREPRT,Y>0 D PG^INHSYSUT(%PASS) W !,%FNUM,?14,$P($G(^DIC(%FNUM,0)),U),?42
..;Save ien Kill off node
..I %PASS=1,+Y>0 D I +Y<0 D MSG^INHSYSUT(%XNODE,%FNUM,.%MSG,0,%PASS) Q
...;if we want to save old values from export environment
...I $D(%SAV(%FNUM)) D FLSV^INHSYSUT(%FNUM,+Y,%ROOT)
...S DINUM=+Y,DIK=%ROOT,DA=+Y D ^DIK
...;create stub node
...S Y=$$DIC(%ROOT,$P(%XNODE,U),%FNUM,%DIC0,"","",.DINUM)
..S DA=+Y
..I INREPRT,Y>0 D
...W:%PASS'=1 ?42,".01",?56
...I %FNUM=4020 W $P($G(^INRHT($P(Y,U,2),0)),U)
...E W:%PASS'=1 $P(Y,U,2)
...W !,%ROOT_DA I '%PASS W !
..I INREPRT,Y'>0,%PASS=1 W ?42,".01"
..I '%PASS,Y>0 D CMP^INHSYS07(+Y,%ROOT,%FNUM,%OIEN,1)
..I %PASS D STUFF(Y,%FNUM,%ROOT,"^UTILITY(""INHSYS"","_$J_","_QT_%FNUM_QT_","_%OIEN_",",1,DA,%PASS,.%MSG2,INREPRT)
;I '%PASS,'INREPRT,'%MSG W !,"All files currently exist in this environment",!,"and will be overwritten",!
I INREPRT,%MSG2 D PG^INHSYSUT(%PASS) W !,"*** Denotes ommitted, and not filed in system."
I INREPRT D PG^INHSYSUT(%PASS)
W !!,"Pass "_%PASS_" Done! "
I INREPRT,%PASS=1,$E(IOST)="C",INCR,$$CR^UTSRD(0,IOSL-1)
Q
;
STUFF(INY,%FILNUM,%ROOT,%BFR,%LEVEL,DA,%PASS,%MSG2,INREPRT) ;recursive data stuffer
;input:
; INY - ien^.01
; %FILNUM - file number
; %ROOT - global root
; %BFR - storage buffer
; %LEVEL - file/sub-file level
; DA - same as fileman documented DA
; %PASS - 0 or null - report
; 1 - save off old files - create required fields
; 2 - populate rest of file
;local:
; %NODE - node
; %PIECE - uparrow piece
; %FLDNUM - field number
; %OIEN - old ien for sub-files
; %NBFR - the new storage buffer root name
; %DATA - node data strage variable
; P01 - .01 value
; %NRT - new global root
;
N %NODE,%NODE1,%PIECE,%FLDNUM,DIE,%OIEN,%NBFR,%DATA,P01,%NRT,YY,DR,I,J
S %NODE=""
I %LEVEL>1,INREPRT D PG^INHSYSUT(%PASS) W !,"m ",%FILNUM,?14,$P($G(^DD(%FILNUM,0)),U)
F S %NODE=$O(^DD(%FILNUM,"GL",%NODE)) Q:%NODE="" D
.S %NODE1=%NODE
.I $L(%NODE),+%NODE'=%NODE S %NODE=""""_%NODE_""""
.;set new storage buffer root name
.S %NBFR=%BFR_%NODE_","
.;Loop through DD to get each piece of every node
.S %PIECE=""
.F S %PIECE=$O(^DD(%FILNUM,"GL",%NODE1,%PIECE)) Q:%PIECE="" D
..S %FLDNUM=""
..;get fieldnum for each piece of every node
..F S %FLDNUM=$O(^DD(%FILNUM,"GL",%NODE1,%PIECE,%FLDNUM)) Q:'%FLDNUM D
...I %PASS=1,'$D(%RQ(%FILNUM,%FLDNUM)) Q
...I INREPRT D:%FLDNUM'=".01" PG^INHSYSUT(%PASS) W:%FLDNUM'=".01"!(%LEVEL=1) !,?42,%FLDNUM
...I INREPRT,%LEVEL>1,%FLDNUM=".01" D PG^INHSYSUT(%PASS) W !,?42,%FLDNUM
...; Don't do it because already populated in PASS 1
...I %PASS=2,$D(%RQ(%FILNUM,%FLDNUM)) Q
...I $D(%OMT(%FILNUM,%FLDNUM)) D:INREPRT Q
....D DATA^INHSYSUT($$RUT^INHSYSUT(%NBFR),%PIECE,.%DATA)
....W " ***",?56,%DATA
....S %MSG2=1
...;If word processing field
...I $$WP^INHSYSUT(+%FILNUM,%FLDNUM) D WORD(%NBFR,%ROOT,DA,%NODE,%PASS) Q
...;If piece is 0 could be multiple
...I %PIECE=0 D MULT(%NBFR,%NODE,%ROOT,.DA,%FILNUM,%FLDNUM,%LEVEL,%PASS,.%MSG2) Q
...D DATA^INHSYSUT($$RUT^INHSYSUT(%NBFR),%PIECE,.%DATA)
...I INREPRT W ?56,%DATA
...;If not .01, if not blank, and not omitted File the data
...I %DATA'="",%FLDNUM'=".01" D FILE^INHSYSUT(.DA,%DATA,%FLDNUM,%ROOT,INREPRT)
.S %NODE=%NODE1
Q
MULT(%NBFR,%NODE,%ROOT,DA,%FILNUM,%FLDNUM,%LEVEL,%PASS,%MSG2) ;Process multiple
;This module will process multiple as if it were an entire
;node and process each entry one piece at a time
; %NBFR - the new storage buffer root name
; %NODE - node
; %ROOT - global root
; DA - ien and "Multiple entry"
; %FILNUM - file number
; %FLDNUM - field number
; %LEVEL - file/sub-file level
; %PASS - 0 or null - report
; 1 - save off old files - create required fields
; 2 - populate rest of file
N %OIEN,%NRT,X,NFLN,YY,%X,%Y,%NFLN,%DIC0,INMSGID
S %DIC0="LX"
S %OIEN=0 F S %OIEN=$O(@$$RUT^INHSYSUT(%NBFR)@(%OIEN)) Q:'%OIEN S X=^(%OIEN,0) D
.N %NRT,ODA,%INFAKE,%DICS
.;set x to current multiple node of UTILITY global
.;get new root
.S %NRT=%ROOT_DA_","_%NODE_","
.S %NFLN=$P(^DD(%FILNUM,%FLDNUM,0),U,2)
.I +%NFLN="4001.19" D Q
..N INIEN
..S INMSGID=$P(@(%NBFR_%OIEN_",0)"),U,2)
..S INIEN=$O(^INTHU("C",INMSGID,"")) Q:'INIEN
..D UPSINGMS^INTSUT3(DA,"NML",INIEN)
.S YY=$$DIC(%NRT,$P(X,U),%NFLN,%DIC0,.DA,%LEVEL,.INFAKE) I YY<0 D MSG^INHSYSUT(X,%NFLN,"",1,%PASS) Q
.S ODA=DA,%X="DA",%Y="ODA" M @%Y=@%X
.D SETDA(.DA,%LEVEL,+YY)
.;every time you recusion into stuff, it processes multiple
.;completely for each entry
.D STUFF(YY,+%NFLN,%NRT,%NBFR_%OIEN_",",%LEVEL+1,.DA,%PASS,.%MSG2,INREPRT)
.K DA S DA=ODA,%Y="DA",%X="ODA" M @%Y=@%X
.I INREPRT D PG^INHSYSUT(%PASS) W !,"----",!,"r "_%FILNUM
Q
WORD(%NBFR,%ROOT,DA,%NODE,%PASS) ;Process word processing field
; input:
; %NBFR - Utility Global Buffer
; %ROOT - Root node of global to stuff
; DA - ien
; %NODE - node
N %INX,%INCNT,%X,%Y,I,L
;Check if data exists to move
I $D(@(%NBFR_"0)")) D
.;move data from utility to correct multiple
.S L=$L(%NBFR),%X=$E(%NBFR,1,L-1)_$S($E(%NBFR,L)="(":"",1:")"),%Y=%ROOT_DA_","_%NODE_")"
.M @%Y=@%X
Q
SETDA(DA,%LEVEL,Y) ;Set DA level so fileman doesn't choke
; Input:
; DA - ien and "Multiple" entry #'s
; %LEVEL - level in multiple
; Y - New entry number
; Output:
; DA - IEN and "Multiple" entry #'s
N I
F I=%LEVEL:-1:3 S DA(I-1)=DA(I-2)
S DA(1)=DA,DA=+Y
Q
DIC(DIC,X,DLAYGO,%IPS,DOA,%L,DINUM) ;dic lookup
;input:
; DIC - Global Root: Can be a string or file number
; If a file number, this function returns -1
; when looking at a multiple
; X - Stuff this bud
; DLAYGO - file number and formatting
; %IPS - input parameter string; see DIC(0) documentation
; DOA - array of previous DA values; passed by referrence
; %L - current level
; DINUM (opt) - force this ien
;output:
; Y - What DIC returns
N G,DA,I,Y,INDD0
I DIC Q:DIC'>0!($G(DOA)&$G(%L)) -1 S DIC=$G(^DIC(DIC,0,"GL")) Q:DIC="" -1
;Check for files whose .01 is a pointer. Currently only check 4020.
I $D(DINUM),DIC="^INRHR(" S INDD0=$G(^DD(4020,.01,0)) I $P(INDD0,U,2)["P" D I Y<0 Q Y
. ;Get file for next lookup
. S INFILE="^"_$P(INDD0,U,3)
. ;Do recursive lookup on file
. S Y=$$DIC(INFILE,X,"","X")
. S X=+Y
I $G(DOA),($G(%L)) D
.F I=%L:-1:2 S DA(I)=DOA(I-1)
.S DA(1)=DOA
S G=DIC_"0)" S:'$D(@G) @G="^"_DLAYGO_"^^"
S DIC(0)=%IPS
I '$D(DINUM) D ^DIC
I $D(DINUM) D ^DICN D:Y=-1
.F I=1,2 D Q:$G(IO)=$G(IO(0))
..I I=2,$D(IO(0))#10,$D(IO)#10 U IO(0)
..W *7,!,!,"Warning, the GIS TRANSACTION MOVER has failed to update ",!
..W DIC," with the .01 field=",X,!,"This could possibly be due to corruption of the"
..W "FILEMAN data structure.",!,"This installation cannot be aborted at this time but"
..W "YOU MUST CONTACT THE SUPPORT CENTER IMMEDIATELY",!!
..I I=2,$D(IO)#10 U IO
Q Y
INHSYS05 ;slt,JPD,WOM; 15 Jun 99 16:27;gis sys con data installation utility
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;CHCS TOOLS_460; GEN 5; 6-OCT-1997
+4 ;COPYRIGHT 1994 SAIC
+5 QUIT
INST(%DRVR,%PASS,INREPRT) ;installation utility entry point
+1 ;input:
+2 ; %DRVR - Internal installation driver routine
+3 ; %PASS - 0 or null - display report only
+4 ; 1 - save off old files - create required fields
+5 ; 2 - populate rest of file
+6 ; INREPRT - 0 or null - off 1 - on
+7 ;local:
+8 ; %LINE - file information stored in ";;" comment form
+9 ; %FNUM - file number
+10 ; %ROOT - global root
+11 ;
+12 NEW B,%FNUM,%FLDS,%ROOT,%OIEN,%XNODE,%UNQ,Y,DA,%FILES,AA,%SAV
+13 NEW DIC,X,DLAYGO,QT,I,%RQ,%MSG,%MSG2,%OMT,%FILES,%DIC0,%GLB
+14 SET INREPRT=$GET(INREPRT)
SET %PASS=$GET(%PASS)
SET (%MSG,%MSG2)=0
+15 ;used eXecute so that ^TCQ program does not crash!
IF '%PASS
XECUTE "D EN^@%DRVR"
+16 IF INREPRT
USE IO
DO HEAD^INHSYSUT(%PASS)
+17 ;set up variables
+18 DO RQ^INHSYSUT(.%RQ)
DO OMT^INHSYSUT(.%OMT)
DO SAVE^INHSYSUT(.%SAV)
DO XRF^INHSYSUT(.%FILES)
+19 SET QT=$CHAR(34)
+20 ;Get each cross reference
+21 FOR AA=1:1
SET %FNUM=$PIECE(%FILES,U,AA)
IF %FNUM=""
QUIT
Begin DoDot:1
+22 ;get root name of file
+23 ;Cant do exact match lookup since names>30 in length
+24 SET %ROOT=$GET(^DIC(%FNUM,0,"GL"))
SET %DIC0="X"
+25 IF %ROOT=""
WRITE !,"Note .. DD file "_%FNUM_" is missing."
QUIT
+26 IF %PASS
SET %DIC0="LX"
+27 ;loop thru utility using cross reference to get ien
+28 SET %OIEN=""
FOR
SET %OIEN=$ORDER(^UTILITY("INHSYS",$JOB,%FNUM,%OIEN))
IF '%OIEN
QUIT
Begin DoDot:2
+29 NEW DA,DINUM
+30 SET %XNODE=^UTILITY("INHSYS",$JOB,%FNUM,%OIEN,0)
+31 ;if Transaction Type file
+32 IF %FNUM=4000
IF $PIECE(%XNODE,U,4)]""
Begin DoDot:3
+33 ;get unique identifier
+34 SET %UNQ=$PIECE(%XNODE,U,4)
SET %GLB=$$RUT^INHSYSUT(%ROOT)
SET Y=$ORDER(@%GLB@("ID",%UNQ,""))
+35 ;If no unique ID laygo the file
+36 IF 'Y
SET Y=$$DIC(%ROOT,$PIECE(%XNODE,U),%FNUM,%DIC0)
IF Y<0
DO MSG^INHSYSUT(%XNODE,%FNUM,.%MSG,0,%PASS)
QUIT
+37 IF '$TEST
SET Y=Y_U_$PIECE(%XNODE,U)
End DoDot:3
+38 IF '$TEST
SET Y=$$DIC(%ROOT,$PIECE(%XNODE,U),%FNUM,%DIC0)
IF Y<0
DO MSG^INHSYSUT(%XNODE,%FNUM,.%MSG,0,%PASS)
+39 IF INREPRT
IF Y>0
DO PG^INHSYSUT(%PASS)
WRITE !,%FNUM,?14,$PIECE($GET(^DIC(%FNUM,0)),U),?42
+40 ;Save ien Kill off node
+41 IF %PASS=1
IF +Y>0
Begin DoDot:3
+42 ;if we want to save old values from export environment
+43 IF $DATA(%SAV(%FNUM))
DO FLSV^INHSYSUT(%FNUM,+Y,%ROOT)
+44 SET DINUM=+Y
SET DIK=%ROOT
SET DA=+Y
DO ^DIK
+45 ;create stub node
+46 SET Y=$$DIC(%ROOT,$PIECE(%XNODE,U),%FNUM,%DIC0,"","",.DINUM)
End DoDot:3
IF +Y<0
DO MSG^INHSYSUT(%XNODE,%FNUM,.%MSG,0,%PASS)
QUIT
+47 SET DA=+Y
+48 IF INREPRT
IF Y>0
Begin DoDot:3
+49 IF %PASS'=1
WRITE ?42,".01",?56
+50 IF %FNUM=4020
WRITE $PIECE($GET(^INRHT($PIECE(Y,U,2),0)),U)
+51 IF '$TEST
IF %PASS'=1
WRITE $PIECE(Y,U,2)
+52 WRITE !,%ROOT_DA
IF '%PASS
WRITE !
End DoDot:3
+53 IF INREPRT
IF Y'>0
IF %PASS=1
WRITE ?42,".01"
+54 IF '%PASS
IF Y>0
DO CMP^INHSYS07(+Y,%ROOT,%FNUM,%OIEN,1)
+55 IF %PASS
DO STUFF(Y,%FNUM,%ROOT,"^UTILITY(""INHSYS"","_$JOB_","_QT_%FNUM_QT_","_%OIEN_",",1,DA,%PASS,.%MSG2,INREPRT)
End DoDot:2
End DoDot:1
+56 ;I '%PASS,'INREPRT,'%MSG W !,"All files currently exist in this environment",!,"and will be overwritten",!
+57 IF INREPRT
IF %MSG2
DO PG^INHSYSUT(%PASS)
WRITE !,"*** Denotes ommitted, and not filed in system."
+58 IF INREPRT
DO PG^INHSYSUT(%PASS)
+59 WRITE !!,"Pass "_%PASS_" Done! "
+60 IF INREPRT
IF %PASS=1
IF $EXTRACT(IOST)="C"
IF INCR
IF $$CR^UTSRD(0,IOSL-1)
+61 QUIT
+62 ;
STUFF(INY,%FILNUM,%ROOT,%BFR,%LEVEL,DA,%PASS,%MSG2,INREPRT) ;recursive data stuffer
+1 ;input:
+2 ; INY - ien^.01
+3 ; %FILNUM - file number
+4 ; %ROOT - global root
+5 ; %BFR - storage buffer
+6 ; %LEVEL - file/sub-file level
+7 ; DA - same as fileman documented DA
+8 ; %PASS - 0 or null - report
+9 ; 1 - save off old files - create required fields
+10 ; 2 - populate rest of file
+11 ;local:
+12 ; %NODE - node
+13 ; %PIECE - uparrow piece
+14 ; %FLDNUM - field number
+15 ; %OIEN - old ien for sub-files
+16 ; %NBFR - the new storage buffer root name
+17 ; %DATA - node data strage variable
+18 ; P01 - .01 value
+19 ; %NRT - new global root
+20 ;
+21 NEW %NODE,%NODE1,%PIECE,%FLDNUM,DIE,%OIEN,%NBFR,%DATA,P01,%NRT,YY,DR,I,J
+22 SET %NODE=""
+23 IF %LEVEL>1
IF INREPRT
DO PG^INHSYSUT(%PASS)
WRITE !,"m ",%FILNUM,?14,$PIECE($GET(^DD(%FILNUM,0)),U)
+24 FOR
SET %NODE=$ORDER(^DD(%FILNUM,"GL",%NODE))
IF %NODE=""
QUIT
Begin DoDot:1
+25 SET %NODE1=%NODE
+26 IF $LENGTH(%NODE)
IF +%NODE'=%NODE
SET %NODE=""""_%NODE_""""
+27 ;set new storage buffer root name
+28 SET %NBFR=%BFR_%NODE_","
+29 ;Loop through DD to get each piece of every node
+30 SET %PIECE=""
+31 FOR
SET %PIECE=$ORDER(^DD(%FILNUM,"GL",%NODE1,%PIECE))
IF %PIECE=""
QUIT
Begin DoDot:2
+32 SET %FLDNUM=""
+33 ;get fieldnum for each piece of every node
+34 FOR
SET %FLDNUM=$ORDER(^DD(%FILNUM,"GL",%NODE1,%PIECE,%FLDNUM))
IF '%FLDNUM
QUIT
Begin DoDot:3
+35 IF %PASS=1
IF '$DATA(%RQ(%FILNUM,%FLDNUM))
QUIT
+36 IF INREPRT
IF %FLDNUM'=".01"
DO PG^INHSYSUT(%PASS)
IF %FLDNUM'=".01"!(%LEVEL=1)
WRITE !,?42,%FLDNUM
+37 IF INREPRT
IF %LEVEL>1
IF %FLDNUM=".01"
DO PG^INHSYSUT(%PASS)
WRITE !,?42,%FLDNUM
+38 ; Don't do it because already populated in PASS 1
+39 IF %PASS=2
IF $DATA(%RQ(%FILNUM,%FLDNUM))
QUIT
+40 IF $DATA(%OMT(%FILNUM,%FLDNUM))
IF INREPRT
Begin DoDot:4
+41 DO DATA^INHSYSUT($$RUT^INHSYSUT(%NBFR),%PIECE,.%DATA)
+42 WRITE " ***",?56,%DATA
+43 SET %MSG2=1
End DoDot:4
QUIT
+44 ;If word processing field
+45 IF $$WP^INHSYSUT(+%FILNUM,%FLDNUM)
DO WORD(%NBFR,%ROOT,DA,%NODE,%PASS)
QUIT
+46 ;If piece is 0 could be multiple
+47 IF %PIECE=0
DO MULT(%NBFR,%NODE,%ROOT,.DA,%FILNUM,%FLDNUM,%LEVEL,%PASS,.%MSG2)
QUIT
+48 DO DATA^INHSYSUT($$RUT^INHSYSUT(%NBFR),%PIECE,.%DATA)
+49 IF INREPRT
WRITE ?56,%DATA
+50 ;If not .01, if not blank, and not omitted File the data
+51 IF %DATA'=""
IF %FLDNUM'=".01"
DO FILE^INHSYSUT(.DA,%DATA,%FLDNUM,%ROOT,INREPRT)
End DoDot:3
End DoDot:2
+52 SET %NODE=%NODE1
End DoDot:1
+53 QUIT
MULT(%NBFR,%NODE,%ROOT,DA,%FILNUM,%FLDNUM,%LEVEL,%PASS,%MSG2) ;Process multiple
+1 ;This module will process multiple as if it were an entire
+2 ;node and process each entry one piece at a time
+3 ; %NBFR - the new storage buffer root name
+4 ; %NODE - node
+5 ; %ROOT - global root
+6 ; DA - ien and "Multiple entry"
+7 ; %FILNUM - file number
+8 ; %FLDNUM - field number
+9 ; %LEVEL - file/sub-file level
+10 ; %PASS - 0 or null - report
+11 ; 1 - save off old files - create required fields
+12 ; 2 - populate rest of file
+13 NEW %OIEN,%NRT,X,NFLN,YY,%X,%Y,%NFLN,%DIC0,INMSGID
+14 SET %DIC0="LX"
+15 SET %OIEN=0
FOR
SET %OIEN=$ORDER(@$$RUT^INHSYSUT(%NBFR)@(%OIEN))
IF '%OIEN
QUIT
SET X=^(%OIEN,0)
Begin DoDot:1
+16 NEW %NRT,ODA,%INFAKE,%DICS
+17 ;set x to current multiple node of UTILITY global
+18 ;get new root
+19 SET %NRT=%ROOT_DA_","_%NODE_","
+20 SET %NFLN=$PIECE(^DD(%FILNUM,%FLDNUM,0),U,2)
+21 IF +%NFLN="4001.19"
Begin DoDot:2
+22 NEW INIEN
+23 SET INMSGID=$PIECE(@(%NBFR_%OIEN_",0)"),U,2)
+24 SET INIEN=$ORDER(^INTHU("C",INMSGID,""))
IF 'INIEN
QUIT
+25 DO UPSINGMS^INTSUT3(DA,"NML",INIEN)
End DoDot:2
QUIT
+26 SET YY=$$DIC(%NRT,$PIECE(X,U),%NFLN,%DIC0,.DA,%LEVEL,.INFAKE)
IF YY<0
DO MSG^INHSYSUT(X,%NFLN,"",1,%PASS)
QUIT
+27 SET ODA=DA
SET %X="DA"
SET %Y="ODA"
MERGE @%Y=@%X
+28 DO SETDA(.DA,%LEVEL,+YY)
+29 ;every time you recusion into stuff, it processes multiple
+30 ;completely for each entry
+31 DO STUFF(YY,+%NFLN,%NRT,%NBFR_%OIEN_",",%LEVEL+1,.DA,%PASS,.%MSG2,INREPRT)
+32 KILL DA
SET DA=ODA
SET %Y="DA"
SET %X="ODA"
MERGE @%Y=@%X
+33 IF INREPRT
DO PG^INHSYSUT(%PASS)
WRITE !,"----",!,"r "_%FILNUM
End DoDot:1
+34 QUIT
WORD(%NBFR,%ROOT,DA,%NODE,%PASS) ;Process word processing field
+1 ; input:
+2 ; %NBFR - Utility Global Buffer
+3 ; %ROOT - Root node of global to stuff
+4 ; DA - ien
+5 ; %NODE - node
+6 NEW %INX,%INCNT,%X,%Y,I,L
+7 ;Check if data exists to move
+8 IF $DATA(@(%NBFR_"0)"))
Begin DoDot:1
+9 ;move data from utility to correct multiple
+10 SET L=$LENGTH(%NBFR)
SET %X=$EXTRACT(%NBFR,1,L-1)_$SELECT($EXTRACT(%NBFR,L)="(":"",1:")")
SET %Y=%ROOT_DA_","_%NODE_")"
+11 MERGE @%Y=@%X
End DoDot:1
+12 QUIT
SETDA(DA,%LEVEL,Y) ;Set DA level so fileman doesn't choke
+1 ; Input:
+2 ; DA - ien and "Multiple" entry #'s
+3 ; %LEVEL - level in multiple
+4 ; Y - New entry number
+5 ; Output:
+6 ; DA - IEN and "Multiple" entry #'s
+7 NEW I
+8 FOR I=%LEVEL:-1:3
SET DA(I-1)=DA(I-2)
+9 SET DA(1)=DA
SET DA=+Y
+10 QUIT
DIC(DIC,X,DLAYGO,%IPS,DOA,%L,DINUM) ;dic lookup
+1 ;input:
+2 ; DIC - Global Root: Can be a string or file number
+3 ; If a file number, this function returns -1
+4 ; when looking at a multiple
+5 ; X - Stuff this bud
+6 ; DLAYGO - file number and formatting
+7 ; %IPS - input parameter string; see DIC(0) documentation
+8 ; DOA - array of previous DA values; passed by referrence
+9 ; %L - current level
+10 ; DINUM (opt) - force this ien
+11 ;output:
+12 ; Y - What DIC returns
+13 NEW G,DA,I,Y,INDD0
+14 IF DIC
IF DIC'>0!($GET(DOA)&$GET(%L))
QUIT -1
SET DIC=$GET(^DIC(DIC,0,"GL"))
IF DIC=""
QUIT -1
+15 ;Check for files whose .01 is a pointer. Currently only check 4020.
+16 IF $DATA(DINUM)
IF DIC="^INRHR("
SET INDD0=$GET(^DD(4020,.01,0))
IF $PIECE(INDD0,U,2)["P"
Begin DoDot:1
+17 ;Get file for next lookup
+18 SET INFILE="^"_$PIECE(INDD0,U,3)
+19 ;Do recursive lookup on file
+20 SET Y=$$DIC(INFILE,X,"","X")
+21 SET X=+Y
End DoDot:1
IF Y<0
QUIT Y
+22 IF $GET(DOA)
IF ($GET(%L))
Begin DoDot:1
+23 FOR I=%L:-1:2
SET DA(I)=DOA(I-1)
+24 SET DA(1)=DOA
End DoDot:1
+25 SET G=DIC_"0)"
IF '$DATA(@G)
SET @G="^"_DLAYGO_"^^"
+26 SET DIC(0)=%IPS
+27 IF '$DATA(DINUM)
DO ^DIC
+28 IF $DATA(DINUM)
DO ^DICN
IF Y=-1
Begin DoDot:1
+29 FOR I=1,2
Begin DoDot:2
+30 IF I=2
IF $DATA(IO(0))#10
IF $DATA(IO)#10
USE IO(0)
+31 WRITE *7,!,!,"Warning, the GIS TRANSACTION MOVER has failed to update ",!
+32 WRITE DIC," with the .01 field=",X,!,"This could possibly be due to corruption of the"
+33 WRITE "FILEMAN data structure.",!,"This installation cannot be aborted at this time but"
+34 WRITE "YOU MUST CONTACT THE SUPPORT CENTER IMMEDIATELY",!!
+35 IF I=2
IF $DATA(IO)#10
USE IO
End DoDot:2
IF $GET(IO)=$GET(IO(0))
QUIT
End DoDot:1
+36 QUIT Y
