LEXQIP3 ;ISL/KER - Query - ICD Procedure - Save ;04/21/2014
;;2.0;LEXICON UTILITY;**62,73,80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^TMP("LEXQIPO") SACC 2.3.2.5.1
;
; External References
; $$VSEX^ICDEX ICR 5747
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
; LEXCDT Code Set Versioning Date
; LEXDG DRG Array
; LEXIEN Internal Entry Number
; LEXLEN Offset Length
; LEXSO Code
; LEXNAM Unversioned Name
; LEXST Status and Effective Dates
; LEXSD Versioned Short Description
; LEXLD Versioned Long Description
; LEXWN Warning
; LEXMOR Major O.R. Procedure
; LEXDG MDC/DRG
; LEXELDT External Last Date
;
EN ; Main Entry Point
K ^TMP("LEXQIPO",$J) Q:'$L($G(LEXELDT)) I +($G(LEXST))<0 D FUT D:$D(^TMP("LEXQIPO",$J)) DSP^LEXQO("LEXQIPO") Q
D FUL D:$D(^TMP("LEXQIPO",$J)) DSP^LEXQO("LEXQIPO")
Q
FUT ; Future Activation
N LEX1,LEX2,LEX3,LEXEFF,LEXI,LEXL,LEXSTA S LEXI=+($G(LEXIEN)) Q:+LEXI'>0
S LEXL=+($G(LEXLEN)) Q:+LEXL'>0 S:LEXL>62 LEXL=62
Q:'$L(LEXSO) Q:'$L(LEXNAM) S LEXSTA=$G(LEXST)
S LEXEFF=$P(LEXSTA,"^",5),LEXSTA=$P(LEXSTA,"^",4)
Q:'$L(LEXSTA) Q:'$L(LEXEFF) S (LEX1,LEX2,LEX3)=""
D BOD(LEXELDT),COD(LEXSO,LEXNAM,+($G(LEXL))),STA(.LEXST,+($G(LEXL)))
Q
BOD(X) ; Based on Date
N LEXBOD S LEXBOD=$G(X),X="Display based on date: "_LEXBOD D BL,TL(X)
Q
COD(X,Y,LEXLEN) ; Code Line
N LEXC,LEXN,LEXT S LEXC=$G(X),LEXN=$G(Y),LEXT="Code: "_LEXC
S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
Q
STA(X,LEXLEN) ; Status Line
N LEX,LEXC,LEXX,LEXE,LEXI,LEXN,LEXS,LEXT,LEXW,LEXEFF,LEXSTA
S LEXX=$G(X),LEXSTA=$P(LEXX,"^",4),LEXEFF=$P(LEXX,"^",5)
S LEXEFF=$TR(LEXEFF,"()",""),LEXW=$P(LEXX,"^",6)
S LEXT=" Status: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXSTA
S LEXT=LEXT_$J(" ",(35-$L(LEXT)))
S:LEXEFF'["future" LEXT=LEXT_"Effective: "
S LEXT=LEXT_$$UP^XLFSTR($E(LEXEFF,1))_$E(LEXEFF,2,$L(LEXEFF)) D BL,TL(LEXT)
I $L(LEXW) D
. N LEX,LEXT,LEXC,LEXI,LEXN S LEX(1)=LEXW D PR^LEXQM(.LEX,(LEXLEN-7))
. Q:+($O(LEX(" "),-1))'>0 S LEXT=$J(" ",((79-+($G(LEXLEN)))))
. S (LEXC,LEXI)=0 F S LEXI=$O(LEX(LEXI)) Q:+LEXI'>0 D
. . N LEXN S LEXN=$$TM^LEXQM($G(LEX(LEXI))) S:$L(LEXN) LEXC=LEXC+1
. . D:LEXC=1 BL D TL((LEXT_LEXN))
Q
FUL ; Full Display
N LEXFUL,LEX,LEXL S LEXL=+($G(LEXLEN)) S:LEXL>62 LEXL=62
S LEXFUL="" D FUT
D LIM(+($G(LEXIEN)),+($G(LEXL)))
D SD(.LEXSD,+($G(LEXL)))
D LD(.LEXLD,+($G(LEXL)))
D WN(.LEXWN,+($G(LEXL)))
D MOR(.LEXMOR,+($G(LEXL)))
D DRG(.LEXDG,+($G(LEXL)))
Q
LIM(X,LEXLEN) ; Limitations - Sex
N LEXC,LEXH,LEXI,LEXS,LEXT S LEXC=0,LEXI=+($G(X)) S LEXS=$$VSEX^ICDEX(80.1,+LEXI,$G(LEXCDT)) Q:"^M^F^"'[("^"_LEXS_"^")
S LEXH="Use only with the " S:LEXS="F" LEXH=LEXH_"female sex" S:LEXS="M" LEXH=LEXH_"male sex"
S LEXT=" Limitations: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXH
D BL,TL(LEXT) S LEXC=1
Q
SD(X,LEXLEN) ; Short Description
N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1)) S LEXN=$G(X(1)),LEXT=" Short Name: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
S LEXE=$G(X(0)),LEXT=" "_LEXE,LEXN=$G(X(2)),LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D TL(LEXT)
Q
LD(X,LEXLEN) ; Long Description
N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1)) S LEXN=$G(X(1)),LEXT=" Description: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
S LEXE=$G(X(0)),LEXT=" "_LEXE,LEXN=$G(X(2)),LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D TL(LEXT)
S LEXT=$J(" ",((79-+($G(LEXLEN))))) S LEXI=2 F S LEXI=$O(X(LEXI)) Q:+LEXI'>0 S LEXN=LEXT_$G(X(LEXI)) D TL(LEXN)
Q
WN(X,LEXLEN) ; Warning
N LEXI,LEXH,LEXE,LEXN,LEXT,LEXC Q:'$D(X(1)) S LEXC=0,LEXN=$G(X(1)),LEXT="",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN
D:$L($G(LEXLD(2))) BL D TL(LEXT)
S LEXT=$J(" ",((79-+($G(LEXLEN))))),LEXI=1 F S LEXI=$O(X(LEXI)) Q:+LEXI'>0 S LEXN=LEXT_$G(X(LEXI)) D TL(LEXN)
Q
MOR(X,LEXLEN) ; Major OR Procedure
N LEXE,LEXH,LEXI,LEXID,LEXN,LEXT Q:'$D(X(1)) Q:'$D(X(1,1)) S LEXID=$G(X(1)) Q:'$L(LEXID) S LEXN=$G(X(1,1)) Q:'$L(LEXN)
S LEXT=" Major OR Proc",LEXE="Major O.R. Procedure",LEXE=LEXN,LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXE D BL,TL(LEXT)
S LEXI=1 F S LEXI=$O(X(1,LEXI)) Q:+LEXI'>0 S LEXE=$G(X(1,LEXI)) I $L(LEXE) S LEXT=$J(" ",((79-+($G(LEXLEN)))))_LEXE D TL(LEXT)
Q
DRG(X,LEXLEN) ; Major Diagnostic Category/DRG
N LEXE,LEXH,LEXI,LEXN,LEXT Q:'$D(X(1)) S LEXN=$G(X(1)) Q:'$L(LEXN) S LEXE=$G(X(0)) S:$L(LEXE,"/")'=3 LEXE=""
S LEXT=" MDC/DRG:",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT) S LEXN=$G(X(2))
S LEXT=" "_LEXE,LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT))) D TL((LEXT_LEXN)) S LEXT=$J(" ",(79-+($G(LEXLEN)))),LEXI=2
F S LEXI=$O(X(LEXI)) Q:+LEXI'>0 S LEXN=$G(X(LEXI)) D:$L(LEXN) TL((LEXT_LEXN))
Q
;
; Miscellaneous
BL ; Blank Line
D TL(" ") Q
TL(X) ; Text Line
I $D(LEXTEST) W !,$G(X) Q
N LEXI,LEXTEST S LEXI=+($O(^TMP("LEXQIPO",$J," "),-1))+1 S ^TMP("LEXQIPO",$J,LEXI)=$G(X),^TMP("LEXQIPO",$J,0)=LEXI
Q
LEXQIP3 ;ISL/KER - Query - ICD Procedure - Save ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**62,73,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXQIPO") SACC 2.3.2.5.1
+5 ;
+6 ; External References
+7 ; $$VSEX^ICDEX ICR 5747
+8 ; $$UP^XLFSTR ICR 10104
+9 ;
+10 ; Local Variables NEWed or KILLed Elsewhere
+11 ; LEXCDT Code Set Versioning Date
+12 ; LEXDG DRG Array
+13 ; LEXIEN Internal Entry Number
+14 ; LEXLEN Offset Length
+15 ; LEXSO Code
+16 ; LEXNAM Unversioned Name
+17 ; LEXST Status and Effective Dates
+18 ; LEXSD Versioned Short Description
+19 ; LEXLD Versioned Long Description
+20 ; LEXWN Warning
+21 ; LEXMOR Major O.R. Procedure
+22 ; LEXDG MDC/DRG
+23 ; LEXELDT External Last Date
+24 ;
EN ; Main Entry Point
+1 KILL ^TMP("LEXQIPO",$JOB)
IF '$LENGTH($GET(LEXELDT))
QUIT
IF +($GET(LEXST))<0
DO FUT
IF $DATA(^TMP("LEXQIPO",$JOB))
DO DSP^LEXQO("LEXQIPO")
QUIT
+2 DO FUL
IF $DATA(^TMP("LEXQIPO",$JOB))
DO DSP^LEXQO("LEXQIPO")
+3 QUIT
FUT ; Future Activation
+1 NEW LEX1,LEX2,LEX3,LEXEFF,LEXI,LEXL,LEXSTA
SET LEXI=+($GET(LEXIEN))
IF +LEXI'>0
QUIT
+2 SET LEXL=+($GET(LEXLEN))
IF +LEXL'>0
QUIT
IF LEXL>62
SET LEXL=62
+3 IF '$LENGTH(LEXSO)
QUIT
IF '$LENGTH(LEXNAM)
QUIT
SET LEXSTA=$GET(LEXST)
+4 SET LEXEFF=$PIECE(LEXSTA,"^",5)
SET LEXSTA=$PIECE(LEXSTA,"^",4)
+5 IF '$LENGTH(LEXSTA)
QUIT
IF '$LENGTH(LEXEFF)
QUIT
SET (LEX1,LEX2,LEX3)=""
+6 DO BOD(LEXELDT)
DO COD(LEXSO,LEXNAM,+($GET(LEXL)))
DO STA(.LEXST,+($GET(LEXL)))
+7 QUIT
BOD(X) ; Based on Date
+1 NEW LEXBOD
SET LEXBOD=$GET(X)
SET X="Display based on date: "_LEXBOD
DO BL
DO TL(X)
+2 QUIT
COD(X,Y,LEXLEN) ; Code Line
+1 NEW LEXC,LEXN,LEXT
SET LEXC=$GET(X)
SET LEXN=$GET(Y)
SET LEXT="Code: "_LEXC
+2 SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+3 QUIT
STA(X,LEXLEN) ; Status Line
+1 NEW LEX,LEXC,LEXX,LEXE,LEXI,LEXN,LEXS,LEXT,LEXW,LEXEFF,LEXSTA
+2 SET LEXX=$GET(X)
SET LEXSTA=$PIECE(LEXX,"^",4)
SET LEXEFF=$PIECE(LEXX,"^",5)
+3 SET LEXEFF=$TRANSLATE(LEXEFF,"()","")
SET LEXW=$PIECE(LEXX,"^",6)
+4 SET LEXT=" Status: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXSTA
+5 SET LEXT=LEXT_$JUSTIFY(" ",(35-$LENGTH(LEXT)))
+6 IF LEXEFF'["future"
SET LEXT=LEXT_"Effective: "
+7 SET LEXT=LEXT_$$UP^XLFSTR($EXTRACT(LEXEFF,1))_$EXTRACT(LEXEFF,2,$LENGTH(LEXEFF))
DO BL
DO TL(LEXT)
+8 IF $LENGTH(LEXW)
Begin DoDot:1
+9 NEW LEX,LEXT,LEXC,LEXI,LEXN
SET LEX(1)=LEXW
DO PR^LEXQM(.LEX,(LEXLEN-7))
+10 IF +($ORDER(LEX(" "),-1))'>0
QUIT
SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
+11 SET (LEXC,LEXI)=0
FOR
SET LEXI=$ORDER(LEX(LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:2
+12 NEW LEXN
SET LEXN=$$TM^LEXQM($GET(LEX(LEXI)))
IF $LENGTH(LEXN)
SET LEXC=LEXC+1
+13 IF LEXC=1
DO BL
DO TL((LEXT_LEXN))
End DoDot:2
End DoDot:1
+14 QUIT
FUL ; Full Display
+1 NEW LEXFUL,LEX,LEXL
SET LEXL=+($GET(LEXLEN))
IF LEXL>62
SET LEXL=62
+2 SET LEXFUL=""
DO FUT
+3 DO LIM(+($GET(LEXIEN)),+($GET(LEXL)))
+4 DO SD(.LEXSD,+($GET(LEXL)))
+5 DO LD(.LEXLD,+($GET(LEXL)))
+6 DO WN(.LEXWN,+($GET(LEXL)))
+7 DO MOR(.LEXMOR,+($GET(LEXL)))
+8 DO DRG(.LEXDG,+($GET(LEXL)))
+9 QUIT
LIM(X,LEXLEN) ; Limitations - Sex
+1 NEW LEXC,LEXH,LEXI,LEXS,LEXT
SET LEXC=0
SET LEXI=+($GET(X))
SET LEXS=$$VSEX^ICDEX(80.1,+LEXI,$GET(LEXCDT))
IF "^M^F^"'[("^"_LEXS_"^")
QUIT
+2 SET LEXH="Use only with the "
IF LEXS="F"
SET LEXH=LEXH_"female sex"
IF LEXS="M"
SET LEXH=LEXH_"male sex"
+3 SET LEXT=" Limitations: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXH
+4 DO BL
DO TL(LEXT)
SET LEXC=1
+5 QUIT
SD(X,LEXLEN) ; Short Description
+1 NEW LEXI,LEXH,LEXE,LEXN,LEXT
IF '$DATA(X(1))
QUIT
SET LEXN=$GET(X(1))
SET LEXT=" Short Name: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+2 SET LEXE=$GET(X(0))
SET LEXT=" "_LEXE
SET LEXN=$GET(X(2))
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO TL(LEXT)
+3 QUIT
LD(X,LEXLEN) ; Long Description
+1 NEW LEXI,LEXH,LEXE,LEXN,LEXT
IF '$DATA(X(1))
QUIT
SET LEXN=$GET(X(1))
SET LEXT=" Description: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+2 SET LEXE=$GET(X(0))
SET LEXT=" "_LEXE
SET LEXN=$GET(X(2))
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO TL(LEXT)
+3 SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
SET LEXI=2
FOR
SET LEXI=$ORDER(X(LEXI))
IF +LEXI'>0
QUIT
SET LEXN=LEXT_$GET(X(LEXI))
DO TL(LEXN)
+4 QUIT
WN(X,LEXLEN) ; Warning
+1 NEW LEXI,LEXH,LEXE,LEXN,LEXT,LEXC
IF '$DATA(X(1))
QUIT
SET LEXC=0
SET LEXN=$GET(X(1))
SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
+2 IF $LENGTH($GET(LEXLD(2)))
DO BL
DO TL(LEXT)
+3 SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
SET LEXI=1
FOR
SET LEXI=$ORDER(X(LEXI))
IF +LEXI'>0
QUIT
SET LEXN=LEXT_$GET(X(LEXI))
DO TL(LEXN)
+4 QUIT
MOR(X,LEXLEN) ; Major OR Procedure
+1 NEW LEXE,LEXH,LEXI,LEXID,LEXN,LEXT
IF '$DATA(X(1))
QUIT
IF '$DATA(X(1,1))
QUIT
SET LEXID=$GET(X(1))
IF '$LENGTH(LEXID)
QUIT
SET LEXN=$GET(X(1,1))
IF '$LENGTH(LEXN)
QUIT
+2 SET LEXT=" Major OR Proc"
SET LEXE="Major O.R. Procedure"
SET LEXE=LEXN
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXE
DO BL
DO TL(LEXT)
+3 SET LEXI=1
FOR
SET LEXI=$ORDER(X(1,LEXI))
IF +LEXI'>0
QUIT
SET LEXE=$GET(X(1,LEXI))
IF $LENGTH(LEXE)
SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))_LEXE
DO TL(LEXT)
+4 QUIT
DRG(X,LEXLEN) ; Major Diagnostic Category/DRG
+1 NEW LEXE,LEXH,LEXI,LEXN,LEXT
IF '$DATA(X(1))
QUIT
SET LEXN=$GET(X(1))
IF '$LENGTH(LEXN)
QUIT
SET LEXE=$GET(X(0))
IF $LENGTH(LEXE,"/")'=3
SET LEXE=""
+2 SET LEXT=" MDC/DRG:"
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
SET LEXN=$GET(X(2))
+3 SET LEXT=" "_LEXE
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))
DO TL((LEXT_LEXN))
SET LEXT=$JUSTIFY(" ",(79-+($GET(LEXLEN))))
SET LEXI=2
+4 FOR
SET LEXI=$ORDER(X(LEXI))
IF +LEXI'>0
QUIT
SET LEXN=$GET(X(LEXI))
IF $LENGTH(LEXN)
DO TL((LEXT_LEXN))
+5 QUIT
+6 ;
+7 ; Miscellaneous
BL ; Blank Line
+1 DO TL(" ")
QUIT
TL(X) ; Text Line
+1 IF $DATA(LEXTEST)
WRITE !,$GET(X)
QUIT
+2 NEW LEXI,LEXTEST
SET LEXI=+($ORDER(^TMP("LEXQIPO",$JOB," "),-1))+1
SET ^TMP("LEXQIPO",$JOB,LEXI)=$GET(X)
SET ^TMP("LEXQIPO",$JOB,0)=LEXI
+3 QUIT
