- 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 Feb 18, 2025@23:30:16 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
