- 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)