- DIWE3 ;SFISC/GFT-WP - MOVE, DELETE, REPEAT, TRANSFER ;02:10 PM 8 Dec 1999
- ;;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.
- ;
- 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; **CCO/NI MOST LINES FROM HERE TO 'YN' HAVE BEEN CHANGED
- S DW1=X G 1:X=U,OPT:'X W " "_$$EZBLD^DIALOG(8117)_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 !,$$EZBLD^DIALOG(8116,X)
- D YN^DICN I %-1 W " ",$$EZBLD^DIALOG(8114) G 1
- S %=2 I DW1=1,DW2=DWLC W !,$C(7),$$EZBLD^DIALOG(8115) D YN^DICN G 1:%-1
- D DEL K DWL G 1
- ;
- F W !,$$EZBLD^DIALOG(8118) R DWL:DTIME S:'$T DTOUT=1 G Q:DWL=U!'$T ;'FROM LINE: '
- I DWL?."?" D H G F
- I +DWL'=DWL W $C(7)," ?? ",$$EZBLD^DIALOG(8054) G F
- MOVE W " ",$$EZBLD^DIALOG(8117) R DW2:DTIME S:'$T DTOUT=1 G Q:DW2=U!'$T S DW1=DWL ;**CCO/NI 'THRU:'
- I DW2=$$UP^DILIBF($$EZBLD^DIALOG(7097)) S DW2=DWLC ;*CCO/NI "END" FOR END
- I 'DW2 S DW2=DW1 W " (",DW1,")"
- S %=2 G YN:'DWAFT W " ",$$EZBLD^DIALOG(8119) R DW3:DTIME S:'$T DTOUT=1 G Q:DW3=U!'$T ;**CCO/NI 'AFTER LINE:'
- 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 !,$$EZBLD^DIALOG(7050) 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 " ",$$EZBLD^DIALOG(8121) S DW1=0 K DWL,X,DICMX,DWAFT Q ;**CCO/NI 'NO CHANGE'
- O S I=I+1,^UTILITY($J,"W",I,0)=X Q
- ;
- Z ;TRANSFER
- 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)
- W !,$$EZBLD^DIALOG(8131) R VAL:DTIME I '$T!(U[VAL)!(VAL="") S DUOUT=1 Q ;**CCO/NI 'FROM WHAT TEXT'
- I VAL?1."?" D G Z0
- .N X,Y,D,DIC,DIR,DZ,DIX,DIY,DIZ,DO,DD
- .S X=8132 D:$G(FILE)=3.9 S X=8133 D:$G(FILE)-3.9&$G(FILE) S X=8134 D
- ..D BLD^DIALOG(X),MSG^DIALOG("WH")
- .I FILE D
- EGP ..W !,$$EZBLD^DIALOG(8064),$$EZBLD^DIALOG(8066,$O(^DD(FILE,0,"NM",0))),"?" ;**CCO/NI 'WANT THE ENTIRE 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 DIFNM,FIELD,X,FTYPE,T,M,W,I,FI,FD,WPRT S X=VAL ;**CCO/NI
- 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 DIFNM=FI,FI=$S(FI="":0,FI&($G(^DIC(FI,0))]""):FI,FI'?.N:$O(^DIC("B",FI,"")),1:0) ;**CCO/NI REMEMBER FILE NAME
- I 'FI S MSG=$$EZBLD^DIALOG(409,DIFNM) Q ;**CCO/NI INVALID FILE
- ACC D DIAC S FIELD=FD I 'FI S MSG=$$EZBLD^DIALOG(1410) Q ;**CCO/NI " NO READ ACCESS TO FILE"
- S FD=$S(FD:FD,FD'?.N:$O(^DD(FI,"B",FD,"")),1:0)
- I 'FD!('$D(^DD(FI,+FD,0))) S DIFNM("FILE")=FI,DIFNM(1)=FIELD,MSG=$$EZBLD^DIALOG(501,.DIFNM) Q ;**CCO/NI "INVALID FIELD"
- I FD S FTYPE=$P($G(^DD(+$P($G(^DD(FI,FD,0)),U,2),.01,0)),U,2) I FTYPE'["W" S MSG=$$EZBLD^DIALOG(504,FD) Q ;**CCO/NI 'NOT W-P'
- I FTYPE["L" D
- .N DIR,X,Y
- .D BLD^DIALOG(8130),MSG^DIALOG("WM") S DIR(0)="Y" D ^DIR ;**CCO/NI WARNING ABOUT NON-WRAP
- .W ! S:'Y MSG=$$EZBLD^DIALOG(8135) Q ;**CCO/NI 'CANCELLED'
- 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=$$EZBLD^DIALOG(1402) Q ;**CCO/NI "NO RECORD FOUND"
- 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=$$EZBLD^DIALOG(1403) ;**CCO/NI "NO TEXT TO TRANSFER FROM"
- Q
- ;
- Q0 W:$X ! W " <"_MSG_">",$C(7) Q ;**CCO/NI DO LINE FEED
- ;
- 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=$$EZBLD^DIALOG(8135),Z=0 D Q0 Q ;**CCO/NI 'CANCELLED'
- 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=$$EZBLD^DIALOG(1401),Z=0 D Q0 ;**CCO/NI 'INVALID RESPONSE'
- S Z=A1 G %
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIWE3 6476 printed Mar 13, 2025@21:59:47 Page 2
- DIWE3 ;SFISC/GFT-WP - MOVE, DELETE, REPEAT, TRANSFER ;02:10 PM 8 Dec 1999
- +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 ;
- 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; **CCO/NI MOST LINES FROM HERE TO 'YN' HAVE BEEN CHANGED
- +1 SET DW1=X
- if X=U
- GOTO 1
- if 'X
- GOTO OPT
- WRITE " "_$$EZBLD^DIALOG(8117)_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 !,$$EZBLD^DIALOG(8116,X)
- +5 DO YN^DICN
- IF %-1
- WRITE " ",$$EZBLD^DIALOG(8114)
- GOTO 1
- +6 SET %=2
- IF DW1=1
- IF DW2=DWLC
- WRITE !,$CHAR(7),$$EZBLD^DIALOG(8115)
- DO YN^DICN
- if %-1
- GOTO 1
- +7 DO DEL
- KILL DWL
- GOTO 1
- +8 ;
- F ;'FROM LINE: '
- WRITE !,$$EZBLD^DIALOG(8118)
- READ 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)," ?? ",$$EZBLD^DIALOG(8054)
- GOTO F
- MOVE ;**CCO/NI 'THRU:'
- WRITE " ",$$EZBLD^DIALOG(8117)
- READ DW2:DTIME
- if '$TEST
- SET DTOUT=1
- if DW2=U!'$TEST
- GOTO Q
- SET DW1=DWL
- +1 ;*CCO/NI "END" FOR END
- IF DW2=$$UP^DILIBF($$EZBLD^DIALOG(7097))
- SET DW2=DWLC
- +2 IF 'DW2
- SET DW2=DW1
- WRITE " (",DW1,")"
- +3 ;**CCO/NI 'AFTER LINE:'
- SET %=2
- if 'DWAFT
- GOTO YN
- WRITE " ",$$EZBLD^DIALOG(8119)
- READ 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 !,$$EZBLD^DIALOG(7050)
- 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 ;**CCO/NI 'NO CHANGE'
- WRITE " ",$$EZBLD^DIALOG(8121)
- SET DW1=0
- KILL DWL,X,DICMX,DWAFT
- QUIT
- O SET I=I+1
- SET ^UTILITY($JOB,"W",I,0)=X
- QUIT
- +1 ;
- Z ;TRANSFER
- +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 ;**CCO/NI 'FROM WHAT TEXT'
- WRITE !,$$EZBLD^DIALOG(8131)
- READ 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 SET X=8132
- if $GET(FILE)=3.9
- Begin DoDot:2
- +5 DO BLD^DIALOG(X)
- DO MSG^DIALOG("WH")
- End DoDot:2
- SET X=8133
- if $GET(FILE)-3.9&$GET(FILE)
- Begin DoDot:2
- End DoDot:2
- SET X=8134
- Begin DoDot:2
- End DoDot:2
- +6 IF FILE
- Begin DoDot:2
- EGP ;**CCO/NI 'WANT THE ENTIRE LIST'
- WRITE !,$$EZBLD^DIALOG(8064),$$EZBLD^DIALOG(8066,$ORDER(^DD(FILE,0,"NM",0))),"?"
- +1 SET DZ="??"
- SET DIR(0)="Y"
- DO ^DIR
- if 'Y
- QUIT
- +2 SET DIC=WPROOT
- SET DIC(0)="QEM"
- SET D="B"
- DO DQ^DICQ
- +3 QUIT
- End DoDot:2
- +4 QUIT
- End DoDot:1
- GOTO Z0
- +5 IF VAL'[":"
- IF 'FILE
- SET MSG="SELECT FILE TO TRANSFER FROM"
- DO Q0
- GOTO Z0
- +6 IF VAL[":"
- DO PRSREL
- IF MSG]""
- DO Q0
- GOTO Z0
- +7 DO DIC
- IF MSG]""
- DO Q0
- GOTO Z0
- +8 IF FILE=3.9
- SET Y=+IENS
- DO XM(.Y)
- if 'Y
- QUIT
- SET IENS=+Y_","
- +9 DO GET1
- IF MSG]""
- DO Q0
- GOTO Z0
- +10 SET DWAFT=U
- DO F
- +11 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 ;**CCO/NI
- NEW DIFNM,FIELD,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 ;**CCO/NI REMEMBER FILE NAME
- SET DIFNM=FI
- SET FI=$SELECT(FI="":0,FI&($GET(^DIC(FI,0))]""):FI,FI'?.N:$ORDER(^DIC("B",FI,"")),1:0)
- +8 ;**CCO/NI INVALID FILE
- IF 'FI
- SET MSG=$$EZBLD^DIALOG(409,DIFNM)
- QUIT
- ACC ;**CCO/NI " NO READ ACCESS TO FILE"
- DO DIAC
- SET FIELD=FD
- IF 'FI
- SET MSG=$$EZBLD^DIALOG(1410)
- QUIT
- +1 SET FD=$SELECT(FD:FD,FD'?.N:$ORDER(^DD(FI,"B",FD,"")),1:0)
- +2 ;**CCO/NI "INVALID FIELD"
- IF 'FD!('$DATA(^DD(FI,+FD,0)))
- SET DIFNM("FILE")=FI
- SET DIFNM(1)=FIELD
- SET MSG=$$EZBLD^DIALOG(501,.DIFNM)
- QUIT
- +3 ;**CCO/NI 'NOT W-P'
- IF FD
- SET FTYPE=$PIECE($GET(^DD(+$PIECE($GET(^DD(FI,FD,0)),U,2),.01,0)),U,2)
- IF FTYPE'["W"
- SET MSG=$$EZBLD^DIALOG(504,FD)
- QUIT
- +4 IF FTYPE["L"
- Begin DoDot:1
- +5 NEW DIR,X,Y
- +6 ;**CCO/NI WARNING ABOUT NON-WRAP
- DO BLD^DIALOG(8130)
- DO MSG^DIALOG("WM")
- SET DIR(0)="Y"
- DO ^DIR
- +7 ;**CCO/NI 'CANCELLED'
- WRITE !
- if 'Y
- SET MSG=$$EZBLD^DIALOG(8135)
- QUIT
- End DoDot:1
- +8 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 ;**CCO/NI "NO RECORD FOUND"
- IF Y<0
- SET MSG=$$EZBLD^DIALOG(1402)
- 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 ;**CCO/NI "NO TEXT TO TRANSFER FROM"
- SET MSG=$$EZBLD^DIALOG(1403)
- +4 QUIT
- +5 ;
- Q0 ;**CCO/NI DO LINE FEED
- if $X
- WRITE !
- WRITE " <"_MSG_">",$CHAR(7)
- QUIT
- +1 ;
- 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
- % ;**CCO/NI 'CANCELLED'
- WRITE !,"Transfer which Response: Original Message// "
- READ A9:DTIME
- IF A9[U
- SET MSG=$$EZBLD^DIALOG(8135)
- 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 ;**CCO/NI 'INVALID RESPONSE'
- SET MSG=$$EZBLD^DIALOG(1401)
- SET Z=0
- DO Q0
- End DoDot:1
- if Z
- QUIT
- +7 SET Z=A1
- GOTO %
