ICDEXLK4 ;SLC/KER - ICD Extractor - Lookup, Text ;04/21/2014
;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
;
; Global Variables
; ^TMP(SUB,$J SACC 2.3.2.5.1
;
; External References
; $$LOW^XLFSTR ICR 10104
; $$UP^XLFSTR ICR 10104
;
; Local Variables Newed or Killed by calling application
; DIC(0) Fileman Lookup Parameters
;
; Local Variables Newed or Killed Elsewhere
; ICDBYCD Sort by Code
; CDT Code Set Date
; OUT Format of display
; SYS Coding System
; VER Versioned Lookup
; SUB ^TMP Subscript
; SYS Coding System
;
TXT ; Lookup by Text (Requires TXT and ROOT)
Q:$D(ICDBYCD) Q:'$L($G(TXT)) Q:'$L($G(ROOT)) Q:$L(TXT)'>1 Q:$G(DIC(0))["B"
S CDT=$$CDT^ICDEXLK3($G(CDT)) N PARS,ORG,CNT,PRV,EROOT,KEY,LOOK,EXACT,ABBR,PRIME
S:'$L($G(SUB)) SUB=$TR(ROOT,"^(,","")
S LOOK=TXT,PRV=+($G(^TMP(SUB,$J,"SEL",0))),(EXACT,ABBR)=0
S CNT=0,ORG=$$UP^XLFSTR($G(TXT)) K PARS D TOKEN^ICDTOKN(TXT,ROOT,$G(SYS),.PARS)
S NUM=$O(PARS(0)),(PRIME,KEY)=$G(PARS(+NUM)) S:+($G(PARS(+NUM,"A")))>0 ABBR=1
K:NUM>0 PARS(+NUM) S:NUM>0&($G(PARS(0))>0) PARS(0)=$G(PARS(0))-1 Q:$L(KEY)'>1
S EROOT=ROOT_"""D""," S:+($G(SYS))>0&($D(@(ROOT_"""AD"","_+($G(SYS))_")"))) EROOT=ROOT_"""AD"","_+($G(SYS))_","
S EXACT=0 I $O(PARS(0))'>0,$L(PRIME),$D(@(EROOT_""""_PRIME_""")")) S EXACT=1
I EXACT>0!(ABBR>0) D
. N ORD,STR,TKN S STR=PRIME F TKN=STR,(STR_"S"),(STR_"ES") D
. . S ORD=TKN I $D(@(EROOT_""""_ORD_""")")) D TXT2
I EXACT'>0&(ABBR'>0) D
. N ORD,STR,TKN S STR=PRIME F TKN=STR,(STR_"S"),(STR_"ES") D
. . S ORD=$E(TKN,1,($L(TKN)-1))_$C(($A($E(TKN,$L(TKN)))-1))_"~"
. . F S ORD=$O(@(EROOT_""""_ORD_""")")) Q:'$$ISORD^ICDEXLK3 D TXT2
D:$D(^TMP(SUB,$J,"FND")) SEL^ICDEXLK5(ROOT,0)
Q
TXT2 ; Lookup by Text (loop)
N IEN S IEN=0 F S IEN=$O(@(EROOT_""""_ORD_""","_+IEN_")")) Q:+IEN'>0 D
. N OK,NUM,TDT,TIE,TXT,KEY,VDT S VDT=+CDT+.000001
. S TDT=$O(@(EROOT_""""_ORD_""","_+IEN_","_VDT_")"),-1)
. I +($G(VER))'>0,TDT'?7N D
. . S TDT=$O(@(EROOT_""""_ORD_""","_+IEN_","_(+CDT-.000001)_")"))
. Q:TDT'?7N S TIE=$O(@(EROOT_""""_ORD_""","_+IEN_","_+TDT_",0)"))
. S TXT=$$UP^XLFSTR($G(@(ROOT_+IEN_",68,"_+TIE_",1)")))
. I $G(DIC(0))'["A",$G(DIC(0))["O" D Q
. . Q:CNT>1 I ORG=TXT D FND^ICDEXLK5(ROOT,IEN,CDT,$G(SYS),$G(VER),0,$G(OUT)) S CNT=CNT+1
. S OK=1,NUM=0
. F S NUM=$O(PARS(NUM)) Q:+NUM'>0 D
. . N EXACT,PR,OR,SP,IN,AB S PR=$G(PARS(NUM)),AB=+($G(PARS(+NUM,"A")))
. . I AB'>0 S IN=$$IN(TXT,PR),SP=$$SI(ROOT,+IEN,+TIE,PR)
. . I AB>0 S IN=$$EX(TXT,PR),SP=$$SE(ROOT,+IEN,+TIE,PR)
. . S:IN'>0&(SP'>0) OK=0
. D:+OK>0 FND^ICDEXLK5(ROOT,IEN,CDT,$G(SYS),$G(VER),0,$G(OUT))
Q
;
; Miscellaneous
SE(RT,IE,TI,X) ; Supplemental Word (exact match exist)
N FIND,IIEN,PLUR,TEXT,ROOT,TIEN
S FIND=$$UP^XLFSTR($G(X)) Q:'$L(FIND) 0
S ROOT=$$ROOT^ICDEX($G(RT)) Q:'$L(ROOT) 0
S IIEN=+($G(IE)),TIEN=+($G(TI))
S TEXT=$$UP^XLFSTR($G(@(ROOT_+IIEN_",68,"_+TIEN_",1)"))) Q:'$L(TEXT) 0
Q:'$D(@(ROOT_+IIEN_",68,"_+TIEN_",2,""B"","""_FIND_""")")) 0
S PLUR=$$EX(TEXT,(FIND_"S")) Q:PLUR>0 0
Q 1
SI(RT,IE,TI,X) ; Supplemental Word (match exist)
N FIND,IIEN,PLUR,TEXT,NEXT,TIEN,ORDR,ROOT
S FIND=$$UP^XLFSTR($G(X)) Q:'$L(FIND) 0
S ROOT=$$ROOT^ICDEX($G(RT)) Q:'$L(ROOT) 0
S IIEN=+($G(IE)),TIEN=+($G(TI))
S:FIND?1N.N ORDR=FIND-.00000000000000009 I FIND'?1N.N D
. S:$L(FIND)=1 ORDR=$C($A(FIND)-1)_"~"
. S:$L(FIND)>1 ORDR=$E(FIND,1,($L(FIND)-1))_$C($A($E(FIND,$L(FIND)))-1)_"~"
S NEXT=$O(@(ROOT_+IIEN_",68,"_+TIEN_",2,""B"","""_ORDR_""")"))
Q:$E(NEXT,1,$L(FIND))=FIND 1
Q 0
EX(X,Y) ; String Y is exactly in X
N CON,FIND,TEXT,EXACT S TEXT=$G(X),FIND=$G(Y),EXACT=1
S CON=$$CON(TEXT,FIND) S X=+($G(CON))
Q X
IN(X,Y) ; String Y is contained in X
N CON,FIND,TEXT S TEXT=$G(X),FIND=$G(Y)
S CON=$$CON(TEXT,FIND) S X=+($G(CON))
Q X
CON(X,Y) ; Text X Contains String Y
N FIND,FOUND,TEXT,LEAD,TRAIL,STR
S TEXT=$$UP^XLFSTR($G(X)),FIND=$$UP^XLFSTR($G(Y))
Q:'$L(TEXT) 0 Q:'$L(FIND) 0 Q:$L(FIND)>$L(TEXT) 0
S (X,FOUND)=0
I +($G(EXACT))>0 S X=0 D Q X
. F TRAIL=" ","-","(","<","{","[","," D Q:FOUND>0
. . N STR S STR=FIND_TRAIL
. . S:$E(TEXT,1,$L(STR))=STR FOUND=1
. . S:FOUND>0 X=FOUND
. Q:FOUND>0 F LEAD=" ","-","(","<","{","[","," D Q:FOUND>0
. . N STR S STR=LEAD_FIND
. . S:$E(TEXT,($L(TEXT)-$L(STR)),$L(TEXT))=STR FOUND=1
. . S:FOUND>0 X=FOUND
. Q:FOUND>0 F LEAD=" ","-","(","<","{","[","," D Q:FOUND>0
. . F TRAIL=" ","-",")",">","}","]","," D Q:FOUND>0
. . . N STR S STR=LEAD_FIND_TRAIL S:TEXT[STR FOUND=1
. . . S:FOUND>0 X=FOUND
. S:FOUND>0 X=FOUND
S:$E(TEXT,1,$L(FIND))=FIND FOUND=1
S:FOUND>0 X=FOUND Q:FOUND>0 X
F LEAD=" ","-","(","<","{","[","," D Q:FOUND>0
. N STR S STR=LEAD_FIND S:TEXT[STR FOUND=1
. S:FOUND>0 X=FOUND
Q:FOUND>0 X F LEAD=" ","-","(","<","{","[","," D Q:FOUND>0
. N TRAIL F TRAIL=" ","-",")",">","}","]","," D Q:FOUND>0
. . N STR S STR=LEAD_FIND_TRAIL S:TEXT[STR FOUND=1
. . S:FOUND>0 X=FOUND
S:FOUND>0 X=FOUND
Q X
LC(X) ; Leading Character
S X=$G(X) S X=$$UP^XLFSTR($E(X,1))_$$LOW^XLFSTR($E(X,2,$L(X)))
Q X
SS ; Show Select/Find Global Arrays
N NN,NC,EX S EX=0 S NN="^TMP(""ICD9"","_$J_")",NC="^TMP(""ICD9"","_$J_","
F S NN=$Q(@NN) Q:'$L(NN)!(NN'[NC) D Q:EX>20
. W !,NN,"=",$E(@NN,1,48) S EX=EX+1
S EX=0 S NN="^TMP(""ICD0"","_$J_")",NC="^TMP(""ICD0"","_$J_","
F S NN=$Q(@NN) Q:'$L(NN)!(NN'[NC) D Q:EX>20
. W !,NN,"=",$E(@NN,1,48) S EX=EX+1
Q
ICDEXLK4 ;SLC/KER - ICD Extractor - Lookup, Text ;04/21/2014
+1 ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
+2 ;
+3 ; Global Variables
+4 ; ^TMP(SUB,$J SACC 2.3.2.5.1
+5 ;
+6 ; External References
+7 ; $$LOW^XLFSTR ICR 10104
+8 ; $$UP^XLFSTR ICR 10104
+9 ;
+10 ; Local Variables Newed or Killed by calling application
+11 ; DIC(0) Fileman Lookup Parameters
+12 ;
+13 ; Local Variables Newed or Killed Elsewhere
+14 ; ICDBYCD Sort by Code
+15 ; CDT Code Set Date
+16 ; OUT Format of display
+17 ; SYS Coding System
+18 ; VER Versioned Lookup
+19 ; SUB ^TMP Subscript
+20 ; SYS Coding System
+21 ;
TXT ; Lookup by Text (Requires TXT and ROOT)
+1 IF $DATA(ICDBYCD)
QUIT
IF '$LENGTH($GET(TXT))
QUIT
IF '$LENGTH($GET(ROOT))
QUIT
IF $LENGTH(TXT)'>1
QUIT
IF $GET(DIC(0))["B"
QUIT
+2 SET CDT=$$CDT^ICDEXLK3($GET(CDT))
NEW PARS,ORG,CNT,PRV,EROOT,KEY,LOOK,EXACT,ABBR,PRIME
+3 IF '$LENGTH($GET(SUB))
SET SUB=$TRANSLATE(ROOT,"^(,","")
+4 SET LOOK=TXT
SET PRV=+($GET(^TMP(SUB,$JOB,"SEL",0)))
SET (EXACT,ABBR)=0
+5 SET CNT=0
SET ORG=$$UP^XLFSTR($GET(TXT))
KILL PARS
DO TOKEN^ICDTOKN(TXT,ROOT,$GET(SYS),.PARS)
+6 SET NUM=$ORDER(PARS(0))
SET (PRIME,KEY)=$GET(PARS(+NUM))
IF +($GET(PARS(+NUM,"A")))>0
SET ABBR=1
+7 IF NUM>0
KILL PARS(+NUM)
IF NUM>0&($GET(PARS(0))>0)
SET PARS(0)=$GET(PARS(0))-1
IF $LENGTH(KEY)'>1
QUIT
+8 SET EROOT=ROOT_"""D"","
IF +($GET(SYS))>0&($DATA(@(ROOT_"""AD"","_+($GET(SYS))_")")))
SET EROOT=ROOT_"""AD"","_+($GET(SYS))_","
+9 SET EXACT=0
IF $ORDER(PARS(0))'>0
IF $LENGTH(PRIME)
IF $DATA(@(EROOT_""""_PRIME_""")"))
SET EXACT=1
+10 IF EXACT>0!(ABBR>0)
Begin DoDot:1
+11 NEW ORD,STR,TKN
SET STR=PRIME
FOR TKN=STR,(STR_"S"),(STR_"ES")
Begin DoDot:2
+12 SET ORD=TKN
IF $DATA(@(EROOT_""""_ORD_""")"))
DO TXT2
End DoDot:2
End DoDot:1
+13 IF EXACT'>0&(ABBR'>0)
Begin DoDot:1
+14 NEW ORD,STR,TKN
SET STR=PRIME
FOR TKN=STR,(STR_"S"),(STR_"ES")
Begin DoDot:2
+15 SET ORD=$EXTRACT(TKN,1,($LENGTH(TKN)-1))_$CHAR(($ASCII($EXTRACT(TKN,$LENGTH(TKN)))-1))_"~"
+16 FOR
SET ORD=$ORDER(@(EROOT_""""_ORD_""")"))
IF '$$ISORD^ICDEXLK3
QUIT
DO TXT2
End DoDot:2
End DoDot:1
+17 IF $DATA(^TMP(SUB,$JOB,"FND"))
DO SEL^ICDEXLK5(ROOT,0)
+18 QUIT
TXT2 ; Lookup by Text (loop)
+1 NEW IEN
SET IEN=0
FOR
SET IEN=$ORDER(@(EROOT_""""_ORD_""","_+IEN_")"))
IF +IEN'>0
QUIT
Begin DoDot:1
+2 NEW OK,NUM,TDT,TIE,TXT,KEY,VDT
SET VDT=+CDT+.000001
+3 SET TDT=$ORDER(@(EROOT_""""_ORD_""","_+IEN_","_VDT_")"),-1)
+4 IF +($GET(VER))'>0
IF TDT'?7N
Begin DoDot:2
+5 SET TDT=$ORDER(@(EROOT_""""_ORD_""","_+IEN_","_(+CDT-.000001)_")"))
End DoDot:2
+6 IF TDT'?7N
QUIT
SET TIE=$ORDER(@(EROOT_""""_ORD_""","_+IEN_","_+TDT_",0)"))
+7 SET TXT=$$UP^XLFSTR($GET(@(ROOT_+IEN_",68,"_+TIE_",1)")))
+8 IF $GET(DIC(0))'["A"
IF $GET(DIC(0))["O"
Begin DoDot:2
+9 IF CNT>1
QUIT
IF ORG=TXT
DO FND^ICDEXLK5(ROOT,IEN,CDT,$GET(SYS),$GET(VER),0,$GET(OUT))
SET CNT=CNT+1
End DoDot:2
QUIT
+10 SET OK=1
SET NUM=0
+11 FOR
SET NUM=$ORDER(PARS(NUM))
IF +NUM'>0
QUIT
Begin DoDot:2
+12 NEW EXACT,PR,OR,SP,IN,AB
SET PR=$GET(PARS(NUM))
SET AB=+($GET(PARS(+NUM,"A")))
+13 IF AB'>0
SET IN=$$IN(TXT,PR)
SET SP=$$SI(ROOT,+IEN,+TIE,PR)
+14 IF AB>0
SET IN=$$EX(TXT,PR)
SET SP=$$SE(ROOT,+IEN,+TIE,PR)
+15 IF IN'>0&(SP'>0)
SET OK=0
End DoDot:2
+16 IF +OK>0
DO FND^ICDEXLK5(ROOT,IEN,CDT,$GET(SYS),$GET(VER),0,$GET(OUT))
End DoDot:1
+17 QUIT
+18 ;
+19 ; Miscellaneous
SE(RT,IE,TI,X) ; Supplemental Word (exact match exist)
+1 NEW FIND,IIEN,PLUR,TEXT,ROOT,TIEN
+2 SET FIND=$$UP^XLFSTR($GET(X))
IF '$LENGTH(FIND)
QUIT 0
+3 SET ROOT=$$ROOT^ICDEX($GET(RT))
IF '$LENGTH(ROOT)
QUIT 0
+4 SET IIEN=+($GET(IE))
SET TIEN=+($GET(TI))
+5 SET TEXT=$$UP^XLFSTR($GET(@(ROOT_+IIEN_",68,"_+TIEN_",1)")))
IF '$LENGTH(TEXT)
QUIT 0
+6 IF '$DATA(@(ROOT_+IIEN_",68,"_+TIEN_",2,""B"","""_FIND_""")"))
QUIT 0
+7 SET PLUR=$$EX(TEXT,(FIND_"S"))
IF PLUR>0
QUIT 0
+8 QUIT 1
SI(RT,IE,TI,X) ; Supplemental Word (match exist)
+1 NEW FIND,IIEN,PLUR,TEXT,NEXT,TIEN,ORDR,ROOT
+2 SET FIND=$$UP^XLFSTR($GET(X))
IF '$LENGTH(FIND)
QUIT 0
+3 SET ROOT=$$ROOT^ICDEX($GET(RT))
IF '$LENGTH(ROOT)
QUIT 0
+4 SET IIEN=+($GET(IE))
SET TIEN=+($GET(TI))
+5 IF FIND?1N.N
SET ORDR=FIND-.00000000000000009
IF FIND'?1N.N
Begin DoDot:1
+6 IF $LENGTH(FIND)=1
SET ORDR=$CHAR($ASCII(FIND)-1)_"~"
+7 IF $LENGTH(FIND)>1
SET ORDR=$EXTRACT(FIND,1,($LENGTH(FIND)-1))_$CHAR($ASCII($EXTRACT(FIND,$LENGTH(FIND)))-1)_"~"
End DoDot:1
+8 SET NEXT=$ORDER(@(ROOT_+IIEN_",68,"_+TIEN_",2,""B"","""_ORDR_""")"))
+9 IF $EXTRACT(NEXT,1,$LENGTH(FIND))=FIND
QUIT 1
+10 QUIT 0
EX(X,Y) ; String Y is exactly in X
+1 NEW CON,FIND,TEXT,EXACT
SET TEXT=$GET(X)
SET FIND=$GET(Y)
SET EXACT=1
+2 SET CON=$$CON(TEXT,FIND)
SET X=+($GET(CON))
+3 QUIT X
IN(X,Y) ; String Y is contained in X
+1 NEW CON,FIND,TEXT
SET TEXT=$GET(X)
SET FIND=$GET(Y)
+2 SET CON=$$CON(TEXT,FIND)
SET X=+($GET(CON))
+3 QUIT X
CON(X,Y) ; Text X Contains String Y
+1 NEW FIND,FOUND,TEXT,LEAD,TRAIL,STR
+2 SET TEXT=$$UP^XLFSTR($GET(X))
SET FIND=$$UP^XLFSTR($GET(Y))
+3 IF '$LENGTH(TEXT)
QUIT 0
IF '$LENGTH(FIND)
QUIT 0
IF $LENGTH(FIND)>$LENGTH(TEXT)
QUIT 0
+4 SET (X,FOUND)=0
+5 IF +($GET(EXACT))>0
SET X=0
Begin DoDot:1
+6 FOR TRAIL=" ","-","(","<","{","[",","
Begin DoDot:2
+7 NEW STR
SET STR=FIND_TRAIL
+8 IF $EXTRACT(TEXT,1,$LENGTH(STR))=STR
SET FOUND=1
+9 IF FOUND>0
SET X=FOUND
End DoDot:2
IF FOUND>0
QUIT
+10 IF FOUND>0
QUIT
FOR LEAD=" ","-","(","<","{","[",","
Begin DoDot:2
+11 NEW STR
SET STR=LEAD_FIND
+12 IF $EXTRACT(TEXT,($LENGTH(TEXT)-$LENGTH(STR)),$LENGTH(TEXT))=STR
SET FOUND=1
+13 IF FOUND>0
SET X=FOUND
End DoDot:2
IF FOUND>0
QUIT
+14 IF FOUND>0
QUIT
FOR LEAD=" ","-","(","<","{","[",","
Begin DoDot:2
+15 FOR TRAIL=" ","-",")",">","}","]",","
Begin DoDot:3
+16 NEW STR
SET STR=LEAD_FIND_TRAIL
IF TEXT[STR
SET FOUND=1
+17 IF FOUND>0
SET X=FOUND
End DoDot:3
IF FOUND>0
QUIT
End DoDot:2
IF FOUND>0
QUIT
+18 IF FOUND>0
SET X=FOUND
End DoDot:1
QUIT X
+19 IF $EXTRACT(TEXT,1,$LENGTH(FIND))=FIND
SET FOUND=1
+20 IF FOUND>0
SET X=FOUND
IF FOUND>0
QUIT X
+21 FOR LEAD=" ","-","(","<","{","[",","
Begin DoDot:1
+22 NEW STR
SET STR=LEAD_FIND
IF TEXT[STR
SET FOUND=1
+23 IF FOUND>0
SET X=FOUND
End DoDot:1
IF FOUND>0
QUIT
+24 IF FOUND>0
QUIT X
FOR LEAD=" ","-","(","<","{","[",","
Begin DoDot:1
+25 NEW TRAIL
FOR TRAIL=" ","-",")",">","}","]",","
Begin DoDot:2
+26 NEW STR
SET STR=LEAD_FIND_TRAIL
IF TEXT[STR
SET FOUND=1
+27 IF FOUND>0
SET X=FOUND
End DoDot:2
IF FOUND>0
QUIT
End DoDot:1
IF FOUND>0
QUIT
+28 IF FOUND>0
SET X=FOUND
+29 QUIT X
LC(X) ; Leading Character
+1 SET X=$GET(X)
SET X=$$UP^XLFSTR($EXTRACT(X,1))_$$LOW^XLFSTR($EXTRACT(X,2,$LENGTH(X)))
+2 QUIT X
SS ; Show Select/Find Global Arrays
+1 NEW NN,NC,EX
SET EX=0
SET NN="^TMP(""ICD9"","_$JOB_")"
SET NC="^TMP(""ICD9"","_$JOB_","
+2 FOR
SET NN=$QUERY(@NN)
IF '$LENGTH(NN)!(NN'[NC)
QUIT
Begin DoDot:1
+3 WRITE !,NN,"=",$EXTRACT(@NN,1,48)
SET EX=EX+1
End DoDot:1
IF EX>20
QUIT
+4 SET EX=0
SET NN="^TMP(""ICD0"","_$JOB_")"
SET NC="^TMP(""ICD0"","_$JOB_","
+5 FOR
SET NN=$QUERY(@NN)
IF '$LENGTH(NN)!(NN'[NC)
QUIT
Begin DoDot:1
+6 WRITE !,NN,"=",$EXTRACT(@NN,1,48)
SET EX=EX+1
End DoDot:1
IF EX>20
QUIT
+7 QUIT
