ICDEXLK4 ;SLC/KER - ICD Extractor - Lookup, Search Text ;12/19/2014
;;18.0;DRG Grouper;**57,67,82**;Oct 20, 2000;Build 21
;
; 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)
N I,TMP S NUM=0,(PRIME,KEY,TMP)="",I=0 F S I=$O(PARS(I)) Q:+I'>0 D
. N TX S TX=$G(PARS(I)) S:$L(TX)>$L(TMP) TMP=TX,NUM=I
S:+NUM>0&($L(TMP)) (PRIME,KEY)=TMP S:+($G(PARS(+NUM,"A")))>0 ABBR=1
I NUM'>0 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(^TMP(SUB,$J,"FND"))) D
. N I S I=0 F S I=$O(PARS(+I)) Q:+I'>0 K PARS(+I,"A")
. 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 CNTL,IIEN,PLUR,TEXT,ROOT,TIEN
S CNTL=$$UP^XLFSTR($G(X)) Q:'$L(CNTL) 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"","""_CNTL_""")")) 0
S PLUR=$$EX(TEXT,(CNTL_"S")) Q:PLUR>0 0
Q 1
SI(RT,IE,TI,X) ; Supplemental Word (match exist)
N CNTL,IIEN,PLUR,TEXT,NEXT,TIEN,ORDR,ROOT
S CNTL=$$UP^XLFSTR($G(X)) Q:'$L(CNTL) 0
S ROOT=$$ROOT^ICDEX($G(RT)) Q:'$L(ROOT) 0
S IIEN=+($G(IE)),TIEN=+($G(TI))
S:CNTL?1N.N ORDR=CNTL-.00000000000000009 I CNTL'?1N.N D
. S:$L(CNTL)=1 ORDR=$C($A(CNTL)-1)_"~"
. S:$L(CNTL)>1 ORDR=$E(CNTL,1,($L(CNTL)-1))_$C($A($E(CNTL,$L(CNTL)))-1)_"~"
S NEXT=$O(@(ROOT_+IIEN_",68,"_+TIEN_",2,""B"","""_ORDR_""")"))
Q:$E(NEXT,1,$L(CNTL))=CNTL 1
Q 0
EX(X,Y) ; String Y is exactly in X
N CON,CNTL,TEXT,EXACT S TEXT=$G(X),CNTL=$G(Y),EXACT=1
S CON=$$CON(TEXT,CNTL) S X=+($G(CON))
Q X
IN(X,Y) ; String Y is contained in X
N CON,CNTL,TEXT S TEXT=$G(X),CNTL=$G(Y)
S CON=$$CON(TEXT,CNTL) S X=+($G(CON))
Q X
CON(X,Y) ; Text X Contains String Y
N CNTL,CONT,TEXT,LEAD,TRAIL,STR
S TEXT=$$UP^XLFSTR($G(X)),CNTL=$$UP^XLFSTR($G(Y))
Q:'$L(TEXT) 0 Q:'$L(CNTL) 0 Q:$L(CNTL)>$L(TEXT) 0
S (X,CONT)=0 I +($G(EXACT))>0 S X=0 D Q X
. F TRAIL=" ","/","-","(","<","{","[","," D Q:CONT>0
. . N STR S STR=CNTL_TRAIL S:$E(TEXT,1,$L(STR))=STR CONT=1 S:CONT>0 X=CONT
. Q:CONT>0 F LEAD=" ","/","-","(","<","{","[","," D Q:CONT>0
. . N STR S STR=LEAD_CNTL S:$E(TEXT,($L(TEXT)-$L(STR)),$L(TEXT))=STR CONT=1 S:CONT>0 X=CONT
. Q:CONT>0 F LEAD=" ","/","-","(","<","{","[","," D Q:CONT>0
. . F TRAIL=" ","-",")",">","}","]","," D Q:CONT>0
. . . N STR S STR=LEAD_CNTL_TRAIL S:TEXT[STR CONT=1 S:CONT>0 X=CONT
. S:CONT>0 X=CONT
S:$E(TEXT,1,$L(CNTL))=CNTL CONT=1
S:CONT>0 X=CONT Q:CONT>0 X
F LEAD=" ","/","-","(","<","{","[","," D Q:CONT>0
. N STR S STR=LEAD_CNTL S:TEXT[STR CONT=1 S:CONT>0 X=CONT
Q:CONT>0 X F LEAD=" ","/","-","(","<","{","[","," D Q:CONT>0
. N TRAIL F TRAIL=" ","-",")",">","}","]","," D Q:CONT>0
. . N STR S STR=LEAD_CNTL_TRAIL S:TEXT[STR CONT=1 S:CONT>0 X=CONT
S:CONT>0 X=CONT
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDEXLK4 5870 printed Apr 09, 2024@20:56:11 Page 2
ICDEXLK4 ;SLC/KER - ICD Extractor - Lookup, Search Text ;12/19/2014
+1 ;;18.0;DRG Grouper;**57,67,82**;Oct 20, 2000;Build 21
+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 NEW I,TMP
SET NUM=0
SET (PRIME,KEY,TMP)=""
SET I=0
FOR
SET I=$ORDER(PARS(I))
if +I'>0
QUIT
Begin DoDot:1
+7 NEW TX
SET TX=$GET(PARS(I))
if $LENGTH(TX)>$LENGTH(TMP)
SET TMP=TX
SET NUM=I
End DoDot:1
+8 if +NUM>0&($LENGTH(TMP))
SET (PRIME,KEY)=TMP
if +($GET(PARS(+NUM,"A")))>0
SET ABBR=1
+9 IF NUM'>0
SET NUM=$ORDER(PARS(0))
SET (PRIME,KEY)=$GET(PARS(+NUM))
if +($GET(PARS(+NUM,"A")))>0
SET ABBR=1
+10 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
+11 SET EROOT=ROOT_"""D"","
if +($GET(SYS))>0&($DATA(@(ROOT_"""AD"","_+($GET(SYS))_")")))
SET EROOT=ROOT_"""AD"","_+($GET(SYS))_","
+12 SET EXACT=0
IF $ORDER(PARS(0))'>0
IF $LENGTH(PRIME)
IF $DATA(@(EROOT_""""_PRIME_""")"))
SET EXACT=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=TKN
IF $DATA(@(EROOT_""""_ORD_""")"))
DO TXT2
End DoDot:2
End DoDot:1
+16 IF (EXACT'>0&(ABBR'>0))!('$DATA(^TMP(SUB,$JOB,"FND")))
Begin DoDot:1
+17 NEW I
SET I=0
FOR
SET I=$ORDER(PARS(+I))
if +I'>0
QUIT
KILL PARS(+I,"A")
+18 NEW ORD,STR,TKN
SET STR=PRIME
FOR TKN=STR,(STR_"S"),(STR_"ES")
Begin DoDot:2
+19 SET ORD=$EXTRACT(TKN,1,($LENGTH(TKN)-1))_$CHAR(($ASCII($EXTRACT(TKN,$LENGTH(TKN)))-1))_"~"
+20 FOR
SET ORD=$ORDER(@(EROOT_""""_ORD_""")"))
if '$$ISORD^ICDEXLK3
QUIT
DO TXT2
End DoDot:2
End DoDot:1
+21 if $DATA(^TMP(SUB,$JOB,"FND"))
DO SEL^ICDEXLK5(ROOT,0)
+22 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 CNTL,IIEN,PLUR,TEXT,ROOT,TIEN
+2 SET CNTL=$$UP^XLFSTR($GET(X))
if '$LENGTH(CNTL)
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"","""_CNTL_""")"))
QUIT 0
+7 SET PLUR=$$EX(TEXT,(CNTL_"S"))
if PLUR>0
QUIT 0
+8 QUIT 1
SI(RT,IE,TI,X) ; Supplemental Word (match exist)
+1 NEW CNTL,IIEN,PLUR,TEXT,NEXT,TIEN,ORDR,ROOT
+2 SET CNTL=$$UP^XLFSTR($GET(X))
if '$LENGTH(CNTL)
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 CNTL?1N.N
SET ORDR=CNTL-.00000000000000009
IF CNTL'?1N.N
Begin DoDot:1
+6 if $LENGTH(CNTL)=1
SET ORDR=$CHAR($ASCII(CNTL)-1)_"~"
+7 if $LENGTH(CNTL)>1
SET ORDR=$EXTRACT(CNTL,1,($LENGTH(CNTL)-1))_$CHAR($ASCII($EXTRACT(CNTL,$LENGTH(CNTL)))-1)_"~"
End DoDot:1
+8 SET NEXT=$ORDER(@(ROOT_+IIEN_",68,"_+TIEN_",2,""B"","""_ORDR_""")"))
+9 if $EXTRACT(NEXT,1,$LENGTH(CNTL))=CNTL
QUIT 1
+10 QUIT 0
EX(X,Y) ; String Y is exactly in X
+1 NEW CON,CNTL,TEXT,EXACT
SET TEXT=$GET(X)
SET CNTL=$GET(Y)
SET EXACT=1
+2 SET CON=$$CON(TEXT,CNTL)
SET X=+($GET(CON))
+3 QUIT X
IN(X,Y) ; String Y is contained in X
+1 NEW CON,CNTL,TEXT
SET TEXT=$GET(X)
SET CNTL=$GET(Y)
+2 SET CON=$$CON(TEXT,CNTL)
SET X=+($GET(CON))
+3 QUIT X
CON(X,Y) ; Text X Contains String Y
+1 NEW CNTL,CONT,TEXT,LEAD,TRAIL,STR
+2 SET TEXT=$$UP^XLFSTR($GET(X))
SET CNTL=$$UP^XLFSTR($GET(Y))
+3 if '$LENGTH(TEXT)
QUIT 0
if '$LENGTH(CNTL)
QUIT 0
if $LENGTH(CNTL)>$LENGTH(TEXT)
QUIT 0
+4 SET (X,CONT)=0
IF +($GET(EXACT))>0
SET X=0
Begin DoDot:1
+5 FOR TRAIL=" ","/","-","(","<","{","[",","
Begin DoDot:2
+6 NEW STR
SET STR=CNTL_TRAIL
if $EXTRACT(TEXT,1,$LENGTH(STR))=STR
SET CONT=1
if CONT>0
SET X=CONT
End DoDot:2
if CONT>0
QUIT
+7 if CONT>0
QUIT
FOR LEAD=" ","/","-","(","<","{","[",","
Begin DoDot:2
+8 NEW STR
SET STR=LEAD_CNTL
if $EXTRACT(TEXT,($LENGTH(TEXT)-$LENGTH(STR)),$LENGTH(TEXT))=STR
SET CONT=1
if CONT>0
SET X=CONT
End DoDot:2
if CONT>0
QUIT
+9 if CONT>0
QUIT
FOR LEAD=" ","/","-","(","<","{","[",","
Begin DoDot:2
+10 FOR TRAIL=" ","-",")",">","}","]",","
Begin DoDot:3
+11 NEW STR
SET STR=LEAD_CNTL_TRAIL
if TEXT[STR
SET CONT=1
if CONT>0
SET X=CONT
End DoDot:3
if CONT>0
QUIT
End DoDot:2
if CONT>0
QUIT
+12 if CONT>0
SET X=CONT
End DoDot:1
QUIT X
+13 if $EXTRACT(TEXT,1,$LENGTH(CNTL))=CNTL
SET CONT=1
+14 if CONT>0
SET X=CONT
if CONT>0
QUIT X
+15 FOR LEAD=" ","/","-","(","<","{","[",","
Begin DoDot:1
+16 NEW STR
SET STR=LEAD_CNTL
if TEXT[STR
SET CONT=1
if CONT>0
SET X=CONT
End DoDot:1
if CONT>0
QUIT
+17 if CONT>0
QUIT X
FOR LEAD=" ","/","-","(","<","{","[",","
Begin DoDot:1
+18 NEW TRAIL
FOR TRAIL=" ","-",")",">","}","]",","
Begin DoDot:2
+19 NEW STR
SET STR=LEAD_CNTL_TRAIL
if TEXT[STR
SET CONT=1
if CONT>0
SET X=CONT
End DoDot:2
if CONT>0
QUIT
End DoDot:1
if CONT>0
QUIT
+20 if CONT>0
SET X=CONT
+21 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
