ICDEXLK5 ;SLC/KER - ICD Extractor - Lookup, List ;04/21/2014
;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
;
; Global Variables
; ^ICDS( N/A
; ^TMP(SUB,$J SACC 2.3.2.5.1
;
; External References
; ^DIM ICR 10016
; $$MIX^LEXXM ICR 5781
; $$DT^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Local Variables Newed or Killed by calling application
; DIC(0) Fileman Lookup Parameters
; DIC("S") Fileman Screen
;
; Local Variables Newed or Killed Elsewhere
; ICDBYCD Sort by Code
; ICDCDT Code Set Date
; ICDOUT Format of display
; ICDVDT Date to use during lookup
; ICDSYS Coding System
; ICDVER Versioned Lookup
; ICDDICSS Secondary Screen
; INP2 User Input (processed)
; LOUD Output to Screen
;
Q
EXM(TXT,ROOT,Y,CDT,SYS,VER) ; Lookup Exact Match
;
; Input TXT Text/Code for search (Required)
; ROOT Global Root (Required)
; .Y Output array passed by reference (Required)
; CDT Date
; SYS Coding System
; VER Versioned Search
;
; Output $$EM Number of Exact Matches Found
; Y(n) Array of Exact Matches
;
N EXM,KEY,ORD,ICDI,IEN,NUM,ORG,EROOT S ORG=$G(TXT) Q:'$L($G(ORG)) 0
Q:'$L($TR(ORG,"""","")) 0 S ROOT=$G(ROOT) Q:'$L($G(ROOT)) 0
S SYS=+($G(SYS)),VER=+($G(VER))
S CDT=$$CDT^ICDEXLK3($G(CDT),SYS)
; Exact Match Case Sensitive Code
S KEY=ORG,KEY=ORG S ORD=$E(KEY,1,($L(KEY)-1))_$C(($A($E(KEY,$L(KEY)))-1))_"~ "
S EROOT=ROOT_"""BA""," S:+SYS>0&($D(@(ROOT_"""ABA"","_+SYS_")"))) EROOT=ROOT_"""ABA"","_+SYS_","
F S ORD=$O(@(EROOT_""""_ORD_""")")) Q:'$$ISORD D
. S IEN=0 F S IEN=$O(@(EROOT_""""_ORD_""","_+IEN_")")) Q:+IEN'>0 D
. . N VAL,STA S STA=1
. . S:VER>0 STA=$$LS^ICDEXLK3(ROOT,IEN,CDT)
. . Q:+($G(VER))>0&(+STA'>0)
. . S VAL=$P($G(@(ROOT_+IEN_",0)")),"^",1)
. . Q:VAL'=ORG S EXM(IEN)="",LOR=1
; Exact Match Code
I $O(EXM(0))'>0 D
. S KEY=$$UP^XLFSTR(ORG),KEY=ORG S ORD=$E(KEY,1,($L(KEY)-1))_$C(($A($E(KEY,$L(KEY)))-1))_"~ "
. S EROOT=ROOT_"""BA""," S:+SYS>0&($D(@(ROOT_"""ABA"","_+SYS_")"))) EROOT=ROOT_"""ABA"","_+SYS_","
. F S ORD=$O(@(EROOT_""""_ORD_""")")) Q:'$$ISORD D
. . S IEN=0 F S IEN=$O(@(EROOT_""""_ORD_""","_+IEN_")")) Q:+IEN'>0 D
. . . N VAL,STA S STA=1 S:VER>0 STA=$$LS^ICDEXLK3(ROOT,IEN,CDT)
. . . Q:+($G(VER))>0&(+STA'>0)
. . . S VAL=$P($G(@(ROOT_+IEN_",0)")),"^",1)
. . . Q:VAL'=ORG S EXM(IEN)="",LOR=1
; Exact Match Text
I $O(EXM(0))'>0 D
. Q:$D(ICDBYCD) S KEY=$$UP^XLFSTR($G(ORG)) K PARS D TOKEN^ICDEXLK3(KEY,ROOT,SYS,.PARS)
. S NUM=$O(PARS(0)),SEQ=$O(PARS(+NUM,0)),KEY=$G(PARS(+NUM,+SEQ))
. K PARS(+NUM,+SEQ) Q:$L(KEY)'>1
. S ORD=$E(KEY,1,($L(KEY)-1))_$C(($A($E(KEY,$L(KEY)))-1))_"~"
. S EROOT=ROOT_"""D""," S:+SYS>0&($D(@(ROOT_"""AD"","_+SYS_")"))) EROOT=ROOT_"""AD"","_+SYS_","
. F S ORD=$O(@(EROOT_""""_ORD_""")")) Q:'$$ISORD D
. . S IEN=0 I $G(DIC(0))["X",ORD'=KEY Q
. . F S IEN=$O(@(EROOT_""""_ORD_""","_+IEN_")")) Q:+IEN'>0 D
. . . N VAL,STA S STA=1 S:VER>0 STA=$$LS^ICDEXLK3(ROOT,IEN,CDT)
. . . Q:+($G(VER))>0&(+STA'>0)
. . . S VAL=$$LD^ICDEXLK3(ROOT,IEN,CDT,VER)
. . . Q:$$UP^XLFSTR(VAL)'=$$UP^XLFSTR(ORG)
. . . S EXM(IEN)="",LOR=0
S (X,IEN)=0 F S IEN=$O(EXM(IEN)) Q:+IEN'>0 D
. N ICDI S ICDI=$O(Y(" "),-1)+1,Y(ICDI)=IEN,(X,Y(0))=ICDI
Q X
IEN ; Lookup by IEN
K Y S FND=0,Y=-1 Q:'$L(INP2) Q:INP2'?1N.N Q:+INP2'>0 Q:'$L(ROOT) Q:+FILE'>0
N XX,VDES,UDES,IEN,SNAME,ICS,INAME,STA,ORG S IEN=INP2 Q:'$D(@(ROOT_+IEN_",0)"))
S ORG="`"_IEN,VDES=$$LD^ICDEX(FILE,IEN,ICDCDT),UDES=$$LD^ICDEX(FILE,IEN,9999999)
S ICS=$$CSI^ICDEX(FILE,IEN),XX=VDES,(SNAME,INAME)=$$SYS^ICDEX(ICS,,"E")
S:$L($G(ICDSYS)) SNAME=$$SYS^ICDEX($G(ICDSYS),,"E")
S STA=$$LS^ICDEX(FILE,IEN,$G(ICDCDT))
I $L($G(ICDSYS))>0,ICS>0,$G(ICDSYS)'=ICS D Q
. K X,Y S X="" S:$L($G(ORG)) X=$G(ORG) S Y=-1,FND=0 Q
. S X=UDES,Y="-1^IEN "_IEN_" is not of the "_SNAME_" coding system"
I +($G(ICDVER))>0,STA'>0 D Q
. K X,Y S X="" S:$L($G(ORG)) X=$G(ORG) S Y=-1,FND=0 Q
. S X=UDES,Y="-1^IEN "_IEN_" is not active on "_$$FMTE^XLFDT($G(ICDCDT),"5Z")
I +($G(ICDVER))'>0,$E(XX,1,2)="-1",$L(UDES),$E(UDES,1,2)'="-1" S XX=UDES
W:$D(LOUD)&($G(DIC(0))["E")&($E(XX,1,2)'="-1") " ",XX
D FND(ROOT,IEN,ICDCDT,$G(ICS),$G(ICDVER),+($G(LOR)),$G(ICDOUT))
D SEL(ROOT,1) S FND=+($G(^TMP(SUB,$J,"SEL",0)))
I FND=1,+($G(^TMP(SUB,$J,"SEL",1)))>0 D
. S Y=$G(^TMP(SUB,$J,"SEL",1)) S:Y[" " Y=$P(Y," ",1)
. D Y^ICDEXLK2($G(ROOT),+Y,$G(ICDCDT))
S:+($G(Y))'>0 Y=-1 S:$L($G(ORG)) X=$G(ORG)
Q
;
FND(ROOT,IEN,CDT,SYS,VER,LOR,OUT) ; Add Item to Found List
;
; Input
;
; ROOT Global Root
; IEN Internal Entry Number
; CDT Date
; SYS Coding System
; VER Versioned Search
; LOR List Order
; 0 List by Text Length
; 1 List by Code Number
; OUT Output Format
; 1 Fileman, code and short text
; 2 Fileman, code and description
; 3 Lexicon, short text and code
; 4 Lexicon, description and code
;
; Output
;
; ^TMP(ID,$J,"FND")
; ^TMP(ID,$J,"FND",LEN,SEQ)=IEN ^ Display Text
; ^TMP(ID,$J,"FND","IEN",<ien>)=""
;
; where
;
; ID is a package namespaced subscript:
;
; ICD9 - for file #80 searches
; ICD0 - for file #80.1 searches
;
; LEN is a number assigned based string length
; SEQ is a unique sequence number for length
;
; Uses DIC("S") to screen output
;
N CC,CODE,CTR,FILE,SEQ,SCREEN,SHORT,LONG,STATUS,STA,SUB,TEXT,TERM,TYP,NUM,Y
S SYS=+($G(SYS)),VER=+($G(VER)) S (Y,IEN)=+($G(IEN)) Q:+IEN'>0
S ROOT=$$ROOT^ICDEX($G(ROOT)),FILE=$$FILE^ICDEX(ROOT)
S SUB=$TR(ROOT,"^("),SCREEN=$$SCREEN Q:'SCREEN Q:+FILE'>0
S CODE=$P($G(@(ROOT_+IEN_",0)")),"^",1) Q:'$L(CODE)
S:'$L($G(CDT)) CDT=$$DT^XLFDT S LOR=+($G(LOR))
S STA=1 I +VER>0 S STA=$$STATCHK^ICDEX(CODE,CDT,SYS) Q:+($G(STA))'>0
Q:'$L(SUB) Q:$D(^TMP(SUB,$J,"FND","IEN",+IEN))
S TYP=$P($G(^ICDS(+SYS,0)),"^",1),TERM=""
S OUT=$G(OUT) S:+OUT'>0 OUT=1 S:+OUT>4 OUT=1
I +($G(OUT))=1!(+($G(OUT))=3) S TERM=$$SD^ICDEX(FILE,IEN,CDT)
I +($G(OUT))=2!(+($G(OUT))=4) D
. S TERM=$$LD^ICDEX(FILE,IEN,CDT) Q:$P(TERM,"^",1)=-1
. I +($G(OUT))=4,$L($T(MIX^LEXXM)) S TERM=$$MIX^LEXXM(TERM)
I VER'>0,($P(TERM,"^",1)=-1!('$L(TERM))) D
. N TDT S TDT=$O(@(ROOT_IEN_",67,""B"","_+($G(CDT))_")")) Q:$E(TDT,1,7)'?7N
. I +($G(OUT))=1!(+($G(OUT))=3) S TERM=$$SD^ICDEX(FILE,IEN,TDT)
. I +($G(OUT))=2!(+($G(OUT))=4) S TERM=$$LD^ICDEX(FILE,IEN,TDT)
. I +($G(OUT))=4,$P(TERM,"^",1)'=-1,$L($T(MIX^LEXXM)) S TERM=$$MIX^LEXXM(TERM)
. S:$P(TERM,"^",1)=-1 TERM="" Q:'$L(TERM)
. S:TDT?7N TERM=TERM_" ("_$$FMTE^XLFDT(TDT,"5ZM")_")"
S:$P(TERM,"^",1)=-1 TERM="" Q:'$L(TERM) S NUM=$$NUM^ICDEX(CODE)
S CODE=CODE_$J(" ",(10-$L(CODE))) S CC=""
S:FILE=80 CC=$$VCC^ICDEX(IEN,CDT),CC=$$CC(+CC)
S STATUS=$O(@(ROOT_+IEN_",66,""B"","_(+CDT+.000001)_")"),-1)
S STATUS=$O(@(ROOT_+IEN_",66,""B"","_+STATUS_","" "")"),-1)
S STATUS=$P($G(@(ROOT_+IEN_",66,"_+STATUS_",0)")),"^",2)
S STATUS=$$ST(STATUS)
S:$G(OUT)'?1N OUT=$G(OUT) S:+OUT'>0 OUT=1 S:+OUT>4 OUT=4
I +($G(OUT))=1!(+($G(OUT))=2) D
. S:$G(DIC(0))'["S" TEXT=CODE_TERM_CC_STATUS
. S:$G(DIC(0))["S" TEXT=TERM_CC_STATUS
I +($G(OUT))=3!(+($G(OUT))=4) D
. S CODE=$$TM(CODE),TEXT=TERM_CC_STATUS
. Q:$G(DIC(0))["S"
. S:$L(TYP) TEXT=TEXT_" ("_TYP_" "_CODE_")"
. S:'$L(TYP) TEXT=TEXT_" ("_CODE_")"
S SEQ=246-$L(TERM) S:LOR>0 SEQ=NUM
S CTR=$O(^TMP(SUB,$J,"FND",+SEQ," "),-1)+1
S ^TMP(SUB,$J,"FND",+SEQ,CTR)=IEN_"^"_TEXT
S ^TMP(SUB,$J,"FND","IEN",+IEN)=""
Q
SEL(ROOT,LOR) ; Add Items to Selection List
;
; Input
;
; ROOT Global Root/File # (Required)
; LOR List Order
; 0 List by Text Length
; 1 List by Code Number
;
; Output
;
; ^TMP(ID,$J,"SEL")
; ^TMP(ID,$J,"SEL",0)=# of entries
; ^TMP(ID,$J,"SEL",#)=IEN^Display Text
;
; where ID is a package namespaced subscript:
;
; ICD9 - for the Diagnosis file #80
; ICD0 - for the Operations/Procedure file #80.1
;
; Uses ^TMP(NAME,$J,"FND") (Optional)
; Kills ^TMP(NAME,$J,"FND")
;
N CTR,FILE,FND,SEQ,SUB,TEXT S ROOT=$$ROOT^ICDEX($G(ROOT)),LOR=+($G(LOR))
S FILE=$$FILE^ICDEX(ROOT),SUB=$TR(ROOT,"^(") K ^TMP(SUB,$J,"SEL")
Q:+FILE'>0 Q:'$L(SUB) K ^TMP(SUB,$J,"SEL")
I +($G(LOR))'>0 D
. S SEQ=" " F S SEQ=$O(^TMP(SUB,$J,"FND",SEQ),-1) Q:+SEQ'>0 D SEL2
I +($G(LOR))>0 D
. S SEQ=0 F S SEQ=$O(^TMP(SUB,$J,"FND",SEQ)) Q:+SEQ'>0 D SEL2
K ^TMP(SUB,$J,"FND")
Q
SEL2 ; Add Items to Selection List (part 2)
N FND S FND=0 F S FND=$O(^TMP(SUB,$J,"FND",+SEQ,FND)) Q:+FND'>0 D
. N CTR,TEXT S TEXT=$G(^TMP(SUB,$J,"FND",+SEQ,FND))
. Q:'$L(TEXT) Q:+TEXT'>0 Q:'$L($P(TEXT,"^",2))
. S CTR=$O(^TMP(SUB,$J,"SEL"," "),-1)+1
. S ^TMP(SUB,$J,"SEL",CTR)=TEXT,^TMP(SUB,$J,"SEL",0)=CTR
Q
;
; Miscellaneous
SH ; Display TMP
N SUB,NN,NC
S SUB="ICD9" S:'$D(^TMP(SUB)) SUB="ICD0" Q:'$D(^TMP(SUB))
S NN="^TMP("""_SUB_""","_$J_")",NC="^TMP("""_SUB_""","_$J_","
W:'$D(@NN) ! Q:'$D(@NN) F S NN=$Q(@NN) Q:'$L(NN)!(NN'[NC) W !,NN,"=",@NN
W !
Q
SCREEN(X) ; Screen Entries - Boolean Truth Value
Q:+($G(Y))'>0 1 Q:'$L($G(ROOT)) 1
N ICDNR,ICDO,ICDS,ICDY S ICDY=+($G(Y)),ROOT=$$ROOT^ICDEX($G(ROOT)) Q:'$L(ROOT) 1
S ICDS=$G(ICDDICS) Q:'$L(ICDS) 1 S Y=+($G(ICDY))
S ICDNR=$D(@(ROOT_+Y_",0)")) X ICDS S ICDO=$T
Q:'ICDO 0
Q 1
Q
; QUASAR
N ICDREF,ICDSC1,ICDSC2,ICDF1,ICDF2,ICDIN
I $L($G(DICR(2,"S"))) D
. I $G(DIC("S"))["X DICR(2,""S"")" S ICDF2=""
. I $G(DICR(1,31))=ICDF2,$L($G(DICR(2,"S"))),$G(ICDF2)["DICR(2,""S"")" S ICDF2=""
Q:'$L((ICDF1_ICDF2)) 1 S ICDIN=$D(@(ROOT_+ICDY_",0)")) Q:ICDIN'>0 0
; SCHEDULING
S X=ICDF1 D ^DIM S:$D(X) ICDSC1=X D:$L(ICDSC1)
. S Y=+($G(ICDY)),ICDREF=$D(@(ROOT_+Y_",0)")) X ICDSC1 S ICDSC1=$T
Q:+ICDSC1'>0&('$L(ICDF2)) 0 Q:'$L(ICDF2) 1
S X=ICDF2 D ^DIM S:$D(X) ICDSC2=X D:$L(ICDSC2)&($L(ICDF1))
. S Y=+($G(ICDY)),ICDREF=$D(@(ROOT_+Y_",0)")) X ICDSC2 S ICDSC2=$T
Q:+ICDSC1'>0!(+(ICDSC2'>0)) 0
Q 1
ISORD(X) ; Check if in $ORDER
Q:'$L($G(ORD)) 0 Q:'$L($G(KEY)) 0
Q:$E($G(ORD),1,$L($G(KEY)))=$G(KEY) 1
Q 0
CC(X) ; CC
Q:+($G(X))=1 " (CC)"
Q:+($G(X))=2 " (Major CC)"
Q ""
ST(X) ; Status indicators
Q:$G(X)?1N&(+$G(X)'>0) " (Inactive)"
Q:$G(X)'?1N&(+$G(X)'>0) " (Pending)"
Q ""
TM(X,Y) ; Trim Y
S Y=$G(Y) S:'$L(Y) Y=" "
F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
Q X
ICDEXLK5 ;SLC/KER - ICD Extractor - Lookup, List ;04/21/2014
+1 ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
+2 ;
+3 ; Global Variables
+4 ; ^ICDS( N/A
+5 ; ^TMP(SUB,$J SACC 2.3.2.5.1
+6 ;
+7 ; External References
+8 ; ^DIM ICR 10016
+9 ; $$MIX^LEXXM ICR 5781
+10 ; $$DT^XLFDT ICR 10103
+11 ; $$FMTE^XLFDT ICR 10103
+12 ; $$UP^XLFSTR ICR 10104
+13 ;
+14 ; Local Variables Newed or Killed by calling application
+15 ; DIC(0) Fileman Lookup Parameters
+16 ; DIC("S") Fileman Screen
+17 ;
+18 ; Local Variables Newed or Killed Elsewhere
+19 ; ICDBYCD Sort by Code
+20 ; ICDCDT Code Set Date
+21 ; ICDOUT Format of display
+22 ; ICDVDT Date to use during lookup
+23 ; ICDSYS Coding System
+24 ; ICDVER Versioned Lookup
+25 ; ICDDICSS Secondary Screen
+26 ; INP2 User Input (processed)
+27 ; LOUD Output to Screen
+28 ;
+29 QUIT
EXM(TXT,ROOT,Y,CDT,SYS,VER) ; Lookup Exact Match
+1 ;
+2 ; Input TXT Text/Code for search (Required)
+3 ; ROOT Global Root (Required)
+4 ; .Y Output array passed by reference (Required)
+5 ; CDT Date
+6 ; SYS Coding System
+7 ; VER Versioned Search
+8 ;
+9 ; Output $$EM Number of Exact Matches Found
+10 ; Y(n) Array of Exact Matches
+11 ;
+12 NEW EXM,KEY,ORD,ICDI,IEN,NUM,ORG,EROOT
SET ORG=$GET(TXT)
IF '$LENGTH($GET(ORG))
QUIT 0
+13 IF '$LENGTH($TRANSLATE(ORG,"""",""))
QUIT 0
SET ROOT=$GET(ROOT)
IF '$LENGTH($GET(ROOT))
QUIT 0
+14 SET SYS=+($GET(SYS))
SET VER=+($GET(VER))
+15 SET CDT=$$CDT^ICDEXLK3($GET(CDT),SYS)
+16 ; Exact Match Case Sensitive Code
+17 SET KEY=ORG
SET KEY=ORG
SET ORD=$EXTRACT(KEY,1,($LENGTH(KEY)-1))_$CHAR(($ASCII($EXTRACT(KEY,$LENGTH(KEY)))-1))_"~ "
+18 SET EROOT=ROOT_"""BA"","
IF +SYS>0&($DATA(@(ROOT_"""ABA"","_+SYS_")")))
SET EROOT=ROOT_"""ABA"","_+SYS_","
+19 FOR
SET ORD=$ORDER(@(EROOT_""""_ORD_""")"))
IF '$$ISORD
QUIT
Begin DoDot:1
+20 SET IEN=0
FOR
SET IEN=$ORDER(@(EROOT_""""_ORD_""","_+IEN_")"))
IF +IEN'>0
QUIT
Begin DoDot:2
+21 NEW VAL,STA
SET STA=1
+22 IF VER>0
SET STA=$$LS^ICDEXLK3(ROOT,IEN,CDT)
+23 IF +($GET(VER))>0&(+STA'>0)
QUIT
+24 SET VAL=$PIECE($GET(@(ROOT_+IEN_",0)")),"^",1)
+25 IF VAL'=ORG
QUIT
SET EXM(IEN)=""
SET LOR=1
End DoDot:2
End DoDot:1
+26 ; Exact Match Code
+27 IF $ORDER(EXM(0))'>0
Begin DoDot:1
+28 SET KEY=$$UP^XLFSTR(ORG)
SET KEY=ORG
SET ORD=$EXTRACT(KEY,1,($LENGTH(KEY)-1))_$CHAR(($ASCII($EXTRACT(KEY,$LENGTH(KEY)))-1))_"~ "
+29 SET EROOT=ROOT_"""BA"","
IF +SYS>0&($DATA(@(ROOT_"""ABA"","_+SYS_")")))
SET EROOT=ROOT_"""ABA"","_+SYS_","
+30 FOR
SET ORD=$ORDER(@(EROOT_""""_ORD_""")"))
IF '$$ISORD
QUIT
Begin DoDot:2
+31 SET IEN=0
FOR
SET IEN=$ORDER(@(EROOT_""""_ORD_""","_+IEN_")"))
IF +IEN'>0
QUIT
Begin DoDot:3
+32 NEW VAL,STA
SET STA=1
IF VER>0
SET STA=$$LS^ICDEXLK3(ROOT,IEN,CDT)
+33 IF +($GET(VER))>0&(+STA'>0)
QUIT
+34 SET VAL=$PIECE($GET(@(ROOT_+IEN_",0)")),"^",1)
+35 IF VAL'=ORG
QUIT
SET EXM(IEN)=""
SET LOR=1
End DoDot:3
End DoDot:2
End DoDot:1
+36 ; Exact Match Text
+37 IF $ORDER(EXM(0))'>0
Begin DoDot:1
+38 IF $DATA(ICDBYCD)
QUIT
SET KEY=$$UP^XLFSTR($GET(ORG))
KILL PARS
DO TOKEN^ICDEXLK3(KEY,ROOT,SYS,.PARS)
+39 SET NUM=$ORDER(PARS(0))
SET SEQ=$ORDER(PARS(+NUM,0))
SET KEY=$GET(PARS(+NUM,+SEQ))
+40 KILL PARS(+NUM,+SEQ)
IF $LENGTH(KEY)'>1
QUIT
+41 SET ORD=$EXTRACT(KEY,1,($LENGTH(KEY)-1))_$CHAR(($ASCII($EXTRACT(KEY,$LENGTH(KEY)))-1))_"~"
+42 SET EROOT=ROOT_"""D"","
IF +SYS>0&($DATA(@(ROOT_"""AD"","_+SYS_")")))
SET EROOT=ROOT_"""AD"","_+SYS_","
+43 FOR
SET ORD=$ORDER(@(EROOT_""""_ORD_""")"))
IF '$$ISORD
QUIT
Begin DoDot:2
+44 SET IEN=0
IF $GET(DIC(0))["X"
IF ORD'=KEY
QUIT
+45 FOR
SET IEN=$ORDER(@(EROOT_""""_ORD_""","_+IEN_")"))
IF +IEN'>0
QUIT
Begin DoDot:3
+46 NEW VAL,STA
SET STA=1
IF VER>0
SET STA=$$LS^ICDEXLK3(ROOT,IEN,CDT)
+47 IF +($GET(VER))>0&(+STA'>0)
QUIT
+48 SET VAL=$$LD^ICDEXLK3(ROOT,IEN,CDT,VER)
+49 IF $$UP^XLFSTR(VAL)'=$$UP^XLFSTR(ORG)
QUIT
+50 SET EXM(IEN)=""
SET LOR=0
End DoDot:3
End DoDot:2
End DoDot:1
+51 SET (X,IEN)=0
FOR
SET IEN=$ORDER(EXM(IEN))
IF +IEN'>0
QUIT
Begin DoDot:1
+52 NEW ICDI
SET ICDI=$ORDER(Y(" "),-1)+1
SET Y(ICDI)=IEN
SET (X,Y(0))=ICDI
End DoDot:1
+53 QUIT X
IEN ; Lookup by IEN
+1 KILL Y
SET FND=0
SET Y=-1
IF '$LENGTH(INP2)
QUIT
IF INP2'?1N.N
QUIT
IF +INP2'>0
QUIT
IF '$LENGTH(ROOT)
QUIT
IF +FILE'>0
QUIT
+2 NEW XX,VDES,UDES,IEN,SNAME,ICS,INAME,STA,ORG
SET IEN=INP2
IF '$DATA(@(ROOT_+IEN_",0)"))
QUIT
+3 SET ORG="`"_IEN
SET VDES=$$LD^ICDEX(FILE,IEN,ICDCDT)
SET UDES=$$LD^ICDEX(FILE,IEN,9999999)
+4 SET ICS=$$CSI^ICDEX(FILE,IEN)
SET XX=VDES
SET (SNAME,INAME)=$$SYS^ICDEX(ICS,,"E")
+5 IF $LENGTH($GET(ICDSYS))
SET SNAME=$$SYS^ICDEX($GET(ICDSYS),,"E")
+6 SET STA=$$LS^ICDEX(FILE,IEN,$GET(ICDCDT))
+7 IF $LENGTH($GET(ICDSYS))>0
IF ICS>0
IF $GET(ICDSYS)'=ICS
Begin DoDot:1
+8 KILL X,Y
SET X=""
IF $LENGTH($GET(ORG))
SET X=$GET(ORG)
SET Y=-1
SET FND=0
QUIT
+9 SET X=UDES
SET Y="-1^IEN "_IEN_" is not of the "_SNAME_" coding system"
End DoDot:1
QUIT
+10 IF +($GET(ICDVER))>0
IF STA'>0
Begin DoDot:1
+11 KILL X,Y
SET X=""
IF $LENGTH($GET(ORG))
SET X=$GET(ORG)
SET Y=-1
SET FND=0
QUIT
+12 SET X=UDES
SET Y="-1^IEN "_IEN_" is not active on "_$$FMTE^XLFDT($GET(ICDCDT),"5Z")
End DoDot:1
QUIT
+13 IF +($GET(ICDVER))'>0
IF $EXTRACT(XX,1,2)="-1"
IF $LENGTH(UDES)
IF $EXTRACT(UDES,1,2)'="-1"
SET XX=UDES
+14 IF $DATA(LOUD)&($GET(DIC(0))["E")&($EXTRACT(XX,1,2)'="-1")
WRITE " ",XX
+15 DO FND(ROOT,IEN,ICDCDT,$GET(ICS),$GET(ICDVER),+($GET(LOR)),$GET(ICDOUT))
+16 DO SEL(ROOT,1)
SET FND=+($GET(^TMP(SUB,$JOB,"SEL",0)))
+17 IF FND=1
IF +($GET(^TMP(SUB,$JOB,"SEL",1)))>0
Begin DoDot:1
+18 SET Y=$GET(^TMP(SUB,$JOB,"SEL",1))
IF Y[" "
SET Y=$PIECE(Y," ",1)
+19 DO Y^ICDEXLK2($GET(ROOT),+Y,$GET(ICDCDT))
End DoDot:1
+20 IF +($GET(Y))'>0
SET Y=-1
IF $LENGTH($GET(ORG))
SET X=$GET(ORG)
+21 QUIT
+22 ;
FND(ROOT,IEN,CDT,SYS,VER,LOR,OUT) ; Add Item to Found List
+1 ;
+2 ; Input
+3 ;
+4 ; ROOT Global Root
+5 ; IEN Internal Entry Number
+6 ; CDT Date
+7 ; SYS Coding System
+8 ; VER Versioned Search
+9 ; LOR List Order
+10 ; 0 List by Text Length
+11 ; 1 List by Code Number
+12 ; OUT Output Format
+13 ; 1 Fileman, code and short text
+14 ; 2 Fileman, code and description
+15 ; 3 Lexicon, short text and code
+16 ; 4 Lexicon, description and code
+17 ;
+18 ; Output
+19 ;
+20 ; ^TMP(ID,$J,"FND")
+21 ; ^TMP(ID,$J,"FND",LEN,SEQ)=IEN ^ Display Text
+22 ; ^TMP(ID,$J,"FND","IEN",<ien>)=""
+23 ;
+24 ; where
+25 ;
+26 ; ID is a package namespaced subscript:
+27 ;
+28 ; ICD9 - for file #80 searches
+29 ; ICD0 - for file #80.1 searches
+30 ;
+31 ; LEN is a number assigned based string length
+32 ; SEQ is a unique sequence number for length
+33 ;
+34 ; Uses DIC("S") to screen output
+35 ;
+36 NEW CC,CODE,CTR,FILE,SEQ,SCREEN,SHORT,LONG,STATUS,STA,SUB,TEXT,TERM,TYP,NUM,Y
+37 SET SYS=+($GET(SYS))
SET VER=+($GET(VER))
SET (Y,IEN)=+($GET(IEN))
IF +IEN'>0
QUIT
+38 SET ROOT=$$ROOT^ICDEX($GET(ROOT))
SET FILE=$$FILE^ICDEX(ROOT)
+39 SET SUB=$TRANSLATE(ROOT,"^(")
SET SCREEN=$$SCREEN
IF 'SCREEN
QUIT
IF +FILE'>0
QUIT
+40 SET CODE=$PIECE($GET(@(ROOT_+IEN_",0)")),"^",1)
IF '$LENGTH(CODE)
QUIT
+41 IF '$LENGTH($GET(CDT))
SET CDT=$$DT^XLFDT
SET LOR=+($GET(LOR))
+42 SET STA=1
IF +VER>0
SET STA=$$STATCHK^ICDEX(CODE,CDT,SYS)
IF +($GET(STA))'>0
QUIT
+43 IF '$LENGTH(SUB)
QUIT
IF $DATA(^TMP(SUB,$JOB,"FND","IEN",+IEN))
QUIT
+44 SET TYP=$PIECE($GET(^ICDS(+SYS,0)),"^",1)
SET TERM=""
+45 SET OUT=$GET(OUT)
IF +OUT'>0
SET OUT=1
IF +OUT>4
SET OUT=1
+46 IF +($GET(OUT))=1!(+($GET(OUT))=3)
SET TERM=$$SD^ICDEX(FILE,IEN,CDT)
+47 IF +($GET(OUT))=2!(+($GET(OUT))=4)
Begin DoDot:1
+48 SET TERM=$$LD^ICDEX(FILE,IEN,CDT)
IF $PIECE(TERM,"^",1)=-1
QUIT
+49 IF +($GET(OUT))=4
IF $LENGTH($TEXT(MIX^LEXXM))
SET TERM=$$MIX^LEXXM(TERM)
End DoDot:1
+50 IF VER'>0
IF ($PIECE(TERM,"^",1)=-1!('$LENGTH(TERM)))
Begin DoDot:1
+51 NEW TDT
SET TDT=$ORDER(@(ROOT_IEN_",67,""B"","_+($GET(CDT))_")"))
IF $EXTRACT(TDT,1,7)'?7N
QUIT
+52 IF +($GET(OUT))=1!(+($GET(OUT))=3)
SET TERM=$$SD^ICDEX(FILE,IEN,TDT)
+53 IF +($GET(OUT))=2!(+($GET(OUT))=4)
SET TERM=$$LD^ICDEX(FILE,IEN,TDT)
+54 IF +($GET(OUT))=4
IF $PIECE(TERM,"^",1)'=-1
IF $LENGTH($TEXT(MIX^LEXXM))
SET TERM=$$MIX^LEXXM(TERM)
+55 IF $PIECE(TERM,"^",1)=-1
SET TERM=""
IF '$LENGTH(TERM)
QUIT
+56 IF TDT?7N
SET TERM=TERM_" ("_$$FMTE^XLFDT(TDT,"5ZM")_")"
End DoDot:1
+57 IF $PIECE(TERM,"^",1)=-1
SET TERM=""
IF '$LENGTH(TERM)
QUIT
SET NUM=$$NUM^ICDEX(CODE)
+58 SET CODE=CODE_$JUSTIFY(" ",(10-$LENGTH(CODE)))
SET CC=""
+59 IF FILE=80
SET CC=$$VCC^ICDEX(IEN,CDT)
SET CC=$$CC(+CC)
+60 SET STATUS=$ORDER(@(ROOT_+IEN_",66,""B"","_(+CDT+.000001)_")"),-1)
+61 SET STATUS=$ORDER(@(ROOT_+IEN_",66,""B"","_+STATUS_","" "")"),-1)
+62 SET STATUS=$PIECE($GET(@(ROOT_+IEN_",66,"_+STATUS_",0)")),"^",2)
+63 SET STATUS=$$ST(STATUS)
+64 IF $GET(OUT)'?1N
SET OUT=$GET(OUT)
IF +OUT'>0
SET OUT=1
IF +OUT>4
SET OUT=4
+65 IF +($GET(OUT))=1!(+($GET(OUT))=2)
Begin DoDot:1
+66 IF $GET(DIC(0))'["S"
SET TEXT=CODE_TERM_CC_STATUS
+67 IF $GET(DIC(0))["S"
SET TEXT=TERM_CC_STATUS
End DoDot:1
+68 IF +($GET(OUT))=3!(+($GET(OUT))=4)
Begin DoDot:1
+69 SET CODE=$$TM(CODE)
SET TEXT=TERM_CC_STATUS
+70 IF $GET(DIC(0))["S"
QUIT
+71 IF $LENGTH(TYP)
SET TEXT=TEXT_" ("_TYP_" "_CODE_")"
+72 IF '$LENGTH(TYP)
SET TEXT=TEXT_" ("_CODE_")"
End DoDot:1
+73 SET SEQ=246-$LENGTH(TERM)
IF LOR>0
SET SEQ=NUM
+74 SET CTR=$ORDER(^TMP(SUB,$JOB,"FND",+SEQ," "),-1)+1
+75 SET ^TMP(SUB,$JOB,"FND",+SEQ,CTR)=IEN_"^"_TEXT
+76 SET ^TMP(SUB,$JOB,"FND","IEN",+IEN)=""
+77 QUIT
SEL(ROOT,LOR) ; Add Items to Selection List
+1 ;
+2 ; Input
+3 ;
+4 ; ROOT Global Root/File # (Required)
+5 ; LOR List Order
+6 ; 0 List by Text Length
+7 ; 1 List by Code Number
+8 ;
+9 ; Output
+10 ;
+11 ; ^TMP(ID,$J,"SEL")
+12 ; ^TMP(ID,$J,"SEL",0)=# of entries
+13 ; ^TMP(ID,$J,"SEL",#)=IEN^Display Text
+14 ;
+15 ; where ID is a package namespaced subscript:
+16 ;
+17 ; ICD9 - for the Diagnosis file #80
+18 ; ICD0 - for the Operations/Procedure file #80.1
+19 ;
+20 ; Uses ^TMP(NAME,$J,"FND") (Optional)
+21 ; Kills ^TMP(NAME,$J,"FND")
+22 ;
+23 NEW CTR,FILE,FND,SEQ,SUB,TEXT
SET ROOT=$$ROOT^ICDEX($GET(ROOT))
SET LOR=+($GET(LOR))
+24 SET FILE=$$FILE^ICDEX(ROOT)
SET SUB=$TRANSLATE(ROOT,"^(")
KILL ^TMP(SUB,$JOB,"SEL")
+25 IF +FILE'>0
QUIT
IF '$LENGTH(SUB)
QUIT
KILL ^TMP(SUB,$JOB,"SEL")
+26 IF +($GET(LOR))'>0
Begin DoDot:1
+27 SET SEQ=" "
FOR
SET SEQ=$ORDER(^TMP(SUB,$JOB,"FND",SEQ),-1)
IF +SEQ'>0
QUIT
DO SEL2
End DoDot:1
+28 IF +($GET(LOR))>0
Begin DoDot:1
+29 SET SEQ=0
FOR
SET SEQ=$ORDER(^TMP(SUB,$JOB,"FND",SEQ))
IF +SEQ'>0
QUIT
DO SEL2
End DoDot:1
+30 KILL ^TMP(SUB,$JOB,"FND")
+31 QUIT
SEL2 ; Add Items to Selection List (part 2)
+1 NEW FND
SET FND=0
FOR
SET FND=$ORDER(^TMP(SUB,$JOB,"FND",+SEQ,FND))
IF +FND'>0
QUIT
Begin DoDot:1
+2 NEW CTR,TEXT
SET TEXT=$GET(^TMP(SUB,$JOB,"FND",+SEQ,FND))
+3 IF '$LENGTH(TEXT)
QUIT
IF +TEXT'>0
QUIT
IF '$LENGTH($PIECE(TEXT,"^",2))
QUIT
+4 SET CTR=$ORDER(^TMP(SUB,$JOB,"SEL"," "),-1)+1
+5 SET ^TMP(SUB,$JOB,"SEL",CTR)=TEXT
SET ^TMP(SUB,$JOB,"SEL",0)=CTR
End DoDot:1
+6 QUIT
+7 ;
+8 ; Miscellaneous
SH ; Display TMP
+1 NEW SUB,NN,NC
+2 SET SUB="ICD9"
IF '$DATA(^TMP(SUB))
SET SUB="ICD0"
IF '$DATA(^TMP(SUB))
QUIT
+3 SET NN="^TMP("""_SUB_""","_$JOB_")"
SET NC="^TMP("""_SUB_""","_$JOB_","
+4 IF '$DATA(@NN)
WRITE !
IF '$DATA(@NN)
QUIT
FOR
SET NN=$QUERY(@NN)
IF '$LENGTH(NN)!(NN'[NC)
QUIT
WRITE !,NN,"=",@NN
+5 WRITE !
+6 QUIT
SCREEN(X) ; Screen Entries - Boolean Truth Value
+1 IF +($GET(Y))'>0
QUIT 1
IF '$LENGTH($GET(ROOT))
QUIT 1
+2 NEW ICDNR,ICDO,ICDS,ICDY
SET ICDY=+($GET(Y))
SET ROOT=$$ROOT^ICDEX($GET(ROOT))
IF '$LENGTH(ROOT)
QUIT 1
+3 SET ICDS=$GET(ICDDICS)
IF '$LENGTH(ICDS)
QUIT 1
SET Y=+($GET(ICDY))
+4 SET ICDNR=$DATA(@(ROOT_+Y_",0)"))
XECUTE ICDS
SET ICDO=$TEST
+5 IF 'ICDO
QUIT 0
+6 QUIT 1
+7 QUIT
+8 ; QUASAR
+9 NEW ICDREF,ICDSC1,ICDSC2,ICDF1,ICDF2,ICDIN
+10 IF $LENGTH($GET(DICR(2,"S")))
Begin DoDot:1
+11 IF $GET(DIC("S"))["X DICR(2,""S"")"
SET ICDF2=""
+12 IF $GET(DICR(1,31))=ICDF2
IF $LENGTH($GET(DICR(2,"S")))
IF $GET(ICDF2)["DICR(2,""S"")"
SET ICDF2=""
End DoDot:1
+13 IF '$LENGTH((ICDF1_ICDF2))
QUIT 1
SET ICDIN=$DATA(@(ROOT_+ICDY_",0)"))
IF ICDIN'>0
QUIT 0
+14 ; SCHEDULING
+15 SET X=ICDF1
DO ^DIM
IF $DATA(X)
SET ICDSC1=X
IF $LENGTH(ICDSC1)
Begin DoDot:1
+16 SET Y=+($GET(ICDY))
SET ICDREF=$DATA(@(ROOT_+Y_",0)"))
XECUTE ICDSC1
SET ICDSC1=$TEST
End DoDot:1
+17 IF +ICDSC1'>0&('$LENGTH(ICDF2))
QUIT 0
IF '$LENGTH(ICDF2)
QUIT 1
+18 SET X=ICDF2
DO ^DIM
IF $DATA(X)
SET ICDSC2=X
IF $LENGTH(ICDSC2)&($LENGTH(ICDF1))
Begin DoDot:1
+19 SET Y=+($GET(ICDY))
SET ICDREF=$DATA(@(ROOT_+Y_",0)"))
XECUTE ICDSC2
SET ICDSC2=$TEST
End DoDot:1
+20 IF +ICDSC1'>0!(+(ICDSC2'>0))
QUIT 0
+21 QUIT 1
ISORD(X) ; Check if in $ORDER
+1 IF '$LENGTH($GET(ORD))
QUIT 0
IF '$LENGTH($GET(KEY))
QUIT 0
+2 IF $EXTRACT($GET(ORD),1,$LENGTH($GET(KEY)))=$GET(KEY)
QUIT 1
+3 QUIT 0
CC(X) ; CC
+1 IF +($GET(X))=1
QUIT " (CC)"
+2 IF +($GET(X))=2
QUIT " (Major CC)"
+3 QUIT ""
ST(X) ; Status indicators
+1 IF $GET(X)?1N&(+$GET(X)'>0)
QUIT " (Inactive)"
+2 IF $GET(X)'?1N&(+$GET(X)'>0)
QUIT " (Pending)"
+3 QUIT ""
TM(X,Y) ; Trim Y
+1 SET Y=$GET(Y)
IF '$LENGTH(Y)
SET Y=" "
+2 FOR
IF $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 FOR
IF $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 QUIT X
