CIAUEDT.m

CIAUEDT ;MSC/IND/DKM - Screen-oriented line editor;14-Aug-2006 09:35;DKM

 ;;1.2;CIA UTILITIES;;Mar 20, 2007

 ;;Copyright 2000-2006, Medsphere Systems Corporation

 ;=================================================================

 ; Inputs:

 ;   CIADATA  = Data to edit

 ;   CIALEN   = Maximum length of data

 ;   CIAX     = Starting column position

 ;   CIAY     = Starting row position

 ;   CIAVALD  = List of valid inputs (optional)

 ;   CIADISV  = DISV node to save under (optional)

 ;   CIATERM  = Valid input terminators (default=<CR>)

 ;   CIAABRT  = Valid input abort characters (default=none)

 ;   CIARM    = Right margin setting (default=IOM or 80)

 ;   CIAQUIT  = Exit code (returned)

 ;   CIAOPT   = Input options

 ;      C = Mark <CR> with ~

 ;      E = Echo off

 ;      H = Horizontal scroll

 ;      I = No timeout

 ;      L = Lowercase only

 ;      O = Overwrite mode

 ;      Q = Quiet mode

 ;      R = Reverse video

 ;      T = Auto-terminate

 ;      U = Uppercase only

 ;      V = Up/down cursor keys terminate input

 ;      X = Suppress auto-erase

 ; Outputs:

 ;   Return value = Edited data

 ;=================================================================

