Annotation of freem_fileman/DDS41.m, revision 1.1.1.1
1.1 snw 1: DDS41 ;SFISC/MKO-VERIFY DATA ;07:42 AM 25 Oct 1994
2: ;;21.0;VA FileMan;;Dec 28, 1994
3: ;Per VHA Directive 10-93-142, this routine should not be modified.
4: N DDO
5: K DDSERROR,DDS4DONE,DDS4ERR
6: S DDS4PG=DDSPG
7: ;
8: ;Set DA,DIE,DDP array to its original value
9: I $G(DDSPTB)_$G(DDSREP)]"" N DIE,DDP,DDSDA,DA,DDSDL D
10: . S DA=DDSDAORG,DDSDL=DDSDLORG,DDSDA=DA_","
11: . F DDSI=1:1:DDSDL S DA(DDSI)=DDSDAORG(DDSI),DDSDA=DDSDA_DA(DDSI)_","
12: . S DDP=$P($G(DDSFLORG),U),DIE=U_$P($G(DDSFLORG),U,2) S:DIE=U DIE=""
13: ;
14: D LDALL
15: I $G(DIERR) D G END
16: . N P
17: . S P(1)=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U),P(2)=$P($G(^(1)),U)
18: . S:P(2)="" P(2)="unnamed"
19: . D BLD^DIALOG(3041,.P),ERR^DDSMSG
20: . S DDS4ERR=1
21: ;
22: D LP
23: ;
24: S DDSPG=DDS4PG,DDS4VC=$G(^DIST(.403,+DDS,20))
25: I DDS4VC'?."^" K @DDSREFT@("MSG") X DDS4VC
26: I $G(@DDSREFT@("MSG"))>0!$G(DIERR) D PRNT
27: ;
28: END S Y='$D(DDSERROR)&'$G(DDS4ERR)
29: K DDS4B,DDS4DA,DDS4DONE,DDS4ERR,DDS4FLD,DDS4PG,DDS4TP
30: K DDS4VC,DDSCAP,DDSDD,DDSERROR,DDSI,DDSPID
31: K DDSREQ,DIERR,DV
32: Q
33: ;
34: LDALL ;Load all pages
35: S (DDSPG,DDS4PG1)=$O(^DIST(.403,+DDS,40,"B",$S($G(DDSPAGE)]"":DDSPAGE,1:1),""))
36: S Y=1
37: F D ^DDS1(DDSPG) Q:$G(DIERR) S DDSPG=$$NP^DDS5(.Y) Q:DDSPG=DDS4PG1!'Y
38: K DDS4PG1
39: Q
40: ;
41: LP ;Loop through all pages/blocks
42: S DX=0,DY=IOSL-1 X IOXY
43: W "Verifying ..."_$P(DDGLCLR,DDGLDEL)
44: ;
45: S DDSPG=0
46: F S DDSPG=$O(@DDSREFT@(DDSPG)) Q:'DDSPG D
47: . S DDS4B=0
48: . F S DDS4B=$O(@DDSREFT@(DDSPG,DDS4B)) Q:'DDS4B D
49: .. I '$D(DDS4DONE(DDS4B)),$P(@DDSREFS@(DDSPG,DDS4B),U,5)="e" D
50: ... S DDSPID=$S($P($G(^DIST(.403,+DDS,40,DDSPG,1)),U)]"":$P(^(1),U),1:"Page "_$P(^(0),U))
51: ... D VB
52: Q
53: ;
54: VB ;Loop through all fields on block
55: N DDP
56: S DDS4DONE(DDS4B)="",DDP=$P(^DIST(.404,DDS4B,0),U,2)
57: S DDO=0 F S DDO=$O(^DIST(.404,DDS4B,40,DDO)) Q:'DDO D VF
58: Q
59: ;
60: VF ;Check for required fields
61: Q:$D(^DIST(.404,DDS4B,40,DDO,0))[0 S DDS4TP=$P(^(0),U,3)
62: Q:DDS4TP=1 Q:DDS4TP=4
63: S DDSCAP=$P(^DIST(.404,DDS4B,40,DDO,0),U,2)_$S($P(^(0),U,4)]"":" ("_$P(^(0),U,4)_")",1:"")
64: ;
65: I DDS4TP=2 N DDP D
66: . S DDP=0,DDS4FLD=DDO_","_DDS4B
67: . K DV
68: ;
69: E D Q:DDS4FLD'=+$P(DDS4FLD,"E")!(DDS4FLD=.01)
70: . S DDS4FLD=$G(^DIST(.404,DDS4B,40,DDO,1))
71: . S DDSDD=$G(^DD(DDP,DDS4FLD,0)),DV=$P(DDSDD,U,2)
72: . S:DDSCAP="" DDSCAP=$S($G(^DD(DDP,DDS4FLD,.1))]"":^(.1),1:$P(DDSDD,U))
73: ;
74: S DDS4DA=" "
75: F S DDS4DA=$O(@DDSREFT@(DDSPG,DDS4B,DDS4DA)) Q:DDS4DA="" D
76: . I $P(@DDSREFT@(DDSPG,DDS4B,DDS4DA),U,6)<2 D VR Q
77: . N DDS4PDA S DDS4PDA=DDS4DA N DDS4DA
78: . S DDS4DA=""
79: . F S DDS4DA=$O(@DDSREFT@(DDSPG,DDS4B,DDS4PDA,"B",DDS4DA)) Q:'DDS4DA D VR
80: Q
81: ;
82: VR ;Check that value is non-null for record
83: S DDSREQ=$P($G(^DIST(.404,DDS4B,40,DDO,4)),U)
84: S:$P($G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"A")),U)]"" DDSREQ=$P(^("A"),U)
85: ;
86: I DDSREQ'=1,$G(DV)'["R" Q
87: ;
88: ;Required WP fields (quit if mult)
89: I DDP,$D(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"M")) D:'^("M") Q
90: . I $G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"F")) S DDS4REF=$NA(^("D"))
91: . E S DDS4REF=$P(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"M"),U,2),DDS4REF=U_$E(DDS4REF,1,$L(DDS4REF)-1)_")"
92: . S (DDS4VAL,DDS4I)=0
93: . F S DDS4I=$O(@DDS4REF@(DDS4I)) Q:'DDS4I I $G(@DDS4REF@(DDS4I,0))'?." " S DDS4VAL=1 Q
94: . D:'DDS4VAL LDERR
95: . K DDS4REF,DDS4I,DDS4VAL
96: ;
97: I $G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"D"))="" D LDERR
98: Q
99: ;
100: LDERR ;Call ^DIALOG to load error
101: N P
102: I $D(DDS4ERR)[0 S DDS4ERR=1 D BLD^DIALOG(3091)
103: S P(1)=DDSPID,P(2)=DDSCAP,P(3)=""
104: I $L(DDS4DA,",")>2 D
105: . N Y,C
106: . S P(3)=$P(@(@DDSREFT@(DDSPG,DDS4B,$G(DDS4PDA,DDS4DA),"GL")_+DDS4DA_",0)"),U)
107: . Q:P(3)=""
108: . S Y=P(3),C=$P(^DD(DDP,.01,0),U,2) D Y^DIQ S P(3)=Y
109: . S P(3)="(Subrecord: "_P(3)_")"
110: D BLD^DIALOG(3092,.P)
111: Q
112: ;
113: PRNT ;
114: S (DDSABT,DX,DY)=0,$X=0,$Y=0 X IOXY
115: W $P(DDGLCLR,DDGLDEL,2)
116: ;
117: I $G(DIERR) D
118: . S DDSI=0
119: . F S DDSI=$O(^TMP("DIERR",$J,DDSI)) Q:'DDSI!DDSABT D
120: .. S DDSJ=0
121: .. F S DDSJ=$O(^TMP("DIERR",$J,DDSI,"TEXT",DDSJ)) Q:'DDSJ!DDSABT D
122: ... D:$G(^TMP("DIERR",$J,DDSI,"TEXT",DDSJ))]"" WLIN(^(DDSJ))
123: G:DDSABT PRNTEND
124: ;
125: I $D(@DDSREFT@("MSG")) D
126: . S DDSI=0
127: . F S DDSI=$O(@DDSREFT@("MSG",DDSI)) Q:'DDSI!DDSABT D
128: .. D:@DDSREFT@("MSG",DDSI)]"" WLIN(^(DDSI))
129: ;
130: D EOP
131: ;
132: PRNTEND W $P(DDGLCLR,DDGLDEL,2)
133: K DDSABT,DDSI,DDSJ
134: K @DDSREFT@("MSG"),^TMP("DIERR",$J)
135: Q
136: ;
137: WLIN(DDSX) ;
138: ;Write a single line, wrap at word boundaries
139: S DDSWIDTH=IOM-1
140: F Q:DDSX=""!DDSABT D
141: . F DDSSP=$L(DDSX," "):-1:1 I $L($P(DDSX," ",1,DDSSP))<DDSWIDTH D Q
142: .. I $Y+4>IOSL D EOP I 'Y S DDSABT=1 Q
143: .. W !,$P(DDSX," ",1,DDSSP)
144: .. S DDSX=$P(DDSX," ",DDSSP+1,999)
145: K DDSWIDTH
146: Q
147: EOP ;
148: N X
149: S DX=0,DY=IOSL-1 X IOXY
150: R "Press RETURN to continue: ",X:DTIME
151: S Y=X'[U&$T
152: Q
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to DDS41.m CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem_fileman