DDWF ;SFISC/MKO-FIND, REPLACE ;02:43 PM 24 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.
;
NEXT ;Find next occurrence of same text
N DDWT
G:$G(DDWFIND)="" FIND
S DDWT=DDWFIND
D FINDT(DDWT,$G(DDWFIND(1)))
Q
;
FIND ;Prompt and find text
N DDWCOD,DDWF,DDWT
D ASK^DDWG(3,$$EZBLD^DIALOG(8126),30,$G(DDWFIND),"","",.DDWT,.DDWCOD) ;**'FIND WHAT: '
Q:DDWT=""
D FINDT(DDWT,$P($G(DDWCOD),U)="U")
Q
;
FINDT(DDWT,DDWBACK) ;Find DDWT
D:$D(DDWMARK) UNMARK^DDW7
S DDWFIND=DDWT,DDWT=$$UC(DDWT)
I $G(DDWBACK) D
. S DDWFIND(1)=1 D LOOKB
E K DDWFIND(1) D LOOK
Q
;
LOOK ;Look in arrays
N DDWF,DDWI,DDWX
S DDWF=$F($$UC(DDWL(DDWRW)),DDWT,DDWC)
I DDWF D REPOS(DDWRW+DDWA,DDWF,DDWT) Q
;
F DDWI=DDWRW+1:1:DDWMR D Q:DDWF
. S DDWX=$F($$UC(DDWL(DDWI)),DDWT)
. I DDWX D REPOS(DDWI+DDWA,DDWX,DDWT) S DDWF=1
Q:DDWF
;
D MSG^DDW(" ...") ;**
F DDWI=DDWSTB:-1:1 D Q:DDWF
. S DDWX=$F($$UC(^TMP("DDW1",$J,DDWI)),DDWT)
. I DDWX D
.. D MSG^DDW()
.. D REPOS(DDWA+DDWMR+DDWSTB-DDWI+1,DDWX,DDWT)
.. S DDWF=1
Q:DDWF
;
D MSG^DDW($$EZBLD^DIALOG(8127)) H 2 ;**'TEXT NOT FOUND'
D MSG^DDW(),CUP(DDWRW,DDWC)
F R *DDWX:0 E Q
Q
;
LOOKB ;Look backward in arrays
N DDWF,DDWI,DDWX
S DDWF=$$RF($E($$UC(DDWL(DDWRW)),1,DDWC-1),DDWT)
I DDWF=DDWC S DDWF=$$RF($E($$UC(DDWL(DDWRW)),1,DDWC-$L(DDWT)-1),DDWT)
I DDWF D REPOS(DDWRW+DDWA,DDWF,DDWT) Q
;
F DDWI=DDWRW-1:-1:1 D Q:DDWF
. S DDWX=$$RF($$UC(DDWL(DDWI)),DDWT)
. I DDWX D REPOS(DDWI+DDWA,DDWX,DDWT) S DDWF=1
Q:DDWF
;
D MSG^DDW(" ...") ;**
F DDWI=DDWA:-1:1 D Q:DDWF
. S DDWX=$$RF($$UC(^TMP("DDW",$J,DDWI)),DDWT)
. I DDWX D
.. D MSG^DDW()
.. D REPOS(DDWI,DDWX,DDWT)
.. S DDWF=1
Q:DDWF
;
D MSG^DDW($$EZBLD^DIALOG(8127)) H 2 ;**'TEXT NOT FOUND'
D MSG^DDW(),CUP(DDWRW,DDWC)
F R *DDWX:0 E Q
Q
;
REPOS(DDWY,DDWX,DDWT) ;Define DDWMARK, paint if on screen
S DDWMARK=DDWY_U_(DDWX-$L(DDWT))_U_DDWY_U_(DDWX-1)
I DDWY-DDWA>0,DDWY-DDWA'>DDWMR,DDWX-DDWOFS>0,DDWX-DDWOFS'>IOM D
. D PAINT^DDW7(DDWMARK,1)
. D POS(DDWY-DDWA,DDWX,"RN")
E D LINE^DDWG(DDWY,DDWX)
D IND^DDW7(1)
Q
;
UC(X) ;Return uppercase of X
Q $$UP^DILIBF(X) ;**
;
RF(X,T) ;Find last occurrence of T in X
N Y
Q:X'[T 0
S Y=1 F S Y=$F(X,T,Y) Q:'$F(X,T,Y)
Q Y
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDWF 2877 printed Dec 13, 2024@02:44:02 Page 2
DDWF ;SFISC/MKO-FIND, REPLACE ;02:43 PM 24 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 ;
NEXT ;Find next occurrence of same text
+1 NEW DDWT
+2 if $GET(DDWFIND)=""
GOTO FIND
+3 SET DDWT=DDWFIND
+4 DO FINDT(DDWT,$GET(DDWFIND(1)))
+5 QUIT
+6 ;
FIND ;Prompt and find text
+1 NEW DDWCOD,DDWF,DDWT
+2 ;**'FIND WHAT: '
DO ASK^DDWG(3,$$EZBLD^DIALOG(8126),30,$GET(DDWFIND),"","",.DDWT,.DDWCOD)
+3 if DDWT=""
QUIT
+4 DO FINDT(DDWT,$PIECE($GET(DDWCOD),U)="U")
+5 QUIT
+6 ;
FINDT(DDWT,DDWBACK) ;Find DDWT
+1 if $DATA(DDWMARK)
DO UNMARK^DDW7
+2 SET DDWFIND=DDWT
SET DDWT=$$UC(DDWT)
+3 IF $GET(DDWBACK)
Begin DoDot:1
+4 SET DDWFIND(1)=1
DO LOOKB
End DoDot:1
+5 IF '$TEST
KILL DDWFIND(1)
DO LOOK
+6 QUIT
+7 ;
LOOK ;Look in arrays
+1 NEW DDWF,DDWI,DDWX
+2 SET DDWF=$FIND($$UC(DDWL(DDWRW)),DDWT,DDWC)
+3 IF DDWF
DO REPOS(DDWRW+DDWA,DDWF,DDWT)
QUIT
+4 ;
+5 FOR DDWI=DDWRW+1:1:DDWMR
Begin DoDot:1
+6 SET DDWX=$FIND($$UC(DDWL(DDWI)),DDWT)
+7 IF DDWX
DO REPOS(DDWI+DDWA,DDWX,DDWT)
SET DDWF=1
End DoDot:1
if DDWF
QUIT
+8 if DDWF
QUIT
+9 ;
+10 ;**
DO MSG^DDW(" ...")
+11 FOR DDWI=DDWSTB:-1:1
Begin DoDot:1
+12 SET DDWX=$FIND($$UC(^TMP("DDW1",$JOB,DDWI)),DDWT)
+13 IF DDWX
Begin DoDot:2
+14 DO MSG^DDW()
+15 DO REPOS(DDWA+DDWMR+DDWSTB-DDWI+1,DDWX,DDWT)
+16 SET DDWF=1
End DoDot:2
End DoDot:1
if DDWF
QUIT
+17 if DDWF
QUIT
+18 ;
+19 ;**'TEXT NOT FOUND'
DO MSG^DDW($$EZBLD^DIALOG(8127))
HANG 2
+20 DO MSG^DDW()
DO CUP(DDWRW,DDWC)
+21 FOR
READ *DDWX:0
IF '$TEST
QUIT
+22 QUIT
+23 ;
LOOKB ;Look backward in arrays
+1 NEW DDWF,DDWI,DDWX
+2 SET DDWF=$$RF($EXTRACT($$UC(DDWL(DDWRW)),1,DDWC-1),DDWT)
+3 IF DDWF=DDWC
SET DDWF=$$RF($EXTRACT($$UC(DDWL(DDWRW)),1,DDWC-$LENGTH(DDWT)-1),DDWT)
+4 IF DDWF
DO REPOS(DDWRW+DDWA,DDWF,DDWT)
QUIT
+5 ;
+6 FOR DDWI=DDWRW-1:-1:1
Begin DoDot:1
+7 SET DDWX=$$RF($$UC(DDWL(DDWI)),DDWT)
+8 IF DDWX
DO REPOS(DDWI+DDWA,DDWX,DDWT)
SET DDWF=1
End DoDot:1
if DDWF
QUIT
+9 if DDWF
QUIT
+10 ;
+11 ;**
DO MSG^DDW(" ...")
+12 FOR DDWI=DDWA:-1:1
Begin DoDot:1
+13 SET DDWX=$$RF($$UC(^TMP("DDW",$JOB,DDWI)),DDWT)
+14 IF DDWX
Begin DoDot:2
+15 DO MSG^DDW()
+16 DO REPOS(DDWI,DDWX,DDWT)
+17 SET DDWF=1
End DoDot:2
End DoDot:1
if DDWF
QUIT
+18 if DDWF
QUIT
+19 ;
+20 ;**'TEXT NOT FOUND'
DO MSG^DDW($$EZBLD^DIALOG(8127))
HANG 2
+21 DO MSG^DDW()
DO CUP(DDWRW,DDWC)
+22 FOR
READ *DDWX:0
IF '$TEST
QUIT
+23 QUIT
+24 ;
REPOS(DDWY,DDWX,DDWT) ;Define DDWMARK, paint if on screen
+1 SET DDWMARK=DDWY_U_(DDWX-$LENGTH(DDWT))_U_DDWY_U_(DDWX-1)
+2 IF DDWY-DDWA>0
IF DDWY-DDWA'>DDWMR
IF DDWX-DDWOFS>0
IF DDWX-DDWOFS'>IOM
Begin DoDot:1
+3 DO PAINT^DDW7(DDWMARK,1)
+4 DO POS(DDWY-DDWA,DDWX,"RN")
End DoDot:1
+5 IF '$TEST
DO LINE^DDWG(DDWY,DDWX)
+6 DO IND^DDW7(1)
+7 QUIT
+8 ;
UC(X) ;Return uppercase of X
+1 ;**
QUIT $$UP^DILIBF(X)
+2 ;
RF(X,T) ;Find last occurrence of T in X
+1 NEW Y
+2 if X'[T
QUIT 0
+3 SET Y=1
FOR
SET Y=$FIND(X,T,Y)
if '$FIND(X,T,Y)
QUIT
+4 QUIT Y
+5 ;
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
