- DDSU ;SFISC/MLH-PROCESS HELP ;10:48 AM 6 Sep 2006
- ;;22.0;VA FileMan;**4,3,54,151**;Mar 30, 1999;Build 10
- ;Per VHA Directive 2004-038, this routine should not be modified.
- LIST ;
- D FM:'$D(DDS),SC:$D(DDS)
- Q
- ;
- SC ;Screen Help
- N A0,A1,A2,A3,A4,A5,A6,DDSB1,X,Y
- K DTOUT,DUOUT
- ;
- W $P(DDGLVID,DDGLDEL,9) S X=$G(IOM,80)-1 X ^%ZOSF("RM")
- I $D(DDQ)#2,DDQ<(IOSL-1),DDQ>DDSHBX!$P(DDQ,U,2)!$D(DDIOL) S DY=$P(DDQ,U),DX=$P(DDQ,U,2)
- E D CLRMSG^DDS S DY=DDSHBX
- X DDXY
- ;
- S:$G(DDD,5)=5 DDD=1
- S:$D(DDO) DDSB1=DDO
- S DDM=1,DDO=.5
- S (A0,DIY,X)="",A1=0,A5=$S(DDD=2:$O(DS(0)),1:$O(DDH(A0)))
- K A2,DDSQ
- ;
- F D SC1 Q:DDO'<1!(X=U)!'A0!DIY!$D(DTOUT)!$D(DUOUT)
- ;
- I $D(DDSB1) S:DDO<1 DDO=DDSB1
- E K DDO
- ;
- S %=0
- S DDQ=$S(DY>(IOSL-1):IOSL-1,1:DY)_U_DX
- S:DDQ>DDSHBX DDM=1
- I $D(A2) K DDD,DDH,DDQ S %=A2 S:%'=1 DDSQ=1 D CLRMSG^DDS G QQ
- I $D(DDC),DDC'<0 D SV
- E K DDD,DDH S DDSQ=1
- ;
- QQ S A0=$X S X=0 X ^%ZOSF("RM") W $P(DDGLVID,DDGLDEL,8) S $X=A0
- Q
- ;
- SC1 S A6=A0,A0=$O(DDH(A0)) S:A6="" A6=A0-1
- I 'A0,DDD Q:DDD=1 Q:DD<DS
- ;
- S A4=$O(DDH(+A0,""))
- I A4'="X"!(DY'>DDSHBX) S DY=DY+1 X DDXY
- I A4="E" D SC2 Q
- ;
- I $D(DDSCTRL) S:+DDSCTRL'=DDSCTRL!(DDSCTRL>3)!(DDSCTRL<1)!(DDSCTRL?.E1"."1N.N) DDSCTRL=2 ;DI*151
- I $Y'<(IOSL-($G(DDSCTRL,2)))!'A0 D SC2 Q:DDO'<1!(X=U)!'A0!DIY!$D(DTOUT)!$D(DUOUT) S DY=DDSHBX+1,DX=0 X DDXY ;DI*151
- Q:A4=""
- ;
- D WR
- ;
- I $Y'<(IOSL-1),'$D(DTOUT),'$D(DUOUT) D Q
- . W ! D SC2
- . W $P(DDGLVID,DDGLDEL,8) S X=0 X ^%ZOSF("RM") D REFRESH^DDSUTL
- . W $P(DDGLVID,DDGLDEL,9) S X=$G(IOM,80)-1 X ^%ZOSF("RM")
- . S DX=0,DY=DDSHBX X DDXY
- ;
- S DY=$Y,DX=0
- Q
- ;
- SC2 S DX=0,DY=IOSL-1 X DDXY
- W $S(DDD=1:$$EZBLD^DIALOG(8053),1:$$EZBLD^DIALOG(8081,A5_"-"_A6))_$P(DDGLCLR,DDGLDEL)
- ;
- R X:DTIME E S DTOUT=1 K DDC G Q2
- I X?1."^" S DUOUT=1,X=U K DDC G Q2
- ;
- I X]"",X<A5!(X>A6) W $C(7) G SC2
- E I X S:DDD["J" DDO=$O(DDH(X,"")) K DDC
- D CLRMSG^DDS
- S DDM=1
- ;
- Q2 S DIY=X,DY=DDSHBX
- Q
- ;
- ASK W $P(A4,U,2)_$S(%'>2:"? ",1:"")_$S(%>0&(%<3):$P($$EZBLD^DIALOG(7001),U,%)_"// ",1:"")_$P(DDGLCLR,DDGLDEL)
- S A2=0
- R X:$G(DTIME,300) E S DTOUT=1,A2=-1 Q
- ;
- I %>2 S A2=X Q
- ;
- N %1 S %1=$$PRS^DIALOGU(7001,X) S:%1>0 X=$E($P(%1,U,2))
- K %1
- ;
- I "YyNn^"'[X W $C(7) X DDXY G ASK
- I X]"","^Nn"[X S A2=2 K DDC Q
- S:"Yy"[X A2=1
- S:X=""&(%]"") A2=+%
- S DDD=1
- Q
- ;
- SV ;Kill DDH array, but save the "ID" nodes and DDH itself
- K A1,A2
- S:$D(DDH("ID")) A1=DDH("ID")
- S:$D(DDH("ID",1)) A2=DDH("ID",1)
- K DDH S DDH=0
- S:$D(A1) DDH("ID")=A1
- S:$D(A2) DDH("ID",1)=A2
- Q
- ;
- FM ;FileMan help - Non screen
- N A0,A1,A2,A3,A4,DDSDIW,DDSDIY,Y
- S A0=""
- F S A0=$O(DDH(A0)) Q:'A0 S DDSDIW=$X,DDSDIY=$Y D W I $G(DDD)>2,DDSDIW-$X!(DDSDIY-$Y) D STP Q:$D(DTOUT)
- I $G(DIPGM)="DICQ1",$G(DP),$G(DIC("?N",DP)) D
- . N DIZ S DIZ=0 D T Q
- ;
- Q I '$D(DTOUT) D SV S DDH=0 Q
- K DDH D:'DTOUT Q
- . K DTOUT N % S %=$G(DIPGM) I %'="DICQ1",%'="DIEQ" Q
- . S DUOUT=1 Q
- Q
- ;
- STP Q:$D(DD)[0!($D(DIY)[0) I DD+DIY'>79 W ?DD S DD=DD+DIY Q
- ;
- T W !?3 S DD=DIY+3
- I $Y>DIZ!'$Y D
- . R "'^' TO STOP: ",%Y:$G(DTIME,300)
- . E S DTOUT=1 K DDD
- . W $C(13),$J("",15),$C(13) Q:$D(DTOUT)
- . I %Y[U S DTOUT=0 K DDD
- . D Y W ?3
- Q
- ;
- W S A4=$O(DDH(A0,"")) Q:A4="" Q:DDH(A0,A4)=""
- W:'$D(DDD) !
- I $G(DDD)=3,A4["T" K DDD
- ;
- WR I A4["X" D Q
- . N DDD,DIY,DDSXEC
- . S DDSXEC=DDH(A0,A4)
- . N DDH
- . I $D(DDS) N DDSID S DDSID=1 S DDQ=$S(DY>(IOSL-1):IOSL-1,1:DY)_U_DX
- . X DDSXEC
- ;
- I A4["Q" D Q
- . S A4=DDH(A0,A4),%=$P(A4,U,1)
- . I $D(DDS) D ASK Q
- . W $P(A4,U,2)
- . D YN^DICN
- ;
- I A4["T" D Q
- . I DDH(A0,A4)[$C(0) D
- .. S DX=$L(DDH(A0,A4),$C(0))-1
- .. X DDXY
- .. S DDH(A0,A4)=$TR(DDH(A0,A4),$C(0),"")
- . W DDH(A0,A4)
- ;
- I '$D(DDS),$G(DDD)'["J",A4'=+A4 Q
- I $D(DDS),$G(DDD)=2!($G(DDD)["J") W A0,?7
- ;
- W DDH(A0,A4)
- I $D(DDH("ID")) D S:$D(DUOUT) DIY=U
- . N DDD,DIY,DDSID
- . S DDSID=DDH("ID")
- . S:$D(DDH("ID",1))#2 DDSID(1)=DDH("ID",1)
- . N DDH
- . S:$D(DDSID(1))#2 DDH("ID",1)=DDSID(1) K DDSID(1)
- . S Y=A4
- . S:$D(DDS) DDQ=$S(DY>(IOSL-1):IOSL-1,1:DY)_U_$X
- . X DDSID
- Q
- ;
- Y D:'$D(DISYS) OS^DII
- S $X=0,$Y=0
- S DIZ=$S($D(DILN)&'$D(DIR0):DILN,1:21)
- Q
- ;
- Z D Y,T
- Q
- ;
- H S:'$D(A1) A1="T"
- S DDH=$G(DDH)+1,DDH(DDH,A1)=DST
- K A1,DST
- D SC
- Q
- ;#8053 Press 'RETURN' to continue...
- ;#8081 Choose |from-to| or '^'...
- ;#7001 Yes^No
- DDSU ;SFISC/MLH-PROCESS HELP ;10:48 AM 6 Sep 2006
- +1 ;;22.0;VA FileMan;**4,3,54,151**;Mar 30, 1999;Build 10
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- LIST ;
- +1 IF '$DATA(DDS)
- DO FM
- IF $DATA(DDS)
- DO SC
- +2 QUIT
- +3 ;
- SC ;Screen Help
- +1 NEW A0,A1,A2,A3,A4,A5,A6,DDSB1,X,Y
- +2 KILL DTOUT,DUOUT
- +3 ;
- +4 WRITE $PIECE(DDGLVID,DDGLDEL,9)
- SET X=$GET(IOM,80)-1
- XECUTE ^%ZOSF("RM")
- +5 IF $DATA(DDQ)#2
- IF DDQ<(IOSL-1)
- IF DDQ>DDSHBX!$PIECE(DDQ,U,2)!$DATA(DDIOL)
- SET DY=$PIECE(DDQ,U)
- SET DX=$PIECE(DDQ,U,2)
- +6 IF '$TEST
- DO CLRMSG^DDS
- SET DY=DDSHBX
- +7 XECUTE DDXY
- +8 ;
- +9 IF $GET(DDD,5)=5
- SET DDD=1
- +10 IF $DATA(DDO)
- SET DDSB1=DDO
- +11 SET DDM=1
- SET DDO=.5
- +12 SET (A0,DIY,X)=""
- SET A1=0
- SET A5=$SELECT(DDD=2:$ORDER(DS(0)),1:$ORDER(DDH(A0)))
- +13 KILL A2,DDSQ
- +14 ;
- +15 FOR
- DO SC1
- IF DDO'<1!(X=U)!'A0!DIY!$DATA(DTOUT)!$DATA(DUOUT)
- QUIT
- +16 ;
- +17 IF $DATA(DDSB1)
- IF DDO<1
- SET DDO=DDSB1
- +18 IF '$TEST
- KILL DDO
- +19 ;
- +20 SET %=0
- +21 SET DDQ=$SELECT(DY>(IOSL-1):IOSL-1,1:DY)_U_DX
- +22 IF DDQ>DDSHBX
- SET DDM=1
- +23 IF $DATA(A2)
- KILL DDD,DDH,DDQ
- SET %=A2
- IF %'=1
- SET DDSQ=1
- DO CLRMSG^DDS
- GOTO QQ
- +24 IF $DATA(DDC)
- IF DDC'<0
- DO SV
- +25 IF '$TEST
- KILL DDD,DDH
- SET DDSQ=1
- +26 ;
- QQ SET A0=$X
- SET X=0
- XECUTE ^%ZOSF("RM")
- WRITE $PIECE(DDGLVID,DDGLDEL,8)
- SET $X=A0
- +1 QUIT
- +2 ;
- SC1 SET A6=A0
- SET A0=$ORDER(DDH(A0))
- IF A6=""
- SET A6=A0-1
- +1 IF 'A0
- IF DDD
- IF DDD=1
- QUIT
- IF DD<DS
- QUIT
- +2 ;
- +3 SET A4=$ORDER(DDH(+A0,""))
- +4 IF A4'="X"!(DY'>DDSHBX)
- SET DY=DY+1
- XECUTE DDXY
- +5 IF A4="E"
- DO SC2
- QUIT
- +6 ;
- +7 ;DI*151
- IF $DATA(DDSCTRL)
- IF +DDSCTRL'=DDSCTRL!(DDSCTRL>3)!(DDSCTRL<1)!(DDSCTRL?.E1"."1N.N)
- SET DDSCTRL=2
- +8 ;DI*151
- IF $Y'<(IOSL-($GET(DDSCTRL,2)))!'A0
- DO SC2
- IF DDO'<1!(X=U)!'A0!DIY!$DATA(DTOUT)!$DATA(DUOUT)
- QUIT
- SET DY=DDSHBX+1
- SET DX=0
- XECUTE DDXY
- +9 IF A4=""
- QUIT
- +10 ;
- +11 DO WR
- +12 ;
- +13 IF $Y'<(IOSL-1)
- IF '$DATA(DTOUT)
- IF '$DATA(DUOUT)
- Begin DoDot:1
- +14 WRITE !
- DO SC2
- +15 WRITE $PIECE(DDGLVID,DDGLDEL,8)
- SET X=0
- XECUTE ^%ZOSF("RM")
- DO REFRESH^DDSUTL
- +16 WRITE $PIECE(DDGLVID,DDGLDEL,9)
- SET X=$GET(IOM,80)-1
- XECUTE ^%ZOSF("RM")
- +17 SET DX=0
- SET DY=DDSHBX
- XECUTE DDXY
- End DoDot:1
- QUIT
- +18 ;
- +19 SET DY=$Y
- SET DX=0
- +20 QUIT
- +21 ;
- SC2 SET DX=0
- SET DY=IOSL-1
- XECUTE DDXY
- +1 WRITE $SELECT(DDD=1:$$EZBLD^DIALOG(8053),1:$$EZBLD^DIALOG(8081,A5_"-"_A6))_$PIECE(DDGLCLR,DDGLDEL)
- +2 ;
- +3 READ X:DTIME
- IF '$TEST
- SET DTOUT=1
- KILL DDC
- GOTO Q2
- +4 IF X?1."^"
- SET DUOUT=1
- SET X=U
- KILL DDC
- GOTO Q2
- +5 ;
- +6 IF X]""
- IF X<A5!(X>A6)
- WRITE $CHAR(7)
- GOTO SC2
- +7 IF '$TEST
- IF X
- IF DDD["J"
- SET DDO=$ORDER(DDH(X,""))
- KILL DDC
- +8 DO CLRMSG^DDS
- +9 SET DDM=1
- +10 ;
- Q2 SET DIY=X
- SET DY=DDSHBX
- +1 QUIT
- +2 ;
- ASK WRITE $PIECE(A4,U,2)_$SELECT(%'>2:"? ",1:"")_$SELECT(%>0&(%<3):$PIECE($$EZBLD^DIALOG(7001),U,%)_"// ",1:"")_$PIECE(DDGLCLR,DDGLDEL)
- +1 SET A2=0
- +2 READ X:$GET(DTIME,300)
- IF '$TEST
- SET DTOUT=1
- SET A2=-1
- QUIT
- +3 ;
- +4 IF %>2
- SET A2=X
- QUIT
- +5 ;
- +6 NEW %1
- SET %1=$$PRS^DIALOGU(7001,X)
- IF %1>0
- SET X=$EXTRACT($PIECE(%1,U,2))
- +7 KILL %1
- +8 ;
- +9 IF "YyNn^"'[X
- WRITE $CHAR(7)
- XECUTE DDXY
- GOTO ASK
- +10 IF X]""
- IF "^Nn"[X
- SET A2=2
- KILL DDC
- QUIT
- +11 IF "Yy"[X
- SET A2=1
- +12 IF X=""&(%]"")
- SET A2=+%
- +13 SET DDD=1
- +14 QUIT
- +15 ;
- SV ;Kill DDH array, but save the "ID" nodes and DDH itself
- +1 KILL A1,A2
- +2 IF $DATA(DDH("ID"))
- SET A1=DDH("ID")
- +3 IF $DATA(DDH("ID",1))
- SET A2=DDH("ID",1)
- +4 KILL DDH
- SET DDH=0
- +5 IF $DATA(A1)
- SET DDH("ID")=A1
- +6 IF $DATA(A2)
- SET DDH("ID",1)=A2
- +7 QUIT
- +8 ;
- FM ;FileMan help - Non screen
- +1 NEW A0,A1,A2,A3,A4,DDSDIW,DDSDIY,Y
- +2 SET A0=""
- +3 FOR
- SET A0=$ORDER(DDH(A0))
- IF 'A0
- QUIT
- SET DDSDIW=$X
- SET DDSDIY=$Y
- DO W
- IF $GET(DDD)>2
- IF DDSDIW-$X!(DDSDIY-$Y)
- DO STP
- IF $DATA(DTOUT)
- QUIT
- +4 IF $GET(DIPGM)="DICQ1"
- IF $GET(DP)
- IF $GET(DIC("?N",DP))
- Begin DoDot:1
- +5 NEW DIZ
- SET DIZ=0
- DO T
- QUIT
- End DoDot:1
- +6 ;
- Q IF '$DATA(DTOUT)
- DO SV
- SET DDH=0
- QUIT
- +1 KILL DDH
- IF 'DTOUT
- Begin DoDot:1
- +2 KILL DTOUT
- NEW %
- SET %=$GET(DIPGM)
- IF %'="DICQ1"
- IF %'="DIEQ"
- QUIT
- +3 SET DUOUT=1
- QUIT
- End DoDot:1
- QUIT
- +4 QUIT
- +5 ;
- STP IF $DATA(DD)[0!($DATA(DIY)[0)
- QUIT
- IF DD+DIY'>79
- WRITE ?DD
- SET DD=DD+DIY
- QUIT
- +1 ;
- T WRITE !?3
- SET DD=DIY+3
- +1 IF $Y">Y>DIZ!'$Y">Y
- Begin DoDot:1
- +2 READ "'^' TO STOP: ",%Y:$GET(DTIME,300)
- +3 IF '$TEST
- SET DTOUT=1
- KILL DDD
- +4 WRITE $CHAR(13),$JUSTIFY("",15),$CHAR(13)
- IF $DATA(DTOUT)
- QUIT
- +5 IF %Y[U
- SET DTOUT=0
- KILL DDD
- +6 DO Y
- WRITE ?3
- End DoDot:1
- +7 QUIT
- +8 ;
- W SET A4=$ORDER(DDH(A0,""))
- IF A4=""
- QUIT
- IF DDH(A0,A4)=""
- QUIT
- +1 IF '$DATA(DDD)
- WRITE !
- +2 IF $GET(DDD)=3
- IF A4["T"
- KILL DDD
- +3 ;
- WR IF A4["X"
- Begin DoDot:1
- +1 NEW DDD,DIY,DDSXEC
- +2 SET DDSXEC=DDH(A0,A4)
- +3 NEW DDH
- +4 IF $DATA(DDS)
- NEW DDSID
- SET DDSID=1
- SET DDQ=$SELECT(DY>(IOSL-1):IOSL-1,1:DY)_U_DX
- +5 XECUTE DDSXEC
- End DoDot:1
- QUIT
- +6 ;
- +7 IF A4["Q"
- Begin DoDot:1
- +8 SET A4=DDH(A0,A4)
- SET %=$PIECE(A4,U,1)
- +9 IF $DATA(DDS)
- DO ASK
- QUIT
- +10 WRITE $PIECE(A4,U,2)
- +11 DO YN^DICN
- End DoDot:1
- QUIT
- +12 ;
- +13 IF A4["T"
- Begin DoDot:1
- +14 IF DDH(A0,A4)[$CHAR(0)
- Begin DoDot:2
- +15 SET DX=$LENGTH(DDH(A0,A4),$CHAR(0))-1
- +16 XECUTE DDXY
- +17 SET DDH(A0,A4)=$TRANSLATE(DDH(A0,A4),$CHAR(0),"")
- End DoDot:2
- +18 WRITE DDH(A0,A4)
- End DoDot:1
- QUIT
- +19 ;
- +20 IF '$DATA(DDS)
- IF $GET(DDD)'["J"
- IF A4'=+A4
- QUIT
- +21 IF $DATA(DDS)
- IF $GET(DDD)=2!($GET(DDD)["J")
- WRITE A0,?7
- +22 ;
- +23 WRITE DDH(A0,A4)
- +24 IF $DATA(DDH("ID"))
- Begin DoDot:1
- +25 NEW DDD,DIY,DDSID
- +26 SET DDSID=DDH("ID")
- +27 IF $DATA(DDH("ID",1))#2
- SET DDSID(1)=DDH("ID",1)
- +28 NEW DDH
- +29 IF $DATA(DDSID(1))#2
- SET DDH("ID",1)=DDSID(1)
- KILL DDSID(1)
- +30 SET Y=A4
- +31 IF $DATA(DDS)
- SET DDQ=$SELECT(DY>(IOSL-1):IOSL-1,1:DY)_U_$X
- +32 XECUTE DDSID
- End DoDot:1
- IF $DATA(DUOUT)
- SET DIY=U
- +33 QUIT
- +34 ;
- Y IF '$DATA(DISYS)
- DO OS^DII
- +1 SET $X=0
- SET $Y=0
- +2 SET DIZ=$SELECT($DATA(DILN)&'$DATA(DIR0):DILN,1:21)
- +3 QUIT
- +4 ;
- Z DO Y
- DO T
- +1 QUIT
- +2 ;
- H IF '$DATA(A1)
- SET A1="T"
- +1 SET DDH=$GET(DDH)+1
- SET DDH(DDH,A1)=DST
- +2 KILL A1,DST
- +3 DO SC
- +4 QUIT
- +5 ;#8053 Press 'RETURN' to continue...
- +6 ;#8081 Choose |from-to| or '^'...
- +7 ;#7001 Yes^No
