source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIFROMSS.m@ 1710

Last change on this file since 1710 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.7 KB
RevLine 
[613]1DIFROMSS ;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
5SEL(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 ;
16HELP(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 ;
23SB(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 ;
39HDR2P(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 ;
48EXAM(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 ;
59VAL(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
Note: See TracBrowser for help on using the repository browser.