ICPT640P ;KER - ICPT*6.0*40 Post-Install ;11/17/2007
;;6.0;CPT/HCPCS;**40**;May 19, 1997;Build 6
;
POST ;
D AJ
Q
AJ ; Modifier AH and AJ
N ICPTACT,ICPTB,DA,DIK,ICPTE,ICPTEX,ICPTL,ICPTM,ICPTND,ICPTNX,ICPTR,ICPTT,ICPTXT S ICPTACT=3050101
S ICPTM=$O(^DIC(81.3,"B","AJ",0)) Q:+ICPTM'>0
S ICPTR=0 F S ICPTR=$O(^DIC(81.3,ICPTM,10,ICPTR)) Q:+ICPTR'>0 D
. N DA,DIK S DA(1)=ICPTM,DA=ICPTR,DIK="^DIC(81.3,"_DA(1)_",10,"
. Q:$L($P($G(^DIC(81.3,ICPTM,10,ICPTR,0)),"^",4)) D ^DIK
F ICPTL=1:1 D Q:'$L(ICPTXT)
. N ICPTB,DA,DIK,ICPTE,ICPTEX,ICPTND,ICPTNX,ICPTR,ICPTT S ICPTR=0,ICPTXT="" S ICPTEX="S ICPTXT=$T(RAN+"_ICPTL_")" X ICPTEX
. S ICPTXT=$$TM(ICPTXT," ") Q:'$L(ICPTXT) Q:'$L($TR(ICPTXT,";","")) S ICPTXT=$P(ICPTXT,";",3,299)
. S ICPTB=$P(ICPTXT,"^",1),ICPTE=$P(ICPTXT,"^",2) Q:$L(ICPTB)'=5 Q:$L(ICPTE)'=5 S ICPTND=ICPTB_"^"_ICPTE_"^"_ICPTACT
. S ICPTT=0 F S ICPTT=$O(^DIC(81.3,+ICPTM,10,"B",ICPTB,ICPTT)) Q:+ICPTT=0 D
. . I $P($G(^DIC(81.3,+ICPTM,10,ICPTT,0)),"^",1,3)=ICPTND S ICPTR=ICPTT
. Q:+ICPTR>0 S ICPTNX=$O(^DIC(81.3,+ICPTM,10," "),-1)+1
. S ^DIC(81.3,+ICPTM,10,ICPTNX,0)=ICPTND,^DIC(81.3,+ICPTM,10,0)="^81.33DA^"_ICPTNX_"^"_ICPTNX
. S DA(1)=+ICPTM,DA=ICPTNX,DIK="^DIC(81.3,"_DA(1)_",10," D IX1^DIK K DA
K DA S DA=+ICPTM,DIK="^DIC(81.3," D IX1^DIK K DA
Q
TM(X,Y) ; Trim Spaces
S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" " 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
RAN ; Modifier AJ Code Ranges
;;90801^90804
;;90806^90808
;;90810^90810
;;90812^90812
;;90814^90814
;;90846^90853
;;90857^90857
;;96116^96120
;;97532^97533
;;96150^96151
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICPT640P 1725 printed Dec 13, 2024@01:45:34 Page 2
ICPT640P ;KER - ICPT*6.0*40 Post-Install ;11/17/2007
+1 ;;6.0;CPT/HCPCS;**40**;May 19, 1997;Build 6
+2 ;
POST ;
+1 DO AJ
+2 QUIT
AJ ; Modifier AH and AJ
+1 NEW ICPTACT,ICPTB,DA,DIK,ICPTE,ICPTEX,ICPTL,ICPTM,ICPTND,ICPTNX,ICPTR,ICPTT,ICPTXT
SET ICPTACT=3050101
+2 SET ICPTM=$ORDER(^DIC(81.3,"B","AJ",0))
if +ICPTM'>0
QUIT
+3 SET ICPTR=0
FOR
SET ICPTR=$ORDER(^DIC(81.3,ICPTM,10,ICPTR))
if +ICPTR'>0
QUIT
Begin DoDot:1
+4 NEW DA,DIK
SET DA(1)=ICPTM
SET DA=ICPTR
SET DIK="^DIC(81.3,"_DA(1)_",10,"
+5 if $LENGTH($PIECE($GET(^DIC(81.3,ICPTM,10,ICPTR,0)),"^",4))
QUIT
DO ^DIK
End DoDot:1
+6 FOR ICPTL=1:1
Begin DoDot:1
+7 NEW ICPTB,DA,DIK,ICPTE,ICPTEX,ICPTND,ICPTNX,ICPTR,ICPTT
SET ICPTR=0
SET ICPTXT=""
SET ICPTEX="S ICPTXT=$T(RAN+"_ICPTL_")"
XECUTE ICPTEX
+8 SET ICPTXT=$$TM(ICPTXT," ")
if '$LENGTH(ICPTXT)
QUIT
if '$LENGTH($TRANSLATE(ICPTXT,";",""))
QUIT
SET ICPTXT=$PIECE(ICPTXT,";",3,299)
+9 SET ICPTB=$PIECE(ICPTXT,"^",1)
SET ICPTE=$PIECE(ICPTXT,"^",2)
if $LENGTH(ICPTB)'=5
QUIT
if $LENGTH(ICPTE)'=5
QUIT
SET ICPTND=ICPTB_"^"_ICPTE_"^"_ICPTACT
+10 SET ICPTT=0
FOR
SET ICPTT=$ORDER(^DIC(81.3,+ICPTM,10,"B",ICPTB,ICPTT))
if +ICPTT=0
QUIT
Begin DoDot:2
+11 IF $PIECE($GET(^DIC(81.3,+ICPTM,10,ICPTT,0)),"^",1,3)=ICPTND
SET ICPTR=ICPTT
End DoDot:2
+12 if +ICPTR>0
QUIT
SET ICPTNX=$ORDER(^DIC(81.3,+ICPTM,10," "),-1)+1
+13 SET ^DIC(81.3,+ICPTM,10,ICPTNX,0)=ICPTND
SET ^DIC(81.3,+ICPTM,10,0)="^81.33DA^"_ICPTNX_"^"_ICPTNX
+14 SET DA(1)=+ICPTM
SET DA=ICPTNX
SET DIK="^DIC(81.3,"_DA(1)_",10,"
DO IX1^DIK
KILL DA
End DoDot:1
if '$LENGTH(ICPTXT)
QUIT
+15 KILL DA
SET DA=+ICPTM
SET DIK="^DIC(81.3,"
DO IX1^DIK
KILL DA
+16 QUIT
TM(X,Y) ; Trim Spaces
+1 SET X=$GET(X)
if X=""
QUIT X
SET Y=$GET(Y)
if '$LENGTH(Y)
SET Y=" "
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
RAN ; Modifier AJ Code Ranges
+1 ;;90801^90804
+2 ;;90806^90808
+3 ;;90810^90810
+4 ;;90812^90812
+5 ;;90814^90814
+6 ;;90846^90853
+7 ;;90857^90857
+8 ;;96116^96120
+9 ;;97532^97533
+10 ;;96150^96151
+11 ;;
