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

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

initial load of WorldVistAEHR

File size: 5.1 KB
RevLine 
[613]1DICN1 ;SFISC/GFT,TKW,SEA/TOAD-PROCESS DIC("DR") ;10:54 AM 9 Feb 2001
2 ;;22.0;VA FileMan;**4,67**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 K DIDA,DICRS,Y,%RCR
6 F Y="DIADD","I","J","X","DO","DC","DA","DE","DG","DIE","DR","DIC","D","D0","D1","D2","D3","D4","D5","D6","DI","DH","DIA","DICR","DK","DIK","DL","DLAYGO","DM","DP","DQ","DU","DW","DIEL","DOV","DIOV","DIEC","DB","DV","DIFLD" S %RCR(Y)=""
7 S DZ="W !?3,$S("""_$P(DO,U)_"""'=$P(DQ(DQ),U):"""_$P(DO,U)_""",1:"""")_"" ""_$P(DQ(DQ),U)_"": """
8 S Y=DA N % S %=0 D I '$D(%) D W,BAD Q
9 . S DD="" N I,J,X,Y
10 . I DINO01 D
11 . . S DD=".01//"
12 . . S I=$G(DISUBVAL(+DO(2),.01)) I I="" S DD=DD_";" Q
13 . . S DD=DD_$S(DIC(0)'["E":"/",1:"")_"^S X=DISUBVAL("_+DO(2)_",.01);" Q
14 . K DISUBVAL(+DO(2),.01)
15 . F I=0:0 S I=$O(DISUBVAL(+DO(2),I)) Q:'I D
16 . . S DD=DD_I_"//"
17 . . I $G(DISUBVAL(+DO(2),I,"INT"))]"" S DD=DD_"//^S X=DISUBVAL("_+DO(2)_","_I_",""INT"");" Q
18 . . S:DIC(0)'["E" DD=DD_"/"
19 . . S DD=DD_"^S X=DISUBVAL("_+DO(2)_","_I_");" Q
20 . S DD=DD_$G(DIC("DR")) I DD]"",$E(DD,$L(DD))'=";" S DD=DD_";"
21 . Q:DIC(0)'["E"
22 . F I=0:0 S I=$O(^DD("KEY","B",+DO(2),I)) Q:'I!('$D(%)) F J=0:0 S J=$O(^DD("KEY",I,2,J)) Q:'J!('$D(%)) D
23 . . S X=$G(^DD("KEY",I,2,J,0)) Q:$P(X,U,2)'=+DO(2)
24 . . S Y=$P(X,U) Q:'Y D CKID
25 . . Q
26 . Q:$D(DIC("DR"))!('$D(%))
27 . S Y=0 F S Y=$O(^DD(+DO(2),0,"ID",Y)) Q:'Y D CKID Q:'$D(%)
28 . Q
29 I DD]"",$O(^DD("KEY","B",+DO(2),0)) D
30 . N I S I=$S(DIC(0)["E":"M",1:"")
31 . S DD=DD_"S DIEFIRE="""_I_"""" Q
32 S %RCR="RCR^DICN1" D STORLIST^%RCR
33 I $D(Y)<9 S Y=DA Q
34 ;
35BAD S:$D(D)#2 DA=D K Y I '$D(DO(1)) S Y=-1 D Q^DIC2 Q
36 K DO D A^DIC S DS(0)="1^",Y=-1 Q
37 ;
38CKID I $G(DUZ(0))'="@",$G(^DD(+DO(2),Y,9))]"" D Q:'$D(%) Q:$L(^DD(+DO(2),Y,9))<%
39 . F %=1:1 I DUZ(0)[$E(^DD(+DO(2),Y,9),%) Q:$L(^(9))'<% K:$P(^(0),U,2)["R" % Q
40 Q:Y=.01
41 I $P(DD,"//")=Y!(DD[(";"_Y_"//"))!(DD[(";"_Y_";")) Q
42 S DD=DD_Y_";"
43Q Q
44 ;
45W S A1="T",DST="SORRY! A VALUE FOR '"_$P(^(0),U,1)_"' MUST BE ENTERED," W:'$D(DDS) ! D H
46 S A1="T",DST="BUT YOU DON'T HAVE 'WRITE ACCESS' FOR THIS FIELD" W:'$D(DDS) !,?6 D H D:$D(DDS) LIST^DDSU
47 S %RCR="D^DICN1" D STORLIST^%RCR Q
48 ;
49H I $D(DDS) S DDH=$S($D(DDH):DDH+1,1:1),DDH(DDH,A1)=DST K A1,DST Q
50 W DST K A1,DST Q
51RCR ;
52 K DR,DIADD,DQ,DG,DE,DO N DISAV0 S DIE=DIC,DR=DD,DIE("W")=DZ,DISAV0=DIC(0) K DIC
53 I $D(DIE("NO^")) S %RCR("DIE(""NO^"")")=DIE("NO^")
54 S DIE("NO^")="BACKOUTOK" N X
55 D:$D(DDS) CLRMSG^DDS D:DR]"" K DIE("W"),DIE("NO^")
56 . N DISAV0,DIFILEI,DINDEX,DIVAL,DIENS,DIOPER
57 . S DIOPER="A" K % M %=DISUBVAL N DISUBVAL M DISUBVAL=% K %
58 . D ^DIE Q
59 D:$D(DDS)
60 . I $Y<IOSL D CLRMSG^DDS Q
61 . D REFRESH^DDSUTL
62A I '$D(DA) S Y(0)=0 Q
63 S:'$$INTEG^DIKK(DIE,DA_DIENS,"","","d") Y(0)=0,X="BADKEY"
64 Q:$D(Y)<9&'$D(DTOUT)&'$D(DIC("W"))&($G(X)'="BADKEY")
65 I $G(X)="BADKEY",DISAV0["E" W !," ",$$EZBLD^DIALOG(741)
66 S:'$G(DTOUT)&($D(Y)'<9) DUOUT=1
67ZAP S DIK=DIE
68 I DISAV0["E" S A1="T",DST=$C(7)_" <'"_$P(@(DIK_"DA,0)"),U,1)_"' DELETED>" W:'$D(DDS) !?3 D H D:$D(DDS) LIST^DDSU
69 D ^DIK S Y(0)=0 K DST Q
70 ;
71D N DISAV0 S DISAV0=DIC(0),DIE=DIC D ZAP Q
72 ;
73ASKP001 ; ask user to confirm new record's .001 field value
74 ; NEW^DICN
75 ;
76 ; quit if there's no .001 or we can't ask
77 ;
78 I DIC(0)'["E" S Y=1 Q
79 S Y=$P(DO,U,2)
80 I '$D(^DD(+Y,.001,0)) S Y=1 Q
81 ;
82 ; if this is not a LAYGO lookup in which X looks like an IEN, and we're
83 ; adding a new file, and we haven't tried this before, then offer a new
84 ; .001 based on the user's or site's file range, whichever's handy.
85 ; NEW^DICN will increment this .001 forward to find the first gap, then
86 ; drop back through here to the paragraph below (because DO(3) will be
87 ; defined next time) to offer it to the user
88 ;
89 I '$D(DIENTRY),DIC="^DIC(",'$D(DO(3)) D S Y="TRY NEXT" Q
90 . S DO(3)=1
91 . I $S($D(^VA(200,DUZ,1))#2:1,1:$D(^DIC(3,DUZ,1))#2),$P(^(1),U) D Q
92 . . S DIY=.1,X=+$P(^(1),U) ; NAKED
93 . I $D(^DD("SITE",1)),X\1000'=^(1) S X=^(1)*1000,%=0
94 ;
95 ; set up our prompt, if .001 looks valid use it as a default, otherwise
96 ; count forward until we find a valid one to offer
97 ;
98 S DST=" "_$P(DO,U)_" "_$P(^DD(+Y,.001,0),U)_": "
99 S %=$P(^DD(+Y,.001,0),U,2),X=$S(%'["N"!(%["O"):0,1:X),%Y=X
100 I X F %=1:1 D N Q:$D(X) S X=0 Q:%>999 S X=%Y+DIY,%Y=X
101 I X S DST=DST_X_"// "
102 ;
103 ; prompt user for .001
104 ;
105 I '$D(DDS) D
106 . W !,DST K DST R Y:$S($D(DTIME):DTIME,1:300) E S DTOUT=1,Y=U W $C(7)
107 E D
108 . S A1="Q",DST=3_U_DST N DIY D H,LIST^DDSU S Y=$S($D(DTOUT):U,1:%) K %
109 ;
110 ; sort through possible responses
111 ;
112 I Y[U S Y=U Q
113 I Y="" S Y=1 Q
114 I Y'="?" D Q:Y
115 . S X=Y D N S Y=$D(X)#2 D:Y Q:Y
116 . . I $D(@(DIC_X_")")) K X S Y=0
117 . . Q
118 . W $C(7)
119 . W:'$D(DDS) "??"
120 ;
121 ; for bad response or help request, offer help and try new IEN
122 ;
123 S DST="" I $D(^DD(+DO(2),.001,3)) S DST=" "_^(3)
124 I '$D(DDS) D
125 . W:DST]"" !?5,DST X:$D(^(4)) ^(4) K DST ; NAKED
126 E D
127 . S A1=0 N DIY D H S:$D(^(4)) DDH("ID")=^(4) D LIST^DDSU ; NAKED
128 S X=$P(DO,U,3) D INCR^DICN0
129 S Y="TRY NEXT"
130 Q
131 ;
132N ; test X as an IEN (apply input transform and numeric restrictions)
133 ; USR^DICN, ASKP001
134 ;
135 I $D(^DD(+$P(DO,U,2),.001,0)),'$D(DINUM) X $P(^(0),U,5,99)
136 I $D(X),$L(X)<15,+X=X,X>0,X>1!(DIC'="^DIC(") Q
137 K X
138 Q
139 ;
140 ; 741 Either key values are null, or creates a duplicate key.
141 ;
Note: See TracBrowser for help on using the repository browser.