DDWG.m

DDWG ;SFISC/MKO-GOTO ;3:40 PM  5 Jul 1996

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

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

GOTO ;Go to a specific location

 N DDWANS,DDWI,DDWHLP

 S DDWHLP(1)="Examples, to go to a screen:  S21, 21, S+3, +3, -3"

 S DDWHLP(2)="          to go to a line:    L53, L+4, L-5"

 S DDWHLP(3)="          to go to a column:  C40, C+10, C-20"

 D ASK(4,"Go to: ",17,"","D VALGTO",.DDWHLP,.DDWANS)

 I U[DDWANS

 E  I "Ss"[$E(DDWANS)!(DDWANS'?1A.E) D

 . D GOTOS

 E  I "Ll"[$E(DDWANS) D

 . D GOTOL

 E  I "Cc"[$E(DDWANS) D

 . D GOTOC

 Q

 ;

GOTOS ;Go to a page

 N DDWS

 S DDWS=DDWANS

 S:DDWS?1A.E DDWS=$E(DDWS,2,999)

 S:DDWS?1P.E DDWS=$E(DDWS,2,999)

 I DDWANS["+" S DDWS=$$SCREEN+DDWS

 E  I DDWANS["-" S DDWS=$$SCREEN-DDWS

 I DDWS<1 S DDWS=1

 E  I DDWS>$$LTOSC(DDWCNT) S DDWS=$$LTOSC(DDWCNT)

 D LINE(DDWS-1*DDWMR+1)

 Q

 ;

GOTOL ;Go to a line

 N DDWLN

 S DDWLN=DDWANS

 S:DDWLN?1A.E DDWLN=$E(DDWLN,2,999)

 S:DDWLN?1P.E DDWLN=$E(DDWLN,2,999)

 I DDWANS["+" S DDWLN=DDWA+DDWRW+DDWLN

 E  I DDWANS["-" S DDWLN=DDWA+DDWRW-DDWLN

 I DDWLN<1 S DDWLN=1

 E  I DDWLN>DDWCNT S DDWLN=DDWCNT

 D LINE(DDWLN)

 Q

 ;

GOTOC ;Go to a column

 N DDWCOL

 S DDWCOL=DDWANS

 S:DDWCOL?1A.E DDWCOL=$E(DDWCOL,2,999)

 S:DDWCOL?1P.E DDWCOL=$E(DDWCOL,2,999)

 I DDWANS["+" S DDWCOL=DDWC+DDWCOL

 E  I DDWANS["-" S DDWCOL=DDWC-DDWCOL

 I DDWCOL<1 S DDWCOL=1

 E  I DDWCOL>246 S DDWCOL=246

 D POS(DDWRW,DDWCOL,"R")

 Q

 ;

LINE(DDWLN,DDWCOL) ;Adjust arrays and position cursor on line DDWLN

 I $G(DDWCOL)'="E",'$G(DDWCOL) S DDWCOL=1

 S:DDWLN>DDWCNT DDWLN=DDWCNT

 I DDWLN>DDWA,DDWLN'>(DDWA+DDWMR-1) D

 . D POS(DDWLN-DDWA,DDWCOL,"RN")

 E  I DDWLN>DDWA D

 . D SHFTDN^DDW3(DDWLN,DDWCOL),POS(DDWLN-DDWA,DDWCOL,"RN")

 E  D

 . D SHFTUP^DDW3(DDWLN),POS(1,DDWCOL,"RN")

 Q

 ;

ASK(DDWLC,DDWS,DDWLEN,DDWDEF,DDWVAL,DDWHLP,DDWANS,DDWCOD) ;Prompt user

 N DDWI

 D CUP(DDWMR-DDWLC,1)

 W $P(DDGLGRA,DDGLDEL)_$TR($J("",IOM)," ",$P(DDGLGRA,DDGLDEL,3))_$P(DDGLGRA,DDGLDEL,2)

 F DDWI=DDWMR-DDWLC+1:1:DDWMR D CUP(DDWI,1) W $P(DDGLCLR,DDGLDEL)

 K DDWANS F  D PROMPT Q:$D(DDWANS)

 ;

 F DDWI=DDWMR-DDWLC:1:DDWMR D

 . D CUP(DDWI,1)

 . W $P(DDGLCLR,DDGLDEL)_$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)

 D POS(DDWRW,DDWC,"RN")

 Q

 ;

PROMPT ;Issue read

 N DDWERR,DDWX

 D CUP(DDWMR-DDWLC+1,1) W DDWS_$P(DDGLCLR,DDGLDEL)

 D EN^DIR0(IOTM+DDWMR-DDWLC-1,$L(DDWS),DDWLEN,1,$G(DDWDEF),245,"","","AKTW",.DDWX,.DDWCOD)

 ;

 I DDWX?1."?",$D(DDWHLP)>9!($G(DDWHLP)]"") D HELP(.DDWHLP) Q

 I $G(DDWVAL)]"" X DDWVAL I $D(DDWERR) W $C(7) D HELP(.DDWERR) Q

 S DDWANS=DDWX

 Q

 ;

VALGTO ;Validate DDWX

 N DDWCH

 Q:U[DDWX

 S DDWERR="Invalid format.  Enter ? for examples."

 Q:DDWX'?.1A.1P1.15N

 I DDWX?1A.E S DDWCH=$E(DDWX) Q:"SsLlCc"'[DDWCH

 I DDWX?.E1P.E I DDWX'["+",DDWX'["-" Q

 K DDWERR

 Q

 ;

HELP(DDWMSG) ;Print message

 N DDWI,DDWEC

 S:$D(DDWMSG)<9 DDWMSG(1)=DDWMSG

 S DDWEC=$O(DDWMSG(""),-1)

 F DDWI=2:1:DDWLC D

 . D CUP(DDWMR-DDWLC+DDWI,1)

 . W $P(DDGLCLR,DDGLDEL)_$G(DDWMSG(DDWI-DDWLC+DDWEC))

 Q

 ;

SCREEN() ;Return current screen

 Q DDWA+DDWRW-1\DDWMR+1

 ;

LTOSC(L) ;Convert line number to page number

 Q L-1\DDWMR+1

 ;

CUP(Y,X) ;Pos cursor

 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

DDWG      ;SFISC/MKO-GOTO ;3:40 PM  5 Jul 1996

 +1       ;;22.0;VA FileMan;;Mar 30, 1999

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

GOTO      ;Go to a specific location

 +1        NEW DDWANS,DDWI,DDWHLP

 +2        SET DDWHLP(1)="Examples, to go to a screen:  S21, 21, S+3, +3, -3"

 +3        SET DDWHLP(2)="          to go to a line:    L53, L+4, L-5"

 +4        SET DDWHLP(3)="          to go to a column:  C40, C+10, C-20"

 +5        DO ASK(4,"Go to: ",17,"","D VALGTO",.DDWHLP,.DDWANS)

 +6        IF U[DDWANS

 +7       IF '$TEST

               IF "Ss"[$EXTRACT(DDWANS)!(DDWANS'?1A.E)

                   Begin DoDot:1

 +8                    DO GOTOS

                   End DoDot:1

 +9       IF '$TEST

               IF "Ll"[$EXTRACT(DDWANS)

                   Begin DoDot:1

 +10                   DO GOTOL

                   End DoDot:1

 +11      IF '$TEST

               IF "Cc"[$EXTRACT(DDWANS)

                   Begin DoDot:1

 +12                   DO GOTOC

                   End DoDot:1

 +13       QUIT 

 +14      ;

GOTOS     ;Go to a page

 +1        NEW DDWS

 +2        SET DDWS=DDWANS

 +3        IF DDWS?1A.E

               SET DDWS=$EXTRACT(DDWS,2,999)

 +4        IF DDWS?1P.E

               SET DDWS=$EXTRACT(DDWS,2,999)

 +5        IF DDWANS["+"

               SET DDWS=$$SCREEN+DDWS

 +6       IF '$TEST

               IF DDWANS["-"

                   SET DDWS=$$SCREEN-DDWS

 +7        IF DDWS<1

               SET DDWS=1

 +8       IF '$TEST

               IF DDWS>$$LTOSC(DDWCNT)

                   SET DDWS=$$LTOSC(DDWCNT)

 +9        DO LINE(DDWS-1*DDWMR+1)

 +10       QUIT 

 +11      ;

GOTOL     ;Go to a line

 +1        NEW DDWLN

 +2        SET DDWLN=DDWANS

 +3        IF DDWLN?1A.E

               SET DDWLN=$EXTRACT(DDWLN,2,999)

 +4        IF DDWLN?1P.E

               SET DDWLN=$EXTRACT(DDWLN,2,999)

 +5        IF DDWANS["+"

               SET DDWLN=DDWA+DDWRW+DDWLN

 +6       IF '$TEST

               IF DDWANS["-"

                   SET DDWLN=DDWA+DDWRW-DDWLN

 +7        IF DDWLN<1

               SET DDWLN=1

 +8       IF '$TEST

               IF DDWLN>DDWCNT

                   SET DDWLN=DDWCNT

 +9        DO LINE(DDWLN)

 +10       QUIT 

 +11      ;

GOTOC     ;Go to a column

 +1        NEW DDWCOL

 +2        SET DDWCOL=DDWANS

 +3        IF DDWCOL?1A.E

               SET DDWCOL=$EXTRACT(DDWCOL,2,999)

 +4        IF DDWCOL?1P.E

               SET DDWCOL=$EXTRACT(DDWCOL,2,999)

 +5        IF DDWANS["+"

               SET DDWCOL=DDWC+DDWCOL

 +6       IF '$TEST

               IF DDWANS["-"

                   SET DDWCOL=DDWC-DDWCOL

 +7        IF DDWCOL<1

               SET DDWCOL=1

 +8       IF '$TEST

               IF DDWCOL>246

                   SET DDWCOL=246

 +9        DO POS(DDWRW,DDWCOL,"R")

 +10       QUIT 

 +11      ;

LINE(DDWLN,DDWCOL) ;Adjust arrays and position cursor on line DDWLN

 +1        IF $GET(DDWCOL)'="E"

               IF '$GET(DDWCOL)

                   SET DDWCOL=1

 +2        IF DDWLN>DDWCNT

               SET DDWLN=DDWCNT

 +3        IF DDWLN>DDWA

               IF DDWLN'>(DDWA+DDWMR-1)

                   Begin DoDot:1

 +4                    DO POS(DDWLN-DDWA,DDWCOL,"RN")

                   End DoDot:1

 +5       IF '$TEST

               IF DDWLN>DDWA

                   Begin DoDot:1

 +6                    DO SHFTDN^DDW3(DDWLN,DDWCOL)

                       DO POS(DDWLN-DDWA,DDWCOL,"RN")

                   End DoDot:1

 +7       IF '$TEST

               Begin DoDot:1

 +8                DO SHFTUP^DDW3(DDWLN)

                   DO POS(1,DDWCOL,"RN")

               End DoDot:1

 +9        QUIT 

 +10      ;

ASK(DDWLC,DDWS,DDWLEN,DDWDEF,DDWVAL,DDWHLP,DDWANS,DDWCOD) ;Prompt user

 +1        NEW DDWI

 +2        DO CUP(DDWMR-DDWLC,1)

 +3        WRITE $PIECE(DDGLGRA,DDGLDEL)_$TRANSLATE($JUSTIFY("",IOM)," ",$PIECE(DDGLGRA,DDGLDEL,3))_$PIECE(DDGLGRA,DDGLDEL,2)

 +4        FOR DDWI=DDWMR-DDWLC+1:1:DDWMR

               DO CUP(DDWI,1)

               WRITE $PIECE(DDGLCLR,DDGLDEL)

 +5        KILL DDWANS

           FOR 

               DO PROMPT

               IF $DATA(DDWANS)

                   QUIT 

 +6       ;

 +7        FOR DDWI=DDWMR-DDWLC:1:DDWMR

               Begin DoDot:1

 +8                DO CUP(DDWI,1)

 +9                WRITE $PIECE(DDGLCLR,DDGLDEL)_$EXTRACT(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)

               End DoDot:1

 +10       DO POS(DDWRW,DDWC,"RN")

 +11       QUIT 

 +12      ;

PROMPT    ;Issue read

 +1        NEW DDWERR,DDWX

 +2        DO CUP(DDWMR-DDWLC+1,1)

           WRITE DDWS_$PIECE(DDGLCLR,DDGLDEL)

 +3        DO EN^DIR0(IOTM+DDWMR-DDWLC-1,$LENGTH(DDWS),DDWLEN,1,$GET(DDWDEF),245,"","","AKTW",.DDWX,.DDWCOD)

 +4       ;

 +5        IF DDWX?1."?"

               IF $DATA(DDWHLP)>9!($GET(DDWHLP)]"")

                   DO HELP(.DDWHLP)

                   QUIT 

 +6        IF $GET(DDWVAL)]""

               XECUTE DDWVAL

               IF $DATA(DDWERR)

                   WRITE $CHAR(7)

                   DO HELP(.DDWERR)

                   QUIT 

 +7        SET DDWANS=DDWX

 +8        QUIT 

 +9       ;

VALGTO    ;Validate DDWX

 +1        NEW DDWCH

 +2        IF U[DDWX

               QUIT 

 +3        SET DDWERR="Invalid format.  Enter ? for examples."

 +4        IF DDWX'?.1A.1P1.15N

               QUIT 

 +5        IF DDWX?1A.E

               SET DDWCH=$EXTRACT(DDWX)

               IF "SsLlCc"'[DDWCH

                   QUIT 

 +6        IF DDWX?.E1P.E

               IF DDWX'["+"

                   IF DDWX'["-"

                       QUIT 

 +7        KILL DDWERR

 +8        QUIT 

 +9       ;

HELP(DDWMSG) ;Print message

 +1        NEW DDWI,DDWEC

 +2        IF $DATA(DDWMSG)<9

               SET DDWMSG(1)=DDWMSG

 +3        SET DDWEC=$ORDER(DDWMSG(""),-1)

 +4        FOR DDWI=2:1:DDWLC

               Begin DoDot:1

 +5                DO CUP(DDWMR-DDWLC+DDWI,1)

 +6                WRITE $PIECE(DDGLCLR,DDGLDEL)_$GET(DDWMSG(DDWI-DDWLC+DDWEC))

               End DoDot:1

 +7        QUIT 

 +8       ;

SCREEN()  ;Return current screen

 +1        QUIT DDWA+DDWRW-1\DDWMR+1

 +2       ;

LTOSC(L)  ;Convert line number to page number

 +1        QUIT L-1\DDWMR+1

 +2       ;

CUP(Y,X)  ;Pos cursor

 +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