Routine: INHSYSUT

INHSYSUT ;JPD/WOM; 23 Aug 1999 12:26;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

MSG(%X,%FNUM,%MSG,%MULT,%PASS) ;Display message if DIC lookup failed

 ; Input:

 ; %X - Entry we tried to look up Using DIC

 ; %FNUM - File number

 ; %MULT - 0 Not a multiple

 ;         1 Multiple

 ; Output:

 ; %MSG - 1 - Flag We have a message

 N %TP,QT

 S %TP="File",%MULT=$G(%MULT),QT=$C(34)

 I %MULT S %TP="Multiple"

 D PG^INHSYS03(%PASS)

 W !!,%TP_" entry "_QT_$P(%X,U)_QT_" does not exist for "_%TP_" "_%FNUM,!,"or is a duplicate entry!",!

 I %MULT W "If entry is a pointer, it will have to be entered by hand",!

 S %MSG=1

RQ(%RQ) ;Required fields

 ;output:  %RQ - Required fields array

N I

 F I=4000,4005,4006,4004,4011,4010,4012,4090.2,4020 S %RQ(I,.01)=""

 F I=.02,.04,.08 S %RQ(4000,I)=""

OMT(%OMT) ;fields to omit from updating

 ;Output:

 ;    %OMT - Fields to omit

 ;      If a file/field is found in this array, it will not

 ;      be updated in Pass 2

N I

 F I=.01 S %OMT(4005.01,I)=""

 F I=1,.01 S %OMT(4005.02,I)=""

 F I=3.01,1,5,7.01,7.03,9 S %OMT(4005,I)=""

 F I=.03,7.02,7.04,7.05 S %OMT(4004,I)=""

SAVE(%SAV) ;Save values from import environment

 ; Output:

 ;  %SAV - File and field to save value from

 ;    Files/fields to restore the site specific data

 ; Programmers note:

 ;   The DEVICE field (.03) in the BACKGROUND PROCESS CONTROL (4004)

 ;   was originally part of the %SAV array. This field was

 ;   omitted for two reasons. First, the field should no longer be

 ;   used by the GIS. Secondly, the field has an input transform that

 ;   causes the ^DIE call at tag FILE^INHSYSUT to ask for user input

 ;   if the string being stuffed is found in more than one entry.

 ;   This file/field should not be removed from array %OMT. The value

 ;   of this field will be NULL after running the GIS Transaction

 ;   Mover.

N I

 F I=.05 S %SAV(4000,I)=""

 F I=.02,5,6,7.02,7.04,7.05,1.01,1.2,1.3,1.4,1.5,1.6,1.8,1.9,1.1,1.11,1.12,1.14,10.01,10.02 S %SAV(4004,I)=""

 F I=3.01,1,5,7.01,7.02,7.03,9 S %SAV(4005,I)=""

FLSV(%XRF,%OIEN,%ROOT) ;Save old file in temp global

 ; Input

 ; %XRF - File number

 ; %OIEN - ien of file saving

 ; %ROOT - Root file name

 N %X,%Y

 S %X=%ROOT_%OIEN_")",%Y="^UTILITY(""INHSYSUT"",$J,%XRF,%OIEN)"

 M @%Y=@%X

 ;S %X=%ROOT_%OIEN_",",%Y="^UTILITY(""INHSYSUT"",$J,%XRF,%OIEN,"

 ;D %XY^%RCR

