LEXAR8 ;ISL/KER - Look-up Response (CONCEPT USAGE update) ;05/23/2017
;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^AUPNPROB("B") ICR 1611
; ^LEX(757, SACC 1.3
; ^LEX(757.001, SACC 1.3
; ^LEX(757.01, SACC 1.3
; ^LEX(757.02, SACC 1.3
; ^LEX(757.1, SACC 1.3
; ^TMP("LEXPL",$J) SACC 2.3.2.5.1
;
; External References
; HOME^%ZIS ICR 10086
; ^%ZTLOAD ICR 10063
; FILE^DIE ICR 2053
; IX1^DIK ICR 10013
; IX2^DIK ICR 10013
; $$IENS^DILF ICR 2054
; $$GET1^DIQ ICR 2056
; $$CODEC^ICDEX ICR 5747
; $$CSI^ICDEX ICR 5747
; $$SAB^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
UPDT ; Update CONCEPT USAGE file 757.001 (TaskMan)
N X,Y,ZTQUEUED,ZTREQ,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTPRI,LEXENV
S LEXENV=$$ENV Q:+LEXENV'>0 S ZTRTN="UPD^LEXAR8",ZTPRI=4,ZTIO="",ZTDTH=$H
S ZTDESC="Update CONCEPT USAGE file 757.001 from the Problem List"
D:$D(LEXTEST) @ZTRTN D:'$D(LEXTEST) ^%ZTLOAD
I +($G(ZTSK))>0,'$D(XPDENV),'$D(LEXBUILD),'$D(LEXIGHF),'$D(LEXREQP) D
. W !,"CONCEPT USAGE update tasked (Task #"_+($G(ZTSK))_"). "
Q
UPD ; Update CONCEPT USAGE file 757.001 (using Problem List)
K ^TMP("LEXPL",$J) N LEXNOT,LEXIIEN,LEXTD,LEXCT S LEXCT=0 S LEXNOT(5570)="",LEXNOT(521774)=""
S LEXTD=$$DT^XLFDT,LEXIIEN=0 F S LEXIIEN=$O(^AUPNPROB("B",LEXIIEN)) Q:+LEXIIEN'>0 D
. N LEXPIEN S LEXPIEN=0 F S LEXPIEN=$O(^AUPNPROB("B",LEXIIEN,LEXPIEN)) Q:+LEXPIEN'>0 D
. . N LEXLEX,LEXSCTC,LEXSTA,LEXSIEN
. . Q:$D(LEXNOT(+LEXIIEN))
. . S LEXCOD=$$CODEC^ICDEX(80,LEXIIEN) I $L(LEXCOD) D
. . . S LEXSYS=$$CSI^ICDEX(80,LEXIIEN) Q:"^1^30^"'[("^"_LEXSYS_"^")
. . . S LEXSAB=$E($$SAB^ICDEX(LEXSYS),1,3) Q:"^ICD^10D^"'[("^"_LEXSAB_"^")
. . . S LEXSTA=$$STATCHK^LEXSRC2(LEXCOD,LEXTD,,LEXSAB)
. . . S LEXSIEN=$P(LEXSTA,"^",2) Q:+LEXSIEN'>0
. . . S ^TMP("LEXPL",$J,"ICD",LEXSIEN)=+($G(^TMP("LEXPL",$J,"ICD",LEXSIEN)))+1
. . . S:'$D(^TMP("LEXPL",$J,"ICD",LEXSIEN,"SAB")) ^TMP("LEXPL",$J,"ICD",LEXSIEN,"SAB")=LEXSAB
. . . S:LEXSAB="10D" ^TMP("LEXPL",$J,"ICD",LEXSIEN,"SAB")=LEXSAB
. . S LEXCOD=$$GET1^DIQ(9000011,LEXPIEN,80001) I $L(LEXCOD) D
. . . S LEXSTA=$$STATCHK^LEXSRC2(LEXCOD,LEXTD,,"SCT")
. . . S LEXSIEN=$P(LEXSTA,"^",2) Q:+LEXSIEN'>0
. . . S ^TMP("LEXPL",$J,"SCT",LEXSIEN)=+($G(^TMP("LEXPL",$J,"SCT",LEXSIEN)))+1
. . . S ^TMP("LEXPL",$J,"SCT",LEXSIEN,"SAB")="SCT"
S LEXSIEN=0 F S LEXSIEN=$O(^TMP("LEXPL",$J,"ICD",LEXSIEN)) Q:+LEXSIEN'>0 D
. N LEXCOD,LEXNOD,LEXFRQ,LEXSYS,LEXSAB,LEXDES,LEXSTA,LEXORG,LEXEIEN,LEXMIEN,LEXNEW
. S LEXNOD=$G(^LEX(757.02,+LEXSIEN,0)),LEXEIEN=+LEXNOD Q:+LEXEIEN'>0 Q:"^1^30^"'[("^"_$P(LEXNOD,"^",3)_"^")
. S LEXMIEN=+($P($G(LEXNOD),"^",4)) I LEXMIEN'>0 K ^TMP("LEXPL",$J,"ICD",LEXSIEN) Q
. S ^TMP("LEXPL",$J,"ICD","MC",LEXMIEN)=""
. S LEXSAB=$G(^TMP("LEXPL",$J,"ICD",LEXSIEN,"SAB")),LEXORG=$$ORIG(LEXMIEN)
. S LEXFRQ=$G(^TMP("LEXPL",$J,"ICD",LEXSIEN))
. S LEXNEW=LEXFRQ+LEXORG
. D UPDF(+LEXMIEN,"PL ICD",+LEXORG,+LEXNEW)
S LEXSIEN=0 F S LEXSIEN=$O(^TMP("LEXPL",$J,"SCT",LEXSIEN)) Q:+LEXSIEN'>0 D
. N LEXCOD,LEXNOD,LEXFRQ,LEXSYS,LEXSAB,LEXDES,LEXSTA,LEXORG,LEXEIEN,LEXMIEN,LEXNEW
. S LEXNOD=$G(^LEX(757.02,+LEXSIEN,0)),LEXEIEN=+LEXNOD Q:+LEXEIEN'>0 Q:$P(LEXNOD,"^",3)'=56
. S LEXMIEN=+($P($G(LEXNOD),"^",4)) I LEXMIEN'>0 K ^TMP("LEXPL",$J,"SCT",LEXSIEN) Q
. S ^TMP("LEXPL",$J,"SCT","MC",LEXMIEN)=""
. S LEXSAB="SCT",LEXORG=$$ORIG(LEXMIEN),LEXFRQ=$G(^TMP("LEXPL",$J,"SCT",LEXSIEN)),LEXNEW=LEXFRQ+LEXORG
. D UPDF(+LEXMIEN,"PL SCT",+LEXORG,+LEXNEW)
F LEXSAB="ICD","10D","SCT" D
. N LEXS,LEXSIEN S LEXS=$S(LEXSAB="ICD":"SY ICD",LEXSAB="10D":"SY ICD",LEXSAB="SCT":"SY SCT",1:("SY "_LEXSAB))
. S LEXS="Update "_LEXS,LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"ASRC",LEXSAB,LEXSIEN)) Q:+LEXSIEN'>0 D
. . N LEXMIEN,LEXORG,LEXFRQ,LEXEIEN,LEXND S LEXMIEN=+($P($G(^LEX(757.02,+LEXSIEN,0)),"^",4)) Q:+LEXMIEN'>0
. . Q:$D(^TMP("LEXPL",$J,"ICD","MC",LEXMIEN))!($D(^TMP("LEXPL",$J,"SCT","MC",LEXMIEN)))
. . S LEXEIEN=+($P($G(^LEX(757,+LEXMIEN,0)),"^",1)) Q:LEXEIEN'>0
. . Q:$P($G(^LEX(757.01,+LEXEIEN,1)),"^",5)>0
. . S (LEXORG,LEXFRQ)=$$ORIG(LEXMIEN) S LEXND=LEXMIEN_"^"_LEXORG_"^"_LEXFRQ
. . I $G(^LEX(757.001,+LEXMIEN,0))'=LEXND D UPDF(+LEXMIEN,LEXS,+LEXORG,+LEXFRQ)
W:'$D(ZTQUEUED)&(+($G(LEXCT))>0) !!,+($G(LEXCT))," changes made"
W:'$D(ZTQUEUED)&(+($G(LEXCT))'>0) !!,"No changes made" K ^TMP("LEXPL",$J)
Q
UPDF(M,S,X,Y) ; Update CONCEPT USAGE file 757.001 (FileMan)
N DA,LEXBUILD,LEXERR,LEXFDA,LEXFRQ,LEXOFQ,LEXIENS,LEXIGHF,LEXMIEN,LEXNEW,LEXOLD,LEXORG,LEXREQP,LEXS,XPDENV
S LEXMIEN=+($G(M)),LEXS=$G(X),LEXORG=$G(X),LEXFRQ=$G(Y) Q:LEXMIEN'>0 Q:'$D(^LEX(757.001,+LEXMIEN,0))
Q:+($G(^LEX(757.001,+LEXMIEN,0)))'=+LEXMIEN Q:$D(^TMP("LEXPL",$J,"MAJ",LEXMIEN)) Q:LEXORG'?1N.N Q:LEXFRQ'?1N.N
S LEXOFQ=+($P($G(^LEX(757.001,+LEXMIEN,0)),"^",3)) S DA=+LEXMIEN
S LEXIENS=$$IENS^DILF(.DA) S LEXFDA(757.001,LEXIENS,.01)=+LEXMIEN,LEXFDA(757.001,LEXIENS,1)=+LEXORG
S LEXNEW=+LEXMIEN_"^"_+LEXORG_"^"_+LEXFRQ,LEXOLD=$G(^LEX(757.001,+LEXMIEN,0)) Q:LEXNEW=LEXOLD
S LEXFDA(757.001,LEXIENS,2)=+LEXFRQ K LEXERR D FILE^DIE(,"LEXFDA","LEXERR")
S:'$D(LEXERR) LEXCT=+($G(LEXCT))+1 S ^TMP("LEXPL",$J,"MAJ",LEXMIEN)="" I $D(LEXTEST)&('$D(ZTQUEUED)) D
. N LEXID S LEXID=$G(LEXS) W !,LEXS,?15,LEXMIEN,?25,LEXORG,?30,LEXFRQ
. I LEXOFQ?1N.N,LEXOFQ'=LEXFRQ W ?35,"(formerly ",LEXOFQ,")"
Q
;
CLEART ; Set the Frequency to the Original Value (TaskMan)
N X,Y,ZTQUEUED,ZTREQ,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTPRI,LEXENV
S LEXENV=$$ENV Q:+LEXENV'>0 S ZTRTN="CLEAR^LEXAR8",ZTPRI=4,ZTIO="",ZTDTH=$H
S ZTDESC="Update CONCEPT USAGE file 757.001 from the Problem List"
D:$D(LEXTEST) @ZTRTN D:'$D(LEXTEST) ^%ZTLOAD
I +($G(ZTSK))>0,'$D(XPDENV),'$D(LEXBUILD),'$D(LEXIGHF),'$D(LEXREQP) D
. W !,"CONCEPT USAGE update tasked (Task #"_+($G(ZTSK))_"). "
Q
CLEAR ; Set the Frequency to the Original Value
N LEXCT,LEXMIEN S (LEXCT,LEXMIEN)=0 F S LEXMIEN=$O(^LEX(757,LEXMIEN)) Q:+LEXMIEN'>0 D
. N LEXORG,LEXFRQ,LEXOLD,LEXOFQ,LEXND S (LEXORG,LEXFRQ)=$$ORIG(+LEXMIEN)
. S LEXND=+LEXMIEN_"^"_+LEXORG_"^"_+LEXFRQ
. S LEXOLD=$G(^LEX(757.001,+LEXMIEN,0)),LEXOFQ=$P(LEXOLD,"^",3)
. I LEXOLD'=LEXND D EDIT(+LEXMIEN,"Clear",+LEXORG,+LEXFRQ)
K ^TMP("LEXPL",$J) W:'$D(ZTQUEUED)&(+($G(LEXCT))>0) !!,+($G(LEXCT))," changes made"
W:'$D(ZTQUEUED)&(+($G(LEXCT))'>0) !!,"No changes made"
Q
;
POPT ; Populate the Original Value (ONLY) (TaskMan)
N X,Y,ZTQUEUED,ZTREQ,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTPRI,LEXENV
S LEXENV=$$ENV Q:+LEXENV'>0 S ZTRTN="POP^LEXAR8",ZTPRI=4,ZTIO="",ZTDTH=$H
S ZTDESC="Update CONCEPT USAGE file 757.001 from the Problem List"
D:$D(LEXTEST) @ZTRTN D:'$D(LEXTEST) ^%ZTLOAD
I +($G(ZTSK))>0,'$D(XPDENV),'$D(LEXBUILD),'$D(LEXIGHF),'$D(LEXREQP) D
. W !,"CONCEPT USAGE update tasked (Task #"_+($G(ZTSK))_"). "
Q
POP ; Populate the Original Value (ONLY)
N LEXCT,LEXMIEN S (LEXCT,LEXMIEN)=0 F S LEXMIEN=$O(^LEX(757,LEXMIEN)) Q:+LEXMIEN'>0 D
. N LEXORG,LEXFRQ,LEXDIF,LEXND
. I '$D(^LEX(757.001,+LEXMIEN,0)) D Q
. . N LEXORG,LEXFRQ,LEXND S (LEXORG,LEXFRQ)=$$ORIG(+LEXMIEN) S LEXND=+LEXMIEN_"^"_+LEXORG_"^"_+LEXFRQ
. . N DA,DIK S DA=+LEXMIEN,DIK="^LEX(757.001," D IX2^DIK S ^LEX(757.001,+LEXMIEN,0)=LEXND
. . N DA,DIK S DA=+LEXMIEN,DIK="^LEX(757.001," D IX1^DIK S LEXCT=LEXCT+1
. . I $D(LEXTEST)&('$D(ZTQUEUED)) D
. . . W !,"Populate",?15,LEXMIEN,?25,LEXORG,?30,LEXFRQ,?35,"(new)"
. S LEXND=$G(^LEX(757.001,+LEXMIEN,0)),LEXORG=$P(LEXND,"^",2),LEXFRQ=$P(LEXND,"^",2)
. S LEXDIF=LEXFRQ-LEXORG S:LEXDIF<0 LEXDIF=0
. S (LEXORG,LEXFRQ)=$$ORIG(+LEXMIEN),LEXFRQ=LEXFRQ+LEXDIF
. S LEXND=+LEXMIEN_"^"_+LEXORG_"^"_+LEXFRQ
. I $G(^LEX(757.001,+LEXMIEN,0))'=LEXND D
. . N DA,DIK,LEXOLD,LEXNEW S LEXOLD=$P($G(^LEX(757.001,+LEXMIEN,0)),"^",3),LEXNEW=+LEXFRQ
. . S DA=+LEXMIEN,DIK="^LEX(757.001," D IX2^DIK
. . S ^LEX(757.001,+LEXMIEN,0)=LEXND
. . N DA,DIK S DA=+LEXMIEN,DIK="^LEX(757.001," D IX1^DIK S LEXCT=LEXCT+1
. . I $D(LEXTEST)&('$D(ZTQUEUED)) D
. . . W !,"Populate",?15,LEXMIEN,?25,LEXORG
. . . W:LEXNEW?1N.N&(LEXOLD?1N.N)&(LEXNEW'=LEXOLD) ?35,"(formerly ",LEXOLD,")"
K ^TMP("LEXPL",$J) W:'$D(ZTQUEUED)&(+($G(LEXCT))>0) !!,+($G(LEXCT))," changes made"
W:'$D(ZTQUEUED)&(+($G(LEXCT))'>0) !!,"No changes made"
Q
;
EDIT(M,S,X,Y) ; Edit CONCEPT USAGE file 757.001 (FileMan)
; M Major Concept IEN
; S System/Type of Edit
; X Originating Value
; Y Frequency
N LEXERR,LEXFRQ,LEXID,LEXMIEN,LEXNEW,LEXOFQ,LEXOLD,LEXORG,LEXS
S LEXMIEN=+($G(M)),LEXS=$G(X),LEXORG=$G(X),LEXFRQ=$G(Y) Q:LEXMIEN'>0 Q:'$D(^LEX(757.001,+LEXMIEN,0))
Q:+($G(^LEX(757.001,+LEXMIEN,0)))'=+LEXMIEN Q:$D(^TMP("LEXPL",$J,"MAJ",LEXMIEN)) Q:LEXORG'?1N.N Q:LEXFRQ'?1N.N
S LEXOFQ=+($P($G(^LEX(757.001,+LEXMIEN,0)),"^",3)),LEXNEW=+LEXMIEN_"^"_+LEXORG_"^"_+LEXFRQ
S LEXOLD=$G(^LEX(757.001,+LEXMIEN,0)) Q:LEXNEW=LEXOLD K LEXERR I $D(^LEX(757.001,+LEXMIEN,0)) D
. N DA,LEXDA,LEXERR,LEXFDA,LEXIENS S DA=+LEXMIEN,LEXIENS=$$IENS^DILF(.DA),LEXFDA(757.001,LEXIENS,.01)=+LEXMIEN
. S LEXFDA(757.001,LEXIENS,1)=+LEXORG,LEXFDA(757.001,LEXIENS,2)=+LEXFRQ K LEXERR D FILE^DIE(,"LEXFDA","LEXERR")
. S:'$D(LEXERR)&($D(LEXCT)) LEXCT=+($G(LEXCT))+1
I '$D(^LEX(757.001,+LEXMIEN,0)) D
. N DA,LEXDA,LEXERR,LEXFDA,LEXIENS S LEXDA(1)=+LEXMIEN,LEXFDA(757.001,"+1,",.01)=+LEXMIEN,LEXFDA(757.001,"+1,",1)=+LEXORG
. S LEXFDA(757.001,"+1,",2)=+LEXFRQ K LEXERR D UPDATE^DIE(,"LEXFDA","LEXDA","LEXERR") S LEXOFQ=""
. S:'$D(LEXERR)&($D(LEXCT)) LEXCT=+($G(LEXCT))+1
S ^TMP("LEXPL",$J,"MAJ",LEXMIEN)="" I $D(LEXTEST)&('$D(ZTQUEUED)) D
. S LEXS=$G(LEXS) W !,LEXS,?15,LEXMIEN,?25,LEXORG,?30,LEXFRQ I LEXOFQ?1N.N,LEXOFQ'=LEXFRQ W ?35,"(formerly ",LEXOFQ,")"
Q
;
ORIG(X) ; Get frequency based on codes and semantics
N LEXBD,LEXCL,LEXFS,LEXMIEN,LEXNOD,LEXSAB,LEXSCT,LEXSM,LEXSO,LEXTIEN,LEXTX S LEXMIEN=+($G(X)) Q:'$D(^LEX(757,LEXMIEN,0)) 0
S (X,LEXFS,LEXSO,LEXSM)=0 S LEXTIEN=0 F S LEXTIEN=$O(^LEX(757.02,"AMC",LEXMIEN,LEXTIEN)) Q:+LEXTIEN=0 D
. N LEXNOD,LEXSAB,LEXCL S LEXNOD=$G(^LEX(757.02,LEXTIEN,0)),LEXSAB=+($P(LEXNOD,U,3)) Q:LEXSAB'>0
. ; Coding Systems
. ; ICD-10-CM 6
. ; ICD-10-PCS 5
. S:LEXSAB=30 LEXCL=6 S:LEXSAB=31 LEXCL=5
. ; ICD-9-CM 4
. ; DSM III/IV 3
. S:LEXSAB=6 LEXCL=3 S:LEXSAB=5 LEXCL=3
. ; ICD-9 Proc 2
. S:LEXSAB=1 LEXCL=4 S:LEXSAB=2 LEXCL=2
. ; CPT/HCPCS 2
. S:LEXSAB=3 LEXCL=2 S:LEXSAB=4 LEXCL=2
. ; Nursing 1
. S:LEXSAB>10&(LEXSAB<16) LEXCL=1
. S:+($G(LEXCL))>LEXSO LEXSO=+($G(LEXCL))
S LEXTIEN=0 F S LEXTIEN=$O(^LEX(757.1,"B",LEXMIEN,LEXTIEN)) Q:+LEXTIEN=0 D
. N LEXCL,LEXBD S LEXBD=+($P($G(^LEX(757.1,LEXTIEN,0)),U,2)),LEXCL=0
. ; Semantic Map
. ; Semantic Behavior 3
. S:LEXBD=3&(+($G(LEXCL))'>0) LEXCL="3^Behavior"
. ; Semantic Disease/Disorder 3
. S:LEXBD=6 LEXCL="3^Disease/Disorder" S:LEXCL>LEXSM LEXSM=LEXCL
S LEXTIEN=0 F S LEXTIEN=$O(^LEX(757.01,"AMC",+LEXMIEN,LEXTIEN)) Q:+LEXTIEN'>0 D
. Q:$P($G(^LEX(757.01,+LEXTIEN,1)),"^",2)'=8 N LEXTX,LEXSCT S LEXTX=$$UP^XLFSTR($G(^LEX(757.01,+LEXTIEN,0))),LEXSCT=0
. ; SNOMED Hierarchy
. ; SNOMED Disease/Disorder 4
. S:LEXTX["(DISORDER" LEXSCT="4^Disorder" S:LEXTX["(FINDING" LEXSCT="4^Finding"
. S:LEXTX["(MORPHOLOGIC ABNORMALITY" LEXSCT="4^Morphologic Abnormality"
. S:LEXTX["(ORGANISM" LEXSCT="4^Organism"
. ; SNOMED Procedure 2
. S:+($G(LEXSCT))'>0&(LEXTX["(PROCEDURE") LEXSCT="2^Procedure"
. S:+LEXSCT>LEXFS LEXFS=LEXSCT
S X=+LEXSO S:X'>0 X=+LEXSM S:+LEXFS>X X=+LEXFS
Q X
;
INC(X) ; Increment Expression
;
; Input
;
; X IEN of the EXPRESSIONS file 757.01
;
; Output
;
; None
;
; This API increments the frequency of use value in the
; CONCEPT USAGE file #757.001. This value is used to
; position the most frequently used terms at the top of
; the selection list.
;
N LEXEIEN,LEXMIEN,LEXMC,LEXOR,LEXFQ,DA,DIK
S LEXEIEN=+($G(X)) Q:'$D(^LEX(757.01,+LEXEIEN,0)) S LEXMIEN=+($G(^LEX(757.01,+LEXEIEN,1)))
Q:'$D(^LEX(757,+LEXMIEN,0)) Q:'$D(^LEX(757.001,+LEXMIEN,0))
S LEXMC=+($P($G(^LEX(757.001,+LEXMIEN,0)),"^",1)),LEXOR=+($P($G(^LEX(757.001,+LEXMIEN,0)),"^",2))
S LEXFQ=+($P($G(^LEX(757.001,+LEXMIEN,0)),"^",3))+1 Q:LEXMC'=LEXMIEN
S DA=LEXMIEN,DIK="^LEX(757.001," D IX2^DIK
S ^LEX(757.001,+LEXMIEN,0)=LEXMC_"^"_LEXOR_"^"_LEXFQ
S DA=LEXMIEN,DIK="^LEX(757.001," D IX1^DIK
Q
;
; Miscellaneous
ENV(X) ; Check environment
N LEXNM,LEXTEST S DT=$$DT^XLFDT D HOME^%ZIS S U="^"
I +($G(DUZ))=0 W !!,?5,"DUZ not defined" Q 0
S LEXNM=$$GET1^DIQ(200,(DUZ_","),.01)
I '$L(LEXNM) W !!,?5,"DUZ not valid" Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXAR8 13156 printed Apr 09, 2024@21:08:35 Page 2
LEXAR8 ;ISL/KER - Look-up Response (CONCEPT USAGE update) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^AUPNPROB("B") ICR 1611
+5 ; ^LEX(757, SACC 1.3
+6 ; ^LEX(757.001, SACC 1.3
+7 ; ^LEX(757.01, SACC 1.3
+8 ; ^LEX(757.02, SACC 1.3
+9 ; ^LEX(757.1, SACC 1.3
+10 ; ^TMP("LEXPL",$J) SACC 2.3.2.5.1
+11 ;
+12 ; External References
+13 ; HOME^%ZIS ICR 10086
+14 ; ^%ZTLOAD ICR 10063
+15 ; FILE^DIE ICR 2053
+16 ; IX1^DIK ICR 10013
+17 ; IX2^DIK ICR 10013
+18 ; $$IENS^DILF ICR 2054
+19 ; $$GET1^DIQ ICR 2056
+20 ; $$CODEC^ICDEX ICR 5747
+21 ; $$CSI^ICDEX ICR 5747
+22 ; $$SAB^ICDEX ICR 5747
+23 ; $$DT^XLFDT ICR 10103
+24 ; $$UP^XLFSTR ICR 10104
+25 ;
UPDT ; Update CONCEPT USAGE file 757.001 (TaskMan)
+1 NEW X,Y,ZTQUEUED,ZTREQ,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTPRI,LEXENV
+2 SET LEXENV=$$ENV
if +LEXENV'>0
QUIT
SET ZTRTN="UPD^LEXAR8"
SET ZTPRI=4
SET ZTIO=""
SET ZTDTH=$HOROLOG
+3 SET ZTDESC="Update CONCEPT USAGE file 757.001 from the Problem List"
+4 if $DATA(LEXTEST)
DO @ZTRTN
if '$DATA(LEXTEST)
DO ^%ZTLOAD
+5 IF +($GET(ZTSK))>0
IF '$DATA(XPDENV)
IF '$DATA(LEXBUILD)
IF '$DATA(LEXIGHF)
IF '$DATA(LEXREQP)
Begin DoDot:1
+6 WRITE !,"CONCEPT USAGE update tasked (Task #"_+($GET(ZTSK))_"). "
End DoDot:1
+7 QUIT
UPD ; Update CONCEPT USAGE file 757.001 (using Problem List)
+1 KILL ^TMP("LEXPL",$JOB)
NEW LEXNOT,LEXIIEN,LEXTD,LEXCT
SET LEXCT=0
SET LEXNOT(5570)=""
SET LEXNOT(521774)=""
+2 SET LEXTD=$$DT^XLFDT
SET LEXIIEN=0
FOR
SET LEXIIEN=$ORDER(^AUPNPROB("B",LEXIIEN))
if +LEXIIEN'>0
QUIT
Begin DoDot:1
+3 NEW LEXPIEN
SET LEXPIEN=0
FOR
SET LEXPIEN=$ORDER(^AUPNPROB("B",LEXIIEN,LEXPIEN))
if +LEXPIEN'>0
QUIT
Begin DoDot:2
+4 NEW LEXLEX,LEXSCTC,LEXSTA,LEXSIEN
+5 if $DATA(LEXNOT(+LEXIIEN))
QUIT
+6 SET LEXCOD=$$CODEC^ICDEX(80,LEXIIEN)
IF $LENGTH(LEXCOD)
Begin DoDot:3
+7 SET LEXSYS=$$CSI^ICDEX(80,LEXIIEN)
if "^1^30^"'[("^"_LEXSYS_"^")
QUIT
+8 SET LEXSAB=$EXTRACT($$SAB^ICDEX(LEXSYS),1,3)
if "^ICD^10D^"'[("^"_LEXSAB_"^")
QUIT
+9 SET LEXSTA=$$STATCHK^LEXSRC2(LEXCOD,LEXTD,,LEXSAB)
+10 SET LEXSIEN=$PIECE(LEXSTA,"^",2)
if +LEXSIEN'>0
QUIT
+11 SET ^TMP("LEXPL",$JOB,"ICD",LEXSIEN)=+($GET(^TMP("LEXPL",$JOB,"ICD",LEXSIEN)))+1
+12 if '$DATA(^TMP("LEXPL",$JOB,"ICD",LEXSIEN,"SAB"))
SET ^TMP("LEXPL",$JOB,"ICD",LEXSIEN,"SAB")=LEXSAB
+13 if LEXSAB="10D"
SET ^TMP("LEXPL",$JOB,"ICD",LEXSIEN,"SAB")=LEXSAB
End DoDot:3
+14 SET LEXCOD=$$GET1^DIQ(9000011,LEXPIEN,80001)
IF $LENGTH(LEXCOD)
Begin DoDot:3
+15 SET LEXSTA=$$STATCHK^LEXSRC2(LEXCOD,LEXTD,,"SCT")
+16 SET LEXSIEN=$PIECE(LEXSTA,"^",2)
if +LEXSIEN'>0
QUIT
+17 SET ^TMP("LEXPL",$JOB,"SCT",LEXSIEN)=+($GET(^TMP("LEXPL",$JOB,"SCT",LEXSIEN)))+1
+18 SET ^TMP("LEXPL",$JOB,"SCT",LEXSIEN,"SAB")="SCT"
End DoDot:3
End DoDot:2
End DoDot:1
+19 SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^TMP("LEXPL",$JOB,"ICD",LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:1
+20 NEW LEXCOD,LEXNOD,LEXFRQ,LEXSYS,LEXSAB,LEXDES,LEXSTA,LEXORG,LEXEIEN,LEXMIEN,LEXNEW
+21 SET LEXNOD=$GET(^LEX(757.02,+LEXSIEN,0))
SET LEXEIEN=+LEXNOD
if +LEXEIEN'>0
QUIT
if "^1^30^"'[("^"_$PIECE(LEXNOD,"^",3)_"^")
QUIT
+22 SET LEXMIEN=+($PIECE($GET(LEXNOD),"^",4))
IF LEXMIEN'>0
KILL ^TMP("LEXPL",$JOB,"ICD",LEXSIEN)
QUIT
+23 SET ^TMP("LEXPL",$JOB,"ICD","MC",LEXMIEN)=""
+24 SET LEXSAB=$GET(^TMP("LEXPL",$JOB,"ICD",LEXSIEN,"SAB"))
SET LEXORG=$$ORIG(LEXMIEN)
+25 SET LEXFRQ=$GET(^TMP("LEXPL",$JOB,"ICD",LEXSIEN))
+26 SET LEXNEW=LEXFRQ+LEXORG
+27 DO UPDF(+LEXMIEN,"PL ICD",+LEXORG,+LEXNEW)
End DoDot:1
+28 SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^TMP("LEXPL",$JOB,"SCT",LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:1
+29 NEW LEXCOD,LEXNOD,LEXFRQ,LEXSYS,LEXSAB,LEXDES,LEXSTA,LEXORG,LEXEIEN,LEXMIEN,LEXNEW
+30 SET LEXNOD=$GET(^LEX(757.02,+LEXSIEN,0))
SET LEXEIEN=+LEXNOD
if +LEXEIEN'>0
QUIT
if $PIECE(LEXNOD,"^",3)'=56
QUIT
+31 SET LEXMIEN=+($PIECE($GET(LEXNOD),"^",4))
IF LEXMIEN'>0
KILL ^TMP("LEXPL",$JOB,"SCT",LEXSIEN)
QUIT
+32 SET ^TMP("LEXPL",$JOB,"SCT","MC",LEXMIEN)=""
+33 SET LEXSAB="SCT"
SET LEXORG=$$ORIG(LEXMIEN)
SET LEXFRQ=$GET(^TMP("LEXPL",$JOB,"SCT",LEXSIEN))
SET LEXNEW=LEXFRQ+LEXORG
+34 DO UPDF(+LEXMIEN,"PL SCT",+LEXORG,+LEXNEW)
End DoDot:1
+35 FOR LEXSAB="ICD","10D","SCT"
Begin DoDot:1
+36 NEW LEXS,LEXSIEN
SET LEXS=$SELECT(LEXSAB="ICD":"SY ICD",LEXSAB="10D":"SY ICD",LEXSAB="SCT":"SY SCT",1:("SY "_LEXSAB))
+37 SET LEXS="Update "_LEXS
SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"ASRC",LEXSAB,LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:2
+38 NEW LEXMIEN,LEXORG,LEXFRQ,LEXEIEN,LEXND
SET LEXMIEN=+($PIECE($GET(^LEX(757.02,+LEXSIEN,0)),"^",4))
if +LEXMIEN'>0
QUIT
+39 if $DATA(^TMP("LEXPL",$JOB,"ICD","MC",LEXMIEN))!($DATA(^TMP("LEXPL",$JOB,"SCT","MC",LEXMIEN)))
QUIT
+40 SET LEXEIEN=+($PIECE($GET(^LEX(757,+LEXMIEN,0)),"^",1))
if LEXEIEN'>0
QUIT
+41 if $PIECE($GET(^LEX(757.01,+LEXEIEN,1)),"^",5)>0
QUIT
+42 SET (LEXORG,LEXFRQ)=$$ORIG(LEXMIEN)
SET LEXND=LEXMIEN_"^"_LEXORG_"^"_LEXFRQ
+43 IF $GET(^LEX(757.001,+LEXMIEN,0))'=LEXND
DO UPDF(+LEXMIEN,LEXS,+LEXORG,+LEXFRQ)
End DoDot:2
End DoDot:1
+44 if '$DATA(ZTQUEUED)&(+($GET(LEXCT))>0)
WRITE !!,+($GET(LEXCT))," changes made"
+45 if '$DATA(ZTQUEUED)&(+($GET(LEXCT))'>0)
WRITE !!,"No changes made"
KILL ^TMP("LEXPL",$JOB)
+46 QUIT
UPDF(M,S,X,Y) ; Update CONCEPT USAGE file 757.001 (FileMan)
+1 NEW DA,LEXBUILD,LEXERR,LEXFDA,LEXFRQ,LEXOFQ,LEXIENS,LEXIGHF,LEXMIEN,LEXNEW,LEXOLD,LEXORG,LEXREQP,LEXS,XPDENV
+2 SET LEXMIEN=+($GET(M))
SET LEXS=$GET(X)
SET LEXORG=$GET(X)
SET LEXFRQ=$GET(Y)
if LEXMIEN'>0
QUIT
if '$DATA(^LEX(757.001,+LEXMIEN,0))
QUIT
+3 if +($GET(^LEX(757.001,+LEXMIEN,0)))'=+LEXMIEN
QUIT
if $DATA(^TMP("LEXPL",$JOB,"MAJ",LEXMIEN))
QUIT
if LEXORG'?1N.N
QUIT
if LEXFRQ'?1N.N
QUIT
+4 SET LEXOFQ=+($PIECE($GET(^LEX(757.001,+LEXMIEN,0)),"^",3))
SET DA=+LEXMIEN
+5 SET LEXIENS=$$IENS^DILF(.DA)
SET LEXFDA(757.001,LEXIENS,.01)=+LEXMIEN
SET LEXFDA(757.001,LEXIENS,1)=+LEXORG
+6 SET LEXNEW=+LEXMIEN_"^"_+LEXORG_"^"_+LEXFRQ
SET LEXOLD=$GET(^LEX(757.001,+LEXMIEN,0))
if LEXNEW=LEXOLD
QUIT
+7 SET LEXFDA(757.001,LEXIENS,2)=+LEXFRQ
KILL LEXERR
DO FILE^DIE(,"LEXFDA","LEXERR")
+8 if '$DATA(LEXERR)
SET LEXCT=+($GET(LEXCT))+1
SET ^TMP("LEXPL",$JOB,"MAJ",LEXMIEN)=""
IF $DATA(LEXTEST)&('$DATA(ZTQUEUED))
Begin DoDot:1
+9 NEW LEXID
SET LEXID=$GET(LEXS)
WRITE !,LEXS,?15,LEXMIEN,?25,LEXORG,?30,LEXFRQ
+10 IF LEXOFQ?1N.N
IF LEXOFQ'=LEXFRQ
WRITE ?35,"(formerly ",LEXOFQ,")"
End DoDot:1
+11 QUIT
+12 ;
CLEART ; Set the Frequency to the Original Value (TaskMan)
+1 NEW X,Y,ZTQUEUED,ZTREQ,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTPRI,LEXENV
+2 SET LEXENV=$$ENV
if +LEXENV'>0
QUIT
SET ZTRTN="CLEAR^LEXAR8"
SET ZTPRI=4
SET ZTIO=""
SET ZTDTH=$HOROLOG
+3 SET ZTDESC="Update CONCEPT USAGE file 757.001 from the Problem List"
+4 if $DATA(LEXTEST)
DO @ZTRTN
if '$DATA(LEXTEST)
DO ^%ZTLOAD
+5 IF +($GET(ZTSK))>0
IF '$DATA(XPDENV)
IF '$DATA(LEXBUILD)
IF '$DATA(LEXIGHF)
IF '$DATA(LEXREQP)
Begin DoDot:1
+6 WRITE !,"CONCEPT USAGE update tasked (Task #"_+($GET(ZTSK))_"). "
End DoDot:1
+7 QUIT
CLEAR ; Set the Frequency to the Original Value
+1 NEW LEXCT,LEXMIEN
SET (LEXCT,LEXMIEN)=0
FOR
SET LEXMIEN=$ORDER(^LEX(757,LEXMIEN))
if +LEXMIEN'>0
QUIT
Begin DoDot:1
+2 NEW LEXORG,LEXFRQ,LEXOLD,LEXOFQ,LEXND
SET (LEXORG,LEXFRQ)=$$ORIG(+LEXMIEN)
+3 SET LEXND=+LEXMIEN_"^"_+LEXORG_"^"_+LEXFRQ
+4 SET LEXOLD=$GET(^LEX(757.001,+LEXMIEN,0))
SET LEXOFQ=$PIECE(LEXOLD,"^",3)
+5 IF LEXOLD'=LEXND
DO EDIT(+LEXMIEN,"Clear",+LEXORG,+LEXFRQ)
End DoDot:1
+6 KILL ^TMP("LEXPL",$JOB)
if '$DATA(ZTQUEUED)&(+($GET(LEXCT))>0)
WRITE !!,+($GET(LEXCT))," changes made"
+7 if '$DATA(ZTQUEUED)&(+($GET(LEXCT))'>0)
WRITE !!,"No changes made"
+8 QUIT
+9 ;
POPT ; Populate the Original Value (ONLY) (TaskMan)
+1 NEW X,Y,ZTQUEUED,ZTREQ,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTPRI,LEXENV
+2 SET LEXENV=$$ENV
if +LEXENV'>0
QUIT
SET ZTRTN="POP^LEXAR8"
SET ZTPRI=4
SET ZTIO=""
SET ZTDTH=$HOROLOG
+3 SET ZTDESC="Update CONCEPT USAGE file 757.001 from the Problem List"
+4 if $DATA(LEXTEST)
DO @ZTRTN
if '$DATA(LEXTEST)
DO ^%ZTLOAD
+5 IF +($GET(ZTSK))>0
IF '$DATA(XPDENV)
IF '$DATA(LEXBUILD)
IF '$DATA(LEXIGHF)
IF '$DATA(LEXREQP)
Begin DoDot:1
+6 WRITE !,"CONCEPT USAGE update tasked (Task #"_+($GET(ZTSK))_"). "
End DoDot:1
+7 QUIT
POP ; Populate the Original Value (ONLY)
+1 NEW LEXCT,LEXMIEN
SET (LEXCT,LEXMIEN)=0
FOR
SET LEXMIEN=$ORDER(^LEX(757,LEXMIEN))
if +LEXMIEN'>0
QUIT
Begin DoDot:1
+2 NEW LEXORG,LEXFRQ,LEXDIF,LEXND
+3 IF '$DATA(^LEX(757.001,+LEXMIEN,0))
Begin DoDot:2
+4 NEW LEXORG,LEXFRQ,LEXND
SET (LEXORG,LEXFRQ)=$$ORIG(+LEXMIEN)
SET LEXND=+LEXMIEN_"^"_+LEXORG_"^"_+LEXFRQ
+5 NEW DA,DIK
SET DA=+LEXMIEN
SET DIK="^LEX(757.001,"
DO IX2^DIK
SET ^LEX(757.001,+LEXMIEN,0)=LEXND
+6 NEW DA,DIK
SET DA=+LEXMIEN
SET DIK="^LEX(757.001,"
DO IX1^DIK
SET LEXCT=LEXCT+1
+7 IF $DATA(LEXTEST)&('$DATA(ZTQUEUED))
Begin DoDot:3
+8 WRITE !,"Populate",?15,LEXMIEN,?25,LEXORG,?30,LEXFRQ,?35,"(new)"
End DoDot:3
End DoDot:2
QUIT
+9 SET LEXND=$GET(^LEX(757.001,+LEXMIEN,0))
SET LEXORG=$PIECE(LEXND,"^",2)
SET LEXFRQ=$PIECE(LEXND,"^",2)
+10 SET LEXDIF=LEXFRQ-LEXORG
if LEXDIF<0
SET LEXDIF=0
+11 SET (LEXORG,LEXFRQ)=$$ORIG(+LEXMIEN)
SET LEXFRQ=LEXFRQ+LEXDIF
+12 SET LEXND=+LEXMIEN_"^"_+LEXORG_"^"_+LEXFRQ
+13 IF $GET(^LEX(757.001,+LEXMIEN,0))'=LEXND
Begin DoDot:2
+14 NEW DA,DIK,LEXOLD,LEXNEW
SET LEXOLD=$PIECE($GET(^LEX(757.001,+LEXMIEN,0)),"^",3)
SET LEXNEW=+LEXFRQ
+15 SET DA=+LEXMIEN
SET DIK="^LEX(757.001,"
DO IX2^DIK
+16 SET ^LEX(757.001,+LEXMIEN,0)=LEXND
+17 NEW DA,DIK
SET DA=+LEXMIEN
SET DIK="^LEX(757.001,"
DO IX1^DIK
SET LEXCT=LEXCT+1
+18 IF $DATA(LEXTEST)&('$DATA(ZTQUEUED))
Begin DoDot:3
+19 WRITE !,"Populate",?15,LEXMIEN,?25,LEXORG
+20 if LEXNEW?1N.N&(LEXOLD?1N.N)&(LEXNEW'=LEXOLD)
WRITE ?35,"(formerly ",LEXOLD,")"
End DoDot:3
End DoDot:2
End DoDot:1
+21 KILL ^TMP("LEXPL",$JOB)
if '$DATA(ZTQUEUED)&(+($GET(LEXCT))>0)
WRITE !!,+($GET(LEXCT))," changes made"
+22 if '$DATA(ZTQUEUED)&(+($GET(LEXCT))'>0)
WRITE !!,"No changes made"
+23 QUIT
+24 ;
EDIT(M,S,X,Y) ; Edit CONCEPT USAGE file 757.001 (FileMan)
+1 ; M Major Concept IEN
+2 ; S System/Type of Edit
+3 ; X Originating Value
+4 ; Y Frequency
+5 NEW LEXERR,LEXFRQ,LEXID,LEXMIEN,LEXNEW,LEXOFQ,LEXOLD,LEXORG,LEXS
+6 SET LEXMIEN=+($GET(M))
SET LEXS=$GET(X)
SET LEXORG=$GET(X)
SET LEXFRQ=$GET(Y)
if LEXMIEN'>0
QUIT
if '$DATA(^LEX(757.001,+LEXMIEN,0))
QUIT
+7 if +($GET(^LEX(757.001,+LEXMIEN,0)))'=+LEXMIEN
QUIT
if $DATA(^TMP("LEXPL",$JOB,"MAJ",LEXMIEN))
QUIT
if LEXORG'?1N.N
QUIT
if LEXFRQ'?1N.N
QUIT
+8 SET LEXOFQ=+($PIECE($GET(^LEX(757.001,+LEXMIEN,0)),"^",3))
SET LEXNEW=+LEXMIEN_"^"_+LEXORG_"^"_+LEXFRQ
+9 SET LEXOLD=$GET(^LEX(757.001,+LEXMIEN,0))
if LEXNEW=LEXOLD
QUIT
KILL LEXERR
IF $DATA(^LEX(757.001,+LEXMIEN,0))
Begin DoDot:1
+10 NEW DA,LEXDA,LEXERR,LEXFDA,LEXIENS
SET DA=+LEXMIEN
SET LEXIENS=$$IENS^DILF(.DA)
SET LEXFDA(757.001,LEXIENS,.01)=+LEXMIEN
+11 SET LEXFDA(757.001,LEXIENS,1)=+LEXORG
SET LEXFDA(757.001,LEXIENS,2)=+LEXFRQ
KILL LEXERR
DO FILE^DIE(,"LEXFDA","LEXERR")
+12 if '$DATA(LEXERR)&($DATA(LEXCT))
SET LEXCT=+($GET(LEXCT))+1
End DoDot:1
+13 IF '$DATA(^LEX(757.001,+LEXMIEN,0))
Begin DoDot:1
+14 NEW DA,LEXDA,LEXERR,LEXFDA,LEXIENS
SET LEXDA(1)=+LEXMIEN
SET LEXFDA(757.001,"+1,",.01)=+LEXMIEN
SET LEXFDA(757.001,"+1,",1)=+LEXORG
+15 SET LEXFDA(757.001,"+1,",2)=+LEXFRQ
KILL LEXERR
DO UPDATE^DIE(,"LEXFDA","LEXDA","LEXERR")
SET LEXOFQ=""
+16 if '$DATA(LEXERR)&($DATA(LEXCT))
SET LEXCT=+($GET(LEXCT))+1
End DoDot:1
+17 SET ^TMP("LEXPL",$JOB,"MAJ",LEXMIEN)=""
IF $DATA(LEXTEST)&('$DATA(ZTQUEUED))
Begin DoDot:1
+18 SET LEXS=$GET(LEXS)
WRITE !,LEXS,?15,LEXMIEN,?25,LEXORG,?30,LEXFRQ
IF LEXOFQ?1N.N
IF LEXOFQ'=LEXFRQ
WRITE ?35,"(formerly ",LEXOFQ,")"
End DoDot:1
+19 QUIT
+20 ;
ORIG(X) ; Get frequency based on codes and semantics
+1 NEW LEXBD,LEXCL,LEXFS,LEXMIEN,LEXNOD,LEXSAB,LEXSCT,LEXSM,LEXSO,LEXTIEN,LEXTX
SET LEXMIEN=+($GET(X))
if '$DATA(^LEX(757,LEXMIEN,0))
QUIT 0
+2 SET (X,LEXFS,LEXSO,LEXSM)=0
SET LEXTIEN=0
FOR
SET LEXTIEN=$ORDER(^LEX(757.02,"AMC",LEXMIEN,LEXTIEN))
if +LEXTIEN=0
QUIT
Begin DoDot:1
+3 NEW LEXNOD,LEXSAB,LEXCL
SET LEXNOD=$GET(^LEX(757.02,LEXTIEN,0))
SET LEXSAB=+($PIECE(LEXNOD,U,3))
if LEXSAB'>0
QUIT
+4 ; Coding Systems
+5 ; ICD-10-CM 6
+6 ; ICD-10-PCS 5
+7 if LEXSAB=30
SET LEXCL=6
if LEXSAB=31
SET LEXCL=5
+8 ; ICD-9-CM 4
+9 ; DSM III/IV 3
+10 if LEXSAB=6
SET LEXCL=3
if LEXSAB=5
SET LEXCL=3
+11 ; ICD-9 Proc 2
+12 if LEXSAB=1
SET LEXCL=4
if LEXSAB=2
SET LEXCL=2
+13 ; CPT/HCPCS 2
+14 if LEXSAB=3
SET LEXCL=2
if LEXSAB=4
SET LEXCL=2
+15 ; Nursing 1
+16 if LEXSAB>10&(LEXSAB<16)
SET LEXCL=1
+17 if +($GET(LEXCL))>LEXSO
SET LEXSO=+($GET(LEXCL))
End DoDot:1
+18 SET LEXTIEN=0
FOR
SET LEXTIEN=$ORDER(^LEX(757.1,"B",LEXMIEN,LEXTIEN))
if +LEXTIEN=0
QUIT
Begin DoDot:1
+19 NEW LEXCL,LEXBD
SET LEXBD=+($PIECE($GET(^LEX(757.1,LEXTIEN,0)),U,2))
SET LEXCL=0
+20 ; Semantic Map
+21 ; Semantic Behavior 3
+22 if LEXBD=3&(+($GET(LEXCL))'>0)
SET LEXCL="3^Behavior"
+23 ; Semantic Disease/Disorder 3
+24 if LEXBD=6
SET LEXCL="3^Disease/Disorder"
if LEXCL>LEXSM
SET LEXSM=LEXCL
End DoDot:1
+25 SET LEXTIEN=0
FOR
SET LEXTIEN=$ORDER(^LEX(757.01,"AMC",+LEXMIEN,LEXTIEN))
if +LEXTIEN'>0
QUIT
Begin DoDot:1
+26 if $PIECE($GET(^LEX(757.01,+LEXTIEN,1)),"^",2)'=8
QUIT
NEW LEXTX,LEXSCT
SET LEXTX=$$UP^XLFSTR($GET(^LEX(757.01,+LEXTIEN,0)))
SET LEXSCT=0
+27 ; SNOMED Hierarchy
+28 ; SNOMED Disease/Disorder 4
+29 if LEXTX["(DISORDER"
SET LEXSCT="4^Disorder"
if LEXTX["(FINDING"
SET LEXSCT="4^Finding"
+30 if LEXTX["(MORPHOLOGIC ABNORMALITY"
SET LEXSCT="4^Morphologic Abnormality"
+31 if LEXTX["(ORGANISM"
SET LEXSCT="4^Organism"
+32 ; SNOMED Procedure 2
+33 if +($GET(LEXSCT))'>0&(LEXTX["(PROCEDURE")
SET LEXSCT="2^Procedure"
+34 if +LEXSCT>LEXFS
SET LEXFS=LEXSCT
End DoDot:1
+35 SET X=+LEXSO
if X'>0
SET X=+LEXSM
if +LEXFS>X
SET X=+LEXFS
+36 QUIT X
+37 ;
INC(X) ; Increment Expression
+1 ;
+2 ; Input
+3 ;
+4 ; X IEN of the EXPRESSIONS file 757.01
+5 ;
+6 ; Output
+7 ;
+8 ; None
+9 ;
+10 ; This API increments the frequency of use value in the
+11 ; CONCEPT USAGE file #757.001. This value is used to
+12 ; position the most frequently used terms at the top of
+13 ; the selection list.
+14 ;
+15 NEW LEXEIEN,LEXMIEN,LEXMC,LEXOR,LEXFQ,DA,DIK
+16 SET LEXEIEN=+($GET(X))
if '$DATA(^LEX(757.01,+LEXEIEN,0))
QUIT
SET LEXMIEN=+($GET(^LEX(757.01,+LEXEIEN,1)))
+17 if '$DATA(^LEX(757,+LEXMIEN,0))
QUIT
if '$DATA(^LEX(757.001,+LEXMIEN,0))
QUIT
+18 SET LEXMC=+($PIECE($GET(^LEX(757.001,+LEXMIEN,0)),"^",1))
SET LEXOR=+($PIECE($GET(^LEX(757.001,+LEXMIEN,0)),"^",2))
+19 SET LEXFQ=+($PIECE($GET(^LEX(757.001,+LEXMIEN,0)),"^",3))+1
if LEXMC'=LEXMIEN
QUIT
+20 SET DA=LEXMIEN
SET DIK="^LEX(757.001,"
DO IX2^DIK
+21 SET ^LEX(757.001,+LEXMIEN,0)=LEXMC_"^"_LEXOR_"^"_LEXFQ
+22 SET DA=LEXMIEN
SET DIK="^LEX(757.001,"
DO IX1^DIK
+23 QUIT
+24 ;
+25 ; Miscellaneous
ENV(X) ; Check environment
+1 NEW LEXNM,LEXTEST
SET DT=$$DT^XLFDT
DO HOME^%ZIS
SET U="^"
+2 IF +($GET(DUZ))=0
WRITE !!,?5,"DUZ not defined"
QUIT 0
+3 SET LEXNM=$$GET1^DIQ(200,(DUZ_","),.01)
+4 IF '$LENGTH(LEXNM)
WRITE !!,?5,"DUZ not valid"
QUIT 0
+5 QUIT 1
