source: FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIVR1.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 5.3 KB
Line 
1DIVR1 ;SFISC/DCM-VERIFY FIELDS API ;9:16 AM 1 Jul 1999
2 ;;22.0;VA FileMan;**7**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN ;
5 I '$D(DIVRREC) S DIVRREC=""
6 N %ZIS,POP,ZTRTN,ZTSAVE,SUB
7 S %ZIS="Q" D ^%ZIS Q:POP
8 I $D(IO("Q")) S ZTRTN="DQ^DIVR1",(ZTSAVE("DIVRFILE"),ZTSAVE("DIVRDR"),ZTSAVE("DIVROUT"))="" S SUB="DIVRREC"_$S($D(DIVRREC)=10:"(",1:"") S ZTSAVE(SUB)="" D ^%ZTLOAD Q
9DQ N PG,TAB,REC,Y,DATE,I,J,K,DIVRFI0,DIVRFINM,DIVRFIIN,DA,V,DIRUT,R,DE,DIUTIL
10 K ^TMP("DIVR1",$J),^TMP("DIERR",$J)
11 I $D(ZTQUEUED) S ZTREQ="@"
12 S PG=0,TAB=0,REC=0,DIUTIL="VERIFY FIELDS" U IO
13 S Y=DT D DD^%DT S DATE=Y
14 D DIVRFILE Q:$G(DIERR)
15 D DIVRREC
16 I '$D(^TMP("DIVR1",$J)),'$G(DIERR) W !!!,?20,"*** NO ERRORS FOUND ***" D Q
17 D DIVROUT^DIV,Q
18 Q
19DIVRFILE S (DIVRFILE,DIVRFIIN)=+DIVRFILE
20 Q:'$$VFILE^DILFD(DIVRFILE,"D")
21 S DIVRFI0=$$FNO^DILIBF(DIVRFILE),DIVRFINM=$$GET1^DID(DIVRFI0,"","","NAME")
22 Q
23DIVRREC S R=$D(DIVRREC)
24 I $D(DIVRREC)#2,(DIVRREC=""!(DIVRREC="ALL")) S R=0 D IJ^DIVU(DIVRFIIN),H1,DIVRDR Q
25 I $D(DIVRREC)#2,$E(DIVRREC)="[" D Q
26 . N Y,D0,DS D DIBT^DIVU(DIVRREC,.Y,DIVRFI0) Q:Y'>0
27 . S D0=0 D H2,IJ^DIVU(DIVRFI0) F S D0=$O(^DIBT(+Y,1,D0)) Q:D0'>0 S DE="",DS=1 D:$$VENTRY^DIEFU(DIVRFI0,+D0,"D") DIVRDR Q:$D(DIRUT)
28 I $D(DIVRREC)=10 D Q
29 . N I S I="" D H2,IJ^DIVU(DIVRFIIN)
30 . F S I=$O(DIVRREC(I)) Q:I'>0 S DIVRREC=I D ONE
31 D H2,IJ^DIVU(DIVRFIIN)
32ONE Q:'$$IENCHK^DIT3(DIVRFIIN,DIVRREC)
33 Q:'$$VENTRY^DIEFU(DIVRFIIN,DIVRREC,"D")
34 N %,DEPTH,D,DS
35 S DEPTH=$L(DIVRREC,",")-1
36 F %=1:1:DEPTH S D="D"_(DEPTH-%) N @D S @D=$P(DIVRREC,",",%)
37 S DS=DEPTH D DIVRDR
38 Q
39DIVRDR N FLD,PC,Z,END,OUT,F,Y,Q,S
40 S F=1,FLD=0,Q="""",S=";"
41 S:$G(DIVRDR)="" DIVRDR="ALL"
42 I DIVRDR="ALL" D Q
43 . F S FLD=$O(^DD(DIVRFILE,FLD)) Q:FLD'>0 D SET Q:$D(DIRUT)
44 F S Z=$G(Z)+1 S PC=$P(DIVRDR,S,Z) Q:PC="" D Q:$D(DIRUT)
45 . N Z
46 . I PC[":" S FLD=$O(^DD(DIVRFILE,+PC),-1),END=+$P(PC,":",2) D Q
47 . . F S FLD=$O(^DD(DIVRFILE,FLD)) Q:FLD'>0!(FLD>END) D SET Q:$D(DIRUT)
48 . S FLD=PC I $$VFIELD^DILFD(DIVRFILE,PC,"D") D SET Q
49 Q
50SET N TYP,IT,T,W,PC3,M,Y,KEY
51 S Y=FLD,Y(0)=^DD(DIVRFILE,FLD,0),TYP=$P(Y(0),U,2),IT=$P(Y(0),U,5,99),PC3=$P(Y(0),U,3)
52 F T="N","D","P","S","V","F" Q:TYP[T
53 F W="FREE TEXT","SET OF CODES","DATE","NUMERIC","POINTER","VARIABLE POINTER","K" I T[$E(W) S:W="K" W="MUMPS" Q
54 I TYP["C" Q
55 I TYP,$P(^DD(+TYP,.01,0),U,2)["W" Q
56 I TYP D MULT Q
57 I 'R D:$Y>(IOSL-4) FF Q:$D(DIRUT) W !!?TAB,$P(^DD(DIVRFILE,FLD,0),U)_" (#"_FLD_")",?40,W
58 I TYP["*",TYP'["X" S IT="Q" I $D(^DD(DIVRFILE,FLD,12.1)) X ^(12.1) I $D(DIC("S")) S IT(1)=DIC("S"),IT="X IT(1) E K X"
59 S KEY=$D(^DD("KEY","F",DIVRFILE,FLD))>9
60 D XDE
61 Q
62XDE I F D
63 .I R,DIVRFILE=DIVRFIIN S DE="D DA^DIVU(.DA) X DE(99) G Q:$G(DIRUT)" Q
64 .D DE^DIVU(DIVRFILE,"","","DE",$G(DS)_U_$G(DS)) S F=0,DE=DE_" D DA^DIVU(.DA) X DE(99) G Q:$G(DIRUT)" Q
65 D DE99(DIVRFILE,FLD)
66 X DE
67 Q
68MULT D:$Y>(IOSL-4) FF Q:$D(DIRUT)
69 W:'R !!?TAB,$P(^DD(DIVRFILE,FLD,0),U)_"(#"_FLD_") --multiple--"
70 N DIVRFILE,FLD,DA,V,I,J,K,F,DE
71 S DIVRFILE=+TYP,FLD=0,TAB=TAB+2,F=1 D IJ^DIVU(DIVRFILE)
72 F S FLD=$O(^DD(DIVRFILE,FLD)) Q:FLD'>0 D SET Q:$D(DIRUT)
73 S TAB=TAB-2 K @("D"_V)
74 Q
75R I X?." " Q:TYP'["R"&'KEY D Q
76 . I X="" S M="Missing"_$S(KEY:" key value",1:"")
77 . E S M="Equals only 1 or more spaces"
78 . D X
79 D @T Q
80P I @("$D(^"_PC3_"X,0))") D F Q
81 S M="No '"_X_"' in pointed-to File" D X Q
82V I $P(X,S,2)'?1A.AN1"(".ANP,$P(X,S,2)'?1"%".AN1"(".ANP S M=Q_X_Q_" has the wrong format" D X Q
83 S M=$S($D(@(U_$P(X,S,2)_"0)")):^(0),1:"")
84 I '$D(^DD(DIVRFILE,FLD,"V","B",+$P(M,U,2))) S M=$P(M,U)_" FILE not in the DD" D X Q
85 I '$D(@(U_$P(X,S,2)_+X_",0)")) S M=U_$P(X,S,2)_+X_",0) does not exist" D X Q
86 D F Q
87S S Y=X I TYP'["X" X IT I '$D(X) S M=Q_Y_Q_" fails screen" D X Q
88 Q:S_PC3[(S_X_":") S M=Q_X_Q_" not in Set" D X Q
89D N Y,%DT S Y=$F(IT,"%DT=""E") S:Y IT=$E(IT,1,Y-2)_$E(IT,Y,999)
90 I TYP["X" X $P(IT," D ^%DT") D ^%DT I Y<0 S M="Invalid date" D X Q
91 D F Q
92N I TYP["X",X'?.1"-".N.".".N S M="Invalid number" D X Q
93 D F Q
94K D ^DIM I '$D(X) S M="Invalid M code" D X
95 Q
96F N Y S Y=X I X'?.ANP S M="Non-printing character" D X
97IT Q:TYP["X" D Q:$D(X) S M=Q_Y_Q_" fails Input Transform"
98 .N %Y S %Y=Y X IT S Y=%Y
99 ;
100X S X=$S(V:DA(V),1:DA),^TMP("DIVR1",$J,$S('R:X,$G(DIVRREC)["[":X,(R&($G(DIVROUT)["[")):X,1:DIVRREC))="",X=V,Z=0
101 I @(I(0)_"0)")
102IEN D FF:$Y>(IOSL-3) Q:$D(DIRUT)
103 I 'R D Q
104 .F Q:'X W !?5,@("D"_Z),?15,$P(^(@("D"_Z),0),U) S X=X-1,Z=Z+1,@("Y=$D(^("_I(V-X)_",0))")
105 .W !?5,@("D"_Z),?15,$S($D(^(@("D"_Z),0)):$P(^(0),U),1:@("D"_Z)),?50,$E(M,1,40) W:V !
106 I R D Q
107 .F Q:'X W !,@("D"_Z),?10,$P(^(@("D"_Z),0),U) W:Z " (",K(Z),")" S X=X-1,Z=Z+1,@("Y=$D(^("_I(V-X)_",0))")
108 .W !,@("D"_Z),?10,$S($D(^(@("D"_Z),0)):$P(^(0),U),1:@("D"_Z)) W:Z " (",K(Z),")" W !?5,$P(^DD(DIVRFILE,FLD,0),U)," (#",FLD,")",?35,W,?50,M W:V !
109 Q
110 ;
111DE99(FI,FD,NP) ;
112 N Y
113 D GET^DIOU(FI,FD,"X",.Y,"I")
114 S DE(99)=Y_" D R " Q
115 Q
116Q D ^%ZISC
117 Q
118FF I IOST["C-" N DIR,X,Y S DIR(0)="E" D ^DIR Q:$D(DIRUT)
119 I R D H2 Q
120H1 W:$Y @IOF W "Verify Fields File: ",DIVRFI0_" "_DIVRFINM,?(IOM-25) W DATE W ?(IOM-9),"PAGE ",PG+1
121 W !,"Field Name (Field #)",?40,"Type"
122 W !?5,"Entry #",?15,"Name",?50,"ERROR"
123 N L W ! F L=1:1:(IOM-2) W "-"
124 S PG=PG+1
125 Q
126H2 W:$Y @IOF W "Verify Fields File: ",DIVRFI0_" "_DIVRFINM,?(IOM-25) W DATE W ?(IOM-9),"PAGE ",PG+1
127 W !,"Entry #",?10,"Name"
128 W !?5,"Field Name (Field #)",?35,"Type",?50,"ERROR"
129 N L W ! F L=1:1:(IOM-2) W "-"
130 S PG=PG+1
131 Q
Note: See TracBrowser for help on using the repository browser.