DDS ;SFISC/MLH,MKO-MAIN ROUTINE ;21SEP2006
;;22.0;VA FileMan;**151**;Mar 30, 1999;Build 10
;Per VHA Directive 2004-038, this routine should not be modified.
N DIE,DX,DY,X,Y
K DDSCTRL ;DI*151
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
;
D EN^DDS0(.DDSFILE,DR,.DA)
I $G(DIERR) D:$G(DDSPARM)'["E" G END^DDS0
. W !,$C(7)_$$EZBLD^DIALOG(3000)
. D MSG^DIALOG("BW")
. S DIMSG=""
;
N DR
X:$G(^DIST(.403,+DDS,11))'?."^" ^(11)
F D PG Q:DDACT="Q"
X:$G(^DIST(.403,+DDS,12))'?."^" ^(12)
;
D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG()
G END^DDS0
;
PROC ;Main loop
F D PG Q:DDACT="Q"
Q
;
PG ;Load page
S DDACT="N"
D ^DDS1(DDSPG)
I $G(DIERR) D Q
. N P S P(1)=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U),P(2)=$P($G(^(1)),U)
. S:P(2)="" P(2)="unnamed"
. D BLD^DIALOG(3041,.P),ERR^DDSMSG H 2
. S DDACT="Q"
;
;Pre-action, save old and get next page
S DDSOPB=DDSPG
I $G(^DIST(.403,+DDS,40,DDSPG,11))'?."^" D PA(^(11)) Q:DDACT="NP"
S DDSNP=$$NP^DDS5(.Y) S:'Y DDSNP=""
;
;Get DDO and DDSBK
I $S($D(DDSBR)[0:1,1:$D(@DDSREFS@(DDSPG,$S(DDO:+DDSBK,1:0),DDO,"N"))[0) D
. S DDO=+$G(@DDSREFS@(DDSPG,"FIRST")),DDSBK=$P($G(^("FIRST")),",",2)
I 'DDSBK D Q
. D BLD^DIALOG(3055,"number "_$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U)_$S($G(^(1))]"":" ("_$P($G(^(1)),U)_")",1:""))
. D ERR^DDSMSG H 2
. S DDACT="Q"
;
;Get DDSPOP and update DDSSC array
;If we're going to another page
I '$D(DDSPGUP) D
. S DDSLN=^DIST(.403,+DDS,40,DDSPG,0),DDSPOP=$P(DDSLN,U,6)
. K:'DDSPOP DDSSC
. I $D(DDSSEL) D
.. S DDSDASV=DDSDA,DDSDLSV=DDSDL
.. M DDSORGSV=DDSDAORG
.. K DA,@$$D0(DDSDL),DDSDAORG
.. S (DA,D0,DDSDAORG)="",DDSDA="0,",DDSDL=0
. I '$D(DDSSC("B",DDSPG)) D
.. S DDSSC=$G(DDSSC)+1,DDSSC(DDSSC)=DDSPG,DDSSC("B",DDSPG,DDSSC)=""
.. S:DDSPOP $P(DDSSC(DDSSC),U,2,3)=$P(DDSLN,U,3)_U_$P(DDSLN,U,7)
.. I $G(DDSSTK) S $P(DDSSC(DDSSC),U,4)=1 K DDSSTK
.. K DDSPOP
. E D
.. Q:$P($G(DDSSC(+$G(DDSSC))),U)=DDSPG
.. N I,J,S
.. S I=$O(DDSSC("B",DDSPG,"")),S=DDSSC(I) K DDSSC("B",DDSPG,I)
.. F J=I:1:DDSSC-1 D
... K DDSSC("B",$P(DDSSC(J+1),U),J)
... S DDSSC(J)=DDSSC(J+1),DDSSC("B",$P(DDSSC(J),U),J)=""
.. S DDSSC(DDSSC)=S,DDSSC("B",DDSPG,DDSSC)=""
;
;If we've moving up from a pop-up page
E K DDSPGUP
;
;Paint the page
D RP^DDSR(DDSSC(DDSSC),DDSSC=1)
;
P1 F D BLK Q:"^Q^NP^"[(U_DDACT_U)
;
;PAGE Post action, print any help
D:$G(^DIST(.403,+DDS,40,+DDSOPB,12))'?."^" PA(^(12))
D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG()
G:"^NB^N^"[(U_DDACT_U) P1
;
I DDACT="Q" D
. I '$P(DDSSC(DDSSC),U,4) D
.. I $G(DDSSEL) D GDA^DDSRSEL Q:'DA
.. D:$G(DDSSC)>1 CLEAR^DDSBOX($P(DDSSC(DDSSC),U,2),$P(DDSSC(DDSSC),U,3))
.. S:DDSSC>1 DDSPG=$P(DDSSC(DDSSC-1),U),DDACT="N",DDSPGUP=1
. K DDSSC("B",$P(DDSSC(DDSSC),U),DDSSC),DDSSC(DDSSC) S DDSSC=DDSSC-1
Q
;
BLK S DDACT="N",DDSOSV=0
;
I $D(@DDSREFS@(DDSPG,DDSBK))[0 S DDACT="Q" Q
S DDSLN=@DDSREFS@(DDSPG,DDSBK)
;
S DDSDN=$P(DDSLN,U,4),DDSTP=$P(DDSLN,U,5)
S DDSREP=$P(DDSLN,U,7),DDSPTB=$P(DDSLN,U,8)
K:'DDSDN DDSDN K:DDSTP="e" DDSTP K:'DDSPTB DDSPTB K:DDSREP'>1 DDSREP
;
I $D(DDSPTB)!$D(DDSREP) N DDP,DDSDA,DIE D
. S DDP=$P(DDSLN,U,3)
. S DDSDA=$P(@DDSREFT@(DDSPG,DDSBK),U) Q:'DDSDA
. S DIE=@DDSREFT@(DDSPG,DDSBK,DDSDA,"GL")
;
I $D(DDSPTB) N DA,@$$D0(DDSDL),DDSDL D
. S DDSPTB=@DDSREFS@(DDSPG,DDSBK,"PTB")
. S DDSDL=$L(DDSDA,",")-2
. S (D0,DA)=+DDSDA
;
I $D(DDSREP) N DDSDL,DA D
. S DDSREP=$P(@DDSREFT@(DDSPG,DDSBK,DDSDA),U,2,999)
. S DDSDA=$G(@DDSREFT@(DDSPG,DDSBK,$P(DDSREP,U),$P(DDSREP,U,4)),"0,"_DDSDA)
. S:'$P(DDSREP,U,7) DDSDA=$P(DDSDA,",")_","
. S DDSDL=$L(DDSDA,",")-2
I N @$$D0(DDSDL) D
. D BLDDA(DDSDA)
. S:'DA DDO=+$P(DDSREP,U,8)
;
I $D(DDSPTB),'$D(DDSREP),'DDSDA,DDSDAORG D Q
. N DDSBK0
. S DDSBK0=DDSBK
. F S DDSBK=$$NB^DDS5(.Y) Q:DDSBK=DDSBK0!'Y!$G(@DDSREFT@(DDSPG,DDSBK))
. Q:Y
. I DDSNP]"" S DDSPG=DDSNP,DDACT="NP" Q
. S DDSPG=$$PP^DDS5(.Y) I Y S DDACT="NP" Q
. S DDACT="Q"
;
S $P(DDSOPB,U,2)=DDSBK
I $G(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,11))'?."^" D PA(^(11)) Q:DDACT="NP"
I $G(^DIST(.404,DDSBK,11))'?."^" D PA(^(11)) Q:DDACT="NP"
I $S($D(DDSBR)[0:1,1:$D(@DDSREFS@(DDSPG,$S(DDO:+DDSBK,1:0),DDO,"N"))[0) D
. S DDO=$P(@DDSREFS@(DDSPG,DDSBK),U,9)
K DDSLN
;
B1 D ^DDS01
;
I $G(^DIST(.403,+DDS,40,DDSPG,40,$P(DDSOPB,U,2),12))'?."^" D PA(^(12)) G:DDACT="N" B1
I $G(^DIST(.404,$P(DDSOPB,U,2),12))'?."^" D PA(^(12)) G:DDACT="N" B1
Q
;
BLDDA(DDSDA) ;
N I
S (DA,@("D"_DDSDL))=$P(DDSDA,",")
F I=1:1:DDSDL S (DA(I),@("D"_(DDSDL-I)))=$P(DDSDA,",",I+1)
Q
;
D0(DL) ;Given DL, return string D0,D1,...,Dn
N I,S
S S="" F I=0:1:DL S S=S_"D"_I_","
S:S?.E1"," S=$E(S,1,$L(S)-1)
Q S
;
CLRMSG ;
I $G(DDSKM) H 2 K DDSKM ;GFT ** IF WE WERE KEEPING SOMETHING IN HELP AREA, HOLD UP 2 SECONDS ISB-0603-31054
K DDQ S DDSH=1,(DDM,DX)=0,DY=DDSHBX+1 X DDXY W $P(DDGLCLR,DDGLDEL,3)
Q
;
PA(DDSPA) ;
N DDSBRORG S:$D(DDSBR)#2 DDSBRORG=DDSBR
K DDSBR X DDSPA
I $D(DDSBR)[0 S:$D(DDSBRORG)#2 DDSBR=DDSBRORG Q
D BR^DDS2
Q
RESET ;Programmer entry point to reset terminal and cleanup
D INIT^DDGLIB0() D:$G(DIERR) MSG^DIALOG("BW")
W $P($G(DDGLVID),DDGLDEL,10)
K DDSPARM
S DDSREFT="^TMP(""DDS"",$J)"
D END^DDS0
G RESET^DDGF
;
RUN ;Run a form
G ^DDSRUN
CLONE ;Clone a form
G ^DDSCLONE
PRINT ;Print a form
G ^DDSPRNT
DFRM ;Delete a form
G ^DDSDFRM
DBLK ;Delete unused blocks
G ^DDSDBLK
DDS ;SFISC/MLH,MKO-MAIN ROUTINE ;21SEP2006
+1 ;;22.0;VA FileMan;**151**;Mar 30, 1999;Build 10
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 NEW DIE,DX,DY,X,Y
+4 ;DI*151
KILL DDSCTRL
+5 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+6 ;
+7 DO EN^DDS0(.DDSFILE,DR,.DA)
+8 IF $GET(DIERR)
IF $GET(DDSPARM)'["E"
Begin DoDot:1
+9 WRITE !,$CHAR(7)_$$EZBLD^DIALOG(3000)
+10 DO MSG^DIALOG("BW")
+11 SET DIMSG=""
End DoDot:1
GOTO END^DDS0
+12 ;
+13 NEW DR
+14 IF $GET(^DIST(.403,+DDS,11))'?."^"
XECUTE ^(11)
+15 FOR
DO PG
IF DDACT="Q"
QUIT
+16 IF $GET(^DIST(.403,+DDS,12))'?."^"
XECUTE ^(12)
+17 ;
+18 IF $GET(@DDSREFT@("HLP"))>0
DO HLP^DDSMSG()
+19 GOTO END^DDS0
+20 ;
PROC ;Main loop
+1 FOR
DO PG
IF DDACT="Q"
QUIT
+2 QUIT
+3 ;
PG ;Load page
+1 SET DDACT="N"
+2 DO ^DDS1(DDSPG)
+3 IF $GET(DIERR)
Begin DoDot:1
+4 NEW P
SET P(1)=$PIECE($GET(^DIST(.403,+DDS,40,DDSPG,0)),U)
SET P(2)=$PIECE($GET(^(1)),U)
+5 IF P(2)=""
SET P(2)="unnamed"
+6 DO BLD^DIALOG(3041,.P)
DO ERR^DDSMSG
HANG 2
+7 SET DDACT="Q"
End DoDot:1
QUIT
+8 ;
+9 ;Pre-action, save old and get next page
+10 SET DDSOPB=DDSPG
+11 IF $GET(^DIST(.403,+DDS,40,DDSPG,11))'?."^"
DO PA(^(11))
IF DDACT="NP"
QUIT
+12 SET DDSNP=$$NP^DDS5(.Y)
IF 'Y
SET DDSNP=""
+13 ;
+14 ;Get DDO and DDSBK
+15 IF $SELECT($DATA(DDSBR)[0:1,1:$DATA(@DDSREFS@(DDSPG,$SELECT(DDO:+DDSBK,1:0),DDO,"N"))[0)
Begin DoDot:1
+16 SET DDO=+$GET(@DDSREFS@(DDSPG,"FIRST"))
SET DDSBK=$PIECE($GET(^("FIRST")),",",2)
End DoDot:1
+17 IF 'DDSBK
Begin DoDot:1
+18 DO BLD^DIALOG(3055,"number "_$PIECE($GET(^DIST(.403,+DDS,40,DDSPG,0)),U)_$SELECT($GET(^(1))]"":" ("_$PIECE($GET(^(1)),U)_")",1:""))
+19 DO ERR^DDSMSG
HANG 2
+20 SET DDACT="Q"
End DoDot:1
QUIT
+21 ;
+22 ;Get DDSPOP and update DDSSC array
+23 ;If we're going to another page
+24 IF '$DATA(DDSPGUP)
Begin DoDot:1
+25 SET DDSLN=^DIST(.403,+DDS,40,DDSPG,0)
SET DDSPOP=$PIECE(DDSLN,U,6)
+26 IF 'DDSPOP
KILL DDSSC
+27 IF $DATA(DDSSEL)
Begin DoDot:2
+28 SET DDSDASV=DDSDA
SET DDSDLSV=DDSDL
+29 MERGE DDSORGSV=DDSDAORG
+30 KILL DA,@$$D0(DDSDL),DDSDAORG
+31 SET (DA,D0,DDSDAORG)=""
SET DDSDA="0,"
SET DDSDL=0
End DoDot:2
+32 IF '$DATA(DDSSC("B",DDSPG))
Begin DoDot:2
+33 SET DDSSC=$GET(DDSSC)+1
SET DDSSC(DDSSC)=DDSPG
SET DDSSC("B",DDSPG,DDSSC)=""
+34 IF DDSPOP
SET $PIECE(DDSSC(DDSSC),U,2,3)=$PIECE(DDSLN,U,3)_U_$PIECE(DDSLN,U,7)
+35 IF $GET(DDSSTK)
SET $PIECE(DDSSC(DDSSC),U,4)=1
KILL DDSSTK
+36 KILL DDSPOP
End DoDot:2
+37 IF '$TEST
Begin DoDot:2
+38 IF $PIECE($GET(DDSSC(+$GET(DDSSC))),U)=DDSPG
QUIT
+39 NEW I,J,S
+40 SET I=$ORDER(DDSSC("B",DDSPG,""))
SET S=DDSSC(I)
KILL DDSSC("B",DDSPG,I)
+41 FOR J=I:1:DDSSC-1
Begin DoDot:3
+42 KILL DDSSC("B",$PIECE(DDSSC(J+1),U),J)
+43 SET DDSSC(J)=DDSSC(J+1)
SET DDSSC("B",$PIECE(DDSSC(J),U),J)=""
End DoDot:3
+44 SET DDSSC(DDSSC)=S
SET DDSSC("B",DDSPG,DDSSC)=""
End DoDot:2
End DoDot:1
+45 ;
+46 ;If we've moving up from a pop-up page
+47 IF '$TEST
KILL DDSPGUP
+48 ;
+49 ;Paint the page
+50 DO RP^DDSR(DDSSC(DDSSC),DDSSC=1)
+51 ;
P1 FOR
DO BLK
IF "^Q^NP^"[(U_DDACT_U)
QUIT
+1 ;
+2 ;PAGE Post action, print any help
+3 IF $GET(^DIST(.403,+DDS,40,+DDSOPB,12))'?."^"
DO PA(^(12))
+4 IF $GET(@DDSREFT@("HLP"))>0
DO HLP^DDSMSG()
+5 IF "^NB^N^"[(U_DDACT_U)
GOTO P1
+6 ;
+7 IF DDACT="Q"
Begin DoDot:1
+8 IF '$PIECE(DDSSC(DDSSC),U,4)
Begin DoDot:2
+9 IF $GET(DDSSEL)
DO GDA^DDSRSEL
IF 'DA
QUIT
+10 IF $GET(DDSSC)>1
DO CLEAR^DDSBOX($PIECE(DDSSC(DDSSC),U,2),$PIECE(DDSSC(DDSSC),U,3))
+11 IF DDSSC>1
SET DDSPG=$PIECE(DDSSC(DDSSC-1),U)
SET DDACT="N"
SET DDSPGUP=1
End DoDot:2
+12 KILL DDSSC("B",$PIECE(DDSSC(DDSSC),U),DDSSC),DDSSC(DDSSC)
SET DDSSC=DDSSC-1
End DoDot:1
+13 QUIT
+14 ;
BLK SET DDACT="N"
SET DDSOSV=0
+1 ;
+2 IF $DATA(@DDSREFS@(DDSPG,DDSBK))[0
SET DDACT="Q"
QUIT
+3 SET DDSLN=@DDSREFS@(DDSPG,DDSBK)
+4 ;
+5 SET DDSDN=$PIECE(DDSLN,U,4)
SET DDSTP=$PIECE(DDSLN,U,5)
+6 SET DDSREP=$PIECE(DDSLN,U,7)
SET DDSPTB=$PIECE(DDSLN,U,8)
+7 IF 'DDSDN
KILL DDSDN
IF DDSTP="e"
KILL DDSTP
IF 'DDSPTB
KILL DDSPTB
IF DDSREP'>1
KILL DDSREP
+8 ;
+9 IF $DATA(DDSPTB)!$DATA(DDSREP)
NEW DDP,DDSDA,DIE
Begin DoDot:1
+10 SET DDP=$PIECE(DDSLN,U,3)
+11 SET DDSDA=$PIECE(@DDSREFT@(DDSPG,DDSBK),U)
IF 'DDSDA
QUIT
+12 SET DIE=@DDSREFT@(DDSPG,DDSBK,DDSDA,"GL")
End DoDot:1
+13 ;
+14 IF $DATA(DDSPTB)
NEW DA,@$$D0(DDSDL),DDSDL
Begin DoDot:1
+15 SET DDSPTB=@DDSREFS@(DDSPG,DDSBK,"PTB")
+16 SET DDSDL=$LENGTH(DDSDA,",")-2
+17 SET (D0,DA)=+DDSDA
End DoDot:1
+18 ;
+19 IF $DATA(DDSREP)
NEW DDSDL,DA
Begin DoDot:1
+20 SET DDSREP=$PIECE(@DDSREFT@(DDSPG,DDSBK,DDSDA),U,2,999)
+21 SET DDSDA=$GET(@DDSREFT@(DDSPG,DDSBK,$PIECE(DDSREP,U),$PIECE(DDSREP,U,4)),"0,"_DDSDA)
+22 IF '$PIECE(DDSREP,U,7)
SET DDSDA=$PIECE(DDSDA,",")_","
+23 SET DDSDL=$LENGTH(DDSDA,",")-2
End DoDot:1
+24 IF $TEST
NEW @$$D0(DDSDL)
Begin DoDot:1
+25 DO BLDDA(DDSDA)
+26 IF 'DA
SET DDO=+$PIECE(DDSREP,U,8)
End DoDot:1
+27 ;
+28 IF $DATA(DDSPTB)
IF '$DATA(DDSREP)
IF 'DDSDA
IF DDSDAORG
Begin DoDot:1
+29 NEW DDSBK0
+30 SET DDSBK0=DDSBK
+31 FOR
SET DDSBK=$$NB^DDS5(.Y)
IF DDSBK=DDSBK0!'Y!$GET(@DDSREFT@(DDSPG,DDSBK))
QUIT
+32 IF Y
QUIT
+33 IF DDSNP]""
SET DDSPG=DDSNP
SET DDACT="NP"
QUIT
+34 SET DDSPG=$$PP^DDS5(.Y)
IF Y
SET DDACT="NP"
QUIT
+35 SET DDACT="Q"
End DoDot:1
QUIT
+36 ;
+37 SET $PIECE(DDSOPB,U,2)=DDSBK
+38 IF $GET(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,11))'?."^"
DO PA(^(11))
IF DDACT="NP"
QUIT
+39 IF $GET(^DIST(.404,DDSBK,11))'?."^"
DO PA(^(11))
IF DDACT="NP"
QUIT
+40 IF $SELECT($DATA(DDSBR)[0:1,1:$DATA(@DDSREFS@(DDSPG,$SELECT(DDO:+DDSBK,1:0),DDO,"N"))[0)
Begin DoDot:1
+41 SET DDO=$PIECE(@DDSREFS@(DDSPG,DDSBK),U,9)
End DoDot:1
+42 KILL DDSLN
+43 ;
B1 DO ^DDS01
+1 ;
+2 IF $GET(^DIST(.403,+DDS,40,DDSPG,40,$PIECE(DDSOPB,U,2),12))'?."^"
DO PA(^(12))
IF DDACT="N"
GOTO B1
+3 IF $GET(^DIST(.404,$PIECE(DDSOPB,U,2),12))'?."^"
DO PA(^(12))
IF DDACT="N"
GOTO B1
+4 QUIT
+5 ;
BLDDA(DDSDA) ;
+1 NEW I
+2 SET (DA,@("D"_DDSDL))=$PIECE(DDSDA,",")
+3 FOR I=1:1:DDSDL
SET (DA(I),@("D"_(DDSDL-I)))=$PIECE(DDSDA,",",I+1)
+4 QUIT
+5 ;
D0(DL) ;Given DL, return string D0,D1,...,Dn
+1 NEW I,S
+2 SET S=""
FOR I=0:1:DL
SET S=S_"D"_I_","
+3 IF S?.E1","
SET S=$EXTRACT(S,1,$LENGTH(S)-1)
+4 QUIT S
+5 ;
CLRMSG ;
+1 ;GFT ** IF WE WERE KEEPING SOMETHING IN HELP AREA, HOLD UP 2 SECONDS ISB-0603-31054
IF $GET(DDSKM)
HANG 2
KILL DDSKM
+2 KILL DDQ
SET DDSH=1
SET (DDM,DX)=0
SET DY=DDSHBX+1
XECUTE DDXY
WRITE $PIECE(DDGLCLR,DDGLDEL,3)
+3 QUIT
+4 ;
PA(DDSPA) ;
+1 NEW DDSBRORG
IF $DATA(DDSBR)#2
SET DDSBRORG=DDSBR
+2 KILL DDSBR
XECUTE DDSPA
+3 IF $DATA(DDSBR)[0
IF $DATA(DDSBRORG)#2
SET DDSBR=DDSBRORG
QUIT
+4 DO BR^DDS2
+5 QUIT
RESET ;Programmer entry point to reset terminal and cleanup
+1 DO INIT^DDGLIB0()
IF $GET(DIERR)
DO MSG^DIALOG("BW")
+2 WRITE $PIECE($GET(DDGLVID),DDGLDEL,10)
+3 KILL DDSPARM
+4 SET DDSREFT="^TMP(""DDS"",$J)"
+5 DO END^DDS0
+6 GOTO RESET^DDGF
+7 ;
RUN ;Run a form
+1 GOTO ^DDSRUN
CLONE ;Clone a form
+1 GOTO ^DDSCLONE
PRINT ;Print a form
+1 GOTO ^DDSPRNT
DFRM ;Delete a form
+1 GOTO ^DDSDFRM
DBLK ;Delete unused blocks
+1 GOTO ^DDSDBLK
