DIFROMSP ;SFISC/DCL-DIFROM SERVER POINTER LIST ;5/18/98 08:29
;;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.
;
POINTERS(DIFRFILE,DIFRFLG,DIFRPTA) ;FILENUMBER, POINTER X-REF TARGET ARRAY ROOT
;FILE, FLAGS, TARGET ARRAY
S DIFRFLG=$G(DIFRFLG)
N DIFRDDNS,DIFRALL
S DIFRALL=DIFRFLG["A"
D FP(DIFRFILE,"","DIFRDDNS") ;ALL DD#s FOR FILE IN DIFRDDNS array
S DIFRDDNS=0
F S DIFRDDNS=$O(DIFRDDNS(DIFRFILE,DIFRDDNS)) Q:DIFRDDNS'>0 D
.D P(DIFRDDNS,DIFRFLG,$NA(@DIFRPTA@("P",DIFRFILE))) ;set "P" x-refs in target array
.Q
Q
;
FP(DIFRFILE,DIFRFLG,DIFRTA) ;FILENUMBER, TARGET ARRAY ROOT FOR SUB DD NRS
;FILE, FLAGS, TARGET ARRAY
N DIFRFD,DIFRFE,DIFRFW,DIFRNM,DIFRX
S DIFRFW=$G(DIFRFLG)'["W"
F S @DIFRTA@(DIFRFILE,DIFRFILE)=$O(^DD(DIFRFILE,0,"NM",""))_" "_$S($D(^DIC(DIFRFILE,0)):"(File-top level)",1:"(sub-file)"),DIFRFE=0
E F S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0 D
.S DIFRFD=0
.F S DIFRFD=$O(^DD(DIFRFE,"SB",DIFRFD)) Q:DIFRFD'>0 D
..I DIFRFW,$P(^DD(DIFRFD,.01,0),"^",2)["W" Q
..I DIFRFILE-DIFRFE!'$D(DIFRFA) S @DIFRTA@(DIFRFILE,DIFRFD)=$O(^DD(DIFRFD,0,"NM",""))_" (sub-file)"
..Q
.Q
Q
;
P(DIFRPDD,DIFRFLG,DIFRPTA) ;DIFRPDD=DD#,DIFRPTA=TARGET ARRAY BY VALUE TO SET "P" X-REF
;FILE/SUB-DD#,FLAGS,TARGET_ARRAY
N X,Y,PN,PIDF,PFILE,DIFRALL
S DIFRFLG=$G(DIFRFLG),DIFRALL=DIFRFLG["A"
I $G(U)'="^" N U S U="^"
S X=$S(DIFRALL:0,1:.01)
F S X=$O(^DD(DIFRPDD,X)) Q:X'>0 I $D(^(X,0)),'$P(^(0),U,2),$P(^(0),U,2)["P" S Y=^(0) D
.I 'DIFRALL,$D(^DD(DIFRPDD,0,"IX",X)) Q
.S PN=0
.S @DIFRPTA@(DIFRPDD,X,PN)=U_$P(Y,U,3)
.F Q:$P($G(^DD(+$P($P(Y,U,2),"P",2),.01,0)),U,2)'["P" S Y=^(0) D
..S PN=PN+1
..S @DIFRPTA@(DIFRPDD,X,PN)=U_$P(Y,U,3)
..Q
.S PIDF=0,PFILE=+$P($P(Y,U,2),"P",2)
.F S PIDF=$O(^DD(PFILE,0,"ID",PIDF)) Q:PIDF'>0 D
..S @DIFRPTA@(DIFRPDD,X,PN,"ID",PIDF)=""
..Q
.;HERE FIND ALL REQUIRED ID OR ALL ID FOR POINTED TOO FILE
.;AND LIST IN @DIFRPTA@(DIFRPDD,X,PN,"ID",FILEDNUMBER)
.Q
Q
;
PGL(DIFRFILE,DIFRFLG,DIFRTA) ; RETURN GL NODES FOR POINTERS IN TARGET ARRAY
;FILE,FLAGS,TARGET ARRAY
N DIFR,DIFRD,DIFRF,DIFRPGL,DIFRX,DIKEY
Q:'$D(^DD(DIFRFILE))
Q:$G(DIFRTA)']""
D FSF(DIFRFILE,"","DIFRPGL")
S DIKEY=$O(^DD("KEY","AP",DIFRFILE,"P",0))
S (DIFR,DIFRD)=0
F S DIFRD=$O(DIFRPGL(DIFRFILE,DIFRD)) Q:DIFRD'>0 D
.S DIFRF=.01 ;Dont select .01 fields
.F S DIFRF=$O(^DD(DIFRD,DIFRF)) Q:DIFRF'>0 I $D(^(DIFRF,0)) S DIFRX=^(0) D
..Q:$P(DIFRX,"^",2) ;Don't select Multiple/WP fields
..I $D(^DD(DIFRD,0,"ID",DIFRF)) Q ;Don't select IDENTIFIER fields
..I DIKEY,$O(^DD("KEY",DIKEY,2,"BB",DIFRF,DIFRD,0)) Q ;Don't select fields in Primary KEY
..I $P(DIFRX,"^",2)["P"!($P(DIFRX,"^",2)["V") S @DIFRTA@("PGL",DIFRD,$$Q^DIQGU($P($P(DIFRX,"^",4),";")),$P($P(DIFRX,"^",4),";",2),DIFRF)=DIFRX Q
..;SEND WHOLD NODE NOT $P(DIFRX,"^",2) Q
..Q
.Q
Q
TP(DIFRFILE,DIFRFLG,DIFRTA) ; $$ Extrinsic Function - Test for Pointers OR Variable Pointers
;Returns 1 or 0, if pointers in file
;FILE,FLAGS,TARGET ARRAY
;If target array exist the entire list of fields being exported will be
;in array
N DIFR,DIFRTMP,DIFRD,DIFRF,DIFRX
S DIFRX=$G(DIFRTA)]""
D FSF(DIFRFILE,"","DIFRTMP")
S (DIFR,DIFRD)=0
F S DIFRD=$O(DIFRTMP(DIFRFILE,DIFRD)) Q:DIFRD'>0 D Q:DIFR
.S DIFRF=.01 ; Do not include .01 fields
.F S DIFRF=$O(^DD(DIFRD,DIFRF)) Q:DIFRF'>0 I $D(^(DIFRF,0)),'$P(^(0),"^",2),($P(^(0),"^",2)["P"!($P(^(0),"^",2)["V")),'$D(^DD(DIFRD,0,"ID",DIFRF)) S:'DIFRX DIFR=1 Q:DIFR D
..S:DIFRX @DIFRTA@(DIFRD,DIFRF)=$S($P(^DD(DIFRD,DIFRF,0),"^",2)["P":"P",1:"V")
..Q
.Q
Q:DIFRX $D(@DIFRTA)>9
Q DIFR
;
TL(DIFRFILE,DIFRFLG,DIFRSA) ; $$ Extrinsic Function - Test for local fields
;FILE,FLAGS,SOURCE_ARRAY - compares local DD with Transport DD
;Returns 1 or 0, if local changes exist
;RUN THIS AFTER DD IS INSTALLED ON TARGET SITE
N DIFR,DIFRD,DIFRF,DIFRTMP
D FSF(DIFRFILE,"","DIFRTMP")
S (DIFR,DIFRD)=0
F S DIFRD=$O(DIFRTMP(DIFRFILE,DIFRD)) Q:DIFRD'>0 D Q:DIFR
.S DIFRF=0
.F S DIFRF=$O(^DD(DIFRD,DIFRF)) Q:DIFRF'>0 I $D(^(DIFRF,0)),'$D(@DIFRSA@("^DD",DIFRFILE,DIFRD,DIFRF,0)) S DIFR=1 Q
.Q
Q DIFR
;
FSF(DIFRFILE,DIFRFLG,DIFRTA) ;File-Sub-File List
;FILE, FLAGS, TARGET ARRAY
N DIFRFD,DIFRFE,DIFRFW,DIFRNM,DIFRX
S DIFRFW=$G(DIFRFLG)'["W"
S @DIFRTA@(DIFRFILE,DIFRFILE)="",DIFRFE=0
F S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0 D
.S DIFRFD=0
.F S DIFRFD=$O(^DD(DIFRFE,"SB",DIFRFD)) Q:DIFRFD'>0 D
..I DIFRFW,$P(^DD(DIFRFD,.01,0),"^",2)["W" Q
..I DIFRFILE-DIFRFE!'$D(DIFRFA) S @DIFRTA@(DIFRFILE,DIFRFD)=""
..Q
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROMSP 4864 printed Sep 23, 2025@20:24:31 Page 2
DIFROMSP ;SFISC/DCL-DIFROM SERVER POINTER LIST ;5/18/98 08:29
+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 ;
POINTERS(DIFRFILE,DIFRFLG,DIFRPTA) ;FILENUMBER, POINTER X-REF TARGET ARRAY ROOT
+1 ;FILE, FLAGS, TARGET ARRAY
+2 SET DIFRFLG=$GET(DIFRFLG)
+3 NEW DIFRDDNS,DIFRALL
+4 SET DIFRALL=DIFRFLG["A"
+5 ;ALL DD#s FOR FILE IN DIFRDDNS array
DO FP(DIFRFILE,"","DIFRDDNS")
+6 SET DIFRDDNS=0
+7 FOR
SET DIFRDDNS=$ORDER(DIFRDDNS(DIFRFILE,DIFRDDNS))
if DIFRDDNS'>0
QUIT
Begin DoDot:1
+8 ;set "P" x-refs in target array
DO P(DIFRDDNS,DIFRFLG,$NAME(@DIFRPTA@("P",DIFRFILE)))
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
FP(DIFRFILE,DIFRFLG,DIFRTA) ;FILENUMBER, TARGET ARRAY ROOT FOR SUB DD NRS
+1 ;FILE, FLAGS, TARGET ARRAY
+2 NEW DIFRFD,DIFRFE,DIFRFW,DIFRNM,DIFRX
+3 SET DIFRFW=$GET(DIFRFLG)'["W"
F SET @DIFRTA@(DIFRFILE,DIFRFILE)=$ORDER(^DD(DIFRFILE,0,"NM",""))_" "_$SELECT($DATA(^DIC(DIFRFILE,0)):"(File-top level)",1:"(sub-file)")
SET DIFRFE=0
E FOR
SET DIFRFE=$ORDER(@DIFRTA@(DIFRFILE,DIFRFE))
if DIFRFE'>0
QUIT
Begin DoDot:1
+1 SET DIFRFD=0
+2 FOR
SET DIFRFD=$ORDER(^DD(DIFRFE,"SB",DIFRFD))
if DIFRFD'>0
QUIT
Begin DoDot:2
+3 IF DIFRFW
IF $PIECE(^DD(DIFRFD,.01,0),"^",2)["W"
QUIT
+4 IF DIFRFILE-DIFRFE!'$DATA(DIFRFA)
SET @DIFRTA@(DIFRFILE,DIFRFD)=$ORDER(^DD(DIFRFD,0,"NM",""))_" (sub-file)"
+5 QUIT
End DoDot:2
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
P(DIFRPDD,DIFRFLG,DIFRPTA) ;DIFRPDD=DD#,DIFRPTA=TARGET ARRAY BY VALUE TO SET "P" X-REF
+1 ;FILE/SUB-DD#,FLAGS,TARGET_ARRAY
+2 NEW X,Y,PN,PIDF,PFILE,DIFRALL
+3 SET DIFRFLG=$GET(DIFRFLG)
SET DIFRALL=DIFRFLG["A"
+4 IF $GET(U)'="^"
NEW U
SET U="^"
+5 SET X=$SELECT(DIFRALL:0,1:.01)
+6 FOR
SET X=$ORDER(^DD(DIFRPDD,X))
if X'>0
QUIT
IF $DATA(^(X,0))
IF '$PIECE(^(0),U,2)
IF $PIECE(^(0),U,2)["P"
SET Y=^(0)
Begin DoDot:1
+7 IF 'DIFRALL
IF $DATA(^DD(DIFRPDD,0,"IX",X))
QUIT
+8 SET PN=0
+9 SET @DIFRPTA@(DIFRPDD,X,PN)=U_$PIECE(Y,U,3)
+10 FOR
if $PIECE($GET(^DD(+$PIECE($PIECE(Y,U,2),"P",2),.01,0)),U,2)'["P"
QUIT
SET Y=^(0)
Begin DoDot:2
+11 SET PN=PN+1
+12 SET @DIFRPTA@(DIFRPDD,X,PN)=U_$PIECE(Y,U,3)
+13 QUIT
End DoDot:2
+14 SET PIDF=0
SET PFILE=+$PIECE($PIECE(Y,U,2),"P",2)
+15 FOR
SET PIDF=$ORDER(^DD(PFILE,0,"ID",PIDF))
if PIDF'>0
QUIT
Begin DoDot:2
+16 SET @DIFRPTA@(DIFRPDD,X,PN,"ID",PIDF)=""
+17 QUIT
End DoDot:2
+18 ;HERE FIND ALL REQUIRED ID OR ALL ID FOR POINTED TOO FILE
+19 ;AND LIST IN @DIFRPTA@(DIFRPDD,X,PN,"ID",FILEDNUMBER)
+20 QUIT
End DoDot:1
+21 QUIT
+22 ;
PGL(DIFRFILE,DIFRFLG,DIFRTA) ; RETURN GL NODES FOR POINTERS IN TARGET ARRAY
+1 ;FILE,FLAGS,TARGET ARRAY
+2 NEW DIFR,DIFRD,DIFRF,DIFRPGL,DIFRX,DIKEY
+3 if '$DATA(^DD(DIFRFILE))
QUIT
+4 if $GET(DIFRTA)']""
QUIT
+5 DO FSF(DIFRFILE,"","DIFRPGL")
+6 SET DIKEY=$ORDER(^DD("KEY","AP",DIFRFILE,"P",0))
+7 SET (DIFR,DIFRD)=0
+8 FOR
SET DIFRD=$ORDER(DIFRPGL(DIFRFILE,DIFRD))
if DIFRD'>0
QUIT
Begin DoDot:1
+9 ;Dont select .01 fields
SET DIFRF=.01
+10 FOR
SET DIFRF=$ORDER(^DD(DIFRD,DIFRF))
if DIFRF'>0
QUIT
IF $DATA(^(DIFRF,0))
SET DIFRX=^(0)
Begin DoDot:2
+11 ;Don't select Multiple/WP fields
if $PIECE(DIFRX,"^",2)
QUIT
+12 ;Don't select IDENTIFIER fields
IF $DATA(^DD(DIFRD,0,"ID",DIFRF))
QUIT
+13 ;Don't select fields in Primary KEY
IF DIKEY
IF $ORDER(^DD("KEY",DIKEY,2,"BB",DIFRF,DIFRD,0))
QUIT
+14 IF $PIECE(DIFRX,"^",2)["P"!($PIECE(DIFRX,"^",2)["V")
SET @DIFRTA@("PGL",DIFRD,$$Q^DIQGU($PIECE($PIECE(DIFRX,"^",4),";")),$PIECE($PIECE(DIFRX,"^",4),";",2),DIFRF)=DIFRX
QUIT
+15 ;SEND WHOLD NODE NOT $P(DIFRX,"^",2) Q
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT
TP(DIFRFILE,DIFRFLG,DIFRTA) ; $$ Extrinsic Function - Test for Pointers OR Variable Pointers
+1 ;Returns 1 or 0, if pointers in file
+2 ;FILE,FLAGS,TARGET ARRAY
+3 ;If target array exist the entire list of fields being exported will be
+4 ;in array
+5 NEW DIFR,DIFRTMP,DIFRD,DIFRF,DIFRX
+6 SET DIFRX=$GET(DIFRTA)]""
+7 DO FSF(DIFRFILE,"","DIFRTMP")
+8 SET (DIFR,DIFRD)=0
+9 FOR
SET DIFRD=$ORDER(DIFRTMP(DIFRFILE,DIFRD))
if DIFRD'>0
QUIT
Begin DoDot:1
+10 ; Do not include .01 fields
SET DIFRF=.01
+11 FOR
SET DIFRF=$ORDER(^DD(DIFRD,DIFRF))
if DIFRF'>0
QUIT
IF $DATA(^(DIFRF,0))
IF '$PIECE(^(0),"^",2)
IF ($PIECE(^(0),"^",2)["P"!($PIECE(^(0),"^",2)["V"))
IF '$DATA(^DD(DIFRD,0,"ID",DIFRF))
if 'DIFRX
SET DIFR=1
if DIFR
QUIT
Begin DoDot:2
+12 if DIFRX
SET @DIFRTA@(DIFRD,DIFRF)=$SELECT($PIECE(^DD(DIFRD,DIFRF,0),"^",2)["P":"P",1:"V")
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
if DIFR
QUIT
+15 if DIFRX
QUIT $DATA(@DIFRTA)>9
+16 QUIT DIFR
+17 ;
TL(DIFRFILE,DIFRFLG,DIFRSA) ; $$ Extrinsic Function - Test for local fields
+1 ;FILE,FLAGS,SOURCE_ARRAY - compares local DD with Transport DD
+2 ;Returns 1 or 0, if local changes exist
+3 ;RUN THIS AFTER DD IS INSTALLED ON TARGET SITE
+4 NEW DIFR,DIFRD,DIFRF,DIFRTMP
+5 DO FSF(DIFRFILE,"","DIFRTMP")
+6 SET (DIFR,DIFRD)=0
+7 FOR
SET DIFRD=$ORDER(DIFRTMP(DIFRFILE,DIFRD))
if DIFRD'>0
QUIT
Begin DoDot:1
+8 SET DIFRF=0
+9 FOR
SET DIFRF=$ORDER(^DD(DIFRD,DIFRF))
if DIFRF'>0
QUIT
IF $DATA(^(DIFRF,0))
IF '$DATA(@DIFRSA@("^DD",DIFRFILE,DIFRD,DIFRF,0))
SET DIFR=1
QUIT
+10 QUIT
End DoDot:1
if DIFR
QUIT
+11 QUIT DIFR
+12 ;
FSF(DIFRFILE,DIFRFLG,DIFRTA) ;File-Sub-File List
+1 ;FILE, FLAGS, TARGET ARRAY
+2 NEW DIFRFD,DIFRFE,DIFRFW,DIFRNM,DIFRX
+3 SET DIFRFW=$GET(DIFRFLG)'["W"
+4 SET @DIFRTA@(DIFRFILE,DIFRFILE)=""
SET DIFRFE=0
+5 FOR
SET DIFRFE=$ORDER(@DIFRTA@(DIFRFILE,DIFRFE))
if DIFRFE'>0
QUIT
Begin DoDot:1
+6 SET DIFRFD=0
+7 FOR
SET DIFRFD=$ORDER(^DD(DIFRFE,"SB",DIFRFD))
if DIFRFD'>0
QUIT
Begin DoDot:2
+8 IF DIFRFW
IF $PIECE(^DD(DIFRFD,.01,0),"^",2)["W"
QUIT
+9 IF DIFRFILE-DIFRFE!'$DATA(DIFRFA)
SET @DIFRTA@(DIFRFILE,DIFRFD)=""
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
