source: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXPLEM.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 4.3 KB
Line 
1LEXPLEM ; ISL Problem List Exact Match URs ; 09-23-96
2 ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
3 ;
4 ; Fixes unresolved narratives which have an exact match in the
5 ; Lexicon by changing the Lexicon pointer from 1 (unresolved)
6 ; to point to the exact match term.
7 ;
8 ; EN^LEXPLEM Entry point to fix exact match unresolved
9 ; narratives
10 ;
11 ; EN2^LEXPLEM(X) Entry point to fix exact match unresolved
12 ; narratives and return the number of exact
13 ; match terms fixed.
14 ;
15 ; EN3^LEXPLEM Entry point to to Task EN^LEXPLEM
16 ;
17 Q
18EN ; Entry to fix exact match
19 N LEXCNT S LEXCNT=0 D EM S:$D(ZTQUEUED) ZTREQ="@" Q
20EN2(X) ; Entry to fix exact match and return # fixed
21 N LEXCNT S LEXCNT=0 D EM S X=LEXCNT Q X
22EN3 ; Task EN^LEXPLEM
23 S ZTRTN="EN^LEXPLEM",ZTDESC="Exact Match URs in Prob List # 9000011",ZTIO="",ZTDTH=$H D ^%ZTLOAD,HOME^%ZIS K Y,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN Q
24EM ; Exact match on a term
25 N DA,DIC,DIE,DR,DTOUT,LEXAT,LEXDA,LEXEX,LEXEXM,LEXICD,LEXISO
26 N LEXLEX,LEXNAR,LEXNIC,LEXNIP,LEXO,LEXOD,LEXOS,LEXPOV,LEXUNP
27 N LEXX,LEXXU,X,Y
28 S LEXEXM=0,LEXUNP=+($O(^ICD9("AB","799.9 ",0))) Q:LEXUNP=0 S DA=0
29 F S DA=$O(^AUPNPROB(DA)) Q:+DA=0 D
30 . S LEXICD=$P($G(^AUPNPROB(DA,0)),"^",1),LEXISO=$P($G(^ICD9(+LEXICD,0)),"^",1)
31 . S LEXLEX=$P($G(^AUPNPROB(DA,1)),"^",1) Q:LEXLEX'=1
32 . S LEXPOV=+($P($G(^AUPNPROB(DA,0)),"^",5)) Q:LEXPOV=0
33 . S LEXNAR=$P($G(^AUTNPOV(LEXPOV,0)),"^",1) Q:'$L(LEXNAR)
34 . I LEXLEX=1,$D(^ICD9("AB",($E(LEXNAR,1,8)_" "))),+($P($G(^ICD9(+($O(^ICD9("AB",($E(LEXNAR,1,8)_" "),0))),0)),"^",9))=0 D Q
35 . . S LEXEXM=$$FC(LEXNAR) Q:+LEXEXM'>2 S LEXNIC=$$ICDONE^LEXU(+LEXEXM)
36 . . S LEXNIP=0 S:$L(LEXNIC) LEXNIP=+($O(^ICD9("AB",(LEXNIC_" "),0)))
37 . . I +LEXEXM>2,$D(^LEX(757.01,+LEXEXM,0)) D EDIT
38 . S LEXEXM=$$FE(LEXNAR)
39 . Q:+LEXEXM'>2 S LEXNIC=$$ICDONE^LEXU(+LEXEXM)
40 . S LEXNIP=0 S:$L(LEXNIC) LEXNIP=+($O(^ICD9("AB",(LEXNIC_" "),0)))
41 . I +LEXEXM>2,$D(^LEX(757.01,+LEXEXM,0)) D EDIT Q
42 Q
43EDIT ; Edit Problem
44 N LEXAT S LEXAT=0,DA=+($G(DA))
45 Q:'$D(^AUPNPROB(DA,0)) Q:'$D(^AUPNPROB(DA,1))
46 S LEXEXM=+($G(LEXEXM))
47 Q:'$D(^LEX(757.01,LEXEXM,0))
48 S LEXNIP=+($G(LEXNIP))
49 S (DIE,DIC)="^AUPNPROB(" S DR="1.01////^S X=LEXEXM"
50 I +LEXNIP>0,$D(^ICD9(+LEXNIP,0)),LEXICD=LEXUNP S DR=".01////^S X=LEXNIP;1.01////^S X=LEXEXM"
51ED2 ; Record is Locked
52 L +^AUPNPROB(DA):1 I '$T,LEXAT'>5 S LEXAT=LEXAT+1 H 2 G ED2
53 G:LEXAT>5 EDQ D ^DIE L -^AUPNPROB(DA)
54EDQ ; Edit Quit
55 I $P($G(^AUPNPROB(DA,0)),"^",1)=LEXNIP,$P($G(^AUPNPROB(DA,1)),"^",1)=LEXEXM S LEXCNT=+($G(LEXCNT))+1
56 Q
57FE(X) ; Find Exact Match on a term return IEN
58 S X=$G(X) Q:'$L(X) -1 N LEXX S LEXX=$G(X),X=-1 Q:'$L(LEXX) -1
59 N LEXO,LEXOD,LEXOS,LEXDA,LEXEX,LEXXU S X=-1,LEXXU=$$UP(LEXX),LEXOD=$$UP($E(LEXX,1,60)),LEXO=0 I $L(LEXOD) D
60 . Q:'$D(^LEX(757.01,"B",LEXOD))&($E($O(^LEX(757.01,"B",LEXOD)),1,$L(LEXOD))'=LEXOD) S LEXOS=$$SCH(LEXOD) F S LEXOS=$O(^LEX(757.01,"B",LEXOS)) Q:LEXOS=""!($E(LEXOS,1,$L(LEXOD))'=LEXOD) D
61 . . S LEXDA=0 F S LEXDA=$O(^LEX(757.01,"B",LEXOS,LEXDA)) Q:+LEXDA=0!($$UP($G(^LEX(757.01,+LEXDA,0)))'[LEXOD) S LEXEX=$G(^LEX(757.01,+LEXDA,0)) I $$UP(LEXEX)=LEXXU S LEXO=LEXDA_"^"_LEXEX
62 S LEXO=+($G(LEXO)) I LEXO>0 S:'$D(^LEX(757.01,LEXO,0)) X=-1 S:$D(^LEX(757.01,LEXO,0)) X=LEXO_"^"_$G(^LEX(757.01,LEXO,0))
63 Q X
64FC(X) ; Find Exact Match on an ICD Code return IEN
65 S X=$G(X) Q:'$L(X) -1 N LEXX S LEXX=$E($G(X),1,9),X=-1 Q:'$L(LEXX) -1
66 Q:'$D(^ICD9("AB",(LEXX_" "))) -1
67 Q:+($P($G(^ICD9(+($O(^ICD9("AB",(LEXX_" "),0))),0)),"^",9))=1 -1
68 ;
69 N LEXSD,LEXEX,LEXI,LEXP
70 S LEXSD=0
71 F S LEXSD=$O(^LEX(757.02,"ACODE",(LEXX_" "),LEXSD)) Q:+LEXSD=0 D
72 . S LEXEX=+($P($G(^LEX(757.02,LEXSD,0)),"^",1)) Q:'$D(^LEX(757.01,LEXEX,0))
73 . Q:$$ICDONE^LEXU(LEXEX)=""
74 . Q:$P($G(^LEX(757.02,LEXSD,0)),"^",2)'=LEXX Q:+($P($G(^LEX(757.02,LEXSD,0)),"^",3))'=1
75 . S LEXI(0)=+($G(LEXI(0)))+1,LEXI(LEXI(0))=LEXEX
76 . I +($P($G(^LEX(757.02,LEXSD,0)),"^",5))=1 D
77 . . S LEXP(0)=+($G(LEXP(0)))+1,LEXP(LEXP(0))=LEXEX
78 I $D(LEXP),+($G(LEXP(0)))=1 S LEXX=+($G(LEXP(1))) S:+LEXX>2&($D(^LEX(757.01,+LEXX,0))) X=LEXX Q X
79 I $D(LEXI),+($G(LEXI(0)))=1 S LEXX=+($G(LEXI(1))) S:+LEXX>2&($D(^LEX(757.01,+LEXX,0))) X=LEXX Q X
80 Q X
81SCH(LEXX) ; Create $O variable
82 S LEXX=$E(LEXX,1,($L(LEXX)-1))_$C($A($E(LEXX,$L(LEXX)))-1)_"~" Q LEXX
83UP(LEXX) ; Uppercase
84 Q $TR($G(LEXX),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Note: See TracBrowser for help on using the repository browser.