Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DICF5

DICF5.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1. ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1. ;;Licensed under the terms of the Apache License, Version 2.0.
  1. ;
  1. PREPS(DIFLAGS,DISUB,DINDEX,DINODE,DIVALUE) ;
  1. ; transform value for indexed set of codes field
  1. ; proc, DINDEX passed by ref
  1. N DICODE,DIMEAN,DIPAIR,DISKIP,DITRY,DIVAL
  1. N DISET S DISET=$P(DINODE,U,3)
  1. CODES ;
  1. N DIP F DIP=1:1:$L(DISET,";")-1 D
  1. . S DIPAIR=$P(DISET,";",DIP)
  1. . F DIVAL=1,2 S DITRY=$G(DIVALUE(DISUB,DIVAL)) D:DITRY]""
  1. . . I DIVAL=2,DIFLAGS["l" Q
  1. . . S DIMEAN=$P(DIPAIR,":",2)
  1. . . I $P(DIMEAN,DITRY)'="" Q
  1. . . I DIFLAGS["X",DIMEAN'=DITRY Q
  1. . . S DICODE=$P(DIPAIR,":")
  1. . . I $G(DINDEX(DISUB,"TRANCODE"))="" D Q
  1. . . . S:DICODE'=DITRY DIVALUE(DISUB,(4+DIVAL))=DICODE Q
  1. . . N X S X=DICODE X DINDEX(DISUB,"TRANCODE") Q:X=""
  1. . . S DIVALUE(DISUB,7)=X Q
  1. . Q
  1. Q
  1. ;
  1. 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
  1. N DIVPTR,DIF,DITYPE S DIVPTR=$S(DINDEX(DISUB,"TYPE")="V":1,1:0)
  1. M DIF=DIFILE N DIFILE M DIFILE=DIF K DIF
  1. N DIFIL,DIFLD S DIFIL=+DINDEX(DISUB,"FILE"),DIFLD=+DINDEX(DISUB,"FIELD")
  1. N DINODE S DINODE=$G(^DD(DIFIL,DIFLD,0)) Q:DINODE=""
  1. D FOLLOW^DICL3(.DIFILE,"",DINODE,1,0,"",DIFLD,DIFIL,DIVPTR,DISUB,.DISCREEN)
  1. N DIEND F DIEND=0:0 S DIEND=$O(DIFILE("STACKEND",DIEND)) Q:'DIEND D
  1. . S DIFIL=$P(DIFILE("STACKEND",DIEND),U,2)
  1. . S DINODE=$G(^DD(DIFIL,.01,0)),DITYPE=$P(DINODE,U,2)
  1. . I DITYPE["F"!(DITYPE["N") D Q
  1. . . Q:$G(DINDEX(DISUB,"TRANCODE"))=""
  1. . . N X S X=DIVALUE(DISUB) X DINDEX(DISUB,"TRANCODE") Q:X=""
  1. . . S DIVALUE(DISUB,5)=X Q
  1. . I $P(DINODE,U,2)["D" D PREPD(DISUB,.DINDEX,DINODE,.DIVALUE) Q
  1. . I $P(DINODE,U,2)["S" D PREPS(DIFLAGS,DISUB,.DINDEX,DINODE,.DIVALUE)
  1. . Q
  1. Q
  1. ;
  1. PREPD(DISUB,DINDEX,DINODE,DIVALUE) ;
  1. ; PREPIX--transform value for indexed date field
  1. N D S D=$G(DIVALUE(DISUB)) Q:D=""
  1. N DIFLAGS S DIFLAGS=$P($P(DINODE,"%DT=""",2),"""")
  1. N DIDATEFM
  1. D DT^DILF($TR(DIFLAGS,"ER")_"Ne",D,.DIDATEFM)
  1. I DIDATEFM'>1 Q
  1. I $G(DINDEX(DISUB,"TRANCODE"))="" S DIVALUE(DISUB,5)=DIDATEFM Q
  1. N X S X=DIDATEFM X DINDEX(DISUB,"TRANCODE") Q:X=""
  1. S DIVALUE(DISUB,6)=X
  1. Q
  1. ;
  1. SOUNDEX(DIVALUE) ; func, convert value to soundex value
  1. N DICODE S DICODE="01230129022455012623019202"
  1. N DISOUND S DISOUND=$C($A(DIVALUE)-(DIVALUE?1L.E*32))
  1. N DIPREV S DIPREV=$E(DICODE,$A(DIVALUE)-64)
  1. N DICHAR,DIPOS
  1. F DIPOS=2:1 S DICHAR=$E(DIVALUE,DIPOS) Q:","[DICHAR D Q:$L(DISOUND)=4
  1. . Q:DICHAR'?1A
  1. . N DITRANS S DITRANS=$E(DICODE,$A(DICHAR)-$S(DICHAR?1U:64,1:96))
  1. . Q:DITRANS=DIPREV Q:DITRANS=9
  1. . S DIPREV=DITRANS
  1. . I DITRANS'=0 S DISOUND=DISOUND_DITRANS
  1. Q $E(DISOUND_"000",1,4)
  1. ;