source: FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIFROMSP.m@ 635

DIFROMSP ;SFISC/DCL-DIFROM SERVER POINTER LIST ;5/18/98  08:29
 ;;22.0;VA FileMan;;Mar 30, 1999
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
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