ICPTMOD2 ;ALB/DEK/KER - CPT MODIFIER APIS ;08/18/2007
;;6.0;CPT/HCPCS;**30,37**;May 19, 1997;Build 25
;
; Global Variables
; ^DIC(81.3
; ^ICPT(
;
; External References
; $$DT^XLFDT DBIA 10103
; $$FMADD^XLFDT DBIA 10103
;
Q
MODA ; Create an array of Modifiers for a CPT Code
;
; Input
;
; CODE CPT/HCPCS Code ?7N / ?1A4N / ?4N1A
; VDT Versioning Date (date service provided)
; .ARY Name of a Local Array passed by value
;
; Output
;
; ARY Only returns Active Modifiers
; ARY(0) = 4 Piece String
; 4 Piece String
; 1 # of Modifiers found for code CODE (input)
; 2 # of Modifiers w/Active Ranges
; 3 # of Modifiers w/Inactive Ranges
; 4 Code
;
; ARY(ST,MOD) = 8 Piece Output String
;
; ST Status A=Active I=Inactive
; MOD Modifier (external format)
; 8 Piece String
; 1 IEN of Modifier
; 2 Versioned Short Text (name)
; 3 Activation date of Modifier
; 4 Beginning Range Code
; 5 Ending Range Code
; 6 Activation Date of Range
; 7 Inactivation Date of Range
; 8 Modifier Identifier
;
N A,EFF,I,ID,MIEN,MOD,SRC,ST,X K ARY
S CODE=$G(CODE) Q:'$D(^ICPT("BA",(CODE_" ")))
S VDT=$G(VDT) S:+VDT'>0 VDT=$$DT^XLFDT Q:VDT'?7N
S SRC=3,MIEN=0 F S MIEN=$O(^DIC(81.3,MIEN)) Q:+MIEN'>0 D
. S (EFF,ST)=$O(^DIC(81.3,MIEN,60,"B"," "),-1) Q:ST'>0 S ST=$O(^DIC(81.3,MIEN,60,"B",ST," "),-1) Q:ST'>0 S ST=$P($G(^DIC(81.3,MIEN,60,ST,0)),"^",2) Q:ST'>0
. S MOD=$P($G(^DIC(81.3,MIEN,0)),"^",1) Q:'$L(MOD)
. S X=$$MODP(CODE,MIEN,"I",VDT,0) S ID=$P(X,"^",6) S ID=$S(+ID>0:"I",1:"A")
. S:+X>0 ARY(ID,MOD)=$P(X,"^",1,2)_"^"_EFF_"^"_$P(X,"^",3,7)
S (A,I)=0,ST="" F S ST=$O(ARY(ST)) Q:ST="" S MOD="" F S MOD=$O(ARY(ST,MOD)) Q:MOD="" S:ST="A" A=A+1 S:ST="I" I=I+1
S ST=A+I,ARY(0)=ST_"^"_A_"^"_I_"^"_CODE
Q
;
MODP(CODE,MOD,MFT,MDT,SRC,DFN) ; Check if modifier can be used with code (pair)
;
; Input:
;
; CODE CPT/HCPCS Code ?7N / ?1A4N / ?4N1A
; MOD Modifier (External or Internal)
; MFT Modifier Format "E" - or "I"
; VDT Date service provided
; SRC Source Screen
; If 0 or Null, Level I and II modifiers
; If >0, Level I, II, and III modifiers
; Output:
;
; If pair is acceptable - Positive "^" Delimited String
;
; 1 - IEN of CPT Modifier
; 2 - Versioned Short Text
; 3 - Beginning Code for Code Range
; 4 - Ending Code for Code Range
; 5 - Code Range Activaiton Date
; 6 - Code Range Inactivation Date
; 7 - Modifier Identifier
;
; If pair is unacceptable
;
; 0 or
; -1 with error message
;
N ADT,BEGA,BEGR,CDT,CODEA,CODN,ENDA,ENDR,ICD,IDT,LACT,LINA,MIEN,MODEFF,MODI,MODNM,MODST,ND,NSTA,RIEN,RSTA,SIEN,STA,STI,STX,TA,TEFF,TI,TIEN,VDT
S:$G(MFT)="" MFT="E" Q:"^E^I^"'[("^"_MFT_"^") "-1^Invalid Modifier Format" S VDT=$P($G(MDT),".",1)
S:+VDT'?7N VDT=$$DT^XLFDT S:VDT#10000=0 VDT=VDT+101 S:VDT#100=0 VDT=VDT+1 S VDT=$S(VDT<2890101:2890101,1:VDT)
Q:+VDT'>0!(VDT'?7N) "-1^Invalid Date" I MFT="E" D I +($G(MIEN))'>0 Q "-1^Multiple Modifiers with the same name, use IEN"
. S MIEN=0 S (TIEN,TI)=0 F S TIEN=$O(^DIC(81.3,"B",MOD,TIEN)) Q:+TIEN'>0 D
. . S TEFF=$$EFF^ICPTSUPT(81.3,TIEN,VDT) Q:'$P(TEFF,"^",2) S TI=TI+1,TA(TI)=TIEN,TA(0)=TI
. S:+($G(TA(0)))=1 MIEN=+($G(TA(1)))
S:MFT="I" MIEN=+MOD S CODE=$G(CODE),CODN=$S(CODE?1.N:+CODE,1:$$CODEN^ICPTCOD(CODE)) I CODN<1!'$D(^ICPT(CODN,0)) Q "-1^NO SUCH CPT CODE"
S CODE=$P($G(^ICPT(CODN,0)),"^") Q:'$L(CODE) "-1^No such CPT Code" Q:$L(CODE)'=5 "-1^Invalid Code"
S CODEA=$S(CODE?1N.4N:+CODE,CODE?4N1A:$A($E(CODE,5))*10_$E(CODE,1,4),1:$A(CODE)_$E(CODE,2,5)) Q:+CODEA'>0 "-1^Invalid Code Source"
S MIEN=$G(MIEN) Q:+MIEN'>0 "-1^Invalid Modifier" S SRC=$S(+($G(SRC))>0:1,1:0),SIEN=$O(^ICPT("BA",(CODE_" "),0)) Q:+SIEN'>0 "-3^Invalid Code"
Q:$P($G(^ICPT(+SIEN,0)),"^",6)="L"&(SRC'>0) "-1^Invalid Code Source"
S MODEFF=$$EFF^ICPTSUPT(81.3,MIEN,VDT) Q:'$P(MODEFF,"^",2) "-1^Modifier Inactive"
S MODNM=$P($G(^DIC(81.3,MIEN,0)),"^",2) Q:'$L(MODNM) "-1^Invalid Modifier Name"
S MODI=$P($G(^DIC(81.3,MIEN,0)),"^",1) Q:'$L(MODI) "-1^Invalid Modifier ID"
S MODST=$$VSTCM^ICPTMOD(MIEN,VDT) K STX S (STA,STI)=0 S CDT=VDT+.001
S (LINA,LACT)="",RSTA=0,RIEN=0 F S RIEN=$O(^DIC(81.3,MIEN,10,RIEN)) Q:+RIEN'>0 D
. N NSTA S NSTA=0,ND=$G(^DIC(81.3,MIEN,10,RIEN,0))
. S BEGR=$P(ND,"^",1) Q:$L(BEGR)'=5 S BEGA=$S(BEGR?1N.4N:+BEGR,BEGR?4N1A:$A($E(BEGR,5))*10_$E(BEGR,1,4),1:$A(BEGR)_$E(BEGR,2,5)) Q:+CODEA<+BEGA
. S ENDR=$P(ND,"^",2) S:$L(ENDR)'=5 ENDR=BEGR S ENDA=$S(ENDR?1N.4N:+ENDR,ENDR?4N1A:$A($E(ENDR,5))*10_$E(ENDR,1,4),1:$A(ENDR)_$E(ENDR,2,5))
. Q:$L(ENDR)&(CODEA>ENDA) S ADT=$P(ND,"^",3),(ICD,IDT)=$P(ND,"^",4) S:ADT="" ADT=2890101
. I +CODEA'<+BEGA,+CODEA'>ENDA,+ADT>0,+IDT'>0 S RSTA=1,NSTA=1 S:+ADT>0&(+ADT>(+LACT)) LACT=+ADT
. I +CODEA'<+BEGA,+CODEA'>ENDA,+ADT>0,+IDT>0,CDT>ADT,CDT'>IDT S RSTA=1,NSTA=1 S:+ADT>0&(+ADT>(+LACT)) LACT=+ADT
. I +CODEA'<+BEGA,+CODEA'>ENDA,+ADT>0,+IDT>0 S:+IDT>0&(+IDT>(+LINA)) LINA=+IDT
. Q:NSTA'>0 S:'$L(IDT) IDT=$$FMADD^XLFDT($$DT^XLFDT,365) S ADT=$P(ND,"^",3),(ICD,IDT)=$P(ND,"^",4) S:ADT="" ADT=2890101
. S:'$L(IDT) IDT=$$FMADD^XLFDT($$DT^XLFDT,365) S STA=+($G(STA))+1,STX(STA)=MIEN_"^"_MODST_"^"_BEGR_"^"_ENDR_"^"_ADT_"^"_ICD_"^"_MODI,STX("B",+ADT,+STA)=""
S:+LACT>0&(+LINA>0)&(LINA'>CDT)&(+LINA>+LACT) RSTA=0
S ADT=$O(STX("B",+CDT),-1),STA=$O(STX("B",+ADT," "),-1),MOD=$G(STX(+STA))
Q:+MOD'>0 "0" Q:+RSTA'>0 "0"
Q MOD
;
MODC(MOD) ; Checks modifier for active range including code
;
; Input:
; MOD - modifier ien
;
N MODNM,MODEFF
S MODEFF=$$EFF^ICPTSUPT(81.3,MOD,MDT)
I '$P(MODEFF,"^",2) S STR="-1^modifier inactive" Q
S PR=CODEA_.0001,PR=$O(^DIC(81.3,MOD,"M",PR),-1)
I 'PR S STR=0 Q
S PRN=^DIC(81.3,MOD,"M",PR)
I 'PRN S STR="-1^bad modifier file entry" Q
I PRN<CODEA S STR=0 Q
S MODNM=$P($G(^DIC(81.3,MOD,0)),"^",2)
S STR=MOD_"^"_MODNM
Q
;
MULT ; Finds iens for all modifiers with same 2-letter code
; MOD = .01, check B x-ref for dupliate .01 fields
; Output:
; STR - a ";" delimited string of IENS for modifier MOD
F MODN=0:0 S MODN=$O(^DIC(81.3,"B",MOD,MODN)) Q:'MODN S STR=STR_MODN_"; "
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICPTMOD2 6618 printed Dec 13, 2024@01:45:47 Page 2
ICPTMOD2 ;ALB/DEK/KER - CPT MODIFIER APIS ;08/18/2007
+1 ;;6.0;CPT/HCPCS;**30,37**;May 19, 1997;Build 25
+2 ;
+3 ; Global Variables
+4 ; ^DIC(81.3
+5 ; ^ICPT(
+6 ;
+7 ; External References
+8 ; $$DT^XLFDT DBIA 10103
+9 ; $$FMADD^XLFDT DBIA 10103
+10 ;
+11 QUIT
MODA ; Create an array of Modifiers for a CPT Code
+1 ;
+2 ; Input
+3 ;
+4 ; CODE CPT/HCPCS Code ?7N / ?1A4N / ?4N1A
+5 ; VDT Versioning Date (date service provided)
+6 ; .ARY Name of a Local Array passed by value
+7 ;
+8 ; Output
+9 ;
+10 ; ARY Only returns Active Modifiers
+11 ; ARY(0) = 4 Piece String
+12 ; 4 Piece String
+13 ; 1 # of Modifiers found for code CODE (input)
+14 ; 2 # of Modifiers w/Active Ranges
+15 ; 3 # of Modifiers w/Inactive Ranges
+16 ; 4 Code
+17 ;
+18 ; ARY(ST,MOD) = 8 Piece Output String
+19 ;
+20 ; ST Status A=Active I=Inactive
+21 ; MOD Modifier (external format)
+22 ; 8 Piece String
+23 ; 1 IEN of Modifier
+24 ; 2 Versioned Short Text (name)
+25 ; 3 Activation date of Modifier
+26 ; 4 Beginning Range Code
+27 ; 5 Ending Range Code
+28 ; 6 Activation Date of Range
+29 ; 7 Inactivation Date of Range
+30 ; 8 Modifier Identifier
+31 ;
+32 NEW A,EFF,I,ID,MIEN,MOD,SRC,ST,X
KILL ARY
+33 SET CODE=$GET(CODE)
if '$DATA(^ICPT("BA",(CODE_" ")))
QUIT
+34 SET VDT=$GET(VDT)
if +VDT'>0
SET VDT=$$DT^XLFDT
if VDT'?7N
QUIT
+35 SET SRC=3
SET MIEN=0
FOR
SET MIEN=$ORDER(^DIC(81.3,MIEN))
if +MIEN'>0
QUIT
Begin DoDot:1
+36 SET (EFF,ST)=$ORDER(^DIC(81.3,MIEN,60,"B"," "),-1)
if ST'>0
QUIT
SET ST=$ORDER(^DIC(81.3,MIEN,60,"B",ST," "),-1)
if ST'>0
QUIT
SET ST=$PIECE($GET(^DIC(81.3,MIEN,60,ST,0)),"^",2)
if ST'>0
QUIT
+37 SET MOD=$PIECE($GET(^DIC(81.3,MIEN,0)),"^",1)
if '$LENGTH(MOD)
QUIT
+38 SET X=$$MODP(CODE,MIEN,"I",VDT,0)
SET ID=$PIECE(X,"^",6)
SET ID=$SELECT(+ID>0:"I",1:"A")
+39 if +X>0
SET ARY(ID,MOD)=$PIECE(X,"^",1,2)_"^"_EFF_"^"_$PIECE(X,"^",3,7)
End DoDot:1
+40 SET (A,I)=0
SET ST=""
FOR
SET ST=$ORDER(ARY(ST))
if ST=""
QUIT
SET MOD=""
FOR
SET MOD=$ORDER(ARY(ST,MOD))
if MOD=""
QUIT
if ST="A"
SET A=A+1
if ST="I"
SET I=I+1
+41 SET ST=A+I
SET ARY(0)=ST_"^"_A_"^"_I_"^"_CODE
+42 QUIT
+43 ;
MODP(CODE,MOD,MFT,MDT,SRC,DFN) ; Check if modifier can be used with code (pair)
+1 ;
+2 ; Input:
+3 ;
+4 ; CODE CPT/HCPCS Code ?7N / ?1A4N / ?4N1A
+5 ; MOD Modifier (External or Internal)
+6 ; MFT Modifier Format "E" - or "I"
+7 ; VDT Date service provided
+8 ; SRC Source Screen
+9 ; If 0 or Null, Level I and II modifiers
+10 ; If >0, Level I, II, and III modifiers
+11 ; Output:
+12 ;
+13 ; If pair is acceptable - Positive "^" Delimited String
+14 ;
+15 ; 1 - IEN of CPT Modifier
+16 ; 2 - Versioned Short Text
+17 ; 3 - Beginning Code for Code Range
+18 ; 4 - Ending Code for Code Range
+19 ; 5 - Code Range Activaiton Date
+20 ; 6 - Code Range Inactivation Date
+21 ; 7 - Modifier Identifier
+22 ;
+23 ; If pair is unacceptable
+24 ;
+25 ; 0 or
+26 ; -1 with error message
+27 ;
+28 NEW ADT,BEGA,BEGR,CDT,CODEA,CODN,ENDA,ENDR,ICD,IDT,LACT,LINA,MIEN,MODEFF,MODI,MODNM,MODST,ND,NSTA,RIEN,RSTA,SIEN,STA,STI,STX,TA,TEFF,TI,TIEN,VDT
+29 if $GET(MFT)=""
SET MFT="E"
if "^E^I^"'[("^"_MFT_"^")
QUIT "-1^Invalid Modifier Format"
SET VDT=$PIECE($GET(MDT),".",1)
+30 if +VDT'?7N
SET VDT=$$DT^XLFDT
if VDT#10000=0
SET VDT=VDT+101
if VDT#100=0
SET VDT=VDT+1
SET VDT=$SELECT(VDT<2890101:2890101,1:VDT)
+31 if +VDT'>0!(VDT'?7N)
QUIT "-1^Invalid Date"
IF MFT="E"
Begin DoDot:1
+32 SET MIEN=0
SET (TIEN,TI)=0
FOR
SET TIEN=$ORDER(^DIC(81.3,"B",MOD,TIEN))
if +TIEN'>0
QUIT
Begin DoDot:2
+33 SET TEFF=$$EFF^ICPTSUPT(81.3,TIEN,VDT)
if '$PIECE(TEFF,"^",2)
QUIT
SET TI=TI+1
SET TA(TI)=TIEN
SET TA(0)=TI
End DoDot:2
+34 if +($GET(TA(0)))=1
SET MIEN=+($GET(TA(1)))
End DoDot:1
IF +($GET(MIEN))'>0
QUIT "-1^Multiple Modifiers with the same name, use IEN"
+35 if MFT="I"
SET MIEN=+MOD
SET CODE=$GET(CODE)
SET CODN=$SELECT(CODE?1.N:+CODE,1:$$CODEN^ICPTCOD(CODE))
IF CODN<1!'$DATA(^ICPT(CODN,0))
QUIT "-1^NO SUCH CPT CODE"
+36 SET CODE=$PIECE($GET(^ICPT(CODN,0)),"^")
if '$LENGTH(CODE)
QUIT "-1^No such CPT Code"
if $LENGTH(CODE)'=5
QUIT "-1^Invalid Code"
+37 SET CODEA=$SELECT(CODE?1N.4N:+CODE,CODE?4N1A:$ASCII($EXTRACT(CODE,5))*10_$EXTRACT(CODE,1,4),1:$ASCII(CODE)_$EXTRACT(CODE,2,5))
if +CODEA'>0
QUIT "-1^Invalid Code Source"
+38 SET MIEN=$GET(MIEN)
if +MIEN'>0
QUIT "-1^Invalid Modifier"
SET SRC=$SELECT(+($GET(SRC))>0:1,1:0)
SET SIEN=$ORDER(^ICPT("BA",(CODE_" "),0))
if +SIEN'>0
QUIT "-3^Invalid Code"
+39 if $PIECE($GET(^ICPT(+SIEN,0)),"^",6)="L"&(SRC'>0)
QUIT "-1^Invalid Code Source"
+40 SET MODEFF=$$EFF^ICPTSUPT(81.3,MIEN,VDT)
if '$PIECE(MODEFF,"^",2)
QUIT "-1^Modifier Inactive"
+41 SET MODNM=$PIECE($GET(^DIC(81.3,MIEN,0)),"^",2)
if '$LENGTH(MODNM)
QUIT "-1^Invalid Modifier Name"
+42 SET MODI=$PIECE($GET(^DIC(81.3,MIEN,0)),"^",1)
if '$LENGTH(MODI)
QUIT "-1^Invalid Modifier ID"
+43 SET MODST=$$VSTCM^ICPTMOD(MIEN,VDT)
KILL STX
SET (STA,STI)=0
SET CDT=VDT+.001
+44 SET (LINA,LACT)=""
SET RSTA=0
SET RIEN=0
FOR
SET RIEN=$ORDER(^DIC(81.3,MIEN,10,RIEN))
if +RIEN'>0
QUIT
Begin DoDot:1
+45 NEW NSTA
SET NSTA=0
SET ND=$GET(^DIC(81.3,MIEN,10,RIEN,0))
+46 SET BEGR=$PIECE(ND,"^",1)
if $LENGTH(BEGR)'=5
QUIT
SET BEGA=$SELECT(BEGR?1N.4N:+BEGR,BEGR?4N1A:$ASCII($EXTRACT(BEGR,5))*10_$EXTRACT(BEGR,1,4),1:$ASCII(BEGR)_$EXTRACT(BEGR,2,5))
if +CODEA<+BEGA
QUIT
+47 SET ENDR=$PIECE(ND,"^",2)
if $LENGTH(ENDR)'=5
SET ENDR=BEGR
SET ENDA=$SELECT(ENDR?1N.4N:+ENDR,ENDR?4N1A:$ASCII($EXTRACT(ENDR,5))*10_$EXTRACT(ENDR,1,4),1:$ASCII(ENDR)_$EXTRACT(ENDR,2,5))
+48 if $LENGTH(ENDR)&(CODEA>ENDA)
QUIT
SET ADT=$PIECE(ND,"^",3)
SET (ICD,IDT)=$PIECE(ND,"^",4)
if ADT=""
SET ADT=2890101
+49 IF +CODEA'<+BEGA
IF +CODEA'>ENDA
IF +ADT>0
IF +IDT'>0
SET RSTA=1
SET NSTA=1
if +ADT>0&(+ADT>(+LACT))
SET LACT=+ADT
+50 IF +CODEA'<+BEGA
IF +CODEA'>ENDA
IF +ADT>0
IF +IDT>0
IF CDT>ADT
IF CDT'>IDT
SET RSTA=1
SET NSTA=1
if +ADT>0&(+ADT>(+LACT))
SET LACT=+ADT
+51 IF +CODEA'<+BEGA
IF +CODEA'>ENDA
IF +ADT>0
IF +IDT>0
if +IDT>0&(+IDT>(+LINA))
SET LINA=+IDT
+52 if NSTA'>0
QUIT
if '$LENGTH(IDT)
SET IDT=$$FMADD^XLFDT($$DT^XLFDT,365)
SET ADT=$PIECE(ND,"^",3)
SET (ICD,IDT)=$PIECE(ND,"^",4)
if ADT=""
SET ADT=2890101
+53 if '$LENGTH(IDT)
SET IDT=$$FMADD^XLFDT($$DT^XLFDT,365)
SET STA=+($GET(STA))+1
SET STX(STA)=MIEN_"^"_MODST_"^"_BEGR_"^"_ENDR_"^"_ADT_"^"_ICD_"^"_MODI
SET STX("B",+ADT,+STA)=""
End DoDot:1
+54 if +LACT>0&(+LINA>0)&(LINA'>CDT)&(+LINA>+LACT)
SET RSTA=0
+55 SET ADT=$ORDER(STX("B",+CDT),-1)
SET STA=$ORDER(STX("B",+ADT," "),-1)
SET MOD=$GET(STX(+STA))
+56 if +MOD'>0
QUIT "0"
if +RSTA'>0
QUIT "0"
+57 QUIT MOD
+58 ;
MODC(MOD) ; Checks modifier for active range including code
+1 ;
+2 ; Input:
+3 ; MOD - modifier ien
+4 ;
+5 NEW MODNM,MODEFF
+6 SET MODEFF=$$EFF^ICPTSUPT(81.3,MOD,MDT)
+7 IF '$PIECE(MODEFF,"^",2)
SET STR="-1^modifier inactive"
QUIT
+8 SET PR=CODEA_.0001
SET PR=$ORDER(^DIC(81.3,MOD,"M",PR),-1)
+9 IF 'PR
SET STR=0
QUIT
+10 SET PRN=^DIC(81.3,MOD,"M",PR)
+11 IF 'PRN
SET STR="-1^bad modifier file entry"
QUIT
+12 IF PRN<CODEA
SET STR=0
QUIT
+13 SET MODNM=$PIECE($GET(^DIC(81.3,MOD,0)),"^",2)
+14 SET STR=MOD_"^"_MODNM
+15 QUIT
+16 ;
MULT ; Finds iens for all modifiers with same 2-letter code
+1 ; MOD = .01, check B x-ref for dupliate .01 fields
+2 ; Output:
+3 ; STR - a ";" delimited string of IENS for modifier MOD
+4 FOR MODN=0:0
SET MODN=$ORDER(^DIC(81.3,"B",MOD,MODN))
if 'MODN
QUIT
SET STR=STR_MODN_"; "
+5 QUIT
