LEXQIP2 ;ISL/KER - Query - ICD Procedure - Extract ;05/23/2017
;;2.0;LEXICON UTILITY;**62,80,86,103**;Sep 23, 1996;Build 2
;
; Global Variables
; None
;
; External References
; $$MOR^ICDEX ICR 5747
; MD^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Documented Integration Agreements
;
; Local Variables NEWed or KILLed in LEXQIP
; LEXINT Internal display flag
; LEXIIEN Include IENs flag
;
Q
LX(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Lexicon Expression
;
; LEX=# of Lines
; LEX(0)=External Date of Expression
; LEX(#)=Expression
;
N LEXEF,LEXEVDT,LEXLEX,LEXEE,LEXFA,LEXI,LEXIA,LEXIEN,LEXAIEN,LEXLEF,LEXLHS,LEXLST,LEXM,LEXN0
N LEXPF,LEXSAB,LEXSIEN,LEXSO,LEXTSRC,LEXT,LEXTE,LEXTEXP,LEXTEF,LEXTEFE,LEXTS,LEXTSTA,LEXVTMP
S LEXIEN=$G(X) Q:+LEXIEN'>0 S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT S LEXSTA=+($G(LEXSTA))
S LEXEVDT=$$SD^LEXQM(LEXVDT),LEXLEN=+($G(LEXLEN)) S:+LEXLEN'>0 LEXLEN=62
Q:'$L(LEXEVDT) S LEXSO=$$CODEC^ICDEX(80.1,+LEXIEN)
Q:'$L(LEXSO) S LEXFA=$$FA(+LEXIEN),LEXM="",LEXIA=$$IA(LEXVDT)
S LEXTSRC=$$SAB^ICDEX($$CSI^ICDEX(80.1,+LEXIEN)) S:$L(LEXTSRC)'=3 LEXTSRC="" S LEXTSTA=$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,LEXTSRC)
S LEXTS=$P($G(LEXTSTA),"^",2),LEXTE=+($G(^LEX(757.02,+LEXTS,0))),LEXTEXP=$G(^LEX(757.01,+LEXTE,0))
S (LEXTEF,LEXTEFE)="",LEXEF="" F S LEXEF=$O(^LEX(757.02,+LEXTS,4,"B",LEXEF)) Q:+LEXEF'>0 D
. N LEXH S LEXH=0 F S LEXH=$O(^LEX(757.02,+LEXTS,4,"B",LEXEF,LEXH)) Q:+LEXH'>0 D
. . S:$P($G(^LEX(757.02,+LEXTS,4,+LEXH,0)),"^",2)>0&(LEXEF?7N) LEXTEF=LEXEF
. . S:LEXTEF?7N LEXTEFE=$$SD^LEXQM(LEXTEF)
I LEXSTA'>0,$L($G(LEXTEXP)),$G(LEXTEF)?7N,$L($G(LEXTEFE)) D Q
. K LEX N LEXT,LEXM,LEXI S LEXT(1)=LEXTEXP S:$D(LEXIIEN) LEXT(1)=$G(LEXT(1))_" (IEN "_LEXTE_")"
. D PR^LEXU(.LEXT,(LEXLEN-7)) S LEXI=0 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 S:$L($G(LEXT(LEXI))) LEX(+LEXI)=$G(LEXT(LEXI))
. S LEX=+($O(LEX(" "),-1)) S LEX(0)=LEXTEFE
S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN)) Q:+LEXSIEN'>0 D
. N LEXN0 S LEXN0=$G(^LEX(757.02,+LEXSIEN,0)),LEXSAB=$P(LEXN0,"^",3)
. Q:"^2^31^"'[("^"_LEXSAB_"^") S LEXPF=+($P(LEXN0,"^",5)) S LEXLEF=$O(^LEX(757.02,+LEXSIEN,4,"B",(LEXVDT+.99999)),-1)
. I LEXLEF?7N D
. . S LEXLHS=$O(^LEX(757.02,+LEXSIEN,4,"B",+LEXLEF," "),-1) I +LEXLHS>0 D
. . . S LEXLST=$G(^LEX(757.02,+LEXSIEN,4,+LEXLHS,0)),LEXLST=$P(LEXLST,"^",2)
. . . S:LEXLST>0 LEXVTMP(+LEXPF,LEXSIEN)=+LEXN0_"^"_LEXLEF
S (LEXLEX,LEXEF)="",LEXSIEN=$O(LEXVTMP(1,0)),LEXLEX=+($G(LEXVTMP(1,+LEXSIEN))),LEXEF=$P($G(LEXVTMP(1,+LEXSIEN)),"^",2)
S:+LEXSIEN'>0!(+LEXLEX'>0) LEXSIEN=$O(LEXVTMP(0,0)),LEXLEX=+($G(LEXVTMP(0,+LEXSIEN))),LEXEF=$P($G(LEXVTMP(0,+LEXSIEN)),"^",2)
K LEX I +LEXLEX>0,$L($G(^LEX(757.01,+LEXLEX,0))),$L(LEXEF),LEXEF?7N D Q
. S LEXAIEN=LEXLEX K LEX N LEXT,LEXM,LEXI S LEXT(1)=$G(^LEX(757.01,+LEXLEX,0))
. S:$D(LEXIIEN) LEXT(1)=$G(LEXT(1))_" (IEN "_LEXAIEN_")" D PR^LEXU(.LEXT,(LEXLEN-7))
. S LEXI=0 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 S:$L($G(LEXT(LEXI))) LEX(+LEXI)=$G(LEXT(LEXI))
. S LEX=+($O(LEX(" "),-1)) S LEXEE=$$SD^LEXQM(LEXEF) S LEX(0)=LEXEE
Q
FA(X) ; First Activation
N LEXFA,LEXH,LEXI,LEXIEN,LEXSO,LEXSY
S LEXIEN=+($G(X)) S X="",LEXSO=$$CODEC^ICDEX(80,+LEXIEN),LEXSY=$$CSI^ICDEX(80,+LEXIEN)
K LEXH S X=$$HIST^ICDEX(LEXSO,.LEXH,LEXSY) S LEXFA="",LEXI=0
F S LEXI=$O(LEXH(LEXI)) Q:+LEXI'>0!($L(LEXFA)) S:+($G(LEXH(LEXI)))>0&(LEXI?7N) LEXFA=LEXI Q:$L(LEXFA)
S X=LEXFA
Q X
IA(X,Y) ; Inaccurate
N LEXBRD,LEXVDT,LEXIEN,LEXSYS S LEXVDT=+($G(X)),LEXIEN=+($G(Y)) Q:+LEXIEN'>0 0
S LEXSYS=$$CSI^ICDEX(80,+LEXIEN) Q:+LEXSYS'>0 0 S:'$L(LEXVDT) LEXVDT=$$DT^XLFDT
S:LEXVDT#10000=0 LEXVDT=LEXVDT+101 S:LEXVDT#100=0 LEXVDT=LEXVDT+1
S LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSYS) S X=$S(LEXVDT<LEXBRD:1,1:0)
Q X
MDCDRG(X,LEXCDT,LEX,LEXLEN) ; Major Diagnostic Category/DRG
Q
N LEXAI,LEXC,LEXDA,LEXDI,LEXEF,LEXFY,LEXI,LEXIEN,LEXL,LEXLC,LEXMDCC,LEXMDCS,LEXME,LEXMI,LEXN,LEXT
N LEXT1,LEXT2,LEXUD,LEXUM,LEXVDT S LEXVDT=+($G(LEXCDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT K LEXUM,LEXUD,LEX
S LEXLC=0,LEXIEN=+($G(X)),LEXCDT=$G(LEXCDT),LEXLEN=+($G(LEXLEN)) S:+LEXLEN'>0 LEXLEN=62 Q:LEXCDT'?7N
D MD^ICDEX(80.1,+LEXIEN,$G(LEXCDT),.LEXMDCS,"IE")
S LEXMDCC=0,LEXMI=0,(LEXEF,LEXFY)=$O(LEXMDCS(0)) Q:LEXFY'>0
S LEXMI=0 F S LEXMI=$O(LEXMDCS(LEXFY,"E",LEXMI)) Q:+LEXMI'>0 D
. N LEXME,LEXMEI S LEXME=$G(LEXMDCS(LEXFY,"E",LEXMI)) Q:'$L(LEXME)
. S LEXMEI=$O(^ICM("B",LEXME,0)) Q:+LEXMEI'>0
. S:$D(LEXIIEN) LEXME=LEXME_" (IEN "_+LEXMEI_")"
. S LEXI=$O(LEX(" "),-1)+1,LEX(LEXI)=LEXME
. S LEXDI=0 F S LEXDI=$O(LEXMDCS(LEXFY,"E",LEXMI,LEXDI)) Q:+LEXDI'>0 D
. . K LEXDA S LEXDA(1)=$G(LEXMDCS(LEXFY,"E",LEXMI,LEXDI))
. . D PR^LEXU(.LEXDA,(LEXLEN-14)) S LEXT1=" DRG "_LEXDI
. . S LEXT1=LEXT1_$J(" ",(14-$L(LEXT1))),LEXT2=$J(" ",14)
. . S (LEXC,LEXI)=0 F S LEXI=$O(LEXDA(LEXI)) Q:+LEXI'>0 D
. . . N LEXT,LEXL,LEXN,LEXAI S LEXT=$$TM^LEXQM($G(LEXDA(LEXI)))
. . . Q:'$L(LEXT) S LEXC=LEXC+1 S:LEXC=1 LEXL=LEXT1_LEXT S:LEXC>1 LEXL=LEXT2_LEXT
. . . S LEXAI=$O(LEX(" "),-1)+1,LEX(LEXAI)=LEXL
S:LEXEF?7N&($L(LEX(1))) LEX(0)=$$SD^LEXQM(LEXEF) S LEX=+($O(LEX(" "),-1))
Q
MAJ(X,LEX) ; Major O.R. Procedures
N LEXC,LEXCHR,LEXHDR,LEXI,LEXI1,LEXI2,LEXIDI,LEXIEN,LEXPC,LEXSTR,LEXT S LEXIEN=+($G(X)) Q:+LEXIEN'>0
S LEXSTR=$$MOR^ICDEX(+LEXIEN) Q:'$L(LEXSTR) D OR(LEXSTR,.LEX)
Q
OR(X,LEX) ; O.R. Procedures
K LEX N LEXC,LEXCHR,LEXHDR,LEXI,LEXI1,LEXI2,LEXIDI,LEXPC,LEXSTR,LEXT S LEXSTR=$G(X) Q:'$L(LEXSTR)
S LEXHDR="Major O.R. ID",LEXPC=0,LEXCHR="" F LEXC=1:1 Q:'$L($E(LEXSTR,LEXC)) D
. S LEXCHR=$E(LEXSTR,LEXC) Q:LEXCHR="" F LEXI=1:1 S LEXIDI=$T(MID+LEXI),LEXIDI=$P(LEXIDI,";;",2) Q:LEXIDI="EXIT" D
. . S LEXI1=$$TM^LEXQM($P(LEXIDI,"=")),LEXI2=$$TM^LEXQM($P(LEXIDI,"=",2)) Q:$L(LEXI1)'=1 Q:LEXI1'=LEXCHR Q:'$L(LEXI2)
. . S LEXT=LEXI2 S:$D(LEXINT) LEXT=LEXT_$J(" ",(22-$L(LEXT)))_"("_LEXI1_")" S LEXPC=LEXPC+1,LEX(1,LEXPC)=$$UP^XLFSTR(LEXT)
S:+($O(LEX(1," "),-1))>0 LEX(0)=$$UP^XLFSTR(LEXHDR),LEX(1)=$$UP^XLFSTR(LEXSTR),LEX=+($O(LEX(1," "),-1))
Q
MID ; Major O.R. Procedures Text
;;1=Bowel
;;2=Chest
;;3=Lymphoma/Leukemia
;;4=Joint
;;5=Pancreas/Liver
;;6=Pelvic
;;7=Shoulder/Elbow
;;8=Thumb/Joint
;;9=Head/Neck
;;A=Cardio
;;M=Musculoskeletal
;;EXIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQIP2 6462 printed Apr 09, 2024@21:10:46 Page 2
LEXQIP2 ;ISL/KER - Query - ICD Procedure - Extract ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**62,80,86,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; None
+5 ;
+6 ; External References
+7 ; $$MOR^ICDEX ICR 5747
+8 ; MD^ICDEX ICR 5747
+9 ; $$DT^XLFDT ICR 10103
+10 ; $$UP^XLFSTR ICR 10104
+11 ;
+12 ; Documented Integration Agreements
+13 ;
+14 ; Local Variables NEWed or KILLed in LEXQIP
+15 ; LEXINT Internal display flag
+16 ; LEXIIEN Include IENs flag
+17 ;
+18 QUIT
LX(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Lexicon Expression
+1 ;
+2 ; LEX=# of Lines
+3 ; LEX(0)=External Date of Expression
+4 ; LEX(#)=Expression
+5 ;
+6 NEW LEXEF,LEXEVDT,LEXLEX,LEXEE,LEXFA,LEXI,LEXIA,LEXIEN,LEXAIEN,LEXLEF,LEXLHS,LEXLST,LEXM,LEXN0
+7 NEW LEXPF,LEXSAB,LEXSIEN,LEXSO,LEXTSRC,LEXT,LEXTE,LEXTEXP,LEXTEF,LEXTEFE,LEXTS,LEXTSTA,LEXVTMP
+8 SET LEXIEN=$GET(X)
if +LEXIEN'>0
QUIT
SET LEXVDT=+($GET(LEXVDT))
if LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
SET LEXSTA=+($GET(LEXSTA))
+9 SET LEXEVDT=$$SD^LEXQM(LEXVDT)
SET LEXLEN=+($GET(LEXLEN))
if +LEXLEN'>0
SET LEXLEN=62
+10 if '$LENGTH(LEXEVDT)
QUIT
SET LEXSO=$$CODEC^ICDEX(80.1,+LEXIEN)
+11 if '$LENGTH(LEXSO)
QUIT
SET LEXFA=$$FA(+LEXIEN)
SET LEXM=""
SET LEXIA=$$IA(LEXVDT)
+12 SET LEXTSRC=$$SAB^ICDEX($$CSI^ICDEX(80.1,+LEXIEN))
if $LENGTH(LEXTSRC)'=3
SET LEXTSRC=""
SET LEXTSTA=$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,LEXTSRC)
+13 SET LEXTS=$PIECE($GET(LEXTSTA),"^",2)
SET LEXTE=+($GET(^LEX(757.02,+LEXTS,0)))
SET LEXTEXP=$GET(^LEX(757.01,+LEXTE,0))
+14 SET (LEXTEF,LEXTEFE)=""
SET LEXEF=""
FOR
SET LEXEF=$ORDER(^LEX(757.02,+LEXTS,4,"B",LEXEF))
if +LEXEF'>0
QUIT
Begin DoDot:1
+15 NEW LEXH
SET LEXH=0
FOR
SET LEXH=$ORDER(^LEX(757.02,+LEXTS,4,"B",LEXEF,LEXH))
if +LEXH'>0
QUIT
Begin DoDot:2
+16 if $PIECE($GET(^LEX(757.02,+LEXTS,4,+LEXH,0)),"^",2)>0&(LEXEF?7N)
SET LEXTEF=LEXEF
+17 if LEXTEF?7N
SET LEXTEFE=$$SD^LEXQM(LEXTEF)
End DoDot:2
End DoDot:1
+18 IF LEXSTA'>0
IF $LENGTH($GET(LEXTEXP))
IF $GET(LEXTEF)?7N
IF $LENGTH($GET(LEXTEFE))
Begin DoDot:1
+19 KILL LEX
NEW LEXT,LEXM,LEXI
SET LEXT(1)=LEXTEXP
if $DATA(LEXIIEN)
SET LEXT(1)=$GET(LEXT(1))_" (IEN "_LEXTE_")"
+20 DO PR^LEXU(.LEXT,(LEXLEN-7))
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXT(LEXI))
if +LEXI'>0
QUIT
if $LENGTH($GET(LEXT(LEXI)))
SET LEX(+LEXI)=$GET(LEXT(LEXI))
+21 SET LEX=+($ORDER(LEX(" "),-1))
SET LEX(0)=LEXTEFE
End DoDot:1
QUIT
+22 SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:1
+23 NEW LEXN0
SET LEXN0=$GET(^LEX(757.02,+LEXSIEN,0))
SET LEXSAB=$PIECE(LEXN0,"^",3)
+24 if "^2^31^"'[("^"_LEXSAB_"^")
QUIT
SET LEXPF=+($PIECE(LEXN0,"^",5))
SET LEXLEF=$ORDER(^LEX(757.02,+LEXSIEN,4,"B",(LEXVDT+.99999)),-1)
+25 IF LEXLEF?7N
Begin DoDot:2
+26 SET LEXLHS=$ORDER(^LEX(757.02,+LEXSIEN,4,"B",+LEXLEF," "),-1)
IF +LEXLHS>0
Begin DoDot:3
+27 SET LEXLST=$GET(^LEX(757.02,+LEXSIEN,4,+LEXLHS,0))
SET LEXLST=$PIECE(LEXLST,"^",2)
+28 if LEXLST>0
SET LEXVTMP(+LEXPF,LEXSIEN)=+LEXN0_"^"_LEXLEF
End DoDot:3
End DoDot:2
End DoDot:1
+29 SET (LEXLEX,LEXEF)=""
SET LEXSIEN=$ORDER(LEXVTMP(1,0))
SET LEXLEX=+($GET(LEXVTMP(1,+LEXSIEN)))
SET LEXEF=$PIECE($GET(LEXVTMP(1,+LEXSIEN)),"^",2)
+30 if +LEXSIEN'>0!(+LEXLEX'>0)
SET LEXSIEN=$ORDER(LEXVTMP(0,0))
SET LEXLEX=+($GET(LEXVTMP(0,+LEXSIEN)))
SET LEXEF=$PIECE($GET(LEXVTMP(0,+LEXSIEN)),"^",2)
+31 KILL LEX
IF +LEXLEX>0
IF $LENGTH($GET(^LEX(757.01,+LEXLEX,0)))
IF $LENGTH(LEXEF)
IF LEXEF?7N
Begin DoDot:1
+32 SET LEXAIEN=LEXLEX
KILL LEX
NEW LEXT,LEXM,LEXI
SET LEXT(1)=$GET(^LEX(757.01,+LEXLEX,0))
+33 if $DATA(LEXIIEN)
SET LEXT(1)=$GET(LEXT(1))_" (IEN "_LEXAIEN_")"
DO PR^LEXU(.LEXT,(LEXLEN-7))
+34 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXT(LEXI))
if +LEXI'>0
QUIT
if $LENGTH($GET(LEXT(LEXI)))
SET LEX(+LEXI)=$GET(LEXT(LEXI))
+35 SET LEX=+($ORDER(LEX(" "),-1))
SET LEXEE=$$SD^LEXQM(LEXEF)
SET LEX(0)=LEXEE
End DoDot:1
QUIT
+36 QUIT
FA(X) ; First Activation
+1 NEW LEXFA,LEXH,LEXI,LEXIEN,LEXSO,LEXSY
+2 SET LEXIEN=+($GET(X))
SET X=""
SET LEXSO=$$CODEC^ICDEX(80,+LEXIEN)
SET LEXSY=$$CSI^ICDEX(80,+LEXIEN)
+3 KILL LEXH
SET X=$$HIST^ICDEX(LEXSO,.LEXH,LEXSY)
SET LEXFA=""
SET LEXI=0
+4 FOR
SET LEXI=$ORDER(LEXH(LEXI))
if +LEXI'>0!($LENGTH(LEXFA))
QUIT
if +($GET(LEXH(LEXI)))>0&(LEXI?7N)
SET LEXFA=LEXI
if $LENGTH(LEXFA)
QUIT
+5 SET X=LEXFA
+6 QUIT X
IA(X,Y) ; Inaccurate
+1 NEW LEXBRD,LEXVDT,LEXIEN,LEXSYS
SET LEXVDT=+($GET(X))
SET LEXIEN=+($GET(Y))
if +LEXIEN'>0
QUIT 0
+2 SET LEXSYS=$$CSI^ICDEX(80,+LEXIEN)
if +LEXSYS'>0
QUIT 0
if '$LENGTH(LEXVDT)
SET LEXVDT=$$DT^XLFDT
+3 if LEXVDT#10000=0
SET LEXVDT=LEXVDT+101
if LEXVDT#100=0
SET LEXVDT=LEXVDT+1
+4 SET LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSYS)
SET X=$SELECT(LEXVDT<LEXBRD:1,1:0)
+5 QUIT X
MDCDRG(X,LEXCDT,LEX,LEXLEN) ; Major Diagnostic Category/DRG
+1 QUIT
+2 NEW LEXAI,LEXC,LEXDA,LEXDI,LEXEF,LEXFY,LEXI,LEXIEN,LEXL,LEXLC,LEXMDCC,LEXMDCS,LEXME,LEXMI,LEXN,LEXT
+3 NEW LEXT1,LEXT2,LEXUD,LEXUM,LEXVDT
SET LEXVDT=+($GET(LEXCDT))
if LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
KILL LEXUM,LEXUD,LEX
+4 SET LEXLC=0
SET LEXIEN=+($GET(X))
SET LEXCDT=$GET(LEXCDT)
SET LEXLEN=+($GET(LEXLEN))
if +LEXLEN'>0
SET LEXLEN=62
if LEXCDT'?7N
QUIT
+5 DO MD^ICDEX(80.1,+LEXIEN,$GET(LEXCDT),.LEXMDCS,"IE")
+6 SET LEXMDCC=0
SET LEXMI=0
SET (LEXEF,LEXFY)=$ORDER(LEXMDCS(0))
if LEXFY'>0
QUIT
+7 SET LEXMI=0
FOR
SET LEXMI=$ORDER(LEXMDCS(LEXFY,"E",LEXMI))
if +LEXMI'>0
QUIT
Begin DoDot:1
+8 NEW LEXME,LEXMEI
SET LEXME=$GET(LEXMDCS(LEXFY,"E",LEXMI))
if '$LENGTH(LEXME)
QUIT
+9 SET LEXMEI=$ORDER(^ICM("B",LEXME,0))
if +LEXMEI'>0
QUIT
+10 if $DATA(LEXIIEN)
SET LEXME=LEXME_" (IEN "_+LEXMEI_")"
+11 SET LEXI=$ORDER(LEX(" "),-1)+1
SET LEX(LEXI)=LEXME
+12 SET LEXDI=0
FOR
SET LEXDI=$ORDER(LEXMDCS(LEXFY,"E",LEXMI,LEXDI))
if +LEXDI'>0
QUIT
Begin DoDot:2
+13 KILL LEXDA
SET LEXDA(1)=$GET(LEXMDCS(LEXFY,"E",LEXMI,LEXDI))
+14 DO PR^LEXU(.LEXDA,(LEXLEN-14))
SET LEXT1=" DRG "_LEXDI
+15 SET LEXT1=LEXT1_$JUSTIFY(" ",(14-$LENGTH(LEXT1)))
SET LEXT2=$JUSTIFY(" ",14)
+16 SET (LEXC,LEXI)=0
FOR
SET LEXI=$ORDER(LEXDA(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:3
+17 NEW LEXT,LEXL,LEXN,LEXAI
SET LEXT=$$TM^LEXQM($GET(LEXDA(LEXI)))
+18 if '$LENGTH(LEXT)
QUIT
SET LEXC=LEXC+1
if LEXC=1
SET LEXL=LEXT1_LEXT
if LEXC>1
SET LEXL=LEXT2_LEXT
+19 SET LEXAI=$ORDER(LEX(" "),-1)+1
SET LEX(LEXAI)=LEXL
End DoDot:3
End DoDot:2
End DoDot:1
+20 if LEXEF?7N&($LENGTH(LEX(1)))
SET LEX(0)=$$SD^LEXQM(LEXEF)
SET LEX=+($ORDER(LEX(" "),-1))
+21 QUIT
MAJ(X,LEX) ; Major O.R. Procedures
+1 NEW LEXC,LEXCHR,LEXHDR,LEXI,LEXI1,LEXI2,LEXIDI,LEXIEN,LEXPC,LEXSTR,LEXT
SET LEXIEN=+($GET(X))
if +LEXIEN'>0
QUIT
+2 SET LEXSTR=$$MOR^ICDEX(+LEXIEN)
if '$LENGTH(LEXSTR)
QUIT
DO OR(LEXSTR,.LEX)
+3 QUIT
OR(X,LEX) ; O.R. Procedures
+1 KILL LEX
NEW LEXC,LEXCHR,LEXHDR,LEXI,LEXI1,LEXI2,LEXIDI,LEXPC,LEXSTR,LEXT
SET LEXSTR=$GET(X)
if '$LENGTH(LEXSTR)
QUIT
+2 SET LEXHDR="Major O.R. ID"
SET LEXPC=0
SET LEXCHR=""
FOR LEXC=1:1
if '$LENGTH($EXTRACT(LEXSTR,LEXC))
QUIT
Begin DoDot:1
+3 SET LEXCHR=$EXTRACT(LEXSTR,LEXC)
if LEXCHR=""
QUIT
FOR LEXI=1:1
SET LEXIDI=$TEXT(MID+LEXI)
SET LEXIDI=$PIECE(LEXIDI,";;",2)
if LEXIDI="EXIT"
QUIT
Begin DoDot:2
+4 SET LEXI1=$$TM^LEXQM($PIECE(LEXIDI,"="))
SET LEXI2=$$TM^LEXQM($PIECE(LEXIDI,"=",2))
if $LENGTH(LEXI1)'=1
QUIT
if LEXI1'=LEXCHR
QUIT
if '$LENGTH(LEXI2)
QUIT
+5 SET LEXT=LEXI2
if $DATA(LEXINT)
SET LEXT=LEXT_$JUSTIFY(" ",(22-$LENGTH(LEXT)))_"("_LEXI1_")"
SET LEXPC=LEXPC+1
SET LEX(1,LEXPC)=$$UP^XLFSTR(LEXT)
End DoDot:2
End DoDot:1
+6 if +($ORDER(LEX(1," "),-1))>0
SET LEX(0)=$$UP^XLFSTR(LEXHDR)
SET LEX(1)=$$UP^XLFSTR(LEXSTR)
SET LEX=+($ORDER(LEX(1," "),-1))
+7 QUIT
MID ; Major O.R. Procedures Text
+1 ;;1=Bowel
+2 ;;2=Chest
+3 ;;3=Lymphoma/Leukemia
+4 ;;4=Joint
+5 ;;5=Pancreas/Liver
+6 ;;6=Pelvic
+7 ;;7=Shoulder/Elbow
+8 ;;8=Thumb/Joint
+9 ;;9=Head/Neck
+10 ;;A=Cardio
+11 ;;M=Musculoskeletal
+12 ;;EXIT
+13 QUIT
