- LEXQIP2 ;ISL/KER - Query - ICD Procedure - Extract ;04/21/2014
- ;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
- ;
- ; 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
- ;
- Q
- MDCDRG(X,LEXCDT,LEX,LEXLEN) ; Major Diagnostic Category/DRG
- 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
- . S LEXME=$G(LEXMDCS(LEXFY,"E",LEXMI)) Q:'$L(LEXME)
- . 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^LEXQM(.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
- LEXQIP2 ;ISL/KER - Query - ICD Procedure - Extract ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
- +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
- +16 ;
- +17 QUIT
- MDCDRG(X,LEXCDT,LEX,LEXLEN) ; Major Diagnostic Category/DRG
- +1 NEW LEXAI,LEXC,LEXDA,LEXDI,LEXEF,LEXFY,LEXI,LEXIEN,LEXL,LEXLC,LEXMDCC,LEXMDCS,LEXME,LEXMI,LEXN,LEXT
- +2 NEW LEXT1,LEXT2,LEXUD,LEXUM,LEXVDT
- SET LEXVDT=+($GET(LEXCDT))
- IF LEXVDT'?7N
- SET LEXVDT=$$DT^XLFDT
- KILL LEXUM,LEXUD,LEX
- +3 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
- +4 DO MD^ICDEX(80.1,+LEXIEN,$GET(LEXCDT),.LEXMDCS,"IE")
- +5 SET LEXMDCC=0
- SET LEXMI=0
- SET (LEXEF,LEXFY)=$ORDER(LEXMDCS(0))
- IF LEXFY'>0
- QUIT
- +6 SET LEXMI=0
- FOR
- SET LEXMI=$ORDER(LEXMDCS(LEXFY,"E",LEXMI))
- IF +LEXMI'>0
- QUIT
- Begin DoDot:1
- +7 SET LEXME=$GET(LEXMDCS(LEXFY,"E",LEXMI))
- IF '$LENGTH(LEXME)
- QUIT
- +8 SET LEXI=$ORDER(LEX(" "),-1)+1
- SET LEX(LEXI)=LEXME
- +9 SET LEXDI=0
- FOR
- SET LEXDI=$ORDER(LEXMDCS(LEXFY,"E",LEXMI,LEXDI))
- IF +LEXDI'>0
- QUIT
- Begin DoDot:2
- +10 KILL LEXDA
- SET LEXDA(1)=$GET(LEXMDCS(LEXFY,"E",LEXMI,LEXDI))
- +11 DO PR^LEXQM(.LEXDA,(LEXLEN-14))
- SET LEXT1=" DRG "_LEXDI
- +12 SET LEXT1=LEXT1_$JUSTIFY(" ",(14-$LENGTH(LEXT1)))
- SET LEXT2=$JUSTIFY(" ",14)
- +13 SET (LEXC,LEXI)=0
- FOR
- SET LEXI=$ORDER(LEXDA(LEXI))
- IF +LEXI'>0
- QUIT
- Begin DoDot:3
- +14 NEW LEXT,LEXL,LEXN,LEXAI
- SET LEXT=$$TM^LEXQM($GET(LEXDA(LEXI)))
- +15 IF '$LENGTH(LEXT)
- QUIT
- SET LEXC=LEXC+1
- IF LEXC=1
- SET LEXL=LEXT1_LEXT
- IF LEXC>1
- SET LEXL=LEXT2_LEXT
- +16 SET LEXAI=$ORDER(LEX(" "),-1)+1
- SET LEX(LEXAI)=LEXL
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +17 IF LEXEF?7N&($LENGTH(LEX(1)))
- SET LEX(0)=$$SD^LEXQM(LEXEF)
- SET LEX=+($ORDER(LEX(" "),-1))
- +18 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
