source: FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPT640P.m@ 1392

Last change on this file since 1392 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 1.6 KB
Line 
1ICPT640P ;KER - ICPT*6.0*40 Post-Install ;11/17/2007
2 ;;6.0;CPT/HCPCS;**40**;May 19, 1997;Build 6
3 ;
4POST ;
5 D AJ
6 Q
7AJ ; Modifier AH and AJ
8 N ICPTACT,ICPTB,DA,DIK,ICPTE,ICPTEX,ICPTL,ICPTM,ICPTND,ICPTNX,ICPTR,ICPTT,ICPTXT S ICPTACT=3050101
9 S ICPTM=$O(^DIC(81.3,"B","AJ",0)) Q:+ICPTM'>0
10 S ICPTR=0 F S ICPTR=$O(^DIC(81.3,ICPTM,10,ICPTR)) Q:+ICPTR'>0 D
11 . N DA,DIK S DA(1)=ICPTM,DA=ICPTR,DIK="^DIC(81.3,"_DA(1)_",10,"
12 . Q:$L($P($G(^DIC(81.3,ICPTM,10,ICPTR,0)),"^",4)) D ^DIK
13 F ICPTL=1:1 D Q:'$L(ICPTXT)
14 . N ICPTB,DA,DIK,ICPTE,ICPTEX,ICPTND,ICPTNX,ICPTR,ICPTT S ICPTR=0,ICPTXT="" S ICPTEX="S ICPTXT=$T(RAN+"_ICPTL_")" X ICPTEX
15 . S ICPTXT=$$TM(ICPTXT," ") Q:'$L(ICPTXT) Q:'$L($TR(ICPTXT,";","")) S ICPTXT=$P(ICPTXT,";",3,299)
16 . S ICPTB=$P(ICPTXT,"^",1),ICPTE=$P(ICPTXT,"^",2) Q:$L(ICPTB)'=5 Q:$L(ICPTE)'=5 S ICPTND=ICPTB_"^"_ICPTE_"^"_ICPTACT
17 . S ICPTT=0 F S ICPTT=$O(^DIC(81.3,+ICPTM,10,"B",ICPTB,ICPTT)) Q:+ICPTT=0 D
18 . . I $P($G(^DIC(81.3,+ICPTM,10,ICPTT,0)),"^",1,3)=ICPTND S ICPTR=ICPTT
19 . Q:+ICPTR>0 S ICPTNX=$O(^DIC(81.3,+ICPTM,10," "),-1)+1
20 . S ^DIC(81.3,+ICPTM,10,ICPTNX,0)=ICPTND,^DIC(81.3,+ICPTM,10,0)="^81.33DA^"_ICPTNX_"^"_ICPTNX
21 . S DA(1)=+ICPTM,DA=ICPTNX,DIK="^DIC(81.3,"_DA(1)_",10," D IX1^DIK K DA
22 K DA S DA=+ICPTM,DIK="^DIC(81.3," D IX1^DIK K DA
23 Q
24TM(X,Y) ; Trim Spaces
25 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))
26 F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
27 F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,229)
28 Q X
29RAN ; Modifier AJ Code Ranges
30 ;;90801^90804
31 ;;90806^90808
32 ;;90810^90810
33 ;;90812^90812
34 ;;90814^90814
35 ;;90846^90853
36 ;;90857^90857
37 ;;96116^96120
38 ;;97532^97533
39 ;;96150^96151
40 ;;
Note: See TracBrowser for help on using the repository browser.