source: FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTMOD2.m@ 1783

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

initial load of FOIAVistA 6/30/08 version
File size: 6.3 KB
Line 
1ICPTMOD2 ;ALB/DEK/KER - CPT MODIFIER APIS ;08/18/2007
2 ;;6.0;CPT/HCPCS;**30,37**;May 19, 1997;Build 25
3 ;
4 ; Global Variables
5 ; ^DIC(81.3
6 ; ^ICPT(
7 ;
8 ; External References
9 ; $$DT^XLFDT DBIA 10103
10 ; $$FMADD^XLFDT DBIA 10103
11 ;
12 Q
13MODA ; Create an array of Modifiers for a CPT Code
14 ;
15 ; Input
16 ;
17 ; CODE CPT/HCPCS Code ?7N / ?1A4N / ?4N1A
18 ; VDT Versioning Date (date service provided)
19 ; .ARY Name of a Local Array passed by value
20 ;
21 ; Output
22 ;
23 ; ARY Only returns Active Modifiers
24 ; ARY(0) = 4 Piece String
25 ; 4 Piece String
26 ; 1 # of Modifiers found for code CODE (input)
27 ; 2 # of Modifiers w/Active Ranges
28 ; 3 # of Modifiers w/Inactive Ranges
29 ; 4 Code
30 ;
31 ; ARY(ST,MOD) = 8 Piece Output String
32 ;
33 ; ST Status A=Active I=Inactive
34 ; MOD Modifier (external format)
35 ; 8 Piece String
36 ; 1 IEN of Modifier
37 ; 2 Versioned Short Text (name)
38 ; 3 Activation date of Modifier
39 ; 4 Beginning Range Code
40 ; 5 Ending Range Code
41 ; 6 Activation Date of Range
42 ; 7 Inactivation Date of Range
43 ; 8 Modifier Identifier
44 ;
45 N A,EFF,I,ID,MIEN,MOD,SRC,ST,X K ARY
46 S CODE=$G(CODE) Q:'$D(^ICPT("BA",(CODE_" ")))
47 S VDT=$G(VDT) S:+VDT'>0 VDT=$$DT^XLFDT Q:VDT'?7N
48 S SRC=3,MIEN=0 F S MIEN=$O(^DIC(81.3,MIEN)) Q:+MIEN'>0 D
49 . 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
50 . S MOD=$P($G(^DIC(81.3,MIEN,0)),"^",1) Q:'$L(MOD)
51 . S X=$$MODP(CODE,MIEN,"I",VDT,0) S ID=$P(X,"^",6) S ID=$S(+ID>0:"I",1:"A")
52 . S:+X>0 ARY(ID,MOD)=$P(X,"^",1,2)_"^"_EFF_"^"_$P(X,"^",3,7)
53 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
54 S ST=A+I,ARY(0)=ST_"^"_A_"^"_I_"^"_CODE
55 Q
56 ;
57MODP(CODE,MOD,MFT,MDT,SRC,DFN) ; Check if modifier can be used with code (pair)
58 ;
59 ; Input:
60 ;
61 ; CODE CPT/HCPCS Code ?7N / ?1A4N / ?4N1A
62 ; MOD Modifier (External or Internal)
63 ; MFT Modifier Format "E" - or "I"
64 ; VDT Date service provided
65 ; SRC Source Screen
66 ; If 0 or Null, Level I and II modifiers
67 ; If >0, Level I, II, and III modifiers
68 ; Output:
69 ;
70 ; If pair is acceptable - Positive "^" Delimited String
71 ;
72 ; 1 - IEN of CPT Modifier
73 ; 2 - Versioned Short Text
74 ; 3 - Beginning Code for Code Range
75 ; 4 - Ending Code for Code Range
76 ; 5 - Code Range Activaiton Date
77 ; 6 - Code Range Inactivation Date
78 ; 7 - Modifier Identifier
79 ;
80 ; If pair is unacceptable
81 ;
82 ; 0 or
83 ; -1 with error message
84 ;
85 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
86 S:$G(MFT)="" MFT="E" Q:"^E^I^"'[("^"_MFT_"^") "-1^Invalid Modifier Format" S VDT=$P($G(MDT),".",1)
87 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)
88 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"
89 . S MIEN=0 S (TIEN,TI)=0 F S TIEN=$O(^DIC(81.3,"B",MOD,TIEN)) Q:+TIEN'>0 D
90 . . S TEFF=$$EFF^ICPTSUPT(81.3,TIEN,VDT) Q:'$P(TEFF,"^",2) S TI=TI+1,TA(TI)=TIEN,TA(0)=TI
91 . S:+($G(TA(0)))=1 MIEN=+($G(TA(1)))
92 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"
93 S CODE=$P($G(^ICPT(CODN,0)),"^") Q:'$L(CODE) "-1^No such CPT Code" Q:$L(CODE)'=5 "-1^Invalid Code"
94 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"
95 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"
96 Q:$P($G(^ICPT(+SIEN,0)),"^",6)="L"&(SRC'>0) "-1^Invalid Code Source"
97 S MODEFF=$$EFF^ICPTSUPT(81.3,MIEN,VDT) Q:'$P(MODEFF,"^",2) "-1^Modifier Inactive"
98 S MODNM=$P($G(^DIC(81.3,MIEN,0)),"^",2) Q:'$L(MODNM) "-1^Invalid Modifier Name"
99 S MODI=$P($G(^DIC(81.3,MIEN,0)),"^",1) Q:'$L(MODI) "-1^Invalid Modifier ID"
100 S MODST=$$VSTCM^ICPTMOD(MIEN,VDT) K STX S (STA,STI)=0 S CDT=VDT+.001
101 S (LINA,LACT)="",RSTA=0,RIEN=0 F S RIEN=$O(^DIC(81.3,MIEN,10,RIEN)) Q:+RIEN'>0 D
102 . N NSTA S NSTA=0,ND=$G(^DIC(81.3,MIEN,10,RIEN,0))
103 . 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
104 . 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))
105 . Q:$L(ENDR)&(CODEA>ENDA) S ADT=$P(ND,"^",3),(ICD,IDT)=$P(ND,"^",4) S:ADT="" ADT=2890101
106 . I +CODEA'<+BEGA,+CODEA'>ENDA,+ADT>0,+IDT'>0 S RSTA=1,NSTA=1 S:+ADT>0&(+ADT>(+LACT)) LACT=+ADT
107 . 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
108 . I +CODEA'<+BEGA,+CODEA'>ENDA,+ADT>0,+IDT>0 S:+IDT>0&(+IDT>(+LINA)) LINA=+IDT
109 . 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
110 . 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)=""
111 S:+LACT>0&(+LINA>0)&(LINA'>CDT)&(+LINA>+LACT) RSTA=0
112 S ADT=$O(STX("B",+CDT),-1),STA=$O(STX("B",+ADT," "),-1),MOD=$G(STX(+STA))
113 Q:+MOD'>0 "0" Q:+RSTA'>0 "0"
114 Q MOD
115 ;
116MODC(MOD) ; Checks modifier for active range including code
117 ;
118 ; Input:
119 ; MOD - modifier ien
120 ;
121 N MODNM,MODEFF
122 S MODEFF=$$EFF^ICPTSUPT(81.3,MOD,MDT)
123 I '$P(MODEFF,"^",2) S STR="-1^modifier inactive" Q
124 S PR=CODEA_.0001,PR=$O(^DIC(81.3,MOD,"M",PR),-1)
125 I 'PR S STR=0 Q
126 S PRN=^DIC(81.3,MOD,"M",PR)
127 I 'PRN S STR="-1^bad modifier file entry" Q
128 I PRN<CODEA S STR=0 Q
129 S MODNM=$P($G(^DIC(81.3,MOD,0)),"^",2)
130 S STR=MOD_"^"_MODNM
131 Q
132 ;
133MULT ; Finds iens for all modifiers with same 2-letter code
134 ; MOD = .01, check B x-ref for dupliate .01 fields
135 ; Output:
136 ; STR - a ";" delimited string of IENS for modifier MOD
137 F MODN=0:0 S MODN=$O(^DIC(81.3,"B",MOD,MODN)) Q:'MODN S STR=STR_MODN_"; "
138 Q
Note: See TracBrowser for help on using the repository browser.