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

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

initial load of WorldVistAEHR
File size: 4.7 KB
Line 
1DDS11(DDSBK,DDSNFO) ;SFISC/MLH,MKO-LOAD DATA ; 04 Jun 2007
2 ;;22.0;VA FileMan;**151**;Mar 30, 1999;Build 10
3 ;Per VHA Directive 2004-038, 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,DDS1KEY,DDS1LN,DDS1ND,DDS1PC,DDS1UI,DDS1DV
22 K DDS1D1,DDS1D2,DDS1D3
23 Q
24 ;
25LD ;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 ;
55L1 ;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)))
62MUMPS I $G(DUZ(0))'="@",DDS1DV["K" S $P(@DDS1REFD@(DDS1FLD,"A"),U,4)=1,Y=$TR($J("",$L(Y))," ","*") ;**151
63 S @DDS1REFD@(DDS1FLD,"D")=Y
64 ;
65 ;Get key info
66 I '$D(@DDS1REFD@(DDS1FLD,"K")) D
67 . S DDS1KEY=0
68 . F S DDS1KEY=$O(^DD("KEY","F",DDP,DDS1FLD,DDS1KEY)) Q:'DDS1KEY D
69 .. S DDS1UI=$P(^DD("KEY",DDS1KEY,0),U,4) Q:'DDS1UI
70 .. Q:$P($G(^DD("IX",DDS1UI,0)),U,6)'="F"
71 .. S ^("K")=$G(@DDS1REFD@(DDS1FLD,"K"))_DDS1UI_U
72 Q
73 ;
74L2 ;Get multiple field
75 S DDS1SUB=+$P(DDS1LN,U,2) Q:$D(^DD(DDS1SUB,.01,0))[0
76 S DDS1DV=DDS1SUB_$P(^DD(DDS1SUB,.01,0),U,2),X=$P(^(0),U,3)
77 S DDS1DIC=DIE_DA_","""_DDS1ND_""","
78 ;
79 D:DDS1DV'["W"
80 . I $D(^DIST(.404,DDSBK,40,DDS1FO,3))#2 D D L22
81 .. D DEF(^DIST(.404,DDSBK,40,DDS1FO,3),$G(^(3.1)),1)
82 .. S DDS1RN=$S($G(Y)="FIRST":$O(@(DDS1DIC_"0)")),$G(Y)="LAST":$O(@(DDS1DIC_""" "")"),-1),1:+$G(Y))
83 . E I $D(DUZ)#2,$L(DDS1DIC)<29,$D(^DISV(DUZ,DDS1DIC))#2 S DDS1RN=^(DDS1DIC) D L22
84 . E S DDS1RN=$S($D(@(DDS1DIC_"0)"))#2:$P(^(0),U,3),1:$O(^(0))) D L22
85 . E S (Y,@DDS1REFD@(DDS1FLD,"D"))=""
86 ;
87 S @DDS1REFD@(DDS1FLD,"M")=$S(DDS1DV["W":0,1:1)_DDS1DIC_U_DDS1SUB
88 K DDS1DIC,DDS1RN,DDS1SUB
89 Q
90L22 ;
91 I DDS1RN>0,$D(@(DDS1DIC_+DDS1RN_",0)"))#2 S Y=$P(^(0),U),@DDS1REFD@(DDS1FLD,"D")=+DDS1RN
92 Q
93 ;
94DEF(DDS1LN3,DDS1LN31,DDS1MULT) ;Get default
95 N DDS1PTR,DDS1OT
96 Q:DDS1LN3=""
97 I DDS1LN3'="!M" S Y=DDS1LN3
98 E I DDS1LN31'?."^" X DDS1LN31 S:$D(Y)[0 Y=""
99 Q:Y=""!$G(DDS1MULT)
100 ;
101 K DIR
102 I DDS1FLD["," D
103 . S DIR(0)=$P(^DIST(.404,DDSBK,40,DDS1FO,20),U)_$P(^(20),U,2,3)
104 . S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999)
105 . I $E($P(DIR(0),U))="P" S DDS1PTR=1
106 E D
107 . S DIR(0)=DDP_","_DDS1FLD
108 . S DDS1PTR=$P($G(^DD(DDP,DDS1FLD,0)),U,2)
109 . S DDS1OT=DDS1PTR["O",DDS1PTR=DDS1PTR["P"
110 S DIR("V")="",(X,DIR("B"))=Y
111 D ^DIR
112 ;
113 I DDER S Y=""
114 I Y]"" D
115 . I $G(DDS1PTR) S Y=$P(Y,U)
116 . S $P(@DDSREFT@("F"_DDP,DDSDA,DDS1FLD,"F"),U)=3
117 . I $G(DDS1PTR),$G(DDS1OT),$D(^DD(DDP,DDS1FLD,2))#2 K Y(0),Y(0,0)
118 . S:$D(Y(0)) @DDSREFT@("F"_DDP,DDSDA,DDS1FLD,"X")=$S($D(Y(0,0))#2:Y(0,0),1:Y(0))
119 . S DDSCHG=1
120 K DDER,DIR
121 Q
122 ;
123L3 ;Get number field
124 S (@DDS1REFD@(.001,"D"),Y)=DA
125 Q
126 ;
127EXT(DDP,DDS1FLD,Y) ;Return external form of Y
128 N DDS1DV,X
129 S DDS1DV=$P(^DD(DDP,DDS1FLD,0),U,2),X=$P(^(0),U,3)
130 I DDS1DV'["O",DDS1DV'["P",DDS1DV'["V",DDS1DV'["D",DDS1DV'["S" Q Y
131 I DDS1DV'["O",Y="" Q ""
132 D XFORM
133 Q Y
134 ;
135XFORM ;
136 N DDS1N
137 I DDS1DV["O",+DDS1FLD,$D(^DD(DDP,+DDS1FLD,2))#2 X ^(2) Q
138 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
139 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
140 I DDS1DV["D" X ^DD("DD")
141 I DDS1DV["S" S DDS1N=$P($P(";"_X,";"_Y_":",2),";",1) S:DDS1N]"" Y=DDS1N
142 Q
Note: See TracBrowser for help on using the repository browser.