Return to DIFROMSP.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DIFROMSP.m, revision 1.1.1.1

1.1       snw         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