Return to DIFROMSU.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DIFROMSU	;SCISC/DCL-DIFROM SERVER BUILD "FIA" SUBSCRIPTS IN TRANSPORT ARRAY;03:24 PM  14 Sep 1994
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: FIA(DIFRFILE,DIFRFLG,DIFRPFL,DIFRTAR,DIFR222,DIFR223,DIFRDSCR,DIFRVER,DIFRMSGR)	;
    5: 	;FILE,FLAGS,PARTIAL_FILE_LIST,TARGET_ARRAY_ROOT,ANSWERS,DD_SCREEN,DATA_SCREEN,VERSION,MSG_ARRAY
    6: 	I '$D(DIQUIET) N DIQUIET S DIQUIET=1
    7: 	I '$D(DIFM) N DIFM S DIFM=1
    8: 	I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
    9: 	N DIFRFD,DIFRFE,DIFRX,FIELD,FIELDNR,DIFRTA,DIFRP,DIFR00
   10: 	S DIFRTA=$NA(@DIFRTAR@("FIA"))
   11: 	I $G(DIFRFILE)'>0 D BLD^DIALOG(9542) Q
   12: 	I '$D(^DIC(DIFRFILE)) D BLD^DIALOG(9539,DIFRFILE) Q
   13: 	I $P($G(DIFR222),"^",3)'="p" G F
   14: 	I $G(DIFRPFL)']"" G F
   15: 	I $D(@DIFRPFL)'>9 G F
   16: 	G F:$O(@DIFRPFL@(0))'>0
   17: 	N DIFRDDC,DIFRFLDC,DIFRTMP
   18: 	K ^TMP("FIA",$J)
   19: 	S DIFRDDC=0,DIFRTMP=$NA(^TMP("FIA",$J))
   20: 	M @DIFRTMP=@DIFRPFL
   21: 	F  S DIFRDDC=$O(@DIFRTMP@(DIFRFILE,DIFRDDC)) Q:DIFRDDC'>0  D
   22: 	.I '$D(^DD(DIFRDDC)) K @DIFRTMP@(DIFRFILE,DIFRDDC) D BLD^DIALOG(9540,DIFRDDC) Q
   23: 	.I '$O(@DIFRTMP@(DIFRFILE,DIFRDDC,0)) D  Q
   24: 	..Q:@DIFRTMP@(DIFRFILE,DIFRDDC)="SUB"
   25: 	..D SB^DIFROMSS(DIFRDDC,"W",$NA(@DIFRTMP@(DIFRFILE)),"SUB")
   26: 	..Q
   27: 	.S DIFRFLDC=0
   28: 	.F  S DIFRFLDC=$O(@DIFRTMP@(DIFRFILE,DIFRDDC,DIFRFLDC)) Q:DIFRFLDC'>0  D
   29: 	..I '$D(^DD(DIFRDDC,DIFRFLDC,0)) K @DIFRTMP@(DIFRFILE,DIFRDDC,DIFRFLDC) D  Q
   30: 	...N DIFRX S DIFRX(1)=DIFRFLDC,DIFRX(2)=DIFRDDC
   31: 	...D BLD^DIALOG(9541,.DIFRX)
   32: 	...Q
   33: 	..I $P(^DD(DIFRDDC,DIFRFLDC,0),"^",2) S DIFRX=$P(^DD(+$P(^(0),"^",2),.01,0),"^",2) D
   34: 	...I DIFRX["W" S @DIFRTMP@(DIFRFILE,+$P(^DD(DIFRDDC,DIFRFLDC,0),"^",2))=0 Q
   35: 	...K @DIFRTMP@(DIFRFILE,DIFRDDC,DIFRFLDC)
   36: 	...Q
   37: 	..Q
   38: 	.Q
   39: 	;
   40: 	M @DIFRTA@(DIFRFILE)=@DIFRTMP@(DIFRFILE)
   41: 	K @DIFRTMP
   42: 	;
   43: 	I $D(@DIFRTA@(DIFRFILE,DIFRFILE))=1 G F
   44: 	S @DIFRTA@(DIFRFILE,DIFRFILE)=1,DIFRFE=DIFRFILE
   45: 	;F  S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0  S:$P(^DD(DIFRFE,.01,0),"^",2)'["W" @DIFRTA@(DIFRFILE,DIFRFE,.01)=0
   46: 	F  S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0  D
   47: 	.S @DIFRTA@(DIFRFILE,DIFRFE)=$D(@DIFRTA@(DIFRFILE,DIFRFE))>9
   48: 	.N DIFRX,DIFRY
   49: 	.S DIFRY=$$UP^DIQGU(DIFRFE,.DIFRX)
   50: 	.Q:'$D(DIFRX)!(+$G(DIFRX(-1))=DIFRFILE)
   51: 	.K DIFRX($O(DIFRX("")))
   52: 	.M @DIFRTAR@("UP",DIFRFILE,DIFRFE)=DIFRX
   53: 	.Q
   54: 	S DIFRFE=DIFRFILE
   55: 	F  S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0  D:'^(DIFRFE)!($D(@DIFRTA@(DIFRFILE,DIFRFE,.01)))
   56: 	.Q:'$D(^DD(DIFRFE,0,"UP"))
   57: 	.N DIFRUP,DIFRFLD
   58: 	.S DIFRUP=^DD(DIFRFE,0,"UP"),DIFRFLD=$O(^DD(DIFRUP,"SB",DIFRFE,0))
   59: 	.Q:$G(@DIFRTA@(DIFRFILE,DIFRUP))=0!($D(@DIFRTA@(DIFRFILE,DIFRUP,DIFRFLD)))
   60: 	.S @DIFRTA@(DIFRFILE,DIFRUP,DIFRFLD)=""
   61: 	.Q:$D(@DIFRTA@(DIFRFILE,DIFRUP))#2
   62: 	.S @DIFRTA@(DIFRFILE,DIFRUP)=1
   63: 	.Q
   64: 	;
   65: 	G G
   66: F	S @DIFRTA@(DIFRFILE,DIFRFILE)=0,DIFRFE=0
   67: 	S:$P(DIFR222,"^",3)'="f" $P(DIFR222,"^",3)="f"
   68: E	F  S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0  D
   69: 	.S DIFRFD=0
   70: 	.F  S DIFRFD=$O(^DD(DIFRFE,"SB",DIFRFD)) Q:DIFRFD'>0  S @DIFRTA@(DIFRFILE,DIFRFD)=0
   71: 	.Q
   72: G	S @DIFRTA@(DIFRFILE)=$P(^DIC(DIFRFILE,0),"^")
   73: 	S (DIFR00,@DIFRTA@(DIFRFILE,0))=^DIC(DIFRFILE,0,"GL")
   74: 	S @DIFRTA@(DIFRFILE,0,0)=$P(@(DIFR00_"0)"),"^",2)
   75: 	S @DIFRTA@(DIFRFILE,0,1)=$G(DIFR222)
   76: 	S @DIFRTA@(DIFRFILE,0,10)=$G(DIFR223)
   77: 	S @DIFRTA@(DIFRFILE,0,11)=$G(DIFRDSCR)
   78: 	S @DIFRTA@(DIFRFILE,0,"RLRO")=$$ROOT($P(DIFR222,"^",6))
   79: 	I $G(DIFRVER)]"" S @DIFRTA@(DIFRFILE,0,"VR")=DIFRVER
   80: FE	I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR)
   81: 	Q
   82: 	;
   83: ERR501(DIFRFILE,DIFRFLD)	;  501 Errors
   84: 	N DIFRERRX
   85: 	S DIFRERRX("FILE")=DIFRFILE,DIFRERRX(1)=DIFRFLD
   86: 	D BLD^DIALOG(501,.DIFRERRX)
   87: 	Q
   88: ROOT(IEN)	;Create root from DIBT(ien
   89: 	;
   90: 	I $G(IEN)>0,$D(^DIBT(IEN,1))>9 Q "^DIBT("_IEN_",1)"
   91: 	I $G(IEN)]"" S IEN=$O(^DIBT("B",IEN,"")) Q:IEN>0 $$ROOT(IEN)
   92: 	Q ""