70 lines
2.7 KiB
Mathematica
70 lines
2.7 KiB
Mathematica
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)
|
|
;
|