DICM ;SFISC/GFT,XAK,TKW-MULTIPLE LOOKUP FOR FLDS WHICH MUST BE TRANSFORMED ;27OCT2012
;;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.
;
I '$D(DICR(1)),DIC(0)'["T" N DICR S DICR=0
I $A(X)=34,X?.E1"""" G N
I $G(^DD(+DO(2),0,"LOOK"))]"",^("LOOK")'="SOUNDEX" G @^("LOOK")
I DIC(0)["U" S DD=0 G W
I DIC(0)["T" G 2
R N DIFLAGS S DIFLAGS="4l"_$P("M^",U,DIC(0)["M")
N DIFORCE D
. S DIFORCE=0 I DIC(0)'["M"!($D(DID)) S DIFORCE=1
. S DIFORCE(0)=$S(DIC(0)'["M":DINDEX,$D(DID):DID,1:"*"),DIFORCE(1)=1
F D 1 I DINDEX=""!(Y>0)!($G(DTOUT))!($G(DIROUT)) Q ;LOOP THRU ALL THE INDEXES!
G 2
;
1 N DS,%Y,DIV
I $G(DINDEX("IXFILE")) S Y=DINDEX(1,"FILE"),%Y=DINDEX(1,"FIELD")
E S Y=$O(^DD(+DO(2),0,"IX",DINDEX,0)) S:Y="" Y=-1 S %Y=+$O(^(Y,0))
I Y=-1,DINDEX="B" S Y=+DO(2),%Y=.01
S:Y="" Y=-1 S:%Y="" %Y=-1
I $D(DICR(U,Y,%Y,DINDEX)) S Y=-1 ;HAVE WE ALREADY TRIED THIS INDEX?
E I %Y=.01,DINDEX'="B",Y=+DO(2),$D(DICR(U,Y,%Y,"B")),$G(DINDEX(1,"TRANCODE"))="" S Y=-1 ;!
I Y'<0 D
. S DS=$G(^DD(Y,%Y,0)) I DS="" S Y=-1 Q
. S %=DINDEX,DICR(U,Y,%Y,DINDEX)=0
. I $D(^DD(Y,%Y,7)) D RS K DS X ^(7) Q
. I $G(DINDEX("IXTYPE"))="S" D A,SOU^DICM1,D Q:Y>0 S Y=-1 Q
. S DIX=Y,Y=$P(DS,U,2) I Y["P",DIC(0)'["L",$T(ORDERQ^DICUIX2)]"",$$ORDERQ^DICUIX2(+$P(Y,"P",2)) S Y="" ;TRICK TO SPEED LOOKUP OF ORDERS!
. S Y=$S(Y["P":"P",Y["D":"D",Y["S":"S",Y["V":"V",1:"") ;TRANSFORMATION WILL BE NECESSARY IF X-REF'D FIELD IS DATE, POINTER, SET OR VARIABLE-POINTER
. I Y]"" D A D:'Y ^DICM1,D Q:Y>0 S Y=-1 Q
. I $G(DINDEX(1,"TRANCODE"))]"" S Y="T" D A,^DICM1 N DITRANX S DITRANX=1 D D
. Q:Y>0 S Y=-1 Q
Q:Y>0!(DIC(0)["T") D
. K DIV M DIV=X S DIV(1)=X N X,Y
. D NXTINDX^DICF2(.DINDEX,.DIFORCE,.DIFILEI,DIFLAGS,.DIV,"*") Q
Q
;
2 D D^DIC0 S %=D ;HERE'S WHERE WE TRY ALTERNATE LOOKUPS: UPPER CASE, COMMA-PIECING, TRUNCATE LONG INPUT
G K:Y>0!($G(DIROUT))
I X?.E1L.E,DIC(0)'["X" D G K:$G(DIROUT) ;CONVERT TO UPPER-CASE
. D % N DIFILEI,DINDEX
. S DIC(0)=$TR(DIC(0),"L"),X=$$UP^DILIBF(X) S:$G(DILONGX) DICR(DILONGX,"ORG")=X
. D DIC Q
I Y'>0,X["," S DS="",DIX=$P(X,",") I DIC(0)'["X",$L(DIX)<31 D G K:$G(DIROUT) ;COMMA-PIECING
. F %=2:1 S DD=$P(X,",",%) I DD'["""" D Q:DD=""
. . F Q:$A(DD)-32 S DD=$E(DD,2,999)
. . F Q:$A(DD,$L(DD))-32 S DD=$E(DD,1,$L(DD)-1)
. . I $L(DD)*2+$L(DS)>200!(DD="") S DD="" Q
. . S DS=DS_" I %?.E1P1"""_DD_""".E!(D'=""B""&(%?1"""_DD_""".E))" Q
. Q:DS="" S %=D
. D % S X=DIX N DILONGX
. S DS="S %=$P(^(0),U)"_DS,DIC(0)=DIC(0)_"D" D 7 Q
I Y'>0,$L(X)>30 D ;LONG DATA
. N DILONGX
. S %=D D % S DILONGX=DICR,Y="DICR("_DICR_")",DICR(DICR,"ORG")=X
. S DS=$S(DIC(0)["X":"I DIVAL="_Y,1:"I '$L($P(DIVAL,"_Y_"))")
. S:DIC(0)["O"&(DIC(0)'["E") DS=DS_",'$L($P(DIVAL,"_Y_",2))"
. D 7 I Y>0!(X'?.E1L.E)!(DIC(0)["X") Q
. S %=D D % S (X,DICR(DICR,"ORG"))=$$UP^DILIBF(X)
. S Y="DICR("_DICR_",""ORG"")"
. S DS="I '$L($P(DIVAL,"_Y_"))" S:DIC(0)["O"&(DIC(0)'["E") DS=DS_",'$L($P(DIVAL,"_Y_",2))"
. D 7
;
K S DICR=+$G(DICR),DD=$D(DICR(DICR,6)) K:'DICR DICR
I Y>0 K DIC("W") D R^DIC2 Q
I $G(DTOUT)!($G(DIROUT)) Q
W I @("$O("_DIC_"""A[""))]""""") G NL:DIC(0)["N",DD
I DO(2)'["Z" S Y=0 D Q:Y>0!($G(DIROUT))
DINUM .I $G(DINDEX("1","FIELD"))=.01,X?1.15NP,$P($G(^DD(+DO(2),.01,0)),U,5,99)["DINUM=X",$P($G(@(DIC_"X,0)")),U)=X D Q:Y>0
..S Y=X I 1 X:$D(DIC("S")) DIC("S") I S DIY="",DS=1 N DZ,DD D ADDKEY^DIC3,GOT^DIC2 Q
..S Y=0
.N DIOUT S DIOUT=0 F DS=1:1 S @("Y=$O("_DIC_"Y))") D Q:DIOUT ;GO THRU THE WHOLE FILE BECAUSE WE HAVE NO CROSS-REFERENCE! (SEE ..DOTS.. BELOW)
. . I 'Y S Y=-1,DIOUT=1 Q
. . W:DIC(0)["E"&(DS#20=0) ".."
. . I $D(@(DIC_Y_",0)")),$P(^(0),U)=X X:$D(DIC("S")) DIC("S") I S DIOUT=1
. . I DIOUT S DIY="",DS=1 N DZ,DD D ADDKEY^DIC3,GOT^DIC2
. . Q
NL I '$G(DICR) D NQ I $T D Q:Y>0!($G(DTOUT))!($G(DIROUT))
. N:'$G(DIASKOK) DIASKOK S (DS,DIASKOK)=1 N DZ,DD
. D ADDKEY^DIC3,GOT^DIC2 Q
DD S Y=-1 I DD D BAD^DIC1 Q
L I DIC(0)["L" K DD G ^DICN
B D BAD^DIC1 Q
;
N D RS S X=$E(X,2,$L(X)-1),%=D D
. I DINDEX("#")>1 S %Y=+$G(DINDEX(1,"FIELD")),DS=$G(^DD(+$G(DINDEX(1,"FILE")),%Y,0)) Q:DS]""
. S DS=^DD(+DO(2),.01,0),%Y=.01 Q
F Y="P","D","S","V" I $P(DS,U,2)[Y K:Y="P" DO D ^DICM1 S:$D(X)#2 DS("INT")=X Q
I $D(X),DINDEX("#")>1 S X(1)=X
S Y=-1 D L:$D(X),E
I Y'>0 K DUOUT D BAD^DIC1 Q
G 2
;
A ; Set variables needed for transforming date/set/ptr/var.ptr
S DICR(DICR+1,4)=%
D % K DF,DID,DINUM Q
;
% ; Set variables up before doing lookup w/transformed value
I DIC(0)'["L" S DICR(DICR+1,8)=1
E I '$$OKTOADD^DICM0(.DIFILEI,.DINDEX,.DIFINDER) S DICR(DICR+1,8)=1
I $G(DINUM)]"" S DICR(DICR+1,10)=DINUM
I $D(DF) S DICR(DICR+1,9)=DF S:$G(DID)]"" DICR(DICR+1,9.1)=$G(DID(1))_U_DID
RS S DICR=DICR+1,DICR(DICR)=X,DICR(DICR,0)=DIC(0),DIC(0)=$TR(DIC(0),"A"),DIC(0)=$TR(DIC(0),"Q") Q
;
D S:$G(DICR(DICR,10))]"" DINUM=DICR(DICR,10)
S (D,DF)=DICR(DICR,4) D
. N T S T=$P($G(DS),U,2)
. S DIC(0)=$TR(DIC(0),"M","") I T["V" S DIC(0)=$TR(DIC(0),"A","")
. I D="B",T'["D",'$G(DITRANX) S DIC(0)=DIC(0)_"s"
. I T["P"!(T["V")!(T["S") S DIC(0)=DIC(0)_"X"
. Q
I DICR(DICR,4)=DINDEX N I M I=DINDEX N DINDEX M DINDEX=I K I S DINDEX("START")=DINDEX
E N DINDEX D
. S (DINDEX,DINDEX("START"))=DICR(DICR,4),DINDEX("WAY")=1
. D INDEX^DICUIX(.DIFILEI,DIFLAGS,.DINDEX,"",.DIVALUE) Q
I DINDEX("#")>1 S (DINDEX(1),DINDEX(1,"FROM"),DINDEX(1,"PART"))=$G(X)
RCR S:'$D(DIDA) DICRS=1
DIC ;
I $D(DICR(DICR,8)) S DIC(0)=$TR(DIC(0),"L")
S Y=-1 I $D(X) D ;**22*159 WAS: I $D(X),$L(X)<31 D
. N DIVAL S (DIVAL,DIVAL(1))=X N X S (X,X(1))=DIVAL
. D RENUM^DIC1 K DIDA Q
I $G(DICR) S:DIC(0)["L" DICR(DICR-1,6)=1 K:$D(DICR(DICR,4)) DF ;**GFT 12/18/07
E S D="B" D:$G(DICR) ;**GFT 1/3/06
.S %=DICR,X=DICR(%),DIC(0)=DICR(%,0),DICR=%-1
.S:$G(DICR(%,10))]"" DINUM=DICR(%,10)
.S:$D(DICR(%,9)) (D,DF)=DICR(%,9) I $G(DICR(%,9.1))]"" S:$P(DICR(%,9.1),U)]"" DID(1)=$P(DICR(%,9.1),U) S DID=$P(DICR(%,9.1),U,2,999)
.K DICRS,DICR(%)
D DO^DIC1:'$D(DO(2)) Q
;
NQ I $L(X)<14,X?.NP,+X=X,@("$D("_DIC_"X,0))") S Y=X D S^DIC3
Q
;
SOUNDEX I DIC(0)["E",'$D(DICRS) W " " D RS,SOU S DIC(0)=$TR(DIC(0),"L") D RCR Q:Y>0
G R
;
7 S Y=-1 N % S %=$S($D(DIC("S")):DIC("S"),1:1) ;RECURSIVE CALL TO ^DIC!
I $D(DS),'$D(DIC("S1")) D
. S DIC("S")=DS I '% S DIC("S")=DIC("S")_" X DIC(""S1"")",DIC("S1")=%
. I X]"" D
. . N DIVAL S (DIVAL,DIVAL(1))=X,DIVAL(0)=1 N X S (X,X(1))=DIVAL
. . N DINDEX,DIFILEI
. . S DIC(0)=$TR(DIC(0),"L") D F^DIC
. K DIC("S") S:$D(DIC("S1")) DIC("S")=DIC("S1") K DIC("S1")
D E Q
;
SOU D SOU^DICM1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICM 6827 printed Dec 13, 2024@02:46:17 Page 2
DICM ;SFISC/GFT,XAK,TKW-MULTIPLE LOOKUP FOR FLDS WHICH MUST BE TRANSFORMED ;27OCT2012
+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 IF '$DATA(DICR(1))
IF DIC(0)'["T"
NEW DICR
SET DICR=0
+8 IF $ASCII(X)=34
IF X?.E1""""
GOTO N
+9 IF $GET(^DD(+DO(2),0,"LOOK"))]""
IF ^("LOOK")'="SOUNDEX"
GOTO @^("LOOK")
+10 IF DIC(0)["U"
SET DD=0
GOTO W
+11 IF DIC(0)["T"
GOTO 2
R NEW DIFLAGS
SET DIFLAGS="4l"_$PIECE("M^",U,DIC(0)["M")
+1 NEW DIFORCE
Begin DoDot:1
+2 SET DIFORCE=0
IF DIC(0)'["M"!($DATA(DID))
SET DIFORCE=1
+3 SET DIFORCE(0)=$SELECT(DIC(0)'["M":DINDEX,$DATA(DID):DID,1:"*")
SET DIFORCE(1)=1
End DoDot:1
+4 ;LOOP THRU ALL THE INDEXES!
FOR
DO 1
IF DINDEX=""!(Y>0)!($GET(DTOUT))!($GET(DIROUT))
QUIT
+5 GOTO 2
+6 ;
1 NEW DS,%Y,DIV
+1 IF $GET(DINDEX("IXFILE"))
SET Y=DINDEX(1,"FILE")
SET %Y=DINDEX(1,"FIELD")
+2 IF '$TEST
SET Y=$ORDER(^DD(+DO(2),0,"IX",DINDEX,0))
if Y=""
SET Y=-1
SET %Y=+$ORDER(^(Y,0))
+3 IF Y=-1
IF DINDEX="B"
SET Y=+DO(2)
SET %Y=.01
+4 if Y=""
SET Y=-1
if %Y=""
SET %Y=-1
+5 ;HAVE WE ALREADY TRIED THIS INDEX?
IF $DATA(DICR(U,Y,%Y,DINDEX))
SET Y=-1
+6 ;!
IF '$TEST
IF %Y=.01
IF DINDEX'="B"
IF Y=+DO(2)
IF $DATA(DICR(U,Y,%Y,"B"))
IF $GET(DINDEX(1,"TRANCODE"))=""
SET Y=-1
+7 IF Y'<0
Begin DoDot:1
+8 SET DS=$GET(^DD(Y,%Y,0))
IF DS=""
SET Y=-1
QUIT
+9 SET %=DINDEX
SET DICR(U,Y,%Y,DINDEX)=0
+10 IF $DATA(^DD(Y,%Y,7))
DO RS
KILL DS
XECUTE ^(7)
QUIT
+11 IF $GET(DINDEX("IXTYPE"))="S"
DO A
DO SOU^DICM1
DO D
if Y>0
QUIT
SET Y=-1
QUIT
+12 ;TRICK TO SPEED LOOKUP OF ORDERS!
SET DIX=Y
SET Y=$PIECE(DS,U,2)
IF Y["P"
IF DIC(0)'["L"
IF $TEXT(ORDERQ^DICUIX2)]""
IF $$ORDERQ^DICUIX2(+$PIECE(Y,"P",2))
SET Y=""
+13 ;TRANSFORMATION WILL BE NECESSARY IF X-REF'D FIELD IS DATE, POINTER, SET OR VARIABLE-POINTER
SET Y=$SELECT(Y["P":"P",Y["D":"D",Y["S":"S",Y["V":"V",1:"")
+14 IF Y]""
DO A
if 'Y
DO ^DICM1
DO D
if Y>0
QUIT
SET Y=-1
QUIT
+15 IF $GET(DINDEX(1,"TRANCODE"))]""
SET Y="T"
DO A
DO ^DICM1
NEW DITRANX
SET DITRANX=1
DO D
+16 if Y>0
QUIT
SET Y=-1
QUIT
End DoDot:1
+17 if Y>0!(DIC(0)["T")
QUIT
Begin DoDot:1
+18 KILL DIV
MERGE DIV=X
SET DIV(1)=X
NEW X,Y
+19 DO NXTINDX^DICF2(.DINDEX,.DIFORCE,.DIFILEI,DIFLAGS,.DIV,"*")
QUIT
End DoDot:1
+20 QUIT
+21 ;
2 ;HERE'S WHERE WE TRY ALTERNATE LOOKUPS: UPPER CASE, COMMA-PIECING, TRUNCATE LONG INPUT
DO D^DIC0
SET %=D
+1 if Y>0!($GET(DIROUT))
GOTO K
+2 ;CONVERT TO UPPER-CASE
IF X?.E1L.E
IF DIC(0)'["X"
Begin DoDot:1
+3 DO %
NEW DIFILEI,DINDEX
+4 SET DIC(0)=$TRANSLATE(DIC(0),"L")
SET X=$$UP^DILIBF(X)
if $GET(DILONGX)
SET DICR(DILONGX,"ORG")=X
+5 DO DIC
QUIT
End DoDot:1
if $GET(DIROUT)
GOTO K
+6 ;COMMA-PIECING
IF Y'>0
IF X[","
SET DS=""
SET DIX=$PIECE(X,",")
IF DIC(0)'["X"
IF $LENGTH(DIX)<31
Begin DoDot:1
+7 FOR %=2:1
SET DD=$PIECE(X,",",%)
IF DD'[""""
Begin DoDot:2
+8 FOR
if $ASCII(DD)-32
QUIT
SET DD=$EXTRACT(DD,2,999)
+9 FOR
if $ASCII(DD,$LENGTH(DD))-32
QUIT
SET DD=$EXTRACT(DD,1,$LENGTH(DD)-1)
+10 IF $LENGTH(DD)*2+$LENGTH(DS)>200!(DD="")
SET DD=""
QUIT
+11 SET DS=DS_" I %?.E1P1"""_DD_""".E!(D'=""B""&(%?1"""_DD_""".E))"
QUIT
End DoDot:2
if DD=""
QUIT
+12 if DS=""
QUIT
SET %=D
+13 DO %
SET X=DIX
NEW DILONGX
+14 SET DS="S %=$P(^(0),U)"_DS
SET DIC(0)=DIC(0)_"D"
DO 7
QUIT
End DoDot:1
if $GET(DIROUT)
GOTO K
+15 ;LONG DATA
IF Y'>0
IF $LENGTH(X)>30
Begin DoDot:1
+16 NEW DILONGX
+17 SET %=D
DO %
SET DILONGX=DICR
SET Y="DICR("_DICR_")"
SET DICR(DICR,"ORG")=X
+18 SET DS=$SELECT(DIC(0)["X":"I DIVAL="_Y,1:"I '$L($P(DIVAL,"_Y_"))")
+19 if DIC(0)["O"&(DIC(0)'["E")
SET DS=DS_",'$L($P(DIVAL,"_Y_",2))"
+20 DO 7
IF Y>0!(X'?.E1L.E)!(DIC(0)["X")
QUIT
+21 SET %=D
DO %
SET (X,DICR(DICR,"ORG"))=$$UP^DILIBF(X)
+22 SET Y="DICR("_DICR_",""ORG"")"
+23 SET DS="I '$L($P(DIVAL,"_Y_"))"
if DIC(0)["O"&(DIC(0)'["E")
SET DS=DS_",'$L($P(DIVAL,"_Y_",2))"
+24 DO 7
End DoDot:1
+25 ;
K SET DICR=+$GET(DICR)
SET DD=$DATA(DICR(DICR,6))
if 'DICR
KILL DICR
+1 IF Y>0
KILL DIC("W")
DO R^DIC2
QUIT
+2 IF $GET(DTOUT)!($GET(DIROUT))
QUIT
W IF @("$O("_DIC_"""A[""))]""""")
if DIC(0)["N"
GOTO NL
GOTO DD
+1 IF DO(2)'["Z"
SET Y=0
Begin DoDot:1
DINUM IF $GET(DINDEX("1","FIELD"))=.01
IF X?1.15NP
IF $PIECE($GET(^DD(+DO(2),.01,0)),U,5,99)["DINUM=X"
IF $PIECE($GET(@(DIC_"X,0)")),U)=X
Begin DoDot:2
+1 SET Y=X
IF 1
if $DATA(DIC("S"))
XECUTE DIC("S")
IF $TEST
SET DIY=""
SET DS=1
NEW DZ,DD
DO ADDKEY^DIC3
DO GOT^DIC2
QUIT
+2 SET Y=0
End DoDot:2
if Y>0
QUIT
+3 ;GO THRU THE WHOLE FILE BECAUSE WE HAVE NO CROSS-REFERENCE! (SEE ..DOTS.. BELOW)
NEW DIOUT
SET DIOUT=0
FOR DS=1:1
SET @("Y=$O("_DIC_"Y))")
Begin DoDot:2
+4 IF 'Y
SET Y=-1
SET DIOUT=1
QUIT
+5 if DIC(0)["E"&(DS#20=0)
WRITE ".."
+6 IF $DATA(@(DIC_Y_",0)"))
IF $PIECE(^(0),U)=X
if $DATA(DIC("S"))
XECUTE DIC("S")
IF $TEST
SET DIOUT=1
+7 IF DIOUT
SET DIY=""
SET DS=1
NEW DZ,DD
DO ADDKEY^DIC3
DO GOT^DIC2
+8 QUIT
End DoDot:2
if DIOUT
QUIT
End DoDot:1
if Y>0!($GET(DIROUT))
QUIT
NL IF '$GET(DICR)
DO NQ
IF $TEST
Begin DoDot:1
+1 if '$GET(DIASKOK)
NEW DIASKOK
SET (DS,DIASKOK)=1
NEW DZ,DD
+2 DO ADDKEY^DIC3
DO GOT^DIC2
QUIT
End DoDot:1
if Y>0!($GET(DTOUT))!($GET(DIROUT))
QUIT
DD SET Y=-1
IF DD
DO BAD^DIC1
QUIT
L IF DIC(0)["L"
KILL DD
GOTO ^DICN
B DO BAD^DIC1
QUIT
+1 ;
N DO RS
SET X=$EXTRACT(X,2,$LENGTH(X)-1)
SET %=D
Begin DoDot:1
+1 IF DINDEX("#")>1
SET %Y=+$GET(DINDEX(1,"FIELD"))
SET DS=$GET(^DD(+$GET(DINDEX(1,"FILE")),%Y,0))
if DS]""
QUIT
+2 SET DS=^DD(+DO(2),.01,0)
SET %Y=.01
QUIT
End DoDot:1
+3 FOR Y="P","D","S","V"
IF $PIECE(DS,U,2)[Y
if Y="P"
KILL DO
DO ^DICM1
if $DATA(X)#2
SET DS("INT")=X
QUIT
+4 IF $DATA(X)
IF DINDEX("#")>1
SET X(1)=X
+5 SET Y=-1
if $DATA(X)
DO L
DO E
+6 IF Y'>0
KILL DUOUT
DO BAD^DIC1
QUIT
+7 GOTO 2
+8 ;
A ; Set variables needed for transforming date/set/ptr/var.ptr
+1 SET DICR(DICR+1,4)=%
+2 DO %
KILL DF,DID,DINUM
QUIT
+3 ;
% ; Set variables up before doing lookup w/transformed value
+1 IF DIC(0)'["L"
SET DICR(DICR+1,8)=1
+2 IF '$TEST
IF '$$OKTOADD^DICM0(.DIFILEI,.DINDEX,.DIFINDER)
SET DICR(DICR+1,8)=1
+3 IF $GET(DINUM)]""
SET DICR(DICR+1,10)=DINUM
+4 IF $DATA(DF)
SET DICR(DICR+1,9)=DF
if $GET(DID)]""
SET DICR(DICR+1,9.1)=$GET(DID(1))_U_DID
RS SET DICR=DICR+1
SET DICR(DICR)=X
SET DICR(DICR,0)=DIC(0)
SET DIC(0)=$TRANSLATE(DIC(0),"A")
SET DIC(0)=$TRANSLATE(DIC(0),"Q")
QUIT
+1 ;
D if $GET(DICR(DICR,10))]""
SET DINUM=DICR(DICR,10)
+1 SET (D,DF)=DICR(DICR,4)
Begin DoDot:1
+2 NEW T
SET T=$PIECE($GET(DS),U,2)
+3 SET DIC(0)=$TRANSLATE(DIC(0),"M","")
IF T["V"
SET DIC(0)=$TRANSLATE(DIC(0),"A","")
+4 IF D="B"
IF T'["D"
IF '$GET(DITRANX)
SET DIC(0)=DIC(0)_"s"
+5 IF T["P"!(T["V")!(T["S")
SET DIC(0)=DIC(0)_"X"
+6 QUIT
End DoDot:1
+7 IF DICR(DICR,4)=DINDEX
NEW I
MERGE I=DINDEX
NEW DINDEX
MERGE DINDEX=I
KILL I
SET DINDEX("START")=DINDEX
+8 IF '$TEST
NEW DINDEX
Begin DoDot:1
+9 SET (DINDEX,DINDEX("START"))=DICR(DICR,4)
SET DINDEX("WAY")=1
+10 DO INDEX^DICUIX(.DIFILEI,DIFLAGS,.DINDEX,"",.DIVALUE)
QUIT
End DoDot:1
+11 IF DINDEX("#")>1
SET (DINDEX(1),DINDEX(1,"FROM"),DINDEX(1,"PART"))=$GET(X)
RCR if '$DATA(DIDA)
SET DICRS=1
DIC ;
+1 IF $DATA(DICR(DICR,8))
SET DIC(0)=$TRANSLATE(DIC(0),"L")
+2 ;**22*159 WAS: I $D(X),$L(X)<31 D
SET Y=-1
IF $DATA(X)
Begin DoDot:1
+3 NEW DIVAL
SET (DIVAL,DIVAL(1))=X
NEW X
SET (X,X(1))=DIVAL
+4 DO RENUM^DIC1
KILL DIDA
QUIT
End DoDot:1
+5 ;**GFT 12/18/07
IF $GET(DICR)
if DIC(0)["L"
SET DICR(DICR-1,6)=1
if $DATA(DICR(DICR,4))
KILL DF
E ;**GFT 1/3/06
SET D="B"
if $GET(DICR)
Begin DoDot:1
+1 SET %=DICR
SET X=DICR(%)
SET DIC(0)=DICR(%,0)
SET DICR=%-1
+2 if $GET(DICR(%,10))]""
SET DINUM=DICR(%,10)
+3 if $DATA(DICR(%,9))
SET (D,DF)=DICR(%,9)
IF $GET(DICR(%,9.1))]""
if $PIECE(DICR(%,9.1),U)]""
SET DID(1)=$PIECE(DICR(%,9.1),U)
SET DID=$PIECE(DICR(%,9.1),U,2,999)
+4 KILL DICRS,DICR(%)
End DoDot:1
+5 if '$DATA(DO(2))
DO DO^DIC1
QUIT
+6 ;
NQ IF $LENGTH(X)<14
IF X?.NP
IF +X=X
IF @("$D("_DIC_"X,0))")
SET Y=X
DO S^DIC3
+1 QUIT
+2 ;
SOUNDEX IF DIC(0)["E"
IF '$DATA(DICRS)
WRITE " "
DO RS
DO SOU
SET DIC(0)=$TRANSLATE(DIC(0),"L")
DO RCR
if Y>0
QUIT
+1 GOTO R
+2 ;
7 ;RECURSIVE CALL TO ^DIC!
SET Y=-1
NEW %
SET %=$SELECT($DATA(DIC("S")):DIC("S"),1:1)
+1 IF $DATA(DS)
IF '$DATA(DIC("S1"))
Begin DoDot:1
+2 SET DIC("S")=DS
IF '%
SET DIC("S")=DIC("S")_" X DIC(""S1"")"
SET DIC("S1")=%
+3 IF X]""
Begin DoDot:2
+4 NEW DIVAL
SET (DIVAL,DIVAL(1))=X
SET DIVAL(0)=1
NEW X
SET (X,X(1))=DIVAL
+5 NEW DINDEX,DIFILEI
+6 SET DIC(0)=$TRANSLATE(DIC(0),"L")
DO F^DIC
End DoDot:2
+7 KILL DIC("S")
if $DATA(DIC("S1"))
SET DIC("S")=DIC("S1")
KILL DIC("S1")
End DoDot:1
+8 DO E
QUIT
+9 ;
SOU DO SOU^DICM1
QUIT
