- 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 Feb 19, 2025@00:12:32 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
