Annotation of freem_fileman/DDS11.m, revision 1.1.1.1
1.1 snw 1: DDS11(DDSBK,DDSNFO) ;SFISC/MLH,MKO-LOAD DATA ;08:46 AM 24 Oct 1994
2: ;;21.0;VA FileMan;;Dec 28, 1994
3: ;Per VHA Directive 10-93-142, this routine should not be modified.
4: ;Input variables:
5: ; DDSBK = Block #
6: ; DDSPG = Page # (needed for form-only fields)
7: ; DDSREFT = Temporary global location
8: ; DDP = File number of block
9: ; DIE = Global root of block
10: ; DDSDA = DA,DA(1),...
11: ; DDSNFO = Flag means don't reload form only fields
12: ;
13: N X,Y
14: S DDS1REFD=$NA(@DDSREFT@("F"_DDP,DDSDA))
15: ;
16: S DDS1FO=0
17: F S DDS1FO=$O(^DIST(.404,DDSBK,40,DDS1FO)) Q:'DDS1FO D LD
18: ;
19: I DDP,DDSDA S @DDS1REFD@("GL")=DIE
20: ;
21: K DDS1REFD,DDS1FLD,DDS1FO,DDS1LN,DDS1ND,DDS1PC,DDS1DV
22: K DDS1D1,DDS1D2,DDS1D3
23: Q
24: ;
25: LD ;Load data for a field
26: ;
27: ;Get form only fields
28: I $P($G(^DIST(.404,DDSBK,40,DDS1FO,0)),U,3)=2,$P($G(^(20)),U)]"" D Q
29: . Q:$G(DDSNFO)
30: . N DDP
31: . S DDP=0,DDS1FLD=DDS1FO_","_DDSBK
32: . Q:"^1^3^"[(U_$G(@DDSREFT@("F0",DDSDA,DDS1FLD,"F"))_U)
33: . S Y=""
34: . I $D(@DDSREFT@("F0",DDSDA,DDS1FLD,"F"))[0,$G(^DIST(.404,DDSBK,40,DDS1FO,3))]"" D DEF(^(3),$G(^(3.1)))
35: . S (@DDSREFT@("F0",DDSDA,DDS1FLD,"D"),^("O"))=Y
36: ;
37: ;Get DD fields
38: S DDS1FLD=$G(^DIST(.404,DDSBK,40,DDS1FO,1)) Q:DDS1FLD?."^"
39: Q:"^1^3^"[(U_$G(@DDS1REFD@(DDS1FLD,"F"))_U)
40: ;
41: S DDS1LN=$G(^DD(DDP,DDS1FLD,0)) Q:DDS1LN?."^"
42: S DDS1PC=$P(DDS1LN,U,4),DDS1ND=$P(DDS1PC,";"),DDS1PC=$P(DDS1PC,";",2)
43: S DDS1DV=$P(DDS1LN,U,2),X=$P(DDS1LN,U,3)
44: ;
45: D @($S(DDS1FLD=.001:"L3",DDS1PC=0:"L2",1:"L1"))
46: ;
47: I DDS1DV["O"!(DDS1DV["P")!(DDS1DV["V")!(DDS1DV["D")!(DDS1DV["S") D
48: . Q:$D(@DDS1REFD@(DDS1FLD,"X"))
49: . D:Y]"" XFORM
50: . S @DDS1REFD@(DDS1FLD,"X")=Y
51: ;
52: I DDS1PC=0,DDS1DV,DDS1DV'["W",$D(@DDS1REFD@(DDS1FLD,"X"))[0 S ^("X")=Y
53: Q
54: ;
55: L1 ;Get non-multiple field
56: S DDS1LN=$G(@(DIE_"DA,DDS1ND)"))
57: I $E(DDS1PC)'="E" S Y=$P(DDS1LN,U,DDS1PC)
58: E S Y=$E(DDS1LN,+$E(DDS1PC,2,999),$P(DDS1PC,",",2)) S:Y?." " Y=""
59: ;
60: K @DDS1REFD@(DDS1FLD,"X")
61: I Y="",$D(@DDS1REFD@(DDS1FLD,"F"))[0,$D(^DIST(.404,DDSBK,40,DDS1FO,3))#2 D DEF(^(3),$G(^(3.1)))
62: S @DDS1REFD@(DDS1FLD,"D")=Y
63: Q
64: ;
65: L2 ;Get multiple field
66: S DDS1SUB=+$P(DDS1LN,U,2) Q:$D(^DD(DDS1SUB,.01,0))[0
67: S DDS1DV=DDS1SUB_$P(^DD(DDS1SUB,.01,0),U,2),X=$P(^(0),U,3)
68: S DDS1DIC=DIE_DA_","""_DDS1ND_""","
69: ;
70: D:DDS1DV'["W"
71: . I $D(^DIST(.404,DDSBK,40,DDS1FO,3))#2 D D L22
72: .. D DEF(^DIST(.404,DDSBK,40,DDS1FO,3),$G(^(3.1)),1)
73: .. S DDS1RN=$S($G(Y)="FIRST":$O(@(DDS1DIC_"0)")),$G(Y)="LAST":$O(@(DDS1DIC_""" "")"),-1),1:+$G(Y))
74: . E I $D(DUZ)#2,$L(DDS1DIC)<29,$D(^DISV(DUZ,DDS1DIC))#2 S DDS1RN=^(DDS1DIC) D L22
75: . E S DDS1RN=$S($D(@(DDS1DIC_"0)"))#2:$P(^(0),U,3),1:$O(^(0))) D L22
76: . E S (Y,@DDS1REFD@(DDS1FLD,"D"))=""
77: ;
78: S @DDS1REFD@(DDS1FLD,"M")=$S(DDS1DV["W":0,1:1)_DDS1DIC_U_DDS1SUB
79: K DDS1DIC,DDS1RN,DDS1SUB
80: Q
81: L22 ;
82: I DDS1RN>0,$D(@(DDS1DIC_+DDS1RN_",0)"))#2 S Y=$P(^(0),U),@DDS1REFD@(DDS1FLD,"D")=+DDS1RN
83: Q
84: ;
85: DEF(DDS1LN3,DDS1LN31,DDS1MULT) ;Get default
86: N DDS1PTR,DDS1OT
87: Q:DDS1LN3=""
88: I DDS1LN3'="!M" S Y=DDS1LN3
89: E I DDS1LN31'?."^" X DDS1LN31 S:$D(Y)[0 Y=""
90: Q:Y=""!$G(DDS1MULT)
91: ;
92: K DIR
93: I DDS1FLD["," D
94: . S DIR(0)=$P(^DIST(.404,DDSBK,40,DDS1FO,20),U)_$P(^(20),U,2,3)
95: . S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999)
96: . I $E($P(DIR(0),U))="P" S DDS1PTR=1
97: E D
98: . S DIR(0)=DDP_","_DDS1FLD
99: . S DDS1PTR=$P($G(^DD(DDP,DDS1FLD,0)),U,2)
100: . S DDS1OT=DDS1PTR["O",DDS1PTR=DDS1PTR["P"
101: S DIR("V")="",(X,DIR("B"))=Y
102: D ^DIR
103: ;
104: I DDER S Y=""
105: I Y]"" D
106: . I $G(DDS1PTR) S Y=$P(Y,U)
107: . S $P(@DDSREFT@("F"_DDP,DDSDA,DDS1FLD,"F"),U)=3
108: . I $G(DDS1PTR),$G(DDS1OT),$D(^DD(DDP,DDS1FLD,2))#2 K Y(0),Y(0,0)
109: . S:$D(Y(0)) @DDSREFT@("F"_DDP,DDSDA,DDS1FLD,"X")=$S($D(Y(0,0))#2:Y(0,0),1:Y(0))
110: . S DDSCHG=1
111: K DDER,DIR
112: Q
113: ;
114: L3 ;Get number field
115: S (@DDS1REFD@(.001,"D"),Y)=DA
116: Q
117: ;
118: EXT(DDP,DDS1FLD,Y) ;Return external form of Y
119: N DDS1DV,X
120: S DDS1DV=$P(^DD(DDP,DDS1FLD,0),U,2),X=$P(^(0),U,3)
121: I DDS1DV'["O",DDS1DV'["P",DDS1DV'["V",DDS1DV'["D",DDS1DV'["S" Q Y
122: I DDS1DV'["O",Y="" Q ""
123: D XFORM
124: Q Y
125: ;
126: XFORM ;
127: N DDS1N
128: I DDS1DV["O",+DDS1FLD,$D(^DD(DDP,+DDS1FLD,2))#2 X ^(2) Q
129: I DDS1DV["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) Q:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DDS1DV=$P(^(0),U,2) G XFORM
130: I DDS1DV["V",+$P(Y,"E"),$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)"))#2 S X=+$P($P(^(0),U,2),"E") Q:$D(^(+$P(Y,"E"),0))[0 S Y=$P(^(0),U) I $D(^DD(+$P(X,"E"),.01,0))#2 S DDS1DV=$P(^(0),U,2),X=$P(^(0),U,3) G XFORM
131: I DDS1DV["D" X ^DD("DD")
132: I DDS1DV["S" S DDS1N=$P($P(";"_X,";"_Y_":",2),";",1) S:DDS1N]"" Y=DDS1N
133: Q
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to DDS11.m CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem_fileman