source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICM2.m@ 1710

Last change on this file since 1710 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.2 KB
RevLine 
[613]1DICM2 ;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
15V 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
27ALL 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 ;
31Q 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")
35QQ K:Y DICR(DICR,6)
36 K DUOUT,DIVP,DIVDIC,DIVY,DO,DIVDO,DIVPDIC,DIEX,DIVP1,DIVP2,DIV,A9 Q
37 ;
38NAME ;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 ;
Note: See TracBrowser for help on using the repository browser.