LEX2047A ; ISL/KER - Post Install LEX*2.0*47 ; 02/05/2007
;;2.0;LEXICON UTILITY;**47**;Sep 23, 1996;Build 5
;
; Global Variables
; ^ICPT( DBIA 4489
; ^DIC(81.3, DBIA 4492
;
; External References
; FILE^DIE DBIA 2053
; UPDATE^DIE DBIA 2053
; IX1^DIK DBIA 10013
; $$IENS^DILF DBIA 2054
; $$CODEN^ICPTCOD DBIA 1995
; $$CPT^ICPTCOD DBIA 1995
; $$MOD^ICPTMOD DBIA 1996
; $$DT^XLFDT DBIA 10103
; $$FMADD^XLFDT DBIA 10103
; MES^XPDUTL DBIA 10141
;
EN ; Main Entry Point
D C1,C2,C3,C4,C5,EN^LEX2047B
Q
;
; Changes
C1 ; 123616 - 99212/G0245 with A8, AA, QY and 57
D IND(" "),REMI("CPT Modifier Ranges Added for A8/AA/QY/57","HD0000000 123616")
N CODE,PRO,MOD,MT,VDT K SHOWSTA
S CODE="99212",VDT=3050101,PRO=$P($$CPT^ICPTCOD(CODE,(VDT+1)),"^",3)
F MOD="A8","AA","QY","57" D
. D:MOD="A8" IND((" CPT Range "_CODE))
. N ACR,PRO,MT,ND,NN,DA,DIK,MIEN S ACR=$$ACR(CODE,MOD,VDT) Q:+ACR>0
. S MT=$$MOD^ICPTMOD(MOD,"E",(VDT+1))
. S MIEN=+MT,MT=$P(MT,"^",3) Q:+MIEN'>0 S DA=$O(^DIC(81.3,+MIEN,10," "),-1)+1 Q:+DA'>1
. S DA(1)=MIEN,DIK="^DIC(81.3,"_DA(1)_",10,"
. S NN=CODE_"^"_CODE_"^"_VDT_"^",ND=DIK_DA_",0)"
. S @ND=NN D IX1^DIK
S CODE="G0245",PRO=$P($$CPT^ICPTCOD(CODE,(VDT+1)),"^",3)
F MOD="A8","AA","QY","57" D
. D:MOD="A8" IND((" CPT Range "_CODE))
. N ACR,PRO,MT,ND,NN,DA,DIK,MIEN S ACR=$$ACR(CODE,MOD,VDT) Q:+ACR>0
. S MT=$$MOD^ICPTMOD(MOD,"E",(VDT+1))
. S MIEN=+MT,MT=$P(MT,"^",3) Q:+MIEN'>0 S DA=$O(^DIC(81.3,+MIEN,10," "),-1)+1 Q:+DA'>1
. S DA(1)=MIEN,DIK="^DIC(81.3,"_DA(1)_",10,"
. S NN=CODE_"^"_CODE_"^"_VDT_"^",ND=DIK_DA_",0)"
. S @ND=NN D IX1^DIK
Q
C2 ; 174408 CPT Modifier Ranges Added for TC/26
D IND(" "),REMI("CPT Modifier Ranges Added for TC/26","HD0000000 174408")
N I,VDT,RANGE
S I=0,VDT=3070101,RANGE=""
F D Q:'$L($G(RANGE))
. N EXEC,CODE,END,MIEN1,MIEN2,MOD,DA,DIK,ND,NN,ACR
. S I=I+1,EXEC="S RANGE=$T(TC26+"_I_")" X EXEC
. S RANGE=$P(RANGE,";;",2,299) Q:'$L(RANGE) I '$L($TR($TR(RANGE,";","")," ","")) S RANGE="" Q
. S CODE=$P(RANGE,";",1),END=$P(RANGE,";",2) Q:$L(CODE)'=5!($L(END)'=5)
. S MIEN1=$P(RANGE,";",3),MIEN2=$P(RANGE,";",4) Q:+MIEN1'>0 Q:+MIEN2'>0
. D IND((" CPT Range "_CODE))
. S MOD="TC",DA(1)=35,DA=MIEN1,DIK="^DIC(81.3,"_DA(1)_",10,",ND=DIK_DA_",0)",NN=CODE_"^"_END_"^"_VDT_"^"
. S ACR=$$ACR(CODE,MOD,(VDT+1)) I +ACR'>0 S @ND=NN D IX1^DIK
. S MOD="26",DA(1)=7,DA=MIEN2,DIK="^DIC(81.3,"_DA(1)_",10,",ND=DIK_DA_",0)",NN=CODE_"^"_END_"^"_VDT_"^"
. S ACR=$$ACR(CODE,MOD,(VDT+1)) I +ACR'>0 S @ND=NN D IX1^DIK
Q
;
C3 ; 134531 - CPT Descriptions for 83519 and 83520
D IND(" "),REMI("CPT Descriptions for 83519 and 83520","HD0000000 134531")
D IND(" 83519 - IMMUNOASSAY, RIA")
D IND(" 83520 - IMMUNOASSAY, NONANTIBODY")
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
K IENS,FDA S (IEN,LEXDA(1),DA(1))=83519,(LEXDA,DA)=IENA
S IENS=$$IENS^DILF(.LEXDA),FDA(81.061,IENS,1)="IMMUNOASSAY, RIA" K IENR,MSG D UPDATE^DIE("","FDA","IENR","MSG")
K FDA S FDA(81,IEN_",",2)="IMMUNOASSAY, RIA" D FILE^DIE("","FDA") S DA=IEN,DIK="^ICPT(" D IX1^DIK
K IENS,FDA S (IEN,LEXDA(1),DA(1))=83520,(LEXDA,DA)=IENB
S IENS=$$IENS^DILF(.LEXDA),FDA(81.061,IENS,1)="IMMUNOASSAY, NONANTIBODY" K IENR,MSG D UPDATE^DIE("","FDA","IENR","MSG")
K FDA S FDA(81,IEN_",",2)="IMMUNOASSAY, NONANTIBODY" D FILE^DIE("","FDA") S DA=IEN,DIK="^ICPT(" D IX1^DIK
K IENS,FDA S (IEN,LEXDA,DA)=301847
S FDA(757.01,IEN_",",.01)="Immunoassay, Analyte, Quantitative; by Radiopharmaceutical Technique (eg, RIA)"
D FILE^DIE("","FDA") S DA=IEN,DIK="^LEX(757.01," D IX1^DIK
Q
C4 ; 134531 - CPT Descriptions for 82270 and 82271
D IND(" "),REMI("CPT Descriptions for 82270 and 82271","HD0000000 134531")
D IND(" 82270 - OCCULT BLOOD, FECES, SINGLE")
D IND(" 82271 - OCCULT BLOOD, OTHER SOURCES")
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
K IENS,FDA S (IEN,LEXDA(1),DA(1))=82270,(LEXDA,DA)=IENA
S IENS=$$IENS^DILF(.LEXDA),FDA(81.061,IENS,1)="OCCULT BLOOD, FECES, SINGLE" K IENR,MSG
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
K IENS,FDA S (IEN,LEXDA,DA)=333338
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"
S FDA(757.01,(IEN_","),.01)=FDA(757.01,(IEN_","),.01)_" (ie, patient was provided 3 cards or single triple card for consec collection)"
D FILE^DIE("","FDA") S DA=IEN,DIK="^LEX(757.01," D IX1^DIK
K IENS,FDA S (IEN,LEXDA(1),DA(1))=82271,(LEXDA,DA)=IENB
S IENS=$$IENS^DILF(.LEXDA),FDA(81.061,IENS,1)="OCCULT BLOOD, OTHER SOURCES" K IENR,MSG D UPDATE^DIE("","FDA","IENR","MSG")
K FDA S FDA(81,IEN_",",2)="OCCULT BLOOD, OTHER SOURCES" D FILE^DIE("","FDA") S DA=IEN,DIK="^ICPT(" D IX1^DIK
Q
C5 ; 138905 - CPT Descriptions for 96101-96103
D IND(" "),REMI("CPT Descriptions for 96101-96103","HD0000000 138905")
D IND(" 96101 - PSYCH TESTING BY PSYCH/PHYS")
D IND(" 96102 - PSYCH TESTING BY TECHNICIAN")
D IND(" 96103 - PSYCH TESTING ADMIN BY COMP")
N IENS,IENA,IENB,IEN,LEXDA,DA,DIK,DIE
S (IEN,DA(1),LEXDA(1))=96101,(IENA,LEXDA,DA)=$O(^ICPT(IEN,61,"B",3060101,0)) I +IEN>0,+IENA>0 D
. 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")
. K IENS,DA,FDA S DA=IEN S FDA(81,IEN_",",2)="PSYCH TESTING BY PSYCH/PHYS" D FILE^DIE("","FDA")
. K DA S DA=IEN,DIK="^ICPT(" D IX1^DIK
S (IEN,DA(1),LEXDA(1))=96102,(IENA,LEXDA,DA)=$O(^ICPT(IEN,61,"B",3060101,0)) I +IEN>0,+IENA>0 D
. 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")
. K IENS,DA,FDA S DA=IEN S FDA(81,IEN_",",2)="PSYCH TESTING BY TECHNICIAN" D FILE^DIE("","FDA")
. K DA S DA=IEN,DIK="^ICPT(" D IX1^DIK
S (IEN,DA(1),LEXDA(1))=96103,(IENA,LEXDA,DA)=$O(^ICPT(IEN,61,"B",3060101,0)) I +IEN>0,+IENA>0 D
. 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")
. K IENS,DA,FDA S DA=IEN S FDA(81,IEN_",",2)="PSYCH TESTING ADMIN BY COMP" D FILE^DIE("","FDA")
. K DA S DA=IEN,DIK="^ICPT(" D IX1^DIK
Q
;
; Miscellaneous
TC26 ; Modifiers TC and 26 Ranges
;;76998;76998;248;163
;;77001;77003;249;164
;;77011;77014;250;165
;;77021;77022;251;166
;;77031;77032;252;167
;;77051;77059;253;168
;;77072;77084;254;169
;;92025;92025;255;170
;;96020;96020;256;171
;;G0389;G0389;257;172
;;
Q
ACR(X,MOD,EFF) ; Code contained in Active Modifier Code Range
N CODE S CODE=$G(X),MOD=$G(MOD),EFF=$G(EFF)
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)
Q:'$D(^ICPT("BA",(CODE_" "))) -1 Q:'$D(^DIC(81.3,"BA",(MOD_" "))) -1 Q:EFF'?7N -1 Q:EFF'<TD -1
S CIEN=$$CODEN^ICPTCOD(CODE),MIEN=0,IEN=0 F S IEN=$O(^DIC(81.3,"BA",(MOD_" "),IEN)) Q:+IEN'>0 D
. N IEN2,STA,ND S IEN2=$O(^DIC(81.3,IEN,60,"B"," "),-1),IEN2=$O(^DIC(81.3,IEN,60,"B",+IEN2," "),-1)
. S ND=$G(^DIC(81.3,IEN,60,IEN2,0)),STA=$P(ND,"^",2) Q:+STA'>0 S MIEN=IEN
Q:CIEN'>0 -1 Q:'$D(^ICPT(CIEN,0)) -1 Q:MIEN'>0 -1 Q:'$D(^DIC(81.3,MIEN,0)) -1
S (OK,IEN,IN)=0 F S IEN=$O(^DIC(81.3,MIEN,10,IEN)) Q:+IEN=0 D Q:OK
. 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)
. S:$L(BEG)=5&('$L(END)) END=BEG Q:$L(END)'=5 Q:$L(BEG)'=5
. 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))
. 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))
. 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))
. Q:CN<BN!(CN>EN) S:+INA>0 IN=1 Q:+INA>0 S:CN'<BN&(CN'>EN) OK=1
S X=OK
Q X
REMI(X,Y) ; Remedy Ticket - Indented
N I S X=$G(X),Y=$G(Y) Q:'$L(X)
I $L(Y) S X=" "_X F Q:$L(X)>54 S X=X_" "
S X=X_" "_Y S:$E(X,1)'=" " X=" "_X D MES^XPDUTL(X) Q
IND(X) ; Indent Text
N I S X=$G(X) Q:'$L(X) S X=" "_X D MES^XPDUTL(X)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEX2047A 8580 printed Apr 09, 2024@21:11:26 Page 2
LEX2047A ; ISL/KER - Post Install LEX*2.0*47 ; 02/05/2007
+1 ;;2.0;LEXICON UTILITY;**47**;Sep 23, 1996;Build 5
+2 ;
+3 ; Global Variables
+4 ; ^ICPT( DBIA 4489
+5 ; ^DIC(81.3, DBIA 4492
+6 ;
+7 ; External References
+8 ; FILE^DIE DBIA 2053
+9 ; UPDATE^DIE DBIA 2053
+10 ; IX1^DIK DBIA 10013
+11 ; $$IENS^DILF DBIA 2054
+12 ; $$CODEN^ICPTCOD DBIA 1995
+13 ; $$CPT^ICPTCOD DBIA 1995
+14 ; $$MOD^ICPTMOD DBIA 1996
+15 ; $$DT^XLFDT DBIA 10103
+16 ; $$FMADD^XLFDT DBIA 10103
+17 ; MES^XPDUTL DBIA 10141
+18 ;
EN ; Main Entry Point
+1 DO C1
DO C2
DO C3
DO C4
DO C5
DO EN^LEX2047B
+2 QUIT
+3 ;
+4 ; Changes
C1 ; 123616 - 99212/G0245 with A8, AA, QY and 57
+1 DO IND(" ")
DO REMI("CPT Modifier Ranges Added for A8/AA/QY/57","HD0000000 123616")
+2 NEW CODE,PRO,MOD,MT,VDT
KILL SHOWSTA
+3 SET CODE="99212"
SET VDT=3050101
SET PRO=$PIECE($$CPT^ICPTCOD(CODE,(VDT+1)),"^",3)
+4 FOR MOD="A8","AA","QY","57"
Begin DoDot:1
+5 if MOD="A8"
DO IND((" CPT Range "_CODE))
+6 NEW ACR,PRO,MT,ND,NN,DA,DIK,MIEN
SET ACR=$$ACR(CODE,MOD,VDT)
if +ACR>0
QUIT
+7 SET MT=$$MOD^ICPTMOD(MOD,"E",(VDT+1))
+8 SET MIEN=+MT
SET MT=$PIECE(MT,"^",3)
if +MIEN'>0
QUIT
SET DA=$ORDER(^DIC(81.3,+MIEN,10," "),-1)+1
if +DA'>1
QUIT
+9 SET DA(1)=MIEN
SET DIK="^DIC(81.3,"_DA(1)_",10,"
+10 SET NN=CODE_"^"_CODE_"^"_VDT_"^"
SET ND=DIK_DA_",0)"
+11 SET @ND=NN
DO IX1^DIK
End DoDot:1
+12 SET CODE="G0245"
SET PRO=$PIECE($$CPT^ICPTCOD(CODE,(VDT+1)),"^",3)
+13 FOR MOD="A8","AA","QY","57"
Begin DoDot:1
+14 if MOD="A8"
DO IND((" CPT Range "_CODE))
+15 NEW ACR,PRO,MT,ND,NN,DA,DIK,MIEN
SET ACR=$$ACR(CODE,MOD,VDT)
if +ACR>0
QUIT
+16 SET MT=$$MOD^ICPTMOD(MOD,"E",(VDT+1))
+17 SET MIEN=+MT
SET MT=$PIECE(MT,"^",3)
if +MIEN'>0
QUIT
SET DA=$ORDER(^DIC(81.3,+MIEN,10," "),-1)+1
if +DA'>1
QUIT
+18 SET DA(1)=MIEN
SET DIK="^DIC(81.3,"_DA(1)_",10,"
+19 SET NN=CODE_"^"_CODE_"^"_VDT_"^"
SET ND=DIK_DA_",0)"
+20 SET @ND=NN
DO IX1^DIK
End DoDot:1
+21 QUIT
C2 ; 174408 CPT Modifier Ranges Added for TC/26
+1 DO IND(" ")
DO REMI("CPT Modifier Ranges Added for TC/26","HD0000000 174408")
+2 NEW I,VDT,RANGE
+3 SET I=0
SET VDT=3070101
SET RANGE=""
+4 FOR
Begin DoDot:1
+5 NEW EXEC,CODE,END,MIEN1,MIEN2,MOD,DA,DIK,ND,NN,ACR
+6 SET I=I+1
SET EXEC="S RANGE=$T(TC26+"_I_")"
XECUTE EXEC
+7 SET RANGE=$PIECE(RANGE,";;",2,299)
if '$LENGTH(RANGE)
QUIT
IF '$LENGTH($TRANSLATE($TRANSLATE(RANGE,";","")," ",""))
SET RANGE=""
QUIT
+8 SET CODE=$PIECE(RANGE,";",1)
SET END=$PIECE(RANGE,";",2)
if $LENGTH(CODE)'=5!($LENGTH(END)'=5)
QUIT
+9 SET MIEN1=$PIECE(RANGE,";",3)
SET MIEN2=$PIECE(RANGE,";",4)
if +MIEN1'>0
QUIT
if +MIEN2'>0
QUIT
+10 DO IND((" CPT Range "_CODE))
+11 SET MOD="TC"
SET DA(1)=35
SET DA=MIEN1
SET DIK="^DIC(81.3,"_DA(1)_",10,"
SET ND=DIK_DA_",0)"
SET NN=CODE_"^"_END_"^"_VDT_"^"
+12 SET ACR=$$ACR(CODE,MOD,(VDT+1))
IF +ACR'>0
SET @ND=NN
DO IX1^DIK
+13 SET MOD="26"
SET DA(1)=7
SET DA=MIEN2
SET DIK="^DIC(81.3,"_DA(1)_",10,"
SET ND=DIK_DA_",0)"
SET NN=CODE_"^"_END_"^"_VDT_"^"
+14 SET ACR=$$ACR(CODE,MOD,(VDT+1))
IF +ACR'>0
SET @ND=NN
DO IX1^DIK
End DoDot:1
if '$LENGTH($GET(RANGE))
QUIT
+15 QUIT
+16 ;
C3 ; 134531 - CPT Descriptions for 83519 and 83520
+1 DO IND(" ")
DO REMI("CPT Descriptions for 83519 and 83520","HD0000000 134531")
+2 DO IND(" 83519 - IMMUNOASSAY, RIA")
+3 DO IND(" 83520 - IMMUNOASSAY, NONANTIBODY")
+4 NEW IENS,IENA,IENB,IEN,LEXDA,DA,DIK,DIE
SET IENA=$ORDER(^ICPT(83519,61,"B",2940601,0))
SET IENB=$ORDER(^ICPT(83520,61,"B",2940601,0))
if IENA'>0
QUIT
if IENB'>0
QUIT
+5 KILL IENS,FDA
SET (IEN,LEXDA(1),DA(1))=83519
SET (LEXDA,DA)=IENA
+6 SET IENS=$$IENS^DILF(.LEXDA)
SET FDA(81.061,IENS,1)="IMMUNOASSAY, RIA"
KILL IENR,MSG
DO UPDATE^DIE("","FDA","IENR","MSG")
+7 KILL FDA
SET FDA(81,IEN_",",2)="IMMUNOASSAY, RIA"
DO FILE^DIE("","FDA")
SET DA=IEN
SET DIK="^ICPT("
DO IX1^DIK
+8 KILL IENS,FDA
SET (IEN,LEXDA(1),DA(1))=83520
SET (LEXDA,DA)=IENB
+9 SET IENS=$$IENS^DILF(.LEXDA)
SET FDA(81.061,IENS,1)="IMMUNOASSAY, NONANTIBODY"
KILL IENR,MSG
DO UPDATE^DIE("","FDA","IENR","MSG")
+10 KILL FDA
SET FDA(81,IEN_",",2)="IMMUNOASSAY, NONANTIBODY"
DO FILE^DIE("","FDA")
SET DA=IEN
SET DIK="^ICPT("
DO IX1^DIK
+11 KILL IENS,FDA
SET (IEN,LEXDA,DA)=301847
+12 SET FDA(757.01,IEN_",",.01)="Immunoassay, Analyte, Quantitative; by Radiopharmaceutical Technique (eg, RIA)"
+13 DO FILE^DIE("","FDA")
SET DA=IEN
SET DIK="^LEX(757.01,"
DO IX1^DIK
+14 QUIT
C4 ; 134531 - CPT Descriptions for 82270 and 82271
+1 DO IND(" ")
DO REMI("CPT Descriptions for 82270 and 82271","HD0000000 134531")
+2 DO IND(" 82270 - OCCULT BLOOD, FECES, SINGLE")
+3 DO IND(" 82271 - OCCULT BLOOD, OTHER SOURCES")
+4 NEW IENS,IENA,IENB,IEN,LEXDA,DA,DIK,DIE
SET IENA=$ORDER(^ICPT(82270,61,"B",3060101,0))
SET IENB=$ORDER(^ICPT(82271,61,"B",3060101,0))
if IENA'>0
QUIT
if IENB'>0
QUIT
+5 KILL IENS,FDA
SET (IEN,LEXDA(1),DA(1))=82270
SET (LEXDA,DA)=IENA
+6 SET IENS=$$IENS^DILF(.LEXDA)
SET FDA(81.061,IENS,1)="OCCULT BLOOD, FECES, SINGLE"
KILL IENR,MSG
+7 DO UPDATE^DIE("","FDA","IENR","MSG")
KILL FDA
SET FDA(81,IEN_",",2)="OCCULT BLOOD, FECES, SINGLE"
DO FILE^DIE("","FDA")
SET DA=IEN
SET DIK="^ICPT("
DO IX1^DIK
+8 KILL IENS,FDA
SET (IEN,LEXDA,DA)=333338
+9 SET FDA(757.01,(IEN_","),.01)="Blood, Occult, by Peroxidase Activity (Eg, Guaiac), Qualitative; Feces, consec collected specimens w/ Single Determination, for Colorectal Neoplasm Screening"
+10 SET FDA(757.01,(IEN_","),.01)=FDA(757.01,(IEN_","),.01)_" (ie, patient was provided 3 cards or single triple card for consec collection)"
+11 DO FILE^DIE("","FDA")
SET DA=IEN
SET DIK="^LEX(757.01,"
DO IX1^DIK
+12 KILL IENS,FDA
SET (IEN,LEXDA(1),DA(1))=82271
SET (LEXDA,DA)=IENB
+13 SET IENS=$$IENS^DILF(.LEXDA)
SET FDA(81.061,IENS,1)="OCCULT BLOOD, OTHER SOURCES"
KILL IENR,MSG
DO UPDATE^DIE("","FDA","IENR","MSG")
+14 KILL FDA
SET FDA(81,IEN_",",2)="OCCULT BLOOD, OTHER SOURCES"
DO FILE^DIE("","FDA")
SET DA=IEN
SET DIK="^ICPT("
DO IX1^DIK
+15 QUIT
C5 ; 138905 - CPT Descriptions for 96101-96103
+1 DO IND(" ")
DO REMI("CPT Descriptions for 96101-96103","HD0000000 138905")
+2 DO IND(" 96101 - PSYCH TESTING BY PSYCH/PHYS")
+3 DO IND(" 96102 - PSYCH TESTING BY TECHNICIAN")
+4 DO IND(" 96103 - PSYCH TESTING ADMIN BY COMP")
+5 NEW IENS,IENA,IENB,IEN,LEXDA,DA,DIK,DIE
+6 SET (IEN,DA(1),LEXDA(1))=96101
SET (IENA,LEXDA,DA)=$ORDER(^ICPT(IEN,61,"B",3060101,0))
IF +IEN>0
IF +IENA>0
Begin DoDot:1
+7 KILL IENS,FDA
SET IENS=$$IENS^DILF(.LEXDA)
SET FDA(81.061,IENS,1)="PSYCH TESTING BY PSYCH/PHYS"
KILL IENR,MSG
DO UPDATE^DIE("","FDA","IENR","MSG")
+8 KILL IENS,DA,FDA
SET DA=IEN
SET FDA(81,IEN_",",2)="PSYCH TESTING BY PSYCH/PHYS"
DO FILE^DIE("","FDA")
+9 KILL DA
SET DA=IEN
SET DIK="^ICPT("
DO IX1^DIK
End DoDot:1
+10 SET (IEN,DA(1),LEXDA(1))=96102
SET (IENA,LEXDA,DA)=$ORDER(^ICPT(IEN,61,"B",3060101,0))
IF +IEN>0
IF +IENA>0
Begin DoDot:1
+11 KILL IENS,FDA
SET IENS=$$IENS^DILF(.LEXDA)
SET FDA(81.061,IENS,1)="PSYCH TESTING BY TECHNICIAN"
KILL IENR,MSG
DO UPDATE^DIE("","FDA","IENR","MSG")
+12 KILL IENS,DA,FDA
SET DA=IEN
SET FDA(81,IEN_",",2)="PSYCH TESTING BY TECHNICIAN"
DO FILE^DIE("","FDA")
+13 KILL DA
SET DA=IEN
SET DIK="^ICPT("
DO IX1^DIK
End DoDot:1
+14 SET (IEN,DA(1),LEXDA(1))=96103
SET (IENA,LEXDA,DA)=$ORDER(^ICPT(IEN,61,"B",3060101,0))
IF +IEN>0
IF +IENA>0
Begin DoDot:1
+15 KILL IENS,FDA
SET IENS=$$IENS^DILF(.LEXDA)
SET FDA(81.061,IENS,1)="PSYCH TESTING ADMIN BY COMP"
KILL IENR,MSG
DO UPDATE^DIE("","FDA","IENR","MSG")
+16 KILL IENS,DA,FDA
SET DA=IEN
SET FDA(81,IEN_",",2)="PSYCH TESTING ADMIN BY COMP"
DO FILE^DIE("","FDA")
+17 KILL DA
SET DA=IEN
SET DIK="^ICPT("
DO IX1^DIK
End DoDot:1
+18 QUIT
+19 ;
+20 ; Miscellaneous
TC26 ; Modifiers TC and 26 Ranges
+1 ;;76998;76998;248;163
+2 ;;77001;77003;249;164
+3 ;;77011;77014;250;165
+4 ;;77021;77022;251;166
+5 ;;77031;77032;252;167
+6 ;;77051;77059;253;168
+7 ;;77072;77084;254;169
+8 ;;92025;92025;255;170
+9 ;;96020;96020;256;171
+10 ;;G0389;G0389;257;172
+11 ;;
+12 QUIT
ACR(X,MOD,EFF) ; Code contained in Active Modifier Code Range
+1 NEW CODE
SET CODE=$GET(X)
SET MOD=$GET(MOD)
SET EFF=$GET(EFF)
+2 NEW TD,CIEN,MIEN,RIEN,IEN,IEN2,BEG,END,BN,EN,CN,ACT,INA,IN,OK,NIEN,ND,NN
SET TD=$$FMADD^XLFDT($$DT^XLFDT,91)
+3 if '$DATA(^ICPT("BA",(CODE_" ")))
QUIT -1
if '$DATA(^DIC(81.3,"BA",(MOD_" ")))
QUIT -1
if EFF'?7N
QUIT -1
if EFF'<TD
QUIT -1
+4 SET CIEN=$$CODEN^ICPTCOD(CODE)
SET MIEN=0
SET IEN=0
FOR
SET IEN=$ORDER(^DIC(81.3,"BA",(MOD_" "),IEN))
if +IEN'>0
QUIT
Begin DoDot:1
+5 NEW IEN2,STA,ND
SET IEN2=$ORDER(^DIC(81.3,IEN,60,"B"," "),-1)
SET IEN2=$ORDER(^DIC(81.3,IEN,60,"B",+IEN2," "),-1)
+6 SET ND=$GET(^DIC(81.3,IEN,60,IEN2,0))
SET STA=$PIECE(ND,"^",2)
if +STA'>0
QUIT
SET MIEN=IEN
End DoDot:1
+7 if CIEN'>0
QUIT -1
if '$DATA(^ICPT(CIEN,0))
QUIT -1
if MIEN'>0
QUIT -1
if '$DATA(^DIC(81.3,MIEN,0))
QUIT -1
+8 SET (OK,IEN,IN)=0
FOR
SET IEN=$ORDER(^DIC(81.3,MIEN,10,IEN))
if +IEN=0
QUIT
Begin DoDot:1
+9 NEW ND
SET ND=$GET(^DIC(81.3,MIEN,10,IEN,0))
SET BEG=$PIECE(ND,"^",1)
SET END=$PIECE(ND,"^",2)
SET ACT=$PIECE(ND,"^",3)
SET INA=$PIECE(ND,"^",4)
+10 if $LENGTH(BEG)=5&('$LENGTH(END))
SET END=BEG
if $LENGTH(END)'=5
QUIT
if $LENGTH(BEG)'=5
QUIT
+11 SET BN=$SELECT(BEG?1.N:+BEG,BEG?4N1A:$ASCII($EXTRACT(BEG,5))*10_$EXTRACT(BEG,1,4),1:$ASCII(BEG)_$EXTRACT(BEG,2,5))
+12 SET EN=$SELECT(END?1.N:+END,END?4N1A:$ASCII($EXTRACT(END,5))*10_$EXTRACT(END,1,4),1:$ASCII(END)_$EXTRACT(END,2,5))
+13 SET CN=$SELECT(CODE?1.N:+CODE,CODE?4N1A:$ASCII($EXTRACT(CODE,5))*10_$EXTRACT(CODE,1,4),1:$ASCII(CODE)_$EXTRACT(CODE,2,5))
+14 if CN<BN!(CN>EN)
QUIT
if +INA>0
SET IN=1
if +INA>0
QUIT
if CN'<BN&(CN'>EN)
SET OK=1
End DoDot:1
if OK
QUIT
+15 SET X=OK
+16 QUIT X
REMI(X,Y) ; Remedy Ticket - Indented
+1 NEW I
SET X=$GET(X)
SET Y=$GET(Y)
if '$LENGTH(X)
QUIT
+2 IF $LENGTH(Y)
SET X=" "_X
FOR
if $LENGTH(X)>54
QUIT
SET X=X_" "
+3 SET X=X_" "_Y
if $EXTRACT(X,1)'=" "
SET X=" "_X
DO MES^XPDUTL(X)
QUIT
IND(X) ; Indent Text
+1 NEW I
SET X=$GET(X)
if '$LENGTH(X)
QUIT
SET X=" "_X
DO MES^XPDUTL(X)
+2 QUIT
