Return to DIFROMSF.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DIFROMSF	;SCISC/DCL-SILENT DIFROM EXTENDED DATABASE FILES;08:41 AM  22 Nov 1994;
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: 	Q
    5: 	;
    6: 	; * EXTENDED DATABASE ELEMENTS (EDE) *
    7: EDEOUT(DIFRIEN,DIFRNAME,DIFRFLG,DIFRFIA,DIFRTA,DIFRLST,DIFRMSGR)	;
    8: 	;ENTRY,PKGNAME,FLAGS,FIA_ARRAY,TARGET_ARRAY,LIST_ARRAY,MSG_ROOT
    9: 	I $G(DIFRNAME)']"" D ERR("PACKAGE NAME") Q
   10: 	N DIFRFILE
   11: 	S DIFRFILE=$S(DIFRFLG="F":.403,DIFRFLG="I":.402,DIFRFLG="P":.4,DIFRFLG="S":.401,DIFRFLG="$":.5,1:"")
   12: 	I DIFRFILE'>0 D ERR("FLAG") Q
   13: 	I $G(DIFRTA)="" S DIFRTA=$NA(^XTMP("XPDT",DIFRNAME,"KRN"))
   14: 	;
   15: 	;              >*>*>*> c h e c k   h e r e <*<*<*<
   16: 	;
   17: 	S DIFRFIA=$G(DIFRFIA) S:DIFRFIA="" DIFRFIA=$NA(@DIFRTA@("FIA"))
   18: 	I $G(DIFRIEN)'>0&($G(DIFRLST)="") D ERR("NO IENs PASSED") Q
   19: 	I $G(DIFRIEN)'>0,$D(@DIFRLST)'>9 D ERR("LIST DOES NOT CONTAIN IENs") Q
   20: 	D EDEOUT^DIFROMS5
   21: 	G EXIT
   22: 	;
   23: EDEIN	; * EXTENDED DATABASE ELEMENTS *
   24: 	Q
   25: FPRE(DIFRFILE,DIFRNAME,DIFRSA)	; FILE-PRE
   26: 	K ^TMP("DIFROMS",$J)
   27: 	;FILENUMBER,SUBSCRIPT_NAME(package name for KIDS),SOURCE_ARRAY
   28: 	S DIFRFILE=$G(DIFRFILE) S:DIFRFILE'>0 DIFRFILE=$G(XPDFIL)
   29: 	I DIFRFILE'>0 D ERR("FILE NUMBER") Q
   30: 	Q:DIFRFILE'=.403
   31: 	I $G(DIFRNAME)="" D ERR("SUBSCRIPT NAME") Q
   32: 	I $G(DIFRSA)="" S DIFRSA=$NA(^XTMP("XPDT",DIFRNAME,"KRN"))
   33: 	I DIFRFILE=.403 D  Q  ;If Forms bring in Blocks
   34: 	.N DIC,DIFRR,DIFRFILE,DIFRL,DIFRX,X,Y
   35: 	.S DIC="^DIST(.404,",DIC(0)="LX",DLAYGO=.404,DIFRFILE=.404
   36: 	.S DIFRR=0
   37: 	.F  S DIFRR=$O(@DIFRSA@(DIFRFILE,DIFRR)) Q:DIFRR'>0  S DIFRX=^(DIFRR,0) D
   38: 	..S DIFRL=$P(DIFRX,"^",2)
   39: 	..S X=$P(DIFRX,"^")
   40: 	..K DA
   41: 	..D ^DIC
   42: 	..I Y'>0 D ERR("UNABLE TO ADD "_$P(DIFRX,"^")_" BLOCK") Q
   43: 	..K ^DIST(.404,+Y)
   44: 	..I '$D(^DD(+DIFRL)) D ERR("BLOCK: "_$P(DIFRX,"^")_" installed but associated file "_DIFRL_" missing")
   45: 	..M ^DIST(.404,+Y)=@DIFRSA@(DIFRFILE,DIFRR)
   46: 	..S DIK=DIC,DA=+Y
   47: 	..D IX1^DIK
   48: 	..Q
   49: 	.Q
   50: 	Q
   51: 	;
   52: EPRE(DIFRFILE,DIFRIEN,DIFROIEN,DIFRNAME,DIFRSA)	; ENTRY-PRE
   53: 	;FILENUM,NEW_ENTRY_NUM,OLD_ENTRY_NUM,PKG/SUBSCRIPT_NAME,SOURCE_ARRAY
   54: 	; Entry Pre - delete template on target system
   55: 	N DIFRRDA,DIFRX,DIFRF
   56: 	S DIFRFILE=$G(DIFRFILE) S:DIFRFILE'>0 DIFRFILE=$G(XPDFIL)
   57: 	I DIFRFILE'>0 D ERR("FILE NUMBER") Q
   58: 	S DIFRIEN=$G(DIFRIEN) S:DIFRIEN'>0 DIFRIEN=$G(DA)
   59: 	I DIFRIEN'>0 D ERR("ENTRY NUMBER") Q
   60: 	S DIFROIEN=$G(DIFROIEN) S:DIFROIEN'>0 DIFROIEN=$G(OLDA)
   61: 	I DIFRIEN'>0 D ERR("OLD ENTRY NUMBER") Q
   62: 	I $G(DIFRNAME)="" D ERR("PACKAGE/SUBSCRIPT NAME MISSING") Q  ;GET VARIABLE FROM RON
   63: 	I $G(DIFRSA)="" S DIFRSA=$NA(^XTMP("XPDT",DIFRNAME,"KRN"))
   64: 	; build file root with entry number and kill entry on target system
   65: 	S DIFRRDA=$$CREF^DIQGU($$ROOT^DIQGU(DIFRFILE)_DIFRIEN)
   66: 	S DIFRX=$P(@DIFRRDA@(0),"^")
   67: 	S DIFRF=$S(DIFRFILE=.4:"DIPT",DIFRFILE=.402:"DIE",DIFRFILE=.401:"DIBT",DIFRFILE=.403:"DIST(.403,",DIFRFILE=.404:"DIST(.404,",1:"FUN")
   68: 	S ^TMP("DIFROMS",$J,DIFRF,DIFRX)=DIFRIEN
   69: 	K @DIFRRDA
   70: 	I DIFRFILE=.403 D  ;If Forms resolve Block Pointers
   71: 	.N DIFRA0,DIFRA1,DIFRA2,DIFRJ,DIFRL,DIFRP,DIFRX,DIFRY
   72: 	.S DIFRJ=0
   73: 	.F  S DIFRJ=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ)) Q:'DIFRJ  I $D(^(DIFRJ,0)) S DIFRP=$P(^(0),"^",2) D
   74: 	..S:DIFRP]"" DIFRP=$O(^DIST(.404,"B",DIFRP,0))
   75: 	..S:DIFRP $P(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,0),"^",2)=DIFRP
   76: 	..S DIFRL=0
   77: 	..F  S DIFRL=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL)) Q:'DIFRL  S DIFRA0=$G(^(DIFRL,0)),DIFRP=$P(DIFRA0,"^") I DIFRP]"" D
   78: 	...S DIFRP=$O(^DIST(.404,"B",DIFRP,0)) I DIFRP D
   79: 	....S $P(DIFRA0,"^")=DIFRP,@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRP,0)=DIFRA0
   80: 	....Q
   81: 	...Q
   82: 	..S DIFRA0=$G(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,0))
   83: 	..Q:DIFRA0=""
   84: 	..K @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40)
   85: 	..S (DIFRA1,DIFRA2)=0
   86: 	..S DIFRL=0
   87: 	..F  S DIFRL=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRL)) Q:'DIFRL  S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL,0)=^(DIFRL,0),DIFRA1=DIFRL,DIFRA2=DIFRA2+1
   88: 	..S $P(DIFRA0,"^",3,4)=DIFRA1_"^"_DIFRA2
   89: 	..S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,0)=DIFRA0
   90: 	..K @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK")
   91: 	..Q
   92: 	.Q
   93: 	Q
   94: EPOST	; ENTRY-POST
   95: 	Q
   96: FPOST	; FILE-POST      RECOMPILE TEMPLATES
   97: 	N DIFR,DIFR1,DIFR2,DMAX,X,Y
   98: 	K DIC,DLAYGO
   99: 	F DIFR="DIE","DIPT" D
  100: 	.I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII
  101: 	.E  S DISYS=^DD("OS")
  102: 	.Q:'$D(^DD("OS",DISYS,"ZS"))
  103: 	.S DIFR1=""
  104: DZ1	.S DIFR1=$O(^TMP("DIFROMS",$J,DIFR,DIFR1)) Q:DIFR1=""
  105: 	.F DIFR2=0:0 S DIFR2=$O(^TMP("DIFROMS",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2  D
  106: 	..S Y=DIFR2
  107: 	..I $D(@("^"_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD") D
  108: 	...S DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z")
  109: 	...Q
  110: 	..Q
  111: 	.G DZ1
  112: 	K ^TMP("DIFROMS",$J)
  113: 	Q
  114: INITCHK	; check
  115: 	;
  116: 	;
  117: 	I '$D(DIQUIET) N DIQUIET S DIQUIET=1
  118: 	I '$D(DIFM) N DIFM S DIFM=1
  119: 	I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
  120: 	Q
  121: 	;
  122: ERR(X)	S X(1)=X D BLD^DIALOG(1700,.X)
  123: EXIT	I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR)
  124: 	Q