Return to DIFROMSP.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DIFROMSP	;SFISC/DCL-DIFROM SERVER POINTER LIST;02:58 PM  9 Sep 1994;
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: 	;
    5: POINTERS(DIFRFILE,DIFRFLG,DIFRPTA)	;FILENUMBER, POINTER X-REF TARGET ARRAY ROOT
    6: 	;FILE, FLAGS, TARGET ARRAY
    7: 	S DIFRFLG=$G(DIFRFLG)
    8: 	N DIFRDDNS,DIFRALL
    9: 	S DIFRALL=DIFRFLG["A"
   10: 	D FP(DIFRFILE,"","DIFRDDNS")  ;ALL DD#s FOR FILE IN DIFRDDNS array
   11: 	S DIFRDDNS=0
   12: 	F  S DIFRDDNS=$O(DIFRDDNS(DIFRFILE,DIFRDDNS)) Q:DIFRDDNS'>0  D
   13: 	.D P(DIFRDDNS,DIFRFLG,$NA(@DIFRPTA@("P",DIFRFILE)))  ;set "P" x-refs in target array
   14: 	.Q
   15: 	Q
   16: 	;
   17: FP(DIFRFILE,DIFRFLG,DIFRTA)	;FILENUMBER, TARGET ARRAY ROOT FOR SUB DD NRS
   18: 	;FILE, FLAGS, TARGET ARRAY
   19: 	N DIFRFD,DIFRFE,DIFRFW,DIFRNM,DIFRX
   20: 	S DIFRFW=$G(DIFRFLG)'["W"
   21: F	S @DIFRTA@(DIFRFILE,DIFRFILE)=$O(^DD(DIFRFILE,0,"NM",""))_"  "_$S($D(^DIC(DIFRFILE,0)):"(File-top level)",1:"(sub-file)"),DIFRFE=0
   22: E	F  S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0  D
   23: 	.S DIFRFD=0
   24: 	.F  S DIFRFD=$O(^DD(DIFRFE,"SB",DIFRFD)) Q:DIFRFD'>0  D
   25: 	..I DIFRFW,$P(^DD(DIFRFD,.01,0),"^",2)["W" Q
   26: 	..I DIFRFILE-DIFRFE!'$D(DIFRFA) S @DIFRTA@(DIFRFILE,DIFRFD)=$O(^DD(DIFRFD,0,"NM",""))_"  (sub-file)"
   27: 	..Q
   28: 	.Q
   29: 	Q
   30: 	;
   31: P(DIFRPDD,DIFRFLG,DIFRPTA)	;DIFRPDD=DD#,DIFRPTA=TARGET ARRAY BY VALUE TO SET "P" X-REF
   32: 	;FILE/SUB-DD#,FLAGS,TARGET_ARRAY
   33: 	N X,Y,PN,PIDF,PFILE,DIFRALL
   34: 	S DIFRFLG=$G(DIFRFLG),DIFRALL=DIFRFLG["A"
   35: 	I $G(U)'="^" N U S U="^"
   36: 	S X=$S(DIFRALL:0,1:.01)
   37: 	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
   38: 	.I 'DIFRALL,$D(^DD(DIFRPDD,0,"IX",X)) Q
   39: 	.S PN=0
   40: 	.S @DIFRPTA@(DIFRPDD,X,PN)=U_$P(Y,U,3)
   41: 	.F  Q:$P($G(^DD(+$P($P(Y,U,2),"P",2),.01,0)),U,2)'["P"  S Y=^(0) D
   42: 	..S PN=PN+1
   43: 	..S @DIFRPTA@(DIFRPDD,X,PN)=U_$P(Y,U,3)
   44: 	..Q
   45: 	.S PIDF=0,PFILE=+$P($P(Y,U,2),"P",2)
   46: 	.F  S PIDF=$O(^DD(PFILE,0,"ID",PIDF)) Q:PIDF'>0  D
   47: 	..S @DIFRPTA@(DIFRPDD,X,PN,"ID",PIDF)=""
   48: 	..Q
   49: 	.;HERE FIND ALL REQUIRED ID OR ALL ID FOR POINTED TOO FILE
   50: 	.;AND LIST IN @DIFRPTA@(DIFRPDD,X,PN,"ID",FILEDNUMBER)
   51: 	.Q
   52: 	Q
   53: 	;
   54: PGL(DIFRFILE,DIFRFLG,DIFRTA)	;  RETURN GL NODES FOR POINTERS IN TARGET ARRAY
   55: 	;FILE,FLAGS,TARGET ARRAY
   56: 	N DIFR,DIFRD,DIFRF,DIFRPGL,DIFRX
   57: 	Q:'$D(^DD(DIFRFILE))
   58: 	Q:$G(DIFRTA)']""
   59: 	D FSF(DIFRFILE,"","DIFRPGL")
   60: 	S (DIFR,DIFRD)=0
   61: 	F  S DIFRD=$O(DIFRPGL(DIFRFILE,DIFRD)) Q:DIFRD'>0  D
   62: 	.S DIFRF=.01  ;Dont select .01 fields
   63: 	.F  S DIFRF=$O(^DD(DIFRD,DIFRF)) Q:DIFRF'>0  I $D(^(DIFRF,0)) S DIFRX=^(0) D
   64: 	..Q:$P(DIFRX,"^",2)  ;Don't select Multiple/WP fields
   65: 	..I $D(^DD(DIFRD,0,"ID",DIFRF)) Q  ;Don't select IDENTIFIER fields
   66: 	..I $P(DIFRX,"^",2)["P"!($P(DIFRX,"^",2)["V") S @DIFRTA@("PGL",DIFRD,$P($P(DIFRX,"^",4),";"),$P($P(DIFRX,"^",4),";",2),DIFRF)=DIFRX Q
   67: 	..;SEND WHOLD NODE NOT $P(DIFRX,"^",2) Q
   68: 	..Q
   69: 	.Q
   70: 	Q
   71: TP(DIFRFILE,DIFRFLG,DIFRTA)	; $$ Extrinsic Function - Test for Pointers OR Variable Pointers
   72: 	;Returns 1 or 0, if pointers in file
   73: 	;FILE,FLAGS,TARGET ARRAY
   74: 	;If target array exist the entire list of fields being exported will be
   75: 	;in array
   76: 	N DIFR,DIFRTMP,DIFRD,DIFRF,DIFRX
   77: 	S DIFRX=$G(DIFRTA)]""
   78: 	D FSF(DIFRFILE,"","DIFRTMP")
   79: 	S (DIFR,DIFRD)=0
   80: 	F  S DIFRD=$O(DIFRTMP(DIFRFILE,DIFRD)) Q:DIFRD'>0  D  Q:DIFR
   81: 	.S DIFRF=.01  ; Do not include .01 fields
   82: 	.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
   83: 	..S:DIFRX @DIFRTA@(DIFRD,DIFRF)=$S($P(^DD(DIFRD,DIFRF,0),"^",2)["P":"P",1:"V")
   84: 	..Q
   85: 	.Q
   86: 	Q:DIFRX $D(@DIFRTA)>9
   87: 	Q DIFR
   88: 	;
   89: TL(DIFRFILE,DIFRFLG,DIFRSA)	; $$ Extrinsic Function - Test for local fields
   90: 	;FILE,FLAGS,SOURCE_ARRAY - compares local DD with Transport DD
   91: 	;Returns 1 or 0, if local changes exist
   92: 	;RUN THIS AFTER DD IS INSTALLED ON TARGET SITE
   93: 	N DIFR,DIFRD,DIFRF,DIFRTMP
   94: 	D FSF(DIFRFILE,"","DIFRTMP")
   95: 	S (DIFR,DIFRD)=0
   96: 	F  S DIFRD=$O(DIFRTMP(DIFRFILE,DIFRD)) Q:DIFRD'>0  D  Q:DIFR
   97: 	.S DIFRF=0
   98: 	.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
   99: 	.Q
  100: 	Q DIFR
  101: 	;
  102: FSF(DIFRFILE,DIFRFLG,DIFRTA)	;File-Sub-File List
  103: 	;FILE, FLAGS, TARGET ARRAY
  104: 	N DIFRFD,DIFRFE,DIFRFW,DIFRNM,DIFRX
  105: 	S DIFRFW=$G(DIFRFLG)'["W"
  106: 	S @DIFRTA@(DIFRFILE,DIFRFILE)="",DIFRFE=0
  107: 	F  S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0  D
  108: 	.S DIFRFD=0
  109: 	.F  S DIFRFD=$O(^DD(DIFRFE,"SB",DIFRFD)) Q:DIFRFD'>0  D
  110: 	..I DIFRFW,$P(^DD(DIFRFD,.01,0),"^",2)["W" Q
  111: 	..I DIFRFILE-DIFRFE!'$D(DIFRFA) S @DIFRTA@(DIFRFILE,DIFRFD)=""
  112: 	..Q
  113: 	.Q
  114: 	Q