MCARDSE ;WISC/MLH-MEDICINE SCREEN HANDLER-PROCESS FIELD ;5/2/96 13:31
;;2.3;Medicine;;09/13/1996
RESPONSE(MHX,MHFL,MHDX,MHDY) ; process a response from the user
N DX,DY,MCHAR,MHY,QUIT,X
;
S X=0 X ^%ZOSF("RM") ; turn off auto wrap
X ^%ZOSF("EOFF") ; turn off echo
S DX=MHDX,DY=MHDY X IOXY ; position cursor
S MHY="" ; the output string
;
; read and process characters until the user says quit
S QUIT=0
F D RD Q:QUIT D:MCHAR>31&(MCHAR'=126)&(MCHAR<128) PROC D:MCHAR=27 PCK Q:QUIT ; don't process control chars or tilde
;
I MCHAR=13,(MHY[U) S MCMASS=1 K MCDID
I $E(MHY,1)="?" S MCMASS=1 K MCDID
I MHY="^D"!(MHY="^U") S MCMASS=1 K MCDID
; did user enter anything?
I MHY="" S MHY=MHX ; nope, default to input
S X=+$G(IOM) X ^%ZOSF("RM") ; reset margin
X ^%ZOSF("EON") ; echo on
S:$E(MHY,1)=U MHY=$$UPPER(MHY)
S:$P(DJJ(V),U,4)["S" MHY=$$UPPER(MHY)
QUIT MHY_"~"_(QUIT'=2) ; second piece indicates a timeout
UPPER(X) ;CONVERT TO UPPERCASE
N Y
X ^%ZOSF("UPPERCASE")
Q Y
;
RD ; read one character
R *MCHAR:DTIME
I MCHAR'=-1,MCHAR'=13 ;,MCHAR'=27 ;Allow the escape charcter
E S QUIT=$S(MCHAR=-1:2,1:1) ; bailout (QUIT=1) or timeout (QUIT=2)
Q
;
PROC ; process one character
I MCHAR'=127 D ; process ordinary character
. D PROCCHAR
E I MHY'="" D PROCDEL ; process <DELETE> if possible
Q
;
PROCCHAR ; process ordinary character
IF $L(MHY)<MHFL D ; not at the end yet
. W $C(MCHAR)
. I MHDX<79 S MHDX=MHDX+1
. E S (DY,MHDY)=MHDY+1,(DX,MHDX)=0 X IOXY
. S MHY=MHY_$C(MCHAR)
. Q
ELSE D ; we're at the end, start overwriting
. W $C(8,7),$C(MCHAR) ; get rid of the last char
. S MHY=$$INSERT^MCU(MHY,MHFL,MCHAR)
. Q
;END IF
Q
;
PROCDEL ; process <DELETE>
I MHDX>0 W $C(8,32,8) S MHDX=MHDX-1
E S (DX,MHDX)=79,(DY,MHDY)=MHDY-1 X IOXY W " "
S MHY=$E(MHY,1,$L(MHY)-1)
Q
;
MLH ;TEST TAG
W @IOF S TEST=$$RESPONSE^MCARDSE($G(TEST),110,0,10)
Q
PCK ;WISC/DCB-Process the escape keys see bottom for mapping
N STR,CHR S STR=$C(27) ;Set the String to Escape
F R *CHR:.001 Q:CHR=-1 S STR=STR_$C(CHR) ; Clear the buffer
I STR=IOCUD K MCDID S QUIT=1 Q
I STR=IOKP4 D JUMP Q
S MHY=$S(STR=IOCUB:"^U",STR=IOCUU:"<",STR=IOCUF:"^D",STR=IOPF1:"^T",STR=IOPF2:"^O",STR=IOPF3:"?",STR=IOPF4:"??",STR=IOKP1:"^C",STR=IOKP3:"^",STR=IOKP5:"^R",STR=IOKP6:" ",STR=IOKP9:"@",STR=IOKP7:"^H",1:"")
S:MHY'="" QUIT=1
Q
;
JUMP ;This allow the user to type in a field number w/o pressing return
N NUM,LOW,HI
S LOW=$O(DJJ("")),HI=DJL
X DJCP X XY W DJLIN X ^%ZOSF("EON") K MCDID S MCMASS=1
W !,"Input a field number",LOW," to ",HI," to jump to."
R !,"Field Number: ",NUM:DTIME I ('$T)!(NUM["^") S QUIT=2 Q
G:NUM["?" JUMP
S NUM=+NUM
I (NUM<LOW)!(NUM>HI) S MHY=U_V,QUIT=1 Q
S MHY="^"_NUM,QUIT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARDSE 2882 printed Oct 16, 2024@18:13:22 Page 2
MCARDSE ;WISC/MLH-MEDICINE SCREEN HANDLER-PROCESS FIELD ;5/2/96 13:31
+1 ;;2.3;Medicine;;09/13/1996
RESPONSE(MHX,MHFL,MHDX,MHDY) ; process a response from the user
+1 NEW DX,DY,MCHAR,MHY,QUIT,X
+2 ;
+3 ; turn off auto wrap
SET X=0
XECUTE ^%ZOSF("RM")
+4 ; turn off echo
XECUTE ^%ZOSF("EOFF")
+5 ; position cursor
SET DX=MHDX
SET DY=MHDY
XECUTE IOXY
+6 ; the output string
SET MHY=""
+7 ;
+8 ; read and process characters until the user says quit
+9 SET QUIT=0
+10 ; don't process control chars or tilde
FOR
DO RD
if QUIT
QUIT
if MCHAR>31&(MCHAR'=126)&(MCHAR<128)
DO PROC
if MCHAR=27
DO PCK
if QUIT
QUIT
+11 ;
+12 IF MCHAR=13
IF (MHY[U)
SET MCMASS=1
KILL MCDID
+13 IF $EXTRACT(MHY,1)="?"
SET MCMASS=1
KILL MCDID
+14 IF MHY="^D"!(MHY="^U")
SET MCMASS=1
KILL MCDID
+15 ; did user enter anything?
+16 ; nope, default to input
IF MHY=""
SET MHY=MHX
+17 ; reset margin
SET X=+$GET(IOM)
XECUTE ^%ZOSF("RM")
+18 ; echo on
XECUTE ^%ZOSF("EON")
+19 if $EXTRACT(MHY,1)=U
SET MHY=$$UPPER(MHY)
+20 if $PIECE(DJJ(V),U,4)["S"
SET MHY=$$UPPER(MHY)
+21 ; second piece indicates a timeout
QUIT MHY_"~"_(QUIT'=2)
UPPER(X) ;CONVERT TO UPPERCASE
+1 NEW Y
+2 XECUTE ^%ZOSF("UPPERCASE")
+3 QUIT Y
+4 ;
RD ; read one character
+1 READ *MCHAR:DTIME
+2 ;,MCHAR'=27 ;Allow the escape charcter
IF MCHAR'=-1
IF MCHAR'=13
+3 ; bailout (QUIT=1) or timeout (QUIT=2)
IF '$TEST
SET QUIT=$SELECT(MCHAR=-1:2,1:1)
+4 QUIT
+5 ;
PROC ; process one character
+1 ; process ordinary character
IF MCHAR'=127
Begin DoDot:1
+2 DO PROCCHAR
End DoDot:1
+3 ; process <DELETE> if possible
IF '$TEST
IF MHY'=""
DO PROCDEL
+4 QUIT
+5 ;
PROCCHAR ; process ordinary character
+1 ; not at the end yet
IF $LENGTH(MHY)<MHFL
Begin DoDot:1
+2 WRITE $CHAR(MCHAR)
+3 IF MHDX<79
SET MHDX=MHDX+1
+4 IF '$TEST
SET (DY,MHDY)=MHDY+1
SET (DX,MHDX)=0
XECUTE IOXY
+5 SET MHY=MHY_$CHAR(MCHAR)
+6 QUIT
End DoDot:1
+7 ; we're at the end, start overwriting
IF '$TEST
Begin DoDot:1
+8 ; get rid of the last char
WRITE $CHAR(8,7),$CHAR(MCHAR)
+9 SET MHY=$$INSERT^MCU(MHY,MHFL,MCHAR)
+10 QUIT
End DoDot:1
+11 ;END IF
+12 QUIT
+13 ;
PROCDEL ; process <DELETE>
+1 IF MHDX>0
WRITE $CHAR(8,32,8)
SET MHDX=MHDX-1
+2 IF '$TEST
SET (DX,MHDX)=79
SET (DY,MHDY)=MHDY-1
XECUTE IOXY
WRITE " "
+3 SET MHY=$EXTRACT(MHY,1,$LENGTH(MHY)-1)
+4 QUIT
+5 ;
MLH ;TEST TAG
+1 WRITE @IOF
SET TEST=$$RESPONSE^MCARDSE($GET(TEST),110,0,10)
+2 QUIT
PCK ;WISC/DCB-Process the escape keys see bottom for mapping
+1 ;Set the String to Escape
NEW STR,CHR
SET STR=$CHAR(27)
+2 ; Clear the buffer
FOR
READ *CHR:.001
if CHR=-1
QUIT
SET STR=STR_$CHAR(CHR)
+3 IF STR=IOCUD
KILL MCDID
SET QUIT=1
QUIT
+4 IF STR=IOKP4
DO JUMP
QUIT
+5 SET MHY=$SELECT(STR=IOCUB:"^U",STR=IOCUU:"<",STR=IOCUF:"^D",STR=IOPF1:"^T",STR=IOPF2:"^O",STR=IOPF3:"?",STR=IOPF4:"??",STR=IOKP1:"^C",STR=IOKP3:"^",STR=IOKP5:"^R",STR=IOKP6:" ",STR=IOKP9:"@",STR=IOKP7:"^H",1:"")
+6 if MHY'=""
SET QUIT=1
+7 QUIT
+8 ;
JUMP ;This allow the user to type in a field number w/o pressing return
+1 NEW NUM,LOW,HI
+2 SET LOW=$ORDER(DJJ(""))
SET HI=DJL
+3 XECUTE DJCP
XECUTE XY
WRITE DJLIN
XECUTE ^%ZOSF("EON")
KILL MCDID
SET MCMASS=1
+4 WRITE !,"Input a field number",LOW," to ",HI," to jump to."
+5 READ !,"Field Number: ",NUM:DTIME
IF ('$TEST)!(NUM["^")
SET QUIT=2
QUIT
+6 if NUM["?"
GOTO JUMP
+7 SET NUM=+NUM
+8 IF (NUM<LOW)!(NUM>HI)
SET MHY=U_V
SET QUIT=1
QUIT
+9 SET MHY="^"_NUM
SET QUIT=1
+10 QUIT
