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 ;05/23/2017
  1. ;;2.0;LEXICON UTILITY;**80,86,103**;Sep 23, 1996;Build 2
  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. PRF(LEX,LEXVDT,LEXSAB) ; Get Code for a Preferred Term by Source
  1. ;
  1. ; Input
  1. ; LEX IEN file 757.01
  1. ; LEXVDT Date for screening
  1. ; LEXSAB Source or pointer to 757.03
  1. ;
  1. ; Output
  1. ;
  1. ; $$PPR Null if the IEN is NOT the preferred term
  1. ; CODE if the IEN is the preferred term
  1. ;
  1. N LEXCOD,LEXEF,LEXHI,LEXIEN,LEXND,LEXSIEN,LEXSRC,LEXST D VDT
  1. S LEXIEN=$G(LEX) Q:+($G(LEXIEN))'>0 "" S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB) ""
  1. S:LEXSAB?1N.N&($D(^LEX(757.03,+LEXSAB,0))) LEXSAB=$P($G(^LEX(757.03,+LEXSAB,0)),"^",1)
  1. S LEXSAB=$E($G(LEXSAB),1,3) Q:$L(LEXSAB)'=3 "" S LEXSRC=$O(^LEX(757.03,"ASAB",LEXSAB,0)) Q:+LEXSRC'>0
  1. S LEXCOD="",LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"B",LEXIEN,LEXSIEN)) Q:+LEXSIEN'>0 D Q:$L(LEXCOD)
  1. . N LEXND,LEXEF,LEXHI,LEXST S LEXND=$G(^LEX(757.02,+LEXSIEN,0)) Q:$P(LEXND,"^",5)'>0 Q:$P(LEXND,"^",3)'=LEXSRC
  1. . S LEXEF=$O(^LEX(757.02,+LEXSIEN,4,"B",(LEXVDT+.001)),-1) Q:LEXEF'?7N
  1. . S LEXHI=$O(^LEX(757.02,+LEXSIEN,4,"B",+LEXEF," "),-1) Q:+LEXHI'>0
  1. . S LEXST=$P($G(^LEX(757.02,+LEXSIEN,4,+LEXHI,0)),"^",2) Q:+LEXST'>0
  1. . S LEXCOD=$P(LEXND,"^",2)
  1. S LEX=LEXCOD
  1. Q LEX
  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.DOMAIN.EXT" D ^DIC Q:+Y>0 LEX
  1. S DIC="^DIC(4.2,",DIC(0)="M",(LEX,X)="ISC-SLC.DOMAIN.EXT"
  1. D ^DIC Q:+Y>0 LEX
  1. Q "ISC-SLC.DOMAIN.EXT"
  1. VDT ; Resolve LEXVDT
  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. 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. 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. 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
  1. ; ARY Local array
  1. ;
  1. ; Output
  1. ;
  1. ; $$PAR Number of Words
  1. ; ARY Output array
  1. ;
  1. ; Words Found
  1. ; ARY(0)=#
  1. ;
  1. ; Words in the order they appear in text
  1. ; ARY(1)=WORD1
  1. ; ARY(n)=WORDn
  1. ;
  1. ; Words alphabetically with the frequency
  1. ; ARY("B",WORDA)=# (Frequency of Use)
  1. ; ARY("B",WORDB)=#
  1. ;
  1. ; Words listed by frequency
  1. ; ARY("L",1)=SEARCHWORD1
  1. ; ARY("L",n)=SEARCHWORDn
  1. ;
  1. ; Special Variables used by the parsing logic:
  1. ;
  1. ; LEXIDX Use indexing logic
  1. ;
  1. ; LEXLOOK Use Lookup logic
  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 Source Abbr 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 Source Abbr or pointer to 757.03
  1. ; LEXVDT Versioning date (optional)
  1. ;
  1. ; Output
  1. ;
  1. ; $$LUPD Date of last update based on date provided
  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
  1. EXP(IEN) ; Get Expression for IEN
  1. ;
  1. ; Input
  1. ;
  1. ; IEN IEN of file 757.01
  1. ;
  1. ; Output
  1. ;
  1. ; $$EXP Expression for IEN
  1. ;
  1. Q $G(^LEX(757.01,+($G(IEN)),0))
  1. EXPS(IEN,CDT,ARY) ; Get Expression and Codes for IEN
  1. ;
  1. ; Input
  1. ;
  1. ; IEN IEN of file 757.01
  1. ; CDT Versioning Date
  1. ; ARY Output Array passed by reference
  1. ;
  1. ; Output
  1. ;
  1. ; ARY Local Array passed by reference
  1. ;
  1. ; ARY(IEN)=Expression
  1. ; ARY(IEN,#)= 3 piece "^" delimited string
  1. ;
  1. ; 1 Code
  1. ; 2 Coding System
  1. ; 3 Pointer to national file
  1. ;
  1. N LEXSA,LEXSOA,LEXEIEN,LEXSR,LEXN,LEXX,LEXEXP S LEXEIEN=+($G(IEN)) Q:+LEXEIEN'>0 Q:'$D(^LEX(757.01,+LEXEIEN,0))
  1. K ARY S LEXSA="ICD/ICP/10D/10P/CPT/CPC/DS4/SNM/NAN/OMA/NIC/SCC/SCT/BIR",LEXEXP=$G(^LEX(757.01,+LEXEIEN,0)) Q:'$L(LEXEXP)
  1. S LEXX=$$SOA^LEXASO(LEXEIEN,LEXSA,1,$G(CDT),.LEXSOA) S LEXSR=0 F S LEXSR=$O(LEXSOA(LEXSR)) Q:+LEXSR'>0 D
  1. . N LEXT S LEXT=$G(LEXSOA(LEXSR,"P")) I $L(LEXT) S ARY(+LEXEIEN,LEXSR)=LEXT Q
  1. . S LEXT=$G(LEXSOA(LEXSR,1)) I $L(LEXT) S ARY(+LEXEIEN,LEXSR)=LEXT
  1. S ARY(+LEXEIEN)=LEXEXP
  1. Q
  1. PREF(CODE,SAB,CDT) ; Get Preferred Expression for an Active Code
  1. ;
  1. ; Input
  1. ;
  1. ; CODE Code (Required)
  1. ; SAB Source Abbr or pointer file 757.03 (Required)
  1. ; CDT Versioning Date
  1. ;
  1. ; Output
  1. ;
  1. ; $$PREF 2 Piece "^" delimited string containing
  1. ;
  1. ; 1 Pointer to file #757.01
  1. ; 2 Display Text (Expression)
  1. ;
  1. ; or -1 ^ Error Message
  1. ;
  1. Q $$EXP^LEXCODE($G(CODE),$G(SAB),$G(CDT))