Return to DIFROMSS.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DIFROMSS	;SCISC/DCL-DIFROM SERVER/DATA SORT LIST/SB-DD/HDR2P ;11:05 AM  15 Sep 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: SEL(DIFRFILE,DIFRX)	;Extrinsic function to return resolved value for
    6: 	;freetext pointer
    7: 	;FILE,X-VALUE
    8: 	N D,DIC,DIE,DIX,DIY,DO,DS,X,Y
    9: 	N %,%K,%Y,DA,D0,D1,D2,D3
   10: 	S DIC="^DIBT(",DIC(0)="QEMZ",X=DIFRX
   11: 	S DIC("S")="I $P(^(0),U,4)=DIFRFILE,$D(^(1))>9"
   12: 	D ^DIC
   13: 	Q:Y'>0 ""
   14: 	Q Y(0,0)
   15: 	;
   16: HELP(DIFRFILE)	;
   17: 	N D,DIC,DIE,DIX,DIY,DO,DS,X,Y
   18: 	N %,%K,%Y,DA,D0,D1,D2,D3
   19: 	S DIC="^DIBT(",DIC(0)="M",DIC("S")="I $P(^(0),U,4)=DIFRFILE,$D(^(1))>9",X="??"
   20: 	D ^DIC
   21: 	Q
   22: 	;
   23: SB(DIFRDD,DIFRFLG,DIFRTA,DIFRVAL)	;Returns a list of sub-DDs for any DD#
   24: 	;DD#,FLAGS,TARGET ARRAY(by value)
   25: 	;DD/SUB DD NUMBER (required)
   26: 	;FLAGS "W"=Include Word-processing fields (optional)
   27: 	;TARGET ARRAY (required)
   28: 	;DIFRVAL - SET TARGET ARRAY EQUAL TO
   29: 	N DIFRSDD,DIFRSSDD,DIFRNW
   30: 	S DIFRSDD=0,DIFRNW=$G(DIFRFLG)'["W",DIFRVAL=$G(DIFRVAL)
   31: 	F  S DIFRSDD=$O(^DD(DIFRDD,"SB",DIFRSDD)) Q:DIFRSDD'>0  D
   32: 	.S DIFRSSDD=0
   33: 	.I DIFRNW,$P($G(^DD(DIFRSDD,.01,0)),"^",2)["W" Q
   34: 	.S @DIFRTA@(DIFRSDD)=DIFRVAL,DIFRSSDD=$O(^DD(DIFRSDD,"SB",0))
   35: 	.I DIFRSSDD D SB(DIFRSDD,$G(DIFRFLG),DIFRTA,DIFRVAL)
   36: 	.Q
   37: 	Q
   38: 	;
   39: HDR2P(DIFRDD)	;Header Node/2nd piece update
   40: 	Q:$G(DIFRDD)'>0 ""
   41: 	Q:'$D(^DIC(+DIFRDD,0,"GL")) "" S DIFRDD=$TR(DIFRDD_$P($P(@(^("GL")_"0)"),"^",2),+DIFRDD,2),"DPSVIs")
   42: 	N DIFRDDT
   43: 	I $O(^DD(+DIFRDD,0,"ID",0)) S DIFRDD=DIFRDD_"I"
   44: 	I $D(^DD(+DIFRDD,0,"SCR")) S DIFRDD=DIFRDD_"s"
   45: 	F DIFRDDT="D","P","S","V" I $P(^DD(+DIFRDD,.01,0),"^",2)[DIFRDDT S DIFRDD=DIFRDD_DIFRDDT Q
   46: 	Q DIFRDD
   47: 	;
   48: EXAM(TA)	;Examine what's in 2nd piece of data Header and put into array sub
   49: 	;TA=Target Array
   50: 	Q:$G(TA)']""
   51: 	N FN,GR,P2
   52: 	S FN=0
   53: 	F  S FN=$O(^DIC(FN)) Q:FN'>0  I $D(^DIC(FN,0,"GL")) S GR=^("GL") D
   54: 	.Q:'$D(@(GR_"0)"))  S P2=$P(^(0),"^",2),P2=$P(P2,+P2,2)
   55: 	.S:P2]"" @TA@(P2)=FN
   56: 	.Q
   57: 	Q
   58: 	;
   59: VAL(DIFRFILE,DIFRIEN)	;Validate Edit and Print Template's and also Forms
   60: 	S DIFRFILE=$G(DIFRFILE),DIFRIEN=$G(DIFRIEN)
   61: 	Q:DIFRIEN'>0 0
   62: 	N ROOT,PIECE,FILE
   63: 	D
   64: 	.N X
   65: 	.S X=DIFRFILE
   66: 	.I X=.4!(X=.402)!(X=.403)!(X=.404) Q
   67: 	.S DIFRFILE=0
   68: 	.Q
   69: 	Q:DIFRFILE'>0 0
   70: 	S ROOT="^"_$P($P(".4;DIPT^.402;DIE^.403;DIST(.403)^.404;DIST(.404)",DIFRFILE_";",2),"^")
   71: 	S PIECE=$P($P(".4;4^.402;4^.403;8^.404;2",DIFRFILE_";",2),"^")
   72: 	Q:'$D(@ROOT@(DIFRIEN,0)) 0
   73: 	S FILE=$P(^(0),"^",PIECE)
   74: 	I DIFRFILE=.404&('FILE) Q 1
   75: 	Q:FILE'>0 0
   76: 	I DIFRFILE=.403 N BLOCK D  Q:'BLOCK 0
   77: 	.N PAGE,BLOCKP
   78: 	.S PAGE=0,BLOCK=1
   79: 	.F  S PAGE=$O(@ROOT@(DIFRIEN,40,PAGE)) Q:PAGE'>0  S BLOCKP=$P($G(^(PAGE,0)),"^",2) S:BLOCKP BLOCK=$$VAL(.404,BLOCKP) Q:'BLOCK  D  Q:'BLOCK
   80: 	..N M40
   81: 	..S M40=0
   82: 	..F  S M40=$O(@ROOT@(DIFRIEN,40,PAGE,40,M40)) Q:M40'>0  S BLOCK=$$VAL(.404,M40) Q:'BLOCK
   83: 	..Q
   84: 	.Q
   85: 	I DIFRFILE=.4,$P(@ROOT@(DIFRIEN,0),"^",8) Q 0
   86: 	Q $D(^DD(FILE,0))#2