| [613] | 1 | DICM2 ;SFISC/XAK/TKW-LOOKUP FOR VAR PTR ;2/15/00 14:55
|
|---|
| 2 | ;;22.0;VA FileMan;**4,31**;Mar 30, 1999
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | N A9,DIEX,DISAVIEX,DIV,DIVDIC,DIVDO,DIVP,DIVP1,DIVP2,DIVPDIC,DIVY,DIASKOK
|
|---|
| 6 | S DIVDO=+DO(2),DIVDIC=DIC,DIVY=%Y N DIADD,DS
|
|---|
| 7 | F %="DR","W","P","V","A" I $D(DIC(%)) M DIV(%)=DIC(%) K DIC(%)
|
|---|
| 8 | I $D(DIC("S")) S DICR(DICR,"S")=DIC("S") K DIC("S")
|
|---|
| 9 | K DO,DUOUT S (DIEX,DISAVIEX)=X
|
|---|
| 10 | I '$D(DICR(DICR,"V")) D
|
|---|
| 11 | . I DIC(0)'["L" S DICR(DICR,"V")=1 Q
|
|---|
| 12 | . S:DICR>1 DICR(DICR,"V")=1 Q
|
|---|
| 13 | G ALL:X'["."
|
|---|
| 14 | I $P(X,".",2,999)="" S Y=-1 G ALL
|
|---|
| 15 | V S DIVP=$P(DIEX,"."),A9=1
|
|---|
| 16 | I DIVP="" G ALL
|
|---|
| 17 | 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
|
|---|
| 18 | S DIVP2="",DIVP=$P(DIEX,".")
|
|---|
| 19 | F %=0:0 S DIVP2=$O(^DD(DIVDO,DIVY,"V","M",DIVP2)) Q:DIVP2="" I $P(DIVP2,DIVP)="" D G Q:'DIVPDIC D ^DICM3 G Q:Y>0 S DIVP=$P(DIEX,".")
|
|---|
| 20 | . S (DIVP,DIVPDIC)=+$O(^DD(DIVDO,DIVY,"V","M",DIVP2,0))
|
|---|
| 21 | . S DIVPDIC=$S($D(^DD(DIVDO,DIVY,"V",DIVP,0)):^(0),1:"")
|
|---|
| 22 | . S X=$P(DIEX,".",2,999),A9=0 Q
|
|---|
| 23 | 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
|
|---|
| 24 | I A9,$P(DIEX,".")?.E1L.E S $P(DIEX,".")=$$OUT^DIALOGU($P(DIEX,"."),"UC") G V
|
|---|
| 25 | I A9 S X=DISAVIEX,A9=0 G ALL
|
|---|
| 26 | K X G Q
|
|---|
| 27 | 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
|
|---|
| 28 | G Q:DICR>1!$D(DICR(DICR,"V")) S DICR(DICR,"V")=1 K DIVP G ALL
|
|---|
| 29 | ;
|
|---|
| 30 | ;
|
|---|
| 31 | Q I '$D(DUOUT),Y<0,DICR<2,'$D(DICR(DICR,"V")) S DICR(DICR,"V")=1 K DIVP G V
|
|---|
| 32 | K:Y<0 X S DICR(DICR,"V")=1
|
|---|
| 33 | F %="DR","W","P","V","A" I $D(DIV(%)) M DIC(%)=DIV(%)
|
|---|
| 34 | I $D(DICR(DICR,"S")) S DIC("S")=DICR(DICR,"S")
|
|---|
| 35 | QQ K:Y DICR(DICR,6)
|
|---|
| 36 | K DUOUT,DIVP,DIVDIC,DIVY,DO,DIVDO,DIVPDIC,DIEX,DIVP1,DIVP2,DIV,A9 Q
|
|---|
| 37 | ;
|
|---|
| 38 | NAME ;DETERMINE EXTERNAL FORM FROM INTERNAL FOR VP
|
|---|
| 39 | S DINAME=DIY Q:DIY'?1.N1";"1.E
|
|---|
| 40 | N % 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:"")
|
|---|
| 41 | Q:%=""
|
|---|
| 42 | I %["P"!(%["S")!(%["D")!(%["V") S DINAME=$$EXT^DIC2(+%,.01,DINAME)
|
|---|
| 43 | Q
|
|---|
| 44 | ;
|
|---|
