- DDWG ;SFISC/MKO-GOTO ;05:49 PM 24 Aug 2002
- ;;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.
- ;
- GOTO ;Go to a specific location
- N DDWANS,DDWI,DDWHLP
- D BLD^DIALOG(8140,,,"DDWHLP") ;**
- D ASK(4,$$EZBLD^DIALOG(7069)_": ",17,"","D VALGTO",.DDWHLP,.DDWANS) ;**
- I U[DDWANS
- E I "Ss"[$E(DDWANS)!(DDWANS'?1A.E) D
- . D GOTOS
- E I "Ll"[$E(DDWANS) D
- . D GOTOL
- E I "Cc"[$E(DDWANS) D
- . D GOTOC
- Q
- ;
- GOTOS ;Go to a page
- N DDWS
- S DDWS=DDWANS
- S:DDWS?1A.E DDWS=$E(DDWS,2,999)
- S:DDWS?1P.E DDWS=$E(DDWS,2,999)
- I DDWANS["+" S DDWS=$$SCREEN+DDWS
- E I DDWANS["-" S DDWS=$$SCREEN-DDWS
- I DDWS<1 S DDWS=1
- E I DDWS>$$LTOSC(DDWCNT) S DDWS=$$LTOSC(DDWCNT)
- D LINE(DDWS-1*DDWMR+1)
- Q
- ;
- GOTOL ;Go to a line
- N DDWLN
- S DDWLN=DDWANS
- S:DDWLN?1A.E DDWLN=$E(DDWLN,2,999)
- S:DDWLN?1P.E DDWLN=$E(DDWLN,2,999)
- I DDWANS["+" S DDWLN=DDWA+DDWRW+DDWLN
- E I DDWANS["-" S DDWLN=DDWA+DDWRW-DDWLN
- I DDWLN<1 S DDWLN=1
- E I DDWLN>DDWCNT S DDWLN=DDWCNT
- D LINE(DDWLN)
- Q
- ;
- GOTOC ;Go to a column
- N DDWCOL
- S DDWCOL=DDWANS
- S:DDWCOL?1A.E DDWCOL=$E(DDWCOL,2,999)
- S:DDWCOL?1P.E DDWCOL=$E(DDWCOL,2,999)
- I DDWANS["+" S DDWCOL=DDWC+DDWCOL
- E I DDWANS["-" S DDWCOL=DDWC-DDWCOL
- I DDWCOL<1 S DDWCOL=1
- E I DDWCOL>246 S DDWCOL=246
- D POS(DDWRW,DDWCOL,"R")
- Q
- ;
- LINE(DDWLN,DDWCOL) ;Adjust arrays and position cursor on line DDWLN
- I $G(DDWCOL)'="E",'$G(DDWCOL) S DDWCOL=1
- S:DDWLN>DDWCNT DDWLN=DDWCNT
- I DDWLN>DDWA,DDWLN'>(DDWA+DDWMR-1) D
- . D POS(DDWLN-DDWA,DDWCOL,"RN")
- E I DDWLN>DDWA D
- . D SHFTDN^DDW3(DDWLN,DDWCOL),POS(DDWLN-DDWA,DDWCOL,"RN")
- E D
- . D SHFTUP^DDW3(DDWLN),POS(1,DDWCOL,"RN")
- Q
- ;
- ASK(DDWLC,DDWS,DDWLEN,DDWDEF,DDWVAL,DDWHLP,DDWANS,DDWCOD) ;Prompt user
- N DDWI
- D CUP(DDWMR-DDWLC,1)
- W $P(DDGLGRA,DDGLDEL)_$TR($J("",IOM)," ",$P(DDGLGRA,DDGLDEL,3))_$P(DDGLGRA,DDGLDEL,2)
- F DDWI=DDWMR-DDWLC+1:1:DDWMR D CUP(DDWI,1) W $P(DDGLCLR,DDGLDEL)
- K DDWANS F D PROMPT Q:$D(DDWANS)
- ;
- F DDWI=DDWMR-DDWLC:1:DDWMR D
- . D CUP(DDWI,1)
- . W $P(DDGLCLR,DDGLDEL)_$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)
- D POS(DDWRW,DDWC,"RN")
- Q
- ;
- PROMPT ;Issue read
- N DDWERR,DDWX
- D CUP(DDWMR-DDWLC+1,1) W DDWS_$P(DDGLCLR,DDGLDEL)
- D EN^DIR0(IOTM+DDWMR-DDWLC-1,$L(DDWS),DDWLEN,1,$G(DDWDEF),245,"","","AKTW",.DDWX,.DDWCOD)
- ;
- I DDWX?1."?",$D(DDWHLP)>9!($G(DDWHLP)]"") D HELP(.DDWHLP) Q
- I $G(DDWVAL)]"" X DDWVAL I $D(DDWERR) W $C(7) D HELP(.DDWERR) Q
- S DDWANS=DDWX
- Q
- ;
- VALGTO ;Validate DDWX
- N DDWCH
- Q:U[DDWX
- S DDWERR=$$EZBLD^DIALOG(1401) ;**
- Q:DDWX'?.1A.1P1.15N
- I DDWX?1A.E S DDWCH=$E(DDWX) Q:"SsLlCc"'[DDWCH
- I DDWX?.E1P.E I DDWX'["+",DDWX'["-" Q
- K DDWERR
- Q
- ;
- HELP(DDWMSG) ;Print message
- N DDWI,DDWEC
- S:$D(DDWMSG)<9 DDWMSG(1)=DDWMSG
- S DDWEC=$O(DDWMSG(""),-1)
- F DDWI=2:1:DDWLC D
- . D CUP(DDWMR-DDWLC+DDWI,1)
- . W $P(DDGLCLR,DDGLDEL)_$G(DDWMSG(DDWI-DDWLC+DDWEC))
- Q
- ;
- SCREEN() ;Return current screen
- Q DDWA+DDWRW-1\DDWMR+1
- ;
- LTOSC(L) ;Convert line number to page number
- Q L-1\DDWMR+1
- ;
- CUP(Y,X) ;Pos cursor
- S DY=IOTM+Y-2,DX=X-1 X IOXY
- Q
- ;
- POS(R,C,F) ;Pos cursor based on char pos C
- N DDWX
- S:$G(C)="E" C=$L($G(DDWL(R)))+1
- S:$G(F)["N" DDWN=$G(DDWL(R))
- S:$G(F)["R" DDWRW=R,DDWC=C
- ;
- S DDWX=C-DDWOFS
- I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)
- S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDWG 3549 printed Jan 18, 2025@03:45:02 Page 2
- DDWG ;SFISC/MKO-GOTO ;05:49 PM 24 Aug 2002
- +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 ;
- GOTO ;Go to a specific location
- +1 NEW DDWANS,DDWI,DDWHLP
- +2 ;**
- DO BLD^DIALOG(8140,,,"DDWHLP")
- +3 ;**
- DO ASK(4,$$EZBLD^DIALOG(7069)_": ",17,"","D VALGTO",.DDWHLP,.DDWANS)
- +4 IF U[DDWANS
- +5 IF '$TEST
- IF "Ss"[$EXTRACT(DDWANS)!(DDWANS'?1A.E)
- Begin DoDot:1
- +6 DO GOTOS
- End DoDot:1
- +7 IF '$TEST
- IF "Ll"[$EXTRACT(DDWANS)
- Begin DoDot:1
- +8 DO GOTOL
- End DoDot:1
- +9 IF '$TEST
- IF "Cc"[$EXTRACT(DDWANS)
- Begin DoDot:1
- +10 DO GOTOC
- End DoDot:1
- +11 QUIT
- +12 ;
- GOTOS ;Go to a page
- +1 NEW DDWS
- +2 SET DDWS=DDWANS
- +3 if DDWS?1A.E
- SET DDWS=$EXTRACT(DDWS,2,999)
- +4 if DDWS?1P.E
- SET DDWS=$EXTRACT(DDWS,2,999)
- +5 IF DDWANS["+"
- SET DDWS=$$SCREEN+DDWS
- +6 IF '$TEST
- IF DDWANS["-"
- SET DDWS=$$SCREEN-DDWS
- +7 IF DDWS<1
- SET DDWS=1
- +8 IF '$TEST
- IF DDWS>$$LTOSC(DDWCNT)
- SET DDWS=$$LTOSC(DDWCNT)
- +9 DO LINE(DDWS-1*DDWMR+1)
- +10 QUIT
- +11 ;
- GOTOL ;Go to a line
- +1 NEW DDWLN
- +2 SET DDWLN=DDWANS
- +3 if DDWLN?1A.E
- SET DDWLN=$EXTRACT(DDWLN,2,999)
- +4 if DDWLN?1P.E
- SET DDWLN=$EXTRACT(DDWLN,2,999)
- +5 IF DDWANS["+"
- SET DDWLN=DDWA+DDWRW+DDWLN
- +6 IF '$TEST
- IF DDWANS["-"
- SET DDWLN=DDWA+DDWRW-DDWLN
- +7 IF DDWLN<1
- SET DDWLN=1
- +8 IF '$TEST
- IF DDWLN>DDWCNT
- SET DDWLN=DDWCNT
- +9 DO LINE(DDWLN)
- +10 QUIT
- +11 ;
- GOTOC ;Go to a column
- +1 NEW DDWCOL
- +2 SET DDWCOL=DDWANS
- +3 if DDWCOL?1A.E
- SET DDWCOL=$EXTRACT(DDWCOL,2,999)
- +4 if DDWCOL?1P.E
- SET DDWCOL=$EXTRACT(DDWCOL,2,999)
- +5 IF DDWANS["+"
- SET DDWCOL=DDWC+DDWCOL
- +6 IF '$TEST
- IF DDWANS["-"
- SET DDWCOL=DDWC-DDWCOL
- +7 IF DDWCOL<1
- SET DDWCOL=1
- +8 IF '$TEST
- IF DDWCOL>246
- SET DDWCOL=246
- +9 DO POS(DDWRW,DDWCOL,"R")
- +10 QUIT
- +11 ;
- LINE(DDWLN,DDWCOL) ;Adjust arrays and position cursor on line DDWLN
- +1 IF $GET(DDWCOL)'="E"
- IF '$GET(DDWCOL)
- SET DDWCOL=1
- +2 if DDWLN>DDWCNT
- SET DDWLN=DDWCNT
- +3 IF DDWLN>DDWA
- IF DDWLN'>(DDWA+DDWMR-1)
- Begin DoDot:1
- +4 DO POS(DDWLN-DDWA,DDWCOL,"RN")
- End DoDot:1
- +5 IF '$TEST
- IF DDWLN>DDWA
- Begin DoDot:1
- +6 DO SHFTDN^DDW3(DDWLN,DDWCOL)
- DO POS(DDWLN-DDWA,DDWCOL,"RN")
- End DoDot:1
- +7 IF '$TEST
- Begin DoDot:1
- +8 DO SHFTUP^DDW3(DDWLN)
- DO POS(1,DDWCOL,"RN")
- End DoDot:1
- +9 QUIT
- +10 ;
- ASK(DDWLC,DDWS,DDWLEN,DDWDEF,DDWVAL,DDWHLP,DDWANS,DDWCOD) ;Prompt user
- +1 NEW DDWI
- +2 DO CUP(DDWMR-DDWLC,1)
- +3 WRITE $PIECE(DDGLGRA,DDGLDEL)_$TRANSLATE($JUSTIFY("",IOM)," ",$PIECE(DDGLGRA,DDGLDEL,3))_$PIECE(DDGLGRA,DDGLDEL,2)
- +4 FOR DDWI=DDWMR-DDWLC+1:1:DDWMR
- DO CUP(DDWI,1)
- WRITE $PIECE(DDGLCLR,DDGLDEL)
- +5 KILL DDWANS
- FOR
- DO PROMPT
- if $DATA(DDWANS)
- QUIT
- +6 ;
- +7 FOR DDWI=DDWMR-DDWLC:1:DDWMR
- Begin DoDot:1
- +8 DO CUP(DDWI,1)
- +9 WRITE $PIECE(DDGLCLR,DDGLDEL)_$EXTRACT(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)
- End DoDot:1
- +10 DO POS(DDWRW,DDWC,"RN")
- +11 QUIT
- +12 ;
- PROMPT ;Issue read
- +1 NEW DDWERR,DDWX
- +2 DO CUP(DDWMR-DDWLC+1,1)
- WRITE DDWS_$PIECE(DDGLCLR,DDGLDEL)
- +3 DO EN^DIR0(IOTM+DDWMR-DDWLC-1,$LENGTH(DDWS),DDWLEN,1,$GET(DDWDEF),245,"","","AKTW",.DDWX,.DDWCOD)
- +4 ;
- +5 IF DDWX?1."?"
- IF $DATA(DDWHLP)>9!($GET(DDWHLP)]"")
- DO HELP(.DDWHLP)
- QUIT
- +6 IF $GET(DDWVAL)]""
- XECUTE DDWVAL
- IF $DATA(DDWERR)
- WRITE $CHAR(7)
- DO HELP(.DDWERR)
- QUIT
- +7 SET DDWANS=DDWX
- +8 QUIT
- +9 ;
- VALGTO ;Validate DDWX
- +1 NEW DDWCH
- +2 if U[DDWX
- QUIT
- +3 ;**
- SET DDWERR=$$EZBLD^DIALOG(1401)
- +4 if DDWX'?.1A.1P1.15N
- QUIT
- +5 IF DDWX?1A.E
- SET DDWCH=$EXTRACT(DDWX)
- if "SsLlCc"'[DDWCH
- QUIT
- +6 IF DDWX?.E1P.E
- IF DDWX'["+"
- IF DDWX'["-"
- QUIT
- +7 KILL DDWERR
- +8 QUIT
- +9 ;
- HELP(DDWMSG) ;Print message
- +1 NEW DDWI,DDWEC
- +2 if $DATA(DDWMSG)<9
- SET DDWMSG(1)=DDWMSG
- +3 SET DDWEC=$ORDER(DDWMSG(""),-1)
- +4 FOR DDWI=2:1:DDWLC
- Begin DoDot:1
- +5 DO CUP(DDWMR-DDWLC+DDWI,1)
- +6 WRITE $PIECE(DDGLCLR,DDGLDEL)_$GET(DDWMSG(DDWI-DDWLC+DDWEC))
- End DoDot:1
- +7 QUIT
- +8 ;
- SCREEN() ;Return current screen
- +1 QUIT DDWA+DDWRW-1\DDWMR+1
- +2 ;
- LTOSC(L) ;Convert line number to page number
- +1 QUIT L-1\DDWMR+1
- +2 ;
- CUP(Y,X) ;Pos cursor
- +1 SET DY=IOTM+Y-2
- SET DX=X-1
- XECUTE IOXY
- +2 QUIT
- +3 ;
- POS(R,C,F) ;Pos cursor based on char pos C
- +1 NEW DDWX
- +2 if $GET(C)="E"
- SET C=$LENGTH($GET(DDWL(R)))+1
- +3 if $GET(F)["N"
- SET DDWN=$GET(DDWL(R))
- +4 if $GET(F)["R"
- SET DDWRW=R
- SET DDWC=C
- +5 ;
- +6 SET DDWX=C-DDWOFS
- +7 IF DDWX>IOM!(DDWX<1)
- DO SHIFT^DDW3(C,.DDWOFS)
- +8 SET DY=IOTM+R-2
- SET DX=C-DDWOFS-1
- XECUTE IOXY
- +9 QUIT