DICF5 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, (Other lookup value transform) ;5/26/99  10:05
 ;;22.0;VA FileMan;**4**;Mar 30, 1999
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
PREPS(DIFLAGS,DISUB,DINDEX,DINODE,DIVALUE) ;
 ; transform value for indexed set of codes field
 ; proc, DINDEX passed by ref
 N DICODE,DIMEAN,DIPAIR,DISKIP,DITRY,DIVAL
 N DISET S DISET=$P(DINODE,U,3)
CODES ;
 N DIP F DIP=1:1:$L(DISET,";")-1 D
 . S DIPAIR=$P(DISET,";",DIP)
 . F DIVAL=1,2 S DITRY=$G(DIVALUE(DISUB,DIVAL)) D:DITRY]""
 . . I DIVAL=2,DIFLAGS["l" Q
 . . S DIMEAN=$P(DIPAIR,":",2)
 . . I $P(DIMEAN,DITRY)'="" Q
 . . I DIFLAGS["X",DIMEAN'=DITRY Q
 . . S DICODE=$P(DIPAIR,":")
 . . I $G(DINDEX(DISUB,"TRANCODE"))="" D  Q
 . . . S:DICODE'=DITRY DIVALUE(DISUB,(4+DIVAL))=DICODE Q
 . . N X S X=DICODE X DINDEX(DISUB,"TRANCODE") Q:X=""
 . . S DIVALUE(DISUB,7)=X Q
 . Q
 Q
 ;
POINT(DISUB,DIFLAGS,DIFILE,DINDEX,DIVALUE,DISCREEN) ; Add transform values for dates and sets at end of pointer chain
 ; save off the primary file info, follow the ptr chain to the end
 N DIVPTR,DIF,DITYPE S DIVPTR=$S(DINDEX(DISUB,"TYPE")="V":1,1:0)
 M DIF=DIFILE N DIFILE M DIFILE=DIF K DIF
 N DIFIL,DIFLD S DIFIL=+DINDEX(DISUB,"FILE"),DIFLD=+DINDEX(DISUB,"FIELD")
 N DINODE S DINODE=$G(^DD(DIFIL,DIFLD,0)) Q:DINODE=""
 D FOLLOW^DICL3(.DIFILE,"",DINODE,1,0,"",DIFLD,DIFIL,DIVPTR,DISUB,.DISCREEN)
 N DIEND F DIEND=0:0 S DIEND=$O(DIFILE("STACKEND",DIEND)) Q:'DIEND  D
 . S DIFIL=$P(DIFILE("STACKEND",DIEND),U,2)
 . S DINODE=$G(^DD(DIFIL,.01,0)),DITYPE=$P(DINODE,U,2)
 . I DITYPE["F"!(DITYPE["N") D  Q
 . . Q:$G(DINDEX(DISUB,"TRANCODE"))=""
 . . N X S X=DIVALUE(DISUB) X DINDEX(DISUB,"TRANCODE") Q:X=""
 . . S DIVALUE(DISUB,5)=X Q
 . I $P(DINODE,U,2)["D" D PREPD(DISUB,.DINDEX,DINODE,.DIVALUE) Q
 . I $P(DINODE,U,2)["S" D PREPS(DIFLAGS,DISUB,.DINDEX,DINODE,.DIVALUE)
 . Q
 Q
 ;
PREPD(DISUB,DINDEX,DINODE,DIVALUE) ;
 ; PREPIX--transform value for indexed date field
 N D S D=$G(DIVALUE(DISUB)) Q:D=""
 N DIFLAGS S DIFLAGS=$P($P(DINODE,"%DT=""",2),"""")
 N DIDATEFM
 D DT^DILF($TR(DIFLAGS,"ER")_"Ne",D,.DIDATEFM)
 I DIDATEFM'>1 Q
 I $G(DINDEX(DISUB,"TRANCODE"))="" S DIVALUE(DISUB,5)=DIDATEFM Q
 N X S X=DIDATEFM X DINDEX(DISUB,"TRANCODE") Q:X=""
 S DIVALUE(DISUB,6)=X
 Q
 ;
SOUNDEX(DIVALUE) ; func, convert value to soundex value
 N DICODE S DICODE="01230129022455012623019202"
 N DISOUND S DISOUND=$C($A(DIVALUE)-(DIVALUE?1L.E*32))
 N DIPREV S DIPREV=$E(DICODE,$A(DIVALUE)-64)
 N DICHAR,DIPOS
 F DIPOS=2:1 S DICHAR=$E(DIVALUE,DIPOS) Q:","[DICHAR  D  Q:$L(DISOUND)=4
 . Q:DICHAR'?1A
 . N DITRANS S DITRANS=$E(DICODE,$A(DICHAR)-$S(DICHAR?1U:64,1:96))
 . Q:DITRANS=DIPREV  Q:DITRANS=9
 . S DIPREV=DITRANS
 . I DITRANS'=0 S DISOUND=DISOUND_DITRANS
 Q $E(DISOUND_"000",1,4)
 ;