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

LEXU3.m

Go to the documentation of this file. 
  1. LEXU3 ;ISL/KER - Miscellaneous Lexicon Utilities ;04/21/2014
  1.  ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
  1.  ;               
  1.  ; Global Variables
  1.  ;    ^LEX(757.001)       N/A
  1.  ;    ^TMP("LEXSCH")      SACC 2.3.2.5.1
  1.  ;    ^TMP("LEXTKN")      SACC 2.3.2.5.1
  1.  ;               
  1.  ; External References
  1.  ;    $$DT^XLFDT          ICR  10103
  1.  ;    $$FMADD^XLFDT       ICR  10103
  1.  ;    $$FMDIFF^XLFDT      ICR  10103
  1.  ;    $$FMTE^XLFDT        ICR  10103
  1.  ;    $$GET1^DIQ          ICR   2056
  1.  ;    ^DIC                ICR  10006
  1.  ;               
  1. ADR(LEX) ; Mailing Address
  1.  N DIC,DTOUT,DUOUT,X,Y S DIC="^DIC(4.2,",DIC(0)="M"
  1.  S (LEX,X)="FO-SLC.MED.VA.GOV" D ^DIC Q:+Y>0 LEX
  1.  S DIC="^DIC(4.2,",DIC(0)="M",(LEX,X)="ISC-SLC.MED.VA.GOV"
  1.  D ^DIC Q:+Y>0 LEX
  1.  Q "ISC-SLC.VA.GOV"
  1. VDT ; Resolve LEXVDT
  1.  ;   Check Environment First
  1.  N LEXSD I $P($G(LEXVDT),".",1)?7N D  Q
  1.  . S LEXVDT=$P($G(LEXVDT),".",1)
  1.  . S LEXVDT=$$FMADD^XLFDT(LEXVDT,0)
  1.  . S:LEXVDT'>0 LEXVDT=$$DT^XLFDT
  1.  . S:$D(^TMP("LEXSCH",$J)) ^TMP("LEXSCH",$J,"VDT",0)=+($G(LEXVDT))
  1.  . S:$D(^TMP("LEXSCH",$J)) ^TMP("LEXSCH",$J,"VDT",1)="Version Date Check: "_$$FMTE^XLFDT($G(LEXVDT))
  1.  ;   Check Lookup Environment Second
  1.  S LEXSD=$P($G(^TMP("LEXSCH",$J,"VDT",0)),".",1)
  1.  I $P($G(LEXVDT),".",1)'?7N,LEXSD?7N D
  1.  . S LEXVDT=$P($G(LEXSD),".",1)
  1.  . S LEXVDT=$$FMADD^XLFDT(LEXVDT,0)
  1.  . S:LEXVDT'>0 LEXVDT=$$DT^XLFDT
  1.  . S:$D(^TMP("LEXSCH",$J)) ^TMP("LEXSCH",$J,"VDT",0)=+($G(LEXVDT))
  1.  . S:$D(^TMP("LEXSCH",$J)) ^TMP("LEXSCH",$J,"VDT",1)="Version Date Check: "_$$FMTE^XLFDT($G(LEXVDT))
  1.  ;   Check System Clock Last
  1.  I $P($G(LEXVDT),".",1)'?7N D
  1.  . S LEXVDT=$$DT^XLFDT
  1.  . S:$D(^TMP("LEXSCH",$J)) ^TMP("LEXSCH",$J,"VDT",0)=+($G(LEXVDT))
  1.  . S:$D(^TMP("LEXSCH",$J)) ^TMP("LEXSCH",$J,"VDT",1)="Version Date Check: "_$$FMTE^XLFDT($G(LEXVDT))
  1.  Q
  1. IMPDATE(SYS) ; Get the Implementation Date for a Coding System
  1.  ; 
  1.  ; Input
  1.  ; 
  1.  ;   SYS       Coding System Abbreviation (757.03,.01)
  1.  ;             or pointer to file 757.03
  1.  ;   
  1.  ; Output
  1.  ; 
  1.  ;   $$IMPDATE  Implementation Date in FileMan format
  1.  ;   
  1.  N FRMT,CSIEN,IMPDATE S FRMT="I" S CSIEN=$$CSYSIEN^LEXTRAN($G(SYS)) I +CSIEN<0 Q CSIEN
  1.  S CSIEN=$P(CSIEN,U,2) S IMPDATE=$$GET1^DIQ(757.03,CSIEN,11,FRMT)
  1.  Q IMPDATE
  1. CSYS(SYS) ; Get Coding System Info
  1.  ; 
  1.  ; Input
  1.  ; 
  1.  ;   SYS       Coding System Abbreviation (757.03,.01)
  1.  ;             or pointer to file 757.03
  1.  ;    
  1.  ; Output
  1.  ; 
  1.  ;     A 13 piece caret (^) delimited string 
  1.  ;     
  1.  ;      1    IEN 
  1.  ;      2    SAB (3 character source abbreviation) 
  1.  ;      3    Source Abbreviation (3-7 char)  (#.01) 
  1.  ;      4    Nomenclature (2-11 char) (#1) 
  1.  ;      5    Source Title (2-52 char) (#2) 
  1.  ;      6    Source (2-50 char) (#3) 
  1.  ;      7    Entries (numeric) (#4) 
  1.  ;      8    Unique Entries (numeric) (#5) 
  1.  ;      9    Inactive Version (1-20 char) (#6) 
  1.  ;     10    HL7 Coding System (2-40 char) (#7) 
  1.  ;     11    SDO Version Date (date) (757.08 #.01) 
  1.  ;     12    SDO Version Id (1-40 char) (757.08 #1) 
  1.  ;     13    Implementation Date (date) (#11)
  1.  ;     14    Lookup Threshold (#12)
  1.  ;     
  1.  N LEXSYS,LEXOUT,LEXND,LEXIEN,LEXEFF,LEXVER,LEXIMP,LEXTHR
  1.  S LEXSYS=$G(SYS) Q:'$L(LEXSYS) "-1^Coding System missing"
  1.  S LEXIEN=$$SIEN(LEXSYS)
  1.  Q:+LEXIEN'>0!('$D(^LEX(757.03,+LEXIEN,0))) "-1^Coding System not found"
  1.  S LEXSYS=$$SMNEM(+LEXIEN)
  1.  S LEXND=$G(^LEX(757.03,+LEXIEN,0))
  1.  Q:$L(LEXND)'>3 "-1^Invalid Coding System HUH"
  1.  S $P(LEXND,"^",8)=$P(LEXND,"^",8)
  1.  S LEXEFF=$O(^LEX(757.03,LEXIEN,1,"B"," "),-1)
  1.  S LEXVER=$O(^LEX(757.03,LEXIEN,1,"B",+LEXEFF),-1)
  1.  S LEXVER=$P($G(^LEX(757.03,LEXIEN,1,+LEXVER,0)),"^",2)
  1.  S LEXIMP=$P($G(^LEX(757.03,LEXIEN,2)),"^",1)
  1.  S LEXTHR=$P($G(^LEX(757.03,LEXIEN,2)),"^",2)
  1.  S LEXOUT=LEXIEN_"^"_$E(LEXND,1,3)_"^"_LEXND_"^"_LEXEFF_"^"_LEXVER_"^"_LEXIMP_"^"_LEXTHR
  1.  Q LEXOUT
  1. SIEN(MNEM) ; Return code system IEN for mnemonic
  1.  Q:'$L($G(MNEM)) "-1"
  1.  Q:$D(^LEX(757.03,"ASAB",MNEM)) $O(^LEX(757.03,"ASAB",MNEM,""))
  1.  Q:$D(^LEX(757.03,"B",MNEM)) $O(^LEX(757.03,"B",MNEM,""))
  1.  Q:$D(^LEX(757.03,"B",$E(MNEM,1,3))) $O(^LEX(757.03,"B",$E(MNEM,1,3),""))
  1.  Q:$D(^LEX(757.03,"C",MNEM)) $O(^LEX(757.03,"C",MNEM,""))
  1.  Q:MNEM?1N.N&($D(^LEX(757.03,+MNEM,0))) +MNEM
  1.  Q "-1"
  1. SMNEM(SIEN) ; Return code system mnemonic for IEN
  1.  I '$D(^LEX(757.03,+($G(SIEN)),0)) Q ""
  1.  Q $P(^LEX(757.03,SIEN,0),"^")
  1. INC(X) ; Increment Concept Usage for a term
  1.  N LEXIEN,LEXMC S LEXIEN=+($G(X)) Q:'$D(^LEX(757.01,+LEXIEN,0))
  1.  S LEXMC=+($G(^LEX(757.01,+LEXIEN,1))) Q:+LEXMC'>0
  1.  Q:'$D(^LEX(757,+LEXMC,0))  Q:+($G(^LEX(757,+LEXMC,0)))'=LEXIEN
  1.  Q:'$D(^LEX(757.001,+LEXMC,0))
  1.  D INC^LEXAR4(LEXMC)
  1.  Q
  1. FREQ(TEXT) ; Get the Frequency of use for a Text String
  1.  ; 
  1.  ; Input   
  1.  ; 
  1.  ;   TEXT     Text String
  1.  ;   
  1.  ; Output
  1.  ; 
  1.  ;   $$FREQ   Frequency of Text
  1.  ;             
  1.  S TEXT=$G(TEXT) Q:'$L(TEXT) 0  N X S X=TEXT K ^TMP("LEXTKN",$J) D PTX^LEXTOKN
  1.  N LEXI,LEXT,LEXF,LEXA S LEXI=0
  1.  F  S LEXI=$O(^TMP("LEXTKN",$J,LEXI)) Q:+LEXI'>0  D
  1.  . S LEXT="" F  S LEXT=$O(^TMP("LEXTKN",$J,LEXI,LEXT)) Q:'$L(LEXT)  D
  1.  . . S LEXF=+($O(^LEX(757.01,"ASL",LEXT,0))) Q:LEXF'>0  S LEXA(LEXF)=LEXT
  1.  S TEXT=+($O(LEXA(0))) K ^TMP("LEXTKN",$J)
  1.  Q TEXT
  1. PAR(TEXT,ARY) ; Parse Text into Words
  1.  ;
  1.  ; Input   
  1.  ; 
  1.  ;   TEXT    Text String to be parsed
  1.  ;   ARY     Local array passed by reference
  1.  ; 
  1.  ; Output  
  1.  ; 
  1.  ;   $$PAR   Number of Words
  1.  ;   ARY     Output array
  1.  ;         
  1.  ;              Words Found
  1.  ;                 ARY(0)=#
  1.  ;                 
  1.  ;              Word List in the order they appear in the input variable
  1.  ;                 ARY(1)=WORD1
  1.  ;                 ARY(n)=WORDn
  1.  ;                 
  1.  ;              Words listed alphabetically with the frequency of occurrence
  1.  ;                 ARY("B",WORDA)=# (Frequency of Use)
  1.  ;                 ARY("B",WORDB)=#
  1.  ;                 
  1.  ;              Words listed in the frequency order (the order used by the search)
  1.  ;                 ARY("L",1)=SEARCHWORD1
  1.  ;                 ARY("L",n)=SEARCHWORDn
  1.  ; 
  1.  ; Special Variables used by the parsing logic:
  1.  ; 
  1.  ;   LEXIDX    If this variable is set, the text will use the
  1.  ;             parsing logic used for setting cross-references.
  1.  ;             This is the default method.
  1.  ;             
  1.  ;   LEXLOOK   If this variable is set, the text will use the
  1.  ;             parsing logic used for settup up for a Lexicon
  1.  ;             search (lookup).
  1.  ;             
  1.  N LEXTI,LEXTL,X S LEXTI=$D(LEXIDX),LEXTL=$D(LEXLOOK) N LEXIDX,LEXLOOK
  1.  I LEXTI>0 S LEXIDX="",LEXTL=0 K LEXLOOK
  1.  I LEXTL>0 S LEXLOOK="",LEXTI=0 K LEXIDX
  1.  S:'$D(LEXLOOK)&('$D(LEXIDX)) LEXIDX=""
  1.  S (X,TEXT)=$G(TEXT) K ^TMP("LEXTKN",$J) D PTX^LEXTOKN
  1.  N LEXI,LEXT,LEXF,LEXA,LEXC S LEXI=0 K ARY
  1.  F  S LEXI=$O(^TMP("LEXTKN",$J,LEXI)) Q:+LEXI'>0  D
  1.  . S LEXT="" F  S LEXT=$O(^TMP("LEXTKN",$J,LEXI,LEXT)) Q:'$L(LEXT)  D
  1.  . . S LEXF=+($O(^LEX(757.01,"ASL",LEXT,0)))
  1.  . . I '$D(ARY("B",LEXT)) D
  1.  . . . N LEXC S LEXC=$O(ARY(" "),-1)+1
  1.  . . . S ARY(+LEXC)=LEXT,ARY(0)=LEXC
  1.  . . . S:+LEXF>0 ARY("F",+LEXF)=LEXT
  1.  . . . S ARY("B",LEXT)=LEXF
  1.  S LEXI=0 F  S LEXI=$O(ARY("F",LEXI)) Q:+LEXI'>0  D
  1.  . N LEXT,LEXC S LEXT=$G(ARY("F",LEXI))
  1.  . S LEXC=$O(ARY("L"," "),-1)+1
  1.  . S:$L(LEXT) ARY("L",LEXC)=LEXT
  1.  K ARY("F") S X=+($G(ARY(0))) K ^TMP("LEXTKN",$J)
  1.  Q X
  1.  ;
  1. MAX(SYS) ; Get the Maximum Number of Terms to Search
  1.  ; 
  1.  ; Input   
  1.  ; 
  1.  ;   SYS       Coding System Abbreviation (757.03,.01)
  1.  ;             or pointer to file 757.03
  1.  ;  
  1.  ; Output  
  1.  ; 
  1.  ;   $$MAX   Maximum number of term to look at before
  1.  ;           issuing a warning to the user
  1.  ;           
  1.  N LEX S LEX=0,SYS=($G(SYS)) Q:'$L(SYS) 100000  S:SYS?1N.N LEX=+SYS
  1.  S:+LEX'>0&($D(^LEX(757.03,"ASAB",SYS))) LEX=$O(^LEX(757.03,"ASAB",SYS,0))
  1.  S:+LEX'>0&($D(^LEX(757.03,"B",SYS))) LEX=$O(^LEX(757.03,"B",SYS,0))
  1.  S:+LEX'>0&($D(^LEX(757.03,"C",SYS))) LEX=$O(^LEX(757.03,"C",SYS,0))
  1.  N Y S Y=$P($G(^LEX(757.03,+LEX,2)),"^",2) S SYS=$S(+Y>0:+Y,1:100000)
  1.  Q SYS
  1. NXSAB(SYS,REV) ; Get the Next/Previous Source Abbreviation
  1.  ; 
  1.  ; Input   
  1.  ; 
  1.  ;   SYS       Coding System Abbreviation (757.03,.01)
  1.  ;               or pointer to file 757.03
  1.  ;               or null
  1.  ;   REV       Direction flag (optional)
  1.  ;                0 or null finds next in a forward direction
  1.  ;                1 finds next in a reverse direction
  1.  ;                 
  1.  ; Output  
  1.  ; 
  1.  ;   $$NXSAB   Next Source Abbreviation in the file
  1.  ;
  1.  N LEXS,LEXO,LEXR,X S (LEXS,LEXO)=$G(SYS),LEXR=+($G(REV)),X=""
  1.  I LEXS?1N.N S:$D(^LEX(757.03,+LEXS,0)) LEXO=$E($G(^LEX(757.03,+LEXS,0)),1,3)
  1.  S:LEXR>0&(LEXO="") LEXO=" "
  1.  S:LEXR'>0 X=$O(^LEX(757.03,"ASAB",LEXO))
  1.  S:LEXR>0 X=$O(^LEX(757.03,"ASAB",LEXO),-1)
  1.  Q X
  1. RECENT(X) ; Recently Updated (90 day window)
  1.  ;
  1.  ; Input
  1.  ; 
  1.  ;    X        Coding System Abbreviation (757.03,.01)
  1.  ;             or pointer to file 757.03
  1.  ;    
  1.  ; Output
  1.  ; 
  1.  ;    X        Boolean flag
  1.  ;    
  1.  ;             1  =  Coding system has been recently updated
  1.  ;                     Checks for a quarterly update by
  1.  ;                     Looking 30 days into the future
  1.  ;                     Looking 60 days into the past
  1.  ;                
  1.  ;             0  =  Coding system has NOT been recently updated
  1.  ;         
  1.  ; This API can be used to trigger code set update protocols
  1.  N LEXCD,LEXDF,LEXSRC,LEXTD S LEXSRC=$G(X),LEXCD=$$RUPD(LEXSRC)
  1.  Q:LEXCD'?7N 0  S X=0 S LEXTD=$$DT^XLFDT
  1.  I LEXCD>LEXTD S LEXDF=$$FMDIFF^XLFDT(LEXCD,LEXTD) S:LEXDF<31 X=1 Q X
  1.  I LEXTD>LEXCD S LEXDF=$$FMDIFF^XLFDT(LEXTD,LEXCD) S:LEXDF<61 X=1 Q X
  1.  Q:LEXTD=LEXCD 1
  1.  Q 0
  1. RUPD(SYS) ; Get the Date the Coding System was most Recently Updated
  1.  ;
  1.  ; Input
  1.  ; 
  1.  ;    SYS      Coding System Abbreviation (757.03,.01)
  1.  ;             or pointer to file 757.03
  1.  ;    
  1.  ; Output
  1.  ; 
  1.  ;    $$RUPD   Date of most recent update based on Today+30
  1.  ;         
  1.  ;              or
  1.  ;         
  1.  ;             -1 ^ error message 
  1.  ;    
  1.  N LEXCDT,LEXSRC S LEXCDT=$$FMADD^XLFDT($$DT^XLFDT,30),LEXSRC=$G(SYS)
  1.  S SYS=$$LUPD(LEXSRC,LEXCDT)
  1.  Q SYS
  1. LUPD(SYS,LEXVDT) ; Get the date the Coding System was Last Updated
  1.  ;
  1.  ; Input
  1.  ; 
  1.  ;    SYS      Coding System Abbreviation (757.03,.01)
  1.  ;             or pointer to file 757.03
  1.  ;    LEXVDT   Date used to determine last update from (optional)
  1.  ;    
  1.  ; Output
  1.  ; 
  1.  ;    $$LUPD   Date of last update based on date provided
  1.  ;    
  1.  ;             or
  1.  ;         
  1.  ;             The last date updated (ever) if a date is not supplied
  1.  ;         
  1.  ;             or
  1.  ;         
  1.  ;             -1 ^ error message 
  1.  ;    
  1.  N LEXCDT,LEXSAB,LEXSRC,LEXDT,LEXLUPD,LEXSYS S LEXCDT=$G(LEXVDT),LEXSRC=$G(SYS) Q:'$L(LEXSRC) "-1^Invalid coding system"
  1.  S LEXSAB=$$CSYS^LEXU(LEXSRC) Q:+LEXSAB'>0 "-1^Invalid coding system abbreviation"
  1.  S LEXSYS=$P(LEXSAB,"^",4) Q:'$D(LEXSYS) "-1^Invalid coding system"
  1.  S LEXSAB=$P(LEXSAB,"^",2) Q:$L(LEXSAB)'=3 "-1^Invalid coding system abbreviation length"
  1.  S LEXDT=$O(^LEX(757.02,"AUPD",LEXSAB,9999999),-1)
  1.  S LEXLUPD=$O(^LEX(757.02,"AUPD",LEXSAB,(9999999+.00001)),-1)
  1.  S:LEXCDT?7N LEXDT=$O(^LEX(757.02,"AUPD",LEXSAB,(LEXCDT+.00001)),-1)
  1.  S SYS="-1^Invalid date" I LEXLUPD>LEXCDT D
  1.  . S:LEXCDT?7N SYS="-1^"_LEXSYS_" coding system not implemented on "_$$FMTE^XLFDT(LEXCDT,"5Z")
  1.  . S:LEXCDT'?7N SYS="-1^"_LEXSYS_" coding system not implemented"
  1.  S:LEXDT?7N SYS=LEXDT
  1.  Q SYS