DDS10 ;SFISC/MKO-BLOCK SETUP ;21SEP2006
;;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.
;
SET(DDS1B,DDS1E,DA,DDP,DIE,DL,DDSDA) ;Get values for pointed-to block
;In:
; DDS1B = Block number or [Block name] (by ref)
; DDS1E = 1, if we're loading a pointed-to block and we want
; interactive dialog (DIC(0)["E") in the lookup
; DA = Record array
;Returns:
; DDS1B = Block number
; DDP = File number of block
; DIE = Global root based on DDP and DA
; DL = Level number (top=0)
; DDSDA = DA,DA(1),...,
;
D BK(.DDS1B,.DDP) Q:$G(DIERR)
D GDA(DDS1B,DDS1E,.DA) Q:$G(DIERR)
D GL(DDP,.DA,.DIE,.DL,.DDSDA,$P($G(^DIST(.403,+DDS,40,+$G(DDSPG),40,DDS1B,0)),U,4)'="d") Q:$G(DIERR) ;Don't LOCK record if block is display-only
Q
;
BK(DDSBK,DDP) ;Lookup block, get file number
;Input:
; DDSBK = Block number or [Block name] (by ref)
;Returns:
; DDSBK = Block number
; DDP = File number
; DIERR
;
I DDSBK=+$P(DDSBK,"E") D Q
. I $D(^DIST(.404,DDSBK,0))[0 D BLD^DIALOG(3051,"#"_DDSBK) Q
. S DDP=+$P(^DIST(.404,DDSBK,0),U,2)
I DDSBK?1"["1.E1"]" D Q
. N X,Y,DIC
. S X=$E(DDSBK,2,$L(DDSBK)-1),DIC="^DIST(.404,",DIC(0)="FZ"
. D ^DIC I Y<0 D BLD^DIALOG(3051,"named "_X) Q
. S DDSBK=+Y,DDP=+$P(Y(0),U,2)
D BLD^DIALOG(3051,"#"_DDSBK)
Q
;
GDA(DDS1B,DDS1E,DA) ;Find new DA
;Input:
; DDS1B = Block number
; DDS1E = 1:Interactive lookup
; DDSDAORG = Original DA array
; DDSDLORG = Original DL
; DDSPG
;Returns:
; DA = Record number
; DIERR
;
N DDSDA,DDSI,X
;
;Set DA array to its original value
S DA=DDSDAORG
F DDSI=1:1:DDSDLORG S DA(DDSI)=DDSDAORG(DDSI)
D DDSDA(.DA,DDSDLORG,.DDSDA)
;
;Xecute each PTB node
F DDSI=1:1 Q:DA=""!'$D(@DDSREFS@(DDSPG,DDS1B,"PTB",DDSI)) X ^(DDSI) S:$G(X)'>0 DA=""
;
;Kill descendants of DA
I '$G(DIERR) S DDSI=DA K DA S DA=DDSI
S:DA'>0!$G(DIERR) DA=""
Q
;
GL(F,DA,DIE,DL,DDSDA,DDSL) ;Get global root, level, and IEN
;Input variables:
; F = file #
; DA = array
; DDSL = flag to lock record
;Returns:
; DIE = global root of file (null if error)
; DL = level (top=0) (null if error)
; DDSDA = IEN
; DIERR = Error flag
;
I '$D(^DD(F)) D BLD^DIALOG(401,F) S (DIE,DL)="" Q
I $D(^DIC(F,0,"GL"))#2 S DIE=^("GL"),DL=0
E D SUBGL Q:$G(DIERR)
;
I '$G(DA) S DDSDA="0," Q
D DDSDA(.DA,DL,.DDSDA)
;
N DDSP S DDSP("FILE")=F,DDSP("IEN")=DDSDA
;
I $D(@(DIE_DA_",0)"))[0 D BLD^DIALOG(601,"",.DDSP)
I $D(@(DIE_DA_",-9)")) D BLD^DIALOG(602,"",.DDSP)
;
I $G(DDSL),$D(^TMP("DDS",$J,"LOCK",DIE_DA_")"))[0 D Q:$G(DIERR)
. D LOCK^DILF(DIE_DA_")") E D BLD^DIALOG(110,"",.DDSP) Q ;**147
. S ^TMP("DDS",$J,"LOCK",DIE_DA_")")=""
Q
;
SUBGL ;Get root and level for subfile
N D,I,S,U1
S D=F
F DL=0:1 Q:$D(^DD(D,0,"UP"))[0 S U1=^("UP") G:'$D(^DD(U1,"SB",D)) SUBER G:$D(^DD(U1,$O(^(D,"")),0))[0 SUBER S S(DL+1)=""""_$P($P(^(0),U,4),";")_"""",D=U1
G:$D(^DIC(D,0,"GL"))[0 SUBER S DIE=^("GL")
F I=DL:-1:1 G:$D(DA(I))[0 SUBER S DIE=DIE_DA(I)_","_S(I)_","
Q
;
SUBER ;Come here if an error is encountered in GL
S (DIE,DL)=""
D BLD^DIALOG(309)
Q
;
DDSDA(DA,DL,DDSDA) ;Determine DDSDA
;Input:
; DA = Record array
; DL = Level number (top=0)
;Output:
; DDSDA = DA,DA(1),...,
;
N I
I DA="" S DDSDA="" Q
S DDSDA=DA_"," F I=1:1:DL S DDSDA=DDSDA_DA(I)_","
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDS10 3686 printed Oct 16, 2024@18:43:36 Page 2
DDS10 ;SFISC/MKO-BLOCK SETUP ;21SEP2006
+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 ;
SET(DDS1B,DDS1E,DA,DDP,DIE,DL,DDSDA) ;Get values for pointed-to block
+1 ;In:
+2 ; DDS1B = Block number or [Block name] (by ref)
+3 ; DDS1E = 1, if we're loading a pointed-to block and we want
+4 ; interactive dialog (DIC(0)["E") in the lookup
+5 ; DA = Record array
+6 ;Returns:
+7 ; DDS1B = Block number
+8 ; DDP = File number of block
+9 ; DIE = Global root based on DDP and DA
+10 ; DL = Level number (top=0)
+11 ; DDSDA = DA,DA(1),...,
+12 ;
+13 DO BK(.DDS1B,.DDP)
if $GET(DIERR)
QUIT
+14 DO GDA(DDS1B,DDS1E,.DA)
if $GET(DIERR)
QUIT
+15 ;Don't LOCK record if block is display-only
DO GL(DDP,.DA,.DIE,.DL,.DDSDA,$PIECE($GET(^DIST(.403,+DDS,40,+$GET(DDSPG),40,DDS1B,0)),U,4)'="d")
if $GET(DIERR)
QUIT
+16 QUIT
+17 ;
BK(DDSBK,DDP) ;Lookup block, get file number
+1 ;Input:
+2 ; DDSBK = Block number or [Block name] (by ref)
+3 ;Returns:
+4 ; DDSBK = Block number
+5 ; DDP = File number
+6 ; DIERR
+7 ;
+8 IF DDSBK=+$PIECE(DDSBK,"E")
Begin DoDot:1
+9 IF $DATA(^DIST(.404,DDSBK,0))[0
DO BLD^DIALOG(3051,"#"_DDSBK)
QUIT
+10 SET DDP=+$PIECE(^DIST(.404,DDSBK,0),U,2)
End DoDot:1
QUIT
+11 IF DDSBK?1"["1.E1"]"
Begin DoDot:1
+12 NEW X,Y,DIC
+13 SET X=$EXTRACT(DDSBK,2,$LENGTH(DDSBK)-1)
SET DIC="^DIST(.404,"
SET DIC(0)="FZ"
+14 DO ^DIC
IF Y<0
DO BLD^DIALOG(3051,"named "_X)
QUIT
+15 SET DDSBK=+Y
SET DDP=+$PIECE(Y(0),U,2)
End DoDot:1
QUIT
+16 DO BLD^DIALOG(3051,"#"_DDSBK)
+17 QUIT
+18 ;
GDA(DDS1B,DDS1E,DA) ;Find new DA
+1 ;Input:
+2 ; DDS1B = Block number
+3 ; DDS1E = 1:Interactive lookup
+4 ; DDSDAORG = Original DA array
+5 ; DDSDLORG = Original DL
+6 ; DDSPG
+7 ;Returns:
+8 ; DA = Record number
+9 ; DIERR
+10 ;
+11 NEW DDSDA,DDSI,X
+12 ;
+13 ;Set DA array to its original value
+14 SET DA=DDSDAORG
+15 FOR DDSI=1:1:DDSDLORG
SET DA(DDSI)=DDSDAORG(DDSI)
+16 DO DDSDA(.DA,DDSDLORG,.DDSDA)
+17 ;
+18 ;Xecute each PTB node
+19 FOR DDSI=1:1
if DA=""!'$DATA(@DDSREFS@(DDSPG,DDS1B,"PTB",DDSI))
QUIT
XECUTE ^(DDSI)
if $GET(X)'>0
SET DA=""
+20 ;
+21 ;Kill descendants of DA
+22 IF '$GET(DIERR)
SET DDSI=DA
KILL DA
SET DA=DDSI
+23 if DA'>0!$GET(DIERR)
SET DA=""
+24 QUIT
+25 ;
GL(F,DA,DIE,DL,DDSDA,DDSL) ;Get global root, level, and IEN
+1 ;Input variables:
+2 ; F = file #
+3 ; DA = array
+4 ; DDSL = flag to lock record
+5 ;Returns:
+6 ; DIE = global root of file (null if error)
+7 ; DL = level (top=0) (null if error)
+8 ; DDSDA = IEN
+9 ; DIERR = Error flag
+10 ;
+11 IF '$DATA(^DD(F))
DO BLD^DIALOG(401,F)
SET (DIE,DL)=""
QUIT
+12 IF $DATA(^DIC(F,0,"GL"))#2
SET DIE=^("GL")
SET DL=0
+13 IF '$TEST
DO SUBGL
if $GET(DIERR)
QUIT
+14 ;
+15 IF '$GET(DA)
SET DDSDA="0,"
QUIT
+16 DO DDSDA(.DA,DL,.DDSDA)
+17 ;
+18 NEW DDSP
SET DDSP("FILE")=F
SET DDSP("IEN")=DDSDA
+19 ;
+20 IF $DATA(@(DIE_DA_",0)"))[0
DO BLD^DIALOG(601,"",.DDSP)
+21 IF $DATA(@(DIE_DA_",-9)"))
DO BLD^DIALOG(602,"",.DDSP)
+22 ;
+23 IF $GET(DDSL)
IF $DATA(^TMP("DDS",$JOB,"LOCK",DIE_DA_")"))[0
Begin DoDot:1
+24 ;**147
DO LOCK^DILF(DIE_DA_")")
IF '$TEST
DO BLD^DIALOG(110,"",.DDSP)
QUIT
+25 SET ^TMP("DDS",$JOB,"LOCK",DIE_DA_")")=""
End DoDot:1
if $GET(DIERR)
QUIT
+26 QUIT
+27 ;
SUBGL ;Get root and level for subfile
+1 NEW D,I,S,U1
+2 SET D=F
+3 FOR DL=0:1
if $DATA(^DD(D,0,"UP"))[0
QUIT
SET U1=^("UP")
if '$DATA(^DD(U1,"SB",D))
GOTO SUBER
if $DATA(^DD(U1,$ORDER(^(D,"")),0))[0
GOTO SUBER
SET S(DL+1)=""""_$PIECE($PIECE(^(0),U,4),";")_""""
SET D=U1
+4 if $DATA(^DIC(D,0,"GL"))[0
GOTO SUBER
SET DIE=^("GL")
+5 FOR I=DL:-1:1
if $DATA(DA(I))[0
GOTO SUBER
SET DIE=DIE_DA(I)_","_S(I)_","
+6 QUIT
+7 ;
SUBER ;Come here if an error is encountered in GL
+1 SET (DIE,DL)=""
+2 DO BLD^DIALOG(309)
+3 QUIT
+4 ;
DDSDA(DA,DL,DDSDA) ;Determine DDSDA
+1 ;Input:
+2 ; DA = Record array
+3 ; DL = Level number (top=0)
+4 ;Output:
+5 ; DDSDA = DA,DA(1),...,
+6 ;
+7 NEW I
+8 IF DA=""
SET DDSDA=""
QUIT
+9 SET DDSDA=DA_","
FOR I=1:1:DL
SET DDSDA=DDSDA_DA(I)_","
+10 QUIT
