Return to DIFROMS4.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Initial commit

DIFROMS4	;SFISC/DCL- DATA FROM DISTRIBUTION ARRAY;03:10 PM  14 Sep 1994;
	;;21.0;VA FileMan;;Dec 28, 1994
	;Per VHA Directive 10-93-142, this routine should not be modified.
	;
	Q
EN	;
	I '$D(@DIFRFIA) D ERR(2) Q
	;N DIFRFILP S DIFRFILP=$D(DIFRFILP)#2
	G:$G(DIFRFILE) FILE
	S DIFRFILE=0 F  S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0  D FILE
	Q
FCHK	I '$D(@DIFRFIA@(DIFRFILE)) D ERR(5) Q  ;  * * * PHASING OUT * * *
FILE	N DIFRS,DIFRSCR,DIFRDA,DIFRND0,DIFROOT,DIFR01,DIFR02,DIFRRLR
	N DIFRQ,DIFRTART,D,DDF,DDT,DTO,DFR,D0,DA,DKP,DIFRFRV,DIFRFRV1,DIFRFRV2
	N DTL,DMRG,DIU,DIK,DIIX,DIC,DFL,D0,D1,A,B,%H,V,W,X,Y,Z
	N DIFRDKP,DIFRDKPD,DIFRDKPR,DIFRDKPS,DIFRNOAD,DIFRX
	I '$D(@DIFRFIA) D ERR(2) Q
	I $G(@DIFRFIA@(DIFRFILE,DIFRFILE)) D  Q
	.N DIFRERR S DIFRERR(1)=DIFRFILE
	.D BLD^DIALOG(9515,.DIFRERR)
	.Q
	S DIFROOT=@DIFRFIA@(DIFRFILE,0),DIFRDA=0
	S DIFR01=@DIFRFIA@(DIFRFILE,0,1),DIFR02=$G(^(2))
	I $P(DIFR02,"^",8)="" S $P(DIFR02,"^",8)=$$TL^DIFROMSP(DIFRFILE,"",DIFRSA)
	S DIFRRLR=$G(@DIFRFIA@(DIFRFILE,0,"RLRI"))  ;  * * * phasing out * * *
	S:DIFRRLR="" DIFRRLR=$NA(@DIFRSA@("DATA",DIFRFILE))
	I $D(@DIFRRLR)'>9 D ERR(4) Q
	S (D,DDF(1),DDT(0))=DIFRFILE
	;
	;   Recover from a failure in Replace Mode RE-INSTALL on target system
	I $D(@DIFRSA@("TMP")) D  K @DIFRSA@("TMP")
	.N DFR,DA,D0,DTO,DKP,Z
	.S DTO=0,DMRG=1,DTO(0)=DIFROOT,DKP=$S($TR($P(DIFR01,"^",8),"O","o")="o":0,1:1)
	.S DFR(1)=$$OREF^DILF(DIFRSA)_"""TMP"",DIFRFILE,D0,"
	.S D0=$O(@DIFRSA@("TMP",DIFRFILE,0)) Q:'$D(^(D0,0))  S Z=^(0)
	.D I^DITR
	.Q
	;
	F  S DIFRDA=$O(@DIFRRLR@(DIFRDA)) Q:DIFRDA'>0  D
	.S DTO=0,DMRG=1,DTO(0)=DIFROOT
	.S DFR(1)=$$OREF^DILF($NA(@DIFRSA@("DATA")))_"DDF(1),D0,"
	.S DKP=$S($TR($P(DIFR01,"^",8),"O","o")="o":0,1:1)
	.S (DIFRDKPD,DIFRDKPR)=$S($TR($P(DIFR01,"^",8),"R","r")="r":1,1:0)
	.S (DIFRND0,DIFRDKP)=0
	.S:+DIFR02 (DIFRDKPD,DIFRDKPR)=0  ;if file is new Replace not needed
	.S DIFRDKPS=$P(DIFR02,"^",8)  ;save local data
	.S DIFRFRV=$TR($P(DIFR01,"^",5),"Y","y")="y"
	.S D0=DIFRDA,Z=@DIFRSA@("DATA",DIFRFILE,DIFRDA,0)
	.K @DIFRSA@("TMP")
	.D I^DITR
	.Q:$D(@DIFRSA@("TMP"))'>9
	.;           re-index entry so old data can find it, in DITR1
	.D:DIFRND0
	..N %,A,B,D0,DA,DIK,DDF,DDT,DFL,DFN,DFR,DKPKDMGR,DTL,DTN,DTO,I,V,W,X,Y,Z
	..S DA=DIFRND0,DIK=DIFROOT
	..D IX1^DIK
	..Q
	.;           preserve data in local fields from old entry
	.S DIFRDKP=1,DIFRFRV=0
	.N DFR,DA,D0
	.;S DFR(1)="^TMP(""DIFRDKPD"",$J,DIFRFILE,D0,"
	.S DFR(1)=$$OREF^DILF(DIFRSA)_"""TMP"",DIFRFILE,D0,"
	.S D0=$O(@DIFRSA@("TMP",DIFRFILE,0)) Q:'$D(^(D0,0))  S Z=^(0)
	.D I^DITR
	.Q
	K DDF,DDT,DDO,DFR,DFN,DTN,@DIFRSA@("TMP")
	; DO A CHECK HERE LIKE Q:'$D(DIFQ) LATER ON
	S DIK=DIFROOT,DIK(0)="AB"
	D IXALL^DIK:$O(@(DIK_"0)"))
	Q
ERR(X)	N Y S Y=$P($T(ERR+X),";",5) Q:'Y  D BLD^DIALOG(Y) Q
	;;FIA Node Is Set To "No Data";1;9509
	;;FIA Array Does Not Exist;2;9501
	;;;3;
	;;Records Do Not Exist;4;9510
	;;FIA File Number Invalid;5;9502
	;; *PARTIAL DD*, Data Transport Not Allowed