DDW2 ;SFISC/MKO-SETTINGS, MODES ;07:22 PM 5 Dec 2002
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
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
D BLD^DIALOG(8136,,,"DDWHLP")
D ASK^DDWG(5,$$EZBLD^DIALOG(8136.1)_" ",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=$$EZBLD^DIALOG(8136.2) ;**TAB response rule
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($$EZBLD^DIALOG(8138.1)) Q
I DDWC>231 D ERR($$EZBLD^DIALOG(8138.2)) Q
I DDWC'<DDWRMAR D ERR($$EZBLD^DIALOG(8138.3)) 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($$EZBLD^DIALOG(8138.1)) Q
I DDWC>245 D ERR($$EZBLD^DIALOG(8138.4)) Q
I DDWC'>DDWLMAR D ERR($$EZBLD^DIALOG(8138.5)) 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 "[",$$UP^DILIBF($P($$EZBLD^DIALOG(7002),U,$S(DDWREP:2,1:1))),"]" ;**
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDW2 3194 printed Dec 13, 2024@02:43:53 Page 2
DDW2 ;SFISC/MKO-SETTINGS, MODES ;07:22 PM 5 Dec 2002
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
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 DO BLD^DIALOG(8136,,,"DDWHLP")
+3 DO ASK^DDWG(5,$$EZBLD^DIALOG(8136.1)_" ",30,$GET(DDWTAB),"D TSALLVAL^DDW2",.DDWHLP,.DDWANS,.DDWCOD)
+4 ;
+5 if DDWCOD="TO"!(DDWANS=U)!(DDWANS=DDWTAB)
QUIT
+6 SET DDWTAB=DDWANS
+7 SET DDWRUL=$$RULER(DDWTAB)
+8 DO RULER^DDW3
DO POS(DDWRW,DDWC)
+9 QUIT
+10 ;
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 ;**TAB response rule
SET DDWERR=$$EZBLD^DIALOG(8136.2)
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($$EZBLD^DIALOG(8138.1))
QUIT
+1 IF DDWC>231
DO ERR($$EZBLD^DIALOG(8138.2))
QUIT
+2 IF DDWC'<DDWRMAR
DO ERR($$EZBLD^DIALOG(8138.3))
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($$EZBLD^DIALOG(8138.1))
QUIT
+1 IF DDWC>245
DO ERR($$EZBLD^DIALOG(8138.4))
QUIT
+2 IF DDWC'>DDWLMAR
DO ERR($$EZBLD^DIALOG(8138.5))
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 "[",$$UP^DILIBF($PIECE($$EZBLD^DIALOG(7002),U,$SELECT(DDWREP:2,1:1))),"]"
+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
