Return to DIFROMSF.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

DIFROMSF	;SCISC/DCL-SILENT DIFROM EXTENDED DATABASE FILES;08:41 AM  22 Nov 1994;
	;;21.0;VA FileMan;;Dec 28, 1994
	;Per VHA Directive 10-93-142, this routine should not be modified.
	Q
	;
	; * EXTENDED DATABASE ELEMENTS (EDE) *
EDEOUT(DIFRIEN,DIFRNAME,DIFRFLG,DIFRFIA,DIFRTA,DIFRLST,DIFRMSGR)	;
	;ENTRY,PKGNAME,FLAGS,FIA_ARRAY,TARGET_ARRAY,LIST_ARRAY,MSG_ROOT
	I $G(DIFRNAME)']"" D ERR("PACKAGE NAME") Q
	N DIFRFILE
	S DIFRFILE=$S(DIFRFLG="F":.403,DIFRFLG="I":.402,DIFRFLG="P":.4,DIFRFLG="S":.401,DIFRFLG="$":.5,1:"")
	I DIFRFILE'>0 D ERR("FLAG") Q
	I $G(DIFRTA)="" S DIFRTA=$NA(^XTMP("XPDT",DIFRNAME,"KRN"))
	;
	;              >*>*>*> c h e c k   h e r e <*<*<*<
	;
	S DIFRFIA=$G(DIFRFIA) S:DIFRFIA="" DIFRFIA=$NA(@DIFRTA@("FIA"))
	I $G(DIFRIEN)'>0&($G(DIFRLST)="") D ERR("NO IENs PASSED") Q
	I $G(DIFRIEN)'>0,$D(@DIFRLST)'>9 D ERR("LIST DOES NOT CONTAIN IENs") Q
	D EDEOUT^DIFROMS5
	G EXIT
	;
EDEIN	; * EXTENDED DATABASE ELEMENTS *
	Q
FPRE(DIFRFILE,DIFRNAME,DIFRSA)	; FILE-PRE
	K ^TMP("DIFROMS",$J)
	;FILENUMBER,SUBSCRIPT_NAME(package name for KIDS),SOURCE_ARRAY
	S DIFRFILE=$G(DIFRFILE) S:DIFRFILE'>0 DIFRFILE=$G(XPDFIL)
	I DIFRFILE'>0 D ERR("FILE NUMBER") Q
	Q:DIFRFILE'=.403
	I $G(DIFRNAME)="" D ERR("SUBSCRIPT NAME") Q
	I $G(DIFRSA)="" S DIFRSA=$NA(^XTMP("XPDT",DIFRNAME,"KRN"))
	I DIFRFILE=.403 D  Q  ;If Forms bring in Blocks
	.N DIC,DIFRR,DIFRFILE,DIFRL,DIFRX,X,Y
	.S DIC="^DIST(.404,",DIC(0)="LX",DLAYGO=.404,DIFRFILE=.404
	.S DIFRR=0
	.F  S DIFRR=$O(@DIFRSA@(DIFRFILE,DIFRR)) Q:DIFRR'>0  S DIFRX=^(DIFRR,0) D
	..S DIFRL=$P(DIFRX,"^",2)
	..S X=$P(DIFRX,"^")
	..K DA
	..D ^DIC
	..I Y'>0 D ERR("UNABLE TO ADD "_$P(DIFRX,"^")_" BLOCK") Q
	..K ^DIST(.404,+Y)
	..I '$D(^DD(+DIFRL)) D ERR("BLOCK: "_$P(DIFRX,"^")_" installed but associated file "_DIFRL_" missing")
	..M ^DIST(.404,+Y)=@DIFRSA@(DIFRFILE,DIFRR)
	..S DIK=DIC,DA=+Y
	..D IX1^DIK
	..Q
	.Q
	Q
	;
