- LEXQIP ;ISL/KER - Query - ICD Procedure - Extract ;04/21/2014
- ;;2.0;LEXICON UTILITY;**62,73,80**;Sep 23, 1996;Build 10
- ;
- ; Global Variables
- ; ^TMP("LEXQIP") SACC 2.3.2.5.1
- ; ^TMP("LEXQIPA") SACC 2.3.2.5.1
- ; ^TMP("LEXQIPO") SACC 2.3.2.5.1
- ;
- ; External References
- ; GETS^DIQ ICR 2056
- ; $$CODEC^ICDEX ICR 5747
- ; $$CSI^ICDEX ICR 5747
- ; $$DTBR^ICDEX ICR 5747
- ; $$HIST^ICDEX ICR 5747
- ; $$ICDOP^ICDEX ICR 5747
- ; $$LA^ICDEX ICR 5747
- ; $$LD^ICDEX ICR 5747
- ; $$MOR^ICDEX ICR 5747
- ; $$ROOT^ICDEX ICR 5747
- ; $$SD^ICDEX ICR 5747
- ; $$DT^XLFDT ICR 10103
- ; $$UP^XLFSTR ICR 10104
- ;
- ; Local Variables NEWed or KILLed Elsewhere
- ; None
- ;
- EN ; Main Entry Point
- N LEXENV S LEXENV=$$EV^LEXQM Q:+LEXENV'>0 N DIC,DTOUT,DUOUT,ICDFMT,ICDSYS,ICDVDT,LEX,LEX1,LEX2,LEX3,LEXAD,LEXBOD,LEXBRD
- N LEXBRW,LEXC,LEXCC,LEXCDT,LEXCHR,LEXD,LEXDAT,LEXDDT,LEXDG,LEXDI,LEXDR,LEXDRG,LEXDRG1,LEXDRG2,LEXDRGC,LEXDRGD,LEXDRGI
- N LEXDRI,LEXDTXT,LEXDX,LEXE,LEXEDT,LEXEE,LEXEF,LEXEFF,LEXELDT,LEXENV,LEXES,LEXEXIT,LEXFA,LEXFUL,LEXH,LEXHDR,LEXHIS,LEXHR
- N LEXI,LEXI1,LEXI2,LEXIA,LEXICP,LEXICPC,LEXID,LEXIDI,LEXIEN,LEXIENS,LEXINC,LEXINCC,LEXINOT,LEXINT,LEXIREQ,LEXL,LEXLA
- N LEXLAST,LEXLC,LEXLD,LEXLDD,LEXLDT,LEXLEF,LEXLEN,LEXLHI,LEXLS,LEXLSD,LEXLTXT,LEXM,LEXMC,LEXMDCC,LEXMDCE,LEXMDCI,LEXMI
- N LEXMOR,LEXMR,LEXMSG,LEXN,LEXNAM,LEXOD,LEXODD,LEXPC,LEXR,LEXREF,LEXRT,LEXS,LEXSD,LEXSDD,LEXSDT,LEXSO,LEXST,LEXSTA
- N LEXSTAT,LEXSTR,LEXSY,LEXSYS,LEXT,LEXTEST,LEXTMP,LEXUD,LEXUM,LEXVDT,LEXVTXT,LEXW,LEXWN,LEXX,X,Y S LEXEXIT=0,LEXCDT=""
- K ^TMP("LEXQIP",$J),^TMP("LEXQIPO",$J),^TMP("LEXQIPA",$J)
- F S LEXCDT=$$AD^LEXQM,LEXAD=LEXCDT Q:'$L(LEXCDT) Q:+($G(LEXEXIT))>0 S LEXEDT=$P(LEXCDT,"^",1),LEXCDT=$P(LEXCDT,"^",2) Q:LEXCDT'?7N D LOOK Q:LEXCDT'?7N Q:+($G(LEXEXIT))>0
- K ^TMP("LEXQIP",$J),^TMP("LEXQIPO",$J),^TMP("LEXQIPA",$J)
- Q
- LOOK ; ICD Lookup Loop
- N LEXDG,LEXST,LEXSD,LEXLD,LEXMOR,LEXWN,LEXCC,LEXMC,LEXICP,LEXICPC
- S LEXCDT=$G(LEXCDT),LEXEDT=$$ED^LEXQM(LEXCDT) I LEXCDT'?7N S LEXCDT="" Q
- S LEXLEN=62 F S LEXICP=$$ICP^LEXQIPA D Q:LEXICP="^"!(LEXICP="^^")
- . S:LEXICP="^^" LEXEXIT=1 Q:LEXICP="^"!(LEXICP="^^")
- . K LEXST,LEXSD,LEXLD,LEXWN,LEXCC,LEXMOR,LEXMC,^TMP("LEXQIP",$J)
- . N LEXIEN,LEXLDT,LEXELDT,LEXINC,LEXINOT,LEXIREQ,LEXINCC,LEXSO,LEXNAM
- . S LEXIEN=+($G(LEXICP)),LEXLDT=+($G(LEXCDT)) Q:+LEXIEN'>0 Q:LEXLDT'?7N
- . S LEXELDT=$$SD^LEXQM(LEXLDT) Q:'$L(LEXELDT)
- . D CSV,EN^LEXQIP3
- Q
- CSV ; Code Set Versioning Display
- N LEXEDT,LEXIEN,LEXIENS,LEXLTXT,LEXSTAT,LEXSYS,LEXMSG,LEXDAT
- N LEXT,LEXTMP S LEXCDT=$G(LEXCDT),LEXEDT=$$ED^LEXQM(LEXCDT)
- I LEXCDT'?7N S (LEXICP,LEXCDT)="" Q
- S LEXIEN=+($G(LEXICP)),LEXSO=$$CODEC^ICDEX(80.1,+LEXIEN)
- S LEXLTXT=$P($G(LEXICP),"^",3) S LEXSYS=$$CSI^ICDEX(80.1,+LEXIEN)
- Q:+LEXIEN'>0 Q:'$L(LEXSO) Q:+LEXSYS'>0
- S LEXDAT=$$ICDOP^ICDEX(LEXSO,LEXCDT,LEXSYS,"E")
- S LEXSO=$P(LEXDAT,"^",2),LEXNAM=$P(LEXDAT,"^",5)
- I '$L(LEXNAM)!($P(LEXNAM,"^",1)=-1) D
- . N LEXLA S LEXLA=$$LA^ICDEX(80.1,+LEXIEN,9999999)
- . S LEXNAM=$$SD^ICDEX(80.1,+LEXIEN,LEXLA)
- Q:'$L($G(LEXNAM))
- ;
- ; "Unversioned" Fields
- ;
- ; ,01 Code
- ; 1.1 Coding System
- ; 1.2 Identifier
- ; 1.4 MDC24
- ; 1.7 ICD Expanded
- ; 1.8 Exclude from Lookup
- ; 20 MAJOR O.R. PROC
- ;
- S LEXTMP=$$MOR^ICDEX(+LEXIEN) D:$L(LEXTMP) OR^LEXQIP2(LEXTMP,.LEXMOR)
- ;
- ; Get the "Versioned" Fields
- ;
- ; Date/Status 80.166 (66)
- S LEXST=$$EF(+($G(LEXIEN)),+LEXCDT),LEXSTAT=+($P(LEXST,"^",2))
- ; Procedure Name 80.167 (67)
- D SDS(+($G(LEXIEN)),+LEXCDT,.LEXSD,62,LEXSTAT)
- ; Description 80.168 (68)
- D LDS(+($G(LEXIEN)),+LEXCDT,.LEXLD,62,LEXSTAT)
- ; Warning Message
- D WN(+LEXCDT,.LEXWN,62)
- ; MDC/DRG Groups 80.171 (71)
- D MDCDRG^LEXQIP2(+LEXIEN,+LEXCDT,.LEXDG,LEXLEN)
- Q
- ;
- EF(X,LEXCDT) ; Effective Dates
- N LEX,LEXAD,LEXBRD,LEXBRW,LEXEE,LEXEF,LEXES,LEXFA,LEXH,LEXI,LEXID,LEXIEN,LEXRT,LEXLS,LEXSO,LEXSYS,LEXST S LEXIEN=+($G(X)),LEXCDT=+($G(LEXCDT))
- S LEXRT=$$ROOT^ICDEX(80.1) Q:+LEXIEN'>0 "^^" S LEXSO=$$CODEC^ICDEX(80.1,+LEXIEN) Q:'$L(LEXSO)!($P(LEXSO,"^",1)="-1") Q:LEXCDT'?7N "^^"
- S LEXSYS=$$CSI^ICDEX(80.1,+LEXIEN),LEX=$$ICDOP^ICDEX(LEXSO,LEXCDT,LEXSYS,"E")
- S LEXFA=$$FA(+LEXIEN),(LEXLS,LEXST)=$P(LEX,"^",10),LEXID=$P(LEX,"^",12),LEXAD=$P(LEX,"^",13),LEXBRD=2781001,LEXBRW=""
- I LEXCDT<LEXBRD&(+LEXFA=LEXBRD) D
- . S LEXBRW="Warning: The 'Based on Date' provided precedes the initial Code Set Business Rule date of "
- . S LEXBRW=LEXBRW_$$SD^LEXQM(LEXBRD)_", the Effective date may be inaccurate."
- S LEXES=$S(+LEXST>0:"Active",1:"Inactive")
- S:+LEXST'>0&(+LEXAD'>0) LEXES="Not Applicable",LEXLS=-1
- S:+LEXFA>0&(+LEXCDT>0)&(LEXFA>LEXCDT) LEXES="Pending",LEXLS=-1,LEXST=0,LEXBRW=""
- S:LEXST>0 LEXEF=LEXAD S:LEXST'>0 LEXEF=LEXID
- S:LEXST'>0&(+LEXID'>0) LEXEF=LEXFA S LEXEE=$$SD^LEXQM(LEXEF)
- I LEXST'>0,+LEXID'>0,$L(LEXEE),+LEXEF>LEXCDT S LEXEE="(future activation of "_LEXEE_")",LEXEF=""
- S X=LEXLS_"^"_LEXST_"^"_LEXEF_"^"_LEXES_"^"_LEXEE S:$L(LEXBRW) $P(X,"^",6)=LEXBRW
- Q X
- ;
- SDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Operation/Procedure (short description)
- ;
- ; LEX=# of Lines
- ; LEX(0)=External Date of Operation/Procedure Name
- ; LEX(#)=Operation/Procedure Name
- ;
- N LEXBRD,LEXBRW,LEXC,LEXD,LEXDDT,LEXE,LEXEE,LEXEFF,LEXFA
- N LEXHIS,LEXI,LEXIA,LEXIEN,LEXL,LEXLA,LEXLAST,LEXLEF
- N LEXLHI,LEXLSD,LEXM,LEXOD,LEXODD,LEXR,LEXS,LEXSD,LEXSDD
- N LEXSDT,LEXSO,LEXSY,LEXT S LEXIEN=$G(X) Q:+LEXIEN'>0
- S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT
- S LEXSTA=+($G(LEXSTA)) S LEXSO=$$CODEC^ICDEX(80.1,+LEXIEN)
- S LEXSY=$$CSI^ICDEX(80.1,+LEXIEN)
- S LEXLA=$$LA^ICDEX(80.1,+LEXIEN,9999999),LEXFA=$$FA(+LEXIEN)
- S LEXLAST=$$ICDOP^ICDEX(LEXSO,LEXLA,LEXSY,"E")
- S LEXLSD=$P(LEXLAST,"^",5),LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSY),LEXBRW=""
- S LEXSD=$$SD^ICDEX(80.1,+LEXIEN,LEXVDT,.LEXS)
- S LEXSD=$G(LEXS(1)),LEXSDD=$P($G(LEXS(0)),"^",2)
- S:'$L(LEXSD) LEXSDD="--/--/----" S LEXM=""
- I $P(LEXSD,"^",1)="-1"!('$L(LEXSD)) D
- . S LEXM="Operation/Procedure Short Name is not available."
- . I (LEXVDT'?7N!(LEXFA'?7N)),LEXVDT<LEXFA D
- . . S LEXM=LEXM_" The date provided precedes the initial activation of the code"
- . I LEXVDT?7N&(LEXFA?7N),LEXVDT<LEXFA D
- . . S LEXM=LEXM_" The date provided ("_$$ED^LEXQM(LEXVDT)_") precedes the initial activation ("_$$ED^LEXQM(LEXFA)_") of the code"
- . S:$L(LEXM) LEXM="NOTE: "_LEXM S LEXOD=LEXLSD,LEXODD="--/--/----"
- I $L(LEXSD)&($P(LEXSD,"^",1)'="-1") D
- . S LEXM="" S LEXOD=LEXSD,LEXODD=$S(LEXSDD?7N:$$ED^LEXQM(LEXSDD),1:"--/--/----")
- S:'$L(LEXOD) LEXOD="Operation/Procedure Short Name not found"
- S:'$L(LEXODD) LEXODD="--/--/----"
- K LEX,LEXT S LEXT(1)=LEXOD D PR^LEXQM(.LEXT,(LEXLEN-7))
- S LEXI=0 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 S LEXT=$G(LEXT(LEXI)) S LEX(LEXI)=LEXT
- I $L($G(LEXM)) D
- . K LEX,LEXT N LEXC S LEXT(1)=LEXM D PR^LEXQM(.LEXT,(LEXLEN-7))
- . S LEXI=0 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 S LEXT=$G(LEXT(LEXI)) S LEXC=$O(LEX(" "),-1)+1,LEX(LEXC)=LEXT
- S:$D(LEX(1)) LEX(0)=LEXODD
- Q
- LDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Operation/Procedure (short description)
- ;
- ; LEX=# of Lines
- ; LEX(0)=External Date of Operation/Procedure Name
- ; LEX(#)=Operation/Procedure Name
- ;
- N LEXBRD,LEXBRW,LEXC,LEXD,LEXDDT,LEXE,LEXEE,LEXEFF,LEXFA
- N LEXHIS,LEXI,LEXIA,LEXIEN,LEXL,LEXLA,LEXLAST,LEXLEF
- N LEXLHI,LEXLSD,LEXM,LEXOD,LEXODD,LEXR,LEXS,LEXLD,LEXLDD
- N LEXSDT,LEXSO,LEXSY,LEXT S LEXIEN=$G(X) Q:+LEXIEN'>0
- S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT
- S LEXSTA=+($G(LEXSTA)) S LEXSO=$$CODEC^ICDEX(80.1,+LEXIEN)
- S LEXSY=$$CSI^ICDEX(80.1,+LEXIEN)
- S LEXLA=$$LA^ICDEX(80.1,+LEXIEN,9999999),LEXFA=$$FA(+LEXIEN)
- S LEXLSD=$$LD^ICDEX(80.1,+LEXIEN,LEXLA)
- S LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSY),LEXBRW=""
- S LEXLD=$$LD^ICDEX(80.1,+LEXIEN,LEXVDT,.LEXS,245)
- S LEXLD=$G(LEXS(1)),LEXLDD=$P($G(LEXS(0)),"^",2)
- S:'$L(LEXLD) LEXLDD="--/--/----" S LEXM=""
- I $P(LEXLD,"^",1)="-1"!('$L(LEXLD)) D
- . S LEXM="Operation/Procedure Description is not available."
- . I (LEXVDT'?7N!(LEXFA'?7N)),LEXVDT<LEXFA D
- . . S LEXM=LEXM_" The date provided precedes the initial activation of the code"
- . I LEXVDT?7N&(LEXFA?7N),LEXVDT<LEXFA D
- . . S LEXM=LEXM_" The date provided ("_$$ED^LEXQM(LEXVDT)_") precedes the initial activation ("_$$ED^LEXQM(LEXFA)_") of the code"
- . S:$L(LEXM) LEXM="NOTE: "_LEXM S LEXOD=LEXLSD,LEXODD="--/--/----"
- I $L(LEXLD)&($P(LEXLD,"^",1)'="-1") D
- . S LEXM="" S LEXOD=LEXLD,LEXODD=$S(LEXLDD?7N:$$ED^LEXQM(LEXLDD),1:"--/--/----")
- S:'$L(LEXOD) LEXOD="Operation/Procedure Description not found"
- S:'$L(LEXODD) LEXODD="--/--/----"
- K LEX,LEXT S LEXT(1)=LEXOD D PR^LEXQM(.LEXT,(LEXLEN-7))
- S LEXI=0 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 S LEXT=$G(LEXT(LEXI)) S LEX(LEXI)=LEXT
- I $L($G(LEXM)) D
- . K LEX,LEXT N LEXC S LEXT(1)=LEXM D PR^LEXQM(.LEXT,(LEXLEN-7))
- . S LEXI=0 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 S LEXT=$G(LEXT(LEXI)) S LEXC=$O(LEX(" "),-1)+1,LEX(LEXC)=LEXT
- S:$D(LEX(1)) LEX(0)=LEXODD
- Q
- ;
- WN(X,LEX,LEXLEN) ; Warning
- ;
- ; LEX=# of Lines
- ; LEX(0)=External Date
- ; LEX(#)=Warning
- ;
- N LEXVDT,LEXREF,LEXIA,LEXTMP K LEX S LEXVDT=$G(X) Q:LEXVDT'?7N S LEXLEN=+$G(LEXLEN) S LEXIA=$$IA(LEXVDT,LEXIEN) Q:+LEXIA'>0 S:+LEXLEN>62 LEXLEN=62
- S LEXTMP(1)="Warning: The 'Based on Date' provided precedes Code Set Versioning. The Operation/Procedure (Short Name) and Description may be inaccurate for "_$$SD^LEXQM(LEXVDT)
- D PR^LEXQM(.LEXTMP,LEXLEN) K LEX S LEXI=0 F S LEXI=$O(LEXTMP(LEXI)) Q:+LEXI'>0 S LEX(LEXI)=$G(LEXTMP(LEXI))
- S LEX=$O(LEX(" "),-1),LEX(0)=$$SD^LEXQM(LEXVDT)
- Q
- ; Miscellaneous
- FA(X) ; First Activation
- N LEXFA,LEXH,LEXI,LEXIEN,LEXSO,LEXSY
- S LEXIEN=+($G(X)) S X="",LEXSO=$$CODEC^ICDEX(80.1,+LEXIEN),LEXSY=$$CSI^ICDEX(80.1,+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.1,+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
- LEXQIP ;ISL/KER - Query - ICD Procedure - Extract ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**62,73,80**;Sep 23, 1996;Build 10
- +2 ;
- +3 ; Global Variables
- +4 ; ^TMP("LEXQIP") SACC 2.3.2.5.1
- +5 ; ^TMP("LEXQIPA") SACC 2.3.2.5.1
- +6 ; ^TMP("LEXQIPO") SACC 2.3.2.5.1
- +7 ;
- +8 ; External References
- +9 ; GETS^DIQ ICR 2056
- +10 ; $$CODEC^ICDEX ICR 5747
- +11 ; $$CSI^ICDEX ICR 5747
- +12 ; $$DTBR^ICDEX ICR 5747
- +13 ; $$HIST^ICDEX ICR 5747
- +14 ; $$ICDOP^ICDEX ICR 5747
- +15 ; $$LA^ICDEX ICR 5747
- +16 ; $$LD^ICDEX ICR 5747
- +17 ; $$MOR^ICDEX ICR 5747
- +18 ; $$ROOT^ICDEX ICR 5747
- +19 ; $$SD^ICDEX ICR 5747
- +20 ; $$DT^XLFDT ICR 10103
- +21 ; $$UP^XLFSTR ICR 10104
- +22 ;
- +23 ; Local Variables NEWed or KILLed Elsewhere
- +24 ; None
- +25 ;
- EN ; Main Entry Point
- +1 NEW LEXENV
- SET LEXENV=$$EV^LEXQM
- IF +LEXENV'>0
- QUIT
- NEW DIC,DTOUT,DUOUT,ICDFMT,ICDSYS,ICDVDT,LEX,LEX1,LEX2,LEX3,LEXAD,LEXBOD,LEXBRD
- +2 NEW LEXBRW,LEXC,LEXCC,LEXCDT,LEXCHR,LEXD,LEXDAT,LEXDDT,LEXDG,LEXDI,LEXDR,LEXDRG,LEXDRG1,LEXDRG2,LEXDRGC,LEXDRGD,LEXDRGI
- +3 NEW LEXDRI,LEXDTXT,LEXDX,LEXE,LEXEDT,LEXEE,LEXEF,LEXEFF,LEXELDT,LEXENV,LEXES,LEXEXIT,LEXFA,LEXFUL,LEXH,LEXHDR,LEXHIS,LEXHR
- +4 NEW LEXI,LEXI1,LEXI2,LEXIA,LEXICP,LEXICPC,LEXID,LEXIDI,LEXIEN,LEXIENS,LEXINC,LEXINCC,LEXINOT,LEXINT,LEXIREQ,LEXL,LEXLA
- +5 NEW LEXLAST,LEXLC,LEXLD,LEXLDD,LEXLDT,LEXLEF,LEXLEN,LEXLHI,LEXLS,LEXLSD,LEXLTXT,LEXM,LEXMC,LEXMDCC,LEXMDCE,LEXMDCI,LEXMI
- +6 NEW LEXMOR,LEXMR,LEXMSG,LEXN,LEXNAM,LEXOD,LEXODD,LEXPC,LEXR,LEXREF,LEXRT,LEXS,LEXSD,LEXSDD,LEXSDT,LEXSO,LEXST,LEXSTA
- +7 NEW LEXSTAT,LEXSTR,LEXSY,LEXSYS,LEXT,LEXTEST,LEXTMP,LEXUD,LEXUM,LEXVDT,LEXVTXT,LEXW,LEXWN,LEXX,X,Y
- SET LEXEXIT=0
- SET LEXCDT=""
- +8 KILL ^TMP("LEXQIP",$JOB),^TMP("LEXQIPO",$JOB),^TMP("LEXQIPA",$JOB)
- +9 FOR
- SET LEXCDT=$$AD^LEXQM
- SET LEXAD=LEXCDT
- IF '$LENGTH(LEXCDT)
- QUIT
- IF +($GET(LEXEXIT))>0
- QUIT
- SET LEXEDT=$PIECE(LEXCDT,"^",1)
- SET LEXCDT=$PIECE(LEXCDT,"^",2)
- IF LEXCDT'?7N
- QUIT
- DO LOOK
- IF LEXCDT'?7N
- QUIT
- IF +($GET(LEXEXIT))>0
- QUIT
- +10 KILL ^TMP("LEXQIP",$JOB),^TMP("LEXQIPO",$JOB),^TMP("LEXQIPA",$JOB)
- +11 QUIT
- LOOK ; ICD Lookup Loop
- +1 NEW LEXDG,LEXST,LEXSD,LEXLD,LEXMOR,LEXWN,LEXCC,LEXMC,LEXICP,LEXICPC
- +2 SET LEXCDT=$GET(LEXCDT)
- SET LEXEDT=$$ED^LEXQM(LEXCDT)
- IF LEXCDT'?7N
- SET LEXCDT=""
- QUIT
- +3 SET LEXLEN=62
- FOR
- SET LEXICP=$$ICP^LEXQIPA
- Begin DoDot:1
- +4 IF LEXICP="^^"
- SET LEXEXIT=1
- IF LEXICP="^"!(LEXICP="^^")
- QUIT
- +5 KILL LEXST,LEXSD,LEXLD,LEXWN,LEXCC,LEXMOR,LEXMC,^TMP("LEXQIP",$JOB)
- +6 NEW LEXIEN,LEXLDT,LEXELDT,LEXINC,LEXINOT,LEXIREQ,LEXINCC,LEXSO,LEXNAM
- +7 SET LEXIEN=+($GET(LEXICP))
- SET LEXLDT=+($GET(LEXCDT))
- IF +LEXIEN'>0
- QUIT
- IF LEXLDT'?7N
- QUIT
- +8 SET LEXELDT=$$SD^LEXQM(LEXLDT)
- IF '$LENGTH(LEXELDT)
- QUIT
- +9 DO CSV
- DO EN^LEXQIP3
- End DoDot:1
- IF LEXICP="^"!(LEXICP="^^")
- QUIT
- +10 QUIT
- CSV ; Code Set Versioning Display
- +1 NEW LEXEDT,LEXIEN,LEXIENS,LEXLTXT,LEXSTAT,LEXSYS,LEXMSG,LEXDAT
- +2 NEW LEXT,LEXTMP
- SET LEXCDT=$GET(LEXCDT)
- SET LEXEDT=$$ED^LEXQM(LEXCDT)
- +3 IF LEXCDT'?7N
- SET (LEXICP,LEXCDT)=""
- QUIT
- +4 SET LEXIEN=+($GET(LEXICP))
- SET LEXSO=$$CODEC^ICDEX(80.1,+LEXIEN)
- +5 SET LEXLTXT=$PIECE($GET(LEXICP),"^",3)
- SET LEXSYS=$$CSI^ICDEX(80.1,+LEXIEN)
- +6 IF +LEXIEN'>0
- QUIT
- IF '$LENGTH(LEXSO)
- QUIT
- IF +LEXSYS'>0
- QUIT
- +7 SET LEXDAT=$$ICDOP^ICDEX(LEXSO,LEXCDT,LEXSYS,"E")
- +8 SET LEXSO=$PIECE(LEXDAT,"^",2)
- SET LEXNAM=$PIECE(LEXDAT,"^",5)
- +9 IF '$LENGTH(LEXNAM)!($PIECE(LEXNAM,"^",1)=-1)
- Begin DoDot:1
- +10 NEW LEXLA
- SET LEXLA=$$LA^ICDEX(80.1,+LEXIEN,9999999)
- +11 SET LEXNAM=$$SD^ICDEX(80.1,+LEXIEN,LEXLA)
- End DoDot:1
- +12 IF '$LENGTH($GET(LEXNAM))
- QUIT
- +13 ;
- +14 ; "Unversioned" Fields
- +15 ;
- +16 ; ,01 Code
- +17 ; 1.1 Coding System
- +18 ; 1.2 Identifier
- +19 ; 1.4 MDC24
- +20 ; 1.7 ICD Expanded
- +21 ; 1.8 Exclude from Lookup
- +22 ; 20 MAJOR O.R. PROC
- +23 ;
- +24 SET LEXTMP=$$MOR^ICDEX(+LEXIEN)
- IF $LENGTH(LEXTMP)
- DO OR^LEXQIP2(LEXTMP,.LEXMOR)
- +25 ;
- +26 ; Get the "Versioned" Fields
- +27 ;
- +28 ; Date/Status 80.166 (66)
- +29 SET LEXST=$$EF(+($GET(LEXIEN)),+LEXCDT)
- SET LEXSTAT=+($PIECE(LEXST,"^",2))
- +30 ; Procedure Name 80.167 (67)
- +31 DO SDS(+($GET(LEXIEN)),+LEXCDT,.LEXSD,62,LEXSTAT)
- +32 ; Description 80.168 (68)
- +33 DO LDS(+($GET(LEXIEN)),+LEXCDT,.LEXLD,62,LEXSTAT)
- +34 ; Warning Message
- +35 DO WN(+LEXCDT,.LEXWN,62)
- +36 ; MDC/DRG Groups 80.171 (71)
- +37 DO MDCDRG^LEXQIP2(+LEXIEN,+LEXCDT,.LEXDG,LEXLEN)
- +38 QUIT
- +39 ;
- EF(X,LEXCDT) ; Effective Dates
- +1 NEW LEX,LEXAD,LEXBRD,LEXBRW,LEXEE,LEXEF,LEXES,LEXFA,LEXH,LEXI,LEXID,LEXIEN,LEXRT,LEXLS,LEXSO,LEXSYS,LEXST
- SET LEXIEN=+($GET(X))
- SET LEXCDT=+($GET(LEXCDT))
- +2 SET LEXRT=$$ROOT^ICDEX(80.1)
- IF +LEXIEN'>0
- QUIT "^^"
- SET LEXSO=$$CODEC^ICDEX(80.1,+LEXIEN)
- IF '$LENGTH(LEXSO)!($PIECE(LEXSO,"^",1)="-1")
- QUIT
- IF LEXCDT'?7N
- QUIT "^^"
- +3 SET LEXSYS=$$CSI^ICDEX(80.1,+LEXIEN)
- SET LEX=$$ICDOP^ICDEX(LEXSO,LEXCDT,LEXSYS,"E")
- +4 SET LEXFA=$$FA(+LEXIEN)
- SET (LEXLS,LEXST)=$PIECE(LEX,"^",10)
- SET LEXID=$PIECE(LEX,"^",12)
- SET LEXAD=$PIECE(LEX,"^",13)
- SET LEXBRD=2781001
- SET LEXBRW=""
- +5 IF LEXCDT<LEXBRD&(+LEXFA=LEXBRD)
- Begin DoDot:1
- +6 SET LEXBRW="Warning: The 'Based on Date' provided precedes the initial Code Set Business Rule date of "
- +7 SET LEXBRW=LEXBRW_$$SD^LEXQM(LEXBRD)_", the Effective date may be inaccurate."
- End DoDot:1
- +8 SET LEXES=$SELECT(+LEXST>0:"Active",1:"Inactive")
- +9 IF +LEXST'>0&(+LEXAD'>0)
- SET LEXES="Not Applicable"
- SET LEXLS=-1
- +10 IF +LEXFA>0&(+LEXCDT>0)&(LEXFA>LEXCDT)
- SET LEXES="Pending"
- SET LEXLS=-1
- SET LEXST=0
- SET LEXBRW=""
- +11 IF LEXST>0
- SET LEXEF=LEXAD
- IF LEXST'>0
- SET LEXEF=LEXID
- +12 IF LEXST'>0&(+LEXID'>0)
- SET LEXEF=LEXFA
- SET LEXEE=$$SD^LEXQM(LEXEF)
- +13 IF LEXST'>0
- IF +LEXID'>0
- IF $LENGTH(LEXEE)
- IF +LEXEF>LEXCDT
- SET LEXEE="(future activation of "_LEXEE_")"
- SET LEXEF=""
- +14 SET X=LEXLS_"^"_LEXST_"^"_LEXEF_"^"_LEXES_"^"_LEXEE
- IF $LENGTH(LEXBRW)
- SET $PIECE(X,"^",6)=LEXBRW
- +15 QUIT X
- +16 ;
- SDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Operation/Procedure (short description)
- +1 ;
- +2 ; LEX=# of Lines
- +3 ; LEX(0)=External Date of Operation/Procedure Name
- +4 ; LEX(#)=Operation/Procedure Name
- +5 ;
- +6 NEW LEXBRD,LEXBRW,LEXC,LEXD,LEXDDT,LEXE,LEXEE,LEXEFF,LEXFA
- +7 NEW LEXHIS,LEXI,LEXIA,LEXIEN,LEXL,LEXLA,LEXLAST,LEXLEF
- +8 NEW LEXLHI,LEXLSD,LEXM,LEXOD,LEXODD,LEXR,LEXS,LEXSD,LEXSDD
- +9 NEW LEXSDT,LEXSO,LEXSY,LEXT
- SET LEXIEN=$GET(X)
- IF +LEXIEN'>0
- QUIT
- +10 SET LEXVDT=+($GET(LEXVDT))
- IF LEXVDT'?7N
- SET LEXVDT=$$DT^XLFDT
- +11 SET LEXSTA=+($GET(LEXSTA))
- SET LEXSO=$$CODEC^ICDEX(80.1,+LEXIEN)
- +12 SET LEXSY=$$CSI^ICDEX(80.1,+LEXIEN)
- +13 SET LEXLA=$$LA^ICDEX(80.1,+LEXIEN,9999999)
- SET LEXFA=$$FA(+LEXIEN)
- +14 SET LEXLAST=$$ICDOP^ICDEX(LEXSO,LEXLA,LEXSY,"E")
- +15 SET LEXLSD=$PIECE(LEXLAST,"^",5)
- SET LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSY)
- SET LEXBRW=""
- +16 SET LEXSD=$$SD^ICDEX(80.1,+LEXIEN,LEXVDT,.LEXS)
- +17 SET LEXSD=$GET(LEXS(1))
- SET LEXSDD=$PIECE($GET(LEXS(0)),"^",2)
- +18 IF '$LENGTH(LEXSD)
- SET LEXSDD="--/--/----"
- SET LEXM=""
- +19 IF $PIECE(LEXSD,"^",1)="-1"!('$LENGTH(LEXSD))
- Begin DoDot:1
- +20 SET LEXM="Operation/Procedure Short Name is not available."
- +21 IF (LEXVDT'?7N!(LEXFA'?7N))
- IF LEXVDT<LEXFA
- Begin DoDot:2
- +22 SET LEXM=LEXM_" The date provided precedes the initial activation of the code"
- End DoDot:2
- +23 IF LEXVDT?7N&(LEXFA?7N)
- IF LEXVDT<LEXFA
- Begin DoDot:2
- +24 SET LEXM=LEXM_" The date provided ("_$$ED^LEXQM(LEXVDT)_") precedes the initial activation ("_$$ED^LEXQM(LEXFA)_") of the code"
- End DoDot:2
- +25 IF $LENGTH(LEXM)
- SET LEXM="NOTE: "_LEXM
- SET LEXOD=LEXLSD
- SET LEXODD="--/--/----"
- End DoDot:1
- +26 IF $LENGTH(LEXSD)&($PIECE(LEXSD,"^",1)'="-1")
- Begin DoDot:1
- +27 SET LEXM=""
- SET LEXOD=LEXSD
- SET LEXODD=$SELECT(LEXSDD?7N:$$ED^LEXQM(LEXSDD),1:"--/--/----")
- End DoDot:1
- +28 IF '$LENGTH(LEXOD)
- SET LEXOD="Operation/Procedure Short Name not found"
- +29 IF '$LENGTH(LEXODD)
- SET LEXODD="--/--/----"
- +30 KILL LEX,LEXT
- SET LEXT(1)=LEXOD
- DO PR^LEXQM(.LEXT,(LEXLEN-7))
- +31 SET LEXI=0
- FOR
- SET LEXI=$ORDER(LEXT(LEXI))
- IF +LEXI'>0
- QUIT
- SET LEXT=$GET(LEXT(LEXI))
- SET LEX(LEXI)=LEXT
- +32 IF $LENGTH($GET(LEXM))
- Begin DoDot:1
- +33 KILL LEX,LEXT
- NEW LEXC
- SET LEXT(1)=LEXM
- DO PR^LEXQM(.LEXT,(LEXLEN-7))
- +34 SET LEXI=0
- FOR
- SET LEXI=$ORDER(LEXT(LEXI))
- IF +LEXI'>0
- QUIT
- SET LEXT=$GET(LEXT(LEXI))
- SET LEXC=$ORDER(LEX(" "),-1)+1
- SET LEX(LEXC)=LEXT
- End DoDot:1
- +35 IF $DATA(LEX(1))
- SET LEX(0)=LEXODD
- +36 QUIT
- LDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Operation/Procedure (short description)
- +1 ;
- +2 ; LEX=# of Lines
- +3 ; LEX(0)=External Date of Operation/Procedure Name
- +4 ; LEX(#)=Operation/Procedure Name
- +5 ;
- +6 NEW LEXBRD,LEXBRW,LEXC,LEXD,LEXDDT,LEXE,LEXEE,LEXEFF,LEXFA
- +7 NEW LEXHIS,LEXI,LEXIA,LEXIEN,LEXL,LEXLA,LEXLAST,LEXLEF
- +8 NEW LEXLHI,LEXLSD,LEXM,LEXOD,LEXODD,LEXR,LEXS,LEXLD,LEXLDD
- +9 NEW LEXSDT,LEXSO,LEXSY,LEXT
- SET LEXIEN=$GET(X)
- IF +LEXIEN'>0
- QUIT
- +10 SET LEXVDT=+($GET(LEXVDT))
- IF LEXVDT'?7N
- SET LEXVDT=$$DT^XLFDT
- +11 SET LEXSTA=+($GET(LEXSTA))
- SET LEXSO=$$CODEC^ICDEX(80.1,+LEXIEN)
- +12 SET LEXSY=$$CSI^ICDEX(80.1,+LEXIEN)
- +13 SET LEXLA=$$LA^ICDEX(80.1,+LEXIEN,9999999)
- SET LEXFA=$$FA(+LEXIEN)
- +14 SET LEXLSD=$$LD^ICDEX(80.1,+LEXIEN,LEXLA)
- +15 SET LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSY)
- SET LEXBRW=""
- +16 SET LEXLD=$$LD^ICDEX(80.1,+LEXIEN,LEXVDT,.LEXS,245)
- +17 SET LEXLD=$GET(LEXS(1))
- SET LEXLDD=$PIECE($GET(LEXS(0)),"^",2)
- +18 IF '$LENGTH(LEXLD)
- SET LEXLDD="--/--/----"
- SET LEXM=""
- +19 IF $PIECE(LEXLD,"^",1)="-1"!('$LENGTH(LEXLD))
- Begin DoDot:1
- +20 SET LEXM="Operation/Procedure Description is not available."
- +21 IF (LEXVDT'?7N!(LEXFA'?7N))
- IF LEXVDT<LEXFA
- Begin DoDot:2
- +22 SET LEXM=LEXM_" The date provided precedes the initial activation of the code"
- End DoDot:2
- +23 IF LEXVDT?7N&(LEXFA?7N)
- IF LEXVDT<LEXFA
- Begin DoDot:2
- +24 SET LEXM=LEXM_" The date provided ("_$$ED^LEXQM(LEXVDT)_") precedes the initial activation ("_$$ED^LEXQM(LEXFA)_") of the code"
- End DoDot:2
- +25 IF $LENGTH(LEXM)
- SET LEXM="NOTE: "_LEXM
- SET LEXOD=LEXLSD
- SET LEXODD="--/--/----"
- End DoDot:1
- +26 IF $LENGTH(LEXLD)&($PIECE(LEXLD,"^",1)'="-1")
- Begin DoDot:1
- +27 SET LEXM=""
- SET LEXOD=LEXLD
- SET LEXODD=$SELECT(LEXLDD?7N:$$ED^LEXQM(LEXLDD),1:"--/--/----")
- End DoDot:1
- +28 IF '$LENGTH(LEXOD)
- SET LEXOD="Operation/Procedure Description not found"
- +29 IF '$LENGTH(LEXODD)
- SET LEXODD="--/--/----"
- +30 KILL LEX,LEXT
- SET LEXT(1)=LEXOD
- DO PR^LEXQM(.LEXT,(LEXLEN-7))
- +31 SET LEXI=0
- FOR
- SET LEXI=$ORDER(LEXT(LEXI))
- IF +LEXI'>0
- QUIT
- SET LEXT=$GET(LEXT(LEXI))
- SET LEX(LEXI)=LEXT
- +32 IF $LENGTH($GET(LEXM))
- Begin DoDot:1
- +33 KILL LEX,LEXT
- NEW LEXC
- SET LEXT(1)=LEXM
- DO PR^LEXQM(.LEXT,(LEXLEN-7))
- +34 SET LEXI=0
- FOR
- SET LEXI=$ORDER(LEXT(LEXI))
- IF +LEXI'>0
- QUIT
- SET LEXT=$GET(LEXT(LEXI))
- SET LEXC=$ORDER(LEX(" "),-1)+1
- SET LEX(LEXC)=LEXT
- End DoDot:1
- +35 IF $DATA(LEX(1))
- SET LEX(0)=LEXODD
- +36 QUIT
- +37 ;
- WN(X,LEX,LEXLEN) ; Warning
- +1 ;
- +2 ; LEX=# of Lines
- +3 ; LEX(0)=External Date
- +4 ; LEX(#)=Warning
- +5 ;
- +6 NEW LEXVDT,LEXREF,LEXIA,LEXTMP
- KILL LEX
- SET LEXVDT=$GET(X)
- IF LEXVDT'?7N
- QUIT
- SET LEXLEN=+$GET(LEXLEN)
- SET LEXIA=$$IA(LEXVDT,LEXIEN)
- IF +LEXIA'>0
- QUIT
- IF +LEXLEN>62
- SET LEXLEN=62
- +7 SET LEXTMP(1)="Warning: The 'Based on Date' provided precedes Code Set Versioning. The Operation/Procedure (Short Name) and Description may be inaccurate for "_$$SD^LEXQM(LEXVDT)
- +8 DO PR^LEXQM(.LEXTMP,LEXLEN)
- KILL LEX
- SET LEXI=0
- FOR
- SET LEXI=$ORDER(LEXTMP(LEXI))
- IF +LEXI'>0
- QUIT
- SET LEX(LEXI)=$GET(LEXTMP(LEXI))
- +9 SET LEX=$ORDER(LEX(" "),-1)
- SET LEX(0)=$$SD^LEXQM(LEXVDT)
- +10 QUIT
- +11 ; Miscellaneous
- FA(X) ; First Activation
- +1 NEW LEXFA,LEXH,LEXI,LEXIEN,LEXSO,LEXSY
- +2 SET LEXIEN=+($GET(X))
- SET X=""
- SET LEXSO=$$CODEC^ICDEX(80.1,+LEXIEN)
- SET LEXSY=$$CSI^ICDEX(80.1,+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.1,+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
