- 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 Jan 18, 2025@03:43:57 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