DICF5 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, (Other lookup value transform) ;5/26/99 10:05
;;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.
;
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)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICF5 3016 printed Apr 09, 2024@21:54:47 Page 2
DICF5 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, (Other lookup value transform) ;5/26/99 10:05
+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 ;
PREPS(DIFLAGS,DISUB,DINDEX,DINODE,DIVALUE) ;
+1 ; transform value for indexed set of codes field
+2 ; proc, DINDEX passed by ref
+3 NEW DICODE,DIMEAN,DIPAIR,DISKIP,DITRY,DIVAL
+4 NEW DISET
SET DISET=$PIECE(DINODE,U,3)
CODES ;
+1 NEW DIP
FOR DIP=1:1:$LENGTH(DISET,";")-1
Begin DoDot:1
+2 SET DIPAIR=$PIECE(DISET,";",DIP)
+3 FOR DIVAL=1,2
SET DITRY=$GET(DIVALUE(DISUB,DIVAL))
if DITRY]""
Begin DoDot:2
+4 IF DIVAL=2
IF DIFLAGS["l"
QUIT
+5 SET DIMEAN=$PIECE(DIPAIR,":",2)
+6 IF $PIECE(DIMEAN,DITRY)'=""
QUIT
+7 IF DIFLAGS["X"
IF DIMEAN'=DITRY
QUIT
+8 SET DICODE=$PIECE(DIPAIR,":")
+9 IF $GET(DINDEX(DISUB,"TRANCODE"))=""
Begin DoDot:3
+10 if DICODE'=DITRY
SET DIVALUE(DISUB,(4+DIVAL))=DICODE
QUIT
End DoDot:3
QUIT
+11 NEW X
SET X=DICODE
XECUTE DINDEX(DISUB,"TRANCODE")
if X=""
QUIT
+12 SET DIVALUE(DISUB,7)=X
QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
POINT(DISUB,DIFLAGS,DIFILE,DINDEX,DIVALUE,DISCREEN) ; Add transform values for dates and sets at end of pointer chain
+1 ; save off the primary file info, follow the ptr chain to the end
+2 NEW DIVPTR,DIF,DITYPE
SET DIVPTR=$SELECT(DINDEX(DISUB,"TYPE")="V":1,1:0)
+3 MERGE DIF=DIFILE
NEW DIFILE
MERGE DIFILE=DIF
KILL DIF
+4 NEW DIFIL,DIFLD
SET DIFIL=+DINDEX(DISUB,"FILE")
SET DIFLD=+DINDEX(DISUB,"FIELD")
+5 NEW DINODE
SET DINODE=$GET(^DD(DIFIL,DIFLD,0))
if DINODE=""
QUIT
+6 DO FOLLOW^DICL3(.DIFILE,"",DINODE,1,0,"",DIFLD,DIFIL,DIVPTR,DISUB,.DISCREEN)
+7 NEW DIEND
FOR DIEND=0:0
SET DIEND=$ORDER(DIFILE("STACKEND",DIEND))
if 'DIEND
QUIT
Begin DoDot:1
+8 SET DIFIL=$PIECE(DIFILE("STACKEND",DIEND),U,2)
+9 SET DINODE=$GET(^DD(DIFIL,.01,0))
SET DITYPE=$PIECE(DINODE,U,2)
+10 IF DITYPE["F"!(DITYPE["N")
Begin DoDot:2
+11 if $GET(DINDEX(DISUB,"TRANCODE"))=""
QUIT
+12 NEW X
SET X=DIVALUE(DISUB)
XECUTE DINDEX(DISUB,"TRANCODE")
if X=""
QUIT
+13 SET DIVALUE(DISUB,5)=X
QUIT
End DoDot:2
QUIT
+14 IF $PIECE(DINODE,U,2)["D"
DO PREPD(DISUB,.DINDEX,DINODE,.DIVALUE)
QUIT
+15 IF $PIECE(DINODE,U,2)["S"
DO PREPS(DIFLAGS,DISUB,.DINDEX,DINODE,.DIVALUE)
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
PREPD(DISUB,DINDEX,DINODE,DIVALUE) ;
+1 ; PREPIX--transform value for indexed date field
+2 NEW D
SET D=$GET(DIVALUE(DISUB))
if D=""
QUIT
+3 NEW DIFLAGS
SET DIFLAGS=$PIECE($PIECE(DINODE,"%DT=""",2),"""")
+4 NEW DIDATEFM
+5 DO DT^DILF($TRANSLATE(DIFLAGS,"ER")_"Ne",D,.DIDATEFM)
+6 IF DIDATEFM'>1
QUIT
+7 IF $GET(DINDEX(DISUB,"TRANCODE"))=""
SET DIVALUE(DISUB,5)=DIDATEFM
QUIT
+8 NEW X
SET X=DIDATEFM
XECUTE DINDEX(DISUB,"TRANCODE")
if X=""
QUIT
+9 SET DIVALUE(DISUB,6)=X
+10 QUIT
+11 ;
SOUNDEX(DIVALUE) ; func, convert value to soundex value
+1 NEW DICODE
SET DICODE="01230129022455012623019202"
+2 NEW DISOUND
SET DISOUND=$CHAR($ASCII(DIVALUE)-(DIVALUE?1L.E*32))
+3 NEW DIPREV
SET DIPREV=$EXTRACT(DICODE,$ASCII(DIVALUE)-64)
+4 NEW DICHAR,DIPOS
+5 FOR DIPOS=2:1
SET DICHAR=$EXTRACT(DIVALUE,DIPOS)
if ","[DICHAR
QUIT
Begin DoDot:1
+6 if DICHAR'?1A
QUIT
+7 NEW DITRANS
SET DITRANS=$EXTRACT(DICODE,$ASCII(DICHAR)-$SELECT(DICHAR?1U:64,1:96))
+8 if DITRANS=DIPREV
QUIT
if DITRANS=9
QUIT
+9 SET DIPREV=DITRANS
+10 IF DITRANS'=0
SET DISOUND=DISOUND_DITRANS
End DoDot:1
if $LENGTH(DISOUND)=4
QUIT
+11 QUIT $EXTRACT(DISOUND_"000",1,4)
+12 ;
