- 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
