DDWC ;SFISC/MKO-CHANGE (REPLACE) ;02:24 PM 14 Aug 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.
;
CHG ;Change
N DDWOPT
D SETUP^DDWC1
F D PROC Q:DDWOPT=-1
D RESTORE^DDWC1
K DDWCHG(1)
Q
;
PROC ;Main procedure
N DDWCOD,DDWT
;
D:$D(DDWMARK) UNMARK^DDW7
D EN^DIR0(IOTM+DDWMR,14,30,"",$G(DDWFIND),100,"","","AKTW",.DDWT,.DDWCOD)
I DDWT=""!($P(DDWCOD,U)="TO") S DDWOPT=-1 Q
S DDWFIND=DDWT,DDWT=$$UC(DDWT)
;
K DDWCHG(1)
D EN^DIR0(IOTM+DDWMR+1,14,30,"",$G(DDWCHG),100,"","","AKTW",.DDWCHG,.DDWCOD)
I $P(DDWCOD,U)="TO" S DDWOPT=-1 Q
S:DDWCHG?1L.E DDWCHG(1)=$$UC($E(DDWCHG))_$E(DDWCHG,2,999)
;
F D OPT Q:DDWOPT]""
Q
;
OPT ;Prompt for and process option
W $P(DDGLVID,DDGLDEL,6)
F D Q:DDWOPT]""
. D CUP(DDWMR+4,15) W " "_$C(8)
. R DDWOPT#1:DTIME E S DDWOPT="Q" Q
. I DDWOPT=U S DDWOPT="Q"
. I DDWOPT="" S DDWOPT="E" Q
. I DDWOPT="?" S DDWOPT="H" Q
. S DDWOPT=$$UC(DDWOPT)
. I "^F^R^A^Q^"'[(U_DDWOPT_U) W $C(7) S DDWOPT=""
D CUP(DDWMR+4,15) W $P(DDGLVID,DDGLDEL,10)_" "
D @DDWOPT
Q
;
F ;Find next
D FINDT^DDWF(DDWFIND)
S DDWOPT=""
Q
;
R ;Replace
N DDWE
I '$D(DDWMARK) D CERR Q
D RS(.DDWE) Q:$G(DDWE)
D F
Q
;
RS(DDWE) ;Change selected text
N DDWDIF
S DDWDIF=$L(DDWCHG)-$P(DDWMARK,U,4)+$P(DDWMARK,U,2)-1
I $L(DDWN)+DDWDIF>245 D Q
. S DDWE=1,DDWOPT=""
. D MSG($C(7)_$$EZBLD^DIALOG(347)) ;**TOO LONG
;
S DDWE=0,DDWED=1
S $E(DDWN,$P(DDWMARK,U,2),$P(DDWMARK,U,4))=$S($E(DDWN,$P(DDWMARK,U,2))?1U:$G(DDWCHG(1),DDWCHG),1:DDWCHG)
S DDWL(DDWRW)=DDWN
D CUP(DDWRW,1) W $P(DDGLCLR,DDGLDEL)_$E(DDWN,1+DDWOFS,IOM+DDWOFS)
K DDWMARK D IND^DDW7()
D POS(DDWRW,DDWC+DDWDIF,"R")
Q
;
A ;Change all
N DDWE,DDWF,DDWI,DDWND,DDWX
D MSG^DDW("...") ;**'CHANGING TEXT'
I $D(DDWMARK) D RS(.DDWE) G:$G(DDWE) AEND
;
S DDWX=$F($$UC(DDWL(DDWRW)),DDWT,DDWC)
I DDWX D
. S DDWL(DDWRW)=$$REP(DDWL(DDWRW),DDWFIND,.DDWCHG,DDWX,.DDWE),DDWF=1
. S:$G(DDWE) DDWE=DDWRW+DDWA_U_DDWE
;
I '$G(DDWE) F DDWI=DDWRW+1:1:DDWMR D Q:$G(DDWE)
. S DDWX=$F($$UC(DDWL(DDWI)),DDWT)
. S:DDWX DDWL(DDWI)=$$REP(DDWL(DDWI),DDWFIND,.DDWCHG,DDWX,.DDWE),DDWF=1
. S:$G(DDWE) DDWE=DDWI+DDWA_U_DDWE
;
I '$G(DDWE) F DDWI=DDWSTB:-1:1 D Q:$G(DDWE)
. S DDWND=^TMP("DDW1",$J,DDWI)
. S DDWX=$F($$UC(DDWND),DDWT)
. S:DDWX ^TMP("DDW1",$J,DDWI)=$$REP(DDWND,DDWFIND,.DDWCHG,DDWX,.DDWE),DDWF=1
. S:$G(DDWE) DDWE=DDWA+DDWMR+DDWSTB-DDWI+1_U_DDWE
;
I $G(DDWF) D
TOOLONG . D:$G(DDWE) MSG^DDW($C(7)_$$EZBLD^DIALOG(347)) H 2 ;**
. F DDWI=1:1:$$MIN(DDWMR,DDWCNT-DDWA) D
.. D CUP(DDWI,1)
.. W $P(DDGLCLR,DDGLDEL)_$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)
. D:$G(DDWE) LINE^DDWG(+DDWE,1),POS(DDWRW,$P(DDWE,U,2),"R")
E D MSG^DDW("Text not found.") H 2 D FLUSH
;
AEND D MSG^DDW(),CUP(DDWRW,DDWC)
S DDWOPT=$S($G(DDWE):-1,1:"")
Q
;
REP(DDWND,DDWFIND,DDWCHG,DDWX,DDWE) ;String replacement of DDWND
N DDWDIF,DDWFST,DDWSV
S DDWDIF=$L(DDWCHG)-$L(DDWFIND)
F D Q:'DDWX!$G(DDWE)
. S DDWSV=DDWND,DDWFST=DDWX-$L(DDWFIND)
. I $L(DDWND)+DDWDIF>245 S DDWE=DDWFST Q
. S $E(DDWND,DDWFST,DDWX-1)=$S($E(DDWND,DDWFST)?1U:$G(DDWCHG(1),DDWCHG),1:DDWCHG)
. S DDWX=DDWX+DDWDIF
. S DDWX=$F($$UC(DDWND),DDWFIND,DDWX)
Q $S($G(DDWE):DDWSV,1:DDWND)
;
E ;Edit Find
D FLUSH
Q
;
Q ;Quit option
D FLUSH
S DDWOPT=-1
Q
;
H ;Help
D MSG("Press the highlighted letter of one of the Options.")
S DDWOPT=""
Q
;
CERR ;The Change options are disabled
D MSG($C(7)_"You must Find the text before you can Change it.")
S DDWOPT=""
Q
;
MSG(DDWX) ;
D CUP(DDWMR+5,1) W $P(DDGLCLR,DDGLDEL)_$G(DDWX) H 2
D CUP(DDWMR+5,1) W $P(DDGLCLR,DDGLDEL)
D FLUSH
Q
;
FLUSH ;Flush read buffer
N DDWX F R *DDWX:0 E Q
Q
;
UC(X) ;Return uppercase of X
Q $$UP^DILIBF(X) ;**
;
MIN(X,Y) ;
Q $S(X<Y:X,1:Y)
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDWC 4393 printed Apr 09, 2024@21:48:33 Page 2
DDWC ;SFISC/MKO-CHANGE (REPLACE) ;02:24 PM 14 Aug 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 ;
CHG ;Change
+1 NEW DDWOPT
+2 DO SETUP^DDWC1
+3 FOR
DO PROC
if DDWOPT=-1
QUIT
+4 DO RESTORE^DDWC1
+5 KILL DDWCHG(1)
+6 QUIT
+7 ;
PROC ;Main procedure
+1 NEW DDWCOD,DDWT
+2 ;
+3 if $DATA(DDWMARK)
DO UNMARK^DDW7
+4 DO EN^DIR0(IOTM+DDWMR,14,30,"",$GET(DDWFIND),100,"","","AKTW",.DDWT,.DDWCOD)
+5 IF DDWT=""!($PIECE(DDWCOD,U)="TO")
SET DDWOPT=-1
QUIT
+6 SET DDWFIND=DDWT
SET DDWT=$$UC(DDWT)
+7 ;
+8 KILL DDWCHG(1)
+9 DO EN^DIR0(IOTM+DDWMR+1,14,30,"",$GET(DDWCHG),100,"","","AKTW",.DDWCHG,.DDWCOD)
+10 IF $PIECE(DDWCOD,U)="TO"
SET DDWOPT=-1
QUIT
+11 if DDWCHG?1L.E
SET DDWCHG(1)=$$UC($EXTRACT(DDWCHG))_$EXTRACT(DDWCHG,2,999)
+12 ;
+13 FOR
DO OPT
if DDWOPT]""
QUIT
+14 QUIT
+15 ;
OPT ;Prompt for and process option
+1 WRITE $PIECE(DDGLVID,DDGLDEL,6)
+2 FOR
Begin DoDot:1
+3 DO CUP(DDWMR+4,15)
WRITE " "_$CHAR(8)
+4 READ DDWOPT#1:DTIME
IF '$TEST
SET DDWOPT="Q"
QUIT
+5 IF DDWOPT=U
SET DDWOPT="Q"
+6 IF DDWOPT=""
SET DDWOPT="E"
QUIT
+7 IF DDWOPT="?"
SET DDWOPT="H"
QUIT
+8 SET DDWOPT=$$UC(DDWOPT)
+9 IF "^F^R^A^Q^"'[(U_DDWOPT_U)
WRITE $CHAR(7)
SET DDWOPT=""
End DoDot:1
if DDWOPT]""
QUIT
+10 DO CUP(DDWMR+4,15)
WRITE $PIECE(DDGLVID,DDGLDEL,10)_" "
+11 DO @DDWOPT
+12 QUIT
+13 ;
F ;Find next
+1 DO FINDT^DDWF(DDWFIND)
+2 SET DDWOPT=""
+3 QUIT
+4 ;
R ;Replace
+1 NEW DDWE
+2 IF '$DATA(DDWMARK)
DO CERR
QUIT
+3 DO RS(.DDWE)
if $GET(DDWE)
QUIT
+4 DO F
+5 QUIT
+6 ;
RS(DDWE) ;Change selected text
+1 NEW DDWDIF
+2 SET DDWDIF=$LENGTH(DDWCHG)-$PIECE(DDWMARK,U,4)+$PIECE(DDWMARK,U,2)-1
+3 IF $LENGTH(DDWN)+DDWDIF>245
Begin DoDot:1
+4 SET DDWE=1
SET DDWOPT=""
+5 ;**TOO LONG
DO MSG($CHAR(7)_$$EZBLD^DIALOG(347))
End DoDot:1
QUIT
+6 ;
+7 SET DDWE=0
SET DDWED=1
+8 SET $EXTRACT(DDWN,$PIECE(DDWMARK,U,2),$PIECE(DDWMARK,U,4))=$SELECT($EXTRACT(DDWN,$PIECE(DDWMARK,U,2))?1U:$GET(DDWCHG(1),DDWCHG),1:DDWCHG)
+9 SET DDWL(DDWRW)=DDWN
+10 DO CUP(DDWRW,1)
WRITE $PIECE(DDGLCLR,DDGLDEL)_$EXTRACT(DDWN,1+DDWOFS,IOM+DDWOFS)
+11 KILL DDWMARK
DO IND^DDW7()
+12 DO POS(DDWRW,DDWC+DDWDIF,"R")
+13 QUIT
+14 ;
A ;Change all
+1 NEW DDWE,DDWF,DDWI,DDWND,DDWX
+2 ;**'CHANGING TEXT'
DO MSG^DDW("...")
+3 IF $DATA(DDWMARK)
DO RS(.DDWE)
if $GET(DDWE)
GOTO AEND
+4 ;
+5 SET DDWX=$FIND($$UC(DDWL(DDWRW)),DDWT,DDWC)
+6 IF DDWX
Begin DoDot:1
+7 SET DDWL(DDWRW)=$$REP(DDWL(DDWRW),DDWFIND,.DDWCHG,DDWX,.DDWE)
SET DDWF=1
+8 if $GET(DDWE)
SET DDWE=DDWRW+DDWA_U_DDWE
End DoDot:1
+9 ;
+10 IF '$GET(DDWE)
FOR DDWI=DDWRW+1:1:DDWMR
Begin DoDot:1
+11 SET DDWX=$FIND($$UC(DDWL(DDWI)),DDWT)
+12 if DDWX
SET DDWL(DDWI)=$$REP(DDWL(DDWI),DDWFIND,.DDWCHG,DDWX,.DDWE)
SET DDWF=1
+13 if $GET(DDWE)
SET DDWE=DDWI+DDWA_U_DDWE
End DoDot:1
if $GET(DDWE)
QUIT
+14 ;
+15 IF '$GET(DDWE)
FOR DDWI=DDWSTB:-1:1
Begin DoDot:1
+16 SET DDWND=^TMP("DDW1",$JOB,DDWI)
+17 SET DDWX=$FIND($$UC(DDWND),DDWT)
+18 if DDWX
SET ^TMP("DDW1",$JOB,DDWI)=$$REP(DDWND,DDWFIND,.DDWCHG,DDWX,.DDWE)
SET DDWF=1
+19 if $GET(DDWE)
SET DDWE=DDWA+DDWMR+DDWSTB-DDWI+1_U_DDWE
End DoDot:1
if $GET(DDWE)
QUIT
+20 ;
+21 IF $GET(DDWF)
Begin DoDot:1
TOOLONG ;**
if $GET(DDWE)
DO MSG^DDW($CHAR(7)_$$EZBLD^DIALOG(347))
HANG 2
+1 FOR DDWI=1:1:$$MIN(DDWMR,DDWCNT-DDWA)
Begin DoDot:2
+2 DO CUP(DDWI,1)
+3 WRITE $PIECE(DDGLCLR,DDGLDEL)_$EXTRACT(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)
End DoDot:2
+4 if $GET(DDWE)
DO LINE^DDWG(+DDWE,1)
DO POS(DDWRW,$PIECE(DDWE,U,2),"R")
End DoDot:1
+5 IF '$TEST
DO MSG^DDW("Text not found.")
HANG 2
DO FLUSH
+6 ;
AEND DO MSG^DDW()
DO CUP(DDWRW,DDWC)
+1 SET DDWOPT=$SELECT($GET(DDWE):-1,1:"")
+2 QUIT
+3 ;
REP(DDWND,DDWFIND,DDWCHG,DDWX,DDWE) ;String replacement of DDWND
+1 NEW DDWDIF,DDWFST,DDWSV
+2 SET DDWDIF=$LENGTH(DDWCHG)-$LENGTH(DDWFIND)
+3 FOR
Begin DoDot:1
+4 SET DDWSV=DDWND
SET DDWFST=DDWX-$LENGTH(DDWFIND)
+5 IF $LENGTH(DDWND)+DDWDIF>245
SET DDWE=DDWFST
QUIT
+6 SET $EXTRACT(DDWND,DDWFST,DDWX-1)=$SELECT($EXTRACT(DDWND,DDWFST)?1U:$GET(DDWCHG(1),DDWCHG),1:DDWCHG)
+7 SET DDWX=DDWX+DDWDIF
+8 SET DDWX=$FIND($$UC(DDWND),DDWFIND,DDWX)
End DoDot:1
if 'DDWX!$GET(DDWE)
QUIT
+9 QUIT $SELECT($GET(DDWE):DDWSV,1:DDWND)
+10 ;
E ;Edit Find
+1 DO FLUSH
+2 QUIT
+3 ;
Q ;Quit option
+1 DO FLUSH
+2 SET DDWOPT=-1
+3 QUIT
+4 ;
H ;Help
+1 DO MSG("Press the highlighted letter of one of the Options.")
+2 SET DDWOPT=""
+3 QUIT
+4 ;
CERR ;The Change options are disabled
+1 DO MSG($CHAR(7)_"You must Find the text before you can Change it.")
+2 SET DDWOPT=""
+3 QUIT
+4 ;
MSG(DDWX) ;
+1 DO CUP(DDWMR+5,1)
WRITE $PIECE(DDGLCLR,DDGLDEL)_$GET(DDWX)
HANG 2
+2 DO CUP(DDWMR+5,1)
WRITE $PIECE(DDGLCLR,DDGLDEL)
+3 DO FLUSH
+4 QUIT
+5 ;
FLUSH ;Flush read buffer
+1 NEW DDWX
FOR
READ *DDWX:0
IF '$TEST
QUIT
+2 QUIT
+3 ;
UC(X) ;Return uppercase of X
+1 ;**
QUIT $$UP^DILIBF(X)
+2 ;
MIN(X,Y) ;
+1 QUIT $SELECT(X<Y:X,1:Y)
+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
