DIFROMS2 ;SFISC/DCL/TKW - INSTALL DD FROM SOURCE ARRAY ; Jul 05, 2022@09:27:23
;;22.2;VA FileMan;**3,5,14,19,21,23**;Jan 05, 2016;Build 2
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;;GFT;**11,53,1037,1053,1055**
;
Q
;
EN ;CALLED FROM DIFROMS
;WHERE, E.G. ^XTMP("XPDI",4861,"^DD",21489,21489,.01,0)="NAME^RF^^0;1^K:$L(X)>30!(X?.N) X
;AND THEREFORE DIFRSA=^XTMP("XPDI",4861)
;^XTMP("XPDI",4861,"FIA",21489)="MSC ORDERS HL7"
;^XTMP("XPDI",4861,"FIA",21489,0)="^MSCH(21489,"
;^XTMP("XPDI",4861,"FIA",21489,0,0)=21489
; 1)="y^y^f^^n^^y^o^n" -- ^XPD(9.6,D0,4,D1,222)
; 2)="1^^0"
;^XTMP("XPDI",4861,"FIA",21489,21489)=0 0=full, 1=partial
; 21489.01)=0
;AND THEREFORE DIFRFIA=^XTMP("XPDI",4861,"FIA")
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 ;LOOP THRU ALL INCOMING TOP-LEVEL FILES
Q
;
;
FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(6) Q
FILE ;
N DIFR01,DIFR02,DIFRVR,DIFRFDD,DIFRQUIT
S DIFR01=$G(@DIFRFIA@(DIFRFILE,0,1)) ;UPDATE DATA DICTIONARY [1S] ^ (#222.2) SEND SECURITY CODE [2S] ^ (#222.3) SEND FULL
S DIFR02=$G(@DIFRFIA@(DIFRFILE,0,2))
I $TR($E(DIFR01),"NY","ny")="n" D ERR(1) Q
S DIFRFDD=$TR($P(DIFR01,"^",3),"FP","fp")'="p" ;DIFRFDD=0 means PARTIAL DEFINITION
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
;
;^XTMP("XPDI",4861,"^DD",21489,21489,0)="FIELD^^1^2"
;^XTMP("XPDI",4861,"^DD",21489,21489,0,"IX","B",21489,.01)=""
;^XTMP("XPDI",4861,"^DD",21489,21489,0,"NM","MSC ORDERS HL7")=""
;^XTMP("XPDI",4861,"^DD",21489,21489,.01,0)="NAME^RF^^0;1^K:$L(X)>30
; parital DDs
I 'DIFRFDD D
.K @DIFRSA@("DIFRNI",DIFRFILE)
.N DIFRD
.S DIFRD=DIFRFILE
.; loop thru sub DDs
.F S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0 D
..Q:$$UP(DIFRSA,DIFRFILE,DIFRD) ;check parent, quit if everything is OK
..S @DIFRSA@("DIFRNI",DIFRFILE,DIFRD)="" ;there is a problem, this node is process in tag DIKZ
..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 '$D(@DIFRFIA@(DIFRFILE,DIFRD)) S @DIFRFIA@(DIFRFILE,DIFRD)=0 ;MAKE SURE WE WILL CROSS-REFERENCE THIS DD
.;S ^DD(DIFRD,0)="FIELD^NL^" ;p14 this was masking the problem of a partial multiple where the .01 field is missing
.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 ;check cross ref.
...K ^DD(DIFRD,DIFRFLD,1,DIFRX,"%D") ;kill Description
...S Z=0 F S Z=$O(^DD(DIFRD,DIFRFLD,1,DIFRX,Z)) Q:'Z I Z'=1,Z'=2 K ^(Z) ;p21 kill spill over cross ref. code
FULL I DIFRFDD F DIFRX="^DIC","^DD" D ;FULL DEFINITION
.N X
.I DIFRX="^DIC",$G(^DIC(DIFRFILE,0))]"" S X=$P(^(0),"^",3,9) ;REMEMBER NODES 3 &4 (LAST^COUNT)
.D K12:DIFRX="^DD" M @DIFRX=@DIFRSA@(DIFRX,DIFRFILE) D UPDATED^DICATTA(DIFRFILE,-1) ;MOVE IN A WHOLE DD OR DIC NODE
.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
PARTIAL I 'DIFRFDD D ;PARTIAL DEFINITION
.N DIFRD
.S DIFRD=0
.F S DIFRD=$O(@DIFRSA@("^DD",DIFRFILE,DIFRD)) Q:DIFRD'>0 D
..I $D(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD)) Q ;ABORT
..D K12(DIFRD) M ^DD(DIFRD)=@DIFRSA@("^DD",DIFRFILE,DIFRD) ;HERE IS WHERE A WHOLE DD COMES OVER!
..D UPDATED^DICATTA(DIFRD,-1) ;SET THE %MSC NODE
SETUP ..I $G(@DIFRSA@("UP",DIFRFILE,DIFRD,-1)) S ^DD(DIFRD,0,"UP")=+^(-1) ;SET THE "UP" NODE, SINCE IT SEEMS NOT TO BE SENT WITH THE REST OF THE ^DD
..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 D IXALL^DIK L -^DD(0) ;CROSS-REFERENCE THE ^DD THAT WE HAVE BUILT
..N Z ;retry lock until success or 5 min. p19
..F Z=1:1:150 L +^DD(0):2 Q:$T
..E S DIFRMSGR="Can't Lock ^DD(0), file #"_DIFRFILE_" not installed!",Z=1/0 ;throw <DIVIDE> error to stop install
..Q
.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
;process errors
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) ;"parent DD(s) missing"
Q
;
K12(DIFRD) N DD,D S DIFRD=+$G(DIFRD) ;DIFRD WILL BE THERE FOR A PARTIAL UPDATE
F DD=0:0 S DD=$O(@DIFRSA@("^DD",DIFRFILE,DD)) Q:'DD I DIFRD=DD!'DIFRD D
.F D=0:0 S D=$O(@DIFRSA@("^DD",DIFRFILE,DD,D)) Q:'D K ^DD(DD,D,12),^(12.1),^("V") ;p23 Kill 'SCREEN' and Variable pointer nodes, because they may not be coming in
Q
;
UP(ROOT,FILE,DDN) ;Return 1 if OK, or 0 for error p14
Q:FILE=DDN 1 ;top level file
Q:$D(^DD(DDN)) 1 ;subDD already exists
Q:'$D(@ROOT@("UP",FILE,DDN)) 1 ;no parent in transport
N T S T=0
D UP1
I $G(@ROOT@("FIA",FILE,DDN))=0 Q T ;full subDD
I T,'$D(@ROOT@("FIA",FILE,DDN,.01)) S T=0 ;partial subDD, no subDD at site, no .01 field sent = error
Q T
;
UP1 N MP,PARENT,X ;p14
S MP=0,X=""
;checks if parent exists or is in transport
F S X=$O(@ROOT@("UP",FILE,DDN,X)) Q:X="" S PARENT=+^(X) D Q:T!(MP)
.I $D(^DD(PARENT))!$D(@ROOT@("FIA",FILE,PARENT)) S:X>-2 T=1 Q ;***GFT
.S MP=1
.Q
Q
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROMS2 8268 printed Sep 23, 2025@20:24:20 Page 2
DIFROMS2 ;SFISC/DCL/TKW - INSTALL DD FROM SOURCE ARRAY ; Jul 05, 2022@09:27:23
+1 ;;22.2;VA FileMan;**3,5,14,19,21,23**;Jan 05, 2016;Build 2
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;;GFT;**11,53,1037,1053,1055**
+7 ;
+8 QUIT
+9 ;
EN ;CALLED FROM DIFROMS
+1 ;WHERE, E.G. ^XTMP("XPDI",4861,"^DD",21489,21489,.01,0)="NAME^RF^^0;1^K:$L(X)>30!(X?.N) X
+2 ;AND THEREFORE DIFRSA=^XTMP("XPDI",4861)
+3 ;^XTMP("XPDI",4861,"FIA",21489)="MSC ORDERS HL7"
+4 ;^XTMP("XPDI",4861,"FIA",21489,0)="^MSCH(21489,"
+5 ;^XTMP("XPDI",4861,"FIA",21489,0,0)=21489
+6 ; 1)="y^y^f^^n^^y^o^n" -- ^XPD(9.6,D0,4,D1,222)
+7 ; 2)="1^^0"
+8 ;^XTMP("XPDI",4861,"FIA",21489,21489)=0 0=full, 1=partial
+9 ; 21489.01)=0
+10 ;AND THEREFORE DIFRFIA=^XTMP("XPDI",4861,"FIA")
+11 IF '$DATA(@DIFRSA)
DO ERR(5)
QUIT
+12 IF '$DATA(@DIFRFIA)
DO ERR(4)
QUIT
+13 if $GET(DIFRFILE)
GOTO FCHK
+14 ;LOOP THRU ALL INCOMING TOP-LEVEL FILES
SET DIFRFILE=0
FOR
SET DIFRFILE=$ORDER(@DIFRFIA@(DIFRFILE))
if DIFRFILE'>0
QUIT
DO FILE
+15 QUIT
+16 ;
+17 ;
FCHK IF '$DATA(@DIFRFIA@(DIFRFILE))
DO ERR(6)
QUIT
FILE ;
+1 NEW DIFR01,DIFR02,DIFRVR,DIFRFDD,DIFRQUIT
+2 ;UPDATE DATA DICTIONARY [1S] ^ (#222.2) SEND SECURITY CODE [2S] ^ (#222.3) SEND FULL
SET DIFR01=$GET(@DIFRFIA@(DIFRFILE,0,1))
+3 SET DIFR02=$GET(@DIFRFIA@(DIFRFILE,0,2))
+4 IF $TRANSLATE($EXTRACT(DIFR01),"NY","ny")="n"
DO ERR(1)
QUIT
+5 ;DIFRFDD=0 means PARTIAL DEFINITION
SET DIFRFDD=$TRANSLATE($PIECE(DIFR01,"^",3),"FP","fp")'="p"
+6 IF 'DIFRFDD
IF '$DATA(^DIC(DIFRFILE))
DO ERR(7)
QUIT
+7 IF $DATA(^DIC(DIFRFILE,0))
IF $GET(@DIFRFIA@(DIFRFILE,0,10))]""
XECUTE ^(10)
IF '$TEST
DO ERR(3)
QUIT
+8 ;I $TR($E(@DIFRFIA@(DIFRFILE,0,5)),"NY","ny")="y",$D(^DIC(DIFRFILE)) D ERR(2) Q ;INSTALL ONLY IF NEW * * PHASING OUT * *
+9 NEW %1,DSEC,D,DA,DIC,DIK,DIFRD,DIFRDATA,DIFRFLD,DIFRDIC,DIFRGL,DIFRX,I,X,Y,Z
+10 ; **>> add file security if new file only <<**
SET DSEC=$PIECE(DIFR02,"^")
+11 ; Check to see if the file was Deleted during Pre-Install
IF 'DSEC
IF '$DATA(^DIC(DIFRFILE,0))#2
SET DSEC=1
+12 ;delete DD wp text for file, field and x-ref description and field tech description
+13 ;also delete "NM" nodes when installing full DD at specified level
+14 ;
+15 ;^XTMP("XPDI",4861,"^DD",21489,21489,0)="FIELD^^1^2"
+16 ;^XTMP("XPDI",4861,"^DD",21489,21489,0,"IX","B",21489,.01)=""
+17 ;^XTMP("XPDI",4861,"^DD",21489,21489,0,"NM","MSC ORDERS HL7")=""
+18 ;^XTMP("XPDI",4861,"^DD",21489,21489,.01,0)="NAME^RF^^0;1^K:$L(X)>30
+19 ; parital DDs
+20 IF 'DIFRFDD
Begin DoDot:1
+21 KILL @DIFRSA@("DIFRNI",DIFRFILE)
+22 NEW DIFRD
+23 SET DIFRD=DIFRFILE
+24 ; loop thru sub DDs
+25 FOR
SET DIFRD=$ORDER(@DIFRFIA@(DIFRFILE,DIFRD))
if DIFRD'>0
QUIT
Begin DoDot:2
+26 ;check parent, quit if everything is OK
if $$UP(DIFRSA,DIFRFILE,DIFRD)
QUIT
+27 ;there is a problem, this node is process in tag DIKZ
SET @DIFRSA@("DIFRNI",DIFRFILE,DIFRD)=""
+28 NEW DIFRNGF,DIFRNGFD
+29 SET DIFRNGF=+$GET(@DIFRSA@("UP",DIFRFILE,DIFRD,-1))
+30 SET DIFRNGFD=.01
FOR
SET DIFRNGFD=$ORDER(@DIFRSA@("^DD",DIFRFILE,DIFRNGF,DIFRNGFD))
if DIFRNGFD=""
QUIT
if +$PIECE($GET(^(DIFRNGFD,0)),U,2)=DIFRD
QUIT
+31 IF DIFRNGFD'=""
KILL @DIFRSA@("^DD",DIFRFILE,DIFRNGF,DIFRNGFD)
+32 QUIT
End DoDot:2
+33 QUIT
End DoDot:1
+34 if DIFRFDD
KILL ^DIC(DIFRFILE,"%D")
+35 SET DIFRD=0
+36 FOR
SET DIFRD=$ORDER(@DIFRSA@("^DD",DIFRFILE,DIFRD))
if DIFRD'>0
QUIT
Begin DoDot:1
+37 ;MAKE SURE WE WILL CROSS-REFERENCE THIS DD
IF '$DATA(@DIFRFIA@(DIFRFILE,DIFRD))
SET @DIFRFIA@(DIFRFILE,DIFRD)=0
+38 ;S ^DD(DIFRD,0)="FIELD^NL^" ;p14 this was masking the problem of a partial multiple where the .01 field is missing
+39 IF 'DIFRFDD
IF $DATA(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD))
QUIT
+40 if $DATA(@DIFRSA@("^DD",DIFRFILE,DIFRD,0,"NM"))\10
KILL ^DD(DIFRD,0,"NM")
+41 SET DIFRFLD=0
+42 FOR
SET DIFRFLD=$ORDER(@DIFRSA@("^DD",DIFRFILE,DIFRD,DIFRFLD))
if DIFRFLD'>0
QUIT
Begin DoDot:2
+43 KILL ^DD(DIFRD,DIFRFLD,21),^(23)
+44 SET DIFRX=0
+45 ;check cross ref.
FOR
SET DIFRX=$ORDER(@DIFRSA@("^DD",DIFRFILE,DIFRD,DIFRFLD,1,DIFRX))
if DIFRX'>0
QUIT
Begin DoDot:3
+46 ;kill Description
KILL ^DD(DIFRD,DIFRFLD,1,DIFRX,"%D")
+47 ;p21 kill spill over cross ref. code
SET Z=0
FOR
SET Z=$ORDER(^DD(DIFRD,DIFRFLD,1,DIFRX,Z))
if 'Z
QUIT
IF Z'=1
IF Z'=2
KILL ^(Z)
End DoDot:3
End DoDot:2
End DoDot:1
FULL ;FULL DEFINITION
IF DIFRFDD
FOR DIFRX="^DIC","^DD"
Begin DoDot:1
+1 NEW X
+2 ;REMEMBER NODES 3 &4 (LAST^COUNT)
IF DIFRX="^DIC"
IF $GET(^DIC(DIFRFILE,0))]""
SET X=$PIECE(^(0),"^",3,9)
+3 ;MOVE IN A WHOLE DD OR DIC NODE
if DIFRX="^DD"
DO K12
MERGE @DIFRX=@DIFRSA@(DIFRX,DIFRFILE)
DO UPDATED^DICATTA(DIFRFILE,-1)
+4 IF DIFRX="^DIC"
IF $GET(X)]""
SET $PIECE(^DIC(DIFRFILE,0),"^",3,9)=X
+5 IF DSEC
IF $DATA(@DIFRSA@("SEC",DIFRX,DIFRFILE))
MERGE @DIFRX=@DIFRSA@("SEC",DIFRX,DIFRFILE)
+6 QUIT
End DoDot:1
PARTIAL ;PARTIAL DEFINITION
IF 'DIFRFDD
Begin DoDot:1
+1 NEW DIFRD
+2 SET DIFRD=0
+3 FOR
SET DIFRD=$ORDER(@DIFRSA@("^DD",DIFRFILE,DIFRD))
if DIFRD'>0
QUIT
Begin DoDot:2
+4 ;ABORT
IF $DATA(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD))
QUIT
+5 ;HERE IS WHERE A WHOLE DD COMES OVER!
DO K12(DIFRD)
MERGE ^DD(DIFRD)=@DIFRSA@("^DD",DIFRFILE,DIFRD)
+6 ;SET THE %MSC NODE
DO UPDATED^DICATTA(DIFRD,-1)
SETUP ;SET THE "UP" NODE, SINCE IT SEEMS NOT TO BE SENT WITH THE REST OF THE ^DD
IF $GET(@DIFRSA@("UP",DIFRFILE,DIFRD,-1))
SET ^DD(DIFRD,0,"UP")=+^(-1)
+1 IF DSEC
IF $DATA(@DIFRSA@("SEC","^DD",DIFRFILE,DIFRD))
MERGE ^DD(DIFRD)=@DIFRSA@("SEC","^DD",DIFRFILE,DIFRD)
+2 QUIT
End DoDot:2
+3 QUIT
End DoDot:1
+4 SET DIFRD=0
FOR
SET DIFRD=$ORDER(@DIFRFIA@(DIFRFILE,DIFRD))
if DIFRD'>0
QUIT
Begin DoDot:1
+5 IF 'DIFRFDD
IF $DATA(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD))
QUIT
+6 SET D=DIFRD
SET DIK="A"
FOR
SET DIK=$ORDER(^DD(D,DIK))
if DIK=""
QUIT
KILL ^(DIK)
+7 ;CROSS-REFERENCE THE ^DD THAT WE HAVE BUILT
SET DA(1)=D
SET DIK="^DD("_D_","
Begin DoDot:2
+8 ;retry lock until success or 5 min. p19
NEW Z
+9 FOR Z=1:1:150
LOCK +^DD(0):2
if $TEST
QUIT
+10 ;throw <DIVIDE> error to stop install
IF '$TEST
SET DIFRMSGR="Can't Lock ^DD(0), file #"_DIFRFILE_" not installed!"
SET Z=1/0
+11 QUIT
End DoDot:2
DO IXALL^DIK
LOCK -^DD(0)
+12 IF $DATA(^DIC(D,"%",0))
SET DIK="^DIC(D,""%"","
DO IXALL^DIK
+13 QUIT
End DoDot:1
+14 IF 'DIFRFDD
Begin DoDot:1
+15 if '$DATA(@DIFRSA@("^DD",DIFRFILE,DIFRFILE,.01))
QUIT
+16 SET $PIECE(@(^DIC(DIFRFILE,0,"GL")_"0)"),"^",2)=$$HDR2P^DIFROMSS(DIFRFILE)
+17 QUIT
End DoDot:1
GOTO IXKEY
+18 SET DIFRGL=^DIC(DIFRFILE,0,"GL")
SET DIFRDIC=$PIECE(^DIC(DIFRFILE,0),U,1,2)
+19 SET $PIECE(DIFRDIC,"^",2)=@DIFRFIA@(DIFRFILE,0,0)
+20 IF DIFRFDD
IF +$GET(@DIFRFIA@(DIFRFILE,0,"VR"))
SET DIFRVR=^("VR")
Begin DoDot:1
+21 SET ^DD(DIFRFILE,0,"VR")=$PIECE(DIFRVR,"^")
+22 SET ^DD(DIFRFILE,0,"VRPK")=$PIECE(DIFRVR,"^",2)
+23 QUIT
End DoDot:1
+24 SET DIFRDATA=$DATA(@(DIFRGL_"0)"))
SET ^(0)=DIFRDIC_"^"_$SELECT(DIFRDATA#2:$PIECE(^(0),"^",3,9),1:"^")
+25 ;
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 ;process errors
+7 IF 'DIFRFDD
IF $DATA(@DIFRSA@("DIFRNI",DIFRFILE))
Begin DoDot:1
+8 NEW DIFRD
+9 SET DIFRD=0
+10 FOR
SET DIFRD=$ORDER(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD))
if DIFRD'>0
QUIT
Begin DoDot:2
+11 NEW DIFRERR
SET DIFRERR(1)=DIFRD
+12 ;"parent DD(s) missing"
DO BLD^DIALOG(9512,.DIFRERR)
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
K12(DIFRD) ;DIFRD WILL BE THERE FOR A PARTIAL UPDATE
NEW DD,D
SET DIFRD=+$GET(DIFRD)
+1 FOR DD=0:0
SET DD=$ORDER(@DIFRSA@("^DD",DIFRFILE,DD))
if 'DD
QUIT
IF DIFRD=DD!'DIFRD
Begin DoDot:1
+2 ;p23 Kill 'SCREEN' and Variable pointer nodes, because they may not be coming in
FOR D=0:0
SET D=$ORDER(@DIFRSA@("^DD",DIFRFILE,DD,D))
if 'D
QUIT
KILL ^DD(DD,D,12),^(12.1),^("V")
End DoDot:1
+3 QUIT
+4 ;
UP(ROOT,FILE,DDN) ;Return 1 if OK, or 0 for error p14
+1 ;top level file
if FILE=DDN
QUIT 1
+2 ;subDD already exists
if $DATA(^DD(DDN))
QUIT 1
+3 ;no parent in transport
if '$DATA(@ROOT@("UP",FILE,DDN))
QUIT 1
+4 NEW T
SET T=0
+5 DO UP1
+6 ;full subDD
IF $GET(@ROOT@("FIA",FILE,DDN))=0
QUIT T
+7 ;partial subDD, no subDD at site, no .01 field sent = error
IF T
IF '$DATA(@ROOT@("FIA",FILE,DDN,.01))
SET T=0
+8 QUIT T
+9 ;
UP1 ;p14
NEW MP,PARENT,X
+1 SET MP=0
SET X=""
+2 ;checks if parent exists or is in transport
+3 FOR
SET X=$ORDER(@ROOT@("UP",FILE,DDN,X))
if X=""
QUIT
SET PARENT=+^(X)
Begin DoDot:1
+4 ;***GFT
IF $DATA(^DD(PARENT))!$DATA(@ROOT@("FIA",FILE,PARENT))
if X>-2
SET T=1
QUIT
+5 SET MP=1
+6 QUIT
End DoDot:1
if T!(MP)
QUIT
+7 QUIT
+8 ;
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
