Annotation of freem_fileman/DIFROMSF.m, revision 1.1.1.1
1.1 snw 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
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to DIFROMSF.m CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem_fileman