HLOPRSR1 ;ALB/CJM - Visual Parser 12 JUN 1997 10:00 am ;11/12/2008
;;1.6;HEALTH LEVEL SEVEN;**138,139**;Oct 13, 1995;Build 11
;Per VHA Directive 2004-038, this routine should not be modified.
;
;
;Definitions:
;$$SCRNSIZE number of lines in the scrolling region
;@MSG@() array containing the message
;$$MSGSIZE number of lines in the message
;$$TOP msg line number appearing at the top of the scrolling region.
; It could be negative if the user scrolled up past the top of
; the msg.
;$$BOT msg line number of the line that appears at the bottom of the
; scrolling area. It could be bigger than $$MSGSIZE if the user
; scrolled down past the msg
;$$LINE the msg line being parsed
;$$X the character parsing position within the msg line
;$$Y the screen line of the current message line
;$$SEG current segment #
;$$FLD current field number
;$$REP current repitition number
;$$COMP current component #
;$$SUB current subcomponent #
;$$SEGSTART (<segment number>) msg line # that the segment starts on
;SEGTYPE - 3 character segment type of the current segment
;DELIM -field,component,subcomponent,repitition dlimiters
;FLD - field delimiter
;REP -repitition delimiter
;COMP - component delimiter
;SUB - subcomponent delimiter
;SEG - SEG(<seg#>)=line it starts on
;SEGLINE() - SEGLINE(<line number>)=segment it is in (1st line only)
;@DESCRIBE@() - list of text lines containing the description of current field
;
PARSE(PARMS) ;
N MSG,POS,SEG,INPUT,QUIT,IOBM,IOTM,HILITE,FLD,REP,ESC,COMP,SUB,DELIM,SEGTYPE,SEGLINE,OLDBM,OLDTM,DESCRIBE,VALUE,LASTPART,VERSION,VALMBCK,XGRT,OLD,REPEAT
S OLDBM=$G(IOBM),OLDTM=$G(IOTM)
S VALMBCK="R"
Q:'$$SETUP^HLOPRSR3(.PARMS,.MSG,.POS,.SEG)
S QUIT=0
F S INPUT=$$READ^XGF(1,30) D Q:QUIT W IOCUON
.D
..;remove what the user typed
..N CHAR,X,Y
..W IOCUOFF
..S CHAR=$$GETCHAR^HLOPRSR2
..I CHAR="" S CHAR=" "
..D IOXY($$Y,$$X)
..W $S($P(POS("CURRENT DELIMITER"),"^",2):IORVON,1:IOINHI)
..W IORVOFF,IOINORM
..W CHAR
.;
.I XGRT="UP" D UP^HLOPRSR2 Q
.I (INPUT="U")!(INPUT="u") D UP^HLOPRSR2 Q
.I XGRT="DOWN" D DOWN^HLOPRSR2 Q
.I (INPUT="D")!(INPUT="d") D DOWN^HLOPRSR2 Q
.I XGRT="LEFT" D LEFT^HLOPRSR2 Q
.I (INPUT="L")!(INPUT="l") D LEFT^HLOPRSR2 Q
.I XGRT="RIGHT" D RIGHT^HLOPRSR2 Q
.I XGRT="TAB" D RIGHT^HLOPRSR2 Q
.I (INPUT="R")!(INPUT="r") D RIGHT^HLOPRSR2 Q
.I (INPUT="Q")!(INPUT="q") S QUIT=1
.I (INPUT="?")!(INPUT="h")!(INPUT="h") D HELP^HLOPRSR3 Q
.D IOXY($$Y,$$X) W IOCUON
K @MSG
I $L(DESCRIBE) K @DESCRIBE
D CLEAN^XGF
D ENS^%ZISS
W IOEDALL
S IOTM=OLDTM,IOBM=OLDBM W @IOSTBM
Q
;
WRITELN(LINE,Y) ;writes one line to the screen
;LINE- # of line in @MSG
;Y - screen line #
D IOXY(Y,1)
I $G(SEGLINE(LINE)) D
.W IOINHI
.W $E($G(@MSG@(LINE)),1,3)
.W IOINORM
.W $E($G(@MSG@(LINE)),4,80)
E D
.W $G(@MSG@(LINE))
Q
;
MSGSIZE() ;
Q $O(@MSG@(9999999999),-1)
SCRNSIZE() ;
Q (IOBM-IOTM)+1
TOP(INC) ;msg line at the top of the scrolling area
I $G(INC) S POS("TOP")=POS("TOP")+INC
Q POS("TOP")
BOT() ;msg line at the bottom of the scrolling area
Q ($$TOP+$$SCRNSIZE)-1
LINE(TO,INC) ;msg line
;
;If TO and INC are null, $$LINE returns the current msg line
;If TO is valued, the current line is set to TO and that value returned
;Otherwise, if INC is valued the current line is incremented by that value and is returned
D
.I $L($G(TO)),$$X(1) S POS("LINE")=TO
.I $G(INC),$$X(1) S POS("LINE")=POS("LINE")+INC
Q +$G(POS("LINE"))
;
X(TO,INC) ;current position within the line
;
;If TO and INC are null, $$X returns the current character position
;If TO is valued, the current position is set to TO and that value returned
;Otherwise, if INC is valued the current position is incremented by that value and is returned
;
D
.I $L($G(TO)) S POS("CHAR")=TO
.I $G(INC) S POS("CHAR")=POS("CHAR")+INC
;
I $G(POS("CHAR"))>$L($G(@MSG@($$LINE))) S POS("CHAR")=$L($G(@MSG@($$LINE)))
I $G(POS("CHAR"))<1 S POS("CHAR")=1
Q +$G(POS("CHAR"))
Y(LINE) ;screen line of msg line = LINE
;LINE defaults to $$LINE
I $D(LINE) Q (LINE-$$TOP)+1
Q ($$LINE-$$TOP)+1
SEG(INC) ;returns the current segement #
;if INC is passed in, the segment # is first incremented/decremented by INC, then the new value is returned
;returns the new current segment
S POS("SEG")=$G(POS("SEG"))+$G(INC)
Q POS("SEG")
FLD(SET) ;returns the currrent field #
;Input:
; SET:
; if "+" increments the field #
; if "-" decrements the field #
; if SET>0 sets the field # to SET
D:$D(SET)
.I $E(SET)="+" S POS("FLD")=$G(POS("FLD"))+1 Q
.I $E(SET)="-" S POS("FLD")=$G(POS("FLD"))-1 Q
.S POS("FLD")=SET
Q $G(POS("FLD"))
REP(SET) ;returns the current repitition #
;Input:
; SET:
; if "+" increments the repitition #
; if "-" decrements the repitition #
; if >0 sets the repitition # to SET
D:$D(SET)
.I $E(SET)="+" S POS("REP")=$G(POS("REP"))+1 Q
.I $E(SET)="-" S POS("REP")=POS("REP")-1 Q
.S POS("REP")=SET
I $D(SET) S:'($G(LASTPART($$FLD))>POS("REP")) LASTPART($$FLD)=POS("REP")
Q +$G(POS("REP"))
COMP(SET) ;returns the current component #
;Input:
; SET:
; if "+" increments the component #
; if "-" decrements the component #
; if >0 sets the component # to SET
D:$D(SET)
.I $E(SET)="+" S POS("COMP")=$G(POS("COMP"))+1 Q
.I $E(SET)="-" S POS("COMP")=POS("COMP")-1 Q
.S POS("COMP")=SET
I $D(SET) S:'($G(LASTPART($$FLD,$$REP))>POS("COMP")) LASTPART($$FLD,$$REP)=POS("COMP")
Q +$G(POS("COMP"))
;
SUB(SET) ;returns the current sub-component #
;Input:
; SET:
; if "+" increments the subcomponent #
; if "-" decrements the subcomponent #
; if >0 sets the sub-component # to SET
D:$D(SET)
.I $E(SET)="+" S POS("SUB")=$G(POS("SUB"))+1 Q
.I $E(SET)="-" S POS("SUB")=POS("SUB")-1 Q
.S POS("SUB")=SET
I $D(SET) S:'($G(LASTPART($$FLD,$$REP,$$COMP))>POS("SUB")) LASTPART($$FLD,$$REP,$$COMP)=POS("SUB")
Q +$G(POS("SUB"))
;
SEGSTART(SEGMENT) ;
Q $G(SEG(SEGMENT))
;
IOXY(Y,X) ; moves to screen position line=Y, col=X
;convert to (0,0) origin
I $G(X),X=+X S X=X-1
I $G(Y),Y=+Y S Y=Y-1
;
D IOXY^XGF($G(Y),$G(X))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLOPRSR1 6333 printed Sep 23, 2025@19:35:07 Page 2
HLOPRSR1 ;ALB/CJM - Visual Parser 12 JUN 1997 10:00 am ;11/12/2008
+1 ;;1.6;HEALTH LEVEL SEVEN;**138,139**;Oct 13, 1995;Build 11
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
+5 ;Definitions:
+6 ;$$SCRNSIZE number of lines in the scrolling region
+7 ;@MSG@() array containing the message
+8 ;$$MSGSIZE number of lines in the message
+9 ;$$TOP msg line number appearing at the top of the scrolling region.
+10 ; It could be negative if the user scrolled up past the top of
+11 ; the msg.
+12 ;$$BOT msg line number of the line that appears at the bottom of the
+13 ; scrolling area. It could be bigger than $$MSGSIZE if the user
+14 ; scrolled down past the msg
+15 ;$$LINE the msg line being parsed
+16 ;$$X the character parsing position within the msg line
+17 ;$$Y the screen line of the current message line
+18 ;$$SEG current segment #
+19 ;$$FLD current field number
+20 ;$$REP current repitition number
+21 ;$$COMP current component #
+22 ;$$SUB current subcomponent #
+23 ;$$SEGSTART (<segment number>) msg line # that the segment starts on
+24 ;SEGTYPE - 3 character segment type of the current segment
+25 ;DELIM -field,component,subcomponent,repitition dlimiters
+26 ;FLD - field delimiter
+27 ;REP -repitition delimiter
+28 ;COMP - component delimiter
+29 ;SUB - subcomponent delimiter
+30 ;SEG - SEG(<seg#>)=line it starts on
+31 ;SEGLINE() - SEGLINE(<line number>)=segment it is in (1st line only)
+32 ;@DESCRIBE@() - list of text lines containing the description of current field
+33 ;
PARSE(PARMS) ;
+1 NEW MSG,POS,SEG,INPUT,QUIT,IOBM,IOTM,HILITE,FLD,REP,ESC,COMP,SUB,DELIM,SEGTYPE,SEGLINE,OLDBM,OLDTM,DESCRIBE,VALUE,LASTPART,VERSION,VALMBCK,XGRT,OLD,REPEAT
+2 SET OLDBM=$GET(IOBM)
SET OLDTM=$GET(IOTM)
+3 SET VALMBCK="R"
+4 if '$$SETUP^HLOPRSR3(.PARMS,.MSG,.POS,.SEG)
QUIT
+5 SET QUIT=0
+6 FOR
SET INPUT=$$READ^XGF(1,30)
Begin DoDot:1
+7 Begin DoDot:2
+8 ;remove what the user typed
+9 NEW CHAR,X,Y
+10 WRITE IOCUOFF
+11 SET CHAR=$$GETCHAR^HLOPRSR2
+12 IF CHAR=""
SET CHAR=" "
+13 DO IOXY($$Y,$$X)
+14 WRITE $SELECT($PIECE(POS("CURRENT DELIMITER"),"^",2):IORVON,1:IOINHI)
+15 WRITE IORVOFF,IOINORM
+16 WRITE CHAR
End DoDot:2
+17 ;
+18 IF XGRT="UP"
DO UP^HLOPRSR2
QUIT
+19 IF (INPUT="U")!(INPUT="u")
DO UP^HLOPRSR2
QUIT
+20 IF XGRT="DOWN"
DO DOWN^HLOPRSR2
QUIT
+21 IF (INPUT="D")!(INPUT="d")
DO DOWN^HLOPRSR2
QUIT
+22 IF XGRT="LEFT"
DO LEFT^HLOPRSR2
QUIT
+23 IF (INPUT="L")!(INPUT="l")
DO LEFT^HLOPRSR2
QUIT
+24 IF XGRT="RIGHT"
DO RIGHT^HLOPRSR2
QUIT
+25 IF XGRT="TAB"
DO RIGHT^HLOPRSR2
QUIT
+26 IF (INPUT="R")!(INPUT="r")
DO RIGHT^HLOPRSR2
QUIT
+27 IF (INPUT="Q")!(INPUT="q")
SET QUIT=1
+28 IF (INPUT="?")!(INPUT="h")!(INPUT="h")
DO HELP^HLOPRSR3
QUIT
+29 DO IOXY($$Y,$$X)
WRITE IOCUON
End DoDot:1
if QUIT
QUIT
WRITE IOCUON
+30 KILL @MSG
+31 IF $LENGTH(DESCRIBE)
KILL @DESCRIBE
+32 DO CLEAN^XGF
+33 DO ENS^%ZISS
+34 WRITE IOEDALL
+35 SET IOTM=OLDTM
SET IOBM=OLDBM
WRITE @IOSTBM
+36 QUIT
+37 ;
WRITELN(LINE,Y) ;writes one line to the screen
+1 ;LINE- # of line in @MSG
+2 ;Y - screen line #
+3 DO IOXY(Y,1)
+4 IF $GET(SEGLINE(LINE))
Begin DoDot:1
+5 WRITE IOINHI
+6 WRITE $EXTRACT($GET(@MSG@(LINE)),1,3)
+7 WRITE IOINORM
+8 WRITE $EXTRACT($GET(@MSG@(LINE)),4,80)
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 WRITE $GET(@MSG@(LINE))
End DoDot:1
+11 QUIT
+12 ;
MSGSIZE() ;
+1 QUIT $ORDER(@MSG@(9999999999),-1)
SCRNSIZE() ;
+1 QUIT (IOBM-IOTM)+1
TOP(INC) ;msg line at the top of the scrolling area
+1 IF $GET(INC)
SET POS("TOP")=POS("TOP")+INC
+2 QUIT POS("TOP")
BOT() ;msg line at the bottom of the scrolling area
+1 QUIT ($$TOP+$$SCRNSIZE)-1
LINE(TO,INC) ;msg line
+1 ;
+2 ;If TO and INC are null, $$LINE returns the current msg line
+3 ;If TO is valued, the current line is set to TO and that value returned
+4 ;Otherwise, if INC is valued the current line is incremented by that value and is returned
+5 Begin DoDot:1
+6 IF $LENGTH($GET(TO))
IF $$X(1)
SET POS("LINE")=TO
+7 IF $GET(INC)
IF $$X(1)
SET POS("LINE")=POS("LINE")+INC
End DoDot:1
+8 QUIT +$GET(POS("LINE"))
+9 ;
X(TO,INC) ;current position within the line
+1 ;
+2 ;If TO and INC are null, $$X returns the current character position
+3 ;If TO is valued, the current position is set to TO and that value returned
+4 ;Otherwise, if INC is valued the current position is incremented by that value and is returned
+5 ;
+6 Begin DoDot:1
+7 IF $LENGTH($GET(TO))
SET POS("CHAR")=TO
+8 IF $GET(INC)
SET POS("CHAR")=POS("CHAR")+INC
End DoDot:1
+9 ;
+10 IF $GET(POS("CHAR"))>$LENGTH($GET(@MSG@($$LINE)))
SET POS("CHAR")=$LENGTH($GET(@MSG@($$LINE)))
+11 IF $GET(POS("CHAR"))<1
SET POS("CHAR")=1
+12 QUIT +$GET(POS("CHAR"))
Y(LINE) ;screen line of msg line = LINE
+1 ;LINE defaults to $$LINE
+2 IF $DATA(LINE)
QUIT (LINE-$$TOP)+1
+3 QUIT ($$LINE-$$TOP)+1
SEG(INC) ;returns the current segement #
+1 ;if INC is passed in, the segment # is first incremented/decremented by INC, then the new value is returned
+2 ;returns the new current segment
+3 SET POS("SEG")=$GET(POS("SEG"))+$GET(INC)
+4 QUIT POS("SEG")
FLD(SET) ;returns the currrent field #
+1 ;Input:
+2 ; SET:
+3 ; if "+" increments the field #
+4 ; if "-" decrements the field #
+5 ; if SET>0 sets the field # to SET
+6 if $DATA(SET)
Begin DoDot:1
+7 IF $EXTRACT(SET)="+"
SET POS("FLD")=$GET(POS("FLD"))+1
QUIT
+8 IF $EXTRACT(SET)="-"
SET POS("FLD")=$GET(POS("FLD"))-1
QUIT
+9 SET POS("FLD")=SET
End DoDot:1
+10 QUIT $GET(POS("FLD"))
REP(SET) ;returns the current repitition #
+1 ;Input:
+2 ; SET:
+3 ; if "+" increments the repitition #
+4 ; if "-" decrements the repitition #
+5 ; if >0 sets the repitition # to SET
+6 if $DATA(SET)
Begin DoDot:1
+7 IF $EXTRACT(SET)="+"
SET POS("REP")=$GET(POS("REP"))+1
QUIT
+8 IF $EXTRACT(SET)="-"
SET POS("REP")=POS("REP")-1
QUIT
+9 SET POS("REP")=SET
End DoDot:1
+10 IF $DATA(SET)
if '($GET(LASTPART($$FLD))>POS("REP"))
SET LASTPART($$FLD)=POS("REP")
+11 QUIT +$GET(POS("REP"))
COMP(SET) ;returns the current component #
+1 ;Input:
+2 ; SET:
+3 ; if "+" increments the component #
+4 ; if "-" decrements the component #
+5 ; if >0 sets the component # to SET
+6 if $DATA(SET)
Begin DoDot:1
+7 IF $EXTRACT(SET)="+"
SET POS("COMP")=$GET(POS("COMP"))+1
QUIT
+8 IF $EXTRACT(SET)="-"
SET POS("COMP")=POS("COMP")-1
QUIT
+9 SET POS("COMP")=SET
End DoDot:1
+10 IF $DATA(SET)
if '($GET(LASTPART($$FLD,$$REP))>POS("COMP"))
SET LASTPART($$FLD,$$REP)=POS("COMP")
+11 QUIT +$GET(POS("COMP"))
+12 ;
SUB(SET) ;returns the current sub-component #
+1 ;Input:
+2 ; SET:
+3 ; if "+" increments the subcomponent #
+4 ; if "-" decrements the subcomponent #
+5 ; if >0 sets the sub-component # to SET
+6 if $DATA(SET)
Begin DoDot:1
+7 IF $EXTRACT(SET)="+"
SET POS("SUB")=$GET(POS("SUB"))+1
QUIT
+8 IF $EXTRACT(SET)="-"
SET POS("SUB")=POS("SUB")-1
QUIT
+9 SET POS("SUB")=SET
End DoDot:1
+10 IF $DATA(SET)
if '($GET(LASTPART($$FLD,$$REP,$$COMP))>POS("SUB"))
SET LASTPART($$FLD,$$REP,$$COMP)=POS("SUB")
+11 QUIT +$GET(POS("SUB"))
+12 ;
SEGSTART(SEGMENT) ;
+1 QUIT $GET(SEG(SEGMENT))
+2 ;
IOXY(Y,X) ; moves to screen position line=Y, col=X
+1 ;convert to (0,0) origin
+2 IF $GET(X)
IF X=+X
SET X=X-1
+3 IF $GET(Y)
IF Y=+Y
SET Y=Y-1
+4 ;
+5 DO IOXY^XGF($GET(Y),$GET(X))
+6 QUIT
