DDS0 ;SFISC/MLH-SETUP, CLEANUP ;24FEB2004
;;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.
;
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,'$P(^DIST(.403,+DDS,0),U,9)) Q:$G(DIERR) ;Don't LOCK record if screen is DISPLAY-ONLY
;
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"
EGP . N P S P("FILE")=$$FILENAME^DIALOGZ(DDSTOP) ;**CCO/NI RESTRICTED FILE NAME
. 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
;
DDSHBX S DDSHBX=17 I $G(DDS),$G(DDSPG),$D(DDSREFS) D
.N % S %=$O(@DDSREFS@("X",DDSPG,""),-1)+1 I %>DDSHBX S DDSHBX=% ;LAST FIELD CAPTION
.F DDH=0:0 S DDH=$O(@DDSREFS@(DDSPG,DDH)) Q:'DDH I $G(^(DDH)) S %=$P(^(DDH),U,7)+^(DDH) I %>DDSHBX S DDSHBX=%
S DDXY=IOXY_" S $X=DX,$Y=DY"
;
K DDH,DDSSC,DDSCHANG,DDSSAVE
S DDSH=1,(DDH,DDM,DDSCHG,DDSSC)=0,DDACT="N"
DDSREFT S DDSREFT=$NA(^TMP("DDS",$J,+DDS)) ;GFT
K @DDSREFT
MOUSEON I $G(DDS)>0 W *27,"[?1000h"
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)
MOUSEOFF W *27,"[?1000l"
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
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDS0 4911 printed Oct 16, 2024@18:43:32 Page 2
DDS0 ;SFISC/MLH-SETUP, CLEANUP ;24FEB2004
+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 ;
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 ;Don't LOCK record if screen is DISPLAY-ONLY
DO GL^DDS10(DDP,.DA,.DIE,.DDSDL,.DDSDA,'$PIECE(^DIST(.403,+DDS,0),U,9))
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
EGP ;**CCO/NI RESTRICTED FILE NAME
NEW P
SET P("FILE")=$$FILENAME^DIALOGZ(DDSTOP)
+1 DO BLD^DIALOG(405,DDSTOP,.P)
End DoDot:1
if $GET(DIERR)
QUIT
+2 ;
+3 SET DDSDLORG=DDSDL
+4 KILL DDSDAORG
SET (DDSDAORG,@("D"_DDSDL))=DA
+5 FOR DDSI=1:1:DDSDL
SET (DDSDAORG(DDSI),@("D"_(DDSDL-DDSI)))=DA(DDSI)
+6 SET DDSFLORG=$GET(DDP)_$GET(DIE)
+7 KILL DDSI
+8 QUIT
+9 ;
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 ;
DDSHBX SET DDSHBX=17
IF $GET(DDS)
IF $GET(DDSPG)
IF $DATA(DDSREFS)
Begin DoDot:1
+1 ;LAST FIELD CAPTION
NEW %
SET %=$ORDER(@DDSREFS@("X",DDSPG,""),-1)+1
IF %>DDSHBX
SET DDSHBX=%
+2 FOR DDH=0:0
SET DDH=$ORDER(@DDSREFS@(DDSPG,DDH))
if 'DDH
QUIT
IF $GET(^(DDH))
SET %=$PIECE(^(DDH),U,7)+^(DDH)
IF %>DDSHBX
SET DDSHBX=%
End DoDot:1
+3 SET DDXY=IOXY_" S $X=DX,$Y=DY"
+4 ;
+5 KILL DDH,DDSSC,DDSCHANG,DDSSAVE
+6 SET DDSH=1
SET (DDH,DDM,DDSCHG,DDSSC)=0
SET DDACT="N"
DDSREFT ;GFT
SET DDSREFT=$NAME(^TMP("DDS",$JOB,+DDS))
+1 KILL @DDSREFT
MOUSEON IF $GET(DDS)>0
WRITE *27,"[?1000h"
+1 NEW %,%H,%I,X
+2 DO NOW^%DTC
+3 SET $PIECE(^DIST(.403,+DDS,0),U,6)=$EXTRACT(%,1,12)
+4 QUIT
+5 ;
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
MOUSEOFF WRITE *27,"[?1000l"
+1 if $GET(DDSPARM)'["E"
KILL DIERR,^TMP("DIERR",$JOB)
+2 if $DATA(DDSREFT)#2
KILL @DDSREFT,DDSREFT
+3 KILL ^TMP("DDSH",$JOB),^TMP("DDSWP",$JOB)
+4 KILL DDACT,DDH,DDM,DDO,DDP,DDQ,DDS,DDSDDP
+5 KILL DDSBK,DDSBR,DDSCHG,DDSDA,DDSDAORG,DDSDL
+6 KILL DDSDLORG,DDSDN,DDSEXT,DDSFDO,DDSFLD,DDSFLORG,DDSGL,DDSH,DDSI
+7 KILL DDSKM,DDSLN,DDSNP,DDSO,DDSOLD,DDSORD,DDSOPB,DDSOSV,DDSPTB,DDSPG
+8 KILL DDSPX,DDSPY,DDSQ,DDSREP,DDSSC,DDSSP,DDSSTACK,DDSTP,DDSU,DDSX
+9 KILL DDSHBX,DDSREFS,DDXY
+10 KILL DIC,DIR,DIR0N,DIROUT,DIRUT,DUOUT,DY,DX
+11 KILL A1,D,DDC,DDD,DI,DIEQ,DIK,DIW,DIY,DIZ,DS
+12 QUIT
+13 ;
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
