- 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 Jan 18, 2025@03:13:56 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