- DDS7 ;SFISC/MKO-Relational ;1:39 PM 28 Jun 1996
- ;;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.
- ;
- RPB(DDP,DDSFLD,DDSPG) ;Repaint pointed-to block(s) recursively
- N DDS7B
- S DDS7B=""
- F S DDS7B=$O(@DDSREFS@("PT",DDP,DDSFLD,DDSPG,DDS7B)) Q:DDS7B="" D
- . N DDP,DDSFLD
- . I $P($G(@DDSREFS@(DDSPG,DDS7B)),U,8) D
- .. D BLK^DDS1(DDSPG,DDS7B,"","",1)
- .. D DB^DDSR(DDSPG,DDS7B)
- . S DDP=$P($G(@DDSREFS@(DDSPG,DDS7B)),U,3)
- . D:$D(@DDSREFS@("PT",DDP))
- .. S DDSFLD=""
- .. F S DDSFLD=$O(@DDSREFS@("PT",DDP,DDSFLD)) Q:DDSFLD="" D
- ... D:$D(@DDSREFS@("PT",DDP,DDSFLD,DDSPG)) RPB(DDP,DDSFLD,DDSPG)
- Q
- ;
- RPF(DDP,DDSPTB,DDSDA,DA) ;Repaint and update pointer field of
- ;pointer blocks because user changed the .01 value
- S DDS7V=$G(@DDSREFT@("F"_DDP,DDSDA,.01,"D")) I DDS7V]"",$D(^("X"))#2 S DDS7V=^("X")
- S DDS7DAS=U_DA_U
- F DDS7I=$L(DDSPTB,U):-1:1 D Q:$G(DDS7FD)'=.01
- . S DDS7PTB=$P(DDSPTB,U,DDS7I)
- . D:DDS7PTB]"" RPF1
- K DDS7B,DDS7D,DDS7DA,DDS7DAS,DDS7DAST,DDS7DDO,DDS7FD,DDS7FI
- K DDS7I,DDS7L,DDS7PTB,DDS7REF,DDS7RJ,DDS7V,DDS7X
- Q
- RPF1 ;
- I DDS7PTB[";J" S DDS7FD="" Q
- S DDS7PTB=$P(DDS7PTB,";")
- I $L(DDS7PTB,",")=2 S DDS7FI=+DDS7PTB,DDS7FD=$P(DDS7PTB,",",2)
- E I $L(DDS7PTB,",")=3 S DDS7FI=0,DDS7FD=$P(DDS7PTB,",",2,3)
- E Q
- Q:DDS7FI=""!(DDS7FD="")
- ;
- ;Repaint pointer field on current page
- S DDS7B=""
- F S DDS7B=$O(@DDSREFS@("F"_DDS7FI,DDS7FD,"L",DDSPG,DDS7B)) Q:DDS7B="" D
- . S DDS7DDO=""
- . F S DDS7DDO=$O(@DDSREFS@("F"_DDS7FI,DDS7FD,"L",DDSPG,DDS7B,DDS7DDO)) Q:DDS7DDO="" D
- .. Q:$G(@DDSREFS@(DDSPG,DDS7B,DDS7DDO,"D"))="" S DY=+^("D"),DX=$P(^("D"),U,2),DDS7L=$P(^("D"),U,3),DDS7RJ=$P(^("D"),U,10)
- .. X IOXY
- .. S DDS7X=$P(DDGLVID,DDGLDEL)_$E(DDS7V,1,DDS7L)_$P(DDGLVID,DDGLDEL,10)
- .. W $S(DDS7RJ:$J(" ",DDS7L-$L(DDS7V))_DDS7X,1:DDS7X_$J(" ",DDS7L-$L(DDS7V)))
- ;
- ;Reset external form of pointer data.
- ;
- ;If the pointer field is the .01, then we may have to follow back
- ;to pointers that point to this pointer block.
- ;
- ;DDS7DAS initially contains a list of records whose .01s we changed.
- ;DDS7DAST keeps a running list of all records in the pointer block
- ;that we change.
- ;DDS7DAS is finally set to this running list, so that when we go
- ;to update the pointer to the pointer block, we know which pointers
- ;to update.
- ;
- S DDS7DAST="",DDS7DA=" "
- F S DDS7DA=$O(@DDSREFT@("F"_DDS7FI,DDS7DA)) Q:DDS7DA'["," D
- . S DDS7REF=$NA(@DDSREFT@("F"_DDS7FI,DDS7DA,DDS7FD))
- . S DDS7D=$G(@DDS7REF@("D"))
- . I DDS7DAS[(U_$P(DDS7D,";")_U),$S(DDS7D[";":U_$P(DDS7D,";",2)=DIE,1:1) D
- .. I DDS7V="",DDS7FD'=.01 S @DDS7REF@("D")="",^("F")=3
- .. S:$D(@DDS7REF@("X"))#2 ^("X")=$S(DDS7V=""&(DDS7FD=.01):@DDS7REF@("D"),1:DDS7V)
- .. I DDS7FD=.01,DDS7DAST_U'[(U_+DDS7DA_U) S DDS7DAST=DDS7DAST_U_+DDS7DA
- S DDS7DAS=DDS7DAST_U
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDS7 3053 printed Feb 19, 2025@00:09:25 Page 2
- DDS7 ;SFISC/MKO-Relational ;1:39 PM 28 Jun 1996
- +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 ;
- RPB(DDP,DDSFLD,DDSPG) ;Repaint pointed-to block(s) recursively
- +1 NEW DDS7B
- +2 SET DDS7B=""
- +3 FOR
- SET DDS7B=$ORDER(@DDSREFS@("PT",DDP,DDSFLD,DDSPG,DDS7B))
- if DDS7B=""
- QUIT
- Begin DoDot:1
- +4 NEW DDP,DDSFLD
- +5 IF $PIECE($GET(@DDSREFS@(DDSPG,DDS7B)),U,8)
- Begin DoDot:2
- +6 DO BLK^DDS1(DDSPG,DDS7B,"","",1)
- +7 DO DB^DDSR(DDSPG,DDS7B)
- End DoDot:2
- +8 SET DDP=$PIECE($GET(@DDSREFS@(DDSPG,DDS7B)),U,3)
- +9 if $DATA(@DDSREFS@("PT",DDP))
- Begin DoDot:2
- +10 SET DDSFLD=""
- +11 FOR
- SET DDSFLD=$ORDER(@DDSREFS@("PT",DDP,DDSFLD))
- if DDSFLD=""
- QUIT
- Begin DoDot:3
- +12 if $DATA(@DDSREFS@("PT",DDP,DDSFLD,DDSPG))
- DO RPB(DDP,DDSFLD,DDSPG)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 QUIT
- +14 ;
- RPF(DDP,DDSPTB,DDSDA,DA) ;Repaint and update pointer field of
- +1 ;pointer blocks because user changed the .01 value
- +2 SET DDS7V=$GET(@DDSREFT@("F"_DDP,DDSDA,.01,"D"))
- IF DDS7V]""
- IF $DATA(^("X"))#2
- SET DDS7V=^("X")
- +3 SET DDS7DAS=U_DA_U
- +4 FOR DDS7I=$LENGTH(DDSPTB,U):-1:1
- Begin DoDot:1
- +5 SET DDS7PTB=$PIECE(DDSPTB,U,DDS7I)
- +6 if DDS7PTB]""
- DO RPF1
- End DoDot:1
- if $GET(DDS7FD)'=.01
- QUIT
- +7 KILL DDS7B,DDS7D,DDS7DA,DDS7DAS,DDS7DAST,DDS7DDO,DDS7FD,DDS7FI
- +8 KILL DDS7I,DDS7L,DDS7PTB,DDS7REF,DDS7RJ,DDS7V,DDS7X
- +9 QUIT
- RPF1 ;
- +1 IF DDS7PTB[";J"
- SET DDS7FD=""
- QUIT
- +2 SET DDS7PTB=$PIECE(DDS7PTB,";")
- +3 IF $LENGTH(DDS7PTB,",")=2
- SET DDS7FI=+DDS7PTB
- SET DDS7FD=$PIECE(DDS7PTB,",",2)
- +4 IF '$TEST
- IF $LENGTH(DDS7PTB,",")=3
- SET DDS7FI=0
- SET DDS7FD=$PIECE(DDS7PTB,",",2,3)
- +5 IF '$TEST
- QUIT
- +6 if DDS7FI=""!(DDS7FD="")
- QUIT
- +7 ;
- +8 ;Repaint pointer field on current page
- +9 SET DDS7B=""
- +10 FOR
- SET DDS7B=$ORDER(@DDSREFS@("F"_DDS7FI,DDS7FD,"L",DDSPG,DDS7B))
- if DDS7B=""
- QUIT
- Begin DoDot:1
- +11 SET DDS7DDO=""
- +12 FOR
- SET DDS7DDO=$ORDER(@DDSREFS@("F"_DDS7FI,DDS7FD,"L",DDSPG,DDS7B,DDS7DDO))
- if DDS7DDO=""
- QUIT
- Begin DoDot:2
- +13 if $GET(@DDSREFS@(DDSPG,DDS7B,DDS7DDO,"D"))=""
- QUIT
- SET DY=+^("D")
- SET DX=$PIECE(^("D"),U,2)
- SET DDS7L=$PIECE(^("D"),U,3)
- SET DDS7RJ=$PIECE(^("D"),U,10)
- +14 XECUTE IOXY
- +15 SET DDS7X=$PIECE(DDGLVID,DDGLDEL)_$EXTRACT(DDS7V,1,DDS7L)_$PIECE(DDGLVID,DDGLDEL,10)
- +16 WRITE $SELECT(DDS7RJ:$JUSTIFY(" ",DDS7L-$LENGTH(DDS7V))_DDS7X,1:DDS7X_$JUSTIFY(" ",DDS7L-$LENGTH(DDS7V)))
- End DoDot:2
- End DoDot:1
- +17 ;
- +18 ;Reset external form of pointer data.
- +19 ;
- +20 ;If the pointer field is the .01, then we may have to follow back
- +21 ;to pointers that point to this pointer block.
- +22 ;
- +23 ;DDS7DAS initially contains a list of records whose .01s we changed.
- +24 ;DDS7DAST keeps a running list of all records in the pointer block
- +25 ;that we change.
- +26 ;DDS7DAS is finally set to this running list, so that when we go
- +27 ;to update the pointer to the pointer block, we know which pointers
- +28 ;to update.
- +29 ;
- +30 SET DDS7DAST=""
- SET DDS7DA=" "
- +31 FOR
- SET DDS7DA=$ORDER(@DDSREFT@("F"_DDS7FI,DDS7DA))
- if DDS7DA'[","
- QUIT
- Begin DoDot:1
- +32 SET DDS7REF=$NAME(@DDSREFT@("F"_DDS7FI,DDS7DA,DDS7FD))
- +33 SET DDS7D=$GET(@DDS7REF@("D"))
- +34 IF DDS7DAS[(U_$PIECE(DDS7D,";")_U)
- IF $SELECT(DDS7D[";":U_$PIECE(DDS7D,";",2)=DIE,1:1)
- Begin DoDot:2
- +35 IF DDS7V=""
- IF DDS7FD'=.01
- SET @DDS7REF@("D")=""
- SET ^("F")=3
- +36 if $DATA(@DDS7REF@("X"))#2
- SET ^("X")=$SELECT(DDS7V=""&(DDS7FD=.01):@DDS7REF@("D"),1:DDS7V)
- +37 IF DDS7FD=.01
- IF DDS7DAST_U'[(U_+DDS7DA_U)
- SET DDS7DAST=DDS7DAST_U_+DDS7DA
- End DoDot:2
- End DoDot:1
- +38 SET DDS7DAS=DDS7DAST_U
- +39 QUIT