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