HLOPRSR2 ;ALB/CJM - Visual Parser 12 JUN 1997 10:00 am ;08/17/2009
;;1.6;HEALTH LEVEL SEVEN;**138,139,146**;Oct 13, 1995;Build 16
;Per VHA Directive 2004-038, this routine should not be modified.
;
;
WRITELN(LINE,Y) ;writes one line to the screen
D WRITELN^HLOPRSR1(.LINE,.Y)
Q
;
RIGHT ;
N CHAR,LINE,QUIT
K VALUE
S (QUIT,VALUE)=""
;
;header segments are a special case
I ((SEGTYPE="MSH")!(SEGTYPE="BHS")),(+POS("CURRENT DELIMITER")=$$SEGSTART($$SEG)),$P(POS("CURRENT DELIMITER"),"^",2)=0 D G GORIGHT
.S POS("CURRENT DELIMITER")=$$LINE_"^4"
.S POS("NEXT DELIMITER")=$$LINE_"^"_($F($G(@MSG@($$LINE)),FLD,5)-1)
.S VALUE=FLD_$P($G(@MSG@($$LINE)),FLD,2)
.S VALUE("START")=$$LINE_"^4"
.S VALUE("END")=$$LINE_"^"_($L(VALUE)+3)
.I $$X(4),$$FLD(2),$$REP(1),$$COMP(1),$$SUB(1)
.S LASTPART(1)=1,LASTPART(1,1)=1,LASTPART(1,1,1)=1
.S LASTPART(2)=1,LASTPART(2,1)=1,LASTPART(2,1,1)=1
.;
;
S POS("CURRENT DELIMITER")=POS("NEXT DELIMITER")
I '(+POS("CURRENT DELIMITER"))!'$P(POS("CURRENT DELIMITER"),"^",2) D DOWN Q ;at segment end so go to next segment
;
I $$LINE(+POS("CURRENT DELIMITER")),$$X($P(POS("CURRENT DELIMITER"),"^",2)) ;set current position to current delimiter
;
S CHAR=$$GETCHAR
D ;what is the next position in the segment?
.I CHAR=FLD D Q
..I $$FLD("+"),$$REP(1),$$COMP(1),$$SUB(1)
.I CHAR=REP D Q
..I $$REP("+"),$$COMP(1),$$SUB(1)
.I CHAR=COMP D Q
..I $$COMP("+"),$$SUB(1)
.I CHAR=SUB D Q
..I $$SUB("+")
;
F S CHAR=$$GETCHAR("+") D Q:QUIT
.I $L(CHAR),DELIM[CHAR S POS("NEXT DELIMITER")=$$LINE_"^"_$$X,QUIT=1 Q
.I '$L(VALUE) S VALUE("START")=$$LINE_"^"_$$X,VALUE("END")=VALUE("START")
.I CHAR="" D Q
..S QUIT=1
..S POS("NEXT DELIMITER")=$$LINE_"^0" ;signals end of segment
.;
.S:$L(VALUE)<512 VALUE=VALUE_CHAR
S VALUE("END")=$$LINE_"^"_$$X
;
GORIGHT ;
;keep the current field in the scrolling region
I $$Y>(IOBM-1) D SCROLL($$Y-(IOBM-1))
;
D DESCRIBE^HLOPRSR3
D HILITE(+$G(VALUE("START")),$P($G(VALUE("START")),"^",2),+$G(VALUE("END")),$P($G(VALUE("END")),"^",2))
Q
LEFT ;
N CHAR,LINE,QUIT
K VALUE
S (QUIT,VALUE)=""
;
S POS("NEXT DELIMITER")=POS("CURRENT DELIMITER")
I $$LINE<2,$$X<2 D UP Q
;
;header segments are a special case
I ((SEGTYPE="MSH")!(SEGTYPE="BHS")),$$LINE=$$SEGSTART($$SEG),$$X<$F($G(@MSG@($$LINE)),FLD,5) D G GOLEFT
.I $$X>4 D
..S POS("CURRENT DELIMITER")=$$LINE_"^4"
..S VALUE=FLD_$P($G(@MSG@($$LINE)),FLD,2)
..S VALUE("START")=$$LINE_"^4"
..S VALUE("END")=$$LINE_"^"_($L(VALUE)+3)
..I $$X(4),$$FLD(2),$$REP(1),$$COMP(1),$$SUB(1)
..S LASTPART(1)=1,LASTPART(1,1)=1,LASTPART(1,1,1)=1
..S LASTPART(2)=1,LASTPART(2,1)=1,LASTPART(2,1,1)=1
.E D
..S VALUE=$P($G(@MSG@($$LINE)),FLD)
..S POS("CURRENT DELIMITER")=$$LINE_"^0"
..S VALUE("START")=$$LINE_"^1"
..S VALUE("END")=$$LINE_"^3"
..I $$X(0),$$FLD(0),$$REP(0),$$COMP(0),$$SUB(0)
.;
;
I '$P(POS("CURRENT DELIMITER"),"^",2) D G GOLEFT ;at segment start so go to end of prior segment
.I $$LINE($$SEGSTART($$SEG(-1))),$$X(1),$$FLD(0),$$COMP(0),$$SUB(0) ;set line to start of prior seg
.K VALUE S VALUE=""
.S SEGTYPE=$E($G(@MSG@($$LINE)),1,3)
.Q:$$LINE<1
.I (SEGTYPE="MSH")!(SEGTYPE="BHS") D
..S VALUE=FLD_$P($G(@MSG@($$LINE)),FLD,2)
..S VALUE("START")=$$LINE_"^4"
..S VALUE("END")=$$LINE_"^"_($L(VALUE)+3)
..I $$X($F($G(@MSG@($$LINE)),FLD,5)-1),$$FLD(3),$$REP(1),$$COMP(1),$$SUB(1) S POS("CURRENT DELIMITER")=$$X
..S LASTPART(1)=1,LASTPART(1,1)=1,LASTPART(1,1,1)=1
..S LASTPART(2)=1,LASTPART(2,1)=1,LASTPART(2,1,1)=1
.E D
..S POS("CURRENT DELIMITER")=$$LINE_"^0"
..S POS("NEXT DELIMITER")=$$LINE_"^0"
..S VALUE=SEGTYPE,VALUE("START")=$$LINE_"^1",VALUE("END")=$$LINE_"^3"
.F S CHAR=$$GETCHAR("+") Q:CHAR="" D
..I DELIM[CHAR D Q
...S POS("CURRENT DELIMITER")=$$LINE_"^"_$$X
...K VALUE S VALUE=""
...I CHAR=FLD,$$FLD("+"),$$REP(1),$$COMP(1),$$SUB(1) Q
...I CHAR=REP,$$REP("+"),$$COMP(1),$$SUB(1) Q
...I CHAR=COMP,$$COMP("+"),$$SUB(1) Q
...I CHAR=SUB,$$SUB("+") Q
..E D
...S:$L(VALUE)<512 VALUE=VALUE_CHAR
...I $L(VALUE)=1 S VALUE("START")=$$LINE_"^"_$$X
...S VALUE("END")=$$LINE_"^"_$$X
;
I $$LINE(+POS("CURRENT DELIMITER")),$$X($P(POS("CURRENT DELIMITER"),"^",2)) ;set current position to current delimiter
;
;
S CHAR=$$GETCHAR
D ;what is the next position in the segment?
.I CHAR=FLD D Q
..I $$FLD("-"),$$REP(LASTPART($$FLD)),$$COMP(LASTPART($$FLD,$$REP)),$$SUB(LASTPART($$FLD,$$REP,$$COMP))
.I CHAR=REP D Q
..I $$REP("-"),$$COMP(LASTPART($$FLD,$$REP)),$$SUB(LASTPART($$FLD,$$REP,$$COMP))
.I CHAR=COMP D Q
..I $$COMP("-"),$$SUB(LASTPART($$FLD,$$REP,$$COMP))
.I CHAR=SUB D Q
..I $$SUB("-")
;
F S CHAR=$$GETCHAR("-") D Q:QUIT
.I $L(CHAR),DELIM[CHAR S POS("CURRENT DELIMITER")=$$LINE_"^"_$$X,QUIT=1 D Q
.I CHAR="" D
..S QUIT=1
..I VALUE="" D UP Q
..S POS("CURRENT DELIMITER")=$$LINE_"^0" ;signals end of segment
.;
.S:$L(VALUE)<512 VALUE=CHAR_VALUE
.I $L(VALUE)=1 S VALUE("END")=$$LINE_"^"_$$X
.S VALUE("START")=$$LINE_"^"_$$X
;
GOLEFT ;
;keep the current field in the scrolling region
I $$Y<(IOTM) D SCROLL($$Y-IOTM)
;
D DESCRIBE^HLOPRSR3
D HILITE(+$G(VALUE("START")),$P($G(VALUE("START")),"^",2),+$G(VALUE("END")),$P($G(VALUE("END")),"^",2))
Q
;
MSGSIZE() ;
Q $$MSGSIZE^HLOPRSR1
SCRNSIZE() ;
Q $$SCRNSIZE^HLOPRSR1
TOP(INC) ;msg line at the top of the scrolling area
Q $$TOP^HLOPRSR1(.INC)
LINE(TO,INC) ;msg line
Q $$LINE^HLOPRSR1(.TO,.INC)
;
X(TO,INC) ;current position within the line
;
Q $$X^HLOPRSR1(.TO,.INC)
Y(LINE) ;screen line of msg line = LINE
Q $$Y^HLOPRSR1(.LINE)
SEG(INC) ;returns the current segement #
Q $$SEG^HLOPRSR1(.INC)
FLD(SET) ;returns the currrent field #
Q $$FLD^HLOPRSR1(.SET)
REP(SET) ;returns the current repitition #
Q $$REP^HLOPRSR1(.SET)
COMP(SET) ;returns the current component #
Q $$COMP^HLOPRSR1(.SET)
;
SUB(SET) ;returns the current sub-component #
Q $$SUB^HLOPRSR1(.SET)
;
SEGSTART(SEGMENT) ;
Q $$SEGSTART^HLOPRSR1(.SEGMENT)
;
IOXY(Y,X) ; moves to screen position line=Y, col=X
D IOXY^HLOPRSR1(.Y,.X)
Q
HILITE(LINE1,CHAR1,LINE2,CHAR2) ;does hightlighting
;LINE1: starting line
;CHAR1: starting character
;LINE2: ending line
;CHAR2: ending character
;
N X
I $G(HILITE) D UNLITE
I LINE1>0,CHAR1>0,LINE2>0,CHAR2>0 D
.W IORVON
.S HILITE=LINE1_"^"_CHAR1_"^"_LINE2_"^"_CHAR2
.D LITE
W IORVOFF
S X=$P(POS("CURRENT DELIMITER"),"^",2)
;
;
;move curson to the delimiter, and write in bold
D IOXY($$Y($$LINE(+POS("CURRENT DELIMITER"))),$$X(X))
;
;
I X D
.W IOINHI
.W $$GETCHAR
.W IOINORM
.D IOXY($$Y,$$X)
W IOCUON
Q
;
LITE N LINE
F LINE=LINE1:1:LINE2 D
.I '($$Y(LINE)>IOBM),'($$Y(LINE)<IOTM) D
..D IOXY($$Y(LINE),$S(LINE=LINE1:CHAR1,1:1))
..W $E($G(@MSG@(LINE)),$S(LINE=LINE1:CHAR1,1:1),$S(LINE=LINE2:CHAR2,1:80))
Q
;
UNLITE ;
N LINE1,CHAR1,LINE2,CHAR2
W IORVOFF
Q:$G(HILITE)=""
S LINE1=$P(HILITE,"^"),CHAR1=$P(HILITE,"^",2),LINE2=$P(HILITE,"^",3),CHAR2=$P(HILITE,"^",4)
K HILITE
I $G(SEGLINE(LINE2)),CHAR1=1 W IOINHI
D LITE
I $G(SEGLINE(LINE2)),CHAR1=1 W IOINORM
Q
;
DOWN ;
N I
K LASTPART
S SEGTYPE=""
I $$SEGSTART($$SEG("+1")) D
.I $$LINE($$SEGSTART($$SEG))
E D
.I $$LINE(,1)>0,$$LINE<$$MSGSIZE,$$LINE($$MSGSIZE+1)
F I="FLD","REP","COMP","SUB" S POS(I)=0
I '($$Y>IOBM) D
.D IOXY($$Y,1)
E D
.D SCROLL($$Y-IOBM)
S SEGTYPE=$E($G(@MSG@($$LINE)),1,3)
S POS("CURRENT DELIMITER")=$$LINE_"^0"
S POS("NEXT DELIMITER")=$$LINE_"^"_$S($$SEGSTART($$SEG):4,1:0)
D DESCRIBE^HLOPRSR3
D HILITE($$LINE,$$X,$$LINE,($$X+2))
Q
;
UP ;
N I
K LASTPART
S SEGTYPE=""
I $$SEGSTART($$SEG("-1")) D
.I $$LINE($$SEGSTART($$SEG))
E D
.I $$LINE(,-1)>0,$$LINE<$$MSGSIZE,$$LINE(0) ;set line to 0
F I="FLD","REP","COMP","SUB" S POS(I)=0
I '($$Y<IOTM) D
.D IOXY($$Y,1)
E D
.D SCROLL($$Y-IOTM)
S SEGTYPE=$E($G(@MSG@($$LINE)),1,3)
S POS("CURRENT DELIMITER")=$$LINE_"^0"
S POS("NEXT DELIMITER")=$$LINE_"^"_$S($$SEGSTART($$SEG):4,1:0)
D DESCRIBE^HLOPRSR3
D HILITE($$LINE,$$X,$$LINE,($$X+2))
Q
;
SCROLL(COUNT) ; Scrolls up (COUNT positive) or down (COUNT negative)
;
N I
I COUNT>0 D
.D IOXY(IOBM,1)
.F I=1:1:COUNT D
..W IOIND
..I $$TOP(1)
..W $G(@MSG@($$BOT^HLOPRSR1))
..D IOXY(IOBM,1)
.I $$LINE($$BOT^HLOPRSR1)
.S POS("CHAR")=1
.;
I COUNT<0 D
.D IOXY(1,1)
.F I=-1:-1:COUNT D
..W IORI
..W $G(@MSG@($$TOP(-1)))
..D IOXY(1,1)
.S POS("CHAR")=1
Q
GETCHAR(INC) ;returns a message character, can go forward or backward but will not cross the segment boundary.
;INC:
; not defined - assumes the current position
; "+" - the next character. May change $$X and $$LINE
; "-" - the prior character. May change $$X and $$LINE
;
N END,TMP
S END=0
S TMP("LINE")=$$LINE
S TMP("X")=$$X
I $E($G(INC))="+" D
.I '($$X<80) D ;get char from next line
..;** P139 START CJM
..I ('$$SEGSTART($$SEG+1))!(($$LINE+1)<$$SEGSTART($$SEG+1)),$$LINE(,1),$$X(1)
..;** P139 END
.E D
..I $$X=$$X(,1) S END=1
E I $E($G(INC))="-" D
.I '($$X()>1) D ;get char from prior line
..I $$SEGSTART($$SEG)<$$LINE D
...I $$LINE(,-1),$$X($L($G(@MSG@($$LINE))))
..E D
...S END=1
.E D
..I $$X=$$X(,-1) S END=1
;** P146 START CJM
;
;This line was added in patch 139. It is incorrect!
;I TMP("LINE")=$$LINE,TMP("X")=$$X S END=1
;
;This is the corrected line.
I $L($G(INC)),TMP("LINE")=$$LINE,TMP("X")=$$X S END=1
;**P146 END
;
Q:END ""
Q $E($G(@MSG@($$LINE)),$$X)
;
LJ(STRING,LENGTH) ;
Q $$LJ^XLFSTR(STRING,LENGTH)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLOPRSR2 9666 printed Jan 18, 2025@03:00:18 Page 2
HLOPRSR2 ;ALB/CJM - Visual Parser 12 JUN 1997 10:00 am ;08/17/2009
+1 ;;1.6;HEALTH LEVEL SEVEN;**138,139,146**;Oct 13, 1995;Build 16
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
WRITELN(LINE,Y) ;writes one line to the screen
+1 DO WRITELN^HLOPRSR1(.LINE,.Y)
+2 QUIT
+3 ;
RIGHT ;
+1 NEW CHAR,LINE,QUIT
+2 KILL VALUE
+3 SET (QUIT,VALUE)=""
+4 ;
+5 ;header segments are a special case
+6 IF ((SEGTYPE="MSH")!(SEGTYPE="BHS"))
IF (+POS("CURRENT DELIMITER")=$$SEGSTART($$SEG))
IF $PIECE(POS("CURRENT DELIMITER"),"^",2)=0
Begin DoDot:1
+7 SET POS("CURRENT DELIMITER")=$$LINE_"^4"
+8 SET POS("NEXT DELIMITER")=$$LINE_"^"_($FIND($GET(@MSG@($$LINE)),FLD,5)-1)
+9 SET VALUE=FLD_$PIECE($GET(@MSG@($$LINE)),FLD,2)
+10 SET VALUE("START")=$$LINE_"^4"
+11 SET VALUE("END")=$$LINE_"^"_($LENGTH(VALUE)+3)
+12 IF $$X(4)
IF $$FLD(2)
IF $$REP(1)
IF $$COMP(1)
IF $$SUB(1)
+13 SET LASTPART(1)=1
SET LASTPART(1,1)=1
SET LASTPART(1,1,1)=1
+14 SET LASTPART(2)=1
SET LASTPART(2,1)=1
SET LASTPART(2,1,1)=1
+15 ;
End DoDot:1
GOTO GORIGHT
+16 ;
+17 SET POS("CURRENT DELIMITER")=POS("NEXT DELIMITER")
+18 ;at segment end so go to next segment
IF '(+POS("CURRENT DELIMITER"))!'$PIECE(POS("CURRENT DELIMITER"),"^",2)
DO DOWN
QUIT
+19 ;
+20 ;set current position to current delimiter
IF $$LINE(+POS("CURRENT DELIMITER"))
IF $$X($PIECE(POS("CURRENT DELIMITER"),"^",2))
+21 ;
+22 SET CHAR=$$GETCHAR
+23 ;what is the next position in the segment?
Begin DoDot:1
+24 IF CHAR=FLD
Begin DoDot:2
+25 IF $$FLD("+")
IF $$REP(1)
IF $$COMP(1)
IF $$SUB(1)
End DoDot:2
QUIT
+26 IF CHAR=REP
Begin DoDot:2
+27 IF $$REP("+")
IF $$COMP(1)
IF $$SUB(1)
End DoDot:2
QUIT
+28 IF CHAR=COMP
Begin DoDot:2
+29 IF $$COMP("+")
IF $$SUB(1)
End DoDot:2
QUIT
+30 IF CHAR=SUB
Begin DoDot:2
+31 IF $$SUB("+")
End DoDot:2
QUIT
End DoDot:1
+32 ;
+33 FOR
SET CHAR=$$GETCHAR("+")
Begin DoDot:1
+34 IF $LENGTH(CHAR)
IF DELIM[CHAR
SET POS("NEXT DELIMITER")=$$LINE_"^"_$$X
SET QUIT=1
QUIT
+35 IF '$LENGTH(VALUE)
SET VALUE("START")=$$LINE_"^"_$$X
SET VALUE("END")=VALUE("START")
+36 IF CHAR=""
Begin DoDot:2
+37 SET QUIT=1
+38 ;signals end of segment
SET POS("NEXT DELIMITER")=$$LINE_"^0"
End DoDot:2
QUIT
+39 ;
+40 if $LENGTH(VALUE)<512
SET VALUE=VALUE_CHAR
End DoDot:1
if QUIT
QUIT
+41 SET VALUE("END")=$$LINE_"^"_$$X
+42 ;
GORIGHT ;
+1 ;keep the current field in the scrolling region
+2 IF $$Y>(IOBM-1)
DO SCROLL($$Y-(IOBM-1))
+3 ;
+4 DO DESCRIBE^HLOPRSR3
+5 DO HILITE(+$GET(VALUE("START")),$PIECE($GET(VALUE("START")),"^",2),+$GET(VALUE("END")),$PIECE($GET(VALUE("END")),"^",2))
+6 QUIT
LEFT ;
+1 NEW CHAR,LINE,QUIT
+2 KILL VALUE
+3 SET (QUIT,VALUE)=""
+4 ;
+5 SET POS("NEXT DELIMITER")=POS("CURRENT DELIMITER")
+6 IF $$LINE<2
IF $$X<2
DO UP
QUIT
+7 ;
+8 ;header segments are a special case
+9 IF ((SEGTYPE="MSH")!(SEGTYPE="BHS"))
IF $$LINE=$$SEGSTART($$SEG)
IF $$X<$F($GET(@MSG@($$LINE)),FLD,5)
Begin DoDot:1
+10 IF $$X>4
Begin DoDot:2
+11 SET POS("CURRENT DELIMITER")=$$LINE_"^4"
+12 SET VALUE=FLD_$PIECE($GET(@MSG@($$LINE)),FLD,2)
+13 SET VALUE("START")=$$LINE_"^4"
+14 SET VALUE("END")=$$LINE_"^"_($LENGTH(VALUE)+3)
+15 IF $$X(4)
IF $$FLD(2)
IF $$REP(1)
IF $$COMP(1)
IF $$SUB(1)
+16 SET LASTPART(1)=1
SET LASTPART(1,1)=1
SET LASTPART(1,1,1)=1
+17 SET LASTPART(2)=1
SET LASTPART(2,1)=1
SET LASTPART(2,1,1)=1
End DoDot:2
+18 IF '$TEST
Begin DoDot:2
+19 SET VALUE=$PIECE($GET(@MSG@($$LINE)),FLD)
+20 SET POS("CURRENT DELIMITER")=$$LINE_"^0"
+21 SET VALUE("START")=$$LINE_"^1"
+22 SET VALUE("END")=$$LINE_"^3"
+23 IF $$X(0)
IF $$FLD(0)
IF $$REP(0)
IF $$COMP(0)
IF $$SUB(0)
End DoDot:2
+24 ;
End DoDot:1
GOTO GOLEFT
+25 ;
+26 ;at segment start so go to end of prior segment
IF '$PIECE(POS("CURRENT DELIMITER"),"^",2)
Begin DoDot:1
+27 ;set line to start of prior seg
IF $$LINE($$SEGSTART($$SEG(-1)))
IF $$X(1)
IF $$FLD(0)
IF $$COMP(0)
IF $$SUB(0)
+28 KILL VALUE
SET VALUE=""
+29 SET SEGTYPE=$EXTRACT($GET(@MSG@($$LINE)),1,3)
+30 if $$LINE<1
QUIT
+31 IF (SEGTYPE="MSH")!(SEGTYPE="BHS")
Begin DoDot:2
+32 SET VALUE=FLD_$PIECE($GET(@MSG@($$LINE)),FLD,2)
+33 SET VALUE("START")=$$LINE_"^4"
+34 SET VALUE("END")=$$LINE_"^"_($LENGTH(VALUE)+3)
+35 IF $$X($FIND($GET(@MSG@($$LINE)),FLD,5)-1)
IF $$FLD(3)
IF $$REP(1)
IF $$COMP(1)
IF $$SUB(1)
SET POS("CURRENT DELIMITER")=$$X
+36 SET LASTPART(1)=1
SET LASTPART(1,1)=1
SET LASTPART(1,1,1)=1
+37 SET LASTPART(2)=1
SET LASTPART(2,1)=1
SET LASTPART(2,1,1)=1
End DoDot:2
+38 IF '$TEST
Begin DoDot:2
+39 SET POS("CURRENT DELIMITER")=$$LINE_"^0"
+40 SET POS("NEXT DELIMITER")=$$LINE_"^0"
+41 SET VALUE=SEGTYPE
SET VALUE("START")=$$LINE_"^1"
SET VALUE("END")=$$LINE_"^3"
End DoDot:2
+42 FOR
SET CHAR=$$GETCHAR("+")
if CHAR=""
QUIT
Begin DoDot:2
+43 IF DELIM[CHAR
Begin DoDot:3
+44 SET POS("CURRENT DELIMITER")=$$LINE_"^"_$$X
+45 KILL VALUE
SET VALUE=""
+46 IF CHAR=FLD
IF $$FLD("+")
IF $$REP(1)
IF $$COMP(1)
IF $$SUB(1)
QUIT
+47 IF CHAR=REP
IF $$REP("+")
IF $$COMP(1)
IF $$SUB(1)
QUIT
+48 IF CHAR=COMP
IF $$COMP("+")
IF $$SUB(1)
QUIT
+49 IF CHAR=SUB
IF $$SUB("+")
QUIT
End DoDot:3
QUIT
+50 IF '$TEST
Begin DoDot:3
+51 if $LENGTH(VALUE)<512
SET VALUE=VALUE_CHAR
+52 IF $LENGTH(VALUE)=1
SET VALUE("START")=$$LINE_"^"_$$X
+53 SET VALUE("END")=$$LINE_"^"_$$X
End DoDot:3
End DoDot:2
End DoDot:1
GOTO GOLEFT
+54 ;
+55 ;set current position to current delimiter
IF $$LINE(+POS("CURRENT DELIMITER"))
IF $$X($PIECE(POS("CURRENT DELIMITER"),"^",2))
+56 ;
+57 ;
+58 SET CHAR=$$GETCHAR
+59 ;what is the next position in the segment?
Begin DoDot:1
+60 IF CHAR=FLD
Begin DoDot:2
+61 IF $$FLD("-")
IF $$REP(LASTPART($$FLD))
IF $$COMP(LASTPART($$FLD,$$REP))
IF $$SUB(LASTPART($$FLD,$$REP,$$COMP))
End DoDot:2
QUIT
+62 IF CHAR=REP
Begin DoDot:2
+63 IF $$REP("-")
IF $$COMP(LASTPART($$FLD,$$REP))
IF $$SUB(LASTPART($$FLD,$$REP,$$COMP))
End DoDot:2
QUIT
+64 IF CHAR=COMP
Begin DoDot:2
+65 IF $$COMP("-")
IF $$SUB(LASTPART($$FLD,$$REP,$$COMP))
End DoDot:2
QUIT
+66 IF CHAR=SUB
Begin DoDot:2
+67 IF $$SUB("-")
End DoDot:2
QUIT
End DoDot:1
+68 ;
+69 FOR
SET CHAR=$$GETCHAR("-")
Begin DoDot:1
+70 IF $LENGTH(CHAR)
IF DELIM[CHAR
SET POS("CURRENT DELIMITER")=$$LINE_"^"_$$X
SET QUIT=1
Begin DoDot:2
End DoDot:2
QUIT
+71 IF CHAR=""
Begin DoDot:2
+72 SET QUIT=1
+73 IF VALUE=""
DO UP
QUIT
+74 ;signals end of segment
SET POS("CURRENT DELIMITER")=$$LINE_"^0"
End DoDot:2
+75 ;
+76 if $LENGTH(VALUE)<512
SET VALUE=CHAR_VALUE
+77 IF $LENGTH(VALUE)=1
SET VALUE("END")=$$LINE_"^"_$$X
+78 SET VALUE("START")=$$LINE_"^"_$$X
End DoDot:1
if QUIT
QUIT
+79 ;
GOLEFT ;
+1 ;keep the current field in the scrolling region
+2 IF $$Y<(IOTM)
DO SCROLL($$Y-IOTM)
+3 ;
+4 DO DESCRIBE^HLOPRSR3
+5 DO HILITE(+$GET(VALUE("START")),$PIECE($GET(VALUE("START")),"^",2),+$GET(VALUE("END")),$PIECE($GET(VALUE("END")),"^",2))
+6 QUIT
+7 ;
MSGSIZE() ;
+1 QUIT $$MSGSIZE^HLOPRSR1
SCRNSIZE() ;
+1 QUIT $$SCRNSIZE^HLOPRSR1
TOP(INC) ;msg line at the top of the scrolling area
+1 QUIT $$TOP^HLOPRSR1(.INC)
LINE(TO,INC) ;msg line
+1 QUIT $$LINE^HLOPRSR1(.TO,.INC)
+2 ;
X(TO,INC) ;current position within the line
+1 ;
+2 QUIT $$X^HLOPRSR1(.TO,.INC)
Y(LINE) ;screen line of msg line = LINE
+1 QUIT $$Y^HLOPRSR1(.LINE)
SEG(INC) ;returns the current segement #
+1 QUIT $$SEG^HLOPRSR1(.INC)
FLD(SET) ;returns the currrent field #
+1 QUIT $$FLD^HLOPRSR1(.SET)
REP(SET) ;returns the current repitition #
+1 QUIT $$REP^HLOPRSR1(.SET)
COMP(SET) ;returns the current component #
+1 QUIT $$COMP^HLOPRSR1(.SET)
+2 ;
SUB(SET) ;returns the current sub-component #
+1 QUIT $$SUB^HLOPRSR1(.SET)
+2 ;
SEGSTART(SEGMENT) ;
+1 QUIT $$SEGSTART^HLOPRSR1(.SEGMENT)
+2 ;
IOXY(Y,X) ; moves to screen position line=Y, col=X
+1 DO IOXY^HLOPRSR1(.Y,.X)
+2 QUIT
HILITE(LINE1,CHAR1,LINE2,CHAR2) ;does hightlighting
+1 ;LINE1: starting line
+2 ;CHAR1: starting character
+3 ;LINE2: ending line
+4 ;CHAR2: ending character
+5 ;
+6 NEW X
+7 IF $GET(HILITE)
DO UNLITE
+8 IF LINE1>0
IF CHAR1>0
IF LINE2>0
IF CHAR2>0
Begin DoDot:1
+9 WRITE IORVON
+10 SET HILITE=LINE1_"^"_CHAR1_"^"_LINE2_"^"_CHAR2
+11 DO LITE
End DoDot:1
+12 WRITE IORVOFF
+13 SET X=$PIECE(POS("CURRENT DELIMITER"),"^",2)
+14 ;
+15 ;
+16 ;move curson to the delimiter, and write in bold
+17 DO IOXY($$Y($$LINE(+POS("CURRENT DELIMITER"))),$$X(X))
+18 ;
+19 ;
+20 IF X
Begin DoDot:1
+21 WRITE IOINHI
+22 WRITE $$GETCHAR
+23 WRITE IOINORM
+24 DO IOXY($$Y,$$X)
End DoDot:1
+25 WRITE IOCUON
+26 QUIT
+27 ;
LITE NEW LINE
+1 FOR LINE=LINE1:1:LINE2
Begin DoDot:1
+2 IF '($$Y(LINE)>IOBM)
IF '($$Y(LINE)<IOTM)
Begin DoDot:2
+3 DO IOXY($$Y(LINE),$SELECT(LINE=LINE1:CHAR1,1:1))
+4 WRITE $EXTRACT($GET(@MSG@(LINE)),$SELECT(LINE=LINE1:CHAR1,1:1),$SELECT(LINE=LINE2:CHAR2,1:80))
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
UNLITE ;
+1 NEW LINE1,CHAR1,LINE2,CHAR2
+2 WRITE IORVOFF
+3 if $GET(HILITE)=""
QUIT
+4 SET LINE1=$PIECE(HILITE,"^")
SET CHAR1=$PIECE(HILITE,"^",2)
SET LINE2=$PIECE(HILITE,"^",3)
SET CHAR2=$PIECE(HILITE,"^",4)
+5 KILL HILITE
+6 IF $GET(SEGLINE(LINE2))
IF CHAR1=1
WRITE IOINHI
+7 DO LITE
+8 IF $GET(SEGLINE(LINE2))
IF CHAR1=1
WRITE IOINORM
+9 QUIT
+10 ;
DOWN ;
+1 NEW I
+2 KILL LASTPART
+3 SET SEGTYPE=""
+4 IF $$SEGSTART($$SEG("+1"))
Begin DoDot:1
+5 IF $$LINE($$SEGSTART($$SEG))
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 IF $$LINE(,1)>0
IF $$LINE<$$MSGSIZE
IF $$LINE($$MSGSIZE+1)
End DoDot:1
+8 FOR I="FLD","REP","COMP","SUB"
SET POS(I)=0
+9 IF '($$Y>IOBM)
Begin DoDot:1
+10 DO IOXY($$Y,1)
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 DO SCROLL($$Y-IOBM)
End DoDot:1
+13 SET SEGTYPE=$EXTRACT($GET(@MSG@($$LINE)),1,3)
+14 SET POS("CURRENT DELIMITER")=$$LINE_"^0"
+15 SET POS("NEXT DELIMITER")=$$LINE_"^"_$S($$SEGSTART($$SEG):4,1:0)
+16 DO DESCRIBE^HLOPRSR3
+17 DO HILITE($$LINE,$$X,$$LINE,($$X+2))
+18 QUIT
+19 ;
UP ;
+1 NEW I
+2 KILL LASTPART
+3 SET SEGTYPE=""
+4 IF $$SEGSTART($$SEG("-1"))
Begin DoDot:1
+5 IF $$LINE($$SEGSTART($$SEG))
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 ;set line to 0
IF $$LINE(,-1)>0
IF $$LINE<$$MSGSIZE
IF $$LINE(0)
End DoDot:1
+8 FOR I="FLD","REP","COMP","SUB"
SET POS(I)=0
+9 IF '($$Y<IOTM)
Begin DoDot:1
+10 DO IOXY($$Y,1)
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 DO SCROLL($$Y-IOTM)
End DoDot:1
+13 SET SEGTYPE=$EXTRACT($GET(@MSG@($$LINE)),1,3)
+14 SET POS("CURRENT DELIMITER")=$$LINE_"^0"
+15 SET POS("NEXT DELIMITER")=$$LINE_"^"_$S($$SEGSTART($$SEG):4,1:0)
+16 DO DESCRIBE^HLOPRSR3
+17 DO HILITE($$LINE,$$X,$$LINE,($$X+2))
+18 QUIT
+19 ;
SCROLL(COUNT) ; Scrolls up (COUNT positive) or down (COUNT negative)
+1 ;
+2 NEW I
+3 IF COUNT>0
Begin DoDot:1
+4 DO IOXY(IOBM,1)
+5 FOR I=1:1:COUNT
Begin DoDot:2
+6 WRITE IOIND
+7 IF $$TOP(1)
+8 WRITE $GET(@MSG@($$BOT^HLOPRSR1))
+9 DO IOXY(IOBM,1)
End DoDot:2
+10 IF $$LINE($$BOT^HLOPRSR1)
+11 SET POS("CHAR")=1
+12 ;
End DoDot:1
+13 IF COUNT<0
Begin DoDot:1
+14 DO IOXY(1,1)
+15 FOR I=-1:-1:COUNT
Begin DoDot:2
+16 WRITE IORI
+17 WRITE $GET(@MSG@($$TOP(-1)))
+18 DO IOXY(1,1)
End DoDot:2
+19 SET POS("CHAR")=1
End DoDot:1
+20 QUIT
GETCHAR(INC) ;returns a message character, can go forward or backward but will not cross the segment boundary.
+1 ;INC:
+2 ; not defined - assumes the current position
+3 ; "+" - the next character. May change $$X and $$LINE
+4 ; "-" - the prior character. May change $$X and $$LINE
+5 ;
+6 NEW END,TMP
+7 SET END=0
+8 SET TMP("LINE")=$$LINE
+9 SET TMP("X")=$$X
+10 IF $EXTRACT($GET(INC))="+"
Begin DoDot:1
+11 ;get char from next line
IF '($$X<80)
Begin DoDot:2
+12 ;** P139 START CJM
+13 IF ('$$SEGSTART($$SEG+1))!(($$LINE+1)<$$SEGSTART($$SEG+1))
IF $$LINE(,1)
IF $$X(1)
+14 ;** P139 END
End DoDot:2
+15 IF '$TEST
Begin DoDot:2
+16 IF $$X=$$X(,1)
SET END=1
End DoDot:2
End DoDot:1
+17 IF '$TEST
IF $EXTRACT($GET(INC))="-"
Begin DoDot:1
+18 ;get char from prior line
IF '($$X()>1)
Begin DoDot:2
+19 IF $$SEGSTART($$SEG)<$$LINE
Begin DoDot:3
+20 IF $$LINE(,-1)
IF $$X($LENGTH($GET(@MSG@($$LINE))))
End DoDot:3
+21 IF '$TEST
Begin DoDot:3
+22 SET END=1
End DoDot:3
End DoDot:2
+23 IF '$TEST
Begin DoDot:2
+24 IF $$X=$$X(,-1)
SET END=1
End DoDot:2
End DoDot:1
+25 ;** P146 START CJM
+26 ;
+27 ;This line was added in patch 139. It is incorrect!
+28 ;I TMP("LINE")=$$LINE,TMP("X")=$$X S END=1
+29 ;
+30 ;This is the corrected line.
+31 IF $LENGTH($GET(INC))
IF TMP("LINE")=$$LINE
IF TMP("X")=$$X
SET END=1
+32 ;**P146 END
+33 ;
+34 if END
QUIT ""
+35 QUIT $EXTRACT($GET(@MSG@($$LINE)),$$X)
+36 ;
LJ(STRING,LENGTH) ;
+1 QUIT $$LJ^XLFSTR(STRING,LENGTH)
