ICPTCOD ;ALB/DEK/KER - CPT CODE APIS ;11/29/2007
;;6.0;CPT/HCPCS;**6,12,13,14,16,19,40**;May 19, 1997;Build 6
;
; External References
; DBIA 10103 $$DT^XLFDT
;
Q
CPT(CODE,CDT,SRC,DFN) ; returns basic info on CPT/HCPCS code
;
; Input: CODE CPT/HCPCS or IEN (Required)
; CDT Date (default = TODAY)
; SRC Screen source
; If '$G(SRC), check Level I and II codes only
; If $G(SRC), check Level I, II, and III codes
; DFN Not in use, future need
;
; Output: Returns a 10 piece string delimited ^
;
; 1 IEN of code in ^ICPT
; 2 CPT Code (.01 field)
; 3 Versioned Short Name (from #61 multiple)
; 4 Category IEN (#3 field)
; 5 Source (#6 field) C:CPT; H:HCPCS; L:VA LOCAL
; 6 Effective Date (from #60 multiple)
; 7 Status (from #60 multiple)
; 8 Inactivation Date (from #60 multiple)
; 9 Activation Date (from #60 multiple)
; 10 Message (CODE TEXT MAY BE INACCURATE)
;
; or
;
; -1^Error Description
;
N DATA,EFF,STR,VCPT
I $G(CODE)="" S STR="-1^NO CODE SELECTED" G CPTQ
S CODE=$G(CODE),CODE=$S(CODE?1.N:+CODE,1:$$CODEN(CODE))
I CODE<1!'$D(^ICPT(CODE)) S STR="-1^NO SUCH ENTRY" G CPTQ
I '$G(SRC),$P(^ICPT(CODE,0),"^",6)="L" S STR="-1^VA LOCAL CODE SELECTED" G CPTQ
S DATA=$G(^ICPT(CODE,0))
I '$L(DATA) S STR="-1^NO DATA" G CPTQ
S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(CDT))
S VCPT=$$VSTCP(CODE,CDT)
S STR=CODE_"^"_DATA,$P(STR,"^",5)=$P(STR,"^",7),STR=$P(STR,"^",1,5)
S EFF=$$EFF^ICPTSUPT(81,CODE,CDT) S:EFF<1 $P(EFF,"^",2)=0
S STR=STR_"^"_EFF_"^"_$$MSG^ICPTSUPT(CDT) S:$L(VCPT) $P(STR,"^",3)=VCPT
CPTQ Q STR
;
CPTD(CODE,OUTARR,DFN,CDT) ; Returns CPT description
;
; Input: CODE CPT/HCPCS code or IEN (Required)
; OUTARR Output Array Name for description
; e.g. "ABC" or "ABC("TEST")"
; Default = ^TMP("ICPTD",$J)
; DFN Not in use, future need
; CDT Date (default = TODAY)
;
; Output: # Number of lines in description
;
; @OUTARR(1:n) - Versioned Description (lines 1-n) (from the 62 multiple)
; @OUTARR(n+1) - blank
; @OUTARR(n+1) - a message stating: CODE TEXT MAY BE INACCURATE
;
; or
;
; -1^Error Description
;
; ** NOTE - User must initialize ^TMP("ICPTD",$J), if used **
;
N ARR,END,I,N,CTV
I $G(CODE)="" S N="-1^NO CODE SELECTED" G CPTDQ
I $G(OUTARR)="" S OUTARR="^TMP(""ICPTD"",$J,"
I OUTARR'["(" S OUTARR=OUTARR_"("
I OUTARR[")" S OUTARR=$P(OUTARR,")")
S END=$E(OUTARR,$L(OUTARR)) I END'="("&(END'=",") S OUTARR=OUTARR_","
I OUTARR="^TMP(""ICPTD"",$J," K ^TMP("ICPTD",$J)
S CODE=$S(CODE?1.N:+CODE,1:$$CODEN(CODE)),I=0,N=0
I CODE<1!'$D(^ICPT(CODE)) S N="-1^NO SUCH CODE" G CPTDQ
S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(CDT))
D VLTCP(+CODE,CDT,.CTV) S (N,I)=0 F S I=$O(CTV(I)) Q:+I=0 D
. S N=N+1,ARR=OUTARR_N_")",@ARR=$$TRIM($G(CTV(I)))
I +N>0 S N=N+1,ARR=OUTARR_N_")",@ARR=" ",N=N+1,ARR=OUTARR_N_")",@ARR=$$MSG^ICPTSUPT(CDT,1)
I +N'>0 S N="-1^VERSIONED DESCRIPTION NOT FOUND FOR MODIFIER "_$P($G(^DIC(81.3,+CODE,0)),"^",1)
CPTDQ Q N
;
CODM(CODE,OUTARR,SRC,CDT,DFN) ; returns list of modifiers for a code
;
; Input: CODE CPT/HCPCS code, Internal or External Format (Required)
; ARY Array Name for list returned
; e.g. "ABC" or "ABC("TEST")"
; Default = ^TMP("ICPTM",$J)
; SRC Source Screen
; If 0 or Null, check Level I/II code/modifiers
; If >0, check Level I/II/III code/modifiers
; CDT Date (default = TODAY)
; DFN Not in use, future need
;
; Output: # Number of modifiers that apply
;
; OUTARR Array in the format:
;
; ARY(Mod) = Versioned Name^Mod IEN
;
; Where
; Mod is the .01 field)
; Versioned Name is 1 field of the 61 multiple
;
; or
;
; -1^Error Description
;
; ** NOTE - User must initialize ^TMP("ICPTM",$J) array if used **
;
N ARR,CODI,CODA,BR,END,ER,MD,MDST,MI,MN,STR,CODEC,ACTMD,MVST
S CDT=$G(CDT)
I $G(CODE)="" S STR="-1^NO CPT SELECTED" G CODMQ
I $G(OUTARR)="" S OUTARR="^TMP(""ICPTM"",$J,"
S STR=0,CODI=$S(CODE?1.N:+CODE,1:$$CODEN(CODE))
I CODI<1!'$D(^ICPT(CODI,0)) S STR="-1^NO SUCH CODE" G CODMQ
I '$G(SRC),$P(^ICPT(CODI,0),"^",6)="L" S STR="-1^VA LOCAL CODE SELECTED" G CODMQ
S CODEC=$$CODEC(CODI),CODA=$$NUM^ICPTAPIU(CODEC)
I OUTARR'["(" S OUTARR=OUTARR_"("
I OUTARR[")" S OUTARR=$P(OUTARR,")")
S END=$E(OUTARR,$L(OUTARR)) I END'="("&(END'=",") S OUTARR=OUTARR_","
I OUTARR="^TMP(""ICPTM"",$J," K ^TMP("ICPTM",$J)
S:$G(CDT)]"" CDT=$$DTBR^ICPTSUPT(CDT)
S BR="" F S BR=$O(^DIC(81.3,"M",BR)) Q:BR>CODA!'BR D
.S ER="" F S ER=$O(^DIC(81.3,"M",BR,ER)) Q:'ER I CODA'>ER D
..S MI=0 F S MI=$O(^DIC(81.3,"M",BR,ER,MI)) Q:'MI D
...N MDPS
...S MDST=$G(^DIC(81.3,MI,0)) Q:'$L(MDST)
...S MDPS=$$MODP^ICPTMOD(CODE,+MI,"I",$G(CDT),$G(SRC)) Q:+MDPS'>0
...I '$G(SRC) Q:$P(MDST,"^",4)="V"
...I $G(CDT) S ACTMD="",ACTMD=$$MOD^ICPTMOD(MI,"I",CDT,$G(SRC)) Q:($P(ACTMD,"^")=-1)!($P(ACTMD,"^",7)=0)
...S MD=$P(MDST,"^",1,2),MN=$P(MD,"^")
...I $L(MN)'=2 Q
...S MVST=$$VSTCM^ICPTMOD(MI,CDT)
...S ARR=OUTARR_""""_MN_""")",@ARR=MVST_"^"_MI,STR=STR+1
I 'STR S STR=0
CODMQ Q STR
;
CODEN(CODE) ; Rreturn the IEN of a CPT/HCPCS code
;
; Input: CPT/HCPCS code
; Output: ien of code
;
I $G(CODE)="" Q -1
N COD
S COD=+$O(^ICPT("B",CODE,0))
Q $S(COD>0:COD,1:-1)
;
CODEC(CODE) ; Return the CPT/HCPCS Code
;
; Input: IEN of CPT/HCPCS code
; Output: CPT/HCPCS code
;
I $G(CODE)="" Q -1
N Y
S Y=$P($G(^ICPT(CODE,0)),"^")
Q $S(Y="":-1,1:Y)
;
VALCPT(CODE,CDT,SRC,DFN) ;check if CPT code is valid for selection
;
; Input:
;
; CODE - CPT or HCPCS code, ien or .01 format, REQUIRED
; CTD - Date, default = today
; SRC - SCREEN SOURCE
; '$G(SRC) level 1, Level 2 only
; $G(SRC) include level 3
; DFN - not in use, future need
;
; Output: STR: 1 if valid code for selection
; -1^error message if not selectable
;
N STR
S CODE=$G(CODE),SRC=$G(SRC),DFN=$G(DFN)
S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(CDT)) ;date business rules
S STR=$$CPT(CODE,CDT,SRC,DFN)
I STR<0 G VALCPTQ
I '$P(STR,"^",7) S STR="-1^INACTIVE CODE"
I STR>0 S STR=1
VALCPTQ Q STR
;
;
Q
VST(IEN,VDATE,TYPE) ; Versioned Short Text
Q:TYPE["ICPT(" $$VSTCP($G(IEN),$G(VDATE))
Q:TYPE["DIC(81.3" $$VSTCM^ICPTMOD($G(IEN),$G(VDATE))
Q ""
VSTCP(IEN,VDATE) ; Versioned Short Text (CPT Procedure)
N CPT0,CPTC,CPTI,CPTSTD,CPTSTI,CPTVDT,CPTTXT
S CPTI=+($G(IEN)) Q:+CPTI'>0 "" Q:'$D(^ICPT(+CPTI)) ""
S CPTVDT=$G(VDATE) S:'$L(CPTVDT)!(+CPTVDT'>0) CPTVDT=$$DT^XLFDT Q:CPTVDT\1'?7N ""
S CPT0=$G(^ICPT(+CPTI,0)),CPTC=$P(CPT0,"^",1) Q:'$L(CPTC) ""
S CPTSTD=$O(^ICPT("AST",(CPTC_" "),(CPTVDT+.000001)),-1)
I +CPTSTD>0 D Q:$L($G(CPTTXT)) $G(CPTTXT)
. S CPTSTI=$O(^ICPT("AST",(CPTC_" "),CPTSTD,+CPTI," "),-1),CPTTXT=$$TRIM($P($G(^ICPT(+CPTI,61,+CPTSTI,0)),"^",2))
S CPTSTD=$O(^ICPT(+CPTI,61,"B",0)) I +CPTSTD>0 D Q:$L($G(CPTTXT)) $G(CPTTXT)
. S CPTSTI=$O(^ICPT(+CPTI,61,"B",CPTSTD,0)),CPTTXT=$$TRIM($P($G(^ICPT(+CPTI,61,+CPTSTI,0)),"^",2))
Q $$TRIM($P(CPT0,"^",2))
VLTCP(IEN,VDATE,ARY) ; Versioned Description - Long Text (CPT Procedure)
N CPT0,CPTC,CPTI,CPTSTD,CPTSTI,CPTVDT,CPTTXT,CPTD,CPTT,CPTE
S CPTI=+($G(IEN)) Q:+CPTI'>0 Q:'$D(^ICPT(+CPTI))
S CPTVDT=$G(VDATE) S:'$L(CPTVDT)!(+CPTVDT'>0) CPTVDT=$$DT^XLFDT Q:CPTVDT\1'?7N
S CPT0=$G(^ICPT(+CPTI,0)),CPTC=$P(CPT0,"^",1) Q:'$L(CPTC)
S CPTSTD=$O(^ICPT("ADS",(CPTC_" "),(CPTVDT+.000001)),-1)
I +CPTSTD>0 D Q:+($O(ARY(0)))>0
. S CPTSTI=$O(^ICPT("ADS",(CPTC_" "),CPTSTD,+CPTI," "),-1)
. S (CPTD,CPTT)=0 F S CPTD=$O(^ICPT(+CPTI,62,CPTSTI,1,CPTD)) Q:+CPTD=0 D
. . S CPTT=CPTT+1,ARY(CPTT)=$$TRIM($G(^ICPT(+CPTI,62,+CPTSTI,1,+CPTD,0))),ARY(0)=CPTT
S CPTSTD=$O(^ICPT(+CPTI,62,"B",0)) I +CPTSTD>0 D Q:+($O(ARY(0)))>0
. S CPTSTI=$O(^ICPT(+CPTI,62,"B",CPTSTD,0))
. S (CPTD,CPTT)=0 F S CPTD=$O(^ICPT(+CPTI,62,CPTSTI,1,CPTD)) Q:+CPTD=0 D
. . S CPTT=CPTT+1,ARY(CPTT)=$$TRIM($G(^ICPT(+CPTI,62,+CPTSTI,1,+CPTD,0))),ARY(0)=CPTT
K ARY S (CPTD,CPTT)=0 F S CPTD=$O(^ICPT(CPTI,"D",CPTD)) Q:+CPTD=0 D
. S CPTT=CPTT+1,ARY(CPTT)=$$TRIM($G(^ICPT(CPTI,"D",CPTD,0))),ARY(0)=CPTT
Q
TRIM(X) ; Trim Spaces
S X=$G(X) Q:X="" X F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,229)
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICPTCOD 8975 printed Oct 16, 2024@17:46:32 Page 2
ICPTCOD ;ALB/DEK/KER - CPT CODE APIS ;11/29/2007
+1 ;;6.0;CPT/HCPCS;**6,12,13,14,16,19,40**;May 19, 1997;Build 6
+2 ;
+3 ; External References
+4 ; DBIA 10103 $$DT^XLFDT
+5 ;
+6 QUIT
CPT(CODE,CDT,SRC,DFN) ; returns basic info on CPT/HCPCS code
+1 ;
+2 ; Input: CODE CPT/HCPCS or IEN (Required)
+3 ; CDT Date (default = TODAY)
+4 ; SRC Screen source
+5 ; If '$G(SRC), check Level I and II codes only
+6 ; If $G(SRC), check Level I, II, and III codes
+7 ; DFN Not in use, future need
+8 ;
+9 ; Output: Returns a 10 piece string delimited ^
+10 ;
+11 ; 1 IEN of code in ^ICPT
+12 ; 2 CPT Code (.01 field)
+13 ; 3 Versioned Short Name (from #61 multiple)
+14 ; 4 Category IEN (#3 field)
+15 ; 5 Source (#6 field) C:CPT; H:HCPCS; L:VA LOCAL
+16 ; 6 Effective Date (from #60 multiple)
+17 ; 7 Status (from #60 multiple)
+18 ; 8 Inactivation Date (from #60 multiple)
+19 ; 9 Activation Date (from #60 multiple)
+20 ; 10 Message (CODE TEXT MAY BE INACCURATE)
+21 ;
+22 ; or
+23 ;
+24 ; -1^Error Description
+25 ;
+26 NEW DATA,EFF,STR,VCPT
+27 IF $GET(CODE)=""
SET STR="-1^NO CODE SELECTED"
GOTO CPTQ
+28 SET CODE=$GET(CODE)
SET CODE=$SELECT(CODE?1.N:+CODE,1:$$CODEN(CODE))
+29 IF CODE<1!'$DATA(^ICPT(CODE))
SET STR="-1^NO SUCH ENTRY"
GOTO CPTQ
+30 IF '$GET(SRC)
IF $PIECE(^ICPT(CODE,0),"^",6)="L"
SET STR="-1^VA LOCAL CODE SELECTED"
GOTO CPTQ
+31 SET DATA=$GET(^ICPT(CODE,0))
+32 IF '$LENGTH(DATA)
SET STR="-1^NO DATA"
GOTO CPTQ
+33 SET CDT=$SELECT($GET(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(CDT))
+34 SET VCPT=$$VSTCP(CODE,CDT)
+35 SET STR=CODE_"^"_DATA
SET $PIECE(STR,"^",5)=$PIECE(STR,"^",7)
SET STR=$PIECE(STR,"^",1,5)
+36 SET EFF=$$EFF^ICPTSUPT(81,CODE,CDT)
if EFF<1
SET $PIECE(EFF,"^",2)=0
+37 SET STR=STR_"^"_EFF_"^"_$$MSG^ICPTSUPT(CDT)
if $LENGTH(VCPT)
SET $PIECE(STR,"^",3)=VCPT
CPTQ QUIT STR
+1 ;
CPTD(CODE,OUTARR,DFN,CDT) ; Returns CPT description
+1 ;
+2 ; Input: CODE CPT/HCPCS code or IEN (Required)
+3 ; OUTARR Output Array Name for description
+4 ; e.g. "ABC" or "ABC("TEST")"
+5 ; Default = ^TMP("ICPTD",$J)
+6 ; DFN Not in use, future need
+7 ; CDT Date (default = TODAY)
+8 ;
+9 ; Output: # Number of lines in description
+10 ;
+11 ; @OUTARR(1:n) - Versioned Description (lines 1-n) (from the 62 multiple)
+12 ; @OUTARR(n+1) - blank
+13 ; @OUTARR(n+1) - a message stating: CODE TEXT MAY BE INACCURATE
+14 ;
+15 ; or
+16 ;
+17 ; -1^Error Description
+18 ;
+19 ; ** NOTE - User must initialize ^TMP("ICPTD",$J), if used **
+20 ;
+21 NEW ARR,END,I,N,CTV
+22 IF $GET(CODE)=""
SET N="-1^NO CODE SELECTED"
GOTO CPTDQ
+23 IF $GET(OUTARR)=""
SET OUTARR="^TMP(""ICPTD"",$J,"
+24 IF OUTARR'["("
SET OUTARR=OUTARR_"("
+25 IF OUTARR[")"
SET OUTARR=$PIECE(OUTARR,")")
+26 SET END=$EXTRACT(OUTARR,$LENGTH(OUTARR))
IF END'="("&(END'=",")
SET OUTARR=OUTARR_","
+27 IF OUTARR="^TMP(""ICPTD"",$J,"
KILL ^TMP("ICPTD",$JOB)
+28 SET CODE=$SELECT(CODE?1.N:+CODE,1:$$CODEN(CODE))
SET I=0
SET N=0
+29 IF CODE<1!'$DATA(^ICPT(CODE))
SET N="-1^NO SUCH CODE"
GOTO CPTDQ
+30 SET CDT=$SELECT($GET(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(CDT))
+31 DO VLTCP(+CODE,CDT,.CTV)
SET (N,I)=0
FOR
SET I=$ORDER(CTV(I))
if +I=0
QUIT
Begin DoDot:1
+32 SET N=N+1
SET ARR=OUTARR_N_")"
SET @ARR=$$TRIM($GET(CTV(I)))
End DoDot:1
+33 IF +N>0
SET N=N+1
SET ARR=OUTARR_N_")"
SET @ARR=" "
SET N=N+1
SET ARR=OUTARR_N_")"
SET @ARR=$$MSG^ICPTSUPT(CDT,1)
+34 IF +N'>0
SET N="-1^VERSIONED DESCRIPTION NOT FOUND FOR MODIFIER "_$PIECE($GET(^DIC(81.3,+CODE,0)),"^",1)
CPTDQ QUIT N
+1 ;
CODM(CODE,OUTARR,SRC,CDT,DFN) ; returns list of modifiers for a code
+1 ;
+2 ; Input: CODE CPT/HCPCS code, Internal or External Format (Required)
+3 ; ARY Array Name for list returned
+4 ; e.g. "ABC" or "ABC("TEST")"
+5 ; Default = ^TMP("ICPTM",$J)
+6 ; SRC Source Screen
+7 ; If 0 or Null, check Level I/II code/modifiers
+8 ; If >0, check Level I/II/III code/modifiers
+9 ; CDT Date (default = TODAY)
+10 ; DFN Not in use, future need
+11 ;
+12 ; Output: # Number of modifiers that apply
+13 ;
+14 ; OUTARR Array in the format:
+15 ;
+16 ; ARY(Mod) = Versioned Name^Mod IEN
+17 ;
+18 ; Where
+19 ; Mod is the .01 field)
+20 ; Versioned Name is 1 field of the 61 multiple
+21 ;
+22 ; or
+23 ;
+24 ; -1^Error Description
+25 ;
+26 ; ** NOTE - User must initialize ^TMP("ICPTM",$J) array if used **
+27 ;
+28 NEW ARR,CODI,CODA,BR,END,ER,MD,MDST,MI,MN,STR,CODEC,ACTMD,MVST
+29 SET CDT=$GET(CDT)
+30 IF $GET(CODE)=""
SET STR="-1^NO CPT SELECTED"
GOTO CODMQ
+31 IF $GET(OUTARR)=""
SET OUTARR="^TMP(""ICPTM"",$J,"
+32 SET STR=0
SET CODI=$SELECT(CODE?1.N:+CODE,1:$$CODEN(CODE))
+33 IF CODI<1!'$DATA(^ICPT(CODI,0))
SET STR="-1^NO SUCH CODE"
GOTO CODMQ
+34 IF '$GET(SRC)
IF $PIECE(^ICPT(CODI,0),"^",6)="L"
SET STR="-1^VA LOCAL CODE SELECTED"
GOTO CODMQ
+35 SET CODEC=$$CODEC(CODI)
SET CODA=$$NUM^ICPTAPIU(CODEC)
+36 IF OUTARR'["("
SET OUTARR=OUTARR_"("
+37 IF OUTARR[")"
SET OUTARR=$PIECE(OUTARR,")")
+38 SET END=$EXTRACT(OUTARR,$LENGTH(OUTARR))
IF END'="("&(END'=",")
SET OUTARR=OUTARR_","
+39 IF OUTARR="^TMP(""ICPTM"",$J,"
KILL ^TMP("ICPTM",$JOB)
+40 if $GET(CDT)]""
SET CDT=$$DTBR^ICPTSUPT(CDT)
+41 SET BR=""
FOR
SET BR=$ORDER(^DIC(81.3,"M",BR))
if BR>CODA!'BR
QUIT
Begin DoDot:1
+42 SET ER=""
FOR
SET ER=$ORDER(^DIC(81.3,"M",BR,ER))
if 'ER
QUIT
IF CODA'>ER
Begin DoDot:2
+43 SET MI=0
FOR
SET MI=$ORDER(^DIC(81.3,"M",BR,ER,MI))
if 'MI
QUIT
Begin DoDot:3
+44 NEW MDPS
+45 SET MDST=$GET(^DIC(81.3,MI,0))
if '$LENGTH(MDST)
QUIT
+46 SET MDPS=$$MODP^ICPTMOD(CODE,+MI,"I",$GET(CDT),$GET(SRC))
if +MDPS'>0
QUIT
+47 IF '$GET(SRC)
if $PIECE(MDST,"^",4)="V"
QUIT
+48 IF $GET(CDT)
SET ACTMD=""
SET ACTMD=$$MOD^ICPTMOD(MI,"I",CDT,$GET(SRC))
if ($PIECE(ACTMD,"^")=-1)!($PIECE(ACTMD,"^",7)=0)
QUIT
+49 SET MD=$PIECE(MDST,"^",1,2)
SET MN=$PIECE(MD,"^")
+50 IF $LENGTH(MN)'=2
QUIT
+51 SET MVST=$$VSTCM^ICPTMOD(MI,CDT)
+52 SET ARR=OUTARR_""""_MN_""")"
SET @ARR=MVST_"^"_MI
SET STR=STR+1
End DoDot:3
End DoDot:2
End DoDot:1
+53 IF 'STR
SET STR=0
CODMQ QUIT STR
+1 ;
CODEN(CODE) ; Rreturn the IEN of a CPT/HCPCS code
+1 ;
+2 ; Input: CPT/HCPCS code
+3 ; Output: ien of code
+4 ;
+5 IF $GET(CODE)=""
QUIT -1
+6 NEW COD
+7 SET COD=+$ORDER(^ICPT("B",CODE,0))
+8 QUIT $SELECT(COD>0:COD,1:-1)
+9 ;
CODEC(CODE) ; Return the CPT/HCPCS Code
+1 ;
+2 ; Input: IEN of CPT/HCPCS code
+3 ; Output: CPT/HCPCS code
+4 ;
+5 IF $GET(CODE)=""
QUIT -1
+6 NEW Y
+7 SET Y=$PIECE($GET(^ICPT(CODE,0)),"^")
+8 QUIT $SELECT(Y="":-1,1:Y)
+9 ;
VALCPT(CODE,CDT,SRC,DFN) ;check if CPT code is valid for selection
+1 ;
+2 ; Input:
+3 ;
+4 ; CODE - CPT or HCPCS code, ien or .01 format, REQUIRED
+5 ; CTD - Date, default = today
+6 ; SRC - SCREEN SOURCE
+7 ; '$G(SRC) level 1, Level 2 only
+8 ; $G(SRC) include level 3
+9 ; DFN - not in use, future need
+10 ;
+11 ; Output: STR: 1 if valid code for selection
+12 ; -1^error message if not selectable
+13 ;
+14 NEW STR
+15 SET CODE=$GET(CODE)
SET SRC=$GET(SRC)
SET DFN=$GET(DFN)
+16 ;date business rules
SET CDT=$SELECT($GET(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(CDT))
+17 SET STR=$$CPT(CODE,CDT,SRC,DFN)
+18 IF STR<0
GOTO VALCPTQ
+19 IF '$PIECE(STR,"^",7)
SET STR="-1^INACTIVE CODE"
+20 IF STR>0
SET STR=1
VALCPTQ QUIT STR
+1 ;
+2 ;
+3 QUIT
VST(IEN,VDATE,TYPE) ; Versioned Short Text
+1 if TYPE["ICPT("
QUIT $$VSTCP($GET(IEN),$GET(VDATE))
+2 if TYPE["DIC(81.3"
QUIT $$VSTCM^ICPTMOD($GET(IEN),$GET(VDATE))
+3 QUIT ""
VSTCP(IEN,VDATE) ; Versioned Short Text (CPT Procedure)
+1 NEW CPT0,CPTC,CPTI,CPTSTD,CPTSTI,CPTVDT,CPTTXT
+2 SET CPTI=+($GET(IEN))
if +CPTI'>0
QUIT ""
if '$DATA(^ICPT(+CPTI))
QUIT ""
+3 SET CPTVDT=$GET(VDATE)
if '$LENGTH(CPTVDT)!(+CPTVDT'>0)
SET CPTVDT=$$DT^XLFDT
if CPTVDT\1'?7N
QUIT ""
+4 SET CPT0=$GET(^ICPT(+CPTI,0))
SET CPTC=$PIECE(CPT0,"^",1)
if '$LENGTH(CPTC)
QUIT ""
+5 SET CPTSTD=$ORDER(^ICPT("AST",(CPTC_" "),(CPTVDT+.000001)),-1)
+6 IF +CPTSTD>0
Begin DoDot:1
+7 SET CPTSTI=$ORDER(^ICPT("AST",(CPTC_" "),CPTSTD,+CPTI," "),-1)
SET CPTTXT=$$TRIM($PIECE($GET(^ICPT(+CPTI,61,+CPTSTI,0)),"^",2))
End DoDot:1
if $LENGTH($GET(CPTTXT))
QUIT $GET(CPTTXT)
+8 SET CPTSTD=$ORDER(^ICPT(+CPTI,61,"B",0))
IF +CPTSTD>0
Begin DoDot:1
+9 SET CPTSTI=$ORDER(^ICPT(+CPTI,61,"B",CPTSTD,0))
SET CPTTXT=$$TRIM($PIECE($GET(^ICPT(+CPTI,61,+CPTSTI,0)),"^",2))
End DoDot:1
if $LENGTH($GET(CPTTXT))
QUIT $GET(CPTTXT)
+10 QUIT $$TRIM($PIECE(CPT0,"^",2))
VLTCP(IEN,VDATE,ARY) ; Versioned Description - Long Text (CPT Procedure)
+1 NEW CPT0,CPTC,CPTI,CPTSTD,CPTSTI,CPTVDT,CPTTXT,CPTD,CPTT,CPTE
+2 SET CPTI=+($GET(IEN))
if +CPTI'>0
QUIT
if '$DATA(^ICPT(+CPTI))
QUIT
+3 SET CPTVDT=$GET(VDATE)
if '$LENGTH(CPTVDT)!(+CPTVDT'>0)
SET CPTVDT=$$DT^XLFDT
if CPTVDT\1'?7N
QUIT
+4 SET CPT0=$GET(^ICPT(+CPTI,0))
SET CPTC=$PIECE(CPT0,"^",1)
if '$LENGTH(CPTC)
QUIT
+5 SET CPTSTD=$ORDER(^ICPT("ADS",(CPTC_" "),(CPTVDT+.000001)),-1)
+6 IF +CPTSTD>0
Begin DoDot:1
+7 SET CPTSTI=$ORDER(^ICPT("ADS",(CPTC_" "),CPTSTD,+CPTI," "),-1)
+8 SET (CPTD,CPTT)=0
FOR
SET CPTD=$ORDER(^ICPT(+CPTI,62,CPTSTI,1,CPTD))
if +CPTD=0
QUIT
Begin DoDot:2
+9 SET CPTT=CPTT+1
SET ARY(CPTT)=$$TRIM($GET(^ICPT(+CPTI,62,+CPTSTI,1,+CPTD,0)))
SET ARY(0)=CPTT
End DoDot:2
End DoDot:1
if +($ORDER(ARY(0)))>0
QUIT
+10 SET CPTSTD=$ORDER(^ICPT(+CPTI,62,"B",0))
IF +CPTSTD>0
Begin DoDot:1
+11 SET CPTSTI=$ORDER(^ICPT(+CPTI,62,"B",CPTSTD,0))
+12 SET (CPTD,CPTT)=0
FOR
SET CPTD=$ORDER(^ICPT(+CPTI,62,CPTSTI,1,CPTD))
if +CPTD=0
QUIT
Begin DoDot:2
+13 SET CPTT=CPTT+1
SET ARY(CPTT)=$$TRIM($GET(^ICPT(+CPTI,62,+CPTSTI,1,+CPTD,0)))
SET ARY(0)=CPTT
End DoDot:2
End DoDot:1
if +($ORDER(ARY(0)))>0
QUIT
+14 KILL ARY
SET (CPTD,CPTT)=0
FOR
SET CPTD=$ORDER(^ICPT(CPTI,"D",CPTD))
if +CPTD=0
QUIT
Begin DoDot:1
+15 SET CPTT=CPTT+1
SET ARY(CPTT)=$$TRIM($GET(^ICPT(CPTI,"D",CPTD,0)))
SET ARY(0)=CPTT
End DoDot:1
+16 QUIT
TRIM(X) ; Trim Spaces
+1 SET X=$GET(X)
if X=""
QUIT X
FOR
if $EXTRACT(X,1)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
if $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 FOR
if X'[" "
QUIT
SET X=$PIECE(X," ",1)_" "_$PIECE(X," ",2,229)
+4 QUIT X
