DIFROMS2 ;SFISC/DCL/TKW-INSTALL DD FROM SOURCE ARRAY ;9:06 AM 14 Jul 2000 [ 04/02/2003 8:25 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;**11,53**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
;
Q
EN ;
I '$D(@DIFRSA) D ERR(5) Q
I '$D(@DIFRFIA) D ERR(4) Q
G:$G(DIFRFILE) FCHK
S DIFRFILE=0 F S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0 D FILE
Q
FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(6) Q
FILE ;
N DIFR01,DIFR02,DIFRVR,DIFRFDD
S DIFR01=$G(@DIFRFIA@(DIFRFILE,0,1)),DIFR02=$G(^(2))
I $TR($E(DIFR01),"NY","ny")="n" D ERR(1) Q
S DIFRFDD=$TR($P(DIFR01,"^",3),"FP","fp")'="p"
I 'DIFRFDD,'$D(^DIC(DIFRFILE)) D ERR(7) Q
I $D(^DIC(DIFRFILE,0)),$G(@DIFRFIA@(DIFRFILE,0,10))]"" X ^(10) I '$T D ERR(3) Q
;I $TR($E(@DIFRFIA@(DIFRFILE,0,5)),"NY","ny")="y",$D(^DIC(DIFRFILE)) D ERR(2) Q ;INSTALL ONLY IF NEW * * PHASING OUT * *
N %1,DSEC,D,DA,DIC,DIK,DIFRD,DIFRDATA,DIFRFLD,DIFRDIC,DIFRGL,DIFRX,I,X,Y,Z
S DSEC=$P(DIFR02,"^") ; **>> add file security if new file only <<**
I 'DSEC,'$D(^DIC(DIFRFILE,0))#2 S DSEC=1 ; Check to see if the file was Deleted during Pre-Install
;delete DD wp text for file, field and x-ref description and field tech description
;also delete "NM" nodes when installing full DD at specified level
I 'DIFRFDD D
.K @DIFRSA@("DIFRNI",DIFRFILE)
.N DIFRD
.S DIFRD=DIFRFILE
.F S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0 D
..Q:$$UP(DIFRSA,DIFRFILE,DIFRD)
..S @DIFRSA@("DIFRNI",DIFRFILE,DIFRD)=""
..N DIFRNGF,DIFRNGFD
..S DIFRNGF=+$G(@DIFRSA@("UP",DIFRFILE,DIFRD,-1))
..S DIFRNGFD=.01 F S DIFRNGFD=$O(@DIFRSA@("^DD",DIFRFILE,DIFRNGF,DIFRNGFD)) Q:DIFRNGFD="" Q:+$P($G(^(DIFRNGFD,0)),U,2)=DIFRD
..I DIFRNGFD'="" K @DIFRSA@("^DD",DIFRFILE,DIFRNGF,DIFRNGFD)
..Q
.Q
K:DIFRFDD ^DIC(DIFRFILE,"%D")
S DIFRD=0
F S DIFRD=$O(@DIFRSA@("^DD",DIFRFILE,DIFRD)) Q:DIFRD'>0 D
.I 'DIFRFDD,$D(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD)) Q
.K:$D(@DIFRSA@("^DD",DIFRFILE,DIFRD,0,"NM"))\10 ^DD(DIFRD,0,"NM")
.S DIFRFLD=0
.F S DIFRFLD=$O(@DIFRSA@("^DD",DIFRFILE,DIFRD,DIFRFLD)) Q:DIFRFLD'>0 D
..K ^DD(DIFRD,DIFRFLD,21),^(23)
..S DIFRX=0
..F S DIFRX=$O(@DIFRSA@("^DD",DIFRFILE,DIFRD,DIFRFLD,1,DIFRX)) Q:DIFRX'>0 D
...K ^DD(DIFRD,DIFRFLD,1,DIFRX,"%D")
...Q
..Q
.Q
I DIFRFDD F DIFRX="^DIC","^DD" D
.;I DIFRX="^DIC",'DIFRFDD Q
.N X
.I DIFRX="^DIC",$G(^DIC(DIFRFILE,0))]"" S X=$P(^(0),"^",3,9)
.M @DIFRX=@DIFRSA@(DIFRX,DIFRFILE)
.I DIFRX="^DIC",$G(X)]"" S $P(^DIC(DIFRFILE,0),"^",3,9)=X
.I DSEC,$D(@DIFRSA@("SEC",DIFRX,DIFRFILE)) M @DIFRX=@DIFRSA@("SEC",DIFRX,DIFRFILE)
.Q
I 'DIFRFDD D
.N DIFRD
.S DIFRD=0
.F S DIFRD=$O(@DIFRSA@("^DD",DIFRFILE,DIFRD)) Q:DIFRD'>0 D
..I $D(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD)) Q
..M ^DD(DIFRD)=@DIFRSA@("^DD",DIFRFILE,DIFRD)
..I DSEC,$D(@DIFRSA@("SEC","^DD",DIFRFILE,DIFRD)) M ^DD(DIFRD)=@DIFRSA@("SEC","^DD",DIFRFILE,DIFRD)
..Q
.Q
S DIFRD=0 F S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0 D
.I 'DIFRFDD,$D(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD)) Q
.S D=DIFRD,DIK="A" F S DIK=$O(^DD(D,DIK)) Q:DIK="" K ^(DIK)
.S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK
.I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," D IXALL^DIK
.Q
I 'DIFRFDD D G IXKEY
.Q:'$D(@DIFRSA@("^DD",DIFRFILE,DIFRFILE,.01))
.S $P(@(^DIC(DIFRFILE,0,"GL")_"0)"),"^",2)=$$HDR2P^DIFROMSS(DIFRFILE)
.Q
S DIFRGL=^DIC(DIFRFILE,0,"GL"),DIFRDIC=$P(^DIC(DIFRFILE,0),U,1,2)
S $P(DIFRDIC,"^",2)=@DIFRFIA@(DIFRFILE,0,0)
I DIFRFDD,+$G(@DIFRFIA@(DIFRFILE,0,"VR")) S DIFRVR=^("VR") D
.S ^DD(DIFRFILE,0,"VR")=$P(DIFRVR,"^")
.S ^DD(DIFRFILE,0,"VRPK")=$P(DIFRVR,"^",2)
.Q
S DIFRDATA=$D(@(DIFRGL_"0)")),^(0)=DIFRDIC_"^"_$S(DIFRDATA#2:$P(^(0),"^",3,9),1:"^")
;
IXKEY ; Bring INDEX and KEY entries
K ^TMP("DIFROMS2",$J,"TRIG")
S DIFRD=0
F S DIFRD=$O(@DIFRSA@("IX",DIFRFILE,DIFRD)) Q:'DIFRD D DDIXIN^DIFROMSX(DIFRFILE,DIFRD,DIFRSA)
K ^TMP("DIFROMS2",$J,"TRIG")
S DIFRD=0
F S DIFRD=$O(@DIFRSA@("KEY",DIFRFILE,DIFRD)) Q:'DIFRD D DDKEYIN^DIFROMSY(DIFRFILE,DIFRD,DIFRSA)
;
DIKZ I $D(^DD(DIFRFILE,0,"DIK")) D
.N %X,DIKJ,DIR,DMAX,X,Y,DIFRDIKA
.D EN2^DIKZ(DIFRFILE,"",^DD(DIFRFILE,0,"DIK"),^DD("ROU"),"DIFRDIKA")
.I $D(DIFRDIKA) M @DIFRSA@("DIKZ",DIFRFILE)=DIFRDIKA
.S @DIFRSA@("DIKZ",DIFRFILE)=^DD(DIFRFILE,0,"DIK")
.Q
I 'DIFRFDD,$D(@DIFRSA@("DIFRNI",DIFRFILE)) D
.N DIFRD
.S DIFRD=0
.F S DIFRD=$O(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD)) Q:DIFRD'>0 D
..N DIFRERR S DIFRERR(1)=DIFRD
..D BLD^DIALOG(9512,.DIFRERR)
..Q
.Q
Q
;
UP(ROOT,FILE,DDN) ;Return 1 or 0 to install
Q:FILE=DDN 1
Q:$D(^DD(DDN)) 1
Q:'$D(@ROOT@("UP",FILE,DDN)) 1
N MP,PARENT,T,X
S MP=0,X="",T=0
F S X=$O(@ROOT@("UP",FILE,DDN,X)) Q:X="" S PARENT=+^(X) D Q:T!(MP)
.I $D(^DD(PARENT))!($G(@ROOT@("FIA",FILE,PARENT))=0) S:X=0 T=1 Q
.S MP=1
.Q
Q T
;
ERR(X) D BLD^DIALOG($P($T(ERR+X),";",5)) Q
;;FIA Node Is Set To "No DD Update";1;9503
;;Already Exist On Target System (INSTALL ONLY IF NEW);2;9504
;;Did Not Pass DD Screen;3;9505
;;FIA Array Does Not Exist;4;9511
;;Distribution Array Does Not Exist;5;9506
;;FIA File Number Invalid;6;9507
;;Partial DD/File Does Not Already Exist On Target System;7;9508
DIFROMS2 ;SFISC/DCL/TKW-INSTALL DD FROM SOURCE ARRAY ;9:06 AM 14 Jul 2000 [ 04/02/2003 8:25 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;**11,53**;Mar 30, 1999
+3 ;Per VHA Directive 10-93-142, this routine should not be modified.
+4 ;
+5 QUIT
EN ;
+1 IF '$DATA(@DIFRSA)
DO ERR(5)
QUIT
+2 IF '$DATA(@DIFRFIA)
DO ERR(4)
QUIT
+3 IF $GET(DIFRFILE)
GOTO FCHK
+4 SET DIFRFILE=0
FOR
SET DIFRFILE=$ORDER(@DIFRFIA@(DIFRFILE))
IF DIFRFILE'>0
QUIT
DO FILE
+5 QUIT
FCHK IF '$DATA(@DIFRFIA@(DIFRFILE))
DO ERR(6)
QUIT
FILE ;
+1 NEW DIFR01,DIFR02,DIFRVR,DIFRFDD
+2 SET DIFR01=$GET(@DIFRFIA@(DIFRFILE,0,1))
SET DIFR02=$GET(^(2))
+3 IF $TRANSLATE($EXTRACT(DIFR01),"NY","ny")="n"
DO ERR(1)
QUIT
+4 SET DIFRFDD=$TRANSLATE($PIECE(DIFR01,"^",3),"FP","fp")'="p"
+5 IF 'DIFRFDD
IF '$DATA(^DIC(DIFRFILE))
DO ERR(7)
QUIT
+6 IF $DATA(^DIC(DIFRFILE,0))
IF $GET(@DIFRFIA@(DIFRFILE,0,10))]""
XECUTE ^(10)
IF '$TEST
DO ERR(3)
QUIT
+7 ;I $TR($E(@DIFRFIA@(DIFRFILE,0,5)),"NY","ny")="y",$D(^DIC(DIFRFILE)) D ERR(2) Q ;INSTALL ONLY IF NEW * * PHASING OUT * *
+8 NEW %1,DSEC,D,DA,DIC,DIK,DIFRD,DIFRDATA,DIFRFLD,DIFRDIC,DIFRGL,DIFRX,I,X,Y,Z
+9 ; **>> add file security if new file only <<**
SET DSEC=$PIECE(DIFR02,"^")
+10 ; Check to see if the file was Deleted during Pre-Install
IF 'DSEC
IF '$DATA(^DIC(DIFRFILE,0))#2
SET DSEC=1
+11 ;delete DD wp text for file, field and x-ref description and field tech description
+12 ;also delete "NM" nodes when installing full DD at specified level
+13 IF 'DIFRFDD
Begin DoDot:1
+14 KILL @DIFRSA@("DIFRNI",DIFRFILE)
+15 NEW DIFRD
+16 SET DIFRD=DIFRFILE
+17 FOR
SET DIFRD=$ORDER(@DIFRFIA@(DIFRFILE,DIFRD))
IF DIFRD'>0
QUIT
Begin DoDot:2
+18 IF $$UP(DIFRSA,DIFRFILE,DIFRD)
QUIT
+19 SET @DIFRSA@("DIFRNI",DIFRFILE,DIFRD)=""
+20 NEW DIFRNGF,DIFRNGFD
+21 SET DIFRNGF=+$GET(@DIFRSA@("UP",DIFRFILE,DIFRD,-1))
+22 SET DIFRNGFD=.01
FOR
SET DIFRNGFD=$ORDER(@DIFRSA@("^DD",DIFRFILE,DIFRNGF,DIFRNGFD))
IF DIFRNGFD=""
QUIT
IF +$PIECE($GET(^(DIFRNGFD,0)),U,2)=DIFRD
QUIT
+23 IF DIFRNGFD'=""
KILL @DIFRSA@("^DD",DIFRFILE,DIFRNGF,DIFRNGFD)
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 IF DIFRFDD
KILL ^DIC(DIFRFILE,"%D")
+27 SET DIFRD=0
+28 FOR
SET DIFRD=$ORDER(@DIFRSA@("^DD",DIFRFILE,DIFRD))
IF DIFRD'>0
QUIT
Begin DoDot:1
+29 IF 'DIFRFDD
IF $DATA(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD))
QUIT
+30 IF $DATA(@DIFRSA@("^DD",DIFRFILE,DIFRD,0,"NM"))\10
KILL ^DD(DIFRD,0,"NM")
+31 SET DIFRFLD=0
+32 FOR
SET DIFRFLD=$ORDER(@DIFRSA@("^DD",DIFRFILE,DIFRD,DIFRFLD))
IF DIFRFLD'>0
QUIT
Begin DoDot:2
+33 KILL ^DD(DIFRD,DIFRFLD,21),^(23)
+34 SET DIFRX=0
+35 FOR
SET DIFRX=$ORDER(@DIFRSA@("^DD",DIFRFILE,DIFRD,DIFRFLD,1,DIFRX))
IF DIFRX'>0
QUIT
Begin DoDot:3
+36 KILL ^DD(DIFRD,DIFRFLD,1,DIFRX,"%D")
+37 QUIT
End DoDot:3
+38 QUIT
End DoDot:2
+39 QUIT
End DoDot:1
+40 IF DIFRFDD
FOR DIFRX="^DIC","^DD"
Begin DoDot:1
+41 ;I DIFRX="^DIC",'DIFRFDD Q
+42 NEW X
+43 IF DIFRX="^DIC"
IF $GET(^DIC(DIFRFILE,0))]""
SET X=$PIECE(^(0),"^",3,9)
+44 MERGE @DIFRX=@DIFRSA@(DIFRX,DIFRFILE)
+45 IF DIFRX="^DIC"
IF $GET(X)]""
SET $PIECE(^DIC(DIFRFILE,0),"^",3,9)=X
+46 IF DSEC
IF $DATA(@DIFRSA@("SEC",DIFRX,DIFRFILE))
MERGE @DIFRX=@DIFRSA@("SEC",DIFRX,DIFRFILE)
+47 QUIT
End DoDot:1
+48 IF 'DIFRFDD
Begin DoDot:1
+49 NEW DIFRD
+50 SET DIFRD=0
+51 FOR
SET DIFRD=$ORDER(@DIFRSA@("^DD",DIFRFILE,DIFRD))
IF DIFRD'>0
QUIT
Begin DoDot:2
+52 IF $DATA(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD))
QUIT
+53 MERGE ^DD(DIFRD)=@DIFRSA@("^DD",DIFRFILE,DIFRD)
+54 IF DSEC
IF $DATA(@DIFRSA@("SEC","^DD",DIFRFILE,DIFRD))
MERGE ^DD(DIFRD)=@DIFRSA@("SEC","^DD",DIFRFILE,DIFRD)
+55 QUIT
End DoDot:2
+56 QUIT
End DoDot:1
+57 SET DIFRD=0
FOR
SET DIFRD=$ORDER(@DIFRFIA@(DIFRFILE,DIFRD))
IF DIFRD'>0
QUIT
Begin DoDot:1
+58 IF 'DIFRFDD
IF $DATA(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD))
QUIT
+59 SET D=DIFRD
SET DIK="A"
FOR
SET DIK=$ORDER(^DD(D,DIK))
IF DIK=""
QUIT
KILL ^(DIK)
+60 SET DA(1)=D
SET DIK="^DD("_D_","
DO IXALL^DIK
+61 IF $DATA(^DIC(D,"%",0))
SET DIK="^DIC(D,""%"","
DO IXALL^DIK
+62 QUIT
End DoDot:1
+63 IF 'DIFRFDD
Begin DoDot:1
+64 IF '$DATA(@DIFRSA@("^DD",DIFRFILE,DIFRFILE,.01))
QUIT
+65 SET $PIECE(@(^DIC(DIFRFILE,0,"GL")_"0)"),"^",2)=$$HDR2P^DIFROMSS(DIFRFILE)
+66 QUIT
End DoDot:1
GOTO IXKEY
+67 SET DIFRGL=^DIC(DIFRFILE,0,"GL")
SET DIFRDIC=$PIECE(^DIC(DIFRFILE,0),U,1,2)
+68 SET $PIECE(DIFRDIC,"^",2)=@DIFRFIA@(DIFRFILE,0,0)
+69 IF DIFRFDD
IF +$GET(@DIFRFIA@(DIFRFILE,0,"VR"))
SET DIFRVR=^("VR")
Begin DoDot:1
+70 SET ^DD(DIFRFILE,0,"VR")=$PIECE(DIFRVR,"^")
+71 SET ^DD(DIFRFILE,0,"VRPK")=$PIECE(DIFRVR,"^",2)
+72 QUIT
End DoDot:1
+73 SET DIFRDATA=$DATA(@(DIFRGL_"0)"))
SET ^(0)=DIFRDIC_"^"_$SELECT(DIFRDATA#2:$PIECE(^(0),"^",3,9),1:"^")
+74 ;
IXKEY ; Bring INDEX and KEY entries
+1 KILL ^TMP("DIFROMS2",$JOB,"TRIG")
+2 SET DIFRD=0
+3 FOR
SET DIFRD=$ORDER(@DIFRSA@("IX",DIFRFILE,DIFRD))
IF 'DIFRD
QUIT
DO DDIXIN^DIFROMSX(DIFRFILE,DIFRD,DIFRSA)
+4 KILL ^TMP("DIFROMS2",$JOB,"TRIG")
+5 SET DIFRD=0
+6 FOR
SET DIFRD=$ORDER(@DIFRSA@("KEY",DIFRFILE,DIFRD))
IF 'DIFRD
QUIT
DO DDKEYIN^DIFROMSY(DIFRFILE,DIFRD,DIFRSA)
+7 ;
DIKZ IF $DATA(^DD(DIFRFILE,0,"DIK"))
Begin DoDot:1
+1 NEW %X,DIKJ,DIR,DMAX,X,Y,DIFRDIKA
+2 DO EN2^DIKZ(DIFRFILE,"",^DD(DIFRFILE,0,"DIK"),^DD("ROU"),"DIFRDIKA")
+3 IF $DATA(DIFRDIKA)
MERGE @DIFRSA@("DIKZ",DIFRFILE)=DIFRDIKA
+4 SET @DIFRSA@("DIKZ",DIFRFILE)=^DD(DIFRFILE,0,"DIK")
+5 QUIT
End DoDot:1
+6 IF 'DIFRFDD
IF $DATA(@DIFRSA@("DIFRNI",DIFRFILE))
Begin DoDot:1
+7 NEW DIFRD
+8 SET DIFRD=0
+9 FOR
SET DIFRD=$ORDER(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD))
IF DIFRD'>0
QUIT
Begin DoDot:2
+10 NEW DIFRERR
SET DIFRERR(1)=DIFRD
+11 DO BLD^DIALOG(9512,.DIFRERR)
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
UP(ROOT,FILE,DDN) ;Return 1 or 0 to install
+1 IF FILE=DDN
QUIT 1
+2 IF $DATA(^DD(DDN))
QUIT 1
+3 IF '$DATA(@ROOT@("UP",FILE,DDN))
QUIT 1
+4 NEW MP,PARENT,T,X
+5 SET MP=0
SET X=""
SET T=0
+6 FOR
SET X=$ORDER(@ROOT@("UP",FILE,DDN,X))
IF X=""
QUIT
SET PARENT=+^(X)
Begin DoDot:1
+7 IF $DATA(^DD(PARENT))!($GET(@ROOT@("FIA",FILE,PARENT))=0)
IF X=0
SET T=1
QUIT
+8 SET MP=1
+9 QUIT
End DoDot:1
IF T!(MP)
QUIT
+10 QUIT T
+11 ;
ERR(X) DO BLD^DIALOG($PIECE($TEXT(ERR+X),";",5))
QUIT
+1 ;;FIA Node Is Set To "No DD Update";1;9503
+2 ;;Already Exist On Target System (INSTALL ONLY IF NEW);2;9504
+3 ;;Did Not Pass DD Screen;3;9505
+4 ;;FIA Array Does Not Exist;4;9511
+5 ;;Distribution Array Does Not Exist;5;9506
+6 ;;FIA File Number Invalid;6;9507
+7 ;;Partial DD/File Does Not Already Exist On Target System;7;9508
