- 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 Jan 18, 2025@03:47:18 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 ;