LIST(INSELTT) ;selectable list of parent and child transaction types

 ;output:

 ;  INSELTT --> array of selected transaction types

 ;local:

 ;  INPAR   --> parent TT

 ;  INCHLD  --> child TT

 ;Note: Does not put TT in INSELTT if the UNIQUE IDENTIFIER is

 ;      blank

 N INPAR,DWLRF,DWLB,DWL,DWLMK,DWLR,DWLMK1,INTT,I,INS,INIEN

 S INPAR="",I=0 F  S INPAR=$O(^INRHT("B",INPAR)) Q:INPAR=""  D

 .S INIEN=$O(^INRHT("B",INPAR,"")) Q:$P(^INRHT(INIEN,0),"^",4)=""

 .S I=I+1,INTT(1,I)=INPAR,INTT(1,I,0)=INIEN_"^c",INTT(2,I)="Child"

 .I $D(^INRHT("AC",INIEN)) S INTT(1,I,0)=INIEN_"^p",INTT(2,I)="Parent"

 S DWLRF="INTT",DWLB="2^5^12^60^8",DWL="HEL0,20F1WXXM-1A2"

 S DWL("TITLE")="D HDR^INHSYSUT"

 F  D ^DWL Q:DWLR'="E"  D EXPAND^INHSYSUT

 I " ^ ^^ "[(" "_DWLR_" ")!'$D(DWLMK) S INSELTT=0 Q

 S INS="" F I=1:1 S INS=$O(DWLMK(1,INS)) Q:'INS  D

 .S INSELTT=I,INSELTT(DWLMK(1,INS))=INTT(1,INS,0)_"^"_$$LB^UTIL(INTT(1,INS))

HDR ;header for list processor

 X DIJC("H")

 W $$SETXY^%ZTF(0,4),$$CENTER^INHUTIL("Transaction Type List",80)

 W $$SETXY^%ZTF(0,18),"Use <FIND> Key to find desired Transaction."

 W $$SETXY^%ZTF(0,19),"Use <SELECT> Key to pick a Transaction Type to process"

 X DIJC("L")

LOCKFL(INLKFLS,INEX) ;Lock files that will be used and check for zero node

 ; Input: INEX - if TRUE, then this is called during

 ;               IMPORT so only lock those files affected

 ; Output:

 ; INLKFLS - Locked files

 ; Returns 0 to continue 1 to quit

 I $D(IO)#10,$D(IO(0))#10 I IO'=IO(0) U IO(0)

 N %FNUM,%LFLG,%ROOT,%FILES,AA

 S %LFLG=0 S:'$D(INEX) INEX=0

 D XRF(.%FILES)

 F AA=1:1 S %FNUM=$P(%FILES,U,AA) Q:%FNUM=""  D  Q:INPOP

 .I INEX,'$D(^UTILITY("INHSYS",$J,%FNUM)) Q

 .S %ROOT=$P(^DIC(%FNUM,0,"GL"),"(")

 .I '$$LOCK(%ROOT,%FNUM) S (%LFLG,INPOP)=1

 .S INLKFLS(%ROOT)=%FNUM

 .S %ROOT=^DIC(%FNUM,0,"GL")_"0)"

 .I $D(@%ROOT)#10'=1 W *7,!,"File Corruption in the "_%FNUM_" file!" S (%LFLG,INPOP)=1

 I %LFLG D

 .W !!,"You will have to try later",!!!!

 .I $$CR^UTSRD(0,IOSL-1)

 I $D(IO)#10,$D(IO(0))#10 I IO'=IO(0) U IO

 Q %LFLG

LOCK(%ROOT,%FILNM) ;Lock other users from this file

 ; %ROOT - Global file node to lock

 ; %FILNM - File Name

 N INLOK S INLOK=1

 L +@%ROOT:3

 E  S INLOK=0 W *7,!,"Another terminal is editing the "_%FILNM_" file!"

 Q INLOK

UNLK(%FILE) ;Unlock file

 N I F I=1:1:3 L -@%FILE

RPRT1(%LEVEL,%FILNM,ND) ;Do report

 ; Input:

 ; %LEVEL - Level of pointer

 ; %FILNM - File Number

 ; ND - Node

N I

 D PG^INHSYS03(1)

 W ! F I=1:1:%LEVEL W "."

 W ?%LEVEL,%FILNM,?%LEVEL+14,$P($G(^DIC(%FILNM,0)),U),?%LEVEL+42,".01",?%LEVEL+48

 I %FILNM'=4020 W $P(@(ND),U)

 E  W $P($G(^INRHT($P(@(ND),U),0)),U)

 W !,?%LEVEL,ND

EXPAND ;Expand logic for list processor

 N INS,DA,DIC

 I '$D(DWLMK) W "SELECT an item to expand on.",*7

 E  D

 .S INS="" S INS=$O(DWLMK(1,INS))

 .S DA=+@(DWLRF_"(1,"_INS_",0)"),DIC="^INRHT("

 .D EN^DIQ

 I $$CR^UTSRD(0,IOSL-1)

FILE(DA,%DATA,%FLDNUM,DIE,INREPRT) ;file data

 ; Input:

 ; DA - ien and "Multiple entry"

 ; %DATA - What to file

 ; %FLDNUM - Field Number

 ; DIE - Global to file

 ; INREPRT - 0 - No report

 ;           1 - Report

 N X,DG,DNM,DQ,DIEZ,D0,D1,D2,D3,D4,D5,D6,D7,INY,FILNUM

 ; Don't stuff data for fields that are site specific except

 ;    on Pass 3

 S FILNUM=$P(@(DIE_"0)"),U,2) I %PASS'=3,$D(%SAV(FILNUM,%FLDNUM))!($D(%OMT(FILNUM,%FLDNUM))) Q

 I INREPRT=2 W ?70,DIE

 I DA'>0 D  Q

 .W !,"NON-EXISTENT OR DUPLICATE ENTRY! for "_$G(DIE)_" field #"_$G(%FLDNUM)_" Data: "_$G(%DATA)_" %XNODE="_$G(%XNODE)

 .D FLSUMERR^INHSYS11(FILNUM,%FLDNUM,DA,$P($G(%XNODE),U),DIE)

 S DR="S INY=0;"_%FLDNUM_"///^S X=%DATA;S INY=1"

 D ^DIE

 I '$G(INY) D

 .W ?56," NO DATA FILED for ",DIE," field #",%FLDNUM," Data: ",%DATA

 .D FLSUMERR^INHSYS11(FILNUM,%FLDNUM,DA,%DATA,DIE)

DATA(%B,%P,%D) ;retrieve the data from the buffer

 ;input:

 ;  %B - buffer

 ;  %P - If an integer, uparrow piece to return

 ;       If the first character is "E", then extract data

 ;output:

 ;  %D - Data

 S %D=""

 I $E(%P)="E",$D(@%B)#2 S %D=$E(@%B,+$E(%P,2,99),+$P(%P,",",2)) Q

 I $D(@%B)#2 S %D=$P(@%B,U,%P)

RUT(%ROOT) ;modify global root to indirection format

 ;%ROOT - Global root

N Y

 ;get last value of root,set to all but last value & concact w/ ) or ""

 S Y=$E(%ROOT,$L(%ROOT)),Y=$E(%ROOT,1,$L(%ROOT)-1)_$S(Y=",":")",1:"")

