DICM2 ;SFISC/XAK/TKW-LOOKUP FOR VAR PTR ;2/15/00 14:55
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
N A9,DIEX,DISAVIEX,DIV,DIVDIC,DIVDO,DIVP,DIVP1,DIVP2,DIVPDIC,DIVY,DIASKOK
S DIVDO=+DO(2),DIVDIC=DIC,DIVY=%Y N DIADD,DS
F %="DR","W","P","V","A" I $D(DIC(%)) M DIV(%)=DIC(%) K DIC(%)
I $D(DIC("S")) S DICR(DICR,"S")=DIC("S") K DIC("S")
K DO,DUOUT S (DIEX,DISAVIEX)=X
I '$D(DICR(DICR,"V")) D
. I DIC(0)'["L" S DICR(DICR,"V")=1 Q
. S:DICR>1 DICR(DICR,"V")=1 Q
G ALL:X'["."
I $P(X,".",2,999)="" S Y=-1 G ALL
V S DIVP=$P(DIEX,"."),A9=1
I DIVP="" G ALL
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
S DIVP2="",DIVP=$P(DIEX,".")
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,".")
. S (DIVP,DIVPDIC)=+$O(^DD(DIVDO,DIVY,"V","M",DIVP2,0))
. S DIVPDIC=$S($D(^DD(DIVDO,DIVY,"V",DIVP,0)):^(0),1:"")
. S X=$P(DIEX,".",2,999),A9=0 Q
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
I A9,$P(DIEX,".")?.E1L.E S $P(DIEX,".")=$$OUT^DIALOGU($P(DIEX,"."),"UC") G V
I A9 S X=DISAVIEX,A9=0 G ALL
K X G Q
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
G Q:DICR>1!$D(DICR(DICR,"V")) S DICR(DICR,"V")=1 K DIVP G ALL
;
;
Q I '$D(DUOUT),Y<0,DICR<2,'$D(DICR(DICR,"V")) S DICR(DICR,"V")=1 K DIVP G V
K:Y<0 X S DICR(DICR,"V")=1
F %="DR","W","P","V","A" I $D(DIV(%)) M DIC(%)=DIV(%)
I $D(DICR(DICR,"S")) S DIC("S")=DICR(DICR,"S")
QQ K:Y DICR(DICR,6)
K DUOUT,DIVP,DIVDIC,DIVY,DO,DIVDO,DIVPDIC,DIEX,DIVP1,DIVP2,DIV,A9 Q
;
NAME ;DETERMINE EXTERNAL FORM FROM INTERNAL FOR VP
S DINAME=DIY Q:DIY'?1.N1";"1.E
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:"")
Q:%=""
I %["P"!(%["S")!(%["D")!(%["V") S DINAME=$$EXT^DIC2(+%,.01,DINAME)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICM2 2523 printed Sep 02, 2024@19:31:38 Page 2
DICM2 ;SFISC/XAK/TKW-LOOKUP FOR VAR PTR ;2/15/00 14:55
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 NEW A9,DIEX,DISAVIEX,DIV,DIVDIC,DIVDO,DIVP,DIVP1,DIVP2,DIVPDIC,DIVY,DIASKOK
+8 SET DIVDO=+DO(2)
SET DIVDIC=DIC
SET DIVY=%Y
NEW DIADD,DS
+9 FOR %="DR","W","P","V","A"
IF $DATA(DIC(%))
MERGE DIV(%)=DIC(%)
KILL DIC(%)
+10 IF $DATA(DIC("S"))
SET DICR(DICR,"S")=DIC("S")
KILL DIC("S")
+11 KILL DO,DUOUT
SET (DIEX,DISAVIEX)=X
+12 IF '$DATA(DICR(DICR,"V"))
Begin DoDot:1
+13 IF DIC(0)'["L"
SET DICR(DICR,"V")=1
QUIT
+14 if DICR>1
SET DICR(DICR,"V")=1
QUIT
End DoDot:1
+15 if X'["."
GOTO ALL
+16 IF $PIECE(X,".",2,999)=""
SET Y=-1
GOTO ALL
V SET DIVP=$PIECE(DIEX,".")
SET A9=1
+1 IF DIVP=""
GOTO ALL
+2 IF $DATA(^DD(DIVDO,DIVY,"V","P",DIVP))
SET (DIVP,DIVPDIC)=+$ORDER(^(DIVP,0))
SET DIVPDIC=$SELECT($DATA(^DD(DIVDO,DIVY,"V",DIVP,0)):^(0),1:"")
if 'DIVPDIC
GOTO Q
SET X=$PIECE(DIEX,".",2,999)
SET A9=0
DO ^DICM3
GOTO Q
+3 SET DIVP2=""
SET DIVP=$PIECE(DIEX,".")
+4 FOR %=0:0
SET DIVP2=$ORDER(^DD(DIVDO,DIVY,"V","M",DIVP2))
if DIVP2=""
QUIT
IF $PIECE(DIVP2,DIVP)=""
Begin DoDot:1
+5 SET (DIVP,DIVPDIC)=+$ORDER(^DD(DIVDO,DIVY,"V","M",DIVP2,0))
+6 SET DIVPDIC=$SELECT($DATA(^DD(DIVDO,DIVY,"V",DIVP,0)):^(0),1:"")
+7 SET X=$PIECE(DIEX,".",2,999)
SET A9=0
QUIT
End DoDot:1
if 'DIVPDIC
GOTO Q
DO ^DICM3
if Y>0
GOTO Q
SET DIVP=$PIECE(DIEX,".")
+8 FOR DIVP=0:0
SET DIVP=+$ORDER(^DD(DIVDO,DIVY,"V",DIVP))
if 'DIVP
QUIT
IF $DATA(^(DIVP,0))
SET DIVPDIC=^(0)
IF $DATA(^DIC(+DIVPDIC,0))
SET %=$PIECE(^(0),U)
IF $PIECE(%,$PIECE(DIEX,"."))=""
SET X=$PIECE(DIEX,".",2,999)
SET A9=0
DO ^DICM3
if Y>0
GOTO Q
SET X=DIEX
+9 IF A9
IF $PIECE(DIEX,".")?.E1L.E
SET $PIECE(DIEX,".")=$$OUT^DIALOGU($PIECE(DIEX,"."),"UC")
GOTO V
+10 IF A9
SET X=DISAVIEX
SET A9=0
GOTO ALL
+11 KILL X
GOTO Q
ALL FOR DIVP1=0:0
SET DIVP1=+$ORDER(^DD(DIVDO,DIVY,"V","O",DIVP1))
if 'DIVP1
QUIT
SET DIVP=+$ORDER(^(DIVP1,0))
IF $DATA(^DD(DIVDO,DIVY,"V",DIVP,0))
SET DIVPDIC=^(0)
DO ^DICM3
if Y>0!(%<0)!$DATA(DUOUT)
GOTO Q
SET X=DIEX
+1 if DICR>1!$DATA(DICR(DICR,"V"))
GOTO Q
SET DICR(DICR,"V")=1
KILL DIVP
GOTO ALL
+2 ;
+3 ;
Q IF '$DATA(DUOUT)
IF Y<0
IF DICR<2
IF '$DATA(DICR(DICR,"V"))
SET DICR(DICR,"V")=1
KILL DIVP
GOTO V
+1 if Y<0
KILL X
SET DICR(DICR,"V")=1
+2 FOR %="DR","W","P","V","A"
IF $DATA(DIV(%))
MERGE DIC(%)=DIV(%)
+3 IF $DATA(DICR(DICR,"S"))
SET DIC("S")=DICR(DICR,"S")
QQ if Y
KILL DICR(DICR,6)
+1 KILL DUOUT,DIVP,DIVDIC,DIVY,DO,DIVDO,DIVPDIC,DIEX,DIVP1,DIVP2,DIV,A9
QUIT
+2 ;
NAME ;DETERMINE EXTERNAL FORM FROM INTERNAL FOR VP
+1 SET DINAME=DIY
if DIY'?1.N1";"1.E
QUIT
+2 NEW %
SET %=$PIECE(DIY,";",2)
SET DINAME="^"_%_+DIY_",0)"
SET DINAME=$SELECT($DATA(@DINAME)#2:$PIECE(^(0),U,1),1:DIY)
SET %=$SELECT($DATA(@("^"_%_"0)")):$PIECE(^(0),U,2),1:"")
+3 if %=""
QUIT
+4 IF %["P"!(%["S")!(%["D")!(%["V")
SET DINAME=$$EXT^DIC2(+%,.01,DINAME)
+5 QUIT
+6 ;
