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