INHMGD7 ;CAR; 7 May 97 11:43;HL7 MESSAGING - SEGMENT SUBROUTINE FOR SENSITIVITY ANALYSIS
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;
; PURPOSE:
; Module SEG^INHMGD7 is used to navigate the segment list under
; each message in ^INTHL7M. It is called by INHMGD6 and it is called
; recursively to reach the children of parent segments, which are
; skipped by INHMGD6. And it is used to evaluate the address of each
; field in each segment.
;
SEG(INSEG,INERN) ;process the segment
;get the segment description string and segment number from '7M.
; Inputs
; INSEG = Segment index
; INERN = Error counter.
S INSEG(1)=^INTHL7M(INM,1,INSEG,0),INSEG(2)=INSEG,INSEG=+INSEG(1)
Q:'$D(^INTHL7S(INSEG,0))
;
N DIC,INWHILE,INCH,INUDI,INX,X
S INSEG(0)=^INTHL7S(INSEG,0) Q:$P(INSEG(0),U,2)="MSH"
S INWHILE=$P(INSEG(1),U,3)!$P(INSEG(1),U,4) ;REPEATS or OTHER
S INUDI=$P(INSEG(1),U,12) ;user defined index
I INWHILE,(INUDI="") D
.I $P(INSEG(1),U,3),'$P(INSEG(1),U,4) D Q ;MULTIPLE
..;look up the multiple name to get the field#
..K DIC S (X,INX)=$P(INSEG(1),U,8),DIC="^DD("_+FILE(FLVL)_","
..S DIC(0)="FMZ",DIC("S")="I $P(^(0),U,2)" D ^DIC
..I Y<0 D Q
...S INWHILE=0 Q:INPARS&('INMODE) ;bogus seg. ok in input ParseOnly
...S INERN=INERN+.1
...S ^UTILITY("INHMGD",$J,"E",INM,INSEG,INERN)=+FILE(FLVL)_U_"Multiple "_INX_" does not exist"
..;multiple found, store file# in FILE(FLVL) and name in INWHILE(1)
..S FLVL=FLVL+1,FILE(FLVL)=+$P(Y(0),U,2),INWHILE(1)=$P(Y,U,2)
.;must have been an OTHER
.S FLVL=FLVL+1,FILE(FLVL)=+$P(INSEG(1),U,5)
.I 'FILE(FLVL) D Q
..S INX="No OTHER file specified",INERN=INERN+.001
..S ^UTILITY("INHMGD",$J,"E",INM,INSEG,INERN)=FILE(FLVL)_U_INX
.;store other file name
.S INWHILE(1)=$P(^DIC(+FILE(FLVL),0),U)
;
;continue processing this segment.
N INAS,INFC,INFIL,INFL,INFLD,INJ,INRS
;could have done this check earlier, but wanted to eval FILE(FLVL)
I $D(^UTILITY("INHMGD",$J,"S",INSEG)) D
.;now go through list of fields for this segment INAS="ien^ien^ien..."
.S INAS=^UTILITY("INHMGD",$J,"S",INSEG)
.F INJ=1:1:$L(INAS,U) K X D
..;separate out the field pointer, then get the contents INFC
..S INFL=$P(INAS,U,INJ) Q:'INFL
..S INFC=$G(^UTILITY("INHMGD",$J,"F",INFL)) Q:INFC=""
..;derive the address
..S INRS=$$RESOLVE^INHMGD3(FILE(FLVL),INFC)
..;If no results returned, mark as error and quit
..I '$L(INRS) D Q
...S ^UTILITY("INHMGD",$J,"E",INM,INSEG,INFL)=FILE(FLVL)_U_INFC_" Unable to resolve or missing from Data Dictionary."
..;mark progress?
..I INDOT S INDOT=INDOT+1 I INDOT>70 S INDOT=1 W "."
..;separate out root and field name
..S INFLD=+$P(INRS,":"),INFIL=+$P(INRS,":",2)
..I INFLD,INFIL S ^UTILITY("INHMGD",$J,"A",INFIL,INFLD,INFL,INSEG,INM)="" Q
..;trap for 'INFLD or 'INFIL
..S ^UTILITY("INHMGD",$J,"E",INM,INSEG,INFL)=FILE(FLVL)_U_"Missing "_INFLD_" or "_INFIL
;
;pick up child segments
I $D(^INTHL7M(INM,1,"ASP",INSEG)) D
.S INCH=0
.F S INCH=$O(^INTHL7M(INM,1,"ASP",INSEG,INCH)) Q:'INCH D
..S INX=0 F S INX=$O(^INTHL7M(INM,1,"ASP",INSEG,INCH,INX)) Q:'INX D SEG(INX,.INERN)
;
;adjust file level
I INWHILE S FLVL=FLVL-1
I FLVL<0 D
.S INERN=INERN+.001
.S ^UTILITY("INHMGD",$J,"E",INM,INSEG,INERN)=FILE(0)_U_"FLVL at -1"
.S FLVL=0
Q
;
INHMGD7 ;CAR; 7 May 97 11:43;HL7 MESSAGING - SEGMENT SUBROUTINE FOR SENSITIVITY ANALYSIS
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;
+4 ; PURPOSE:
+5 ; Module SEG^INHMGD7 is used to navigate the segment list under
+6 ; each message in ^INTHL7M. It is called by INHMGD6 and it is called
+7 ; recursively to reach the children of parent segments, which are
+8 ; skipped by INHMGD6. And it is used to evaluate the address of each
+9 ; field in each segment.
+10 ;
SEG(INSEG,INERN) ;process the segment
+1 ;get the segment description string and segment number from '7M.
+2 ; Inputs
+3 ; INSEG = Segment index
+4 ; INERN = Error counter.
+5 SET INSEG(1)=^INTHL7M(INM,1,INSEG,0)
SET INSEG(2)=INSEG
SET INSEG=+INSEG(1)
+6 IF '$DATA(^INTHL7S(INSEG,0))
QUIT
+7 ;
+8 NEW DIC,INWHILE,INCH,INUDI,INX,X
+9 SET INSEG(0)=^INTHL7S(INSEG,0)
IF $PIECE(INSEG(0),U,2)="MSH"
QUIT
+10 ;REPEATS or OTHER
SET INWHILE=$PIECE(INSEG(1),U,3)!$PIECE(INSEG(1),U,4)
+11 ;user defined index
SET INUDI=$PIECE(INSEG(1),U,12)
+12 IF INWHILE
IF (INUDI="")
Begin DoDot:1
+13 ;MULTIPLE
IF $PIECE(INSEG(1),U,3)
IF '$PIECE(INSEG(1),U,4)
Begin DoDot:2
+14 ;look up the multiple name to get the field#
+15 KILL DIC
SET (X,INX)=$PIECE(INSEG(1),U,8)
SET DIC="^DD("_+FILE(FLVL)_","
+16 SET DIC(0)="FMZ"
SET DIC("S")="I $P(^(0),U,2)"
DO ^DIC
+17 IF Y<0
Begin DoDot:3
+18 ;bogus seg. ok in input ParseOnly
SET INWHILE=0
IF INPARS&('INMODE)
QUIT
+19 SET INERN=INERN+.1
+20 SET ^UTILITY("INHMGD",$JOB,"E",INM,INSEG,INERN)=+FILE(FLVL)_U_"Multiple "_INX_" does not exist"
End DoDot:3
QUIT
+21 ;multiple found, store file# in FILE(FLVL) and name in INWHILE(1)
+22 SET FLVL=FLVL+1
SET FILE(FLVL)=+$PIECE(Y(0),U,2)
SET INWHILE(1)=$PIECE(Y,U,2)
End DoDot:2
QUIT
+23 ;must have been an OTHER
+24 SET FLVL=FLVL+1
SET FILE(FLVL)=+$PIECE(INSEG(1),U,5)
+25 IF 'FILE(FLVL)
Begin DoDot:2
+26 SET INX="No OTHER file specified"
SET INERN=INERN+.001
+27 SET ^UTILITY("INHMGD",$JOB,"E",INM,INSEG,INERN)=FILE(FLVL)_U_INX
End DoDot:2
QUIT
+28 ;store other file name
+29 SET INWHILE(1)=$PIECE(^DIC(+FILE(FLVL),0),U)
End DoDot:1
+30 ;
+31 ;continue processing this segment.
+32 NEW INAS,INFC,INFIL,INFL,INFLD,INJ,INRS
+33 ;could have done this check earlier, but wanted to eval FILE(FLVL)
+34 IF $DATA(^UTILITY("INHMGD",$JOB,"S",INSEG))
Begin DoDot:1
+35 ;now go through list of fields for this segment INAS="ien^ien^ien..."
+36 SET INAS=^UTILITY("INHMGD",$JOB,"S",INSEG)
+37 FOR INJ=1:1:$LENGTH(INAS,U)
KILL X
Begin DoDot:2
+38 ;separate out the field pointer, then get the contents INFC
+39 SET INFL=$PIECE(INAS,U,INJ)
IF 'INFL
QUIT
+40 SET INFC=$GET(^UTILITY("INHMGD",$JOB,"F",INFL))
IF INFC=""
QUIT
+41 ;derive the address
+42 SET INRS=$$RESOLVE^INHMGD3(FILE(FLVL),INFC)
+43 ;If no results returned, mark as error and quit
+44 IF '$LENGTH(INRS)
Begin DoDot:3
+45 SET ^UTILITY("INHMGD",$JOB,"E",INM,INSEG,INFL)=FILE(FLVL)_U_INFC_" Unable to resolve or missing from Data Dictionary."
End DoDot:3
QUIT
+46 ;mark progress?
+47 IF INDOT
SET INDOT=INDOT+1
IF INDOT>70
SET INDOT=1
WRITE "."
+48 ;separate out root and field name
+49 SET INFLD=+$PIECE(INRS,":")
SET INFIL=+$PIECE(INRS,":",2)
+50 IF INFLD
IF INFIL
SET ^UTILITY("INHMGD",$JOB,"A",INFIL,INFLD,INFL,INSEG,INM)=""
QUIT
+51 ;trap for 'INFLD or 'INFIL
+52 SET ^UTILITY("INHMGD",$JOB,"E",INM,INSEG,INFL)=FILE(FLVL)_U_"Missing "_INFLD_" or "_INFIL
End DoDot:2
End DoDot:1
+53 ;
+54 ;pick up child segments
+55 IF $DATA(^INTHL7M(INM,1,"ASP",INSEG))
Begin DoDot:1
+56 SET INCH=0
+57 FOR
SET INCH=$ORDER(^INTHL7M(INM,1,"ASP",INSEG,INCH))
IF 'INCH
QUIT
Begin DoDot:2
+58 SET INX=0
FOR
SET INX=$ORDER(^INTHL7M(INM,1,"ASP",INSEG,INCH,INX))
IF 'INX
QUIT
DO SEG(INX,.INERN)
End DoDot:2
End DoDot:1
+59 ;
+60 ;adjust file level
+61 IF INWHILE
SET FLVL=FLVL-1
+62 IF FLVL<0
Begin DoDot:1
+63 SET INERN=INERN+.001
+64 SET ^UTILITY("INHMGD",$JOB,"E",INM,INSEG,INERN)=FILE(0)_U_"FLVL at -1"
+65 SET FLVL=0
End DoDot:1
+66 QUIT
+67 ;
