DIWE3 ;SFISC/GFT-WP - MOVE, DELETE, REPEAT, TRANSFER ;12:49 PM 5 Oct 1999 [ 04/02/2003 8:25 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;**8**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
M ;MOVE
S DWAFT=1 G 1:X=U,OPT:'X S (DW1,DW3)=0 D MOVE Q:$D(DTOUT) S:DW1>DW3 DW1=DW1+I,DW2=DW2+I D DEL:DW1
1 G ^DIWE1
;
OPT W ! G OPT^DIWE1
;
R ;REPEAT
S DWAFT=1 G 1:X=U,OPT:'X D MOVE
G 1
;
D ;DELETE
S DW1=X G 1:X=U,OPT:'X W " thru: "_DW1_"// " R DW2:DTIME S:'$T DTOUT=1
G 1:DW2=U!'$T S:DW2="" DW2=DW1 I DW1>DW2 W $C(7),"??" G OPT
I DW2>DWLC S DW2=DWLC W " ("_DW2_")"
S X=DW2-DW1+1,%=2 W !,"OK TO REMOVE "_X_" LINE"_$E("S",X>1)
D YN^DICN I %-1 W " <NOTHING DELETED>" G 1
S %=2 I DW1=1,DW2=DWLC W !,$C(7),"ARE YOU SURE YOU WANT TO DELETE THIS ENTIRE TEXT" D YN^DICN G 1:%-1
D DEL K DWL G 1
;
F R !,"From line: ",DWL:DTIME S:'$T DTOUT=1 G Q:DWL=U!'$T
I DWL?."?" D H G F
I +DWL'=DWL W $C(7)," ?? Please enter a number." G F
MOVE R " thru: ",DW2:DTIME S:'$T DTOUT=1 G Q:DW2=U!'$T S DW1=DWL
I $E(DW2)="E"!($E(DW2)="e") S DW2=9999999
I 'DW2 S DW2=DW1 W " (",DW1,")"
S %=2 G YN:'DWAFT R " after line: ",DW3:DTIME S:'$T DTOUT=1 G Q:DW3=U!'$T
I DW1-1<DW3,DW2>DW3 G Q
I DW1<1!(DW2>DWLC)!(DW1>DW2)!(DW3<0)!(DW3>DWLC)!(+DW3'=DW3) G Q
YN W !,"ARE YOU SURE" D YN^DICN
G Q:%-1 K ^UTILITY($J,"W") S I=0
I DWAFT?.N X "S J=DW1-.1 F S J=$O("_DIC_"J)) Q:J>DW2!(J'>0) I $D(^(J,0)) S X=^(0) D O" S:J="" J=-1 G DN
I DW1>DW2 G Q
N % S %=DW1-1 F S %=$O(^TMP($J,"DIWE3",%)) Q:%'>0!(%>DW2) I $D(^(%,0))#2 S X=^(0) D O
DN G Q:'I X "F J=DWLC:-1:DW3+1 S "_DIC_"J+I,0)="_DIC_"J,0)","F J=1:1:I S "_DIC_"DW3+J,0)=^UTILITY($J,""W"",J,0) W ""."""
K ^UTILITY($J,"W"),DWL,X,DICMX,^TMP($J,"DIWE3") S DWLC=DWLC+I,@(DIC_"0)")=DWLC Q
DEL S I=+DW1
X "F J=DW2+1:1:DWLC S "_DIC_"I,0)="_DIC_"J,0),I=I+1 W ""."""
S I=DW2-DW1
X "F J=DWLC-I:1:DWLC K "_DIC_"J) W ""."""
S DWLC=DWLC-I-1 Q
H N DIR,X,Y,DIRUT,%
S DIR(0)="E"
F %=1:1 Q:'$D(^TMP($J,"DIWE3",%)) S X=$G(^(%,0)) W !,$J(%,3),">",X I %#15=0 D ^DIR Q:X=U!$D(DIRUT)
Q
Q W " <NO CHANGE>",$C(7) S DW1=0 K DWL,X,DICMX,DWAFT Q
O S I=I+1,^UTILITY($J,"W",I,0)=X Q
Z ;
Q:X=""!(X[U)!(X>DWLC) S DW3=X
N VAL,FILE,FLD,WPROOT,IENS,ARR,RT,FI,FD,WPRT,IEN S FI=0,RT=DIC
D RT(RT,"ARR") I $G(ARR)=U G Z0
S FI=ARR("FILE"),FD=ARR("FLDNO"),WPRT=ARR("ROOT"),IEN=ARR("IENS")
Z0 N MSG S MSG="",FILE=FI,FLD=$G(FD),WPROOT=$G(WPRT),IENS=$G(IEN)
R !,"From what text: ",VAL:DTIME I '$T!(U[VAL)!(VAL="") S DUOUT=1 Q
I VAL?1."?" D G Z0
.N X,Y,D,DIC,DIR,DZ,DIX,DIY,DIZ,DO,DD
.W !! I $G(FILE)=3.9 W ?5,"Enter the message number or SUBJECT of another mailman message, OR ",!
.I FILE,FILE'=3.9 W ?5,"Select another entry in this file OR"
.W !?5,"Use relational syntax to pick up information from a word-processing",!?5,"field in another file.",!
.W ?5,"ex. ""VALUE"":FILE NAME:WORD PROCESSING FIELD NAME",!
.I FILE D
..W !,"Do you want the entire "_$O(^DD(FILE,0,"NM",0))_" list?"
..S DZ="??" S DIR(0)="Y" D ^DIR Q:'Y
..S DIC=WPROOT,DIC(0)="QEM",D="B" D DQ^DICQ
..Q
.Q
I VAL'[":",'FILE S MSG="SELECT FILE TO TRANSFER FROM" D Q0 G Z0
I VAL[":" D PRSREL I MSG]"" D Q0 G Z0
D DIC I MSG]"" D Q0 G Z0
I FILE=3.9 S Y=+IENS D XM(.Y) Q:'Y S IENS=+Y_","
D GET1 I MSG]"" D Q0 G Z0
S DWAFT=U D F
Q
RT(DIROOT,DIARR) ;
N QL,CROOT,FILE,GL,OK,RT,TOPFILE
Q:$G(DIROOT)=""
S CROOT=$NA(@$$CREF^DILF(DIROOT))
S:$G(DIARR)="" DIARR=$NA(^TMP($J,DIROOT))
K @DIARR
;
S QL=$QL(CROOT)
I QL>1 D
. S RT=$NA(@CROOT,QL-2),FILE=+$P($G(@RT@(0)),U,2),RT=$$OREF^DILF(RT)
. I FILE,$D(^DD(FILE,0))#2 D
.. S TOPFILE=$$FNO^DILIBF(FILE)
.. I TOPFILE D
... S GL=$G(^DIC(TOPFILE,0,"GL"))
... I GL]"",RT[GL S OK=1 D RT1
S:'$G(OK) @DIARR=U
Q
RT1 ;
N %,FLD,IENS,NOD,X,Y
S @DIARR@("FILE")=FILE
S @DIARR@("TOPFILE")=TOPFILE
S @DIARR@("ROOT")=RT
;
S NOD=$QS(CROOT,QL),FLD=$O(^DD(FILE,"GL",NOD,0,""))
I FLD,$P($P($G(^DD(FILE,FLD,0)),U,4),";")=NOD S @DIARR@("FLDNO")=FLD
;
S IENS="" F %=QL-3:-2:1 S IENS=IENS_$QS(CROOT,%)_","
S @DIARR@("IENS")=IENS
Q
;
PRSREL N X,FTYPE,T,M,W,I,FI,FD,WPRT S X=VAL
S T=$F(X," IN ") I T S X=$E(X,1,T-5),W=":",M=T-4,I=X_W_$E(VAL,T,999),T=$F(I," FILE",M) S:T&$F(W,$E(I,T)) I=$E(I,1,T-6)_$E(I,T,999) S X=I
S VAL=$P(X,":"),FI=$P(X,":",2),FD=$P(X,":",3)
I 'VAL,VAL'?1"`".N,VAL'?1"""".E1"""" S MSG="INVALID SYNTAX" Q
I $E(VAL)=$C(34) D
. I VAL?3"""".E3"""" S @("VAL="_VAL) Q
. S VAL=$E(VAL,2,$L(VAL)-1)
S FI=$S(FI="":0,FI&($G(^DIC(FI,0))]""):FI,FI'?.N:$O(^DIC("B",FI,"")),1:0)
I 'FI S MSG="INVALID FILE" Q
D DIAC I 'FI S MSG="NO READ ACCESS TO FILE" Q
S FD=$S(FD:FD,FD'?.N:$O(^DD(FI,"B",FD,"")),1:0)
I 'FD!('$D(^DD(FI,+FD,0))) S MSG="INVALID FIELD" Q
I FD S FTYPE=$P($G(^DD(+$P($G(^DD(FI,FD,0)),U,2),.01,0)),U,2) I FTYPE'["W" S MSG="NOT A WORD PROCESSING FLD" Q
I FTYPE["L" D
.N DIR,X,Y
.W $C(7),!!,"WARNING!",!,"The field you are transferring text from displays text without wrapping."
.W !,"The field you are transferring text into may display text differently."
.W !!,"Do you want to continue?",! N X,Y,DIR S DIR(0)="Y" D ^DIR
.W ! S:'Y MSG="TEXT TRANSFER CANCELLED" Q
S:MSG="" FILE=FI,FLD=FD,WPROOT=$G(^DIC(FI,0,"GL")) Q
DIC N X,DIC,Y
S DIC=WPROOT,X=VAL,DIC(0)="QEM" D ^DIC
I Y<0 S MSG="NO RECORD FOUND" Q
I IENS]"" S IENS=+Y_","_IENS
E S IENS=+Y_","
Q
GET1 N X K ^TMP($J,"DIWE3")
S X=$$GET1^DIQ(FILE,IENS,FLD,"Z","^TMP($J,""DIWE3"")")
I $D(^TMP($J,"DIWE3")) Q
S MSG="NO TEXT TO TRANSFER FROM"
Q
NW N DIR,X,Y
W $C(7),!!,"WARNING!",!,"The field you are transferring text from displays text without wrapping."
W !,"The field you are transferring text into may display text differently."
W !!,"Do you want to continue?",! N X,Y,DIR S DIR(0)="Y" D ^DIR
W ! S:'Y MSG="TEXT TRANSFER CANCELLED" Q
Q0 W " <"_MSG_">",$C(7) Q
DIAC I FI=3.9 Q
N DIAC,DIFILE
S DIAC="RD",DIFILE=FI
D ^DIAC S:'DIAC FI=0
Q
XM(Z) N %,A9,XMZ,ARR,MSG,A1
S A1=Z
% W !,"Transfer which Response: Original Message// " R A9:DTIME I A9[U S MSG="TEXT TRANSFER CANCELLED",Z=0 D Q0 Q
I A9?1."?" S XMZ=+Z D ENT8^XMAH S Z=A1 G %
I A9=""!(A9=0)!(A9="O") Q
I A9 D Q:Z
. N A0 S %=$$HDR^XMGAPI2(+Y,.ARR,9) S A0=$G(ARR("RSP",A9))
. I A0 S Z=A0 Q
. S MSG="INVALID RESPONSE",Z=0 D Q0
S Z=A1 G %
DIWE3 ;SFISC/GFT-WP - MOVE, DELETE, REPEAT, TRANSFER ;12:49 PM 5 Oct 1999 [ 04/02/2003 8:25 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;**8**;Mar 30, 1999
+3 ;Per VHA Directive 10-93-142, this routine should not be modified.
M ;MOVE
+1 SET DWAFT=1
IF X=U
GOTO 1
IF 'X
GOTO OPT
SET (DW1,DW3)=0
DO MOVE
IF $DATA(DTOUT)
QUIT
IF DW1>DW3
SET DW1=DW1+I
SET DW2=DW2+I
IF DW1
DO DEL
1 GOTO ^DIWE1
+1 ;
OPT WRITE !
GOTO OPT^DIWE1
+1 ;
R ;REPEAT
+1 SET DWAFT=1
IF X=U
GOTO 1
IF 'X
GOTO OPT
DO MOVE
+2 GOTO 1
+3 ;
D ;DELETE
+1 SET DW1=X
IF X=U
GOTO 1
IF 'X
GOTO OPT
WRITE " thru: "_DW1_"// "
READ DW2:DTIME
IF '$TEST
SET DTOUT=1
+2 IF DW2=U!'$TEST
GOTO 1
IF DW2=""
SET DW2=DW1
IF DW1>DW2
WRITE $CHAR(7),"??"
GOTO OPT
+3 IF DW2>DWLC
SET DW2=DWLC
WRITE " ("_DW2_")"
+4 SET X=DW2-DW1+1
SET %=2
WRITE !,"OK TO REMOVE "_X_" LINE"_$EXTRACT("S",X>1)
+5 DO YN^DICN
IF %-1
WRITE " <NOTHING DELETED>"
GOTO 1
+6 SET %=2
IF DW1=1
IF DW2=DWLC
WRITE !,$CHAR(7),"ARE YOU SURE YOU WANT TO DELETE THIS ENTIRE TEXT"
DO YN^DICN
IF %-1
GOTO 1
+7 DO DEL
KILL DWL
GOTO 1
+8 ;
F READ !,"From line: ",DWL:DTIME
IF '$TEST
SET DTOUT=1
IF DWL=U!'$TEST
GOTO Q
+1 IF DWL?."?"
DO H
GOTO F
+2 IF +DWL'=DWL
WRITE $CHAR(7)," ?? Please enter a number."
GOTO F
MOVE READ " thru: ",DW2:DTIME
IF '$TEST
SET DTOUT=1
IF DW2=U!'$TEST
GOTO Q
SET DW1=DWL
+1 IF $EXTRACT(DW2)="E"!($EXTRACT(DW2)="e")
SET DW2=9999999
+2 IF 'DW2
SET DW2=DW1
WRITE " (",DW1,")"
+3 SET %=2
IF 'DWAFT
GOTO YN
READ " after line: ",DW3:DTIME
IF '$TEST
SET DTOUT=1
IF DW3=U!'$TEST
GOTO Q
+4 IF DW1-1<DW3
IF DW2>DW3
GOTO Q
+5 IF DW1<1!(DW2>DWLC)!(DW1>DW2)!(DW3<0)!(DW3>DWLC)!(+DW3'=DW3)
GOTO Q
YN WRITE !,"ARE YOU SURE"
DO YN^DICN
+1 IF %-1
GOTO Q
KILL ^UTILITY($JOB,"W")
SET I=0
+2 IF DWAFT?.N
XECUTE "S J=DW1-.1 F S J=$O("_DIC_"J)) Q:J>DW2!(J'>0) I $D(^(J,0)) S X=^(0) D O"
IF J=""
SET J=-1
GOTO DN
+3 IF DW1>DW2
GOTO Q
+4 NEW %
SET %=DW1-1
FOR
SET %=$ORDER(^TMP($JOB,"DIWE3",%))
IF %'>0!(%>DW2)
QUIT
IF $DATA(^(%,0))#2
SET X=^(0)
DO O
DN IF 'I
GOTO Q
XECUTE "F J=DWLC:-1:DW3+1 S "_DIC_"J+I,0)="_DIC_"J,0)"
XECUTE "F J=1:1:I S "_DIC_"DW3+J,0)=^UTILITY($J,""W"",J,0) W ""."""
+1 KILL ^UTILITY($JOB,"W"),DWL,X,DICMX,^TMP($JOB,"DIWE3")
SET DWLC=DWLC+I
SET @(DIC_"0)")=DWLC
QUIT
DEL SET I=+DW1
+1 XECUTE "F J=DW2+1:1:DWLC S "_DIC_"I,0)="_DIC_"J,0),I=I+1 W ""."""
+2 SET I=DW2-DW1
+3 XECUTE "F J=DWLC-I:1:DWLC K "_DIC_"J) W ""."""
+4 SET DWLC=DWLC-I-1
QUIT
H NEW DIR,X,Y,DIRUT,%
+1 SET DIR(0)="E"
+2 FOR %=1:1
IF '$DATA(^TMP($JOB,"DIWE3",%))
QUIT
SET X=$GET(^(%,0))
WRITE !,$JUSTIFY(%,3),">",X
IF %#15=0
DO ^DIR
IF X=U!$DATA(DIRUT)
QUIT
+3 QUIT
Q WRITE " <NO CHANGE>",$CHAR(7)
SET DW1=0
KILL DWL,X,DICMX,DWAFT
QUIT
O SET I=I+1
SET ^UTILITY($JOB,"W",I,0)=X
QUIT
Z ;
+1 IF X=""!(X[U)!(X>DWLC)
QUIT
SET DW3=X
+2 NEW VAL,FILE,FLD,WPROOT,IENS,ARR,RT,FI,FD,WPRT,IEN
SET FI=0
SET RT=DIC
+3 DO RT(RT,"ARR")
IF $GET(ARR)=U
GOTO Z0
+4 SET FI=ARR("FILE")
SET FD=ARR("FLDNO")
SET WPRT=ARR("ROOT")
SET IEN=ARR("IENS")
Z0 NEW MSG
SET MSG=""
SET FILE=FI
SET FLD=$GET(FD)
SET WPROOT=$GET(WPRT)
SET IENS=$GET(IEN)
+1 READ !,"From what text: ",VAL:DTIME
IF '$TEST!(U[VAL)!(VAL="")
SET DUOUT=1
QUIT
+2 IF VAL?1."?"
Begin DoDot:1
+3 NEW X,Y,D,DIC,DIR,DZ,DIX,DIY,DIZ,DO,DD
+4 WRITE !!
IF $GET(FILE)=3.9
WRITE ?5,"Enter the message number or SUBJECT of another mailman message, OR ",!
+5 IF FILE
IF FILE'=3.9
WRITE ?5,"Select another entry in this file OR"
+6 WRITE !?5,"Use relational syntax to pick up information from a word-processing",!?5,"field in another file.",!
+7 WRITE ?5,"ex. ""VALUE"":FILE NAME:WORD PROCESSING FIELD NAME",!
+8 IF FILE
Begin DoDot:2
+9 WRITE !,"Do you want the entire "_$ORDER(^DD(FILE,0,"NM",0))_" list?"
+10 SET DZ="??"
SET DIR(0)="Y"
DO ^DIR
IF 'Y
QUIT
+11 SET DIC=WPROOT
SET DIC(0)="QEM"
SET D="B"
DO DQ^DICQ
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
GOTO Z0
+14 IF VAL'[":"
IF 'FILE
SET MSG="SELECT FILE TO TRANSFER FROM"
DO Q0
GOTO Z0
+15 IF VAL[":"
DO PRSREL
IF MSG]""
DO Q0
GOTO Z0
+16 DO DIC
IF MSG]""
DO Q0
GOTO Z0
+17 IF FILE=3.9
SET Y=+IENS
DO XM(.Y)
IF 'Y
QUIT
SET IENS=+Y_","
+18 DO GET1
IF MSG]""
DO Q0
GOTO Z0
+19 SET DWAFT=U
DO F
+20 QUIT
RT(DIROOT,DIARR) ;
+1 NEW QL,CROOT,FILE,GL,OK,RT,TOPFILE
+2 IF $GET(DIROOT)=""
QUIT
+3 SET CROOT=$NAME(@$$CREF^DILF(DIROOT))
+4 IF $GET(DIARR)=""
SET DIARR=$NAME(^TMP($JOB,DIROOT))
+5 KILL @DIARR
+6 ;
+7 SET QL=$QLENGTH(CROOT)
+8 IF QL>1
Begin DoDot:1
+9 SET RT=$NAME(@CROOT,QL-2)
SET FILE=+$PIECE($GET(@RT@(0)),U,2)
SET RT=$$OREF^DILF(RT)
+10 IF FILE
IF $DATA(^DD(FILE,0))#2
Begin DoDot:2
+11 SET TOPFILE=$$FNO^DILIBF(FILE)
+12 IF TOPFILE
Begin DoDot:3
+13 SET GL=$GET(^DIC(TOPFILE,0,"GL"))
+14 IF GL]""
IF RT[GL
SET OK=1
DO RT1
End DoDot:3
End DoDot:2
End DoDot:1
+15 IF '$GET(OK)
SET @DIARR=U
+16 QUIT
RT1 ;
+1 NEW %,FLD,IENS,NOD,X,Y
+2 SET @DIARR@("FILE")=FILE
+3 SET @DIARR@("TOPFILE")=TOPFILE
+4 SET @DIARR@("ROOT")=RT
+5 ;
+6 SET NOD=$QSUBSCRIPT(CROOT,QL)
SET FLD=$ORDER(^DD(FILE,"GL",NOD,0,""))
+7 IF FLD
IF $PIECE($PIECE($GET(^DD(FILE,FLD,0)),U,4),";")=NOD
SET @DIARR@("FLDNO")=FLD
+8 ;
+9 SET IENS=""
FOR %=QL-3:-2:1
SET IENS=IENS_$QSUBSCRIPT(CROOT,%)_","
+10 SET @DIARR@("IENS")=IENS
+11 QUIT
+12 ;
PRSREL NEW X,FTYPE,T,M,W,I,FI,FD,WPRT
SET X=VAL
+1 SET T=$FIND(X," IN ")
IF T
SET X=$EXTRACT(X,1,T-5)
SET W=":"
SET M=T-4
SET I=X_W_$EXTRACT(VAL,T,999)
SET T=$FIND(I," FILE",M)
IF T&$FIND(W,$EXTRACT(I,T))
SET I=$EXTRACT(I,1,T-6)_$EXTRACT(I,T,999)
SET X=I
+2 SET VAL=$PIECE(X,":")
SET FI=$PIECE(X,":",2)
SET FD=$PIECE(X,":",3)
+3 IF 'VAL
IF VAL'?1"`".N
IF VAL'?1"""".E1""""
SET MSG="INVALID SYNTAX"
QUIT
+4 IF $EXTRACT(VAL)=$CHAR(34)
Begin DoDot:1
+5 IF VAL?3"""".E3""""
SET @("VAL="_VAL)
QUIT
+6 SET VAL=$EXTRACT(VAL,2,$LENGTH(VAL)-1)
End DoDot:1
+7 SET FI=$SELECT(FI="":0,FI&($GET(^DIC(FI,0))]""):FI,FI'?.N:$ORDER(^DIC("B",FI,"")),1:0)
+8 IF 'FI
SET MSG="INVALID FILE"
QUIT
+9 DO DIAC
IF 'FI
SET MSG="NO READ ACCESS TO FILE"
QUIT
+10 SET FD=$SELECT(FD:FD,FD'?.N:$ORDER(^DD(FI,"B",FD,"")),1:0)
+11 IF 'FD!('$DATA(^DD(FI,+FD,0)))
SET MSG="INVALID FIELD"
QUIT
+12 IF FD
SET FTYPE=$PIECE($GET(^DD(+$PIECE($GET(^DD(FI,FD,0)),U,2),.01,0)),U,2)
IF FTYPE'["W"
SET MSG="NOT A WORD PROCESSING FLD"
QUIT
+13 IF FTYPE["L"
Begin DoDot:1
+14 NEW DIR,X,Y
+15 WRITE $CHAR(7),!!,"WARNING!",!,"The field you are transferring text from displays text without wrapping."
+16 WRITE !,"The field you are transferring text into may display text differently."
+17 WRITE !!,"Do you want to continue?",!
NEW X,Y,DIR
SET DIR(0)="Y"
DO ^DIR
+18 WRITE !
IF 'Y
SET MSG="TEXT TRANSFER CANCELLED"
QUIT
End DoDot:1
+19 IF MSG=""
SET FILE=FI
SET FLD=FD
SET WPROOT=$GET(^DIC(FI,0,"GL"))
QUIT
DIC NEW X,DIC,Y
+1 SET DIC=WPROOT
SET X=VAL
SET DIC(0)="QEM"
DO ^DIC
+2 IF Y<0
SET MSG="NO RECORD FOUND"
QUIT
+3 IF IENS]""
SET IENS=+Y_","_IENS
+4 IF '$TEST
SET IENS=+Y_","
+5 QUIT
GET1 NEW X
KILL ^TMP($JOB,"DIWE3")
+1 SET X=$$GET1^DIQ(FILE,IENS,FLD,"Z","^TMP($J,""DIWE3"")")
+2 IF $DATA(^TMP($JOB,"DIWE3"))
QUIT
+3 SET MSG="NO TEXT TO TRANSFER FROM"
+4 QUIT
NW NEW DIR,X,Y
+1 WRITE $CHAR(7),!!,"WARNING!",!,"The field you are transferring text from displays text without wrapping."
+2 WRITE !,"The field you are transferring text into may display text differently."
+3 WRITE !!,"Do you want to continue?",!
NEW X,Y,DIR
SET DIR(0)="Y"
DO ^DIR
+4 WRITE !
IF 'Y
SET MSG="TEXT TRANSFER CANCELLED"
QUIT
Q0 WRITE " <"_MSG_">",$CHAR(7)
QUIT
DIAC IF FI=3.9
QUIT
+1 NEW DIAC,DIFILE
+2 SET DIAC="RD"
SET DIFILE=FI
+3 DO ^DIAC
IF 'DIAC
SET FI=0
+4 QUIT
XM(Z) NEW %,A9,XMZ,ARR,MSG,A1
+1 SET A1=Z
% WRITE !,"Transfer which Response: Original Message// "
READ A9:DTIME
IF A9[U
SET MSG="TEXT TRANSFER CANCELLED"
SET Z=0
DO Q0
QUIT
+1 IF A9?1."?"
SET XMZ=+Z
DO ENT8^XMAH
SET Z=A1
GOTO %
+2 IF A9=""!(A9=0)!(A9="O")
QUIT
+3 IF A9
Begin DoDot:1
+4 NEW A0
SET %=$$HDR^XMGAPI2(+Y,.ARR,9)
SET A0=$GET(ARR("RSP",A9))
+5 IF A0
SET Z=A0
QUIT
+6 SET MSG="INVALID RESPONSE"
SET Z=0
DO Q0
End DoDot:1
IF Z
QUIT
+7 SET Z=A1
GOTO %
