DDW2.m

DDW2 ;SFISC/MKO-SETTINGS, MODES ;11:32 AM  25 Aug 2000 [ 04/02/2003   8:25 AM ]

 ;;22.0;VA FileMan;**1001**;APR 1, 2003

 ;;22.0;VA FileMan;**18**;Mar 30, 1999

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

TSET N DDWX

 S DDWX=$E(DDWRUL,DDWC)

 S DDWX=$S(DDWX="T":"=",DDWX="=":"T",1:DDWX)

 S $E(DDWRUL,DDWC)=DDWX

 I DDWC'=DDWLMAR,DDWC'=DDWRMAR D

 . D CUP(DDWMR+1,DDWC-DDWOFS) W DDWX

 . D POS(DDWRW,DDWC)

 Q

 ;

TSALL ;Prompt for tab stops

 N DDWHLP,DDWANS,DDWCOD

 S DDWHLP(1)="  Specify in which column(s) you want to set tab stops. To set individual"

 S DDWHLP(2)="  tab stops, type a series of numbers separated by commas, for example:"

 S DDWHLP(3)="  4,7,15,20. To set tab stops at repeated intervals after the last stop,"

 S DDWHLP(4)="  or column 1, type the interval as +n, for example: 10,20,+5."

 D ASK^DDWG(5,"Columns in which to set tab stops: ",30,$G(DDWTAB),"D TSALLVAL^DDW2",.DDWHLP,.DDWANS,.DDWCOD)

 ;

 Q:DDWCOD="TO"!(DDWANS=U)!(DDWANS=DDWTAB)

 S DDWTAB=DDWANS

 S DDWRUL=$$RULER(DDWTAB)

 D RULER^DDW3,POS(DDWRW,DDWC)

 Q

 ;

TSALLVAL ;Validate tab stops

 K DDWERR

 S:DDWX="@" DDWX=""

 I DDWX?1."^"!($P($G(DDWCOD),U)="TO") S DDWX=U Q

 I $TR(DDWX,"+,")?.E1.APC.E D

 . S DDWERR="  Response can contain only commas (,), plus signs (+), and numbers."

 Q

 ;

RULER(TAB) ;Return the ruler with tab stops

 N C,INT,LAST,POS,RUL

 S RUL=$TR($J("",255)," ","=")

 ;

 ;Process each comma piece in tab

 S LAST=1

 F C=1:1:$L(TAB,",") D

 . S POS=$P(TAB,",",C) Q:POS'?.1"+"1.3N

 . I $E(POS)="+" D

 .. S INT=+$E(POS,2,999)

 .. F POS=LAST+INT:INT:255 S $E(RUL,POS)="T"

 . E  S:POS<256 $E(RUL,POS)="T",LAST=POS

 Q RUL

 ;

LSET I 'DDWRAP D ERR("Margins cannot be set when wrap is off") Q

 I DDWC>231 D ERR("Left margin cannot be set beyond column 231") Q

 I DDWC'<DDWRMAR D ERR("Left margin must be left of right margin") Q

 I DDWLMAR-DDWOFS'<1,DDWLMAR-DDWOFS'>IOM D

 . D CUP(DDWMR+1,DDWLMAR-DDWOFS) W $E(DDWRUL,DDWLMAR)

 D CUP(DDWMR+1,DDWC-DDWOFS) W "<" D POS(DDWRW,DDWC)

 S DDWLMAR=DDWC

 Q

 ;

RSET I 'DDWRAP D ERR("Margins cannot be set when wrap is off") Q

 I DDWC>245 D ERR("Right margin cannot be set beyond column 245") Q

 I DDWC'>DDWLMAR D ERR("Right margin must be right of left margin") Q

 I DDWRMAR-DDWOFS'<1,DDWRMAR-DDWOFS'>IOM D

 . D CUP(DDWMR+1,DDWRMAR-DDWOFS) W $E(DDWRUL,DDWRMAR)

 D CUP(DDWMR+1,DDWC-DDWOFS) W ">" D POS(DDWRW,DDWC)

 S DDWRMAR=DDWC

 Q

 ;

WRAPM S DDWRAP=DDWRAP+1#2

 D CUP(0,3) W $S(DDWRAP:"[ WRAP ]",1:"========")

 I 'DDWRAP D

 . S DDWLMAR(1)=DDWLMAR,DDWLMAR=1

 . S DDWRMAR(1)=DDWRMAR,DDWRMAR=245

 E  D

 . S DDWLMAR=DDWLMAR(1) K DDWLMAR(1)

 . S DDWRMAR=DDWRMAR(1) K DDWRMAR(1)

 D RULER^DDW3,POS(DDWRW,DDWC)

 Q

 ;

REPLM S DDWREP=DDWREP+1#2

 D CUP(0,13) W $S(DDWREP:"[ REPLACE ]",1:"[ INSERT ]=")

 D POS(DDWRW,DDWC)

 Q

 ;

