- 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 Feb 19, 2025@00:09:17 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