DIFROMSB ;SCISC/DCL-SILENT DIFROM/INSTALL BLOCKS ;08:35 AM 22 Nov 1994
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;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.
;
Q
BLKSIN(DIFRNAME,DIFRFLG,DIFRSA,DIFRMSGR) ;
;PACKAGE_NAME,FLAGS,SOURCE_ROOT,MSG_ROOT
;*
;PACKAGE_NAME=Package Name
; (Required if Source Root is not passed) - Identifies the
; unique key subscript in the transport structure.
;*
;FLAGS=O
; (Optional) - "O"=use Old calls (DIC)
;*
;SOURCE_ROOT=Source Array Root
; (Optional) - Closed array reference which contain all the
; Blocks that are to be installed.
; (Note) - Required if Package_Name is not passed.
;*
;MSG_ROOT=Closed Root for Error Messages
; (Optional) - Array where messages such as errors will be
; returned. If not passed, decendents of the ^TMP
; will be used.
;*
I $G(DIFRNAME)=""&($G(DIFRSA))="" D ERR("PACKAGE NAME/SOUCE ROOT") Q
N DIFRFILE,DIFRDA,DIFROLD,DIFRX,DIFRY,DIC,DA,DLAYGO,X,Y
S DIFRFILE=.404,DIFRDA=0
I $G(DIFRSA)="" S DIFRSA=$NA(^XTMP("XPDI",DIFRNAME,"KRN"))
S DIFROLD=$G(DIFRFLG)["O"
I DIFROLD S DLAYGO=DIFRFILE,DIC="^DIST(.404,",DIC(0)="LX" D Q
.F S DIFRDA=$O(@DIFRSA@(.404,DIFRDA)) Q:DIFRDA'>0 S DIFRX=^(DIFRDA,0) D
..S X=$P(DIFRX,"^"),DIFRFL=$P(DIFRX,"^",2)
..K DA
..D ^DIC
..I Y>0 S DIFRY=Y D DELADD Q
..N DIFRERR S DIFRERR(1)=$P(DIFRX,"^")
..D BLD^DIALOG(9517,.DIFRERR)
..Q
; CODE FOR NEW CALLS <<<***
G EXIT
Q
DELADD ;
K ^DIST(.404,+DIFRY),DA,DIK
M ^DIST(.404,+DIFRY)=@DIFRSA@(.404,DIFRDA)
S DIK="^DIST(.404,",DA=+DIFRY
D IX1^DIK
I '$D(DD(+DIFRFL)) D
.N DIFRERR S DIFRERR(1)=$P(DIFRX,"^"),DIFRERR(2)=DIFRFL
.D BLD^DIALOG(9518,.DIFRERR)
.Q
Q
;
ERR(X) S X(1)=X D BLD^DIALOG(202,.X)
Q
EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROMSB 2129 printed Apr 09, 2024@21:49:18 Page 2
DIFROMSB ;SCISC/DCL-SILENT DIFROM/INSTALL BLOCKS ;08:35 AM 22 Nov 1994
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+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 ;
+7 QUIT
BLKSIN(DIFRNAME,DIFRFLG,DIFRSA,DIFRMSGR) ;
+1 ;PACKAGE_NAME,FLAGS,SOURCE_ROOT,MSG_ROOT
+2 ;*
+3 ;PACKAGE_NAME=Package Name
+4 ; (Required if Source Root is not passed) - Identifies the
+5 ; unique key subscript in the transport structure.
+6 ;*
+7 ;FLAGS=O
+8 ; (Optional) - "O"=use Old calls (DIC)
+9 ;*
+10 ;SOURCE_ROOT=Source Array Root
+11 ; (Optional) - Closed array reference which contain all the
+12 ; Blocks that are to be installed.
+13 ; (Note) - Required if Package_Name is not passed.
+14 ;*
+15 ;MSG_ROOT=Closed Root for Error Messages
+16 ; (Optional) - Array where messages such as errors will be
+17 ; returned. If not passed, decendents of the ^TMP
+18 ; will be used.
+19 ;*
+20 IF $GET(DIFRNAME)=""&($GET(DIFRSA))=""
DO ERR("PACKAGE NAME/SOUCE ROOT")
QUIT
+21 NEW DIFRFILE,DIFRDA,DIFROLD,DIFRX,DIFRY,DIC,DA,DLAYGO,X,Y
+22 SET DIFRFILE=.404
SET DIFRDA=0
+23 IF $GET(DIFRSA)=""
SET DIFRSA=$NAME(^XTMP("XPDI",DIFRNAME,"KRN"))
+24 SET DIFROLD=$GET(DIFRFLG)["O"
+25 IF DIFROLD
SET DLAYGO=DIFRFILE
SET DIC="^DIST(.404,"
SET DIC(0)="LX"
Begin DoDot:1
+26 FOR
SET DIFRDA=$ORDER(@DIFRSA@(.404,DIFRDA))
if DIFRDA'>0
QUIT
SET DIFRX=^(DIFRDA,0)
Begin DoDot:2
+27 SET X=$PIECE(DIFRX,"^")
SET DIFRFL=$PIECE(DIFRX,"^",2)
+28 KILL DA
+29 DO ^DIC
+30 IF Y>0
SET DIFRY=Y
DO DELADD
QUIT
+31 NEW DIFRERR
SET DIFRERR(1)=$PIECE(DIFRX,"^")
+32 DO BLD^DIALOG(9517,.DIFRERR)
+33 QUIT
End DoDot:2
End DoDot:1
QUIT
+34 ; CODE FOR NEW CALLS <<<***
+35 GOTO EXIT
+36 QUIT
DELADD ;
+1 KILL ^DIST(.404,+DIFRY),DA,DIK
+2 MERGE ^DIST(.404,+DIFRY)=@DIFRSA@(.404,DIFRDA)
+3 SET DIK="^DIST(.404,"
SET DA=+DIFRY
+4 DO IX1^DIK
+5 IF '$DATA(DD(+DIFRFL))
Begin DoDot:1
+6 NEW DIFRERR
SET DIFRERR(1)=$PIECE(DIFRX,"^")
SET DIFRERR(2)=DIFRFL
+7 DO BLD^DIALOG(9518,.DIFRERR)
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
ERR(X) SET X(1)=X
DO BLD^DIALOG(202,.X)
+1 QUIT
EXIT IF $GET(DIFRMSGR)]""
DO CALLOUT^DIEFU(DIFRMSGR)
+1 QUIT
