INTSTR2 ;DGH; 5 Aug 97 14:20;Continuation of Required Field functions
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;
Q ;no top entry
;
LOOP(INUIF,LVL,UIFMES,UCNT,INCDEC,DEFMES,INERR) ;Recursive logic
;Compares message segment id at the current LVL
;with the UIF segment id at the current UCNT.
;INPUT:
; INUIF = Entry in UIF being evaluated
; LVL = level array LVL(1), LVL(2) set to segment being validated.
; UIFMES = UIF message array.
; UCNT = UIF array node being validated. UCNT is incremented inside
; LOOP if MSID=USID. Otherwise, it stays the same.
; Note that USID=UIFMES(UCNT)=segment id for the
; INCDEC = 1 to increment levels and work deeper into nests
; = 0 to decrement levels and back out of nests
; required segments only checked if INCDEC=1
; DEFMES = Defined message array.
; INERR = (PRB) flag. Initialized=0, will be set to 1 or 2
; if error conditions are found.
;INPUT not passed
; INDELIM = delimiter. Must be local variable set previously
; INSUBDEL = subdelimiter set of all but INDELIM.
;
;set arrays for comparison
I $D(DEBUG) D
.D IO^INTSTR("==========================================================")
.D IO^INTSTR("Entering LOOP tag with UCNT= "_UCNT_" INCDEC= "_INCDEC)
.D IO^INTSTR("LVL array:")
.S QX=$Q(LVL) Q:'$L(QX) S INMSG=QX_"="_$G(@(QX)) D IO^INTSTR(INMSG)
.F S QX=$Q(@(QX)) Q:'$L(QX) S INMSG=QX_"="_$G(@(QX)) D IO^INTSTR(INMSG)
N MESS,CURLVL,CURCNT,ORD,USID,MSID,G,MREP,MREQ,OUT2
Q:'$D(LVL) Q:'UCNT
S CURLVL=$O(LVL(""),-1),CURCNT=LVL(CURLVL) S:'$D(LCT) LCT=0
;If current level is 1 and current count=0, nothing left to do
I CURLVL=1,CURCNT=0 Q
S ORD="",I="" F S I=$O(LVL(I)) Q:'I D
.S ORD=ORD_LVL(I)_","
S G="DEFMES("_$E(ORD,1,($L(ORD)-1))_")"
S MESS(0)=$G(@G@(0))
S MSID=$P(MESS(0),U),MREP=$P(MESS(0),U,2),MREQ=$P(MESS(0),U,3),USID=UIFMES(UCNT)
I $G(DEBUG)>1 D
.S INMSG=G_"="_MESS(0) D IO^INTSTR(INMSG)
.S INMSG="MSID= "_MSID_" USID= "_USID_" Repeating= "_MREP_" Required="_MREQ D IO^INTSTR(INMSG)
Q:'$L(MSID)
;For navigational segments, increment LVL and recurse
I MSID="NAVIGATE" D D LOOP(INUIF,.LVL,.UIFMES,.UCNT,.INCDEC,.DEFMES,.INERR) Q
.;Navigational segment should be a "parent segment" with a level below
.I $O(@G@(0)) S LVL(CURLVL+1)=1 Q
.;If another level does not exist, increment at current level and
.;see if node exists
.S LVL(CURLVL)=CURCNT+1 S X=$$EXIST(.LVL,.DEFMES) Q:X
.;If neither condition is met, back out
.D FNDNXT(.LVL,CURLVL,.DEFMES)
;If this segment is not defined, print message, increment both the
;USID and LCT counters, and recurse.
I '$D(DEFMES(USID)) S INMSG="Message contains unexpected segment "_USID,UCNT=$O(UIFMES(UCNT)) D GETLINE^INHOU(INUIF,.LCT,.LINE),IO^INTSTR(INMSG),LOOP(INUIF,.LVL,.UIFMES,.UCNT,.INCDEC,.DEFMES,.INERR) Q
;If segments match (FNDNXT may have reset MSID, MREQ and MREP)
S MATCH=$S(MSID=USID:1,1:0)
I MATCH D
.I INEXPND S INMSG=$S(MREQ:"Required",1:"Optional")_" segment "_MSID_" found" D IO^INTSTR(INMSG)
.S INCDEC=1
.;Validate required fields if there are any
.D VALID^INTSTR1(.LCT,.DEFMES,MSID,.UIFMES,UCNT,INUIF,.INERR)
.;Check for repeating segments. Increment uif counter until
.;segments no longer match.
.S OUT=0 F D Q:OUT
..S UCNT=$O(UIFMES(UCNT)) I 'UCNT S OUT=1 Q
..S USID=$P(UIFMES(UCNT),U) I MSID'=USID S OUT=1 Q
..;S INMSG=$S('MREP:"Unexpected repeating ",1:"Repeating ")_MSID_" segment found" S:'MREP INERR=1 I INEXPND!'MREP D IO^INTSTR(INMSG)
..S INMSG="Repeating "_MSID_" segment found" I INEXPND D IO^INTSTR(INMSG)
..D VALID^INTSTR1(.LCT,.DEFMES,MSID,.UIFMES,UCNT,INUIF,.INERR)
;End of processing if segments match. At this point, the USID counter
;has been incremented to the next segment (if another segment exists).
;Quit if another segment does not exist. (But verify if another
;segment Should exist)
;Q:'UCNT
;Q:'$D(UIFMES(UCNT))
S OUT=0 D
.;If UCNT has value, we are still looping through segments
.Q:UCNT
.;Otherwise no more segments in message being checked
.S OUT=1
.;quit if no other level exists
.Q:'$O(@G@(0))
.;otherwise see if next level is required
.S OUT2=0 F D Q:OUT2
..S LVL(CURLVL+1)=1 S X=$$EXIST(.LVL,.DEFMES,.MESS) I 'X S OUT2=1 Q
..;If next segment is navigational, look deeper
..I $P(MESS,U)["NAVIGATE" S CURLVL=CURLVL+1 Q
..I $P(MESS,U,3) S INMSG="Required segment "_$P(MESS,U,1)_" missing. Message ended abruptly.",INERR=2 D IO^INTSTR(INMSG) S OUT2=1
Q:OUT
;Otherwise, fall through to recursive tag.
;
;If segment ids did not match, logic depends on whether we need
;to look deeper into nesting (INCDEC=1) or are backing out (INCDEC=0)
D
.I INCDEC D Q
..;Check for required segment (only check going into nest)
..I 'MATCH,MREQ S INMSG="Required segment "_MSID_" missing, "_USID_" segment found in it's place" D IO^INTSTR(INMSG)
..;If another level exists, create another level counter. BUT don't
..;go into nest if segments didn't match.
..;First see if another level exists.
..I MATCH,$O(@G@(0)) D Q
...S LVL(CURLVL+1)=1
..;Else another level doesn't exist, increment at current level
..;and see if node exists
..S LVL(CURLVL)=CURCNT+1 S X=$$EXIST(.LVL,.DEFMES) Q:X
..;If neither condition is met, set INCDEC=0 and back out
..S INCDEC=0
..I CURLVL>1 K LVL(CURLVL)
.I 'INCDEC D
..;Test logic as of 4/28!!!!!
..D FNDNXT(.LVL,CURLVL,.DEFMES)
;Now that UCNT may have been incremented, and LVL definitely
;has been modified, loop recursively
D LOOP(INUIF,.LVL,.UIFMES,.UCNT,.INCDEC,.DEFMES,.INERR)
Q
;
FNDNXT(LVL,CURLVL,DEFMES) ;Find next "nest"
;If backing out of one nest, must find LVL at which another exists
;or recursion will continually traverse up and down same nest.
;INPUT:
; LVL=Level array
; LVL(CURLVL) = the current level in the LVL array
; DEFMES = the defined message array
;OUTPUT:
; A new LVL at which a defined message exists
; MREQ and MREP will be redefined if a match is found.
N OUT,ID,REP,REQ
;If LVL=1, can't back out any further, increment LVL(1)
I CURLVL=1 S LVL(1)=LVL(1)+1 Q
S OUT=0 F D Q:OUT
.;Kill current level to back out one level
.K LVL(CURLVL)
.;Identify the deepest remaining level and its current count
.S CURLVL=$O(LVL(""),-1),CURCNT=LVL(CURLVL)
.;Again see if back out to LVL=1, can't back out any further
.I CURLVL=1 S LVL(1)=LVL(1)+1,OUT=1 Q
.;At current backed out level, if MSID=USID, it's a repeating segment.
.D MESSID(.LVL,.ID,.REP,.REQ) I ID=USID D Q
..;Be sure segment is allowed to repeat
..I 'REP S INMSG="WARNING: Repeating segment "_ID_" is not defined as repeating" D IO^INTSTR(INMSG)
..S MSID=ID,MREP=REP,MREQ=REQ,OUT=1
.;If no match on MSID, increment at this level and see if node exists.
.;If not, this function will continue to kill levels.
.S LVL(CURLVL)=CURCNT+1 S OUT=$$EXIST(.LVL,.DEFMES)
Q
;
EXIST(LVL,DEFMES,MESS) ;Return whether node exists at current level
;INPUT:
; LVL=the current nesting level
; DEFMES = Defined message array
; MESS (OPT) (PBR) = returns the 0 node
;RETURN VALUE:
; 1=YES 0=NO
S ORD="",I="" F S I=$O(LVL(I)) Q:'I D
.S ORD=ORD_LVL(I)_","
S G="DEFMES("_$E(ORD,1,($L(ORD)-1))_")"
I $D(MESS) S MESS=$G(@G@(0))
Q:$D(@G@(0)) 1
Q 0
;
MESSID(LVL,ID,REP,REQ) ;Lookup message id for segment at current level
;This tag duplicates logic at LOOP+33, but it's too late in DIT
;to consolidate.
;INPUT:
; ID=MESSAGE ID
; LVL=LVL ARRAY
; REP=Repeatable?
; REQ=Required?
N ORD,I,G,MESS
S ORD="",I="" F S I=$O(LVL(I)) Q:'I D
.S ORD=ORD_LVL(I)_","
S G="DEFMES("_$E(ORD,1,($L(ORD)-1))_")"
S MESS(0)=$G(@G@(0))
S ID=$P(MESS(0),U),REP=$P(MESS(0),U,2),REQ=$P(MESS(0),U,3)
Q
;
INTSTR2 ;DGH; 5 Aug 97 14:20;Continuation of Required Field functions
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;
+4 ;no top entry
QUIT
+5 ;
LOOP(INUIF,LVL,UIFMES,UCNT,INCDEC,DEFMES,INERR) ;Recursive logic
+1 ;Compares message segment id at the current LVL
+2 ;with the UIF segment id at the current UCNT.
+3 ;INPUT:
+4 ; INUIF = Entry in UIF being evaluated
+5 ; LVL = level array LVL(1), LVL(2) set to segment being validated.
+6 ; UIFMES = UIF message array.
+7 ; UCNT = UIF array node being validated. UCNT is incremented inside
+8 ; LOOP if MSID=USID. Otherwise, it stays the same.
+9 ; Note that USID=UIFMES(UCNT)=segment id for the
+10 ; INCDEC = 1 to increment levels and work deeper into nests
+11 ; = 0 to decrement levels and back out of nests
+12 ; required segments only checked if INCDEC=1
+13 ; DEFMES = Defined message array.
+14 ; INERR = (PRB) flag. Initialized=0, will be set to 1 or 2
+15 ; if error conditions are found.
+16 ;INPUT not passed
+17 ; INDELIM = delimiter. Must be local variable set previously
+18 ; INSUBDEL = subdelimiter set of all but INDELIM.
+19 ;
+20 ;set arrays for comparison
+21 IF $DATA(DEBUG)
Begin DoDot:1
+22 DO IO^INTSTR("==========================================================")
+23 DO IO^INTSTR("Entering LOOP tag with UCNT= "_UCNT_" INCDEC= "_INCDEC)
+24 DO IO^INTSTR("LVL array:")
+25 SET QX=$QUERY(LVL)
IF '$LENGTH(QX)
QUIT
SET INMSG=QX_"="_$GET(@(QX))
DO IO^INTSTR(INMSG)
+26 FOR
SET QX=$QUERY(@(QX))
IF '$LENGTH(QX)
QUIT
SET INMSG=QX_"="_$GET(@(QX))
DO IO^INTSTR(INMSG)
End DoDot:1
+27 NEW MESS,CURLVL,CURCNT,ORD,USID,MSID,G,MREP,MREQ,OUT2
+28 IF '$DATA(LVL)
QUIT
IF 'UCNT
QUIT
+29 SET CURLVL=$ORDER(LVL(""),-1)
SET CURCNT=LVL(CURLVL)
IF '$DATA(LCT)
SET LCT=0
+30 ;If current level is 1 and current count=0, nothing left to do
+31 IF CURLVL=1
IF CURCNT=0
QUIT
+32 SET ORD=""
SET I=""
FOR
SET I=$ORDER(LVL(I))
IF 'I
QUIT
Begin DoDot:1
+33 SET ORD=ORD_LVL(I)_","
End DoDot:1
+34 SET G="DEFMES("_$EXTRACT(ORD,1,($LENGTH(ORD)-1))_")"
+35 SET MESS(0)=$GET(@G@(0))
+36 SET MSID=$PIECE(MESS(0),U)
SET MREP=$PIECE(MESS(0),U,2)
SET MREQ=$PIECE(MESS(0),U,3)
SET USID=UIFMES(UCNT)
+37 IF $GET(DEBUG)>1
Begin DoDot:1
+38 SET INMSG=G_"="_MESS(0)
DO IO^INTSTR(INMSG)
+39 SET INMSG="MSID= "_MSID_" USID= "_USID_" Repeating= "_MREP_" Required="_MREQ
DO IO^INTSTR(INMSG)
End DoDot:1
+40 IF '$LENGTH(MSID)
QUIT
+41 ;For navigational segments, increment LVL and recurse
+42 IF MSID="NAVIGATE"
Begin DoDot:1
+43 ;Navigational segment should be a "parent segment" with a level below
+44 IF $ORDER(@G@(0))
SET LVL(CURLVL+1)=1
QUIT
+45 ;If another level does not exist, increment at current level and
+46 ;see if node exists
+47 SET LVL(CURLVL)=CURCNT+1
SET X=$$EXIST(.LVL,.DEFMES)
IF X
QUIT
+48 ;If neither condition is met, back out
+49 DO FNDNXT(.LVL,CURLVL,.DEFMES)
End DoDot:1
DO LOOP(INUIF,.LVL,.UIFMES,.UCNT,.INCDEC,.DEFMES,.INERR)
QUIT
+50 ;If this segment is not defined, print message, increment both the
+51 ;USID and LCT counters, and recurse.
+52 IF '$DATA(DEFMES(USID))
SET INMSG="Message contains unexpected segment "_USID
SET UCNT=$ORDER(UIFMES(UCNT))
DO GETLINE^INHOU(INUIF,.LCT,.LINE)
DO IO^INTSTR(INMSG)
DO LOOP(INUIF,.LVL,.UIFMES,.UCNT,.INCDEC,.DEFMES,.INERR)
QUIT
+53 ;If segments match (FNDNXT may have reset MSID, MREQ and MREP)
+54 SET MATCH=$SELECT(MSID=USID:1,1:0)
+55 IF MATCH
Begin DoDot:1
+56 IF INEXPND
SET INMSG=$SELECT(MREQ:"Required",1:"Optional")_" segment "_MSID_" found"
DO IO^INTSTR(INMSG)
+57 SET INCDEC=1
+58 ;Validate required fields if there are any
+59 DO VALID^INTSTR1(.LCT,.DEFMES,MSID,.UIFMES,UCNT,INUIF,.INERR)
+60 ;Check for repeating segments. Increment uif counter until
+61 ;segments no longer match.
+62 SET OUT=0
FOR
Begin DoDot:2
+63 SET UCNT=$ORDER(UIFMES(UCNT))
IF 'UCNT
SET OUT=1
QUIT
+64 SET USID=$PIECE(UIFMES(UCNT),U)
IF MSID'=USID
SET OUT=1
QUIT
+65 ;S INMSG=$S('MREP:"Unexpected repeating ",1:"Repeating ")_MSID_" segment found" S:'MREP INERR=1 I INEXPND!'MREP D IO^INTSTR(INMSG)
+66 SET INMSG="Repeating "_MSID_" segment found"
IF INEXPND
DO IO^INTSTR(INMSG)
+67 DO VALID^INTSTR1(.LCT,.DEFMES,MSID,.UIFMES,UCNT,INUIF,.INERR)
End DoDot:2
IF OUT
QUIT
End DoDot:1
+68 ;End of processing if segments match. At this point, the USID counter
+69 ;has been incremented to the next segment (if another segment exists).
+70 ;Quit if another segment does not exist. (But verify if another
+71 ;segment Should exist)
+72 ;Q:'UCNT
+73 ;Q:'$D(UIFMES(UCNT))
+74 SET OUT=0
Begin DoDot:1
+75 ;If UCNT has value, we are still looping through segments
+76 IF UCNT
QUIT
+77 ;Otherwise no more segments in message being checked
+78 SET OUT=1
+79 ;quit if no other level exists
+80 IF '$ORDER(@G@(0))
QUIT
+81 ;otherwise see if next level is required
+82 SET OUT2=0
FOR
Begin DoDot:2
+83 SET LVL(CURLVL+1)=1
SET X=$$EXIST(.LVL,.DEFMES,.MESS)
IF 'X
SET OUT2=1
QUIT
+84 ;If next segment is navigational, look deeper
+85 IF $PIECE(MESS,U)["NAVIGATE"
SET CURLVL=CURLVL+1
QUIT
+86 IF $PIECE(MESS,U,3)
SET INMSG="Required segment "_$PIECE(MESS,U,1)_" missing. Message ended abruptly."
SET INERR=2
DO IO^INTSTR(INMSG)
SET OUT2=1
End DoDot:2
IF OUT2
QUIT
End DoDot:1
+87 IF OUT
QUIT
+88 ;Otherwise, fall through to recursive tag.
+89 ;
+90 ;If segment ids did not match, logic depends on whether we need
+91 ;to look deeper into nesting (INCDEC=1) or are backing out (INCDEC=0)
+92 Begin DoDot:1
+93 IF INCDEC
Begin DoDot:2
+94 ;Check for required segment (only check going into nest)
+95 IF 'MATCH
IF MREQ
SET INMSG="Required segment "_MSID_" missing, "_USID_" segment found in it's place"
DO IO^INTSTR(INMSG)
+96 ;If another level exists, create another level counter. BUT don't
+97 ;go into nest if segments didn't match.
+98 ;First see if another level exists.
+99 IF MATCH
IF $ORDER(@G@(0))
Begin DoDot:3
+100 SET LVL(CURLVL+1)=1
End DoDot:3
QUIT
+101 ;Else another level doesn't exist, increment at current level
+102 ;and see if node exists
+103 SET LVL(CURLVL)=CURCNT+1
SET X=$$EXIST(.LVL,.DEFMES)
IF X
QUIT
+104 ;If neither condition is met, set INCDEC=0 and back out
+105 SET INCDEC=0
+106 IF CURLVL>1
KILL LVL(CURLVL)
End DoDot:2
QUIT
+107 IF 'INCDEC
Begin DoDot:2
+108 ;Test logic as of 4/28!!!!!
+109 DO FNDNXT(.LVL,CURLVL,.DEFMES)
End DoDot:2
End DoDot:1
+110 ;Now that UCNT may have been incremented, and LVL definitely
+111 ;has been modified, loop recursively
+112 DO LOOP(INUIF,.LVL,.UIFMES,.UCNT,.INCDEC,.DEFMES,.INERR)
+113 QUIT
+114 ;
FNDNXT(LVL,CURLVL,DEFMES) ;Find next "nest"
+1 ;If backing out of one nest, must find LVL at which another exists
+2 ;or recursion will continually traverse up and down same nest.
+3 ;INPUT:
+4 ; LVL=Level array
+5 ; LVL(CURLVL) = the current level in the LVL array
+6 ; DEFMES = the defined message array
+7 ;OUTPUT:
+8 ; A new LVL at which a defined message exists
+9 ; MREQ and MREP will be redefined if a match is found.
+10 NEW OUT,ID,REP,REQ
+11 ;If LVL=1, can't back out any further, increment LVL(1)
+12 IF CURLVL=1
SET LVL(1)=LVL(1)+1
QUIT
+13 SET OUT=0
FOR
Begin DoDot:1
+14 ;Kill current level to back out one level
+15 KILL LVL(CURLVL)
+16 ;Identify the deepest remaining level and its current count
+17 SET CURLVL=$ORDER(LVL(""),-1)
SET CURCNT=LVL(CURLVL)
+18 ;Again see if back out to LVL=1, can't back out any further
+19 IF CURLVL=1
SET LVL(1)=LVL(1)+1
SET OUT=1
QUIT
+20 ;At current backed out level, if MSID=USID, it's a repeating segment.
+21 DO MESSID(.LVL,.ID,.REP,.REQ)
IF ID=USID
Begin DoDot:2
+22 ;Be sure segment is allowed to repeat
+23 IF 'REP
SET INMSG="WARNING: Repeating segment "_ID_" is not defined as repeating"
DO IO^INTSTR(INMSG)
+24 SET MSID=ID
SET MREP=REP
SET MREQ=REQ
SET OUT=1
End DoDot:2
QUIT
+25 ;If no match on MSID, increment at this level and see if node exists.
+26 ;If not, this function will continue to kill levels.
+27 SET LVL(CURLVL)=CURCNT+1
SET OUT=$$EXIST(.LVL,.DEFMES)
End DoDot:1
IF OUT
QUIT
+28 QUIT
+29 ;
EXIST(LVL,DEFMES,MESS) ;Return whether node exists at current level
+1 ;INPUT:
+2 ; LVL=the current nesting level
+3 ; DEFMES = Defined message array
+4 ; MESS (OPT) (PBR) = returns the 0 node
+5 ;RETURN VALUE:
+6 ; 1=YES 0=NO
+7 SET ORD=""
SET I=""
FOR
SET I=$ORDER(LVL(I))
IF 'I
QUIT
Begin DoDot:1
+8 SET ORD=ORD_LVL(I)_","
End DoDot:1
+9 SET G="DEFMES("_$EXTRACT(ORD,1,($LENGTH(ORD)-1))_")"
+10 IF $DATA(MESS)
SET MESS=$GET(@G@(0))
+11 IF $DATA(@G@(0))
QUIT 1
+12 QUIT 0
+13 ;
MESSID(LVL,ID,REP,REQ) ;Lookup message id for segment at current level
+1 ;This tag duplicates logic at LOOP+33, but it's too late in DIT
+2 ;to consolidate.
+3 ;INPUT:
+4 ; ID=MESSAGE ID
+5 ; LVL=LVL ARRAY
+6 ; REP=Repeatable?
+7 ; REQ=Required?
+8 NEW ORD,I,G,MESS
+9 SET ORD=""
SET I=""
FOR
SET I=$ORDER(LVL(I))
IF 'I
QUIT
Begin DoDot:1
+10 SET ORD=ORD_LVL(I)_","
End DoDot:1
+11 SET G="DEFMES("_$EXTRACT(ORD,1,($LENGTH(ORD)-1))_")"
+12 SET MESS(0)=$GET(@G@(0))
+13 SET ID=$PIECE(MESS(0),U)
SET REP=$PIECE(MESS(0),U,2)
SET REQ=$PIECE(MESS(0),U,3)
+14 QUIT
+15 ;
