Return to DICM.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DICM.m, revision 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