| 1 | DIFROMSS ;SCISC/DCL-DIFROM SERVER/DATA SORT LIST/SB-DD/HDR2P ;6/2/96 18:55
|
|---|
| 2 | ;;22.0;VA FileMan;;Mar 30, 1999
|
|---|
| 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 $D(^DD(+DIFRDD,0,"ID")) 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
|
|---|
