DIFROMSE ;SFISC/DCL-FILE ORDER TO RESOLVE POINTERS ;07:27 AM 2 Jun 1994
;;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.
;
Q
;File Order List for Resolving Pointers
FOLRP(DIFRFLG,DIFRTA) ;FLAGS,TARGET_ARRAY ; Creates the "DIORD" subscript
; structure in the transport array.
;FLAGS,TARGET_ARRAY
;*
;FLAGS = None
;*
;TARGET_ARRAY = CLOSED ROOT
; This is the Transport Array Root.
; "DIORD" is appended to the array root.
; A ordered list of files is returned
; in the target array. Each file is given
; a value to determine which file should have
; pointers resolved. After each file has been
; assigned a value it is ordered by value then
; by file number. If files have the same value
; the file number is then used to determine the
; order. This call is used after all the file
; being transported are in the "FIA" structure.
;*
Q:$G(DIFRTA)']""
N DIFRCNT,DIFRDD,DIFRF,DIFRFILE,DIFRFLD,DIFRX
S DIFRFILE=0
K ^TMP("DIFROMSE",$J),^TMP("DIFRORD",$J),^TMP("DIFRFILE",$J),@DIFRTA@("DIORD")
F S DIFRFILE=$O(@DIFRTA@("FIA",DIFRFILE)) Q:DIFRFILE'>0 D
.D FSF^DIFROMSP(DIFRFILE,"","^TMP(""DIFROMSE"",$J)")
.Q
S DIFRFILE=0
F S DIFRFILE=$O(^TMP("DIFROMSE",$J,DIFRFILE)) Q:DIFRFILE'>0 D
.S DIFRDD=0,^TMP("DIFRORD",$J,DIFRFILE)=0
.F S DIFRDD=$O(^TMP("DIFROMSE",$J,DIFRFILE,DIFRDD)) Q:DIFRDD'>0 D
..S DIFRFLD=0
..F S DIFRFLD=$O(^DD(DIFRDD,DIFRFLD)) Q:DIFRFLD'>0 S DIFRX=$G(^(DIFRFLD,0)) D
...Q:$P(DIFRX,"^",2)
...Q:$P(DIFRX,"^",2)'["P"&($P(DIFRX,"^")'["V")
...S DIFRCNT=0
...I $P(DIFRX,"^",2)["V" D G P
....S DIFRF=0 F S DIFRF=$O(^DD(DIFRDD,DIFRFLD,"V","B",DIFRF)) Q:DIFRF'>0 S ^TMP("DIFRFILE",$J,DIFRF)=DIFRCNT+1
....Q
...I +$P(@("^"_$P(DIFRX,"^",3)_"0)"),"^",2)=DIFRFILE S:$G(^TMP("DIFRORD",$J,DIFRFILE))'>DIFRCNT ^(DIFRFILE)=DIFRCNT Q
...I $P(DIFRX,"^",2)["P" S ^TMP("DIFRFILE",$J,+$P(@("^"_$P(DIFRX,"^",3)_"0)"),"^",2))=DIFRCNT+1
P ...S DIFRF=$O(^TMP("DIFRFILE",$J,"")) Q:DIFRF="" S DIFRCNT=^(DIFRF) K ^(DIFRF)
...I $G(^TMP("DIFRORD",$J,DIFRF))'>DIFRCNT S ^(DIFRF)=DIFRCNT
...S DIFRX=^DD(DIFRF,.01,0)
...I $P(DIFRX,"^",2)["P" S ^TMP("DIFRFILE",$J,+$P(@("^"_$P(DIFRX,"^",3)_"0)"),"^",2))=DIFRCNT+1 G P
...G:$P(DIFRX,"^",2)'["V" P
...S DIFRF=0 F S DIFRF=$O(^DD(DIFRDD,DIFRFLD,"V","B",DIFRF)) Q:DIFRF'>0 S ^TMP("DIFRFILE",$J,DIFRF)=DIFRCNT
...S DIFRCNT=DIFRCNT+1
...G P
...Q
..Q
.Q
S DIFRFILE=0
F S DIFRFILE=$O(^TMP("DIFRORD",$J,DIFRFILE)) Q:DIFRFILE'>0 S DIFRX=^(DIFRFILE),^TMP("DIFRORD",$J,"DIORD",DIFRX,DIFRFILE)=""
S DIFRX="",DIFRCNT=1 F S DIFRX=$O(^TMP("DIFRORD",$J,"DIORD",DIFRX),-1) Q:DIFRX="" D
.S DIFRFILE=0 F S DIFRFILE=$O(^TMP("DIFRORD",$J,"DIORD",DIFRX,DIFRFILE)) Q:DIFRFILE'>0 D
..S @DIFRTA@("DIORD",DIFRCNT)=DIFRFILE,DIFRCNT=DIFRCNT+1
D KILL
Q
KILL ;
K ^TMP("DIFROMSE",$J),^TMP("DIFRORD",$J),^TMP("DIFRFILE",$J)
Q
;
CHK(DIFRFLG,DIFRSA,DIFRTA) ;CHECK FILES POINTED TO AGAINST FILES GOING OUT WITH DATA
;Compares the "DIORD" with the "FIA" structures
;FLAGS,SOURCE_ARRAY,TARGET_ARRAY
;*
;FLAGS = None
;*
;SOURCE_ARRAY = TRANSPORT ARRAY ROOT
;*
;TARGET_ARRAY = TARGET ARRAY ROOT
; Returns a list of files that are pointed to
; but not being exported. This is used after
; all the files being exported are in the "FIA"
; structure.
;*
Q:$G(DIFRSA)']""
Q:$G(DIFRTA)']""
N DIFRX,DIFRFILE
S DIFRX=0
F S DIFRX=$O(@DIFRSA@("DIORD",DIFRX)) Q:DIFRX'>0 S DIFRFILE=^(DIFRX) D
.Q:$D(@DIFRSA@("DATA",DIFRFILE))&($P($G(@DIFRSA@("FIA",DIFRFILE,0,1)),"^",5)="y")
.S @DIFRTA@(DIFRFILE)=""
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROMSE 4059 printed Apr 09, 2024@21:44:33 Page 2
DIFROMSE ;SFISC/DCL-FILE ORDER TO RESOLVE POINTERS ;07:27 AM 2 Jun 1994
+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 ;
+7 QUIT
+8 ;File Order List for Resolving Pointers
FOLRP(DIFRFLG,DIFRTA) ;FLAGS,TARGET_ARRAY ; Creates the "DIORD" subscript
+1 ; structure in the transport array.
+2 ;FLAGS,TARGET_ARRAY
+3 ;*
+4 ;FLAGS = None
+5 ;*
+6 ;TARGET_ARRAY = CLOSED ROOT
+7 ; This is the Transport Array Root.
+8 ; "DIORD" is appended to the array root.
+9 ; A ordered list of files is returned
+10 ; in the target array. Each file is given
+11 ; a value to determine which file should have
+12 ; pointers resolved. After each file has been
+13 ; assigned a value it is ordered by value then
+14 ; by file number. If files have the same value
+15 ; the file number is then used to determine the
+16 ; order. This call is used after all the file
+17 ; being transported are in the "FIA" structure.
+18 ;*
+19 if $GET(DIFRTA)']""
QUIT
+20 NEW DIFRCNT,DIFRDD,DIFRF,DIFRFILE,DIFRFLD,DIFRX
+21 SET DIFRFILE=0
+22 KILL ^TMP("DIFROMSE",$JOB),^TMP("DIFRORD",$JOB),^TMP("DIFRFILE",$JOB),@DIFRTA@("DIORD")
+23 FOR
SET DIFRFILE=$ORDER(@DIFRTA@("FIA",DIFRFILE))
if DIFRFILE'>0
QUIT
Begin DoDot:1
+24 DO FSF^DIFROMSP(DIFRFILE,"","^TMP(""DIFROMSE"",$J)")
+25 QUIT
End DoDot:1
+26 SET DIFRFILE=0
+27 FOR
SET DIFRFILE=$ORDER(^TMP("DIFROMSE",$JOB,DIFRFILE))
if DIFRFILE'>0
QUIT
Begin DoDot:1
+28 SET DIFRDD=0
SET ^TMP("DIFRORD",$JOB,DIFRFILE)=0
+29 FOR
SET DIFRDD=$ORDER(^TMP("DIFROMSE",$JOB,DIFRFILE,DIFRDD))
if DIFRDD'>0
QUIT
Begin DoDot:2
+30 SET DIFRFLD=0
+31 FOR
SET DIFRFLD=$ORDER(^DD(DIFRDD,DIFRFLD))
if DIFRFLD'>0
QUIT
SET DIFRX=$GET(^(DIFRFLD,0))
Begin DoDot:3
+32 if $PIECE(DIFRX,"^",2)
QUIT
+33 if $PIECE(DIFRX,"^",2)'["P"&($PIECE(DIFRX,"^")'["V")
QUIT
+34 SET DIFRCNT=0
+35 IF $PIECE(DIFRX,"^",2)["V"
Begin DoDot:4
+36 SET DIFRF=0
FOR
SET DIFRF=$ORDER(^DD(DIFRDD,DIFRFLD,"V","B",DIFRF))
if DIFRF'>0
QUIT
SET ^TMP("DIFRFILE",$JOB,DIFRF)=DIFRCNT+1
+37 QUIT
End DoDot:4
GOTO P
+38 IF +$PIECE(@("^"_$PIECE(DIFRX,"^",3)_"0)"),"^",2)=DIFRFILE
if $GET(^TMP("DIFRORD",$JOB,DIFRFILE))'>DIFRCNT
SET ^(DIFRFILE)=DIFRCNT
QUIT
+39 IF $PIECE(DIFRX,"^",2)["P"
SET ^TMP("DIFRFILE",$JOB,+$PIECE(@("^"_$PIECE(DIFRX,"^",3)_"0)"),"^",2))=DIFRCNT+1
P SET DIFRF=$ORDER(^TMP("DIFRFILE",$JOB,""))
if DIFRF=""
QUIT
SET DIFRCNT=^(DIFRF)
KILL ^(DIFRF)
+1 IF $GET(^TMP("DIFRORD",$JOB,DIFRF))'>DIFRCNT
SET ^(DIFRF)=DIFRCNT
+2 SET DIFRX=^DD(DIFRF,.01,0)
+3 IF $PIECE(DIFRX,"^",2)["P"
SET ^TMP("DIFRFILE",$JOB,+$PIECE(@("^"_$PIECE(DIFRX,"^",3)_"0)"),"^",2))=DIFRCNT+1
GOTO P
+4 if $PIECE(DIFRX,"^",2)'["V"
GOTO P
+5 SET DIFRF=0
FOR
SET DIFRF=$ORDER(^DD(DIFRDD,DIFRFLD,"V","B",DIFRF))
if DIFRF'>0
QUIT
SET ^TMP("DIFRFILE",$JOB,DIFRF)=DIFRCNT
+6 SET DIFRCNT=DIFRCNT+1
+7 GOTO P
+8 QUIT
End DoDot:3
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 SET DIFRFILE=0
+12 FOR
SET DIFRFILE=$ORDER(^TMP("DIFRORD",$JOB,DIFRFILE))
if DIFRFILE'>0
QUIT
SET DIFRX=^(DIFRFILE)
SET ^TMP("DIFRORD",$JOB,"DIORD",DIFRX,DIFRFILE)=""
+13 SET DIFRX=""
SET DIFRCNT=1
FOR
SET DIFRX=$ORDER(^TMP("DIFRORD",$JOB,"DIORD",DIFRX),-1)
if DIFRX=""
QUIT
Begin DoDot:1
+14 SET DIFRFILE=0
FOR
SET DIFRFILE=$ORDER(^TMP("DIFRORD",$JOB,"DIORD",DIFRX,DIFRFILE))
if DIFRFILE'>0
QUIT
Begin DoDot:2
+15 SET @DIFRTA@("DIORD",DIFRCNT)=DIFRFILE
SET DIFRCNT=DIFRCNT+1
End DoDot:2
End DoDot:1
+16 DO KILL
+17 QUIT
KILL ;
+1 KILL ^TMP("DIFROMSE",$JOB),^TMP("DIFRORD",$JOB),^TMP("DIFRFILE",$JOB)
+2 QUIT
+3 ;
CHK(DIFRFLG,DIFRSA,DIFRTA) ;CHECK FILES POINTED TO AGAINST FILES GOING OUT WITH DATA
+1 ;Compares the "DIORD" with the "FIA" structures
+2 ;FLAGS,SOURCE_ARRAY,TARGET_ARRAY
+3 ;*
+4 ;FLAGS = None
+5 ;*
+6 ;SOURCE_ARRAY = TRANSPORT ARRAY ROOT
+7 ;*
+8 ;TARGET_ARRAY = TARGET ARRAY ROOT
+9 ; Returns a list of files that are pointed to
+10 ; but not being exported. This is used after
+11 ; all the files being exported are in the "FIA"
+12 ; structure.
+13 ;*
+14 if $GET(DIFRSA)']""
QUIT
+15 if $GET(DIFRTA)']""
QUIT
+16 NEW DIFRX,DIFRFILE
+17 SET DIFRX=0
+18 FOR
SET DIFRX=$ORDER(@DIFRSA@("DIORD",DIFRX))
if DIFRX'>0
QUIT
SET DIFRFILE=^(DIFRX)
Begin DoDot:1
+19 if $DATA(@DIFRSA@("DATA",DIFRFILE))&($PIECE($GET(@DIFRSA@("FIA",DIFRFILE,0,1)),"^",5)="y")
QUIT
+20 SET @DIFRTA@(DIFRFILE)=""
+21 QUIT
End DoDot:1
+22 QUIT
