Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEXQCP

LEXQCP.m

Go to the documentation of this file. 
  1. LEXQCP ;ISL/KER - Query - CPT Procedures - Extract ;04/21/2014
  1.  ;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
  1.  ;               
  1.  ; Global Variables
  1.  ;    ^ICPT(              ICR   4489
  1.  ;               
  1.  ; External References
  1.  ;    $$CPTD^ICPTCOD      ICR   1995
  1.  ;    $$CPT^ICPTCOD       ICR   1995
  1.  ;    $$DT^XLFDT          ICR  10103
  1.  ;    $$GET1^DIQ          ICR   2056
  1.  ;    $$UP^XLFSTR         ICR  10104
  1.  ;    GETS^DIQ            ICR   2056
  1.  ;               
  1. EN ; Main Entry Point
  1.  N LEXENV S LEXENV=$$EV^LEXQM Q:+LEXENV'>0
  1.  N LEXAD,LEXEDT,LEXCDT,LEXEXIT,LEXTEST S LEXEXIT=0,LEXCDT=""
  1.  W ! F  S LEXCDT=$$AD^LEXQM,LEXAD=LEXCDT Q:'$L(LEXCDT)  S LEXEDT=$P(LEXCDT,"^",1),LEXCDT=$P(LEXCDT,"^",2) Q:LEXCDT'?7N  D LOOK Q:LEXCDT'?7N  Q:+LEXEXIT>0
  1.  Q
  1. LOOK ; CPT Lookup Loop
  1.  S LEXCDT=$G(LEXCDT),LEXEDT=$$ED^LEXQM(LEXCDT) I LEXCDT'?7N S LEXCDT="" Q
  1.  N LEXCPT,LEXCPTC S LEXLEN=62
  1.  F  S LEXCPT=$$CPT^LEXQCPA S:LEXCPT="^^" LEXEXIT=1 Q:LEXCPT="^"!(LEXCPT="^^")  D  Q:LEXCPT="^"!(LEXCPT="^^")
  1.  . K LEXGET,LEXST,LEXSD,LEXLD,LEXMD,LEXLX,LEXWN N LEXIEN,LEXLDT,LEXELDT,LEXINC,LEXFA
  1.  . S LEXIEN=+($G(LEXCPT)),LEXLDT=+($G(LEXCDT)),LEXFA=$$FA^LEXQCP2(+LEXIEN)
  1.  . Q:+LEXIEN'>0  Q:LEXLDT'?7N  S LEXELDT=$$SD^LEXQM(LEXLDT) Q:'$L(LEXELDT)
  1.  . S LEXINC=0 I LEXFA?7N,LEXCDT?7N,LEXFA'>LEXCDT D
  1.  . . S LEXINC=$$INC^LEXQCPA Q:LEXINC["^"
  1.  . D CSV,EN^LEXQCP2
  1.  Q
  1. CSV ; Code Set Versioning Display
  1.  N LEXEDT,LEXIEN,LEXIENS,LEXLTXT,LEXSO,LEXSTAT
  1.  S LEXCDT=$G(LEXCDT),LEXEDT=$$ED^LEXQM(LEXCDT) I LEXCDT'?7N S (LEXCPT,LEXCDT)="" Q
  1.  S LEXIEN=+($G(LEXCPT)),LEXSO=$P($G(LEXCPT),"^",2),LEXLTXT=$P($G(LEXCPT),"^",3) Q:+LEXIEN'>0  Q:'$L(LEXSO)
  1.  ;
  1.  ; Get the "Unversioned" Fields
  1.  ;   
  1.  ;   CPT Code                    Field .01
  1.  ;   CPT Major Category          Field 3
  1.  ;   CPT Sub-Category            Field 3
  1.  ;   Age Low                     Field 10.01
  1.  ;   Age High                    Field 10.02
  1.  ;   Sex                         Field 10.03
  1.  ;
  1.  S LEXIENS=LEXIEN_"," D GETS^DIQ(81,LEXIENS,".01;3;10.01;10.02;10.03","IE","LEXGET","LEXMSG")
  1.  I $G(LEXGET(81,LEXIENS,3,"I"))>0,$L($G(LEXGET(81,LEXIENS,3,"I"))) D
  1.  . S LEXGET(81,LEXIENS,3,2)=$$GET1^DIQ(81.1,(+($G(LEXGET(81,LEXIENS,3,"I")))_","),.01)
  1.  . S LEXGET(81,LEXIENS,3,1)=$$GET1^DIQ(81.1,(+($G(LEXGET(81,LEXIENS,3,"I")))_","),3)
  1.  . I $L($G(LEXGET(81,LEXIENS,3,2))),'$L($G(LEXGET(81,LEXIENS,3,1))) S LEXGET(81,LEXIENS,3,1)=$G(LEXGET(81,LEXIENS,3,2)) K LEXGET(81,LEXIENS,3,2)
  1.  . I $G(LEXGET(81,LEXIENS,3,2))=$G(LEXGET(81,LEXIENS,3,1)) K LEXGET(81,LEXIENS,3,2)
  1.  . I '$L($G(LEXGET(81,LEXIENS,3,2))),'$L($G(LEXGET(81,LEXIENS,3,1))) K LEXGET(81,LEXIENS,3,1),LEXGET(81,LEXIENS,3,2)
  1.  ; Get the "Versioned" Fields
  1.  ;                
  1.  ;   Effective Date and Status   Sub-File 81.02   (60)
  1.  S LEXST=$$EF(+($G(LEXIEN)),+LEXCDT),LEXSTAT=+($P(LEXST,"^",2))
  1.  ;   Procedure Name              Sub-File 81.061  (61)
  1.  D SDS(+($G(LEXIEN)),+LEXCDT,.LEXSD,62,LEXSTAT)
  1.  ;   Description                 Sub-File 81.062  (62)
  1.  D LDS(+($G(LEXIEN)),+LEXCDT,.LEXLD,62,LEXSTAT)
  1.  ;   Lexicon Expression          
  1.  D LX(+($G(LEXIEN)),+LEXCDT,.LEXLX,62,LEXSTAT)
  1.  D WN^LEXQCP2(+LEXCDT,.LEXWN,62)
  1.  D MOD^LEXQCP2(+($G(LEXIEN)),+LEXCDT,.LEXMD,62,LEXSTAT)
  1.  Q
  1.  ;            
  1. EF(X,LEXCDT) ; Effective Dates
  1.  N LEX,LEXBRD,LEXBRW,LEXAD,LEXEE,LEXEF,LEXES,LEXFA,LEXH,LEXI,LEXID,LEXIEN,LEXLS,LEXSO,LEXST S LEXIEN=+($G(X)),LEXCDT=+($G(LEXCDT))
  1.  Q:+LEXIEN'>0 "^^"  Q:'$L(^ICPT(+LEXIEN,0)) "^^"  Q:LEXCDT'?7N "^^"  S LEXSO=$P($G(^ICPT(+LEXIEN,0)),"^",1),LEXBRD=2890101,LEXBRW=""
  1.  S LEX=$$CPT^ICPTCOD(LEXSO,LEXCDT) S LEXFA=$$FA^LEXQCP2(+LEXIEN) S (LEXLS,LEXST)=$P(LEX,"^",7),LEXID=$P(LEX,"^",8)
  1.  S:LEXCDT<LEXBRD&(+LEXFA=LEXBRD) LEXBRW="Warning:  The 'Based on Date' provided precedes the initial Code Set Business Rule date of "_$$SD^LEXQM(LEXBRD)_", the Effective date may be inaccurate."
  1.  S LEXAD=$P(LEX,"^",9),LEXES=$S(+LEXST>0:"Active",1:"Inactive")
  1.  S:+LEXST'>0&(+LEXAD'>0) LEXES="Not Applicable",LEXLS=-1
  1.  S:+LEXFA>0&(+LEXCDT>0)&(LEXFA>LEXCDT) LEXES="Pending",LEXLS=-1,LEXST=0,LEXBRW=""
  1.  S:LEXST>0 LEXEF=LEXAD S:LEXST'>0 LEXEF=LEXID
  1.  S:LEXST'>0&(+LEXID'>0) LEXEF=LEXFA S LEXEE=$$SD^LEXQM(LEXEF)
  1.  I LEXST'>0,+LEXID'>0,$L(LEXEE),+LEXEF>LEXCDT S LEXEE="(future activation of "_LEXEE_")",LEXEF=""
  1.  S X=LEXLS_"^"_LEXST_"^"_LEXEF_"^"_LEXES_"^"_LEXEE S:$L(LEXBRW) $P(X,"^",6)=LEXBRW
  1.  Q X
  1.  ;            
  1. SDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Procedure Name (short description)
  1.  ;            
  1.  ; LEX=# of Lines
  1.  ; LEX(0)=External Date of Procedure Name
  1.  ; LEX(#)=Procedure Name
  1.  ;            
  1.  N LEXD,LEXBRD,LEXBRW,LEXDDT,LEXE,LEXEE,LEXEFF,LEXFA,LEXHIS,LEXI,LEXIA,LEXIEN,LEXL,LEXLAST,LEXLEF,LEXLHI,LEXM,LEXR,LEXSDT,LEXSO,LEXLSD,LEXT
  1.  S LEXIEN=$G(X) Q:+LEXIEN'>0  Q:'$D(^ICPT(+LEXIEN,61))  S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT S LEXSTA=+($G(LEXSTA))
  1.  S LEXSO=$P($G(^ICPT(+LEXIEN,0)),"^",1),LEXLAST=$$CPT^ICPTCOD(LEXSO),LEXLSD=$P(LEXLAST,"^",3),LEXBRD=2890101,LEXBRW=""
  1.  S:$D(LEXGET)&($L(LEXLSD)) LEXGET(81,(+LEXIEN_","),"B")=LEXLSD
  1.  S LEXLEN=+($G(LEXLEN)) S:+LEXLEN'>0 LEXLEN=62 S LEXFA=$$FA^LEXQCP2(+LEXIEN),LEXM=""
  1.  S LEXM="" S:+LEXVDT<LEXFA&(LEXFA'=LEXBRD) LEXM="Procedure Short Name is not available.  The date provided precedes the initial activation of the code"
  1.  I $L(LEXM) D  Q
  1.  . K LEX N LEXT,LEXI S LEXT(1)=LEXM D PR^LEXQM(.LEXT,(LEXLEN-7))
  1.  . S LEXI=0 F  S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0  S LEXT=$G(LEXT(LEXI)) S LEX(LEXI)=LEXT
  1.  . S:$D(LEX(1)) LEX(0)="--/--/----" S LEX=+($O(LEX(" "),-1))
  1.  S LEXM="" S LEXEFF=$O(^ICPT(LEXIEN,61,"B",(LEXVDT+.001)),-1),LEXHIS=$O(^ICPT(LEXIEN,61,"B",+LEXEFF," "),-1),LEXSDT=$P($G(^ICPT(+LEXIEN,61,+LEXHIS,0)),"^",2)
  1.  S LEXLEF=$O(^ICPT(LEXIEN,61,"B",(9999999+.001)),-1),LEXLHI=$O(^ICPT(LEXIEN,61,"B",+LEXLEF," "),-1),LEXDDT=$P($G(^ICPT(+LEXIEN,61,+LEXLHI,0)),"^",2)
  1.  S (LEXD,LEXE,LEXR)="" S:$L(LEXSDT)&(LEXEFF?7N) LEXD=LEXSDT,LEXE=LEXEFF
  1.  S:$L(LEXDDT)&(LEXLEF?7N)&('$L(LEXD))&('$L(LEXE)) LEXD=LEXDDT,LEXE=LEXLEF,LEXR="No Text Available for Date Provided"
  1.  K LEX S LEX(1)=LEXD S:$L(LEXD) LEXGET(81,(+LEXIEN_","),"B")=LEXD
  1.  S LEXEE=$$SD^LEXQM(LEXE) S:$D(LEXTEST)&(+LEXSTA'>0) LEXEE="--/--/----" S:$L(LEX(1)) LEX(0)=LEXEE
  1.  S LEX=+($O(LEX(" "),-1))
  1.  Q
  1. LDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Long Description
  1.  ;            
  1.  ; LEX=# of Lines
  1.  ; LEX(0)=External Date of Description
  1.  ; LEX(#)=Description
  1.  ; LEX(#)=Description continued
  1.  ;            
  1.  N LEXC,LEXBRD,LEXBRW,LEXDDT,LEXEVDT,LEXFA,LEXI,LEXIEN,LEXL,LEXLN,LEXM,LEXT,LEXSO,LEXTL,LEXTMP S LEXIEN=$G(X) Q:+LEXIEN'>0  Q:'$D(^ICPT(+LEXIEN,62))
  1.  S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT S LEXEVDT=$$SD^LEXQM(LEXVDT),LEXLEN=+($G(LEXLEN)) S:+LEXLEN'>0 LEXLEN=62
  1.  S LEXSO=$P($G(^ICPT(+LEXIEN,0)),"^",1) S LEXFA=$$FA^LEXQCP2(+LEXIEN),LEXM="" S LEXSTA=+($G(LEXSTA)),LEXBRD=2890101,LEXBRW=""
  1.  S LEXM="" S:+LEXVDT<LEXFA&(LEXFA'=LEXBRD) LEXM="Description is not available.  The date provided precedes the initial activation of the code"
  1.  I $L(LEXM) D  Q
  1.  . K LEX N LEXT,LEXI 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 LEX(LEXI)=LEXT
  1.  . S:$D(LEX(1)) LEX(0)="--/--/----" S LEX=+($O(LEX(" "),-1))
  1.  K LEXTMP S LEXTL=$$CPTD^ICPTCOD(LEXSO,"LEXTMP",,LEXVDT) S LEXL=+($O(LEXTMP(" "),-1)),LEXLN=$G(LEXTMP(+LEXL))
  1.  S LEXM="" K:LEXL>0&(LEXLN["CODE TEXT MAY BE INACCURATE") LEXTMP(+LEXL)
  1.  F LEXI=1:1:2 S LEXL=+($O(LEXTMP(" "),-1)),LEXLN=$$TM^LEXQM($G(LEXTMP(+LEXL))) K:LEXL>0&('$L(LEXLN)) LEXTMP(+LEXL)
  1.  S LEXDDT=$O(^ICPT(+LEXIEN,62,"B",(LEXVDT+.999999)),-1) S:LEXDDT'?7N LEXDDT=$O(^ICPT(+LEXIEN,62,"B",0)) S:LEXDDT?7N LEXEVDT=$$SD^LEXQM(LEXDDT)
  1.  D PR^LEXQM(.LEXTMP,LEXLEN) K LEX F LEXI=1:1:13 D
  1.  . Q:'$D(LEXTMP(LEXI))  S LEXT=$$TM^LEXQM($G(LEXTMP(LEXI))),LEX(LEXI)=$$UP^XLFSTR(LEXT)
  1.  I $L(LEXM) D
  1.  . N LEXT,LEXI,LEXL,LEXC S LEXL=+($O(LEX(" "),-1)),LEXC=0 S LEXT(1)=LEXM D PR^LEXQM(.LEXT,(LEXLEN-7))
  1.  . S LEXI=0 F  S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0  D
  1.  . . S LEXT=$G(LEXT(LEXI)) S:$L(LEXT) LEXC=LEXC+1 S LEXL=LEXL+1,LEX(LEXL)=LEXT
  1.  S:$D(LEXTEST)&(+LEXSTA'>0) LEXEVDT="--/--/----" S:$D(LEX(1)) LEX(0)=LEXEVDT S LEX=+($O(LEX(" "),-1))
  1.  Q
  1. LX(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Lexicon Expression
  1.  ;            
  1.  ; LEX=# of Lines
  1.  ; LEX(0)=External Date of Expression
  1.  ; LEX(#)=Expression
  1.  ; LEX(#)=Expression continued
  1.  ;            
  1.  N LEXEF,LEXEVDT,LEXLEX,LEXEE,LEXFA,LEXI,LEXIA,LEXIEN,LEXLEF,LEXLHS,LEXLST,LEXM,LEXN0,LEXPF,LEXSAB,LEXSIEN,LEXSO,LEXT,LEXVTMP
  1.  S LEXIEN=$G(X) Q:+LEXIEN'>0  Q:'$D(^ICPT(+LEXIEN,0))  S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT S LEXSTA=+($G(LEXSTA))
  1.  S LEXEVDT=$$SD^LEXQM(LEXVDT),LEXLEN=+($G(LEXLEN)) S:+LEXLEN'>0 LEXLEN=62  Q:'$L(LEXEVDT)
  1.  S LEXSO=$P($G(^ICPT(+LEXIEN,0)),"^",1) Q:'$L(LEXSO)  S LEXFA=$$FA^LEXQCP2(+LEXIEN),LEXM="",LEXIA=$$IA(LEXVDT)
  1.  S LEXSIEN=0 F  S LEXSIEN=$O(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN)) Q:+LEXSIEN'>0  D
  1.  . N LEXN0 S LEXN0=$G(^LEX(757.02,+LEXSIEN,0)),LEXSAB=$P(LEXN0,"^",3)
  1.  . Q:"^3^4^"'[("^"_LEXSAB_"^")  S LEXPF=+($P(LEXN0,"^",5)) S LEXLEF=$O(^LEX(757.02,+LEXSIEN,4,"B",(LEXVDT+.99999)),-1) I LEXLEF?7N D
  1.  . . S LEXLHS=$O(^LEX(757.02,+LEXSIEN,4,"B",+LEXLEF," "),-1) I +LEXLHS>0 D
  1.  . . . S LEXLST=$G(^LEX(757.02,+LEXSIEN,4,+LEXLHS,0)),LEXLST=$P(LEXLST,"^",2)
  1.  . . . S:LEXLST>0 LEXVTMP(+LEXPF,LEXSIEN)=+LEXN0_"^"_LEXLEF
  1.  S (LEXLEX,LEXEF)="",LEXSIEN=$O(LEXVTMP(1,0)),LEXLEX=+($G(LEXVTMP(1,+LEXSIEN))),LEXEF=$P($G(LEXVTMP(1,+LEXSIEN)),"^",2)
  1.  S:+LEXSIEN'>0!(+LEXLEX'>0) LEXSIEN=$O(LEXVTMP(0,0)),LEXLEX=+($G(LEXVTMP(0,+LEXSIEN))),LEXEF=$P($G(LEXVTMP(0,+LEXSIEN)),"^",2)
  1.  K LEX I +LEXLEX>0,$L($G(^LEX(757.01,+LEXLEX,0))),$L(LEXEF),LEXEF?7N  D  Q
  1.  . K LEX N LEXT,LEXM,LEXI S LEXT(1)=$G(^LEX(757.01,+LEXLEX,0)) D PR^LEXQM(.LEXT,(LEXLEN-7))
  1.  . S LEXI=0 F  S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0  S:$L($G(LEXT(LEXI))) LEX(+LEXI)=$G(LEXT(LEXI))
  1.  . S LEX=+($O(LEX(" "),-1)) S LEXEE=$$SD^LEXQM(LEXEF) S:$D(LEXTEST)&(+LEXSTA'>0) LEXEE="--/--/----" S LEX(0)=LEXEE
  1.  Q
  1.  ; Miscellaneous
  1. IA(X) ;   Inaccurate
  1.  N LEXBRD,LEXVDT,LEXSYS S LEXVDT=+($G(X)),LEXSYS=1,LEXVDT=$S($G(LEXVDT)="":$$DT^XLFDT,1:$$DBR(LEXVDT)),LEXBRD=3021001,X=$S(LEXVDT<LEXBRD:1,1:0)
  1.  Q X
  1. DBR(X) ;   Date Business Rules
  1.  N LEXVDT S LEXVDT=$G(X) Q:'$G(LEXVDT)!($P(LEXVDT,".")'?7N) $$DT^XLFDT
  1.  S:LEXVDT#10000=0 LEXVDT=LEXVDT+101 S:LEXVDT#100=0 LEXVDT=LEXVDT+1 S X=$S(LEXVDT<2890101:2890101,1:LEXVDT)
  1.  Q X