Annotation of freem_fileman/DIFROMSF.m, revision 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