146 lines
5.5 KiB
Mathematica
146 lines
5.5 KiB
Mathematica
LEXSRC2 ; ISL/KER/FJF Classification Code Source Util ; 01/01/2004
|
|
;;2.0;LEXICON UTILITY;**25,28**;Sep 23, 1996;Build 1
|
|
;
|
|
; External References
|
|
; DBIA 3992 $$STATCHK^ICDAPIU
|
|
; DBIA 1997 $$STATCHK^ICPTAPIU
|
|
; DBIA 10103 $$DT^XLFDT
|
|
;
|
|
Q
|
|
CPT(LEXC,LEXVDT) ; Return Pointer to Active CPT
|
|
;
|
|
; Input CPT Code
|
|
; Output IEN file 81 of Active Codes only
|
|
S LEXC=$G(LEXC) Q:'$L(LEXC) "" S LEXVDT=$G(LEXVDT) S:+LEXVDT'>0 LEXVDT=$$DT^XLFDT
|
|
S LEXC=$$STATCHK^ICPTAPIU(LEXC,LEXVDT) Q:+LEXC'>0 "" S LEXC=$P(LEXC,"^",2) Q:+LEXC'>0 ""
|
|
Q +LEXC
|
|
;
|
|
ICD(LEXC,LEXVDT) ; Return Pointer to Active ICD/ICP
|
|
;
|
|
; Input ICD9 or ICD0 Code
|
|
; Output IEN file 80 or 80.1 of Active Codes only
|
|
S LEXC=$G(LEXC) Q:'$L(LEXC) "" S LEXVDT=$G(LEXVDT) S:+LEXVDT'>0 LEXVDT=$$DT^XLFDT
|
|
S LEXC=$$STATCHK^ICDAPIU(LEXC,LEXVDT) Q:+LEXC'>0 "" S LEXC=$P(LEXC,"^",2) Q:+LEXC'>0 ""
|
|
Q +LEXC
|
|
;
|
|
STATCHK(CODE,CDT,LEX) ; Check Status of a Code
|
|
;
|
|
; Input:
|
|
; CODE - Any Code (ICD/CPT/DSM etc)
|
|
; CDT - Date to screen against (default = today)
|
|
; LEX - Output Array, passed by reference
|
|
;
|
|
; Output:
|
|
;
|
|
; 2-Piece String containing the code's status
|
|
; and the IEN if the code exists, else -1.
|
|
; The following are possible outputs:
|
|
; 1 ^ IEN Active Code
|
|
; 0 ^ IEN Inactive Code
|
|
; 0 ^ -1 Code not Found
|
|
;
|
|
; ASTM Triplet in array LEX passed by reference (optional)
|
|
;
|
|
; LEX(0) = <ien 757.02> ^ <code>
|
|
; 2-Piece String containing the IEN of
|
|
; the code and the code
|
|
;
|
|
; LEX(1) = <ien 757.01> ^ <expression>
|
|
; 2-Piece String containing the IEN of
|
|
; the code's expression and the expression
|
|
;
|
|
; LEX(2) = <ien 757.03> ^ <abbr> ^ <nomen> ^ <name>
|
|
; 4-Piece String containing the IEN of
|
|
; the code's classification system, the
|
|
; source abbreviation, Nomenclature and
|
|
; the name of the classification system
|
|
;
|
|
; This API requires the ACT Cross-Reference
|
|
; ^LEX(757.02,"ACT",<code>,<status>,<date>,<ien>)
|
|
;
|
|
;
|
|
N LEXC,LEXAIEN,LEXIEN,LEXDT,X,PREVACT,PREVINA,MOSTREC,STATUS
|
|
S LEXC=$G(CODE) I '$L(LEXC) S (LEX,X)="0^-1" D UPD Q X
|
|
S LEXDT=$P($G(CDT),".",1),LEXDT=$S(+LEXDT>0:LEXDT,1:$$DT^XLFDT)
|
|
;
|
|
; Find preceding date for active codes
|
|
S PREVACT=+$O(^LEX(757.02,"ACT",LEXC_" ",3,LEXDT+.00001),-1)
|
|
S LEXAIEN=0 S:+PREVACT>0 LEXAIEN=+$O(^LEX(757.02,"ACT",LEXC_" ",3,+PREVACT," "),-1)
|
|
;
|
|
; Find preceding date for inactive codes
|
|
S PREVINA=+$O(^LEX(757.02,"ACT",LEXC_" ",2,LEXDT+.00001),-1)
|
|
S:+LEXAIEN>0&(+$O(^LEX(757.02,"ACT",LEXC_" ",2,PREVINA," "),-1)'=LEXAIEN) PREVINA=0
|
|
;
|
|
; Check that both are not zero
|
|
I PREVACT=0,PREVINA=0 S (LEX,X)="0^-1" D UPD Q X
|
|
;
|
|
; Find the most recent of the two dates and matching status
|
|
S MOSTREC=$S(PREVACT>PREVINA:PREVACT,1:PREVINA)
|
|
S STATUS=$S(PREVACT>PREVINA:1,1:0)
|
|
;
|
|
; Now cope with difficulties arising from boundary conditions
|
|
I $$BOUND D
|
|
.S STATUS='STATUS
|
|
.S MOSTREC=$O(^LEX(757.02,"ACT",LEXC_" ",STATUS+2,LEXDT),-1)
|
|
;
|
|
; Get code IEN
|
|
S LEXIEN=$O(^LEX(757.02,"ACT",LEXC_" ",STATUS+2,MOSTREC,""))
|
|
;
|
|
; Quit with valid status and code IEN
|
|
S (LEX,X)=STATUS_"^"_LEXIEN D UPD
|
|
Q X
|
|
;
|
|
BOUND() ; Do we have a boundary?
|
|
; Check if we have an entry for the next day of the complementary
|
|
; status, if so then we need to obtain the status for the
|
|
; preceding day
|
|
I $D(^LEX(757.02,"ACT",LEXC_" ",2+'STATUS,$$DPLUS1(MOSTREC))) Q 1
|
|
Q 0
|
|
;
|
|
DPLUS1(DATE) ; Add a day to the date
|
|
;
|
|
Q $$HTFM^XLFDT($$FMTH^XLFDT(DATE)+1)
|
|
;
|
|
UPD ; Update Array
|
|
N LEXI,LEXC,LEXN,LEXE,LEXS S LEXI=+($P($G(X),"^",2)) Q:+LEXI'>0
|
|
S LEXN=$G(^LEX(757.02,+LEXI,0)),LEXE=+LEXN,LEXC=$P(LEXN,"^",2)
|
|
S LEXS=+($P(LEXN,"^",3)),LEX(0)=+LEXI_"^"_LEXC
|
|
S LEX(1)=LEXE_"^"_$P($G(^LEX(757.01,+LEXE,0)),"^",1)
|
|
S LEX(2)=LEXS_"^"_$P($G(^LEX(757.03,+LEXS,0)),"^",1,3)
|
|
Q
|
|
PI(X) ; Preferred IEN for code X
|
|
N LEXE,LEXLA,LEXA,LEXS,LEXC,LEXP,LEXPF,LEXF,LEXI,LEXC,LEXFL
|
|
S LEXC=$G(X) Q:'$L(LEXC) "" S (LEXP,LEXF,LEXI)=0,LEXPF(0)=LEXC
|
|
F S LEXI=$O(^LEX(757.02,"CODE",(LEXC_" "),LEXI)) Q:+LEXI=0!(LEXP>0) D
|
|
. S:+LEXF'>0 LEXF=LEXI S LEXFL=$S(+($P($G(^LEX(757.02,+LEXI,0)),"^",5))>0:1,1:0)
|
|
. S LEXE=0,LEXLA="" F S LEXE=$O(^LEX(757.02,+LEXI,4,LEXE)) Q:+LEXE=0 D
|
|
. . S LEXS=$P($G(^LEX(757.02,+LEXI,4,LEXE,0)),"^",2) Q:+LEXS'>0
|
|
. . S LEXA=$P($G(^LEX(757.02,+LEXI,4,LEXE,0)),"^",1)
|
|
. . S:+LEXA>+LEXLA LEXLA=+LEXA
|
|
. S:+LEXLA>0 LEXPF(LEXFL,LEXLA,LEXI)=""
|
|
S X="" I $D(LEXPF(1)) S X=$O(LEXPF(1," "),-1),X=$O(LEXPF(1,+X," "),-1)
|
|
I '$D(LEXPF(1)),$D(LEXPF(0)) S X=$O(LEXPF(0," "),-1),X=$O(LEXPF(0,+X," "),-1)
|
|
Q X
|
|
;
|
|
HIST(CODE,ARY) ; Activation History
|
|
;
|
|
; Input:
|
|
; CODE - Code - REQUIRED
|
|
; .ARY - Array, passed by Reference
|
|
;
|
|
; Output:
|
|
; ARY(0) = Number of Activation History Entries
|
|
; ARY(<date>) = status where: 1 is Active
|
|
; ARY("IEN") = <ien>
|
|
;
|
|
N LEXC,LEXI,LEXN,LEXD,LEXF,LEXO S LEXC=$G(CODE) Q:'$L(LEXC) -1
|
|
S LEXI=$$PI(LEXC),ARY("IEN")=LEXI,LEXO=""
|
|
M LEXO=^LEX(757.02,+LEXI,4) K LEXO("B")
|
|
S ARY(0)=+($P($G(LEXO(0)),U,4))
|
|
S:+ARY(0)=0 ARY(0)=-1 K:ARY(0)=-1 ARY("IEN")
|
|
S (LEXI,LEXC)=0 F S LEXI=$O(LEXO(LEXI)) Q:+LEXI=0 D
|
|
. S LEXD=$P($G(LEXO(LEXI,0)),U,1) Q:+LEXD=0
|
|
. S LEXF=$P($G(LEXO(LEXI,0)),U,2) Q:'$L(LEXF)
|
|
. S LEXC=LEXC+1,ARY(0)=LEXC,ARY(LEXD)=LEXF
|
|
Q ARY(0)
|