EPRE(DIFRFILE,DIFRIEN,DIFROIEN,DIFRNAME,DIFRSA)	; ENTRY-PRE
	;FILENUM,NEW_ENTRY_NUM,OLD_ENTRY_NUM,PKG/SUBSCRIPT_NAME,SOURCE_ARRAY
	; Entry Pre - delete template on target system
	N DIFRRDA,DIFRX,DIFRF
	S DIFRFILE=$G(DIFRFILE) S:DIFRFILE'>0 DIFRFILE=$G(XPDFIL)
	I DIFRFILE'>0 D ERR("FILE NUMBER") Q
	S DIFRIEN=$G(DIFRIEN) S:DIFRIEN'>0 DIFRIEN=$G(DA)
	I DIFRIEN'>0 D ERR("ENTRY NUMBER") Q
	S DIFROIEN=$G(DIFROIEN) S:DIFROIEN'>0 DIFROIEN=$G(OLDA)
	I DIFRIEN'>0 D ERR("OLD ENTRY NUMBER") Q
	I $G(DIFRNAME)="" D ERR("PACKAGE/SUBSCRIPT NAME MISSING") Q  ;GET VARIABLE FROM RON
	I $G(DIFRSA)="" S DIFRSA=$NA(^XTMP("XPDT",DIFRNAME,"KRN"))
	; build file root with entry number and kill entry on target system
	S DIFRRDA=$$CREF^DIQGU($$ROOT^DIQGU(DIFRFILE)_DIFRIEN)
	S DIFRX=$P(@DIFRRDA@(0),"^")
	S DIFRF=$S(DIFRFILE=.4:"DIPT",DIFRFILE=.402:"DIE",DIFRFILE=.401:"DIBT",DIFRFILE=.403:"DIST(.403,",DIFRFILE=.404:"DIST(.404,",1:"FUN")
	S ^TMP("DIFROMS",$J,DIFRF,DIFRX)=DIFRIEN
	K @DIFRRDA
	I DIFRFILE=.403 D  ;If Forms resolve Block Pointers
	.N DIFRA0,DIFRA1,DIFRA2,DIFRJ,DIFRL,DIFRP,DIFRX,DIFRY
	.S DIFRJ=0
	.F  S DIFRJ=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ)) Q:'DIFRJ  I $D(^(DIFRJ,0)) S DIFRP=$P(^(0),"^",2) D
	..S:DIFRP]"" DIFRP=$O(^DIST(.404,"B",DIFRP,0))
	..S:DIFRP $P(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,0),"^",2)=DIFRP
	..S DIFRL=0
	..F  S DIFRL=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL)) Q:'DIFRL  S DIFRA0=$G(^(DIFRL,0)),DIFRP=$P(DIFRA0,"^") I DIFRP]"" D
	...S DIFRP=$O(^DIST(.404,"B",DIFRP,0)) I DIFRP D
	....S $P(DIFRA0,"^")=DIFRP,@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRP,0)=DIFRA0
	....Q
	...Q
	..S DIFRA0=$G(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,0))
	..Q:DIFRA0=""
	..K @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40)
	..S (DIFRA1,DIFRA2)=0
	..S DIFRL=0
	..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
	..S $P(DIFRA0,"^",3,4)=DIFRA1_"^"_DIFRA2
	..S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,0)=DIFRA0
	..K @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK")
	..Q
	.Q
	Q
EPOST	; ENTRY-POST
	Q
FPOST	; FILE-POST      RECOMPILE TEMPLATES
	N DIFR,DIFR1,DIFR2,DMAX,X,Y
	K DIC,DLAYGO
	F DIFR="DIE","DIPT" D
	.I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII
	.E  S DISYS=^DD("OS")
	.Q:'$D(^DD("OS",DISYS,"ZS"))
	.S DIFR1=""
DZ1	.S DIFR1=$O(^TMP("DIFROMS",$J,DIFR,DIFR1)) Q:DIFR1=""
	.F DIFR2=0:0 S DIFR2=$O(^TMP("DIFROMS",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2  D
	..S Y=DIFR2
	..I $D(@("^"_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD") D
	...S DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z")
	...Q
	..Q
	.G DZ1
	K ^TMP("DIFROMS",$J)
	Q
INITCHK	; check
	;
	;
	I '$D(DIQUIET) N DIQUIET S DIQUIET=1
	I '$D(DIFM) N DIFM S DIFM=1
	I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
	Q
	;
ERR(X)	S X(1)=X D BLD^DIALOG(1700,.X)
EXIT	I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR)
	Q