INHMGD6 ;CAR; 7 May 97 11:43;HL7 MESSAGING - REBUILD SENSITIVITY ANALYSIS GLOBAL
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;
; PURPOSE:
; Module INHMGD6 is used to rebuild the Sensitivity Analysis Global
; ^UTILITY("INHMGD",
;
INSUPDT ;Create ^UTILITY("INHMGD",$J,...) dBase
; Input:
; None:
;
N INAS,INDA,INDC,INDL,INDOT,INF,INFS,INH,INJ
N INM,INS,INSEG,INSQ
S INDOT=0 ;show user some activity when rebuilding?
I $E(IOST)="C",'$D(IO("Q")),IO=IO(0) S INDOT=1
I INDOT W !,"Rebuilding ^UTILITY(""INHMGD""), this may take a while."
;
;1. load all Fields (^INTHL7F(X)), containing a "C" node and ] "", but
; watch for 10 nodes and expand subfields.
S INF=0 F S INF=$O(^INTHL7F(INF)) Q:'INF D
.;try for the DOCUMENTED DATA SOURCE 1st
.S INDL=$P($G(^INTHL7F(INF,0)),U,11)
.I INDL]"" S INDL="##"_INDL
.;else go for the DATA LOCATION
.S:INDL="" INDL=$G(^INTHL7F(INF,"C"))
.;pick up any sub-fields, must check for actual content
.I $D(^INTHL7F(INF,10,"AS")) D Q
..S (INX,INAS)="" F S INX=$O(^INTHL7F(INF,10,"AS",INX)) Q:'INX D
...S INDA=$O(^INTHL7F(INF,10,"AS",INX,0))
...S INDA=+$G(^INTHL7F(INF,10,+INDA,0)) Q:'INDA
...Q:'$D(^INTHL7F(INDA,"C")) S INDC=^INTHL7F(INDA,"C")
...Q:$TR(INDC," ")=""!(INDC["@")
...I INDC'["INTERNAL",$E(INDC)="""" Q
...S INAS=INAS_$S(INAS]"":"^"_INDA,1:INDA)
..I $L(INAS) S ^UTILITY("INHMGD",$J,"F10",INF)=INAS
.Q:INDL=""
.;don't save what we can't use
.Q:INDL["@"
.I $E(INDL)="""",INDL'["INTERNAL" Q
.S ^UTILITY("INHMGD",$J,"F",INF)=INDL
I INDOT W "."
;
;2. load Segments (^INTHL7S(X)), pointing to an ^INTHL7F(fld,"C")
; containing more than "".
S INS=0 F S INS=$O(^INTHL7S(INS)) Q:'INS D
.;order through the fields using the "AS" field
.S INFS=0,INAS="" F S INFS=$O(^INTHL7S(INS,1,"AS",INFS)) Q:'INFS D
..;get the "in order" index INSQ
..S INSQ=$O(^INTHL7S(INS,1,"AS",INFS,0)) Q:'INSQ
..;which points to the INSEG field
..S INSEG=+$G(^INTHL7S(INS,1,INSQ,0))
..;check if there is a DATA LOCATION or DOCUMENTED DATA SOURCE
..I INSEG,$D(^UTILITY("INHMGD",$J,"F",INSEG)) D Q
...S INAS=INAS_$S(INAS]"":"^"_INSEG,1:INSEG) ;format is: ien^ien^ien...
..;how about a sub-field
..I INSEG,$D(^UTILITY("INHMGD",$J,"F10",INSEG)) D
...S INSFS=^UTILITY("INHMGD",$J,"F10",INSEG) ;get the subfield string
...S INAS=INAS_$S(INAS]"":"^"_INSFS,1:INSFS) ;tack it on to INAS
.;save any fields that we found.
.S:INAS]"" ^UTILITY("INHMGD",$J,"S",INS)=INAS
I INDOT W "."
;
;3. then order through the messages (^INTHL7M(X)), and for each segment
;in ^UTILITY, store the following:
; (root,field,HL7field,segment,message) where there is a field
;-----------main message loop-------------------
S INM=0 F S INM=$O(^INTHL7M(INM)) Q:'INM D
.S INM(0)=$G(^INTHL7M(INM,0))
.Q:$P(INM(0),U,8) ;inactive - quit
.S INTRP=$G(^INTHL7M(INM,"S")) ;get script pointers
.S INMODE=$S($P(INTRP,U,2):1,1:0) ;incoming (0) or outgoing (1) message
.S INPARS=$S($P(INM(0),U,7)="P":1,1:0) ;is parse only set
.K FILE,FLVL S FLVL=0
.;get the root from $P5 of ^(0), exit if there is no root.
.S FILE=$P(INM(0),U,5) Q:'FILE S FILE(0)=FILE
.;order through the segment pointers. "AS" x-ref is in output order
.S INS=0 F S INS=$O(^INTHL7M(INM,1,"AS",INS)) Q:'INS D
..;$O to get the index that the "AS" references
..S INX=$O(^INTHL7M(INM,1,"AS",INS,0)) Q:'INX
..;check for common err:2 INSQs
..S INSEG(1)=$O(^INTHL7M(INM,1,"AS",INS,INX)) I INSEG(1) D
...S INSEG(1)=$G(^INTHL7M(INM,1,INX,0)),INERN=INERN+.001
...S ^UTILITY("INHMGD",$J,"E",INM,+INSEG(1),INERN)=FILE(FLVL)_U_"Msg# "_INM_" has multiple segments defined for Sequence# "_$P(INSEG(1),U,2)
..;retrieve segment info, skip processing if seg has parent segment,
..;since it will be called recursively from SEG
..S INSEG(1)=$G(^INTHL7M(INM,1,INX,0)) D:'$P(INSEG(1),U,11) SEG^INHMGD7(INX,.INERN)
;
;the UTILITY global is complete, delete the nodes we no longer need.
K ^UTILITY("INHMGD",$J,"F"),^UTILITY("INHMGD",$J,"S")
K ^UTILITY("INHMGD",$J,"F10"),^UTILITY("INHMGD",$J,"M")
Q
;
INHMGD6 ;CAR; 7 May 97 11:43;HL7 MESSAGING - REBUILD SENSITIVITY ANALYSIS GLOBAL
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;
+4 ; PURPOSE:
+5 ; Module INHMGD6 is used to rebuild the Sensitivity Analysis Global
+6 ; ^UTILITY("INHMGD",
+7 ;
INSUPDT ;Create ^UTILITY("INHMGD",$J,...) dBase
+1 ; Input:
+2 ; None:
+3 ;
+4 NEW INAS,INDA,INDC,INDL,INDOT,INF,INFS,INH,INJ
+5 NEW INM,INS,INSEG,INSQ
+6 ;show user some activity when rebuilding?
SET INDOT=0
+7 IF $EXTRACT(IOST)="C"
IF '$DATA(IO("Q"))
IF IO=IO(0)
SET INDOT=1
+8 IF INDOT
WRITE !,"Rebuilding ^UTILITY(""INHMGD""), this may take a while."
+9 ;
+10 ;1. load all Fields (^INTHL7F(X)), containing a "C" node and ] "", but
+11 ; watch for 10 nodes and expand subfields.
+12 SET INF=0
FOR
SET INF=$ORDER(^INTHL7F(INF))
IF 'INF
QUIT
Begin DoDot:1
+13 ;try for the DOCUMENTED DATA SOURCE 1st
+14 SET INDL=$PIECE($GET(^INTHL7F(INF,0)),U,11)
+15 IF INDL]""
SET INDL="##"_INDL
+16 ;else go for the DATA LOCATION
+17 IF INDL=""
SET INDL=$GET(^INTHL7F(INF,"C"))
+18 ;pick up any sub-fields, must check for actual content
+19 IF $DATA(^INTHL7F(INF,10,"AS"))
Begin DoDot:2
+20 SET (INX,INAS)=""
FOR
SET INX=$ORDER(^INTHL7F(INF,10,"AS",INX))
IF 'INX
QUIT
Begin DoDot:3
+21 SET INDA=$ORDER(^INTHL7F(INF,10,"AS",INX,0))
+22 SET INDA=+$GET(^INTHL7F(INF,10,+INDA,0))
IF 'INDA
QUIT
+23 IF '$DATA(^INTHL7F(INDA,"C"))
QUIT
SET INDC=^INTHL7F(INDA,"C")
+24 IF $TRANSLATE(INDC," ")=""!(INDC["@")
QUIT
+25 IF INDC'["INTERNAL"
IF $EXTRACT(INDC)=""""
QUIT
+26 SET INAS=INAS_$SELECT(INAS]"":"^"_INDA,1:INDA)
End DoDot:3
+27 IF $LENGTH(INAS)
SET ^UTILITY("INHMGD",$JOB,"F10",INF)=INAS
End DoDot:2
QUIT
+28 IF INDL=""
QUIT
+29 ;don't save what we can't use
+30 IF INDL["@"
QUIT
+31 IF $EXTRACT(INDL)=""""
IF INDL'["INTERNAL"
QUIT
+32 SET ^UTILITY("INHMGD",$JOB,"F",INF)=INDL
End DoDot:1
+33 IF INDOT
WRITE "."
+34 ;
+35 ;2. load Segments (^INTHL7S(X)), pointing to an ^INTHL7F(fld,"C")
+36 ; containing more than "".
+37 SET INS=0
FOR
SET INS=$ORDER(^INTHL7S(INS))
IF 'INS
QUIT
Begin DoDot:1
+38 ;order through the fields using the "AS" field
+39 SET INFS=0
SET INAS=""
FOR
SET INFS=$ORDER(^INTHL7S(INS,1,"AS",INFS))
IF 'INFS
QUIT
Begin DoDot:2
+40 ;get the "in order" index INSQ
+41 SET INSQ=$ORDER(^INTHL7S(INS,1,"AS",INFS,0))
IF 'INSQ
QUIT
+42 ;which points to the INSEG field
+43 SET INSEG=+$GET(^INTHL7S(INS,1,INSQ,0))
+44 ;check if there is a DATA LOCATION or DOCUMENTED DATA SOURCE
+45 IF INSEG
IF $DATA(^UTILITY("INHMGD",$JOB,"F",INSEG))
Begin DoDot:3
+46 ;format is: ien^ien^ien...
SET INAS=INAS_$SELECT(INAS]"":"^"_INSEG,1:INSEG)
End DoDot:3
QUIT
+47 ;how about a sub-field
+48 IF INSEG
IF $DATA(^UTILITY("INHMGD",$JOB,"F10",INSEG))
Begin DoDot:3
+49 ;get the subfield string
SET INSFS=^UTILITY("INHMGD",$JOB,"F10",INSEG)
+50 ;tack it on to INAS
SET INAS=INAS_$SELECT(INAS]"":"^"_INSFS,1:INSFS)
End DoDot:3
End DoDot:2
+51 ;save any fields that we found.
+52 IF INAS]""
SET ^UTILITY("INHMGD",$JOB,"S",INS)=INAS
End DoDot:1
+53 IF INDOT
WRITE "."
+54 ;
+55 ;3. then order through the messages (^INTHL7M(X)), and for each segment
+56 ;in ^UTILITY, store the following:
+57 ; (root,field,HL7field,segment,message) where there is a field
+58 ;-----------main message loop-------------------
+59 SET INM=0
FOR
SET INM=$ORDER(^INTHL7M(INM))
IF 'INM
QUIT
Begin DoDot:1
+60 SET INM(0)=$GET(^INTHL7M(INM,0))
+61 ;inactive - quit
IF $PIECE(INM(0),U,8)
QUIT
+62 ;get script pointers
SET INTRP=$GET(^INTHL7M(INM,"S"))
+63 ;incoming (0) or outgoing (1) message
SET INMODE=$SELECT($PIECE(INTRP,U,2):1,1:0)
+64 ;is parse only set
SET INPARS=$SELECT($PIECE(INM(0),U,7)="P":1,1:0)
+65 KILL FILE,FLVL
SET FLVL=0
+66 ;get the root from $P5 of ^(0), exit if there is no root.
+67 SET FILE=$PIECE(INM(0),U,5)
IF 'FILE
QUIT
SET FILE(0)=FILE
+68 ;order through the segment pointers. "AS" x-ref is in output order
+69 SET INS=0
FOR
SET INS=$ORDER(^INTHL7M(INM,1,"AS",INS))
IF 'INS
QUIT
Begin DoDot:2
+70 ;$O to get the index that the "AS" references
+71 SET INX=$ORDER(^INTHL7M(INM,1,"AS",INS,0))
IF 'INX
QUIT
+72 ;check for common err:2 INSQs
+73 SET INSEG(1)=$ORDER(^INTHL7M(INM,1,"AS",INS,INX))
IF INSEG(1)
Begin DoDot:3
+74 SET INSEG(1)=$GET(^INTHL7M(INM,1,INX,0))
SET INERN=INERN+.001
+75 SET ^UTILITY("INHMGD",$JOB,"E",INM,+INSEG(1),INERN)=FILE(FLVL)_U_"Msg# "_INM_" has multiple segments defined for Sequence# "_$PIECE(INSEG(1),U,2)
End DoDot:3
+76 ;retrieve segment info, skip processing if seg has parent segment,
+77 ;since it will be called recursively from SEG
+78 SET INSEG(1)=$GET(^INTHL7M(INM,1,INX,0))
IF '$PIECE(INSEG(1),U,11)
DO SEG^INHMGD7(INX,.INERN)
End DoDot:2
End DoDot:1
+79 ;
+80 ;the UTILITY global is complete, delete the nodes we no longer need.
+81 KILL ^UTILITY("INHMGD",$JOB,"F"),^UTILITY("INHMGD",$JOB,"S")
+82 KILL ^UTILITY("INHMGD",$JOB,"F10"),^UTILITY("INHMGD",$JOB,"M")
+83 QUIT
+84 ;
