- DDXP4 ;SFISC/DPC,S0-EXPORT DATA ;7:37 AM 30 May 2000
- ;;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.
- ;
- EN1 ;
- K ^UTILITY($J)
- D ^DICRW I Y=-1 G QUIT
- S DDXPFINO=+Y
- XTEM ;
- S DIC="^DIPT(",DIC(0)="QEASZ",DIC("A")="Choose an EXPORT template or '^' to Quit: ",DIC("S")="I $P(^(0),U,8)=3",D="F"_DDXPFINO W !
- D IX^DIC K DIC,D I $D(DTOUT)!$D(DUOUT) G QUIT
- I Y=-1 G XTEM
- S DDXPXTNO=+Y,DDXPXTNM=$P(Y,U,2),FLDS="["_DDXPXTNM_"]"
- I DUZ(0)[$E($P(Y(0),U,6),1)!(DUZ(0)="@") D I $D(DIRUT) G QUIT
- . W !,"Do you want to delete the "_DDXPXTNM_" template",!,"after the data export is complete?",!
- . S DDXPTMDL=0,DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR W !
- . S:Y DDXPTMDL=1
- S DDXPFFNO=+$G(^DIPT(DDXPXTNO,105)),DDXPFMZO=$G(^DIST(.44,DDXPFFNO,0))
- I $G(^DIST(.44,DDXPFFNO,6))]"" S DDXPDATE=1
- S DDXPATH=$P($G(^DIPT(DDXPXTNO,105)),U,4) I DDXPATH]"" D MULTBY
- SORS ;
- W ! S DIR(0)="YA",DIR("B")="NO",DIR("A")="Do you want to SEARCH for entries to be exported? "
- S DIR("?",1)="To use VA FileMan's SEARCH option to choose entries, answer 'YES'."
- S:'$D(BY) DIR("?",2)="After the SEARCH, you can respond to VA FileMan's 'SORT BY:' prompt."
- S DIR("?")="If you answer 'NO', "_$S('$D(BY):"you can only SORT entries before export.",1:"the data export will begin.")
- D ^DIR K DIR I $D(DIRUT) G QUIT
- S DDXPSORS=Y,DIC=DDXPFINO,L=0
- D DIOBEG,DIOEND
- I DDXPSORS D EN^DIS
- I $G(X)="^"!($G(POP)) G QUIT
- I 'DDXPSORS D EN1^DIP
- I $G(X)="^"!($G(POP)) G QUIT
- I $G(DDXPQ),$G(DDXPTMDL) W !,?5,"Export template "_DDXPXTNM_" will be deleted",!,?5,"when queued export is completed." G DONE
- I $G(DDXPTMDL) S DIK="^DIPT(",DA=DDXPXTNO D ^DIK K DIK,DA
- G DONE
- QUIT ;
- W !!,?10,"Export NOT completed!"
- DONE ;
- K DDXPFINO,DDXPSORS,DDXPIOM,DDXPIOSL,DDXPXTNO,DDXPXTNM,DDXPFFNO,DDXPFMZO,DDXPCUSR,DDXPDATE,DDXPTMDL,DDXPY,DDXPATH,L,Y,DTOUT,DUOUT,DIRUT,DIC,FLDS,BY,FR,DIOEND,DIOBEG,DDXPQ,X,POP
- Q
- ZIS ;
- S %ZIS="Q"
- S DDXPIOM=$S($P(DDXPFMZO,U,8):$P(DDXPFMZO,U,8),$G(^DIPT(DDXPXTNO,"IOM")):^("IOM"),1:80)
- S DDXPIOSL=99999
- Q
- MULTBY ;
- N NUMPC,I,C S BY="",C=",",NUMPC=$L(DDXPATH,C)
- W !!,"Since you are exporting fields from multiples,"
- W !,"a sort will be done automatically."
- W !,"You will NOT have the opportunity to sort the data before export.",!
- F I=1:1:NUMPC D
- . S BY=BY_DDXPATH_",NUMBER,"
- . S DDXPATH=$P(DDXPATH,C,1,$L(DDXPATH,C)-1)
- . Q
- S BY=$E(BY,1,$L(BY)-1),FR=""
- Q
- DIOBEG ;
- S DDXPBEG=$G(^DIST(.44,DDXPFFNO,1))
- I DDXPBEG']"" G QBEG
- I $E(DDXPBEG)="""" S DIOBEG="W "_DDXPBEG G QBEG
- S DIOBEG=DDXPBEG
- QBEG K DDXPBEG
- Q
- DIOEND ;
- S DDXPEND=$G(^DIST(.44,DDXPFFNO,2))
- I DDXPEND']"" G QEND
- I $E(DDXPEND)="""" S DIOEND="W "_DDXPEND G QEND
- S DIOEND=DDXPEND
- QEND K DDXPEND
- Q
- DJTOPY(Y) ;
- N BJ,EJ,YOUT,NUMW,TYPEJ,DDXPXORY,SUB S YOUT=Y
- S BJ=$F(Y,"$J(") I BJ D
- . S DDXPXORY=$P($E(Y,BJ,999),",",1)
- . S NUMW=$L($E(Y,1,BJ),"W")-1 I NUMW'>0 Q
- . S EJ=$F(Y,") ",BJ)
- . S TYPEJ=$L($E(Y,BJ,$S(EJ:EJ-1,1:999)),",")
- . I TYPEJ'=2&(TYPEJ'=3) Q
- . I TYPEJ=3 S SUB="$S("_DDXPXORY_"]"""":+"_DDXPXORY_",1:"""_$P(DDXPFMZO,U,13)_""")"
- . I TYPEJ=2 S SUB=DDXPXORY
- . S YOUT=$P($E(Y,1,BJ),"W",1,NUMW)_"W "_SUB_$S(EJ:$E(Y,EJ-1,999),1:"")
- . Q
- Q YOUT
- DT ;
- N X
- I 'Y S DDXPY=Y Q
- S X=Y
- I $D(^DIST(.44,DDXPFFNO,6)) X ^(6) S DDXPY=$G(Y)
- Q
- EN2 ; Export API from EXPORT^DDXP
- N DDXP,DDXPXTNO,DDPXFFNO,DDXPFMZO,DDXPDATE,DDXPATH,DDXPOUT,ERROR,DIA
- K ^UTILITY($J)
- ; Check for valild file number
- I '$G(DDXPFINO) S ERROR="File Number Missing." D EN2ERR G DONE
- I DDXPFINO[U D I $D(DDXPOUT) K DDXPOUT G DONE
- . I $P(DDXPFINO,U)'=1.1 S DDXPOUT=1,ERROR="You can only use the "","" syntax if doing an Export of the Audit File(1.1)" D EN2ERR Q
- . I '$D(^DIC(+$P(DDXPFINO,U,2),0))#2 S DDXPOUT=1,ERROR="File Does Not Exist on This System." D EN2ERR Q
- I DDXPFINO'[U,'$D(^DIC(+DDXPFINO,0))#2 S ERROR="File Does Not Exist on This System." D EN2ERR G DONE
- N DIC,D,X
- S DIC="^DIPT(",DIC(0)="SZ",DIC("S")="I $P(^(0),U,8)=3",D="F"_+DDXPFINO,X=DDXPXTNM
- D IX^DIC K DIC
- I Y<0 S ERROR="The Template is Not an Export Template or Is Missing." D EN2ERR G DONE
- S DDXPXTNO=+Y
- S DDXPFFNO=+$G(^DIPT(DDXPXTNO,105)),DDXPFMZO=$G(^DIST(.44,DDXPFFNO,0))
- I $G(^DIST(.44,DDXPFFNO,6))]"" S DDXPDATE=1
- I $G(DDXPBY)="" S DDXPATH=$P($G(^DIPT(DDXPXTNO,105)),U,4) I DDXPATH]"" D MULTBY
- ; Setup For Sort Template If BY NOT Setup by MULTBY
- I '$D(BY) D I $D(DDXPOUT) K DDXPOUT S ERROR="Sort Template Invalid or Missing." D EN2ERR G DONE
- . I $G(DDXPBY)]"" D Q:$D(DDXPOUT)
- .. N DIC,X
- .. S DIC="^DIBT(",DIC(0)="Z",X=DDXPBY
- .. D ^DIC K DIC
- .. I Y<0 S DDXPOUT=1 Q
- .. D SORTCHK I $D(DDXPOUT) Q
- .. S BY="["_DDXPBY_"]"
- S DDXP=4 ; Tell other FileMan routines we are Exporting
- S DIC=$S(+DDXPFINO=1.1:"^DIA("_+$P(DDXPFINO,U,2)_",",1:+DDXPFINO)
- S L=0
- S FLDS="["_DDXPXTNM_"]"
- D DIOBEG,DIOEND,EN1^DIP
- I $G(X)="^"!($G(POP)) K DDXP,DDXPBY,DDXPFR,DDXPTO G QUIT
- K:$D(DIA) DIA ; **Leaking Variable**
- I $G(DDXPTMDL) S DIK="^DIPT(",DA=DDXPXTNO D ^DIK K DIK,DA
- K DDXP,DDXPBY,DDXPFR,DDXPTO
- G DONE
- SORTCHK ; Check Sort For Illegal Qualifiers
- N D0,D1,DDXPX,I
- S D0=+Y
- S D1=0
- F S D1=$O(^DIBT(D0,2,D1)) Q:D1<1!$D(DDXPOUT) D
- . S DDXPX=^DIBT(D0,2,D1,0)
- . F I="#","!","+","@" D Q:$D(DDXPOUT)
- .. I $P(DDXPX,U,4)[I,I'="@" S DDXPOUT=1,ERROR="You can not use the """_I_""" when exporting." D EN2ERR Q
- .. I I="@",$P(DDXPX,U,4)["@",$P(DDXPX,U,4)'["@B" S DDXPOUT=1,ERROR="You can not use the ""@"" when exporting." D EN2ERR Q
- . F I=";C",";S" D Q:$D(DDXPOUT)
- .. I $P(DDXPX,U,5)[I S DDXPOUT=1,ERROR="You can not use "_I_" when exporting." D EN2ERR Q
- .. I $P(DDXPX,U,5)[";""" S DDXPOUT=1,ERROR="You can Replace a Caption when exporting." D EN2ERR Q
- Q
- EN2ERR ; Error Processing
- I $D(IOST),$E(IOST,1,2)="C-" W $C(7)
- W "=>"_ERROR,!
- K DDXPBY,DDXPFR,DDXPTO,ERROR
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDXP4 6071 printed Jan 18, 2025@03:45:12 Page 2
- DDXP4 ;SFISC/DPC,S0-EXPORT DATA ;7:37 AM 30 May 2000
- +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 ;
- EN1 ;
- +1 KILL ^UTILITY($JOB)
- +2 DO ^DICRW
- IF Y=-1
- GOTO QUIT
- +3 SET DDXPFINO=+Y
- XTEM ;
- +1 SET DIC="^DIPT("
- SET DIC(0)="QEASZ"
- SET DIC("A")="Choose an EXPORT template or '^' to Quit: "
- SET DIC("S")="I $P(^(0),U,8)=3"
- SET D="F"_DDXPFINO
- WRITE !
- +2 DO IX^DIC
- KILL DIC,D
- IF $DATA(DTOUT)!$DATA(DUOUT)
- GOTO QUIT
- +3 IF Y=-1
- GOTO XTEM
- +4 SET DDXPXTNO=+Y
- SET DDXPXTNM=$PIECE(Y,U,2)
- SET FLDS="["_DDXPXTNM_"]"
- +5 IF DUZ(0)[$EXTRACT($PIECE(Y(0),U,6),1)!(DUZ(0)="@")
- Begin DoDot:1
- +6 WRITE !,"Do you want to delete the "_DDXPXTNM_" template",!,"after the data export is complete?",!
- +7 SET DDXPTMDL=0
- SET DIR(0)="Y"
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- WRITE !
- +8 if Y
- SET DDXPTMDL=1
- End DoDot:1
- IF $DATA(DIRUT)
- GOTO QUIT
- +9 SET DDXPFFNO=+$GET(^DIPT(DDXPXTNO,105))
- SET DDXPFMZO=$GET(^DIST(.44,DDXPFFNO,0))
- +10 IF $GET(^DIST(.44,DDXPFFNO,6))]""
- SET DDXPDATE=1
- +11 SET DDXPATH=$PIECE($GET(^DIPT(DDXPXTNO,105)),U,4)
- IF DDXPATH]""
- DO MULTBY
- SORS ;
- +1 WRITE !
- SET DIR(0)="YA"
- SET DIR("B")="NO"
- SET DIR("A")="Do you want to SEARCH for entries to be exported? "
- +2 SET DIR("?",1)="To use VA FileMan's SEARCH option to choose entries, answer 'YES'."
- +3 if '$DATA(BY)
- SET DIR("?",2)="After the SEARCH, you can respond to VA FileMan's 'SORT BY:' prompt."
- +4 SET DIR("?")="If you answer 'NO', "_$SELECT('$DATA(BY):"you can only SORT entries before export.",1:"the data export will begin.")
- +5 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- GOTO QUIT
- +6 SET DDXPSORS=Y
- SET DIC=DDXPFINO
- SET L=0
- +7 DO DIOBEG
- DO DIOEND
- +8 IF DDXPSORS
- DO EN^DIS
- +9 IF $GET(X)="^"!($GET(POP))
- GOTO QUIT
- +10 IF 'DDXPSORS
- DO EN1^DIP
- +11 IF $GET(X)="^"!($GET(POP))
- GOTO QUIT
- +12 IF $GET(DDXPQ)
- IF $GET(DDXPTMDL)
- WRITE !,?5,"Export template "_DDXPXTNM_" will be deleted",!,?5,"when queued export is completed."
- GOTO DONE
- +13 IF $GET(DDXPTMDL)
- SET DIK="^DIPT("
- SET DA=DDXPXTNO
- DO ^DIK
- KILL DIK,DA
- +14 GOTO DONE
- QUIT ;
- +1 WRITE !!,?10,"Export NOT completed!"
- DONE ;
- +1 KILL DDXPFINO,DDXPSORS,DDXPIOM,DDXPIOSL,DDXPXTNO,DDXPXTNM,DDXPFFNO,DDXPFMZO,DDXPCUSR,DDXPDATE,DDXPTMDL,DDXPY,DDXPATH,L,Y,DTOUT,DUOUT,DIRUT,DIC,FLDS,BY,FR,DIOEND,DIOBEG,DDXPQ,X,POP
- +2 QUIT
- ZIS ;
- +1 SET %ZIS="Q"
- +2 SET DDXPIOM=$SELECT($PIECE(DDXPFMZO,U,8):$PIECE(DDXPFMZO,U,8),$GET(^DIPT(DDXPXTNO,"IOM")):^("IOM"),1:80)
- +3 SET DDXPIOSL=99999
- +4 QUIT
- MULTBY ;
- +1 NEW NUMPC,I,C
- SET BY=""
- SET C=","
- SET NUMPC=$LENGTH(DDXPATH,C)
- +2 WRITE !!,"Since you are exporting fields from multiples,"
- +3 WRITE !,"a sort will be done automatically."
- +4 WRITE !,"You will NOT have the opportunity to sort the data before export.",!
- +5 FOR I=1:1:NUMPC
- Begin DoDot:1
- +6 SET BY=BY_DDXPATH_",NUMBER,"
- +7 SET DDXPATH=$PIECE(DDXPATH,C,1,$LENGTH(DDXPATH,C)-1)
- +8 QUIT
- End DoDot:1
- +9 SET BY=$EXTRACT(BY,1,$LENGTH(BY)-1)
- SET FR=""
- +10 QUIT
- DIOBEG ;
- +1 SET DDXPBEG=$GET(^DIST(.44,DDXPFFNO,1))
- +2 IF DDXPBEG']""
- GOTO QBEG
- +3 IF $EXTRACT(DDXPBEG)=""""
- SET DIOBEG="W "_DDXPBEG
- GOTO QBEG
- +4 SET DIOBEG=DDXPBEG
- QBEG KILL DDXPBEG
- +1 QUIT
- DIOEND ;
- +1 SET DDXPEND=$GET(^DIST(.44,DDXPFFNO,2))
- +2 IF DDXPEND']""
- GOTO QEND
- +3 IF $EXTRACT(DDXPEND)=""""
- SET DIOEND="W "_DDXPEND
- GOTO QEND
- +4 SET DIOEND=DDXPEND
- QEND KILL DDXPEND
- +1 QUIT
- DJTOPY(Y) ;
- +1 NEW BJ,EJ,YOUT,NUMW,TYPEJ,DDXPXORY,SUB
- SET YOUT=Y
- +2 SET BJ=$FIND(Y,"$J(")
- IF BJ
- Begin DoDot:1
- +3 SET DDXPXORY=$PIECE($EXTRACT(Y,BJ,999),",",1)
- +4 SET NUMW=$LENGTH($EXTRACT(Y,1,BJ),"W")-1
- IF NUMW'>0
- QUIT
- +5 SET EJ=$FIND(Y,") ",BJ)
- +6 SET TYPEJ=$LENGTH($EXTRACT(Y,BJ,$SELECT(EJ:EJ-1,1:999)),",")
- +7 IF TYPEJ'=2&(TYPEJ'=3)
- QUIT
- +8 IF TYPEJ=3
- SET SUB="$S("_DDXPXORY_"]"""":+"_DDXPXORY_",1:"""_$PIECE(DDXPFMZO,U,13)_""")"
- +9 IF TYPEJ=2
- SET SUB=DDXPXORY
- +10 SET YOUT=$PIECE($EXTRACT(Y,1,BJ),"W",1,NUMW)_"W "_SUB_$SELECT(EJ:$EXTRACT(Y,EJ-1,999),1:"")
- +11 QUIT
- End DoDot:1
- +12 QUIT YOUT
- DT ;
- +1 NEW X
- +2 IF 'Y
- SET DDXPY=Y
- QUIT
- +3 SET X=Y
- +4 IF $DATA(^DIST(.44,DDXPFFNO,6))
- XECUTE ^(6)
- SET DDXPY=$GET(Y)
- +5 QUIT
- EN2 ; Export API from EXPORT^DDXP
- +1 NEW DDXP,DDXPXTNO,DDPXFFNO,DDXPFMZO,DDXPDATE,DDXPATH,DDXPOUT,ERROR,DIA
- +2 KILL ^UTILITY($JOB)
- +3 ; Check for valild file number
- +4 IF '$GET(DDXPFINO)
- SET ERROR="File Number Missing."
- DO EN2ERR
- GOTO DONE
- +5 IF DDXPFINO[U
- Begin DoDot:1
- +6 IF $PIECE(DDXPFINO,U)'=1.1
- SET DDXPOUT=1
- SET ERROR="You can only use the "","" syntax if doing an Export of the Audit File(1.1)"
- DO EN2ERR
- QUIT
- +7 IF '$DATA(^DIC(+$PIECE(DDXPFINO,U,2),0))#2
- SET DDXPOUT=1
- SET ERROR="File Does Not Exist on This System."
- DO EN2ERR
- QUIT
- End DoDot:1
- IF $DATA(DDXPOUT)
- KILL DDXPOUT
- GOTO DONE
- +8 IF DDXPFINO'[U
- IF '$DATA(^DIC(+DDXPFINO,0))#2
- SET ERROR="File Does Not Exist on This System."
- DO EN2ERR
- GOTO DONE
- +9 NEW DIC,D,X
- +10 SET DIC="^DIPT("
- SET DIC(0)="SZ"
- SET DIC("S")="I $P(^(0),U,8)=3"
- SET D="F"_+DDXPFINO
- SET X=DDXPXTNM
- +11 DO IX^DIC
- KILL DIC
- +12 IF Y<0
- SET ERROR="The Template is Not an Export Template or Is Missing."
- DO EN2ERR
- GOTO DONE
- +13 SET DDXPXTNO=+Y
- +14 SET DDXPFFNO=+$GET(^DIPT(DDXPXTNO,105))
- SET DDXPFMZO=$GET(^DIST(.44,DDXPFFNO,0))
- +15 IF $GET(^DIST(.44,DDXPFFNO,6))]""
- SET DDXPDATE=1
- +16 IF $GET(DDXPBY)=""
- SET DDXPATH=$PIECE($GET(^DIPT(DDXPXTNO,105)),U,4)
- IF DDXPATH]""
- DO MULTBY
- +17 ; Setup For Sort Template If BY NOT Setup by MULTBY
- +18 IF '$DATA(BY)
- Begin DoDot:1
- +19 IF $GET(DDXPBY)]""
- Begin DoDot:2
- +20 NEW DIC,X
- +21 SET DIC="^DIBT("
- SET DIC(0)="Z"
- SET X=DDXPBY
- +22 DO ^DIC
- KILL DIC
- +23 IF Y<0
- SET DDXPOUT=1
- QUIT
- +24 DO SORTCHK
- IF $DATA(DDXPOUT)
- QUIT
- +25 SET BY="["_DDXPBY_"]"
- End DoDot:2
- if $DATA(DDXPOUT)
- QUIT
- End DoDot:1
- IF $DATA(DDXPOUT)
- KILL DDXPOUT
- SET ERROR="Sort Template Invalid or Missing."
- DO EN2ERR
- GOTO DONE
- +26 ; Tell other FileMan routines we are Exporting
- SET DDXP=4
- +27 SET DIC=$SELECT(+DDXPFINO=1.1:"^DIA("_+$PIECE(DDXPFINO,U,2)_",",1:+DDXPFINO)
- +28 SET L=0
- +29 SET FLDS="["_DDXPXTNM_"]"
- +30 DO DIOBEG
- DO DIOEND
- DO EN1^DIP
- +31 IF $GET(X)="^"!($GET(POP))
- KILL DDXP,DDXPBY,DDXPFR,DDXPTO
- GOTO QUIT
- +32 ; **Leaking Variable**
- if $DATA(DIA)
- KILL DIA
- +33 IF $GET(DDXPTMDL)
- SET DIK="^DIPT("
- SET DA=DDXPXTNO
- DO ^DIK
- KILL DIK,DA
- +34 KILL DDXP,DDXPBY,DDXPFR,DDXPTO
- +35 GOTO DONE
- SORTCHK ; Check Sort For Illegal Qualifiers
- +1 NEW D0,D1,DDXPX,I
- +2 SET D0=+Y
- +3 SET D1=0
- +4 FOR
- SET D1=$ORDER(^DIBT(D0,2,D1))
- if D1<1!$DATA(DDXPOUT)
- QUIT
- Begin DoDot:1
- +5 SET DDXPX=^DIBT(D0,2,D1,0)
- +6 FOR I="#","!","+","@"
- Begin DoDot:2
- +7 IF $PIECE(DDXPX,U,4)[I
- IF I'="@"
- SET DDXPOUT=1
- SET ERROR="You can not use the """_I_""" when exporting."
- DO EN2ERR
- QUIT
- +8 IF I="@"
- IF $PIECE(DDXPX,U,4)["@"
- IF $PIECE(DDXPX,U,4)'["@B"
- SET DDXPOUT=1
- SET ERROR="You can not use the ""@"" when exporting."
- DO EN2ERR
- QUIT
- End DoDot:2
- if $DATA(DDXPOUT)
- QUIT
- +9 FOR I=";C",";S"
- Begin DoDot:2
- +10 IF $PIECE(DDXPX,U,5)[I
- SET DDXPOUT=1
- SET ERROR="You can not use "_I_" when exporting."
- DO EN2ERR
- QUIT
- +11 IF $PIECE(DDXPX,U,5)[";"""
- SET DDXPOUT=1
- SET ERROR="You can Replace a Caption when exporting."
- DO EN2ERR
- QUIT
- End DoDot:2
- if $DATA(DDXPOUT)
- QUIT
- End DoDot:1
- +12 QUIT
- EN2ERR ; Error Processing
- +1 IF $DATA(IOST)
- IF $EXTRACT(IOST,1,2)="C-"
- WRITE $CHAR(7)
- +2 WRITE "=>"_ERROR,!
- +3 KILL DDXPBY,DDXPFR,DDXPTO,ERROR
- +4 QUIT