Return to DICM2.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DICM2.m, revision 1.1.1.1

1.1       snw         1: DICM2  ;SFISC/XAK-LOOKUP FOR VAR PTR ;8/13/90  3:46 PM
                      2:        ;;21.0;VA FileMan;;Dec 28, 1994
                      3:        ;Per VHA Directive 10-93-142, this routine should not be modified.
                      4:        ;
                      5:        S DIVDO=+DO(2),DIVDIC=DIC,DIVY=%Y N DIADD,DS
                      6:        F %="DR","S","A","V" I $D(DIC(%)) S DIV(%)=DIC(%)
                      7:        K DIC("W"),DIC("S"),DIC("DR"),DO,DUOUT S DIEX=X G ALL:X'["."
                      8:        I $P(X,".",2,999)="" S Y=-1 G Q
                      9: V      S DIVP=$P(DIEX,"."),A9=1
                     10:        I DIVP="" G ALL
                     11:        I $D(^DD(DIVDO,DIVY,"V","P",DIVP)) S (DIVP,DIVPDIC)=+$O(^(DIVP,0)),DIVPDIC=$S($D(^DD(DIVDO,DIVY,"V",DIVP,0)):^(0),1:"") G Q:'DIVPDIC S X=$P(DIEX,".",2,999),A9=0 D ^DICM3 G Q
                     12:        S DIVP2="",DIVP=$P(DIEX,".")
                     13:        F %=0:0 S DIVP2=$O(^DD(DIVDO,DIVY,"V","M",DIVP2)) Q:DIVP2=""  I $P(DIVP2,DIVP)="" S (DIVP,DIVPDIC)=+$O(^(DIVP2,0)),DIVPDIC=$S($D(^DD(DIVDO,DIVY,"V",DIVP,0)):^(0),1:""),X=$P(DIEX,".",2,999),A9=0 G Q:'DIVPDIC D ^DICM3 G Q:Y>0 S DIVP=$P(DIEX,".")
                     14:        F DIVP=0:0 S DIVP=+$O(^DD(DIVDO,DIVY,"V",DIVP)) Q:'DIVP  I $D(^(DIVP,0)) S DIVPDIC=^(0) I $D(^DIC(+DIVPDIC,0)) S %=$P(^(0),U) I $P(%,$P(DIEX,"."))="" S X=$P(DIEX,".",2,999),A9=0 D ^DICM3 G Q:Y>0 S X=DIEX
                     15:        I A9 S X=DIEX,A9=0 G ALL
                     16:        K X G Q
                     17: ALL    F DIVP1=0:0 S DIVP1=+$O(^DD(DIVDO,DIVY,"V","O",DIVP1)) Q:'DIVP1  S DIVP=+$O(^(DIVP1,0)) I $D(^DD(DIVDO,DIVY,"V",DIVP,0)) S DIVPDIC=^(0) D ^DICM3 G Q:Y>0!(%<0)!$D(DUOUT) S X=DIEX
                     18:        G Q:DICR>1!$D(DICR(DICR,"V")) S DICR(DICR,"V")=1 K DIVP G ALL
                     19:        ;
                     20:        ;
                     21: Q      I '$D(DUOUT),Y<0,DICR<2,'$D(DICR(DICR,"V")) S DICR(DICR,"V")=1 K DIVP G V
                     22:        K:Y<0 X S DICR(DICR,"V")=1
                     23:        F %="DR","S","A","V" I $D(DIV(%)) S DIC(%)=DIV(%)
                     24: QQ     K:Y DICR(DICR,6)
                     25:        K DUOUT,DIVP,DIVDIC,DIVY,DO,DIVDO,DIVPDIC,DIEX,DIVP1,DIVP2,DIV,A9 Q
                     26:        ;
                     27: NAME   ;DETERMINE EXTERNAL FORM FROM INTERNAL FOR VP
                     28:        S DINAME=DIY Q:'DIY  S %=$P(DIY,";",2),DINAME="^"_%_+DIY_",0)",DINAME=$S($D(@DINAME)#2:$P(^(0),U,1),1:DIY),%=$S($D(@("^"_%_"0)")):$P(^(0),U,2),1:"") Q:%=""
                     29:        I %["P"!(%["S")!(%["D") S C=$P(^DD(+%,.01,0),U,2),%YYY=DIY,%YY=Y,Y=DINAME D Y^DIQ S DINAME=Y,DIY=%YYY,Y=%YY,C="," K %YY,%YYY
                     30:        Q
                     31: DQ     ;