142 lines
5.1 KiB
Mathematica
142 lines
5.1 KiB
Mathematica
|
DICN1 ;SFISC/GFT,TKW,SEA/TOAD-PROCESS DIC("DR") ;10:54 AM 9 Feb 2001
|
||
|
|
;;22.0;VA FileMan;**4,67**;Mar 30, 1999
|
||
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
||
|
|
;
|
||
|
|
K DIDA,DICRS,Y,%RCR
|
||
|
|
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)=""
|
||
|
|
S DZ="W !?3,$S("""_$P(DO,U)_"""'=$P(DQ(DQ),U):"""_$P(DO,U)_""",1:"""")_"" ""_$P(DQ(DQ),U)_"": """
|
||
|
|
S Y=DA N % S %=0 D I '$D(%) D W,BAD Q
|
||
|
|
. S DD="" N I,J,X,Y
|
||
|
|
. I DINO01 D
|
||
|
|
. . S DD=".01//"
|
||
|
|
. . S I=$G(DISUBVAL(+DO(2),.01)) I I="" S DD=DD_";" Q
|
||
|
|
. . S DD=DD_$S(DIC(0)'["E":"/",1:"")_"^S X=DISUBVAL("_+DO(2)_",.01);" Q
|
||
|
|
. K DISUBVAL(+DO(2),.01)
|
||
|
|
. F I=0:0 S I=$O(DISUBVAL(+DO(2),I)) Q:'I D
|
||
|
|
. . S DD=DD_I_"//"
|
||
|
|
. . I $G(DISUBVAL(+DO(2),I,"INT"))]"" S DD=DD_"//^S X=DISUBVAL("_+DO(2)_","_I_",""INT"");" Q
|
||
|
|
. . S:DIC(0)'["E" DD=DD_"/"
|
||
|
|
. . S DD=DD_"^S X=DISUBVAL("_+DO(2)_","_I_");" Q
|
||
|
|
. S DD=DD_$G(DIC("DR")) I DD]"",$E(DD,$L(DD))'=";" S DD=DD_";"
|
||
|
|
. Q:DIC(0)'["E"
|
||
|
|
. 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
|
||
|
|
. . S X=$G(^DD("KEY",I,2,J,0)) Q:$P(X,U,2)'=+DO(2)
|
||
|
|
. . S Y=$P(X,U) Q:'Y D CKID
|
||
|
|
. . Q
|
||
|
|
. Q:$D(DIC("DR"))!('$D(%))
|
||
|
|
. S Y=0 F S Y=$O(^DD(+DO(2),0,"ID",Y)) Q:'Y D CKID Q:'$D(%)
|
||
|
|
. Q
|
||
|
|
I DD]"",$O(^DD("KEY","B",+DO(2),0)) D
|
||
|
|
. N I S I=$S(DIC(0)["E":"M",1:"")
|
||
|
|
. S DD=DD_"S DIEFIRE="""_I_"""" Q
|
||
|
|
S %RCR="RCR^DICN1" D STORLIST^%RCR
|
||
|
|
I $D(Y)<9 S Y=DA Q
|
||
|
|
;
|
||
|
|
BAD S:$D(D)#2 DA=D K Y I '$D(DO(1)) S Y=-1 D Q^DIC2 Q
|
||
|
|
K DO D A^DIC S DS(0)="1^",Y=-1 Q
|
||
|
|
;
|
||
|
|
CKID I $G(DUZ(0))'="@",$G(^DD(+DO(2),Y,9))]"" D Q:'$D(%) Q:$L(^DD(+DO(2),Y,9))<%
|
||
|
|
. F %=1:1 I DUZ(0)[$E(^DD(+DO(2),Y,9),%) Q:$L(^(9))'<% K:$P(^(0),U,2)["R" % Q
|
||
|
|
Q:Y=.01
|
||
|
|
I $P(DD,"//")=Y!(DD[(";"_Y_"//"))!(DD[(";"_Y_";")) Q
|
||
|
|
S DD=DD_Y_";"
|
||
|
|
Q Q
|
||
|
|
;
|
||
|
|
W S A1="T",DST="SORRY! A VALUE FOR '"_$P(^(0),U,1)_"' MUST BE ENTERED," W:'$D(DDS) ! D H
|
||
|
|
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
|
||
|
|
S %RCR="D^DICN1" D STORLIST^%RCR Q
|
||
|
|
;
|
||
|
|
H I $D(DDS) S DDH=$S($D(DDH):DDH+1,1:1),DDH(DDH,A1)=DST K A1,DST Q
|
||
|
|
W DST K A1,DST Q
|
||
|
|
RCR ;
|
||
|
|
K DR,DIADD,DQ,DG,DE,DO N DISAV0 S DIE=DIC,DR=DD,DIE("W")=DZ,DISAV0=DIC(0) K DIC
|
||
|
|
I $D(DIE("NO^")) S %RCR("DIE(""NO^"")")=DIE("NO^")
|
||
|
|
S DIE("NO^")="BACKOUTOK" N X
|
||
|
|
D:$D(DDS) CLRMSG^DDS D:DR]"" K DIE("W"),DIE("NO^")
|
||
|
|
. N DISAV0,DIFILEI,DINDEX,DIVAL,DIENS,DIOPER
|
||
|
|
. S DIOPER="A" K % M %=DISUBVAL N DISUBVAL M DISUBVAL=% K %
|
||
|
|
. D ^DIE Q
|
||
|
|
D:$D(DDS)
|
||
|
|
. I $Y<IOSL D CLRMSG^DDS Q
|
||
|
|
. D REFRESH^DDSUTL
|
||
|
|
A I '$D(DA) S Y(0)=0 Q
|
||
|
|
S:'$$INTEG^DIKK(DIE,DA_DIENS,"","","d") Y(0)=0,X="BADKEY"
|
||
|
|
Q:$D(Y)<9&'$D(DTOUT)&'$D(DIC("W"))&($G(X)'="BADKEY")
|
||
|
|
I $G(X)="BADKEY",DISAV0["E" W !," ",$$EZBLD^DIALOG(741)
|
||
|
|
S:'$G(DTOUT)&($D(Y)'<9) DUOUT=1
|
||
|
|
ZAP S DIK=DIE
|
||
|
|
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
|
||
|
|
D ^DIK S Y(0)=0 K DST Q
|
||
|
|
;
|
||
|
|
D N DISAV0 S DISAV0=DIC(0),DIE=DIC D ZAP Q
|
||
|
|
;
|
||
|
|
ASKP001 ; ask user to confirm new record's .001 field value
|
||
|
|
; NEW^DICN
|
||
|
|
;
|
||
|
|
; quit if there's no .001 or we can't ask
|
||
|
|
;
|
||
|
|
I DIC(0)'["E" S Y=1 Q
|
||
|
|
S Y=$P(DO,U,2)
|
||
|
|
I '$D(^DD(+Y,.001,0)) S Y=1 Q
|
||
|
|
;
|
||
|
|
; if this is not a LAYGO lookup in which X looks like an IEN, and we're
|
||
|
|
; adding a new file, and we haven't tried this before, then offer a new
|
||
|
|
; .001 based on the user's or site's file range, whichever's handy.
|
||
|
|
; NEW^DICN will increment this .001 forward to find the first gap, then
|
||
|
|
; drop back through here to the paragraph below (because DO(3) will be
|
||
|
|
; defined next time) to offer it to the user
|
||
|
|
;
|
||
|
|
I '$D(DIENTRY),DIC="^DIC(",'$D(DO(3)) D S Y="TRY NEXT" Q
|
||
|
|
. S DO(3)=1
|
||
|
|
. I $S($D(^VA(200,DUZ,1))#2:1,1:$D(^DIC(3,DUZ,1))#2),$P(^(1),U) D Q
|
||
|
|
. . S DIY=.1,X=+$P(^(1),U) ; NAKED
|
||
|
|
. I $D(^DD("SITE",1)),X\1000'=^(1) S X=^(1)*1000,%=0
|
||
|
|
;
|
||
|
|
; set up our prompt, if .001 looks valid use it as a default, otherwise
|
||
|
|
; count forward until we find a valid one to offer
|
||
|
|
;
|
||
|
|
S DST=" "_$P(DO,U)_" "_$P(^DD(+Y,.001,0),U)_": "
|
||
|
|
S %=$P(^DD(+Y,.001,0),U,2),X=$S(%'["N"!(%["O"):0,1:X),%Y=X
|
||
|
|
I X F %=1:1 D N Q:$D(X) S X=0 Q:%>999 S X=%Y+DIY,%Y=X
|
||
|
|
I X S DST=DST_X_"// "
|
||
|
|
;
|
||
|
|
; prompt user for .001
|
||
|
|
;
|
||
|
|
I '$D(DDS) D
|
||
|
|
. W !,DST K DST R Y:$S($D(DTIME):DTIME,1:300) E S DTOUT=1,Y=U W $C(7)
|
||
|
|
E D
|
||
|
|
. S A1="Q",DST=3_U_DST N DIY D H,LIST^DDSU S Y=$S($D(DTOUT):U,1:%) K %
|
||
|
|
;
|
||
|
|
; sort through possible responses
|
||
|
|
;
|
||
|
|
I Y[U S Y=U Q
|
||
|
|
I Y="" S Y=1 Q
|
||
|
|
I Y'="?" D Q:Y
|
||
|
|
. S X=Y D N S Y=$D(X)#2 D:Y Q:Y
|
||
|
|
. . I $D(@(DIC_X_")")) K X S Y=0
|
||
|
|
. . Q
|
||
|
|
. W $C(7)
|
||
|
|
. W:'$D(DDS) "??"
|
||
|
|
;
|
||
|
|
; for bad response or help request, offer help and try new IEN
|
||
|
|
;
|
||
|
|
S DST="" I $D(^DD(+DO(2),.001,3)) S DST=" "_^(3)
|
||
|
|
I '$D(DDS) D
|
||
|
|
. W:DST]"" !?5,DST X:$D(^(4)) ^(4) K DST ; NAKED
|
||
|
|
E D
|
||
|
|
. S A1=0 N DIY D H S:$D(^(4)) DDH("ID")=^(4) D LIST^DDSU ; NAKED
|
||
|
|
S X=$P(DO,U,3) D INCR^DICN0
|
||
|
|
S Y="TRY NEXT"
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
N ; test X as an IEN (apply input transform and numeric restrictions)
|
||
|
|
; USR^DICN, ASKP001
|
||
|
|
;
|
||
|
|
I $D(^DD(+$P(DO,U,2),.001,0)),'$D(DINUM) X $P(^(0),U,5,99)
|
||
|
|
I $D(X),$L(X)<15,+X=X,X>0,X>1!(DIC'="^DIC(") Q
|
||
|
|
K X
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
; 741 Either key values are null, or creates a duplicate key.
|
||
|
|
;
|