Return to DICM.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DICM.m, revision 1.1.1.1

1.1       snw         1: DICM   ;SFISC/GFT,XAK-MULTIPLE LOOKUP FOR FLDS WHICH MUST BE TRANSFORMED ;2/17/93 12:19 ;
                      2:        ;;21.0;VA FileMan;;Dec 28, 1994
                      3:        ;Per VHA Directive 10-93-142, this routine should not be modified.
                      4:        S:'$D(DICR(1)) DICR=0 I $A(X)=34,X?.E1"""" G N
                      5:        G:$D(^DD(+DO(2),0,"LOOK")) @^("LOOK") I DIC(0)["U" S DD=0 G W
                      6: R      S %="B",Y=+DO(2),%Y=.01,DD=0 G 1
                      7: Z      S:%=-1 %="" S %=$O(^DD(+DO(2),0,"IX",%)) S:%="" %=-1 S Y=$O(^(%,0)) S:Y="" Y=-1 S %Y=$O(^(Y,0)),DD=1 S:%Y="" %Y=-1
                      8: 1      G 2:Y<0,Z:$D(DICR(U,Y,%Y)),Z:D'=%&(DIC(0)'["M"),Z:'$D(^DD(Y,%Y,0)) S DICR(U,Y,%Y)=0,DS=^(0) I $D(^(7)) D RS K DS X ^(7) G Y
                      9:        S DIX=Y F Y="P","D","S","V",-1 I $P(DS,U,2)[Y D A D:'Y ^DICM1,D Q
                     10: Y      G R:Y<0
                     11: 2      G K:Y+1 I X?.E1L.E,DIC(0)'["X" D %,LC^DICM1 G K:Y+1
                     12:        S DS="",DIX=$P(X,",",1) F %=2:1 S DD=$P(X,",",%) I DD'["""" S:$A(DD)=32 DD=$E(DD,2,999) Q:$L(DD)*2+$L(DS)>200!(DD="")  S DS=DS_" I %?.E1P1"""_DD_""".E!(D'=""B""&(%?1"""_DD_""".E))"
                     13:        I DS]"",DIC(0)'["X" D % S X=DIX,DS="S %=$P(^(0),U,1)"_DS,DIC(0)=DIC(0)_"D" D 7 G K:Y+1
                     14:        I $L(X)>30 D % S Y="DICR("_DICR_")",DS=$S(DIC(0)["X":"I $P(^(0),U,1)="_Y,1:"I '$L($P(^(0),"_Y_",1))"),X=$E(X,1,30) S:DIC(0)["O"&(DIC(0)'["E") DS=DS_",'$L($P($P(^(0),U),"_Y_",2))" D 7
                     15: K      S DD=$D(DICR(DICR,6)) K:'DICR DICR
                     16:        I Y+1 K DIC("W") G R^DIC2
                     17: W      D U G:'$T NL:DIC(0)["N",DD I DO(2)'["Z" S Y=0 F DS=1:1 S @("Y=$O("_DIC_"Y))") S:Y="" Y=-1 Q:Y'>0  W:DIC(0)["E"&(DS#20=0) ".." I $D(^(Y,0)),$P(^(0),U)=X X:$D(DIC("S")) DIC("S") I  S DIY="" G GOT^DIC2
                     18: NL     I '$D(DICR) D NQ G GOT^DIC2:$T
                     19: DD     G B:DD
                     20: L      I DIC(0)["L" K DD G ^DICN
                     21: B      G O^DIC1
                     22:        ;
                     23: N      D RS S X=$E(X,2,$L(X)-1),DS=^DD(+DO(2),.01,0),%=D,%Y=.01 F Y="P","D","S","V" I $P(DS,U,2)[Y K:Y="P" DO D ^DICM1 Q
                     24:        S Y=-1 D L:$D(X),E G B:Y<0,2
                     25:        ;
                     26: A      G %:'DD I '$D(^DD(DIX,%Y,1,DD)) S DD=$O(^(DD)) G A:DD>0 S (DD,Y)=-1 Q
                     27:        I $S($D(^(DD,0)):$P(^(0),U,3,9)]"",1:1) S DD=DD+1 G A
                     28: %      S DICR(DICR+1,4)=% I %'="B"!(DIC(0)'["L") S DICR(DICR+1,8)=1
                     29:        I $D(DF) S DICR(DICR+1,9)=DF K DF
                     30: RS     S DICR=DICR+1,DICR(DICR)=X,DICR(DICR,0)=DIC(0),DD="A" D DZ S DD="Q"
                     31: DZ     S DIC(0)=$P(DIC(0),DD,1)_$P(DIC(0),DD,2) Q
                     32:        ;
                     33: D      S (D,DF)=DICR(DICR,4),DD="M" S:D="B"&(DO(2)'["D") DIC(0)=DIC(0)_$S(DIC(0)["E"&(DO(2)["P"!(DO(2)["S")):"OX",1:"S") D DZ I $D(DS),$P(DS,U,2)["V" S DD="A" D DZ
                     34: RCR    S:'$D(DIDA) DICRS=1
                     35: DIC    ;
                     36:        I $D(DICR(DICR,8)) S DD="L" D DZ
                     37:        S Y=-1 I $D(X),$L(X)<31 D RENUM^DIC1 K DIDA
                     38:        S:DIC(0)["L" DICR(DICR-1,6)=1 K:$D(DICR(DICR,4)) DF
                     39: E      S D="B",%=DICR,X=DICR(%),DIC(0)=DICR(%,0),DICR=%-1 S:$D(DICR(%,9)) (D,DF)=DICR(%,9) K DICRS,DICR(%) D DO^DIC1:'$D(DO) Q
                     40:        ;
                     41: U      I @("$O("_DIC_"""A[""))=""""")
                     42:        Q
                     43:        ;
                     44: NQ     I $L(X)<14,X?.NP,+X=X,@("$D("_DIC_"X,0))") S Y=X D S^DIC
                     45:        Q
                     46:        ;
                     47: SOUNDEX        I DIC(0)["E",'$D(DICRS) W "  " D RS,SOU S DD="L" D DZ,RCR Q:Y>0
                     48:        G R
                     49:        ;
                     50: 7      S Y=-1,%=$S($D(DIC("S")):DIC("S"),1:1) I $D(DS),'$D(DIC("S1")) S DIC("S")=DS,DD="L" S:'% DIC("S")=DIC("S")_" X DIC(""S1"")",DIC("S1")=% D:X]"" DZ,F^DIC K DIC("S") S:$D(DIC("S1")) DIC("S")=DIC("S1") K DIC("S1")
                     51:        G E
                     52:        ;
                     53: SOU    G SOU^DICM1