Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HLOPRSR2

HLOPRSR2.m

Go to the documentation of this file.
  1. 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
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;
  1. WRITELN(LINE,Y) ;writes one line to the screen
  1. D WRITELN^HLOPRSR1(.LINE,.Y)
  1. Q
  1. ;
  1. N CHAR,LINE,QUIT
  1. K VALUE
  1. S (QUIT,VALUE)=""
  1. ;
  1. ;header segments are a special case
  1. I ((SEGTYPE="MSH")!(SEGTYPE="BHS")),(+POS("CURRENT DELIMITER")=$$SEGSTART($$SEG)),$P(POS("CURRENT DELIMITER"),"^",2)=0 D G GORIGHT
  1. .S POS("CURRENT DELIMITER")=$$LINE_"^4"
  1. .S POS("NEXT DELIMITER")=$$LINE_"^"_($F($G(@MSG@($$LINE)),FLD,5)-1)
  1. .S VALUE=FLD_$P($G(@MSG@($$LINE)),FLD,2)
  1. .S VALUE("START")=$$LINE_"^4"
  1. .S VALUE("END")=$$LINE_"^"_($L(VALUE)+3)
  1. .I $$X(4),$$FLD(2),$$REP(1),$$COMP(1),$$SUB(1)
  1. .S LASTPART(1)=1,LASTPART(1,1)=1,LASTPART(1,1,1)=1
  1. .S LASTPART(2)=1,LASTPART(2,1)=1,LASTPART(2,1,1)=1
  1. .;
  1. ;
  1. S POS("CURRENT DELIMITER")=POS("NEXT DELIMITER")
  1. I '(+POS("CURRENT DELIMITER"))!'$P(POS("CURRENT DELIMITER"),"^",2) D DOWN Q ;at segment end so go to next segment
  1. ;
  1. I $$LINE(+POS("CURRENT DELIMITER")),$$X($P(POS("CURRENT DELIMITER"),"^",2)) ;set current position to current delimiter
  1. ;
  1. S CHAR=$$GETCHAR
  1. D ;what is the next position in the segment?
  1. .I CHAR=FLD D Q
  1. ..I $$FLD("+"),$$REP(1),$$COMP(1),$$SUB(1)
  1. .I CHAR=REP D Q
  1. ..I $$REP("+"),$$COMP(1),$$SUB(1)
  1. .I CHAR=COMP D Q
  1. ..I $$COMP("+"),$$SUB(1)
  1. .I CHAR=SUB D Q
  1. ..I $$SUB("+")
  1. ;
  1. F S CHAR=$$GETCHAR("+") D Q:QUIT
  1. .I $L(CHAR),DELIM[CHAR S POS("NEXT DELIMITER")=$$LINE_"^"_$$X,QUIT=1 Q
  1. .I '$L(VALUE) S VALUE("START")=$$LINE_"^"_$$X,VALUE("END")=VALUE("START")
  1. .I CHAR="" D Q
  1. ..S QUIT=1
  1. ..S POS("NEXT DELIMITER")=$$LINE_"^0" ;signals end of segment
  1. .;
  1. .S:$L(VALUE)<512 VALUE=VALUE_CHAR
  1. S VALUE("END")=$$LINE_"^"_$$X
  1. ;
  1. GORIGHT ;
  1. ;keep the current field in the scrolling region
  1. I $$Y>(IOBM-1) D SCROLL($$Y-(IOBM-1))
  1. ;
  1. D DESCRIBE^HLOPRSR3
  1. D HILITE(+$G(VALUE("START")),$P($G(VALUE("START")),"^",2),+$G(VALUE("END")),$P($G(VALUE("END")),"^",2))
  1. Q
  1. LEFT ;
  1. N CHAR,LINE,QUIT
  1. K VALUE
  1. S (QUIT,VALUE)=""
  1. ;
  1. S POS("NEXT DELIMITER")=POS("CURRENT DELIMITER")
  1. I $$LINE<2,$$X<2 D UP Q
  1. ;
  1. ;header segments are a special case
  1. I ((SEGTYPE="MSH")!(SEGTYPE="BHS")),$$LINE=$$SEGSTART($$SEG),$$X<$F($G(@MSG@($$LINE)),FLD,5) D G GOLEFT
  1. .I $$X>4 D
  1. ..S POS("CURRENT DELIMITER")=$$LINE_"^4"
  1. ..S VALUE=FLD_$P($G(@MSG@($$LINE)),FLD,2)
  1. ..S VALUE("START")=$$LINE_"^4"
  1. ..S VALUE("END")=$$LINE_"^"_($L(VALUE)+3)
  1. ..I $$X(4),$$FLD(2),$$REP(1),$$COMP(1),$$SUB(1)
  1. ..S LASTPART(1)=1,LASTPART(1,1)=1,LASTPART(1,1,1)=1
  1. ..S LASTPART(2)=1,LASTPART(2,1)=1,LASTPART(2,1,1)=1
  1. .E D
  1. ..S VALUE=$P($G(@MSG@($$LINE)),FLD)
  1. ..S POS("CURRENT DELIMITER")=$$LINE_"^0"
  1. ..S VALUE("START")=$$LINE_"^1"
  1. ..S VALUE("END")=$$LINE_"^3"
  1. ..I $$X(0),$$FLD(0),$$REP(0),$$COMP(0),$$SUB(0)
  1. .;
  1. ;
  1. I '$P(POS("CURRENT DELIMITER"),"^",2) D G GOLEFT ;at segment start so go to end of prior segment
  1. .I $$LINE($$SEGSTART($$SEG(-1))),$$X(1),$$FLD(0),$$COMP(0),$$SUB(0) ;set line to start of prior seg
  1. .K VALUE S VALUE=""
  1. .S SEGTYPE=$E($G(@MSG@($$LINE)),1,3)
  1. .Q:$$LINE<1
  1. .I (SEGTYPE="MSH")!(SEGTYPE="BHS") D
  1. ..S VALUE=FLD_$P($G(@MSG@($$LINE)),FLD,2)
  1. ..S VALUE("START")=$$LINE_"^4"
  1. ..S VALUE("END")=$$LINE_"^"_($L(VALUE)+3)
  1. ..I $$X($F($G(@MSG@($$LINE)),FLD,5)-1),$$FLD(3),$$REP(1),$$COMP(1),$$SUB(1) S POS("CURRENT DELIMITER")=$$X
  1. ..S LASTPART(1)=1,LASTPART(1,1)=1,LASTPART(1,1,1)=1
  1. ..S LASTPART(2)=1,LASTPART(2,1)=1,LASTPART(2,1,1)=1
  1. .E D
  1. ..S POS("CURRENT DELIMITER")=$$LINE_"^0"
  1. ..S POS("NEXT DELIMITER")=$$LINE_"^0"
  1. ..S VALUE=SEGTYPE,VALUE("START")=$$LINE_"^1",VALUE("END")=$$LINE_"^3"
  1. .F S CHAR=$$GETCHAR("+") Q:CHAR="" D
  1. ..I DELIM[CHAR D Q
  1. ...S POS("CURRENT DELIMITER")=$$LINE_"^"_$$X
  1. ...K VALUE S VALUE=""
  1. ...I CHAR=FLD,$$FLD("+"),$$REP(1),$$COMP(1),$$SUB(1) Q
  1. ...I CHAR=REP,$$REP("+"),$$COMP(1),$$SUB(1) Q
  1. ...I CHAR=COMP,$$COMP("+"),$$SUB(1) Q
  1. ...I CHAR=SUB,$$SUB("+") Q
  1. ..E D
  1. ...S:$L(VALUE)<512 VALUE=VALUE_CHAR
  1. ...I $L(VALUE)=1 S VALUE("START")=$$LINE_"^"_$$X
  1. ...S VALUE("END")=$$LINE_"^"_$$X
  1. ;
  1. I $$LINE(+POS("CURRENT DELIMITER")),$$X($P(POS("CURRENT DELIMITER"),"^",2)) ;set current position to current delimiter
  1. ;
  1. ;
  1. S CHAR=$$GETCHAR
  1. D ;what is the next position in the segment?
  1. .I CHAR=FLD D Q
  1. ..I $$FLD("-"),$$REP(LASTPART($$FLD)),$$COMP(LASTPART($$FLD,$$REP)),$$SUB(LASTPART($$FLD,$$REP,$$COMP))
  1. .I CHAR=REP D Q
  1. ..I $$REP("-"),$$COMP(LASTPART($$FLD,$$REP)),$$SUB(LASTPART($$FLD,$$REP,$$COMP))
  1. .I CHAR=COMP D Q
  1. ..I $$COMP("-"),$$SUB(LASTPART($$FLD,$$REP,$$COMP))
  1. .I CHAR=SUB D Q
  1. ..I $$SUB("-")
  1. ;
  1. F S CHAR=$$GETCHAR("-") D Q:QUIT
  1. .I $L(CHAR),DELIM[CHAR S POS("CURRENT DELIMITER")=$$LINE_"^"_$$X,QUIT=1 D Q
  1. .I CHAR="" D
  1. ..S QUIT=1
  1. ..I VALUE="" D UP Q
  1. ..S POS("CURRENT DELIMITER")=$$LINE_"^0" ;signals end of segment
  1. .;
  1. .S:$L(VALUE)<512 VALUE=CHAR_VALUE
  1. .I $L(VALUE)=1 S VALUE("END")=$$LINE_"^"_$$X
  1. .S VALUE("START")=$$LINE_"^"_$$X
  1. ;
  1. GOLEFT ;
  1. ;keep the current field in the scrolling region
  1. I $$Y<(IOTM) D SCROLL($$Y-IOTM)
  1. ;
  1. D DESCRIBE^HLOPRSR3
  1. D HILITE(+$G(VALUE("START")),$P($G(VALUE("START")),"^",2),+$G(VALUE("END")),$P($G(VALUE("END")),"^",2))
  1. Q
  1. ;
  1. MSGSIZE() ;
  1. Q $$MSGSIZE^HLOPRSR1
  1. SCRNSIZE() ;
  1. Q $$SCRNSIZE^HLOPRSR1
  1. TOP(INC) ;msg line at the top of the scrolling area
  1. Q $$TOP^HLOPRSR1(.INC)
  1. LINE(TO,INC) ;msg line
  1. Q $$LINE^HLOPRSR1(.TO,.INC)
  1. ;
  1. X(TO,INC) ;current position within the line
  1. ;
  1. Q $$X^HLOPRSR1(.TO,.INC)
  1. Y(LINE) ;screen line of msg line = LINE
  1. Q $$Y^HLOPRSR1(.LINE)
  1. SEG(INC) ;returns the current segement #
  1. Q $$SEG^HLOPRSR1(.INC)
  1. FLD(SET) ;returns the currrent field #
  1. Q $$FLD^HLOPRSR1(.SET)
  1. REP(SET) ;returns the current repitition #
  1. Q $$REP^HLOPRSR1(.SET)
  1. COMP(SET) ;returns the current component #
  1. Q $$COMP^HLOPRSR1(.SET)
  1. ;
  1. SUB(SET) ;returns the current sub-component #
  1. Q $$SUB^HLOPRSR1(.SET)
  1. ;
  1. SEGSTART(SEGMENT) ;
  1. Q $$SEGSTART^HLOPRSR1(.SEGMENT)
  1. ;
  1. IOXY(Y,X) ; moves to screen position line=Y, col=X
  1. D IOXY^HLOPRSR1(.Y,.X)
  1. Q
  1. HILITE(LINE1,CHAR1,LINE2,CHAR2) ;does hightlighting
  1. ;LINE1: starting line
  1. ;CHAR1: starting character
  1. ;LINE2: ending line
  1. ;CHAR2: ending character
  1. ;
  1. N X
  1. I $G(HILITE) D UNLITE
  1. I LINE1>0,CHAR1>0,LINE2>0,CHAR2>0 D
  1. .W IORVON
  1. .S HILITE=LINE1_"^"_CHAR1_"^"_LINE2_"^"_CHAR2
  1. .D LITE
  1. W IORVOFF
  1. S X=$P(POS("CURRENT DELIMITER"),"^",2)
  1. ;
  1. ;
  1. ;move curson to the delimiter, and write in bold
  1. D IOXY($$Y($$LINE(+POS("CURRENT DELIMITER"))),$$X(X))
  1. ;
  1. ;
  1. I X D
  1. .W IOINHI
  1. .W $$GETCHAR
  1. .W IOINORM
  1. .D IOXY($$Y,$$X)
  1. W IOCUON
  1. Q
  1. ;
  1. LITE N LINE
  1. F LINE=LINE1:1:LINE2 D
  1. .I '($$Y(LINE)>IOBM),'($$Y(LINE)<IOTM) D
  1. ..D IOXY($$Y(LINE),$S(LINE=LINE1:CHAR1,1:1))
  1. ..W $E($G(@MSG@(LINE)),$S(LINE=LINE1:CHAR1,1:1),$S(LINE=LINE2:CHAR2,1:80))
  1. Q
  1. ;
  1. UNLITE ;
  1. N LINE1,CHAR1,LINE2,CHAR2
  1. W IORVOFF
  1. Q:$G(HILITE)=""
  1. S LINE1=$P(HILITE,"^"),CHAR1=$P(HILITE,"^",2),LINE2=$P(HILITE,"^",3),CHAR2=$P(HILITE,"^",4)
  1. K HILITE
  1. I $G(SEGLINE(LINE2)),CHAR1=1 W IOINHI
  1. D LITE
  1. I $G(SEGLINE(LINE2)),CHAR1=1 W IOINORM
  1. Q
  1. ;
  1. DOWN ;
  1. N I
  1. K LASTPART
  1. S SEGTYPE=""
  1. I $$SEGSTART($$SEG("+1")) D
  1. .I $$LINE($$SEGSTART($$SEG))
  1. E D
  1. .I $$LINE(,1)>0,$$LINE<$$MSGSIZE,$$LINE($$MSGSIZE+1)
  1. F I="FLD","REP","COMP","SUB" S POS(I)=0
  1. I '($$Y>IOBM) D
  1. .D IOXY($$Y,1)
  1. E D
  1. .D SCROLL($$Y-IOBM)
  1. S SEGTYPE=$E($G(@MSG@($$LINE)),1,3)
  1. S POS("CURRENT DELIMITER")=$$LINE_"^0"
  1. S POS("NEXT DELIMITER")=$$LINE_"^"_$S($$SEGSTART($$SEG):4,1:0)
  1. D DESCRIBE^HLOPRSR3
  1. D HILITE($$LINE,$$X,$$LINE,($$X+2))
  1. Q
  1. ;
  1. UP ;
  1. N I
  1. K LASTPART
  1. S SEGTYPE=""
  1. I $$SEGSTART($$SEG("-1")) D
  1. .I $$LINE($$SEGSTART($$SEG))
  1. E D
  1. .I $$LINE(,-1)>0,$$LINE<$$MSGSIZE,$$LINE(0) ;set line to 0
  1. F I="FLD","REP","COMP","SUB" S POS(I)=0
  1. I '($$Y<IOTM) D
  1. .D IOXY($$Y,1)
  1. E D
  1. .D SCROLL($$Y-IOTM)
  1. S SEGTYPE=$E($G(@MSG@($$LINE)),1,3)
  1. S POS("CURRENT DELIMITER")=$$LINE_"^0"
  1. S POS("NEXT DELIMITER")=$$LINE_"^"_$S($$SEGSTART($$SEG):4,1:0)
  1. D DESCRIBE^HLOPRSR3
  1. D HILITE($$LINE,$$X,$$LINE,($$X+2))
  1. Q
  1. ;
  1. SCROLL(COUNT) ; Scrolls up (COUNT positive) or down (COUNT negative)
  1. ;
  1. N I
  1. I COUNT>0 D
  1. .D IOXY(IOBM,1)
  1. .F I=1:1:COUNT D
  1. ..W IOIND
  1. ..I $$TOP(1)
  1. ..W $G(@MSG@($$BOT^HLOPRSR1))
  1. ..D IOXY(IOBM,1)
  1. .I $$LINE($$BOT^HLOPRSR1)
  1. .S POS("CHAR")=1
  1. .;
  1. I COUNT<0 D
  1. .D IOXY(1,1)
  1. .F I=-1:-1:COUNT D
  1. ..W IORI
  1. ..W $G(@MSG@($$TOP(-1)))
  1. ..D IOXY(1,1)
  1. .S POS("CHAR")=1
  1. Q
  1. GETCHAR(INC) ;returns a message character, can go forward or backward but will not cross the segment boundary.
  1. ;INC:
  1. ; not defined - assumes the current position
  1. ; "+" - the next character. May change $$X and $$LINE
  1. ; "-" - the prior character. May change $$X and $$LINE
  1. ;
  1. N END,TMP
  1. S END=0
  1. S TMP("LINE")=$$LINE
  1. S TMP("X")=$$X
  1. I $E($G(INC))="+" D
  1. .I '($$X<80) D ;get char from next line
  1. ..;** P139 START CJM
  1. ..I ('$$SEGSTART($$SEG+1))!(($$LINE+1)<$$SEGSTART($$SEG+1)),$$LINE(,1),$$X(1)
  1. ..;** P139 END
  1. .E D
  1. ..I $$X=$$X(,1) S END=1
  1. E I $E($G(INC))="-" D
  1. .I '($$X()>1) D ;get char from prior line
  1. ..I $$SEGSTART($$SEG)<$$LINE D
  1. ...I $$LINE(,-1),$$X($L($G(@MSG@($$LINE))))
  1. ..E D
  1. ...S END=1
  1. .E D
  1. ..I $$X=$$X(,-1) S END=1
  1. ;** P146 START CJM
  1. ;
  1. ;This line was added in patch 139. It is incorrect!
  1. ;I TMP("LINE")=$$LINE,TMP("X")=$$X S END=1
  1. ;
  1. ;This is the corrected line.
  1. I $L($G(INC)),TMP("LINE")=$$LINE,TMP("X")=$$X S END=1
  1. ;**P146 END
  1. ;
  1. Q:END ""
  1. Q $E($G(@MSG@($$LINE)),$$X)
  1. ;
  1. LJ(STRING,LENGTH) ;
  1. Q $$LJ^XLFSTR(STRING,LENGTH)