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