DIFROMS4 ;SFISC/DCL- DATA FROM DISTRIBUTION ARRAY ;5/24/00 15:22 [ 04/02/2003 8:25 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;**41**;Mar 30, 1999
;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
N %,%H,A,B,D,D0,D1,DA,DDF,DDT,DFL,DFN,DFR,DIC,DIFL,DIIX,DIK,DINUM,DIU
N DKP,DMRG,DTL,DTN,DTO,I,V,W,X,Y,Z
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 DIFRDA,DIFRND0,DIFROOT,DIFR01,DIFR02,DIFRRLR,DIFRFRV
N DIFRDKP,DIFRDKPD,DIFRDKPR,DIFRDKPS
D KILL
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
;
; Recover from a failure in Replace Mode RE-INSTALL on target system
I $D(@DIFRSA@("TMP")) D K @DIFRSA@("TMP")
.S (D,DDF(1),DDT(0))=DIFRFILE
.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,REINDEX
.D KILL Q
;
F S DIFRDA=$O(@DIFRRLR@(DIFRDA)) Q:DIFRDA'>0 D
.S (D,DDF(1),DDT(0))=DIFRFILE
.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,REINDEX
.; If no data in local fields, quit.
.I $D(@DIFRSA@("TMP"))'>9 D KILL Q
.; restore data in local fields from old entry
.S DIFRDKP=1,DIFRFRV=0
.K 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,REINDEX,KILL
.Q
K @DIFRSA@("TMP")
; DO A CHECK HERE LIKE Q:'$D(DIFQ) LATER ON
Q
;
KILL K %,%H,A,B,D,D0,D1,DA,DDF,DDT,DFL,DFN,DFR,DIC,DIFL,DIIX,DIK,DINUM,DIU
K DKP,DMRG,DTL,DTN,DTO,I,V,W,X,Y,Z Q
;
REINDEX ; REINDEX ENTRY
Q:DIFRND0'>0
N DIK,DA S DA=DIFRND0,DIK=DIFROOT,DIK(0)="AB"
D IX1^DIK 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. No sending of data allowed for file |1|;1;9515
DIFROMS4 ;SFISC/DCL- DATA FROM DISTRIBUTION ARRAY ;5/24/00 15:22 [ 04/02/2003 8:25 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;**41**;Mar 30, 1999
+3 ;Per VHA Directive 10-93-142, this routine should not be modified.
+4 ;
+5 QUIT
EN ;
+1 IF '$DATA(@DIFRFIA)
DO ERR(2)
QUIT
+2 ;N DIFRFILP S DIFRFILP=$D(DIFRFILP)#2
+3 NEW %,%H,A,B,D,D0,D1,DA,DDF,DDT,DFL,DFN,DFR,DIC,DIFL,DIIX,DIK,DINUM,DIU
+4 NEW DKP,DMRG,DTL,DTN,DTO,I,V,W,X,Y,Z
+5 IF $GET(DIFRFILE)
GOTO FILE
+6 SET DIFRFILE=0
FOR
SET DIFRFILE=$ORDER(@DIFRFIA@(DIFRFILE))
IF DIFRFILE'>0
QUIT
DO FILE
+7 QUIT
FCHK ; * * * PHASING OUT * * *
IF '$DATA(@DIFRFIA@(DIFRFILE))
DO ERR(5)
QUIT
FILE NEW DIFRDA,DIFRND0,DIFROOT,DIFR01,DIFR02,DIFRRLR,DIFRFRV
+1 NEW DIFRDKP,DIFRDKPD,DIFRDKPR,DIFRDKPS
+2 DO KILL
+3 IF '$DATA(@DIFRFIA)
DO ERR(2)
QUIT
+4 IF $GET(@DIFRFIA@(DIFRFILE,DIFRFILE))
Begin DoDot:1
+5 NEW DIFRERR
SET DIFRERR(1)=DIFRFILE
+6 DO BLD^DIALOG(9515,.DIFRERR)
+7 QUIT
End DoDot:1
QUIT
+8 SET DIFROOT=@DIFRFIA@(DIFRFILE,0)
SET DIFRDA=0
+9 SET DIFR01=@DIFRFIA@(DIFRFILE,0,1)
SET DIFR02=$GET(^(2))
+10 IF $PIECE(DIFR02,"^",8)=""
SET $PIECE(DIFR02,"^",8)=$$TL^DIFROMSP(DIFRFILE,"",DIFRSA)
+11 ; * * * phasing out * * *
SET DIFRRLR=$GET(@DIFRFIA@(DIFRFILE,0,"RLRI"))
+12 IF DIFRRLR=""
SET DIFRRLR=$NAME(@DIFRSA@("DATA",DIFRFILE))
+13 IF $DATA(@DIFRRLR)'>9
DO ERR(4)
QUIT
+14 ;
+15 ; Recover from a failure in Replace Mode RE-INSTALL on target system
+16 IF $DATA(@DIFRSA@("TMP"))
Begin DoDot:1
+17 SET (D,DDF(1),DDT(0))=DIFRFILE
+18 SET DTO=0
SET DMRG=1
SET DTO(0)=DIFROOT
SET DKP=$SELECT($TRANSLATE($PIECE(DIFR01,"^",8),"O","o")="o":0,1:1)
+19 SET DFR(1)=$$OREF^DILF(DIFRSA)_"""TMP"",DIFRFILE,D0,"
+20 SET D0=$ORDER(@DIFRSA@("TMP",DIFRFILE,0))
IF '$DATA(^(D0,0))
QUIT
SET Z=^(0)
+21 DO I^DITR
DO REINDEX
+22 DO KILL
QUIT
End DoDot:1
KILL @DIFRSA@("TMP")
+23 ;
+24 FOR
SET DIFRDA=$ORDER(@DIFRRLR@(DIFRDA))
IF DIFRDA'>0
QUIT
Begin DoDot:1
+25 SET (D,DDF(1),DDT(0))=DIFRFILE
+26 SET DTO=0
SET DMRG=1
SET DTO(0)=DIFROOT
+27 SET DFR(1)=$$OREF^DILF($NAME(@DIFRSA@("DATA")))_"DDF(1),D0,"
+28 SET DKP=$SELECT($TRANSLATE($PIECE(DIFR01,"^",8),"O","o")="o":0,1:1)
+29 SET (DIFRDKPD,DIFRDKPR)=$SELECT($TRANSLATE($PIECE(DIFR01,"^",8),"R","r")="r":1,1:0)
+30 SET (DIFRND0,DIFRDKP)=0
+31 ;if file is new Replace not needed
IF +DIFR02
SET (DIFRDKPD,DIFRDKPR)=0
+32 ;save local data
SET DIFRDKPS=$PIECE(DIFR02,"^",8)
+33 SET DIFRFRV=$TRANSLATE($PIECE(DIFR01,"^",5),"Y","y")="y"
+34 SET D0=DIFRDA
SET Z=@DIFRSA@("DATA",DIFRFILE,DIFRDA,0)
+35 KILL @DIFRSA@("TMP")
+36 DO I^DITR
DO REINDEX
+37 ; If no data in local fields, quit.
+38 IF $DATA(@DIFRSA@("TMP"))'>9
DO KILL
QUIT
+39 ; restore data in local fields from old entry
+40 SET DIFRDKP=1
SET DIFRFRV=0
+41 KILL DFR,DA,D0
+42 ;S DFR(1)="^TMP(""DIFRDKPD"",$J,DIFRFILE,D0,"
+43 SET DFR(1)=$$OREF^DILF(DIFRSA)_"""TMP"",DIFRFILE,D0,"
+44 SET D0=$ORDER(@DIFRSA@("TMP",DIFRFILE,0))
IF '$DATA(^(D0,0))
QUIT
SET Z=^(0)
+45 DO I^DITR
DO REINDEX
DO KILL
+46 QUIT
End DoDot:1
+47 KILL @DIFRSA@("TMP")
+48 ; DO A CHECK HERE LIKE Q:'$D(DIFQ) LATER ON
+49 QUIT
+50 ;
KILL KILL %,%H,A,B,D,D0,D1,DA,DDF,DDT,DFL,DFN,DFR,DIC,DIFL,DIIX,DIK,DINUM,DIU
+1 KILL DKP,DMRG,DTL,DTN,DTO,I,V,W,X,Y,Z
QUIT
+2 ;
REINDEX ; REINDEX ENTRY
+1 IF DIFRND0'>0
QUIT
+2 NEW DIK,DA
SET DA=DIFRND0
SET DIK=DIFROOT
SET DIK(0)="AB"
+3 DO IX1^DIK
QUIT
+4 ;
ERR(X) NEW Y
SET Y=$PIECE($TEXT(ERR+X),";",5)
IF 'Y
QUIT
DO BLD^DIALOG(Y)
QUIT
+1 ;;FIA Node Is Set To "No Data";1;9509
+2 ;;FIA Array Does Not Exist;2;9501
+3 ;;;3;
+4 ;;Records Do Not Exist;4;9510
+5 ;;FIA File Number Invalid;5;9502
+6 ;;Partial DD. No sending of data allowed for file |1|;1;9515
