LEXU3 ;ISL/KER - Miscellaneous Lexicon Utilities ;05/23/2017
;;2.0;LEXICON UTILITY;**80,86,103**;Sep 23, 1996;Build 2
;
; 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
;
PRF(LEX,LEXVDT,LEXSAB) ; Get Code for a Preferred Term by Source
;
; Input
; LEX IEN file 757.01
; LEXVDT Date for screening
; LEXSAB Source or pointer to 757.03
;
; Output
;
; $$PPR Null if the IEN is NOT the preferred term
; CODE if the IEN is the preferred term
;
N LEXCOD,LEXEF,LEXHI,LEXIEN,LEXND,LEXSIEN,LEXSRC,LEXST D VDT
S LEXIEN=$G(LEX) Q:+($G(LEXIEN))'>0 "" S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB) ""
S:LEXSAB?1N.N&($D(^LEX(757.03,+LEXSAB,0))) LEXSAB=$P($G(^LEX(757.03,+LEXSAB,0)),"^",1)
S LEXSAB=$E($G(LEXSAB),1,3) Q:$L(LEXSAB)'=3 "" S LEXSRC=$O(^LEX(757.03,"ASAB",LEXSAB,0)) Q:+LEXSRC'>0
S LEXCOD="",LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"B",LEXIEN,LEXSIEN)) Q:+LEXSIEN'>0 D Q:$L(LEXCOD)
. N LEXND,LEXEF,LEXHI,LEXST S LEXND=$G(^LEX(757.02,+LEXSIEN,0)) Q:$P(LEXND,"^",5)'>0 Q:$P(LEXND,"^",3)'=LEXSRC
. S LEXEF=$O(^LEX(757.02,+LEXSIEN,4,"B",(LEXVDT+.001)),-1) Q:LEXEF'?7N
. S LEXHI=$O(^LEX(757.02,+LEXSIEN,4,"B",+LEXEF," "),-1) Q:+LEXHI'>0
. S LEXST=$P($G(^LEX(757.02,+LEXSIEN,4,+LEXHI,0)),"^",2) Q:+LEXST'>0
. S LEXCOD=$P(LEXND,"^",2)
S LEX=LEXCOD
Q LEX
ADR(LEX) ; Mailing Address
N DIC,DTOUT,DUOUT,X,Y S DIC="^DIC(4.2,",DIC(0)="M"
S (LEX,X)="FO-SLC.DOMAIN.EXT" D ^DIC Q:+Y>0 LEX
S DIC="^DIC(4.2,",DIC(0)="M",(LEX,X)="ISC-SLC.DOMAIN.EXT"
D ^DIC Q:+Y>0 LEX
Q "ISC-SLC.DOMAIN.EXT"
VDT ; Resolve LEXVDT
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))
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))
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
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
; ARY Local array
;
; Output
;
; $$PAR Number of Words
; ARY Output array
;
; Words Found
; ARY(0)=#
;
; Words in the order they appear in text
; ARY(1)=WORD1
; ARY(n)=WORDn
;
; Words alphabetically with the frequency
; ARY("B",WORDA)=# (Frequency of Use)
; ARY("B",WORDB)=#
;
; Words listed by frequency
; ARY("L",1)=SEARCHWORD1
; ARY("L",n)=SEARCHWORDn
;
; Special Variables used by the parsing logic:
;
; LEXIDX Use indexing logic
;
; LEXLOOK Use Lookup logic
;
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 Source Abbr 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 Source Abbr or pointer to 757.03
; LEXVDT Versioning date (optional)
;
; Output
;
; $$LUPD Date of last update based on date provided
;
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
EXP(IEN) ; Get Expression for IEN
;
; Input
;
; IEN IEN of file 757.01
;
; Output
;
; $$EXP Expression for IEN
;
Q $G(^LEX(757.01,+($G(IEN)),0))
EXPS(IEN,CDT,ARY) ; Get Expression and Codes for IEN
;
; Input
;
; IEN IEN of file 757.01
; CDT Versioning Date
; ARY Output Array passed by reference
;
; Output
;
; ARY Local Array passed by reference
;
; ARY(IEN)=Expression
; ARY(IEN,#)= 3 piece "^" delimited string
;
; 1 Code
; 2 Coding System
; 3 Pointer to national file
;
N LEXSA,LEXSOA,LEXEIEN,LEXSR,LEXN,LEXX,LEXEXP S LEXEIEN=+($G(IEN)) Q:+LEXEIEN'>0 Q:'$D(^LEX(757.01,+LEXEIEN,0))
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)
S LEXX=$$SOA^LEXASO(LEXEIEN,LEXSA,1,$G(CDT),.LEXSOA) S LEXSR=0 F S LEXSR=$O(LEXSOA(LEXSR)) Q:+LEXSR'>0 D
. N LEXT S LEXT=$G(LEXSOA(LEXSR,"P")) I $L(LEXT) S ARY(+LEXEIEN,LEXSR)=LEXT Q
. S LEXT=$G(LEXSOA(LEXSR,1)) I $L(LEXT) S ARY(+LEXEIEN,LEXSR)=LEXT
S ARY(+LEXEIEN)=LEXEXP
Q
PREF(CODE,SAB,CDT) ; Get Preferred Expression for an Active Code
;
; Input
;
; CODE Code (Required)
; SAB Source Abbr or pointer file 757.03 (Required)
; CDT Versioning Date
;
; Output
;
; $$PREF 2 Piece "^" delimited string containing
;
; 1 Pointer to file #757.01
; 2 Display Text (Expression)
;
; or -1 ^ Error Message
;
Q $$EXP^LEXCODE($G(CODE),$G(SAB),$G(CDT))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXU3 10953 printed Apr 09, 2024@21:14:23 Page 2
LEXU3 ;ISL/KER - Miscellaneous Lexicon Utilities ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**80,86,103**;Sep 23, 1996;Build 2
+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 ;
PRF(LEX,LEXVDT,LEXSAB) ; Get Code for a Preferred Term by Source
+1 ;
+2 ; Input
+3 ; LEX IEN file 757.01
+4 ; LEXVDT Date for screening
+5 ; LEXSAB Source or pointer to 757.03
+6 ;
+7 ; Output
+8 ;
+9 ; $$PPR Null if the IEN is NOT the preferred term
+10 ; CODE if the IEN is the preferred term
+11 ;
+12 NEW LEXCOD,LEXEF,LEXHI,LEXIEN,LEXND,LEXSIEN,LEXSRC,LEXST
DO VDT
+13 SET LEXIEN=$GET(LEX)
if +($GET(LEXIEN))'>0
QUIT ""
SET LEXSAB=$GET(LEXSAB)
if '$LENGTH(LEXSAB)
QUIT ""
+14 if LEXSAB?1N.N&($DATA(^LEX(757.03,+LEXSAB,0)))
SET LEXSAB=$PIECE($GET(^LEX(757.03,+LEXSAB,0)),"^",1)
+15 SET LEXSAB=$EXTRACT($GET(LEXSAB),1,3)
if $LENGTH(LEXSAB)'=3
QUIT ""
SET LEXSRC=$ORDER(^LEX(757.03,"ASAB",LEXSAB,0))
if +LEXSRC'>0
QUIT
+16 SET LEXCOD=""
SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"B",LEXIEN,LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:1
+17 NEW LEXND,LEXEF,LEXHI,LEXST
SET LEXND=$GET(^LEX(757.02,+LEXSIEN,0))
if $PIECE(LEXND,"^",5)'>0
QUIT
if $PIECE(LEXND,"^",3)'=LEXSRC
QUIT
+18 SET LEXEF=$ORDER(^LEX(757.02,+LEXSIEN,4,"B",(LEXVDT+.001)),-1)
if LEXEF'?7N
QUIT
+19 SET LEXHI=$ORDER(^LEX(757.02,+LEXSIEN,4,"B",+LEXEF," "),-1)
if +LEXHI'>0
QUIT
+20 SET LEXST=$PIECE($GET(^LEX(757.02,+LEXSIEN,4,+LEXHI,0)),"^",2)
if +LEXST'>0
QUIT
+21 SET LEXCOD=$PIECE(LEXND,"^",2)
End DoDot:1
if $LENGTH(LEXCOD)
QUIT
+22 SET LEX=LEXCOD
+23 QUIT LEX
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.DOMAIN.EXT"
DO ^DIC
if +Y>0
QUIT LEX
+3 SET DIC="^DIC(4.2,"
SET DIC(0)="M"
SET (LEX,X)="ISC-SLC.DOMAIN.EXT"
+4 DO ^DIC
if +Y>0
QUIT LEX
+5 QUIT "ISC-SLC.DOMAIN.EXT"
VDT ; Resolve LEXVDT
+1 NEW LEXSD
IF $PIECE($GET(LEXVDT),".",1)?7N
Begin DoDot:1
+2 SET LEXVDT=$PIECE($GET(LEXVDT),".",1)
+3 SET LEXVDT=$$FMADD^XLFDT(LEXVDT,0)
+4 if LEXVDT'>0
SET LEXVDT=$$DT^XLFDT
+5 if $DATA(^TMP("LEXSCH",$JOB))
SET ^TMP("LEXSCH",$JOB,"VDT",0)=+($GET(LEXVDT))
+6 if $DATA(^TMP("LEXSCH",$JOB))
SET ^TMP("LEXSCH",$JOB,"VDT",1)="Version Date Check: "_$$FMTE^XLFDT($GET(LEXVDT))
End DoDot:1
QUIT
+7 SET LEXSD=$PIECE($GET(^TMP("LEXSCH",$JOB,"VDT",0)),".",1)
+8 IF $PIECE($GET(LEXVDT),".",1)'?7N
IF LEXSD?7N
Begin DoDot:1
+9 SET LEXVDT=$PIECE($GET(LEXSD),".",1)
+10 SET LEXVDT=$$FMADD^XLFDT(LEXVDT,0)
+11 if LEXVDT'>0
SET LEXVDT=$$DT^XLFDT
+12 if $DATA(^TMP("LEXSCH",$JOB))
SET ^TMP("LEXSCH",$JOB,"VDT",0)=+($GET(LEXVDT))
+13 if $DATA(^TMP("LEXSCH",$JOB))
SET ^TMP("LEXSCH",$JOB,"VDT",1)="Version Date Check: "_$$FMTE^XLFDT($GET(LEXVDT))
End DoDot:1
+14 IF $PIECE($GET(LEXVDT),".",1)'?7N
Begin DoDot:1
+15 SET LEXVDT=$$DT^XLFDT
+16 if $DATA(^TMP("LEXSCH",$JOB))
SET ^TMP("LEXSCH",$JOB,"VDT",0)=+($GET(LEXVDT))
+17 if $DATA(^TMP("LEXSCH",$JOB))
SET ^TMP("LEXSCH",$JOB,"VDT",1)="Version Date Check: "_$$FMTE^XLFDT($GET(LEXVDT))
End DoDot:1
+18 QUIT
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
+5 ; ARY Local array
+6 ;
+7 ; Output
+8 ;
+9 ; $$PAR Number of Words
+10 ; ARY Output array
+11 ;
+12 ; Words Found
+13 ; ARY(0)=#
+14 ;
+15 ; Words in the order they appear in text
+16 ; ARY(1)=WORD1
+17 ; ARY(n)=WORDn
+18 ;
+19 ; Words alphabetically with the frequency
+20 ; ARY("B",WORDA)=# (Frequency of Use)
+21 ; ARY("B",WORDB)=#
+22 ;
+23 ; Words listed by frequency
+24 ; ARY("L",1)=SEARCHWORD1
+25 ; ARY("L",n)=SEARCHWORDn
+26 ;
+27 ; Special Variables used by the parsing logic:
+28 ;
+29 ; LEXIDX Use indexing logic
+30 ;
+31 ; LEXLOOK Use Lookup logic
+32 ;
+33 NEW LEXTI,LEXTL,X
SET LEXTI=$DATA(LEXIDX)
SET LEXTL=$DATA(LEXLOOK)
NEW LEXIDX,LEXLOOK
+34 IF LEXTI>0
SET LEXIDX=""
SET LEXTL=0
KILL LEXLOOK
+35 IF LEXTL>0
SET LEXLOOK=""
SET LEXTI=0
KILL LEXIDX
+36 if '$DATA(LEXLOOK)&('$DATA(LEXIDX))
SET LEXIDX=""
+37 SET (X,TEXT)=$GET(TEXT)
KILL ^TMP("LEXTKN",$JOB)
DO PTX^LEXTOKN
+38 NEW LEXI,LEXT,LEXF,LEXA,LEXC
SET LEXI=0
KILL ARY
+39 FOR
SET LEXI=$ORDER(^TMP("LEXTKN",$JOB,LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+40 SET LEXT=""
FOR
SET LEXT=$ORDER(^TMP("LEXTKN",$JOB,LEXI,LEXT))
if '$LENGTH(LEXT)
QUIT
Begin DoDot:2
+41 SET LEXF=+($ORDER(^LEX(757.01,"ASL",LEXT,0)))
+42 IF '$DATA(ARY("B",LEXT))
Begin DoDot:3
+43 NEW LEXC
SET LEXC=$ORDER(ARY(" "),-1)+1
+44 SET ARY(+LEXC)=LEXT
SET ARY(0)=LEXC
+45 if +LEXF>0
SET ARY("F",+LEXF)=LEXT
+46 SET ARY("B",LEXT)=LEXF
End DoDot:3
End DoDot:2
End DoDot:1
+47 SET LEXI=0
FOR
SET LEXI=$ORDER(ARY("F",LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+48 NEW LEXT,LEXC
SET LEXT=$GET(ARY("F",LEXI))
+49 SET LEXC=$ORDER(ARY("L"," "),-1)+1
+50 if $LENGTH(LEXT)
SET ARY("L",LEXC)=LEXT
End DoDot:1
+51 KILL ARY("F")
SET X=+($GET(ARY(0)))
KILL ^TMP("LEXTKN",$JOB)
+52 QUIT X
+53 ;
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 Source Abbr or pointer to file 757.03
+5 ;
+6 ; Output
+7 ;
+8 ; X Boolean flag
+9 ;
+10 ; 1 = Coding system has been recently updated
+11 ; Checks for a quarterly update by
+12 ; Looking 30 days into the future
+13 ; Looking 60 days into the past
+14 ;
+15 ; 0 = Coding system has NOT been recently updated
+16 ;
+17 ; This API can be used to trigger code set update protocols
+18 NEW LEXCD,LEXDF,LEXSRC,LEXTD
SET LEXSRC=$GET(X)
SET LEXCD=$$RUPD(LEXSRC)
+19 if LEXCD'?7N
QUIT 0
SET X=0
SET LEXTD=$$DT^XLFDT
+20 IF LEXCD>LEXTD
SET LEXDF=$$FMDIFF^XLFDT(LEXCD,LEXTD)
if LEXDF<31
SET X=1
QUIT X
+21 IF LEXTD>LEXCD
SET LEXDF=$$FMDIFF^XLFDT(LEXTD,LEXCD)
if LEXDF<61
SET X=1
QUIT X
+22 if LEXTD=LEXCD
QUIT 1
+23 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 Source Abbr or pointer to 757.03
+5 ; LEXVDT Versioning date (optional)
+6 ;
+7 ; Output
+8 ;
+9 ; $$LUPD Date of last update based on date provided
+10 ;
+11 NEW LEXCDT,LEXSAB,LEXSRC,LEXDT,LEXLUPD,LEXSYS
SET LEXCDT=$GET(LEXVDT)
SET LEXSRC=$GET(SYS)
if '$LENGTH(LEXSRC)
QUIT "-1^Invalid coding system"
+12 SET LEXSAB=$$CSYS^LEXU(LEXSRC)
if +LEXSAB'>0
QUIT "-1^Invalid coding system abbreviation"
+13 SET LEXSYS=$PIECE(LEXSAB,"^",4)
if '$DATA(LEXSYS)
QUIT "-1^Invalid coding system"
+14 SET LEXSAB=$PIECE(LEXSAB,"^",2)
if $LENGTH(LEXSAB)'=3
QUIT "-1^Invalid coding system abbreviation length"
+15 SET LEXDT=$ORDER(^LEX(757.02,"AUPD",LEXSAB,9999999),-1)
+16 SET LEXLUPD=$ORDER(^LEX(757.02,"AUPD",LEXSAB,(9999999+.00001)),-1)
+17 if LEXCDT?7N
SET LEXDT=$ORDER(^LEX(757.02,"AUPD",LEXSAB,(LEXCDT+.00001)),-1)
+18 SET SYS="-1^Invalid date"
IF LEXLUPD>LEXCDT
Begin DoDot:1
+19 if LEXCDT?7N
SET SYS="-1^"_LEXSYS_" coding system not implemented on "_$$FMTE^XLFDT(LEXCDT,"5Z")
+20 if LEXCDT'?7N
SET SYS="-1^"_LEXSYS_" coding system not implemented"
End DoDot:1
+21 if LEXDT?7N
SET SYS=LEXDT
+22 QUIT SYS
EXP(IEN) ; Get Expression for IEN
+1 ;
+2 ; Input
+3 ;
+4 ; IEN IEN of file 757.01
+5 ;
+6 ; Output
+7 ;
+8 ; $$EXP Expression for IEN
+9 ;
+10 QUIT $GET(^LEX(757.01,+($GET(IEN)),0))
EXPS(IEN,CDT,ARY) ; Get Expression and Codes for IEN
+1 ;
+2 ; Input
+3 ;
+4 ; IEN IEN of file 757.01
+5 ; CDT Versioning Date
+6 ; ARY Output Array passed by reference
+7 ;
+8 ; Output
+9 ;
+10 ; ARY Local Array passed by reference
+11 ;
+12 ; ARY(IEN)=Expression
+13 ; ARY(IEN,#)= 3 piece "^" delimited string
+14 ;
+15 ; 1 Code
+16 ; 2 Coding System
+17 ; 3 Pointer to national file
+18 ;
+19 NEW LEXSA,LEXSOA,LEXEIEN,LEXSR,LEXN,LEXX,LEXEXP
SET LEXEIEN=+($GET(IEN))
if +LEXEIEN'>0
QUIT
if '$DATA(^LEX(757.01,+LEXEIEN,0))
QUIT
+20 KILL ARY
SET LEXSA="ICD/ICP/10D/10P/CPT/CPC/DS4/SNM/NAN/OMA/NIC/SCC/SCT/BIR"
SET LEXEXP=$GET(^LEX(757.01,+LEXEIEN,0))
if '$LENGTH(LEXEXP)
QUIT
+21 SET LEXX=$$SOA^LEXASO(LEXEIEN,LEXSA,1,$GET(CDT),.LEXSOA)
SET LEXSR=0
FOR
SET LEXSR=$ORDER(LEXSOA(LEXSR))
if +LEXSR'>0
QUIT
Begin DoDot:1
+22 NEW LEXT
SET LEXT=$GET(LEXSOA(LEXSR,"P"))
IF $LENGTH(LEXT)
SET ARY(+LEXEIEN,LEXSR)=LEXT
QUIT
+23 SET LEXT=$GET(LEXSOA(LEXSR,1))
IF $LENGTH(LEXT)
SET ARY(+LEXEIEN,LEXSR)=LEXT
End DoDot:1
+24 SET ARY(+LEXEIEN)=LEXEXP
+25 QUIT
PREF(CODE,SAB,CDT) ; Get Preferred Expression for an Active Code
+1 ;
+2 ; Input
+3 ;
+4 ; CODE Code (Required)
+5 ; SAB Source Abbr or pointer file 757.03 (Required)
+6 ; CDT Versioning Date
+7 ;
+8 ; Output
+9 ;
+10 ; $$PREF 2 Piece "^" delimited string containing
+11 ;
+12 ; 1 Pointer to file #757.01
+13 ; 2 Display Text (Expression)
+14 ;
+15 ; or -1 ^ Error Message
+16 ;
+17 QUIT $$EXP^LEXCODE($GET(CODE),$GET(SAB),$GET(CDT))
