DDS0 ;SFISC/MLH-SETUP, CLEANUP ;4:45 AM 7 Sep 2006
;;22.0;VA FileMan;**8,151**;Mar 30, 1999;Build 10
;Per VHA Directive 2004-038, this routine should not be modified.
;
EN(DDSFILE,DR,DA) ;Initial setup
S U="^"
D INIT^DDGLIB0() Q:$G(DIERR)
D FORM(.DDSFILE,DR) Q:$G(DIERR)
;
;Compile the form if not already compiled
S DDSREFS=$$REF(DDS)
I '$$COMPILED(DDS) D EN^DDSZ(DDS) Q:$G(DIERR)
N:$P(^DIST(.403,+DDS,0),U,10) DA
;
D FRSTPG(DDS,.DA,$G(DDSPAGE)) Q:$G(DIERR)
D REC(DDP,.DA) Q:$G(DIERR)
D INIT
Q
;
FORM(DDSFILE,DR) ;Form lookup
;Output:
; DDS = Form number^Form name
; DDP = File number (or 0)
; DDSPG = First page to go to on form
; DIERR
;
I $D(DDSFILE)[0 D BLD^DIALOG(201,"DDSFILE") Q
;
N DIC,X,Y
;
S DDP=$S(DDSFILE=+DDSFILE:DDSFILE,1:+$P($G(@(DDSFILE_"0)")),U,2))
S X=$S(DR:DR,1:$P($P(DR,"[",2),"]"))
S DIC="^DIST(.403,",DIC(0)="FNX",D="F"_DDP
D IX^DIC K DIC
;
I Y<0 D BLD^DIALOG(3021,X) Q
I '$O(^DIST(.403,+Y,40,"B","")) D BLD^DIALOG(3022,X) Q
S DDS=Y
;
I $D(DDSFILE(1))#2 S DDP=$S(DDSFILE(1)=+DDSFILE(1):DDSFILE(1),1:+$P($G(@(DDSFILE(1)_"0)")),U,2))
Q
;
FRSTPG(DDS,DA,DDSPAGE) ;Get first page of form
;Output:
; DDSPG
; DDSSEL = 1, if DA is null and there is a record selection page
; DIERR
;
N P
I $G(DA)!$P(^DIST(.403,+DDS,0),U,10) D
. S P=$S($G(DDSPAGE):DDSPAGE,1:1)
. S DDSPG=$O(^DIST(.403,+DDS,40,"B",P,""))
. I $D(^DIST(.403,+DDS,40,+DDSPG,0))[0 D BLD^DIALOG(3023,"number "_P)
E D PG^DDSRSEL D:'$G(DDSSEL) BLD^DIALOG(202,"record")
Q
;
REC(DDP,DA) ;Check record and lock
;Output:
; DIE = Global root
; DDSDA = DA,DA(1),...,
; DDSDAORG = Original DA array
; DDSDL = Level number (top=0)
; DDSDLORG = Original level number
; DDSFLORG = Orig DDP^Orig DIE
; D0,D1,etc.
; DIERR
;
I '$G(DA) D Q
. S DIE="",(DDSDL,DDSDLORG)=0,DDSDA="0,"
. S DA="",DDSDAORG=DA
;
D GL^DDS10(DDP,.DA,.DIE,.DDSDL,.DDSDA,1) Q:$G(DIERR)
;
I $D(DIOVRD)[0 D Q:$G(DIERR)
. N DDSTOP S DDSTOP=$$FNO^DILIBF(DDP)
. Q:$P($G(^DD(DDSTOP,0,"DI")),U,2)'["Y"
. N P S P("FILE")=$P(@(DIE_"0)"),U)
. D BLD^DIALOG(405,DDSTOP,.P)
;
S DDSDLORG=DDSDL
K DDSDAORG S (DDSDAORG,@("D"_DDSDL))=DA
F DDSI=1:1:DDSDL S (DDSDAORG(DDSI),@("D"_(DDSDL-DDSI)))=DA(DDSI)
S DDSFLORG=$G(DDP)_$G(DIE)
K DDSI
Q
;
INIT ;Initialize some variables
; DDSHBX = $Y of first line of help area
; DDSREFT = Global reference of temporary global location
; DDSFDO = 1 if entire form is display-only
; DDSCHG = Change flag
; DDSKM = Flag to keep whatever's in help area
; DDSH = Flag to indicate help area is empty
; DDSSC = Array to indicate what pages are on the screen
;
S DDSHBX=IOSL-7
S DDXY=IOXY_" S $X=DX,$Y=DY"
;
K DDH,DDSSC,DDSCHANG,DDSSAVE
S DDSH=1,(DDH,DDM,DDSCHG,DDSSC)=0,DDACT="N"
S DDSREFT="^TMP(""DDS"",$J,"_+DDS_")"
K @DDSREFT
;
N %,%H,%I,X
D NOW^%DTC
S $P(^DIST(.403,+DDS,0),U,6)=$E(%,1,12)
Q
;
END I $D(DDSHBX) S DX=0,DY=IOSL-1 X IOXY
D KILL^DDGLIB0($G(DDSPARM))
;
D:$D(^TMP("DDS",$J,"LOCK")) UNLOCK
;
K:'$G(DA) DA
I $D(DA),$D(DDSDAORG)#2,$D(DDSDLORG)#2 D
. K DA,D0
. S DA=DDSDAORG
. F DDSI=1:1:DDSDLORG S DA(DDSI)=DDSDAORG(DDSI) K @("D"_DDSI)
;
K:$G(DDSPARM)'["E" DIERR,^TMP("DIERR",$J)
K:$D(DDSREFT)#2 @DDSREFT,DDSREFT
K ^TMP("DDSH",$J),^TMP("DDSWP",$J)
K DDACT,DDH,DDM,DDO,DDP,DDQ,DDS,DDSDDP
K DDSBK,DDSBR,DDSCHG,DDSDA,DDSDAORG,DDSDL
K DDSDLORG,DDSDN,DDSEXT,DDSFDO,DDSFLD,DDSFLORG,DDSGL,DDSH,DDSI
K DDSKM,DDSLN,DDSNP,DDSO,DDSOLD,DDSORD,DDSOPB,DDSOSV,DDSPTB,DDSPG
K DDSPX,DDSPY,DDSQ,DDSREP,DDSSC,DDSSP,DDSSTACK,DDSTP,DDSU,DDSX
K DDSHBX,DDSREFS,DDXY,DDSCTRL ;DI*151
K DIC,DIR,DIR0N,DIROUT,DIRUT,DUOUT,DY,DX
K A1,D,DDC,DDD,DI,DIEQ,DIK,DIW,DIY,DIZ,DS
Q
;
UNLOCK ;Unlock any lock records
N I
S I="" F S I=$O(^TMP("DDS",$J,"LOCK",I)) Q:I="" L -@I
K ^TMP("DDS",$J,"LOCK")
Q
;
COMPILED(DDS) ;Return 1 if form is compiled
Q $D(@$$REF(DDS))>0
;
REF(DDS) ;Return global reference for compiled global
Q $NA(^DIST(.403,+DDS,"AY"))
;
OLDREF(DDS) ;Return global reference for compiled global used prior
;to version 22.0
Q $NA(^DIST(.403,+DDS,"AZ"))
;
IXF ;
N D0,DA,DIC,DP,Y S DIC="^DD("_DDGFDD_",",DIC(0)="EN" D ^DIC
I Y'>0 K X
E S X=+$P(Y,"E")
Q
DDS0 ;SFISC/MLH-SETUP, CLEANUP ;4:45 AM 7 Sep 2006
+1 ;;22.0;VA FileMan;**8,151**;Mar 30, 1999;Build 10
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EN(DDSFILE,DR,DA) ;Initial setup
+1 SET U="^"
+2 DO INIT^DDGLIB0()
IF $GET(DIERR)
QUIT
+3 DO FORM(.DDSFILE,DR)
IF $GET(DIERR)
QUIT
+4 ;
+5 ;Compile the form if not already compiled
+6 SET DDSREFS=$$REF(DDS)
+7 IF '$$COMPILED(DDS)
DO EN^DDSZ(DDS)
IF $GET(DIERR)
QUIT
+8 IF $PIECE(^DIST(.403,+DDS,0),U,10)
NEW DA
+9 ;
+10 DO FRSTPG(DDS,.DA,$GET(DDSPAGE))
IF $GET(DIERR)
QUIT
+11 DO REC(DDP,.DA)
IF $GET(DIERR)
QUIT
+12 DO INIT
+13 QUIT
+14 ;
FORM(DDSFILE,DR) ;Form lookup
+1 ;Output:
+2 ; DDS = Form number^Form name
+3 ; DDP = File number (or 0)
+4 ; DDSPG = First page to go to on form
+5 ; DIERR
+6 ;
+7 IF $DATA(DDSFILE)[0
DO BLD^DIALOG(201,"DDSFILE")
QUIT
+8 ;
+9 NEW DIC,X,Y
+10 ;
+11 SET DDP=$SELECT(DDSFILE=+DDSFILE:DDSFILE,1:+$PIECE($GET(@(DDSFILE_"0)")),U,2))
+12 SET X=$SELECT(DR:DR,1:$PIECE($PIECE(DR,"[",2),"]"))
+13 SET DIC="^DIST(.403,"
SET DIC(0)="FNX"
SET D="F"_DDP
+14 DO IX^DIC
KILL DIC
+15 ;
+16 IF Y<0
DO BLD^DIALOG(3021,X)
QUIT
+17 IF '$ORDER(^DIST(.403,+Y,40,"B",""))
DO BLD^DIALOG(3022,X)
QUIT
+18 SET DDS=Y
+19 ;
+20 IF $DATA(DDSFILE(1))#2
SET DDP=$SELECT(DDSFILE(1)=+DDSFILE(1):DDSFILE(1),1:+$PIECE($GET(@(DDSFILE(1)_"0)")),U,2))
+21 QUIT
+22 ;
FRSTPG(DDS,DA,DDSPAGE) ;Get first page of form
+1 ;Output:
+2 ; DDSPG
+3 ; DDSSEL = 1, if DA is null and there is a record selection page
+4 ; DIERR
+5 ;
+6 NEW P
+7 IF $GET(DA)!$PIECE(^DIST(.403,+DDS,0),U,10)
Begin DoDot:1
+8 SET P=$SELECT($GET(DDSPAGE):DDSPAGE,1:1)
+9 SET DDSPG=$ORDER(^DIST(.403,+DDS,40,"B",P,""))
+10 IF $DATA(^DIST(.403,+DDS,40,+DDSPG,0))[0
DO BLD^DIALOG(3023,"number "_P)
End DoDot:1
+11 IF '$TEST
DO PG^DDSRSEL
IF '$GET(DDSSEL)
DO BLD^DIALOG(202,"record")
+12 QUIT
+13 ;
REC(DDP,DA) ;Check record and lock
+1 ;Output:
+2 ; DIE = Global root
+3 ; DDSDA = DA,DA(1),...,
+4 ; DDSDAORG = Original DA array
+5 ; DDSDL = Level number (top=0)
+6 ; DDSDLORG = Original level number
+7 ; DDSFLORG = Orig DDP^Orig DIE
+8 ; D0,D1,etc.
+9 ; DIERR
+10 ;
+11 IF '$GET(DA)
Begin DoDot:1
+12 SET DIE=""
SET (DDSDL,DDSDLORG)=0
SET DDSDA="0,"
+13 SET DA=""
SET DDSDAORG=DA
End DoDot:1
QUIT
+14 ;
+15 DO GL^DDS10(DDP,.DA,.DIE,.DDSDL,.DDSDA,1)
IF $GET(DIERR)
QUIT
+16 ;
+17 IF $DATA(DIOVRD)[0
Begin DoDot:1
+18 NEW DDSTOP
SET DDSTOP=$$FNO^DILIBF(DDP)
+19 IF $PIECE($GET(^DD(DDSTOP,0,"DI")),U,2)'["Y"
QUIT
+20 NEW P
SET P("FILE")=$PIECE(@(DIE_"0)"),U)
+21 DO BLD^DIALOG(405,DDSTOP,.P)
End DoDot:1
IF $GET(DIERR)
QUIT
+22 ;
+23 SET DDSDLORG=DDSDL
+24 KILL DDSDAORG
SET (DDSDAORG,@("D"_DDSDL))=DA
+25 FOR DDSI=1:1:DDSDL
SET (DDSDAORG(DDSI),@("D"_(DDSDL-DDSI)))=DA(DDSI)
+26 SET DDSFLORG=$GET(DDP)_$GET(DIE)
+27 KILL DDSI
+28 QUIT
+29 ;
INIT ;Initialize some variables
+1 ; DDSHBX = $Y of first line of help area
+2 ; DDSREFT = Global reference of temporary global location
+3 ; DDSFDO = 1 if entire form is display-only
+4 ; DDSCHG = Change flag
+5 ; DDSKM = Flag to keep whatever's in help area
+6 ; DDSH = Flag to indicate help area is empty
+7 ; DDSSC = Array to indicate what pages are on the screen
+8 ;
+9 SET DDSHBX=IOSL-7
+10 SET DDXY=IOXY_" S $X=DX,$Y=DY"
+11 ;
+12 KILL DDH,DDSSC,DDSCHANG,DDSSAVE
+13 SET DDSH=1
SET (DDH,DDM,DDSCHG,DDSSC)=0
SET DDACT="N"
+14 SET DDSREFT="^TMP(""DDS"",$J,"_+DDS_")"
+15 KILL @DDSREFT
+16 ;
+17 NEW %,%H,%I,X
+18 DO NOW^%DTC
+19 SET $PIECE(^DIST(.403,+DDS,0),U,6)=$EXTRACT(%,1,12)
+20 QUIT
+21 ;
END IF $DATA(DDSHBX)
SET DX=0
SET DY=IOSL-1
XECUTE IOXY
+1 DO KILL^DDGLIB0($GET(DDSPARM))
+2 ;
+3 IF $DATA(^TMP("DDS",$JOB,"LOCK"))
DO UNLOCK
+4 ;
+5 IF '$GET(DA)
KILL DA
+6 IF $DATA(DA)
IF $DATA(DDSDAORG)#2
IF $DATA(DDSDLORG)#2
Begin DoDot:1
+7 KILL DA,D0
+8 SET DA=DDSDAORG
+9 FOR DDSI=1:1:DDSDLORG
SET DA(DDSI)=DDSDAORG(DDSI)
KILL @("D"_DDSI)
End DoDot:1
+10 ;
+11 IF $GET(DDSPARM)'["E"
KILL DIERR,^TMP("DIERR",$JOB)
+12 IF $DATA(DDSREFT)#2
KILL @DDSREFT,DDSREFT
+13 KILL ^TMP("DDSH",$JOB),^TMP("DDSWP",$JOB)
+14 KILL DDACT,DDH,DDM,DDO,DDP,DDQ,DDS,DDSDDP
+15 KILL DDSBK,DDSBR,DDSCHG,DDSDA,DDSDAORG,DDSDL
+16 KILL DDSDLORG,DDSDN,DDSEXT,DDSFDO,DDSFLD,DDSFLORG,DDSGL,DDSH,DDSI
+17 KILL DDSKM,DDSLN,DDSNP,DDSO,DDSOLD,DDSORD,DDSOPB,DDSOSV,DDSPTB,DDSPG
+18 KILL DDSPX,DDSPY,DDSQ,DDSREP,DDSSC,DDSSP,DDSSTACK,DDSTP,DDSU,DDSX
+19 ;DI*151
KILL DDSHBX,DDSREFS,DDXY,DDSCTRL
+20 KILL DIC,DIR,DIR0N,DIROUT,DIRUT,DUOUT,DY,DX
+21 KILL A1,D,DDC,DDD,DI,DIEQ,DIK,DIW,DIY,DIZ,DS
+22 QUIT
+23 ;
UNLOCK ;Unlock any lock records
+1 NEW I
+2 SET I=""
FOR
SET I=$ORDER(^TMP("DDS",$JOB,"LOCK",I))
IF I=""
QUIT
LOCK -@I
+3 KILL ^TMP("DDS",$JOB,"LOCK")
+4 QUIT
+5 ;
COMPILED(DDS) ;Return 1 if form is compiled
+1 QUIT $DATA(@$$REF(DDS))>0
+2 ;
REF(DDS) ;Return global reference for compiled global
+1 QUIT $NAME(^DIST(.403,+DDS,"AY"))
+2 ;
OLDREF(DDS) ;Return global reference for compiled global used prior
+1 ;to version 22.0
+2 QUIT $NAME(^DIST(.403,+DDS,"AZ"))
+3 ;
IXF ;
+1 NEW D0,DA,DIC,DP,Y
SET DIC="^DD("_DDGFDD_","
SET DIC(0)="EN"
DO ^DIC
+2 IF Y'>0
KILL X
+3 IF '$TEST
SET X=+$PIECE(Y,"E")
+4 QUIT
