- 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 Feb 18, 2025@23:35:55 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))