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

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

initial load of WorldVistAEHR
File size: 5.6 KB
RevLine 
[613]1DDS41 ;SFISC/MKO-VERIFY DATA ;21SEP2006
2 ;;22.0;VA FileMan;**8,151**;Mar 30, 1999;Build 10
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 N DDO,DIERR
5 N DDS4B,DDS4DA,DDS4DONE,DDS4ERR,DDS4FLD,DDS4OUT,DDS4PG,DDS4PG1,DDS4TP
6 N DDSCAP,DDSERROR,DDSFDA,DDSI,DDSKEY,DDSPID,DDSREQ
7 ;
8 S DDS4OUT=$NA(@DDSREFT@("VALMSG"))
9 S DDS4PG=DDSPG
10 ;
11 K @DDS4OUT,@DDSREFT@("MSG"),@DDSREFT@("KMSG")
12 ;
13 I $G(DDSPTB)_$G(DDSREP)]"" N DIE,DDP,DDSDA,DA,DDSDL D
14 . S DA=DDSDAORG,DDSDL=DDSDLORG,DDSDA=DA_","
15 . F DDSI=1:1:DDSDL S DA(DDSI)=DDSDAORG(DDSI),DDSDA=DDSDA_DA(DDSI)_","
16 . S DDP=$P($G(DDSFLORG),U),DIE=U_$P($G(DDSFLORG),U,2) S:DIE=U DIE=""
17 ;
18 D LDALL
19 I $G(DIERR) D G END
20 . N P
21 . S P(1)=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U),P(2)=$P($G(^(1)),U)
22 . S:P(2)="" P(2)="unnamed"
23 . D BLD^DIALOG(3041,.P),ERR^DDSMSG ;PAGE COULD NOT BE LOADED
24 . S DDS4ERR=1
25 ;
26 D LP
27 ;
28 ;Validate keys
29 S DDSKEY=1
30 I $D(DDSFDA) D
31 . S DDSKEY=$$KEYVAL^DIE("","DDSFDA",$NA(@DDSREFT@("KMSG")))
32 . I 'DDSKEY,$D(DDS4ERR)[0 S DDS4ERR=1 D BLD^DIALOG(3091,"","",DDS4OUT,"S")
33 ;
34 S DDSPG=DDS4PG
35 I '$G(DDS4ERR),$G(^DIST(.403,+DDS,20))'?."^" X ^(20)
36 I $G(@DDSREFT@("MSG"))>0!$G(DDS4ERR)!'DDSKEY D PRNT
37 ;
38END S Y='$D(DDSERROR)&'$G(DDS4ERR)&$G(DDSKEY)
39 K @DDS4OUT,@DDSREFT@("MSG"),@DDSREFT@("KMSG")
40 Q
41 ;
42LDALL ;Load all pages
43 S DX=0,DY=IOSL-1 X IOXY
44 W "Please wait. Loading all pages ..."_$P(DDGLCLR,DDGLDEL)
45 S (DDSPG,DDS4PG1)=$O(^DIST(.403,+DDS,40,"B",$S($G(DDSPAGE)]"":DDSPAGE,1:1),""))
46 S Y=1
47 F D ^DDS1(DDSPG) Q:$G(DIERR) S DDSPG=$$NP^DDS5(.Y) Q:DDSPG=DDS4PG1!'Y
48 Q
49 ;
50LP ;Loop through all pages/blocks
51 N DDP
52 S DX=0,DY=IOSL-1 X IOXY
53 W "Verifying ..."_$P(DDGLCLR,DDGLDEL)
54 ;
55 S DDSPG=0 F S DDSPG=$O(@DDSREFT@(DDSPG)) Q:'DDSPG D
56 . S DDS4B=0 F S DDS4B=$O(@DDSREFT@(DDSPG,DDS4B)) Q:'DDS4B D
57 .. Q:$D(DDS4DONE(DDS4B)) Q:$P(@DDSREFS@(DDSPG,DDS4B),U,5)'="e"
58 .. S DDSPID=$S($P($G(^DIST(.403,+DDS,40,DDSPG,1)),U)]"":$P(^(1),U),1:"Page "_$P(^(0),U))
59 .. S DDS4DONE(DDS4B)="",DDP=$P(^DIST(.404,DDS4B,0),U,2)
60 .. S DDO=0 F S DDO=$O(^DIST(.404,DDS4B,40,DDO)) Q:'DDO D VF
61 Q
62 ;
63VF ;Check required and key fields
64 Q:$D(^DIST(.404,DDS4B,40,DDO,0))[0 S DDS4TP=$P(^(0),U,3)
65 Q:DDS4TP=1 Q:DDS4TP=4
66 S DDSCAP=$P(^DIST(.404,DDS4B,40,DDO,0),U,2)_$S($P(^(0),U,4)]"":" ("_$P(^(0),U,4)_")",1:"")
67 S DDSREQ=$P($G(^DIST(.404,DDS4B,40,DDO,4)),U)
68 S DDSKEY=0
69 ;
70 I DDS4TP=2 N DDP D
71 . S DDP=0,DDS4FLD=DDO_","_DDS4B
72 . S:DDSCAP="" DDSCAP=$P(^DIST(.404,DDS4B,40,DDO,0),U,5)
73 ;
74 E D Q:DDS4FLD'=+$P(DDS4FLD,"E")
75 . S DDS4FLD=$G(^DIST(.404,DDS4B,40,DDO,1))
76 . I $G(^DD(DDP,DDS4FLD,0))?."^" S DDS4FLD="" Q
77 . S:DDSCAP="" DDSCAP=$S($G(^DD(DDP,DDS4FLD,.1))]"":^(.1),1:$P(^(0),U))
78 . S:DDSREQ="" DDSREQ=$P(^DD(DDP,DDS4FLD,0),U,2)["R"
79 . S DDSKEY=$D(^DD("KEY","F",DDP,DDS4FLD))>0
80 ;
81 S DDS4DA=" "
82 F S DDS4DA=$O(@DDSREFT@(DDSPG,DDS4B,DDS4DA)) Q:DDS4DA="" D
83 . I $P(@DDSREFT@(DDSPG,DDS4B,DDS4DA),U,6)<2 D VR Q
84 . ;
85 . N DDS4PDA S DDS4PDA=DDS4DA N DDS4DA
86 . S DDS4DA=""
87 . F S DDS4DA=$O(@DDSREFT@(DDSPG,DDS4B,DDS4PDA,"B",DDS4DA)) Q:'DDS4DA D VR
88 Q
89 ;
90VR ;Check individual records
91 I $P($G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"A")),U)]"" N DDSREQ S DDSREQ=$P(^("A"),U)
92 I 'DDSREQ,'DDSKEY Q
93 ;
94 ;Required WP fields (quit if mult)
95 I DDP,$D(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"M")) D:'^("M") Q
96 . N DDS4I,DDS4REF,DDS4VAL
97 . I $G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"F")) S DDS4REF=$NA(^("D"))
98 . E S DDS4REF=$P(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"M"),U,2),DDS4REF=U_$E(DDS4REF,1,$L(DDS4REF)-1)_")"
99 . S (DDS4VAL,DDS4I)=0
100 . F S DDS4I=$O(@DDS4REF@(DDS4I)) Q:'DDS4I I $G(@DDS4REF@(DDS4I,0))'?." " S DDS4VAL=1 Q
101 . D:'DDS4VAL LDERR
102 ;
103 I $G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"D"))="" D LDERR Q
104 ;
105 I DDSKEY,$D(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"F")) S DDSFDA(DDP,DDS4DA,DDS4FLD)=$G(^("D"))
106 Q
107 ;
108LDERR ;Call ^DIALOG to load error
109 N P
110 I $D(DDS4ERR)[0 S DDS4ERR=1 D BLD^DIALOG(3091,"","",DDS4OUT,"S")
111 S P(1)=DDSPID,P(2)=DDSCAP,P(3)=""
112 I $L(DDS4DA,",")>2 D
113 . N Y,C
114 . S P(3)=$P(@(@DDSREFT@(DDSPG,DDS4B,$G(DDS4PDA,DDS4DA),"GL")_+DDS4DA_",0)"),U)
115 . Q:P(3)=""
116 . S Y=P(3),C=$P(^DD(DDP,.01,0),U,2) D Y^DIQ S P(3)=Y
117 . S P(3)="(Subrecord: "_P(3)_")"
118 D BLD^DIALOG(3092,.P,"",DDS4OUT,"S")
119 Q
120 ;
121PRNT ;Print messages
122 N DDSABT
123 S (DDSABT,DX,DY)=0 X IOXY
124 W $P(DDGLCLR,DDGLDEL,2)
125 S $X=0,$Y=0
126 ;
127 ;Print required field messages
128 I $G(DDS4ERR) S DDSI=0 F S DDSI=$O(@DDS4OUT@(DDSI)) Q:'DDSI D Q:DDSABT
129 . D:$G(@DDS4OUT@(DDSI))]"" WLIN(^(DDSI))
130 ;
131 ;Print duplicate key messages
132 S DDSI=0 F S DDSI=$O(@DDSREFT@("KMSG","DIERR",DDSI)) Q:'DDSI D Q:DDSABT
133 . D WLIN(" "),WLIN(@DDSREFT@("KMSG","DIERR",DDSI,"TEXT",1))
134 . Q:@DDSREFT@("KMSG","DIERR",DDSI)'=740
135 . ;
136 . N DA,FIL,FILE,FLD,FLDS,FNAME,IENS,J,KEY,LEV,RNAME
137 . S FILE=@DDSREFT@("KMSG","DIERR",DDSI,"PARAM","FILE"),IENS=$G(^("IENS")),KEY=$G(^("KEY"))
138 . D FRNAME^DIKCU1(FILE,IENS,.FNAME,.RNAME,.LEV)
139 . ;
140 . I LEV D
141 .. S FNAME=$J("",7)_"Subfile: "_FNAME D WLIN(.FNAME,16)
142 .. S RNAME=$J("",8)_"Record: "_RNAME D WLIN(.RNAME,16)
143 . ;
144 . S FLDS="",J=0 F S J=$O(^DD("KEY",KEY,2,J)) Q:'J D
145 .. Q:'$D(^DD("KEY",KEY,2,J,0)) S FLD=$P(^(0),U),FIL=$P(^(0),U,2)
146 .. Q:'$D(^DD(FIL,FLD,0)) S FLDS=FLDS_$P(^(0),U)_" (#"_FLD_"), "
147 . D:FLDS]"" WLIN(" Key Field(s): "_$E(FLDS,1,$L(FLDS)-2),16)
148 ;
149 ;Print developer messages
150 S DDSI=0 F S DDSI=$O(@DDSREFT@("MSG",DDSI)) Q:'DDSI D Q:DDSABT
151 . D:@DDSREFT@("MSG",DDSI)]"" WLIN(^(DDSI))
152 ;
153 D EOP
154 Q
155 ;
156WLIN(DDSX,DDSINDNT) ;Write a single line, wrap at word boundaries
157 N I
158 D WRAP^DIKCU2(.DDSX,IOM-1-$G(DDSINDNT),IOM-1)
159 S DDSX(0)=DDSX
160 F I=0:1 Q:'$D(DDSX(I)) D Q:DDSABT
161 . I $Y+4>IOSL D EOP I 'Y S DDSABT=1 Q
162 . W !,$J("",$S(I:$G(DDSINDNT),1:0))_DDSX(I)
163 Q
164EOP ;Issue EOP prompt
165 N X
166 S DX=0,DY=IOSL-1 X IOXY
167 R "Press RETURN to continue: ",X:DTIME
168 S Y=X'[U&$T
169 I Y S (DX,DY)=0 X IOXY W $P(DDGLCLR,DDGLDEL,2) S $X=0,$Y=0
170 Q
Note: See TracBrowser for help on using the repository browser.