ENTRY(CIADATA,CIALEN,CIAX,CIAY,CIAVALD,CIAOPT,CIADISV,CIATERM,CIAABRT,CIARM,CIAQUIT) ;

 N CIAZ,CIAZ1,CIAZ2,CIASAVE,CIAINS,CIAAE,CIABUF,CIATAB,CIAPOS,CIAEON,CIALEFT,CIABEL,CIAMAX,CIARVON,CIARVOFF,CIAC,CIAW

 S CIAVALD=$G(CIAVALD),CIAOPT=$$UP^XLFSTR($G(CIAOPT)),CIABEL=$S(CIAOPT'["Q":$C(7),1:""),CIADISV=$G(CIADISV)

 S:$G(CIATERM)="" CIATERM=$C(13)                                         ; Valid line terminators

 S CIAABRT=$G(CIAABRT)                                                   ; Valid input abort keys

 S CIARVON=$C(27,91,55,109),CIARVOFF=$C(27,91,109)                       ; Reverse video control

 S CIAINS=CIAOPT'["O"                                                    ; Default mode = insert

 S CIAAE=CIAOPT'["X"                                                     ; Auto-erase option

 S CIAEON=CIAOPT'["E"                                                    ; No echo option

 I CIAOPT["I"!'$D(DTIME) N DTIME S DTIME=99999999                        ; Suppress timeout option

 S CIABUF=""

 S CIARM=$G(CIARM,$G(IOM,80))                                            ; Display width

 S CIATAB=$C(9)                                                         ; Tab character

 S CIAX=$G(CIAX,$X),CIAY=$G(CIAY,$Y),CIAW=CIARM-CIAX

 S:CIAW'>0 CIAW=1

 S:'$G(CIALEN) CIALEN=CIAW                                                ; Default field width

 S CIAMAX=$S(CIAOPT["H":250,1:CIALEN)                                     ; Maximum data length

 S (CIASAVE,CIADATA)=$E($G(CIADATA),1,CIAMAX)                              ; Truncate data if too long

 I $$NEWERR^%ZTER N $ET S $ET=""

 S @$$TRAP^CIAUOS("ERROR^CIAUEDT")

 D RM^CIAUOS(0)

 X ^%ZOSF("EOFF")

 F  Q:CIADATA'[CIATAB  S CIAZ=$P(CIADATA,CIATAB),CIADATA=CIAZ_$J("",8-($L(CIAZ)#8))_$P(CIADATA,CIATAB,2,999)

RESTART D RESET

AGAIN F CIAQUIT=0:0 Q:CIAQUIT  D NXT S CIAAE=0

 X ^%ZOSF("EON")

 W $$XY^CIAU(CIAX,CIAY),$S(CIAOPT["R":CIARVOFF,1:"")

 I CIADISV'="" Q:"^^"[CIADATA CIADATA S:CIADATA=" " CIADATA=$G(^DISV(DUZ,CIADISV))

 S:CIADISV'="" ^DISV(DUZ,CIADISV)=CIADATA

 Q CIADATA                                                              ; Return to calling routine

NXT D POSCUR()                                                            ; Position cursor

 R *CIAC:DTIME                                                          ; Next character typed

 I CIAC=27 D ESC Q:'CIAC

 I CIAC<1!(CIAABRT[$C(CIAC)) S CIADATA=U,CIAQUIT=1 Q

 I CIATERM[$C(CIAC) D TERM Q

 I CIAC<28 D:CIAC'=27 @("CTL"_$C(CIAC+64)) Q

 I CIAC=127!(CIAC=240) D CTLH Q

 I CIAC>64,CIAC<91,CIAOPT["L" S CIAC=CIAC+32

 E  I CIAC>96,CIAC<123,CIAOPT["U" S CIAC=CIAC-32

 I $L(CIAVALD),CIAVALD'[$C(CIAC) D RAISE^CIAUOS()

 D:CIAAE CTLK,POSCUR()                                                  ; Erase buffer if auto erase on

 D INSW($C(CIAC))

 S CIAQUIT=CIAPOS=CIALEN&(CIAOPT["T")

 Q

CTLA S CIAINS='CIAINS                                                        ; Toggle insert mode

 Q

CTLB D MOVETO(0)                                                           ; Move cursor to beginning

 Q

CTLX S CIADATA=CIASAVE                                                       ; Restore buffer to original

 G RESET

CTLE D MOVETO($L(CIADATA))                                                  ; Move cursor to end

 Q

CTLI D INSW($J("",8-(CIAPOS#8)))                                            ; Insert expanded tab

 Q

CTLJ F CIAZ=CIAPOS:-1:1 Q:$A(CIADATA,CIAZ)'=32                                     ; Find previous nonspace

 F CIAZ=CIAZ:-1:1 Q:$A(CIADATA,CIAZ)=32                                          ; Find previous space

 S CIABUF=$E(CIADATA,CIAZ,CIAPOS)                                            ; Save deleted portion

 S CIADATA=$E(CIADATA,1,CIAZ-1)_$E(CIADATA,CIAPOS+1,CIALEN)                    ; Remove word

 D MOVETO(CIAZ-1)

 Q

CTLK S CIABUF=CIADATA                                                        ; Save buffer

 S CIADATA=""                                                           ; Erase buffer

 D RESET

 Q

CTLL S CIABUF=$E(CIADATA,CIAPOS+1,CIALEN)                                      ; Save deleted portion

 S CIADATA=$E(CIADATA,1,CIAPOS)                                           ; Truncate at current position

 D DSPLY(CIAPOS)

 Q

CTLM D POSCUR(CIAPOS),INSW("~"):CIAOPT["C",MOVETO(CIAPOS-$X+CIAX+CIAW)

 Q

CTLR D INSW(CIABUF)                                                         ; Insert at current position

 Q

CTLT D CTLL

 Q

CTLU S CIABUF=$E(CIADATA,1,CIAPOS)                                            ; Save deleted portion

 S CIADATA=$E(CIADATA,CIAPOS+1,CIALEN)                                     ; Remove to left of cursor

 D RESET

 Q

CTLH I 'CIAPOS W CIABEL Q

 D LEFT

CTLD S CIADATA=$E(CIADATA,1,CIAPOS)_$E(CIADATA,CIAPOS+2,CIAMAX)                  ; Delete character to left

 D DSPLY(CIAPOS,1)

 Q

TERM S CIAQUIT=2

 Q

ESC R *CIAZ:1

 R:CIAZ>0 *CIAZ:1

 S CIAC=0

 G UP:CIAZ=65,DOWN:CIAZ=66,RIGHT:CIAZ=67,LEFT:CIAZ=68                              ;Execute code

 S CIAC=27

 Q

DSPLY(CIAP1,CIAP2) ;

 Q:'CIAEON                                                              ; Refresh buffer display starting at position CIAP1

 N CIAZ,CIAZ1

 S CIAP1=+$G(CIAP1,CIALEFT),CIAZ=$E(CIADATA,CIAP1+1,CIALEFT+CIALEN),CIAP2=$S($D(CIAP2):CIAP2+$L(CIAZ),1:CIALEN-CIAP1+CIALEFT)

 S:CIAP2>CIALEN CIAP2=CIALEN

 S CIAZ=CIAZ_$J("",CIAP2-$L(CIAZ))

 F  D  Q:CIAZ=""

 .D POSCUR(CIAP1)

 .S CIAZ1=CIARM-$X

 .S:CIAZ1<1 CIAZ1=1

 .W $E(CIAZ,1,CIAZ1)

 .S CIAZ=$E(CIAZ,CIAZ1+1,999),CIAP1=CIAP1+CIAZ1

 Q

INSW(CIATXT) ;

 S:CIAPOS>$L(CIADATA) CIADATA=CIADATA_$J("",CIAPOS-$L(CIADATA))              ; Pad if past end of buffer

 S CIADATA=$E($E(CIADATA,1,CIAPOS)_CIATXT_$E(CIADATA,CIAPOS+2-CIAINS,CIAMAX),1,CIAMAX)

 D DSPLY(CIAPOS,0),MOVETO(CIAPOS+$L(CIATXT))

 Q

POSCUR(CIAP) ;

 N CIAZX,CIAZY

 S CIAP=+$G(CIAP,CIAPOS),CIAZX=CIAP-CIALEFT,CIAZY=CIAZX\CIAW+CIAY,CIAZX=CIAZX#CIAW+CIAX

 W $$XY^CIAU(CIAZX,CIAZY)

 Q

MOVETO(CIAP) ;

 I CIAP>CIAMAX!(CIAP<0) W CIABEL Q

 S CIAPOS=CIAP,CIAP=CIALEFT

 S:CIAPOS<CIALEFT CIALEFT=CIAPOS-CIAW-1

 S:CIALEFT+CIALEN<CIAPOS CIALEFT=CIAPOS-CIAW+1

 S:CIALEFT'<CIAMAX CIALEFT=CIAMAX-CIAW

 S:CIALEFT<0 CIALEFT=0

 D DSPLY():CIALEFT'=CIAP,POSCUR()

 Q

UP I CIAOPT["V" S CIAQUIT=3

 E  D MOVETO(CIAPOS-CIAW)

 Q

DOWN I CIAOPT["V" S CIAQUIT=4

 E  D MOVETO(CIAPOS+CIAW)

 Q

RIGHT D MOVETO(CIAPOS+1)

 Q

LEFT D MOVETO(CIAPOS-1)

 Q

RESET W $S(CIAOPT["R":CIARVON,1:CIARVOFF)

 S (CIAPOS,CIALEFT)=0                                                    ; Current edit offset

 D DSPLY()                                                             ; Refresh display

 Q

ERROR W CIABEL                                                               ; Sound bell

 S @$$TRAP^CIAUOS("ERROR^CIAUEDT")

 G AGAIN

CIAUEDT   ;MSC/IND/DKM - Screen-oriented line editor;14-Aug-2006 09:35;DKM

 +1       ;;1.2;CIA UTILITIES;;Mar 20, 2007

 +2       ;;Copyright 2000-2006, Medsphere Systems Corporation

 +3       ;=================================================================

 +4       ; Inputs:

 +5       ;   CIADATA  = Data to edit

 +6       ;   CIALEN   = Maximum length of data

 +7       ;   CIAX     = Starting column position

 +8       ;   CIAY     = Starting row position

 +9       ;   CIAVALD  = List of valid inputs (optional)

 +10      ;   CIADISV  = DISV node to save under (optional)

 +11      ;   CIATERM  = Valid input terminators (default=<CR>)

 +12      ;   CIAABRT  = Valid input abort characters (default=none)

 +13      ;   CIARM    = Right margin setting (default=IOM or 80)

 +14      ;   CIAQUIT  = Exit code (returned)

 +15      ;   CIAOPT   = Input options

 +16      ;      C = Mark <CR> with ~

 +17      ;      E = Echo off

 +18      ;      H = Horizontal scroll

 +19      ;      I = No timeout

 +20      ;      L = Lowercase only

 +21      ;      O = Overwrite mode

 +22      ;      Q = Quiet mode

 +23      ;      R = Reverse video

 +24      ;      T = Auto-terminate

 +25      ;      U = Uppercase only

 +26      ;      V = Up/down cursor keys terminate input

 +27      ;      X = Suppress auto-erase

 +28      ; Outputs:

 +29      ;   Return value = Edited data

 +30      ;=================================================================

ENTRY(CIADATA,CIALEN,CIAX,CIAY,CIAVALD,CIAOPT,CIADISV,CIATERM,CIAABRT,CIARM,CIAQUIT) ;

 +1        NEW CIAZ,CIAZ1,CIAZ2,CIASAVE,CIAINS,CIAAE,CIABUF,CIATAB,CIAPOS,CIAEON,CIALEFT,CIABEL,CIAMAX,CIARVON,CIARVOFF,CIAC,CIAW

 +2        SET CIAVALD=$GET(CIAVALD)

           SET CIAOPT=$$UP^XLFSTR($GET(CIAOPT))

           SET CIABEL=$SELECT(CIAOPT'["Q":$CHAR(7),1:"")

           SET CIADISV=$GET(CIADISV)

 +3       ; Valid line terminators

           IF $GET(CIATERM)=""

               SET CIATERM=$CHAR(13)

 +4       ; Valid input abort keys

           SET CIAABRT=$GET(CIAABRT)

 +5       ; Reverse video control

           SET CIARVON=$CHAR(27,91,55,109)

           SET CIARVOFF=$CHAR(27,91,109)

 +6       ; Default mode = insert

           SET CIAINS=CIAOPT'["O"

 +7       ; Auto-erase option

           SET CIAAE=CIAOPT'["X"

 +8       ; No echo option

           SET CIAEON=CIAOPT'["E"

 +9       ; Suppress timeout option

           IF CIAOPT["I"!'$DATA(DTIME)

               NEW DTIME

               SET DTIME=99999999

 +10       SET CIABUF=""

 +11      ; Display width

           SET CIARM=$GET(CIARM,$GET(IOM,80))

 +12      ; Tab character

           SET CIATAB=$CHAR(9)

 +13       SET CIAX=$GET(CIAX,$X)

           SET CIAY=$GET(CIAY,$Y)

           SET CIAW=CIARM-CIAX

 +14       IF CIAW'>0

               SET CIAW=1

 +15      ; Default field width

           IF '$GET(CIALEN)

               SET CIALEN=CIAW

 +16      ; Maximum data length

           SET CIAMAX=$SELECT(CIAOPT["H":250,1:CIALEN)

 +17      ; Truncate data if too long

           SET (CIASAVE,CIADATA)=$EXTRACT($GET(CIADATA),1,CIAMAX)

 +18       IF $$NEWERR^%ZTER

               NEW $ETRAP

               SET $ETRAP=""

 +19       SET @$$TRAP^CIAUOS("ERROR^CIAUEDT")

 +20       DO RM^CIAUOS(0)

 +21       XECUTE ^%ZOSF("EOFF")

 +22       FOR 

               IF CIADATA'[CIATAB

                   QUIT 

               SET CIAZ=$PIECE(CIADATA,CIATAB)

               SET CIADATA=CIAZ_$JUSTIFY("",8-($LENGTH(CIAZ)#8))_$PIECE(CIADATA,CIATAB,2,999)

RESTART    DO RESET

AGAIN      FOR CIAQUIT=0:0

               IF CIAQUIT

                   QUIT 

               DO NXT

               SET CIAAE=0

 +1        XECUTE ^%ZOSF("EON")

 +2        WRITE $$XY^CIAU(CIAX,CIAY),$SELECT(CIAOPT["R":CIARVOFF,1:"")

 +3        IF CIADISV'=""

               IF "^^"[CIADATA

                   QUIT CIADATA

               IF CIADATA=" "

                   SET CIADATA=$GET(^DISV(DUZ,CIADISV))

 +4        IF CIADISV'=""

               SET ^DISV(DUZ,CIADISV)=CIADATA

 +5       ; Return to calling routine

           QUIT CIADATA

NXT       ; Position cursor

           DO POSCUR()

 +1       ; Next character typed

           READ *CIAC:DTIME

 +2        IF CIAC=27

               DO ESC

               IF 'CIAC

                   QUIT 

 +3        IF CIAC<1!(CIAABRT[$CHAR(CIAC))

               SET CIADATA=U

               SET CIAQUIT=1

               QUIT 

 +4        IF CIATERM[$CHAR(CIAC)

               DO TERM

               QUIT 

 +5        IF CIAC<28

               IF CIAC'=27

                   DO @("CTL"_$CHAR(CIAC+64))

               QUIT 

 +6        IF CIAC=127!(CIAC=240)

               DO CTLH

               QUIT 

 +7        IF CIAC>64

               IF CIAC<91

                   IF CIAOPT["L"

                       SET CIAC=CIAC+32

 +8       IF '$TEST

               IF CIAC>96

                   IF CIAC<123

                       IF CIAOPT["U"

                           SET CIAC=CIAC-32

 +9        IF $LENGTH(CIAVALD)

               IF CIAVALD'[$CHAR(CIAC)

                   DO RAISE^CIAUOS()

 +10      ; Erase buffer if auto erase on

           IF CIAAE

               DO CTLK

               DO POSCUR()

 +11       DO INSW($CHAR(CIAC))

 +12       SET CIAQUIT=CIAPOS=CIALEN&(CIAOPT["T")

 +13       QUIT 

CTLA      ; Toggle insert mode

           SET CIAINS='CIAINS

 +1        QUIT 

CTLB      ; Move cursor to beginning

           DO MOVETO(0)

 +1        QUIT 

CTLX      ; Restore buffer to original

           SET CIADATA=CIASAVE

 +1        GOTO RESET

CTLE      ; Move cursor to end

           DO MOVETO($LENGTH(CIADATA))

 +1        QUIT 

CTLI      ; Insert expanded tab

           DO INSW($JUSTIFY("",8-(CIAPOS#8)))

 +1        QUIT 

CTLJ      ; Find previous nonspace

           FOR CIAZ=CIAPOS:-1:1

               IF $ASCII(CIADATA,CIAZ)'=32

                   QUIT 

 +1       ; Find previous space

           FOR CIAZ=CIAZ:-1:1

               IF $ASCII(CIADATA,CIAZ)=32

                   QUIT 

 +2       ; Save deleted portion

           SET CIABUF=$EXTRACT(CIADATA,CIAZ,CIAPOS)

 +3       ; Remove word

           SET CIADATA=$EXTRACT(CIADATA,1,CIAZ-1)_$EXTRACT(CIADATA,CIAPOS+1,CIALEN)

 +4        DO MOVETO(CIAZ-1)

 +5        QUIT 

CTLK      ; Save buffer

           SET CIABUF=CIADATA

 +1       ; Erase buffer

           SET CIADATA=""

 +2        DO RESET

 +3        QUIT 

CTLL      ; Save deleted portion

           SET CIABUF=$EXTRACT(CIADATA,CIAPOS+1,CIALEN)

 +1       ; Truncate at current position

           SET CIADATA=$EXTRACT(CIADATA,1,CIAPOS)

 +2        DO DSPLY(CIAPOS)

 +3        QUIT 

CTLM       DO POSCUR(CIAPOS)

           IF CIAOPT["C"

               DO INSW("~")

           DO MOVETO(CIAPOS-$X+CIAX+CIAW)

 +1        QUIT 

CTLR      ; Insert at current position

           DO INSW(CIABUF)

 +1        QUIT 

CTLT       DO CTLL

 +1        QUIT 

CTLU      ; Save deleted portion

           SET CIABUF=$EXTRACT(CIADATA,1,CIAPOS)

 +1       ; Remove to left of cursor

           SET CIADATA=$EXTRACT(CIADATA,CIAPOS+1,CIALEN)

 +2        DO RESET

 +3        QUIT 

CTLH       IF 'CIAPOS

               WRITE CIABEL

               QUIT 

 +1        DO LEFT

CTLD      ; Delete character to left

           SET CIADATA=$EXTRACT(CIADATA,1,CIAPOS)_$EXTRACT(CIADATA,CIAPOS+2,CIAMAX)

 +1        DO DSPLY(CIAPOS,1)

 +2        QUIT 

TERM       SET CIAQUIT=2

 +1        QUIT 

ESC        READ *CIAZ:1

 +1        IF CIAZ>0

               READ *CIAZ:1

 +2        SET CIAC=0

 +3       ;Execute code

           IF CIAZ=65

               GOTO UP

           IF CIAZ=66

               GOTO DOWN

           IF CIAZ=67

               GOTO RIGHT

           IF CIAZ=68

               GOTO LEFT

 +4        SET CIAC=27

 +5        QUIT 

DSPLY(CIAP1,CIAP2) ;

 +1       ; Refresh buffer display starting at position CIAP1

           IF 'CIAEON

               QUIT 

 +2        NEW CIAZ,CIAZ1

 +3        SET CIAP1=+$GET(CIAP1,CIALEFT)

           SET CIAZ=$EXTRACT(CIADATA,CIAP1+1,CIALEFT+CIALEN)

           SET CIAP2=$SELECT($DATA(CIAP2):CIAP2+$LENGTH(CIAZ),1:CIALEN-CIAP1+CIALEFT)

 +4        IF CIAP2>CIALEN

               SET CIAP2=CIALEN

 +5        SET CIAZ=CIAZ_$JUSTIFY("",CIAP2-$LENGTH(CIAZ))

 +6        FOR 

               Begin DoDot:1

 +7                DO POSCUR(CIAP1)

 +8                SET CIAZ1=CIARM-$X

 +9                IF CIAZ1<1

                       SET CIAZ1=1

 +10               WRITE $EXTRACT(CIAZ,1,CIAZ1)

 +11               SET CIAZ=$EXTRACT(CIAZ,CIAZ1+1,999)

                   SET CIAP1=CIAP1+CIAZ1

               End DoDot:1

               IF CIAZ=""

                   QUIT 

 +12       QUIT 

INSW(CIATXT) ;

 +1       ; Pad if past end of buffer

           IF CIAPOS>$LENGTH(CIADATA)

               SET CIADATA=CIADATA_$JUSTIFY("",CIAPOS-$LENGTH(CIADATA))

 +2        SET CIADATA=$EXTRACT($EXTRACT(CIADATA,1,CIAPOS)_CIATXT_$EXTRACT(CIADATA,CIAPOS+2-CIAINS,CIAMAX),1,CIAMAX)

 +3        DO DSPLY(CIAPOS,0)

           DO MOVETO(CIAPOS+$LENGTH(CIATXT))

 +4        QUIT 

POSCUR(CIAP) ;

 +1        NEW CIAZX,CIAZY

 +2        SET CIAP=+$GET(CIAP,CIAPOS)

           SET CIAZX=CIAP-CIALEFT

           SET CIAZY=CIAZX\CIAW+CIAY

           SET CIAZX=CIAZX#CIAW+CIAX

 +3        WRITE $$XY^CIAU(CIAZX,CIAZY)

 +4        QUIT 

MOVETO(CIAP) ;

 +1        IF CIAP>CIAMAX!(CIAP<0)

               WRITE CIABEL

               QUIT 

 +2        SET CIAPOS=CIAP

           SET CIAP=CIALEFT

 +3        IF CIAPOS<CIALEFT

               SET CIALEFT=CIAPOS-CIAW-1

 +4        IF CIALEFT+CIALEN<CIAPOS

               SET CIALEFT=CIAPOS-CIAW+1

 +5        IF CIALEFT'<CIAMAX

               SET CIALEFT=CIAMAX-CIAW

 +6        IF CIALEFT<0

               SET CIALEFT=0

 +7        IF CIALEFT'=CIAP

               DO DSPLY()

           DO POSCUR()

 +8        QUIT 

UP         IF CIAOPT["V"

               SET CIAQUIT=3

 +1       IF '$TEST

               DO MOVETO(CIAPOS-CIAW)

 +2        QUIT 

DOWN       IF CIAOPT["V"

               SET CIAQUIT=4

 +1       IF '$TEST

               DO MOVETO(CIAPOS+CIAW)

 +2        QUIT 

RIGHT      DO MOVETO(CIAPOS+1)

 +1        QUIT 

LEFT       DO MOVETO(CIAPOS-1)

 +1        QUIT 

RESET      WRITE $SELECT(CIAOPT["R":CIARVON,1:CIARVOFF)

 +1       ; Current edit offset

           SET (CIAPOS,CIALEFT)=0

 +2       ; Refresh display

           DO DSPLY()

 +3        QUIT 

ERROR     ; Sound bell

           WRITE CIABEL

 +1        SET @$$TRAP^CIAUOS("ERROR^CIAUEDT")

 +2        GOTO AGAIN