Q Y

UP(FN) ;goes up & up searching for the top level file number

 ;input:

 ;  FN - the current sub-level file number

N Y

 I '$D(^DD(FN,0,"UP")) S Y=FN

 E  S Y=$$UP(^("UP"))

Q Y

PG(%PASS) ;Page check

 ; Input:

 ;     %PASS - Which PASS

 I IOSL-5'>$Y D

 .I $E(IOST)="C",INCR,$$CR^UTSRD(0,IOSL-1)

 .D HEAD(%PASS)

HEAD(%PASS) ;header for destination report

 ; Input:

 ;   %PASS - Which pass is being run

 W @IOF

 I %PASS=1 W $$CENTER^INHUTIL("Pass 1 Required Fields",80)

 I %PASS=2 W $$CENTER^INHUTIL("Pass 2 All Fields",80)

 W !!,"File Number",?14,"File Name",?42,"Field Number",?56,"Data"

 W !,"^Root(IEN",!

WP(FIL,FLD) ;word process field

 ;input:

 ;  FIL - file number

 ;  FLD - field number

 ;  Returns 0 false 1 true

N Y

 I $P(^DD(FIL,FLD,0),U,2) S Y=$$WP(+$P(^(0),U,2),.01)

 Q $P(^(0),U,2)["W"

XRF(%FILES) ;cross reference of files and fields requiring some resolution

 ; Output:

 ; %FILES(FILE#)=fields

 ;':' delimiter separates field # and sub-file #

 ;',' delimiter separates sub-file # and sub-field #

 ;';' delimiter separates fields

 ;i.e. field[:sub-file,sub-field,...][;field...] etc.

 ; Subnodes used at RSLV^INHSYS03

 S %FILES="4012^4005^4011^4000^4004^4010^4090.2^4020^4006"

 S %FILES(4012)=".02;10:4012.02,.01;50"

 S %FILES(4005)=".02;.1"

 S %FILES(4011)=".05;1:4011.01,.01,.11;2:4011.02,.01;100;101"

 S %FILES(4000)=".02;.03;.06;.09;.17"

 S %FILES(4004)=".07"

 S %FILES(4010)="1:4010.01,.01"

 S %FILES(4090.2)=".02"

 S %FILES(4020)=".01;.02"

 S %FILES(4006)=".03"

INHSYSUT  ;JPD/WOM; 23 Aug 1999 12:26;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

 +6       ;

MSG(%X,%FNUM,%MSG,%MULT,%PASS) ;Display message if DIC lookup failed

 +1       ; Input:

 +2       ; %X - Entry we tried to look up Using DIC

 +3       ; %FNUM - File number

 +4       ; %MULT - 0 Not a multiple

 +5       ;         1 Multiple

 +6       ; Output:

 +7       ; %MSG - 1 - Flag We have a message

 +8        NEW %TP,QT

 +9        SET %TP="File"

           SET %MULT=$GET(%MULT)

           SET QT=$CHAR(34)

 +10       IF %MULT

               SET %TP="Multiple"

 +11       DO PG^INHSYS03(%PASS)

 +12       WRITE !!,%TP_" entry "_QT_$PIECE(%X,U)_QT_" does not exist for "_%TP_" "_%FNUM,!,"or is a duplicate entry!",!

 +13       IF %MULT

               WRITE "If entry is a pointer, it will have to be entered by hand",!

 +14       SET %MSG=1

 +15       QUIT

RQ(%RQ)   ;Required fields

 +1       ;output:  %RQ - Required fields array

 +2        NEW I

 +3        FOR I=4000,4005,4006,4004,4011,4010,4012,4090.2,4020

               SET %RQ(I,.01)=""

 +4        FOR I=.02,.04,.08

               SET %RQ(4000,I)=""

 +5        QUIT

OMT(%OMT) ;fields to omit from updating

 +1       ;Output:

 +2       ;    %OMT - Fields to omit

 +3       ;      If a file/field is found in this array, it will not

 +4       ;      be updated in Pass 2

 +5       ;

 +6        NEW I

 +7        FOR I=.01

               SET %OMT(4005.01,I)=""

 +8        FOR I=1,.01

               SET %OMT(4005.02,I)=""

 +9        FOR I=3.01,1,5,7.01,7.03,9

               SET %OMT(4005,I)=""

 +10       FOR I=.03,7.02,7.04,7.05

               SET %OMT(4004,I)=""

 +11       QUIT

SAVE(%SAV) ;Save values from import environment

 +1       ; Output:

 +2       ;  %SAV - File and field to save value from

 +3       ;    Files/fields to restore the site specific data

 +4       ;

 +5       ; Programmers note:

 +6       ;   The DEVICE field (.03) in the BACKGROUND PROCESS CONTROL (4004)

 +7       ;   was originally part of the %SAV array. This field was

 +8       ;   omitted for two reasons. First, the field should no longer be

 +9       ;   used by the GIS. Secondly, the field has an input transform that

 +10      ;   causes the ^DIE call at tag FILE^INHSYSUT to ask for user input

 +11      ;   if the string being stuffed is found in more than one entry.

 +12      ;   This file/field should not be removed from array %OMT. The value

 +13      ;   of this field will be NULL after running the GIS Transaction

 +14      ;   Mover.

 +15      ;

 +16       NEW I

 +17       FOR I=.05

               SET %SAV(4000,I)=""

 +18       FOR I=.02,5,6,7.02,7.04,7.05,1.01,1.2,1.3,1.4,1.5,1.6,1.8,1.9,1.1,1.11,1.12,1.14,10.01,10.02

               SET %SAV(4004,I)=""

 +19       FOR I=3.01,1,5,7.01,7.02,7.03,9

               SET %SAV(4005,I)=""

 +20       QUIT

FLSV(%XRF,%OIEN,%ROOT) ;Save old file in temp global

 +1       ; Input

 +2       ; %XRF - File number

 +3       ; %OIEN - ien of file saving

 +4       ; %ROOT - Root file name

 +5        NEW %X,%Y

 +6        SET %X=%ROOT_%OIEN_")"

           SET %Y="^UTILITY(""INHSYSUT"",$J,%XRF,%OIEN)"

 +7        MERGE @%Y=@%X

 +8       ;S %X=%ROOT_%OIEN_",",%Y="^UTILITY(""INHSYSUT"",$J,%XRF,%OIEN,"

 +9       ;D %XY^%RCR

 +10       QUIT

LIST(INSELTT) ;selectable list of parent and child transaction types

 +1       ;output:

 +2       ;  INSELTT --> array of selected transaction types

 +3       ;local:

 +4       ;  INPAR   --> parent TT

 +5       ;  INCHLD  --> child TT

 +6       ;

 +7       ;Note: Does not put TT in INSELTT if the UNIQUE IDENTIFIER is

 +8       ;      blank

 +9        NEW INPAR,DWLRF,DWLB,DWL,DWLMK,DWLR,DWLMK1,INTT,I,INS,INIEN

 +10       SET INPAR=""

           SET I=0

FOR

               SET INPAR=$ORDER(^INRHT("B",INPAR))

               IF INPAR=""

                   QUIT

               Begin DoDot:1

 +11               SET INIEN=$ORDER(^INRHT("B",INPAR,""))

                   IF $PIECE(^INRHT(INIEN,0),"^",4)=""

                       QUIT

 +12               SET I=I+1

                   SET INTT(1,I)=INPAR

                   SET INTT(1,I,0)=INIEN_"^c"

                   SET INTT(2,I)="Child"

 +13               IF $DATA(^INRHT("AC",INIEN))

                       SET INTT(1,I,0)=INIEN_"^p"

                       SET INTT(2,I)="Parent"

               End DoDot:1

 +14       SET DWLRF="INTT"

           SET DWLB="2^5^12^60^8"

           SET DWL="HEL0,20F1WXXM-1A2"

 +15       SET DWL("TITLE")="D HDR^INHSYSUT"

 +16       FOR

               DO ^DWL

               IF DWLR'="E"

                   QUIT

               DO EXPAND^INHSYSUT

 +17       IF " ^ ^^ "[(" "_DWLR_" ")!'$DATA(DWLMK)

               SET INSELTT=0

               QUIT

 +18       SET INS=""

           FOR I=1:1

               SET INS=$ORDER(DWLMK(1,INS))

               IF 'INS

                   QUIT

               Begin DoDot:1

 +19               SET INSELTT=I

                   SET INSELTT(DWLMK(1,INS))=INTT(1,INS,0)_"^"_$$LB^UTIL(INTT(1,INS))

               End DoDot:1

 +20       QUIT

HDR       ;header for list processor

 +1        XECUTE DIJC("H")

 +2        WRITE $$SETXY^%ZTF(0,4),$$CENTER^INHUTIL("Transaction Type List",80)

 +3        WRITE $$SETXY^%ZTF(0,18),"Use <FIND> Key to find desired Transaction."

 +4        WRITE $$SETXY^%ZTF(0,19),"Use <SELECT> Key to pick a Transaction Type to process"

 +5        XECUTE DIJC("L")

 +6        QUIT

LOCKFL(INLKFLS,INEX) ;Lock files that will be used and check for zero node

 +1       ; Input: INEX - if TRUE, then this is called during

 +2       ;               IMPORT so only lock those files affected

 +3       ; Output:

 +4       ; INLKFLS - Locked files

 +5       ; Returns 0 to continue 1 to quit

 +6        IF $DATA(IO)#10

               IF $DATA(IO(0))#10

                   IF IO'=IO(0)

                       USE IO(0)

 +7        NEW %FNUM,%LFLG,%ROOT,%FILES,AA

 +8        SET %LFLG=0

           IF '$DATA(INEX)

               SET INEX=0

 +9        DO XRF(.%FILES)

 +10       FOR AA=1:1

               SET %FNUM=$PIECE(%FILES,U,AA)

               IF %FNUM=""

                   QUIT

               Begin DoDot:1

 +11               IF INEX

                       IF '$DATA(^UTILITY("INHSYS",$JOB,%FNUM))

                           QUIT

 +12               SET %ROOT=$PIECE(^DIC(%FNUM,0,"GL"),"(")

 +13               IF '$$LOCK(%ROOT,%FNUM)

                       SET (%LFLG,INPOP)=1

 +14               SET INLKFLS(%ROOT)=%FNUM

 +15               SET %ROOT=^DIC(%FNUM,0,"GL")_"0)"

 +16               IF $DATA(@%ROOT)#10'=1

                       WRITE *7,!,"File Corruption in the "_%FNUM_" file!"

                       SET (%LFLG,INPOP)=1

               End DoDot:1

               IF INPOP

                   QUIT

 +17       IF %LFLG

               Begin DoDot:1

 +18               WRITE !!,"You will have to try later",!!!!

 +19               IF $$CR^UTSRD(0,IOSL-1)

               End DoDot:1

 +20       IF $DATA(IO)#10

               IF $DATA(IO(0))#10

                   IF IO'=IO(0)

                       USE IO

 +21       QUIT %LFLG

LOCK(%ROOT,%FILNM) ;Lock other users from this file

 +1       ; %ROOT - Global file node to lock

 +2       ; %FILNM - File Name

 +3        NEW INLOK

           SET INLOK=1

 +4        LOCK +@%ROOT:3

 +5       IF '$TEST

               SET INLOK=0

               WRITE *7,!,"Another terminal is editing the "_%FILNM_" file!"

 +6        QUIT INLOK

UNLK(%FILE) ;Unlock file

 +1        NEW I

           FOR I=1:1:3

               LOCK -@%FILE

 +2        QUIT

RPRT1(%LEVEL,%FILNM,ND) ;Do report

 +1       ; Input:

 +2       ; %LEVEL - Level of pointer

 +3       ; %FILNM - File Number

 +4       ; ND - Node

 +5        NEW I

 +6        DO PG^INHSYS03(1)

 +7        WRITE !

           FOR I=1:1:%LEVEL

               WRITE "."

 +8        WRITE ?%LEVEL,%FILNM,?%LEVEL+14,$PIECE($GET(^DIC(%FILNM,0)),U),?%LEVEL+42,".01",?%LEVEL+48

 +9        IF %FILNM'=4020

               WRITE $PIECE(@(ND),U)

 +10      IF '$TEST

               WRITE $PIECE($GET(^INRHT($PIECE(@(ND),U),0)),U)

 +11       WRITE !,?%LEVEL,ND

 +12       QUIT

EXPAND    ;Expand logic for list processor

 +1       ;

 +2        NEW INS,DA,DIC

 +3        IF '$DATA(DWLMK)

               WRITE "SELECT an item to expand on.",*7

 +4       IF '$TEST

               Begin DoDot:1

 +5                SET INS=""

                   SET INS=$ORDER(DWLMK(1,INS))

 +6                SET DA=+@(DWLRF_"(1,"_INS_",0)")

                   SET DIC="^INRHT("

 +7                DO EN^DIQ

               End DoDot:1

 +8        IF $$CR^UTSRD(0,IOSL-1)

 +9        QUIT

FILE(DA,%DATA,%FLDNUM,DIE,INREPRT) ;file data

 +1       ; Input:

 +2       ; DA - ien and "Multiple entry"

 +3       ; %DATA - What to file

 +4       ; %FLDNUM - Field Number

 +5       ; DIE - Global to file

 +6       ; INREPRT - 0 - No report

 +7       ;           1 - Report

 +8        NEW X,DG,DNM,DQ,DIEZ,D0,D1,D2,D3,D4,D5,D6,D7,INY,FILNUM

 +9       ;

 +10      ; Don't stuff data for fields that are site specific except

 +11      ;    on Pass 3

 +12       SET FILNUM=$PIECE(@(DIE_"0)"),U,2)

           IF %PASS'=3

               IF $DATA(%SAV(FILNUM,%FLDNUM))!($DATA(%OMT(FILNUM,%FLDNUM)))

                   QUIT

 +13       IF INREPRT=2

               WRITE ?70,DIE

 +14       IF DA'>0

               Begin DoDot:1

 +15               WRITE !,"NON-EXISTENT OR DUPLICATE ENTRY! for "_$GET(DIE)_" field #"_$GET(%FLDNUM)_" Data: "_$GET(%DATA)_" %XNODE="_$GET(%XNODE)

 +16               DO FLSUMERR^INHSYS11(FILNUM,%FLDNUM,DA,$PIECE($GET(%XNODE),U),DIE)

               End DoDot:1

               QUIT

 +17       SET DR="S INY=0;"_%FLDNUM_"///^S X=%DATA;S INY=1"

 +18       DO ^DIE

 +19       IF '$GET(INY)

               Begin DoDot:1

 +20               WRITE ?56," NO DATA FILED for ",DIE," field #",%FLDNUM," Data: ",%DATA

 +21               DO FLSUMERR^INHSYS11(FILNUM,%FLDNUM,DA,%DATA,DIE)

               End DoDot:1

 +22       QUIT

DATA(%B,%P,%D) ;retrieve the data from the buffer

 +1       ;input:

 +2       ;  %B - buffer

 +3       ;  %P - If an integer, uparrow piece to return

 +4       ;       If the first character is "E", then extract data

 +5       ;output:

 +6       ;  %D - Data

 +7        SET %D=""

 +8        IF $EXTRACT(%P)="E"

               IF $DATA(@%B)#2

                   SET %D=$EXTRACT(@%B,+$EXTRACT(%P,2,99),+$PIECE(%P,",",2))

                   QUIT

 +9        IF $DATA(@%B)#2

               SET %D=$PIECE(@%B,U,%P)

 +10       QUIT

RUT(%ROOT) ;modify global root to indirection format

 +1       ;%ROOT - Global root

 +2        NEW Y

 +3       ;get last value of root,set to all but last value & concact w/ ) or ""

 +4        SET Y=$EXTRACT(%ROOT,$LENGTH(%ROOT))

           SET Y=$EXTRACT(%ROOT,1,$LENGTH(%ROOT)-1)_$SELECT(Y=",":")",1:"")

 +5        QUIT Y

 +6       ;

UP(FN)    ;goes up & up searching for the top level file number

 +1       ;input:

 +2       ;  FN - the current sub-level file number

 +3        NEW Y

 +4        IF '$DATA(^DD(FN,0,"UP"))

               SET Y=FN

 +5       IF '$TEST

               SET Y=$$UP(^("UP"))

 +6        QUIT Y

 +7       ;

PG(%PASS) ;Page check

 +1       ; Input:

 +2       ;     %PASS - Which PASS

 +3        IF IOSL-5'>$Y

               Begin DoDot:1

 +4                IF $EXTRACT(IOST)="C"

                       IF INCR

                           IF $$CR^UTSRD(0,IOSL-1)

 +5                DO HEAD(%PASS)

               End DoDot:1

 +6        QUIT

HEAD(%PASS) ;header for destination report

 +1       ; Input:

 +2       ;   %PASS - Which pass is being run

 +3        WRITE @IOF

 +4        IF %PASS=1

               WRITE $$CENTER^INHUTIL("Pass 1 Required Fields",80)

 +5        IF %PASS=2

               WRITE $$CENTER^INHUTIL("Pass 2 All Fields",80)

 +6        WRITE !!,"File Number",?14,"File Name",?42,"Field Number",?56,"Data"

 +7        WRITE !,"^Root(IEN",!

 +8        QUIT

WP(FIL,FLD) ;word process field

 +1       ;input:

 +2       ;  FIL - file number

 +3       ;  FLD - field number

 +4       ;  Returns 0 false 1 true

 +5        NEW Y

 +6        IF $PIECE(^DD(FIL,FLD,0),U,2)

               SET Y=$$WP(+$PIECE(^(0),U,2),.01)

 +7        QUIT $PIECE(^(0),U,2)["W"

 +8       ;

XRF(%FILES) ;cross reference of files and fields requiring some resolution

 +1       ; Output:

 +2       ; %FILES(FILE#)=fields

 +3       ;':' delimiter separates field # and sub-file #

 +4       ;',' delimiter separates sub-file # and sub-field #

 +5       ;';' delimiter separates fields

 +6       ;i.e. field[:sub-file,sub-field,...][;field...] etc.

 +7       ; Subnodes used at RSLV^INHSYS03

 +8        SET %FILES="4012^4005^4011^4000^4004^4010^4090.2^4020^4006"

 +9        SET %FILES(4012)=".02;10:4012.02,.01;50"

 +10       SET %FILES(4005)=".02;.1"

 +11       SET %FILES(4011)=".05;1:4011.01,.01,.11;2:4011.02,.01;100;101"

 +12       SET %FILES(4000)=".02;.03;.06;.09;.17"

 +13       SET %FILES(4004)=".07"

 +14       SET %FILES(4010)="1:4010.01,.01"

 +15       SET %FILES(4090.2)=".02"

 +16       SET %FILES(4020)=".01;.02"

 +17       SET %FILES(4006)=".03"

 +18       QUIT

INHSYSUT.m