source: FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEX2047A.m@ 949

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

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1LEX2047A ; ISL/KER - Post Install LEX*2.0*47 ; 02/05/2007
2 ;;2.0;LEXICON UTILITY;**47**;Sep 23, 1996;Build 5
3 ;
4 ; Global Variables
5 ; ^ICPT( DBIA 4489
6 ; ^DIC(81.3, DBIA 4492
7 ;
8 ; External References
9 ; FILE^DIE DBIA 2053
10 ; UPDATE^DIE DBIA 2053
11 ; IX1^DIK DBIA 10013
12 ; $$IENS^DILF DBIA 2054
13 ; $$CODEN^ICPTCOD DBIA 1995
14 ; $$CPT^ICPTCOD DBIA 1995
15 ; $$MOD^ICPTMOD DBIA 1996
16 ; $$DT^XLFDT DBIA 10103
17 ; $$FMADD^XLFDT DBIA 10103
18 ; MES^XPDUTL DBIA 10141
19 ;
20EN ; Main Entry Point
21 D C1,C2,C3,C4,C5,EN^LEX2047B
22 Q
23 ;
24 ; Changes
25C1 ; 123616 - 99212/G0245 with A8, AA, QY and 57
26 D IND(" "),REMI("CPT Modifier Ranges Added for A8/AA/QY/57","HD0000000 123616")
27 N CODE,PRO,MOD,MT,VDT K SHOWSTA
28 S CODE="99212",VDT=3050101,PRO=$P($$CPT^ICPTCOD(CODE,(VDT+1)),"^",3)
29 F MOD="A8","AA","QY","57" D
30 . D:MOD="A8" IND((" CPT Range "_CODE))
31 . N ACR,PRO,MT,ND,NN,DA,DIK,MIEN S ACR=$$ACR(CODE,MOD,VDT) Q:+ACR>0
32 . S MT=$$MOD^ICPTMOD(MOD,"E",(VDT+1))
33 . S MIEN=+MT,MT=$P(MT,"^",3) Q:+MIEN'>0 S DA=$O(^DIC(81.3,+MIEN,10," "),-1)+1 Q:+DA'>1
34 . S DA(1)=MIEN,DIK="^DIC(81.3,"_DA(1)_",10,"
35 . S NN=CODE_"^"_CODE_"^"_VDT_"^",ND=DIK_DA_",0)"
36 . S @ND=NN D IX1^DIK
37 S CODE="G0245",PRO=$P($$CPT^ICPTCOD(CODE,(VDT+1)),"^",3)
38 F MOD="A8","AA","QY","57" D
39 . D:MOD="A8" IND((" CPT Range "_CODE))
40 . N ACR,PRO,MT,ND,NN,DA,DIK,MIEN S ACR=$$ACR(CODE,MOD,VDT) Q:+ACR>0
41 . S MT=$$MOD^ICPTMOD(MOD,"E",(VDT+1))
42 . S MIEN=+MT,MT=$P(MT,"^",3) Q:+MIEN'>0 S DA=$O(^DIC(81.3,+MIEN,10," "),-1)+1 Q:+DA'>1
43 . S DA(1)=MIEN,DIK="^DIC(81.3,"_DA(1)_",10,"
44 . S NN=CODE_"^"_CODE_"^"_VDT_"^",ND=DIK_DA_",0)"
45 . S @ND=NN D IX1^DIK
46 Q
47C2 ; 174408 CPT Modifier Ranges Added for TC/26
48 D IND(" "),REMI("CPT Modifier Ranges Added for TC/26","HD0000000 174408")
49 N I,VDT,RANGE
50 S I=0,VDT=3070101,RANGE=""
51 F D Q:'$L($G(RANGE))
52 . N EXEC,CODE,END,MIEN1,MIEN2,MOD,DA,DIK,ND,NN,ACR
53 . S I=I+1,EXEC="S RANGE=$T(TC26+"_I_")" X EXEC
54 . S RANGE=$P(RANGE,";;",2,299) Q:'$L(RANGE) I '$L($TR($TR(RANGE,";","")," ","")) S RANGE="" Q
55 . S CODE=$P(RANGE,";",1),END=$P(RANGE,";",2) Q:$L(CODE)'=5!($L(END)'=5)
56 . S MIEN1=$P(RANGE,";",3),MIEN2=$P(RANGE,";",4) Q:+MIEN1'>0 Q:+MIEN2'>0
57 . D IND((" CPT Range "_CODE))
58 . S MOD="TC",DA(1)=35,DA=MIEN1,DIK="^DIC(81.3,"_DA(1)_",10,",ND=DIK_DA_",0)",NN=CODE_"^"_END_"^"_VDT_"^"
59 . S ACR=$$ACR(CODE,MOD,(VDT+1)) I +ACR'>0 S @ND=NN D IX1^DIK
60 . S MOD="26",DA(1)=7,DA=MIEN2,DIK="^DIC(81.3,"_DA(1)_",10,",ND=DIK_DA_",0)",NN=CODE_"^"_END_"^"_VDT_"^"
61 . S ACR=$$ACR(CODE,MOD,(VDT+1)) I +ACR'>0 S @ND=NN D IX1^DIK
62 Q
63 ;
64C3 ; 134531 - CPT Descriptions for 83519 and 83520
65 D IND(" "),REMI("CPT Descriptions for 83519 and 83520","HD0000000 134531")
66 D IND(" 83519 - IMMUNOASSAY, RIA")
67 D IND(" 83520 - IMMUNOASSAY, NONANTIBODY")
68 N IENS,IENA,IENB,IEN,LEXDA,DA,DIK,DIE S IENA=$O(^ICPT(83519,61,"B",2940601,0)),IENB=$O(^ICPT(83520,61,"B",2940601,0)) Q:IENA'>0 Q:IENB'>0
69 K IENS,FDA S (IEN,LEXDA(1),DA(1))=83519,(LEXDA,DA)=IENA
70 S IENS=$$IENS^DILF(.LEXDA),FDA(81.061,IENS,1)="IMMUNOASSAY, RIA" K IENR,MSG D UPDATE^DIE("","FDA","IENR","MSG")
71 K FDA S FDA(81,IEN_",",2)="IMMUNOASSAY, RIA" D FILE^DIE("","FDA") S DA=IEN,DIK="^ICPT(" D IX1^DIK
72 K IENS,FDA S (IEN,LEXDA(1),DA(1))=83520,(LEXDA,DA)=IENB
73 S IENS=$$IENS^DILF(.LEXDA),FDA(81.061,IENS,1)="IMMUNOASSAY, NONANTIBODY" K IENR,MSG D UPDATE^DIE("","FDA","IENR","MSG")
74 K FDA S FDA(81,IEN_",",2)="IMMUNOASSAY, NONANTIBODY" D FILE^DIE("","FDA") S DA=IEN,DIK="^ICPT(" D IX1^DIK
75 K IENS,FDA S (IEN,LEXDA,DA)=301847
76 S FDA(757.01,IEN_",",.01)="Immunoassay, Analyte, Quantitative; by Radiopharmaceutical Technique (eg, RIA)"
77 D FILE^DIE("","FDA") S DA=IEN,DIK="^LEX(757.01," D IX1^DIK
78 Q
79C4 ; 134531 - CPT Descriptions for 82270 and 82271
80 D IND(" "),REMI("CPT Descriptions for 82270 and 82271","HD0000000 134531")
81 D IND(" 82270 - OCCULT BLOOD, FECES, SINGLE")
82 D IND(" 82271 - OCCULT BLOOD, OTHER SOURCES")
83 N IENS,IENA,IENB,IEN,LEXDA,DA,DIK,DIE S IENA=$O(^ICPT(82270,61,"B",3060101,0)),IENB=$O(^ICPT(82271,61,"B",3060101,0)) Q:IENA'>0 Q:IENB'>0
84 K IENS,FDA S (IEN,LEXDA(1),DA(1))=82270,(LEXDA,DA)=IENA
85 S IENS=$$IENS^DILF(.LEXDA),FDA(81.061,IENS,1)="OCCULT BLOOD, FECES, SINGLE" K IENR,MSG
86 D UPDATE^DIE("","FDA","IENR","MSG") K FDA S FDA(81,IEN_",",2)="OCCULT BLOOD, FECES, SINGLE" D FILE^DIE("","FDA") S DA=IEN,DIK="^ICPT(" D IX1^DIK
87 K IENS,FDA S (IEN,LEXDA,DA)=333338
88 S FDA(757.01,(IEN_","),.01)="Blood, Occult, by Peroxidase Activity (Eg, Guaiac), Qualitative; Feces, consec collected specimens w/ Single Determination, for Colorectal Neoplasm Screening"
89 S FDA(757.01,(IEN_","),.01)=FDA(757.01,(IEN_","),.01)_" (ie, patient was provided 3 cards or single triple card for consec collection)"
90 D FILE^DIE("","FDA") S DA=IEN,DIK="^LEX(757.01," D IX1^DIK
91 K IENS,FDA S (IEN,LEXDA(1),DA(1))=82271,(LEXDA,DA)=IENB
92 S IENS=$$IENS^DILF(.LEXDA),FDA(81.061,IENS,1)="OCCULT BLOOD, OTHER SOURCES" K IENR,MSG D UPDATE^DIE("","FDA","IENR","MSG")
93 K FDA S FDA(81,IEN_",",2)="OCCULT BLOOD, OTHER SOURCES" D FILE^DIE("","FDA") S DA=IEN,DIK="^ICPT(" D IX1^DIK
94 Q
95C5 ; 138905 - CPT Descriptions for 96101-96103
96 D IND(" "),REMI("CPT Descriptions for 96101-96103","HD0000000 138905")
97 D IND(" 96101 - PSYCH TESTING BY PSYCH/PHYS")
98 D IND(" 96102 - PSYCH TESTING BY TECHNICIAN")
99 D IND(" 96103 - PSYCH TESTING ADMIN BY COMP")
100 N IENS,IENA,IENB,IEN,LEXDA,DA,DIK,DIE
101 S (IEN,DA(1),LEXDA(1))=96101,(IENA,LEXDA,DA)=$O(^ICPT(IEN,61,"B",3060101,0)) I +IEN>0,+IENA>0 D
102 . K IENS,FDA S IENS=$$IENS^DILF(.LEXDA),FDA(81.061,IENS,1)="PSYCH TESTING BY PSYCH/PHYS" K IENR,MSG D UPDATE^DIE("","FDA","IENR","MSG")
103 . K IENS,DA,FDA S DA=IEN S FDA(81,IEN_",",2)="PSYCH TESTING BY PSYCH/PHYS" D FILE^DIE("","FDA")
104 . K DA S DA=IEN,DIK="^ICPT(" D IX1^DIK
105 S (IEN,DA(1),LEXDA(1))=96102,(IENA,LEXDA,DA)=$O(^ICPT(IEN,61,"B",3060101,0)) I +IEN>0,+IENA>0 D
106 . K IENS,FDA S IENS=$$IENS^DILF(.LEXDA),FDA(81.061,IENS,1)="PSYCH TESTING BY TECHNICIAN" K IENR,MSG D UPDATE^DIE("","FDA","IENR","MSG")
107 . K IENS,DA,FDA S DA=IEN S FDA(81,IEN_",",2)="PSYCH TESTING BY TECHNICIAN" D FILE^DIE("","FDA")
108 . K DA S DA=IEN,DIK="^ICPT(" D IX1^DIK
109 S (IEN,DA(1),LEXDA(1))=96103,(IENA,LEXDA,DA)=$O(^ICPT(IEN,61,"B",3060101,0)) I +IEN>0,+IENA>0 D
110 . K IENS,FDA S IENS=$$IENS^DILF(.LEXDA),FDA(81.061,IENS,1)="PSYCH TESTING ADMIN BY COMP" K IENR,MSG D UPDATE^DIE("","FDA","IENR","MSG")
111 . K IENS,DA,FDA S DA=IEN S FDA(81,IEN_",",2)="PSYCH TESTING ADMIN BY COMP" D FILE^DIE("","FDA")
112 . K DA S DA=IEN,DIK="^ICPT(" D IX1^DIK
113 Q
114 ;
115 ; Miscellaneous
116TC26 ; Modifiers TC and 26 Ranges
117 ;;76998;76998;248;163
118 ;;77001;77003;249;164
119 ;;77011;77014;250;165
120 ;;77021;77022;251;166
121 ;;77031;77032;252;167
122 ;;77051;77059;253;168
123 ;;77072;77084;254;169
124 ;;92025;92025;255;170
125 ;;96020;96020;256;171
126 ;;G0389;G0389;257;172
127 ;;
128 Q
129ACR(X,MOD,EFF) ; Code contained in Active Modifier Code Range
130 N CODE S CODE=$G(X),MOD=$G(MOD),EFF=$G(EFF)
131 N TD,CIEN,MIEN,RIEN,IEN,IEN2,BEG,END,BN,EN,CN,ACT,INA,IN,OK,NIEN,ND,NN S TD=$$FMADD^XLFDT($$DT^XLFDT,91)
132 Q:'$D(^ICPT("BA",(CODE_" "))) -1 Q:'$D(^DIC(81.3,"BA",(MOD_" "))) -1 Q:EFF'?7N -1 Q:EFF'<TD -1
133 S CIEN=$$CODEN^ICPTCOD(CODE),MIEN=0,IEN=0 F S IEN=$O(^DIC(81.3,"BA",(MOD_" "),IEN)) Q:+IEN'>0 D
134 . N IEN2,STA,ND S IEN2=$O(^DIC(81.3,IEN,60,"B"," "),-1),IEN2=$O(^DIC(81.3,IEN,60,"B",+IEN2," "),-1)
135 . S ND=$G(^DIC(81.3,IEN,60,IEN2,0)),STA=$P(ND,"^",2) Q:+STA'>0 S MIEN=IEN
136 Q:CIEN'>0 -1 Q:'$D(^ICPT(CIEN,0)) -1 Q:MIEN'>0 -1 Q:'$D(^DIC(81.3,MIEN,0)) -1
137 S (OK,IEN,IN)=0 F S IEN=$O(^DIC(81.3,MIEN,10,IEN)) Q:+IEN=0 D Q:OK
138 . N ND S ND=$G(^DIC(81.3,MIEN,10,IEN,0)),BEG=$P(ND,"^",1),END=$P(ND,"^",2),ACT=$P(ND,"^",3),INA=$P(ND,"^",4)
139 . S:$L(BEG)=5&('$L(END)) END=BEG Q:$L(END)'=5 Q:$L(BEG)'=5
140 . S BN=$S(BEG?1.N:+BEG,BEG?4N1A:$A($E(BEG,5))*10_$E(BEG,1,4),1:$A(BEG)_$E(BEG,2,5))
141 . S EN=$S(END?1.N:+END,END?4N1A:$A($E(END,5))*10_$E(END,1,4),1:$A(END)_$E(END,2,5))
142 . S CN=$S(CODE?1.N:+CODE,CODE?4N1A:$A($E(CODE,5))*10_$E(CODE,1,4),1:$A(CODE)_$E(CODE,2,5))
143 . Q:CN<BN!(CN>EN) S:+INA>0 IN=1 Q:+INA>0 S:CN'<BN&(CN'>EN) OK=1
144 S X=OK
145 Q X
146REMI(X,Y) ; Remedy Ticket - Indented
147 N I S X=$G(X),Y=$G(Y) Q:'$L(X)
148 I $L(Y) S X=" "_X F Q:$L(X)>54 S X=X_" "
149 S X=X_" "_Y S:$E(X,1)'=" " X=" "_X D MES^XPDUTL(X) Q
150IND(X) ; Indent Text
151 N I S X=$G(X) Q:'$L(X) S X=" "_X D MES^XPDUTL(X)
152 Q
Note: See TracBrowser for help on using the repository browser.