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