- DDS ;SFISC/MLH,MKO - MAIN ROUTINE ;18MAR2017
- ;;22.2;VA FileMan;**3,5**;Jan 05, 2016;Build 28
- ;;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.
- ;GFT;**1003,1004,1028,1043,1045,1055,1057**
- ;
- N DIE,DX,DY,X,Y,DDSATOP
- 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 -- do all the PAGES
- F D PG Q:DDACT="Q"
- Q
- ;
- PG ;Load page
- N DDSMX,DDSMY,DDSMOUSE,FND
- S DDACT="N"
- D EN^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
- SEL . I $D(DDSSEL) D
- .. N P S P=$P($G(^DIST(.403,+DDS,21)),U) Q:P="" Q:$O(^(40,"B",P,""))'=DDSPG ;CONVERT PAGE TO ITS INTERNAL NUMBER
- .. S DDSDASV=DDSDA,DDSDLSV=DDSDL
- .. M DDSORGSV=DDSDAORG
- .. K DA,@$$D0(DDSDL),DDSDAORG ;IF IT'S (REALLY) A RECORD SELECTION PAGE FORGET DA
- .. 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)="" ;Stack 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 ;Process what came from the RECORD SELECTION PAGE now that we've returned from it
- .. 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 ;Unstack DDSSC
- 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 ;NEW WHEN WE GO INTO MULTIPLE!!
- . S DDP=$P(DDSLN,U,3)
- DIE . S DDSDA=$P(@DDSREFT@(DDSPG,DDSBK),U) I DDSDA'>0,$G(^(DDSBK,"COMP MUL"))="" S DIE=$G(DIE) Q ;Get Entry Number
- . 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) ;2-arg $G -- go to empty line if none other specified
- . 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) ;If this is a new subEntry, start at 1st editable field
- ;
- PTB 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"
- 1 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) ;First field
- 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 ;FROM DDSU
- 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) ;CLEAR WHOLE COMMAND AREA
- N I F S I=$O(DDSMOUSE(DDSHBX)) Q:I+1=IOSL!'I K DDSMOUSE(I)
- Q
- ;
- PA(DDSPA) ;
- N DDSBRORG S:$D(DDSBR)#2 DDSBRORG=DDSBR
- K DDSBR X DDSPA ;PRE-ACTION OR POST-ACTION
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDS 6404 printed Jan 18, 2025@03:43:56 Page 2
- DDS ;SFISC/MLH,MKO - MAIN ROUTINE ;18MAR2017
- +1 ;;22.2;VA FileMan;**3,5**;Jan 05, 2016;Build 28
- +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 ;GFT;**1003,1004,1028,1043,1045,1055,1057**
- +7 ;
- +8 NEW DIE,DX,DY,X,Y,DDSATOP
- +9 IF '$DATA(DIFM)
- NEW DIFM
- SET DIFM=1
- DO INIZE^DIEFU
- +10 ;
- +11 DO EN^DDS0(.DDSFILE,DR,.DA)
- +12 IF $GET(DIERR)
- if $GET(DDSPARM)'["E"
- Begin DoDot:1
- +13 WRITE !,$CHAR(7)_$$EZBLD^DIALOG(3000)
- +14 DO MSG^DIALOG("BW")
- +15 SET DIMSG=""
- End DoDot:1
- GOTO END^DDS0
- +16 ;
- +17 NEW DR
- +18 if $GET(^DIST(.403,+DDS,11))'?."^"
- XECUTE ^(11)
- +19 FOR
- DO PG
- if DDACT="Q"
- QUIT
- +20 if $GET(^DIST(.403,+DDS,12))'?."^"
- XECUTE ^(12)
- +21 ;
- +22 if $GET(@DDSREFT@("HLP"))>0
- DO HLP^DDSMSG()
- +23 GOTO END^DDS0
- +24 ;
- PROC ;Main loop -- do all the PAGES
- +1 FOR
- DO PG
- if DDACT="Q"
- QUIT
- +2 QUIT
- +3 ;
- PG ;Load page
- +1 NEW DDSMX,DDSMY,DDSMOUSE,FND
- +2 SET DDACT="N"
- +3 DO EN^DDS1(DDSPG)
- +4 IF $GET(DIERR)
- Begin DoDot:1
- +5 NEW P
- SET P(1)=$PIECE($GET(^DIST(.403,+DDS,40,DDSPG,0)),U)
- SET P(2)=$PIECE($GET(^(1)),U)
- +6 if P(2)=""
- SET P(2)="unnamed"
- +7 DO BLD^DIALOG(3041,.P)
- DO ERR^DDSMSG
- HANG 2
- +8 SET DDACT="Q"
- End DoDot:1
- QUIT
- +9 ;
- +10 ;Pre-action, save old and get next page
- +11 SET DDSOPB=DDSPG
- +12 IF $GET(^DIST(.403,+DDS,40,DDSPG,11))'?."^"
- DO PA(^(11))
- if DDACT="NP"
- QUIT
- +13 SET DDSNP=$$NP^DDS5(.Y)
- if 'Y
- SET DDSNP=""
- +14 ;
- +15 ;Get DDO and DDSBK
- +16 IF $SELECT($DATA(DDSBR)[0:1,1:$DATA(@DDSREFS@(DDSPG,$SELECT(DDO:+DDSBK,1:0),DDO,"N"))[0)
- Begin DoDot:1
- +17 SET DDO=+$GET(@DDSREFS@(DDSPG,"FIRST"))
- SET DDSBK=$PIECE($GET(^("FIRST")),",",2)
- End DoDot:1
- +18 IF 'DDSBK
- Begin DoDot:1
- +19 DO BLD^DIALOG(3055,"number "_$PIECE($GET(^DIST(.403,+DDS,40,DDSPG,0)),U)_$SELECT($GET(^(1))]"":" ("_$PIECE($GET(^(1)),U)_")",1:""))
- +20 DO ERR^DDSMSG
- HANG 2
- +21 SET DDACT="Q"
- End DoDot:1
- QUIT
- +22 ;
- +23 ;Get DDSPOP and update DDSSC array
- +24 ;If we're going to another page
- +25 IF '$DATA(DDSPGUP)
- Begin DoDot:1
- +26 SET DDSLN=^DIST(.403,+DDS,40,DDSPG,0)
- SET DDSPOP=$PIECE(DDSLN,U,6)
- +27 if 'DDSPOP
- KILL DDSSC
- SEL IF $DATA(DDSSEL)
- Begin DoDot:2
- +1 ;CONVERT PAGE TO ITS INTERNAL NUMBER
- NEW P
- SET P=$PIECE($GET(^DIST(.403,+DDS,21)),U)
- if P=""
- QUIT
- if $ORDER(^(40,"B",P,""))'=DDSPG
- QUIT
- +2 SET DDSDASV=DDSDA
- SET DDSDLSV=DDSDL
- +3 MERGE DDSORGSV=DDSDAORG
- +4 ;IF IT'S (REALLY) A RECORD SELECTION PAGE FORGET DA
- KILL DA,@$$D0(DDSDL),DDSDAORG
- +5 SET (DA,D0,DDSDAORG)=""
- SET DDSDA="0,"
- SET DDSDL=0
- End DoDot:2
- +6 IF '$DATA(DDSSC("B",DDSPG))
- Begin DoDot:2
- +7 ;Stack DDSSC
- SET DDSSC=$GET(DDSSC)+1
- SET DDSSC(DDSSC)=DDSPG
- SET DDSSC("B",DDSPG,DDSSC)=""
- +8 if DDSPOP
- SET $PIECE(DDSSC(DDSSC),U,2,3)=$PIECE(DDSLN,U,3)_U_$PIECE(DDSLN,U,7)
- +9 IF $GET(DDSSTK)
- SET $PIECE(DDSSC(DDSSC),U,4)=1
- KILL DDSSTK
- +10 KILL DDSPOP
- End DoDot:2
- +11 IF '$TEST
- Begin DoDot:2
- +12 if $PIECE($GET(DDSSC(+$GET(DDSSC))),U)=DDSPG
- QUIT
- +13 NEW I,J,S
- +14 SET I=$ORDER(DDSSC("B",DDSPG,""))
- SET S=DDSSC(I)
- KILL DDSSC("B",DDSPG,I)
- +15 FOR J=I:1:DDSSC-1
- Begin DoDot:3
- +16 KILL DDSSC("B",$PIECE(DDSSC(J+1),U),J)
- +17 SET DDSSC(J)=DDSSC(J+1)
- SET DDSSC("B",$PIECE(DDSSC(J),U),J)=""
- End DoDot:3
- +18 SET DDSSC(DDSSC)=S
- SET DDSSC("B",DDSPG,DDSSC)=""
- End DoDot:2
- End DoDot:1
- +19 ;
- +20 ;If we've moving up from a pop-up page
- +21 IF '$TEST
- KILL DDSPGUP
- +22 ;
- +23 ;Paint the page
- +24 DO RP^DDSR(DDSSC(DDSSC),DDSSC=1)
- +25 ;
- 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 ;Process what came from the RECORD SELECTION PAGE now that we've returned from it
- 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 ;Unstack DDSSC
- 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 ;NEW WHEN WE GO INTO MULTIPLE!!
- IF $DATA(DDSPTB)!$DATA(DDSREP)
- NEW DDP,DDSDA,DIE
- Begin DoDot:1
- +10 SET DDP=$PIECE(DDSLN,U,3)
- DIE ;Get Entry Number
- SET DDSDA=$PIECE(@DDSREFT@(DDSPG,DDSBK),U)
- IF DDSDA'>0
- IF $GET(^(DDSBK,"COMP MUL"))=""
- SET DIE=$GET(DIE)
- QUIT
- +1 SET DIE=@DDSREFT@(DDSPG,DDSBK,DDSDA,"GL")
- End DoDot:1
- +2 ;
- +3 IF $DATA(DDSPTB)
- NEW DA,@$$D0(DDSDL),DDSDL
- Begin DoDot:1
- +4 SET DDSPTB=@DDSREFS@(DDSPG,DDSBK,"PTB")
- +5 SET DDSDL=$LENGTH(DDSDA,",")-2
- +6 SET (D0,DA)=+DDSDA
- End DoDot:1
- +7 ;
- +8 IF $DATA(DDSREP)
- NEW DDSDL,DA
- Begin DoDot:1
- +9 SET DDSREP=$PIECE(@DDSREFT@(DDSPG,DDSBK,DDSDA),U,2,999)
- +10 ;2-arg $G -- go to empty line if none other specified
- SET DDSDA=$GET(@DDSREFT@(DDSPG,DDSBK,$PIECE(DDSREP,U),$PIECE(DDSREP,U,4)),"0,"_DDSDA)
- +11 if '$PIECE(DDSREP,U,7)
- SET DDSDA=$PIECE(DDSDA,",")_","
- +12 SET DDSDL=$LENGTH(DDSDA,",")-2
- End DoDot:1
- +13 IF $TEST
- NEW @$$D0(DDSDL)
- Begin DoDot:1
- +14 DO BLDDA(DDSDA)
- +15 ;If this is a new subEntry, start at 1st editable field
- if 'DA
- SET DDO=+$PIECE(DDSREP,U,8)
- End DoDot:1
- +16 ;
- PTB IF $DATA(DDSPTB)
- IF '$DATA(DDSREP)
- IF 'DDSDA
- IF DDSDAORG
- Begin DoDot:1
- +1 NEW DDSBK0
- +2 SET DDSBK0=DDSBK
- +3 FOR
- SET DDSBK=$$NB^DDS5(.Y)
- if DDSBK=DDSBK0!'Y!$GET(@DDSREFT@(DDSPG,DDSBK))
- QUIT
- +4 if Y
- QUIT
- +5 IF DDSNP]""
- SET DDSPG=DDSNP
- SET DDACT="NP"
- QUIT
- +6 SET DDSPG=$$PP^DDS5(.Y)
- IF Y
- SET DDACT="NP"
- QUIT
- +7 SET DDACT="Q"
- End DoDot:1
- QUIT
- +8 ;
- +9 SET $PIECE(DDSOPB,U,2)=DDSBK
- +10 IF $GET(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,11))'?."^"
- DO PA(^(11))
- if DDACT="NP"
- QUIT
- +11 IF $GET(^DIST(.404,DDSBK,11))'?."^"
- DO PA(^(11))
- if DDACT="NP"
- QUIT
- 1 IF $SELECT($DATA(DDSBR)[0:1,1:$DATA(@DDSREFS@(DDSPG,$SELECT(DDO:+DDSBK,1:0),DDO,"N"))[0)
- Begin DoDot:1
- +1 ;First field
- SET DDO=$PIECE(@DDSREFS@(DDSPG,DDSBK),U,9)
- End DoDot:1
- +2 KILL DDSLN
- +3 ;
- 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 ;FROM DDSU
- +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 ;CLEAR WHOLE COMMAND AREA
- KILL DDQ
- SET DDSH=1
- SET (DDM,DX)=0
- SET DY=DDSHBX+1
- XECUTE DDXY
- WRITE $PIECE(DDGLCLR,DDGLDEL,3)
- +3 NEW I
- FOR
- SET I=$ORDER(DDSMOUSE(DDSHBX))
- if I+1=IOSL!'I
- QUIT
- KILL DDSMOUSE(I)
- +4 QUIT
- +5 ;
- PA(DDSPA) ;
- +1 NEW DDSBRORG
- if $DATA(DDSBR)#2
- SET DDSBRORG=DDSBR
- +2 ;PRE-ACTION OR POST-ACTION
- KILL DDSBR
- XECUTE DDSPA
- +3 IF $DATA(DDSBR)[0
- if $DATA(DDSBRORG)#2
- SET DDSBR=DDSBRORG
- QUIT
- +4 DO BR^DDS2
- +5 QUIT
- +6 ;
- +7 ;
- +8 ;
- +9 ;
- +10 ;
- +11 ;
- 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