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

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1DICN ;SFISC/GFT,XAK,TKW,SEA/TOAD-ADD NEW ENTRY ;4/7/00 13:11
2 ;;22.0;VA FileMan;**4,31**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 N DIENTRY,DIFILE,DIAC D:'$D(DO) GETFA^DIC1(.DIC,.DO) S DO(1)=1
6 I '$D(DINDEX) N DINDEX S DINDEX("#")=1,DINDEX("START")="B"
7 N DISUBVAL,V
8 I DINDEX("#")>1 M V=X N X D I X="",DIC(0)'["E"!('$D(DISUBVAL)) D BAD^DIC1 Q
9 . D VALIX(+DO(2),.DINDEX,.V,.DISUBVAL,.X,.DS) K V Q
10 I $S($D(DLAYGO):DO(2)\1-(DLAYGO\1),1:1) S %=1 D B1 I '% D BAD^DIC1 Q
11USR D DS S DIX=X
12 I X'?16.N,X?.NP,X,DIC(0)["E",'$G(DICR),DS'["DINUM",$P(DS,U,2)'["N",DIC(0)["N"!$D(^DD(+DO(2),.001,0)) D N^DICN1 I $D(X) S DIENTRY=X G I
13 S X=DIX D:DINDEX("#")'>1 VAL G I:$D(X)
14 S X=DIX
15B D BAD^DIC1 S Y=-1 Q
16 ;
17B1 Q:'DO(2) Q:$D(^DD(+DO(2),0,"UP"))!(DO(2)=".12P")
18 S DIFILE=+DO(2),DIAC="LAYGO" D ^DIAC K DIAC,DIFILE
19 Q
20 ;
211 I '$D(DIC("S")) S DST=$G(DST)_$$EZBLD^DIALOG(8058,$$OUT^DIALOGU(Y,"ORD")) S:$D(^DD(+DO(2),0,"UP")) DST=DST_$$EZBLD^DIALOG(8059,$O(^DD(^("UP"),0,"NM",0))) S DST=DST_")"
22Y I $D(DDS) S A1="Q",DST=%_U_DST D H^DDSU Q
23 W !,DST K DST
24YN ;
25 N %1 S %1=$$EZBLD^DIALOG(7001) S:'$D(%) %=0 W "? " W:(%>0) $P(%1,U,%),"// "
26RX R %Y:$S($D(DTIME):DTIME,1:300) E S DTOUT=1,%Y=U W $C(7)
27 I %Y]""!'% S %=+$$PRS^DIALOGU(7001,%Y) S:(%<0&($A(%Y)'=94)) %=0
28 I '%,%Y'?."?" W $C(7),"??",!?4,$$EZBLD^DIALOG(8040),": " G RX
29 W:$X>73 ! W:% $S(%>0:" ("_$P(%1,U,%)_")",1:"") Q
30 ;
31DS S DS=^DD(+DO(2),.01,0) Q
32 ;
33VAL I X'?.ANP K X Q
34 I X["""" K X Q
35 I $P(DS,U,2)'["N",$A(X)=45 K X Q
36 I $P(DS,U,2)["*" S:DS["DINUM" DINUM=X Q
37 N %T,%DT,C,DIG,DIH,DIU,DIV
38 S %=$F(DS,"%DT=""E"),DS=$E(DS,1,%-2)_$E(DS,%,999) N DICTST S DICTST=DS["+X=X"&(X?16.N) K:DICTST X X:'DICTST $P(DS,U,5,99) Q
39 ;
40I1 S DST=$C(7)_$$EZBLD^DIALOG(8060)
41 I '$D(DIENTRY),Y]"" S DST=DST_$$EZBLD^DIALOG(8061,Y)
42 S %=$P(DO,U,1) I $L(DST)+$L(%)'>55 S DST=DST_$$EZBLD^DIALOG(8062,%) Q
43 W:'$D(DDS) !,DST K A1 D:$D(DDS) H^DIC2 S DST=" "_$$EZBLD^DIALOG(8062,%) Q
44 ;
45I I DIC(0)["E",DO(2)'["A",DIC(0)'["W" K DTOUT,DUOUT D G OUT^DICN0:$G(DTOUT)!($G(DUOUT)) I %'=1 S Y=-1 D BAD^DIC1 Q
46 . S (Y,DIX)=X I Y]"" N C S C=$P(^DD(+DO(2),.01,0),U,2) D Y^DIQ
47 . D I1 S %=2,Y=$P(DO,U,4)+1,X=DIX D 1
48I2 . Q:%>0!($G(DTOUT)) I %=-1 S DUOUT=1 Q
49 . W:'$D(DDS) $C(7)_"??",!?4,$$EZBLD^DIALOG(8040) D YN G I2
50 G NEW:'$D(DIENTRY)
51R D DS S DST=" "_$P(DS,U,1)_": "
52 I '$D(DDS) W !,DST K DST R X:DTIME S:$E(X)=U DUOUT=1,Y=-1 S:'$T X=U,DTOUT=1,Y=-1
53 I $D(DDS) S A1="Q",DST="3^"_DST D H^DDSU S X=% I $D(DTOUT) S X=U,Y=-1
54 I X[U D BAD^DIC1 Q
55 I X="" G R
56 D VAL
57 I '$D(X) W $C(7) W:'$D(DDS) "??" G:'$D(^DD(+DO(2),.01,3)) R S DST=" "_^(3) W:'$D(DDS) !,DST D:$D(DDS) H^DDSU G R
58 ;
59NEW ; try to add a new record to the file
60 G NEW^DICN0
61 ;
62FILE ; DOCUMENTED ENTRY POINT: add a new record to a file
63 ;
64 N DIENTRY,DS,DIAC,DIFILE D NEW^DICN0,Q^DIC2 Q
65 ;
66FIRE ; fire the SET logic of a bulletin or trigger xref (in DZ)
67 ; STORLIST^%RCR (called by NEW^DICN0)
68 ;
69 X DZ
70 Q
71 ;
72VALIX(DIFILEI,DINDEX,V,DISUBVAL,X,DS) ;
73 ; Save lookup values in array by field no. so we can update the fields on the new record.
74 N VI,DISUB,DIERR,DIFILE,DIFIELD,DO,DIOK
75 S X="" I $G(V)]"",$G(V(1))="" S V(1)=V
76 F DISUB=1:1:DINDEX("#") I $G(V(DISUB))]"" D
77 . S DIFILE=$G(DINDEX(DISUB,"FILE")),DIFIELD=$G(DINDEX(DISUB,"FIELD"))
78 . S DIOK=0 I 'DIFILE!('DIFIELD) Q
79 . S V=V(DISUB)
80 . I DISUB=1 D I DIOK S:DIOK'=2 DISUBVAL(DIFILE,DIFIELD)=V Q
81 . . I $A(V)=34,V?.E1"""" S V=$E(V,2,($L(V))-1)
82 . . I $G(DS("INT"))="",'$G(DICRS) S:"VP"[$G(DINDEX(1,"TYPE")) DIOK=2 Q
83 . . S DIOK=1
84 . . I DIFILE=DIFILEI,DIFIELD=.01 S X=$S($G(DICRS):V,1:DS("INT")) Q
85 . . S DISUBVAL(DIFILE,DIFIELD,"INT")=$S($G(DICRS):V,1:DS("INT"))
86 . . Q
87 . S DISUBVAL(DIFILE,DIFIELD)=V
88 . D CHK^DIE(DIFILE,DIFIELD,"",V,.VI,"DIERR") Q:VI="^"
89 . I DIFILE=DIFILEI,DIFIELD=.01 S X=VI K DISUBVAL(DIFILE,.01) Q
90 . S DISUBVAL(DIFILE,DIFIELD,"INT")=VI
91 . Q
92 Q
93 ;
94 ;#7001 Yes/No question
95 ;#8040 Answer with 'Yes' or 'No'
96 ;#8058 (the |entry number|
97 ;#8059 for this |filename|
98 ;#8060 Are you adding
99 ;#8061 '|.01 field value|' as
100 ;#8062 a new |filename|
Note: See TracBrowser for help on using the repository browser.