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

ICPTCOD.m

Go to the documentation of this file. 
  1. ICPTCOD ;ALB/DEK/KER - CPT CODE APIS ; 04/18/2004
  1.  ;;6.0;CPT/HCPCS;**6,12,13,14,16,19**;May 19, 1997;Build 44
  1.  ;
  1.  ; External References
  1.  ;   DBIA  10103  $$DT^XLFDT
  1.  ;                         
  1.  Q
  1. CPT(CODE,CDT,SRC,DFN) ; returns basic info on CPT/HCPCS code
  1.  ;
  1.  ; Input:   CODE   CPT/HCPCS or IEN (Required)
  1.  ;          CDT    Date  (default = TODAY)
  1.  ;          SRC    Screen source
  1.  ;                   If '$G(SRC), check Level I and II codes only
  1.  ;                   If $G(SRC), check Level I, II, and III codes
  1.  ;          DFN    Not in use, future need
  1.  ; 
  1.  ; Output:  Returns a 10 piece string delimited ^
  1.  ; 
  1.  ;            1  IEN of code in ^ICPT
  1.  ;            2  CPT Code (.01 field)
  1.  ;            3  Versioned Short Name (from #61 multiple)
  1.  ;            4  Category IEN (#3 field)
  1.  ;            5  Source (#6 field) C:CPT; H:HCPCS; L:VA LOCAL
  1.  ;            6  Effective Date (from #60 multiple)
  1.  ;            7  Status (from #60 multiple)
  1.  ;            8  Inactivation Date (from #60 multiple)
  1.  ;            9  Activation Date (from #60 multiple)
  1.  ;           10  Message (CODE TEXT MAY BE INACCURATE)
  1.  ; 
  1.  ;            or 
  1.  ; 
  1.  ;           -1^Error Description
  1.  ; 
  1.  N DATA,EFF,STR,VCPT
  1.  I $G(CODE)="" S STR="-1^NO CODE SELECTED" G CPTQ
  1.  S CODE=$G(CODE),CODE=$S(CODE?1.N:+CODE,1:$$CODEN(CODE))
  1.  I CODE<1!'$D(^ICPT(CODE)) S STR="-1^NO SUCH ENTRY" G CPTQ
  1.  I '$G(SRC),$P(^ICPT(CODE,0),"^",6)="L" S STR="-1^VA LOCAL CODE SELECTED" G CPTQ
  1.  S DATA=$G(^ICPT(CODE,0))
  1.  I '$L(DATA) S STR="-1^NO DATA" G CPTQ
  1.  S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(CDT))
  1.  S VCPT=$$VSTCP(CODE,CDT)
  1.  S STR=CODE_"^"_DATA,$P(STR,"^",5)=$P(STR,"^",7),STR=$P(STR,"^",1,5)
  1.  S EFF=$$EFF^ICPTSUPT(81,CODE,CDT) S:EFF<1 $P(EFF,"^",2)=0
  1.  S STR=STR_"^"_EFF_"^"_$$MSG^ICPTSUPT(CDT) S:$L(VCPT) $P(STR,"^",3)=VCPT
  1. CPTQ Q STR
  1.  ;
  1. CPTD(CODE,OUTARR,DFN,CDT) ; Returns CPT description
  1.  ;
  1.  ; Input:   CODE   CPT/HCPCS code or IEN (Required)
  1.  ;          OUTARR Output Array Name for description
  1.  ;                   e.g. "ABC" or "ABC("TEST")" 
  1.  ;                   Default = ^TMP("ICPTD",$J)
  1.  ;          DFN    Not in use, future need
  1.  ;          CDT    Date (default = TODAY)
  1.  ; 
  1.  ; Output:  #      Number of lines in description
  1.  ; 
  1.  ;          @OUTARR(1:n) - Versioned Description (lines 1-n) (from the 62 multiple)
  1.  ;          @OUTARR(n+1) - blank
  1.  ;          @OUTARR(n+1) - a message stating: CODE TEXT MAY BE INACCURATE
  1.  ; 
  1.  ;           or
  1.  ; 
  1.  ;          -1^Error Description
  1.  ;
  1.  ; ** NOTE - User must initialize ^TMP("ICPTD",$J), if used **
  1.  ;
  1.  N ARR,END,I,N,CTV
  1.  I $G(CODE)="" S N="-1^NO CODE SELECTED" G CPTDQ
  1.  I $G(OUTARR)="" S OUTARR="^TMP(""ICPTD"",$J,"
  1.  I OUTARR'["(" S OUTARR=OUTARR_"("
  1.  I OUTARR[")" S OUTARR=$P(OUTARR,")")
  1.  S END=$E(OUTARR,$L(OUTARR)) I END'="("&(END'=",") S OUTARR=OUTARR_","
  1.  I OUTARR="^TMP(""ICPTD"",$J," K ^TMP("ICPTD",$J)
  1.  S CODE=$S(CODE?1.N:+CODE,1:$$CODEN(CODE)),I=0,N=0
  1.  I CODE<1!'$D(^ICPT(CODE)) S N="-1^NO SUCH CODE" G CPTDQ
  1.  S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(CDT))
  1.  D VLTCP(+CODE,CDT,.CTV) S (N,I)=0 F  S I=$O(CTV(I)) Q:+I=0  D
  1.  . S N=N+1,ARR=OUTARR_N_")",@ARR=$$TRIM($G(CTV(I)))
  1.  I +N>0 S N=N+1,ARR=OUTARR_N_")",@ARR=" ",N=N+1,ARR=OUTARR_N_")",@ARR=$$MSG^ICPTSUPT(CDT,1)
  1.  I +N'>0 S N="-1^VERSIONED DESCRIPTION NOT FOUND FOR MODIFIER "_$P($G(^DIC(81.3,+CODE,0)),"^",1)
  1. CPTDQ Q N
  1.  ;
  1. CODM(CODE,OUTARR,SRC,CDT,DFN) ; returns list of modifiers for a code
  1.  ; 
  1.  ; Input:   CODE  CPT/HCPCS code, Internal or External Format (Required)
  1.  ;          ARY   Array Name for list returned
  1.  ;                  e.g. "ABC" or "ABC("TEST")"
  1.  ;                  Default = ^TMP("ICPTM",$J)
  1.  ;          SRC   Source Screen
  1.  ;                  If 0 or Null, check Level I/II code/modifiers
  1.  ;                  If >0, check Level I/II/III code/modifiers
  1.  ;          CDT   Date (default = TODAY)
  1.  ;          DFN   Not in use, future need
  1.  ; 
  1.  ; Output:  #     Number of modifiers that apply
  1.  ; 
  1.  ;          OUTARR Array in the format: 
  1.  ; 
  1.  ;                 ARY(Mod) = Versioned Name^Mod IEN 
  1.  ; 
  1.  ;                 Where
  1.  ;                   Mod is the .01 field)
  1.  ;                   Versioned Name is 1 field of the 61 multiple
  1.  ; 
  1.  ;           or 
  1.  ; 
  1.  ;           -1^Error Description
  1.  ; 
  1.  ;   ** NOTE - User must initialize ^TMP("ICPTM",$J) array if used **
  1.  ;
  1.  N ARR,CODI,CODA,BR,END,ER,MD,MDST,MI,MN,STR,CODEC,ACTMD,MVST
  1.  S CDT=$G(CDT)
  1.  I $G(CODE)="" S STR="-1^NO CPT SELECTED" G CODMQ
  1.  I $G(OUTARR)="" S OUTARR="^TMP(""ICPTM"",$J,"
  1.  S STR=0,CODI=$S(CODE?1.N:+CODE,1:$$CODEN(CODE))
  1.  I CODI<1!'$D(^ICPT(CODI,0)) S STR="-1^NO SUCH CODE" G CODMQ
  1.  I '$G(SRC),$P(^ICPT(CODI,0),"^",6)="L" S STR="-1^VA LOCAL CODE SELECTED" G CODMQ
  1.  S CODEC=$$CODEC(CODI),CODA=$$NUM^ICPTAPIU(CODEC)
  1.  I OUTARR'["(" S OUTARR=OUTARR_"("
  1.  I OUTARR[")" S OUTARR=$P(OUTARR,")")
  1.  S END=$E(OUTARR,$L(OUTARR)) I END'="("&(END'=",") S OUTARR=OUTARR_","
  1.  I OUTARR="^TMP(""ICPTM"",$J," K ^TMP("ICPTM",$J)
  1.  S:$G(CDT)]"" CDT=$$DTBR^ICPTSUPT(CDT)
  1.  S BR="" F  S BR=$O(^DIC(81.3,"M",BR)) Q:BR>CODA!'BR  D
  1.  .S ER="" F  S ER=$O(^DIC(81.3,"M",BR,ER)) Q:'ER  I CODA'>ER D
  1.  ..S MI=0 F  S MI=$O(^DIC(81.3,"M",BR,ER,MI)) Q:'MI  D
  1.  ...S MDST=$G(^DIC(81.3,MI,0)) Q:'$L(MDST)
  1.  ...I '$G(SRC) Q:$P(MDST,"^",4)="V"
  1.  ...I $G(CDT) S ACTMD="",ACTMD=$$MOD^ICPTMOD(MI,"I",CDT,$G(SRC)) Q:($P(ACTMD,"^")=-1)!($P(ACTMD,"^",7)=0)
  1.  ...S MD=$P(MDST,"^",1,2),MN=$P(MD,"^")
  1.  ...I $L(MN)'=2 Q
  1.  ...S MVST=$$VSTCM^ICPTMOD(MI,CDT)
  1.  ...S ARR=OUTARR_""""_MN_""")",@ARR=MVST_"^"_MI,STR=STR+1
  1.  I 'STR S STR=0
  1. CODMQ Q STR
  1.  ;
  1. CODEN(CODE) ; Rreturn the IEN of a CPT/HCPCS code
  1.  ;
  1.  ;   Input:  CPT/HCPCS code
  1.  ;  Output:  ien of code
  1.  ;
  1.  I $G(CODE)="" Q -1
  1.  N COD
  1.  S COD=+$O(^ICPT("B",CODE,0))
  1.  Q $S(COD>0:COD,1:-1)
  1.  ;
  1. CODEC(CODE) ; Return the CPT/HCPCS Code
  1.  ;
  1.  ;  Input: IEN of CPT/HCPCS code
  1.  ; Output: CPT/HCPCS code
  1.  ;
  1.  I $G(CODE)="" Q -1
  1.  N Y
  1.  S Y=$P($G(^ICPT(CODE,0)),"^")
  1.  Q $S(Y="":-1,1:Y)
  1.  ;
  1. VALCPT(CODE,CDT,SRC,DFN) ;check if CPT code is valid for selection
  1.  ;
  1.  ; Input:
  1.  ;
  1.  ;    CODE - CPT or HCPCS code, ien or .01 format, REQUIRED
  1.  ;    CTD  - Date, default = today
  1.  ;    SRC  - SCREEN SOURCE
  1.  ;              '$G(SRC) level 1, Level 2 only
  1.  ;              $G(SRC) include level 3
  1.  ;    DFN  - not in use, future need
  1.  ;
  1.  ; Output: STR:  1                  if valid code for selection
  1.  ;              -1^error message    if not selectable
  1.  ;
  1.  N STR
  1.  S CODE=$G(CODE),SRC=$G(SRC),DFN=$G(DFN)
  1.  S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(CDT)) ;date business rules
  1.  S STR=$$CPT(CODE,CDT,SRC,DFN)
  1.  I STR<0 G VALCPTQ
  1.  I '$P(STR,"^",7) S STR="-1^INACTIVE CODE"
  1.  I STR>0 S STR=1
  1. VALCPTQ Q STR
  1.  ;
  1.  ;
  1.  Q
  1. VST(IEN,VDATE,TYPE)     ; Versioned Short Text
  1.  Q:TYPE["ICPT(" $$VSTCP($G(IEN),$G(VDATE))
  1.  Q:TYPE["DIC(81.3" $$VSTCM^ICPTMOD($G(IEN),$G(VDATE))
  1.  Q ""
  1. VSTCP(IEN,VDATE) ; Versioned Short Text (CPT Procedure)
  1.  N CPT0,CPTC,CPTI,CPTSTD,CPTSTI,CPTVDT,CPTTXT
  1.  S CPTI=+($G(IEN)) Q:+CPTI'>0 ""  Q:'$D(^ICPT(+CPTI)) ""
  1.  S CPTVDT=$G(VDATE) S:'$L(CPTVDT)!(+CPTVDT'>0) CPTVDT=$$DT^XLFDT Q:CPTVDT\1'?7N ""
  1.  S CPT0=$G(^ICPT(+CPTI,0)),CPTC=$P(CPT0,"^",1) Q:'$L(CPTC) ""
  1.  S CPTSTD=$O(^ICPT("AST",(CPTC_" "),(CPTVDT+.000001)),-1)
  1.  I +CPTSTD>0 D  Q:$L($G(CPTTXT)) $G(CPTTXT)
  1.  . S CPTSTI=$O(^ICPT("AST",(CPTC_" "),CPTSTD,+CPTI," "),-1),CPTTXT=$$TRIM($P($G(^ICPT(+CPTI,61,+CPTSTI,0)),"^",2))
  1.  S CPTSTD=$O(^ICPT(+CPTI,61,"B",0)) I +CPTSTD>0 D  Q:$L($G(CPTTXT)) $G(CPTTXT)
  1.  . S CPTSTI=$O(^ICPT(+CPTI,61,"B",CPTSTD,0)),CPTTXT=$$TRIM($P($G(^ICPT(+CPTI,61,+CPTSTI,0)),"^",2))
  1.  Q $$TRIM($P(CPT0,"^",2))
  1. VLTCP(IEN,VDATE,ARY) ; Versioned Description - Long Text (CPT Procedure)
  1.  N CPT0,CPTC,CPTI,CPTSTD,CPTSTI,CPTVDT,CPTTXT,CPTD,CPTT,CPTE
  1.  S CPTI=+($G(IEN)) Q:+CPTI'>0  Q:'$D(^ICPT(+CPTI))
  1.  S CPTVDT=$G(VDATE) S:'$L(CPTVDT)!(+CPTVDT'>0) CPTVDT=$$DT^XLFDT Q:CPTVDT\1'?7N
  1.  S CPT0=$G(^ICPT(+CPTI,0)),CPTC=$P(CPT0,"^",1) Q:'$L(CPTC)
  1.  S CPTSTD=$O(^ICPT("ADS",(CPTC_" "),(CPTVDT+.000001)),-1)
  1.  I +CPTSTD>0 D  Q:+($O(ARY(0)))>0
  1.  . S CPTSTI=$O(^ICPT("ADS",(CPTC_" "),CPTSTD,+CPTI," "),-1)
  1.  . S (CPTD,CPTT)=0 F  S CPTD=$O(^ICPT(+CPTI,62,CPTSTI,1,CPTD)) Q:+CPTD=0  D
  1.  . . S CPTT=CPTT+1,ARY(CPTT)=$$TRIM($G(^ICPT(+CPTI,62,+CPTSTI,1,+CPTD,0))),ARY(0)=CPTT
  1.  S CPTSTD=$O(^ICPT(+CPTI,62,"B",0)) I +CPTSTD>0 D  Q:+($O(ARY(0)))>0
  1.  . S CPTSTI=$O(^ICPT(+CPTI,62,"B",CPTSTD,0))
  1.  . S (CPTD,CPTT)=0 F  S CPTD=$O(^ICPT(+CPTI,62,CPTSTI,1,CPTD)) Q:+CPTD=0  D
  1.  . . S CPTT=CPTT+1,ARY(CPTT)=$$TRIM($G(^ICPT(+CPTI,62,+CPTSTI,1,+CPTD,0))),ARY(0)=CPTT
  1.  K ARY S (CPTD,CPTT)=0 F  S CPTD=$O(^ICPT(CPTI,"D",CPTD)) Q:+CPTD=0  D
  1.  . S CPTT=CPTT+1,ARY(CPTT)=$$TRIM($G(^ICPT(CPTI,"D",CPTD,0))),ARY(0)=CPTT
  1.  Q
  1. TRIM(X) ; Trim Spaces
  1.  S X=$G(X) Q:X="" X F  Q:$E(X,1)'=" "  S X=$E(X,2,$L(X))
  1.  F  Q:$E(X,$L(X))'=" "  S X=$E(X,1,($L(X)-1))
  1.  F  Q:X'["  "  S X=$P(X,"  ",1)_" "_$P(X,"  ",2,229)
  1.  Q X