STAT S DDWSTAT=DDWSTAT+1#2

 I DDWSTAT S DDWTO=1

 E  D

 . D CUP(DDWMR+2,1)

 . W $P(DDGLCLR,DDGLDEL) D POS(DDWRW,DDWC)

 . S DDWTO=DTIME

 . K DDWTC

 Q

 ;

CUP(Y,X) ;Cursor positioning

 S DY=IOTM+Y-2,DX=X-1 X IOXY

 Q

 ;

POS(R,C,F) ;Pos cursor based on char pos C

 N DDWX

 S:$G(C)="E" C=$L($G(DDWL(R)))+1

 S:$G(F)["N" DDWN=$G(DDWL(R))

 S:$G(F)["R" DDWRW=R,DDWC=C

 ;

 S DDWX=C-DDWOFS

 I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)

 S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY

 Q

 ;

SCR(C) ;Return screen number

 Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1

 ;

ERR(DDWX) ;Error

 W $C(7)

 D MSG^DDW(DDWX) H 2 D MSG^DDW()

 F  R *DDWX:0 E  Q

 D POS(DDWRW,DDWC)

 Q

DDW2      ;SFISC/MKO-SETTINGS, MODES ;11:32 AM  25 Aug 2000 [ 04/02/2003   8:25 AM ]

 +1       ;;22.0;VA FileMan;**1001**;APR 1, 2003

 +2       ;;22.0;VA FileMan;**18**;Mar 30, 1999

 +3       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +4       ;

TSET       NEW DDWX

 +1        SET DDWX=$EXTRACT(DDWRUL,DDWC)

 +2        SET DDWX=$SELECT(DDWX="T":"=",DDWX="=":"T",1:DDWX)

 +3        SET $EXTRACT(DDWRUL,DDWC)=DDWX

 +4        IF DDWC'=DDWLMAR

               IF DDWC'=DDWRMAR

                   Begin DoDot:1

 +5                    DO CUP(DDWMR+1,DDWC-DDWOFS)

                       WRITE DDWX

 +6                    DO POS(DDWRW,DDWC)

                   End DoDot:1

 +7        QUIT 

 +8       ;

TSALL     ;Prompt for tab stops

 +1        NEW DDWHLP,DDWANS,DDWCOD

 +2        SET DDWHLP(1)="  Specify in which column(s) you want to set tab stops. To set individual"

 +3        SET DDWHLP(2)="  tab stops, type a series of numbers separated by commas, for example:"

 +4        SET DDWHLP(3)="  4,7,15,20. To set tab stops at repeated intervals after the last stop,"

 +5        SET DDWHLP(4)="  or column 1, type the interval as +n, for example: 10,20,+5."

 +6        DO ASK^DDWG(5,"Columns in which to set tab stops: ",30,$GET(DDWTAB),"D TSALLVAL^DDW2",.DDWHLP,.DDWANS,.DDWCOD)

 +7       ;

 +8        IF DDWCOD="TO"!(DDWANS=U)!(DDWANS=DDWTAB)

               QUIT 

 +9        SET DDWTAB=DDWANS

 +10       SET DDWRUL=$$RULER(DDWTAB)

 +11       DO RULER^DDW3

           DO POS(DDWRW,DDWC)

 +12       QUIT 

 +13      ;

TSALLVAL  ;Validate tab stops

 +1        KILL DDWERR

 +2        IF DDWX="@"

               SET DDWX=""

 +3        IF DDWX?1."^"!($PIECE($GET(DDWCOD),U)="TO")

               SET DDWX=U

               QUIT 

 +4        IF $TRANSLATE(DDWX,"+,")?.E1.APC.E

               Begin DoDot:1

 +5                SET DDWERR="  Response can contain only commas (,), plus signs (+), and numbers."

               End DoDot:1

 +6        QUIT 

 +7       ;

RULER(TAB) ;Return the ruler with tab stops

 +1        NEW C,INT,LAST,POS,RUL

 +2        SET RUL=$TRANSLATE($JUSTIFY("",255)," ","=")

 +3       ;

 +4       ;Process each comma piece in tab

 +5        SET LAST=1

 +6        FOR C=1:1:$LENGTH(TAB,",")

               Begin DoDot:1

 +7                SET POS=$PIECE(TAB,",",C)

                   IF POS'?.1"+"1.3N

                       QUIT 

 +8                IF $EXTRACT(POS)="+"

                       Begin DoDot:2

 +9                        SET INT=+$EXTRACT(POS,2,999)

 +10                       FOR POS=LAST+INT:INT:255

                               SET $EXTRACT(RUL,POS)="T"

                       End DoDot:2

 +11              IF '$TEST

                       IF POS<256

                           SET $EXTRACT(RUL,POS)="T"

                           SET LAST=POS

               End DoDot:1

 +12       QUIT RUL

 +13      ;

LSET       IF 'DDWRAP

               DO ERR("Margins cannot be set when wrap is off")

               QUIT 

 +1        IF DDWC>231

               DO ERR("Left margin cannot be set beyond column 231")

               QUIT 

 +2        IF DDWC'<DDWRMAR

               DO ERR("Left margin must be left of right margin")

               QUIT 

 +3        IF DDWLMAR-DDWOFS'<1

               IF DDWLMAR-DDWOFS'>IOM

                   Begin DoDot:1

 +4                    DO CUP(DDWMR+1,DDWLMAR-DDWOFS)

                       WRITE $EXTRACT(DDWRUL,DDWLMAR)

                   End DoDot:1

 +5        DO CUP(DDWMR+1,DDWC-DDWOFS)

           WRITE "<"

           DO POS(DDWRW,DDWC)

 +6        SET DDWLMAR=DDWC

 +7        QUIT 

 +8       ;

RSET       IF 'DDWRAP

               DO ERR("Margins cannot be set when wrap is off")

               QUIT 

 +1        IF DDWC>245

               DO ERR("Right margin cannot be set beyond column 245")

               QUIT 

 +2        IF DDWC'>DDWLMAR

               DO ERR("Right margin must be right of left margin")

               QUIT 

 +3        IF DDWRMAR-DDWOFS'<1

               IF DDWRMAR-DDWOFS'>IOM

                   Begin DoDot:1

 +4                    DO CUP(DDWMR+1,DDWRMAR-DDWOFS)

                       WRITE $EXTRACT(DDWRUL,DDWRMAR)

                   End DoDot:1

 +5        DO CUP(DDWMR+1,DDWC-DDWOFS)

           WRITE ">"

           DO POS(DDWRW,DDWC)

 +6        SET DDWRMAR=DDWC

 +7        QUIT 

 +8       ;

WRAPM      SET DDWRAP=DDWRAP+1#2

 +1        DO CUP(0,3)

           WRITE $SELECT(DDWRAP:"[ WRAP ]",1:"========")

 +2        IF 'DDWRAP

               Begin DoDot:1

 +3                SET DDWLMAR(1)=DDWLMAR

                   SET DDWLMAR=1

 +4                SET DDWRMAR(1)=DDWRMAR

                   SET DDWRMAR=245

               End DoDot:1

 +5       IF '$TEST

               Begin DoDot:1

 +6                SET DDWLMAR=DDWLMAR(1)

                   KILL DDWLMAR(1)

 +7                SET DDWRMAR=DDWRMAR(1)

                   KILL DDWRMAR(1)

               End DoDot:1

 +8        DO RULER^DDW3

           DO POS(DDWRW,DDWC)

 +9        QUIT 

 +10      ;

REPLM      SET DDWREP=DDWREP+1#2

 +1        DO CUP(0,13)

           WRITE $SELECT(DDWREP:"[ REPLACE ]",1:"[ INSERT ]=")

 +2        DO POS(DDWRW,DDWC)

 +3        QUIT 

 +4       ;

STAT       SET DDWSTAT=DDWSTAT+1#2

 +1        IF DDWSTAT

               SET DDWTO=1

 +2       IF '$TEST

               Begin DoDot:1

 +3                DO CUP(DDWMR+2,1)

 +4                WRITE $PIECE(DDGLCLR,DDGLDEL)

                   DO POS(DDWRW,DDWC)

 +5                SET DDWTO=DTIME

 +6                KILL DDWTC

               End DoDot:1

 +7        QUIT 

 +8       ;

CUP(Y,X)  ;Cursor positioning

 +1        SET DY=IOTM+Y-2

           SET DX=X-1

           XECUTE IOXY

 +2        QUIT 

 +3       ;

POS(R,C,F) ;Pos cursor based on char pos C

 +1        NEW DDWX

 +2        IF $GET(C)="E"

               SET C=$LENGTH($GET(DDWL(R)))+1

 +3        IF $GET(F)["N"

               SET DDWN=$GET(DDWL(R))

 +4        IF $GET(F)["R"

               SET DDWRW=R

               SET DDWC=C

 +5       ;

 +6        SET DDWX=C-DDWOFS

 +7        IF DDWX>IOM!(DDWX<1)

               DO SHIFT^DDW3(C,.DDWOFS)

 +8        SET DY=IOTM+R-2

           SET DX=C-DDWOFS-1

           XECUTE IOXY

 +9        QUIT 

 +10      ;

SCR(C)    ;Return screen number

 +1        QUIT C-$PIECE(DDWOFS,U,2)-1\$PIECE(DDWOFS,U,3)+1

 +2       ;

ERR(DDWX) ;Error

 +1        WRITE $CHAR(7)

 +2        DO MSG^DDW(DDWX)

           HANG 2

           DO MSG^DDW()

 +3        FOR 

               READ *DDWX:0

              IF '$TEST

                   QUIT 

 +4        DO POS(DDWRW,DDWC)

 +5        QUIT