Return to DICN1.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DICN1	;SFISC/GFT-PROCESS DIC("DR") ;10/4/94  11:09
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: 	K DIDA,DICRS,Y,%RCR
    5: 	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)=""
    6: 	S DZ="W !?3,$S("""_$P(DO,U)_"""'=$P(DQ(DQ),U):"""_$P(DO,U)_""",1:"""")_"" ""_$P(DQ(DQ),U)_"": """
    7: 	I $D(DIC("DR")) S DD=DIC("DR")
    8: 	E  S DD="",%=0,Y=0 F  S Y=$O(^DD(+DO(2),0,"ID",Y)) S:Y="" Y=-1 Q:Y'>0  D CKID I '$D(%) D W G BAD
    9: 	S %RCR="RCR^DICN1" D STORLIST^%RCR G D^DICN:$D(Y)<9
   10: BAD	S:$D(D)#2 DA=D K Y I '$D(DO(1)) S Y=-1 G Q^DIC2
   11: 	K DO G A^DIC
   12: 	;
   13: CKID	I $D(DUZ(0)),DUZ(0)'="@",$D(^DD(+DO(2),Y,9)),^(9)]"" F %=1:1 I DUZ(0)[$E(^(9),%) Q:$L(^(9))'<%  K:$P(^(0),U,2)["R" % G Q
   14: 	S DD=DD_Y_";"
   15: Q	Q
   16: 	;
   17: W	S A1="T",DST="SORRY!  A VALUE FOR '"_$P(^(0),U,1)_"' MUST BE ENTERED," W:'$D(DDS) ! D H
   18: 	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
   19: 	S %RCR="D^DICN1" D STORLIST^%RCR Q
   20: 	;
   21: H	I $D(DDS) S DDH=$S($D(DDH):DDH+1,1:1),DDH(DDH,A1)=DST K A1,DST Q
   22: 	W DST K A1,DST Q
   23: RCR	;
   24: 	K DR,DIADD,DQ,DG,DE,DO S DIE=DIC,DR=DD,DIE("W")=DZ K DIC I $D(DIE("NO^")) S %RCR("DIE(""NO^"")")=DIE("NO^")
   25: 	S DIE("NO^")="OUTOK"
   26: 	D:$D(DDS) CLRMSG^DDS D ^DIE K DIE("W"),DIE("NO^")
   27: 	D:$D(DDS)
   28: 	. I $Y<IOSL D CLRMSG^DDS Q
   29: 	. D REFRESH^DDSUTL
   30: A	I '$D(DA) S Y(0)=0 Q
   31: 	Q:$D(Y)<9&'$D(DTOUT)&'$D(DIC("W"))
   32: ZAP	S DIK=DIE,A1="T",DST=$C(7)_"   <'"_$P(@(DIK_"DA,0)"),U,1)_"' DELETED>" W:'$D(DDS) !?3 D H D:$D(DDS) LIST^DDSU
   33: 	D ^DIK S Y(0)=0 K DST Q
   34: 	;
   35: D	S DIE=DIC G ZAP
   36: 	;
   37: RIX	;
   38: 	K %RCR F %="D0","Y","DIC","DIU","DIV","DO","D","DD","DICR","X" S %RCR(%)=""
   39: 	S %RCR="RR^DICN1",DZ=^(1) D STORLIST^%RCR G IX^DICN
   40: 	;
   41: RR	X DZ Q
   42: 	;
   43: NUM	;
   44: 	I '$D(DD),DIC="^DIC(",'$D(DO(3)) D DIC G F2^DICN
   45: 	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
   46: 	S DST="   "_$P(DO,U)_" "_$P(^DD(+Y,.001,0),U)_": " S:X DST=DST_X_"// " I '$D(DDS) W !,DST K DST R Y:$S($D(DTIME):DTIME,1:300) E  S DTOUT=1,Y=U W $C(7)
   47: 	I $D(DDS) S A1="Q",DST=3_U_DST D H,LIST^DDSU S Y=$S($D(DTOUT):U,1:%) K %
   48: 	I Y="?" G WR
   49: 	G BAD^DIC1:Y[U S:Y]"" X=Y D N I '$D(X) W $C(7) W:'$D(DDS) "??" G WR
   50: 	G LOCK^DICN
   51: 	;
   52: WR	S DST="" S:$D(^DD(+DO(2),.001,3)) DST="     "_^(3)
   53: 	I '$D(DDS) W:DST]"" !?5,DST X:$D(^(4)) ^(4) K DST
   54: 	I $D(DDS) S A1=+Y D H S:$D(^(4)) DDH("ID")=^(4) D LIST^DDSU
   55: 	G F1^DICN
   56: 	;
   57: N	X:$D(^DD(+$P(DO,U,2),.001,0)) $P(^(0),U,5,99) I $D(X),$L(X)<15,+X=X,X>0,X>1!(DIC'="^DIC(") Q
   58: 	K X Q
   59: 	;
   60: DS	I '$D(DISMN) S DISMN=1000 D OS^DII:'$D(DISYS) S DISMN=$S(+$P(^DD("OS",DISYS,0),U,2):$P(^(0),U,2),1:DISMN)
   61: 	Q
   62: DIC	;
   63: 	S DO(3)=1
   64: 	I $S($D(^VA(200,DUZ,1))#2:1,1:$D(^DIC(3,DUZ,1))#2),$P(^(1),U) S DIY=.1,X=+$P(^(1),U) Q
   65: 	I $D(^DD("SITE",1)),X\1000'=^(1) S X=^(1)*1000,%=0
   66: 	Q