- 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 Feb 19, 2025@00:14:28 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