ICPT63PT ;ALB/ESD - CPT Update '98 Post-Init Driver; 1/29/98
;;6.0;CPT/HCPCS;**3**;May 19, 1997
;
EN ;- Main entry point
;
;- Modify CPT Copyright file (#81.2)
D DISTUP
;
;- Add, revise, inactivate categories in the CPT Category file (#81.1)
D CATUPD
;
;- Add, revise, inactivate modifiers in the CPT Modifier file (#81.3)
D EN^ICPT63P2
;
;- Reminder message to users to reload the ^ICPT global
D MES^XPDUTL("")
D BMES^XPDUTL("****** YOU MUST LOAD THE CPT GLOBAL (^ICPT) FROM THE FILE ICPT6_3.GBL")
D MES^XPDUTL("UPON COMPLETION OF THIS INSTALLATION! ******")
D MES^XPDUTL("")
ENQ Q
;
;
DISTUP ;- Entry point for Distribution Date update
;
D MES^XPDUTL("")
D BMES^XPDUTL(">>> Updating Distribution Date in the CPT Copyright file (#81.2)......")
I '$$DISTDT D G DISTUPQ
. D BMES^XPDUTL(">>> Error updating Distribution Date field in CPT Copyright file (#81.2).")
D MES^XPDUTL("......completed.")
DISTUPQ Q
;
;
DISTDT() ;- Add distribution date to file #81.2
N DIC,DIE,DR,X,Y
S DIC="^DIC(81.2,"
S DIC(0)="OX"
;
;- Get entry (currently only one entry exists in this file)
S X="CPT MESSAGE"
D ^DIC
I +Y=-1 G DISTDTQ
;
;- Add date
S DA=+Y
S DIE=DIC
S DR=".02///2980201"
D ^DIE
DISTDTQ Q $S(+$G(DA)>0:1,1:0)
;
;
CATUPD ;- Entry point for CPT Category update
;
N CATEG,CATI,PRTFLG
S PRTFLG=""
D BMES^XPDUTL(">>> Updating CPT Category file (#81.1)......")
;
;- Get category record from list
F CATI=1:1 S CATEG=$P($T(CATS+CATI),";;",2) Q:CATEG="QUIT" D
. ;
. ;- Display heading on screen once
. I (PRTFLG'=$P(CATEG,"^")) D @($S($P(CATEG,"^")="A":"AMSG",$P(CATEG,"^")="M":"MMSG",1:"IMSG"))
. ;
. ;- Determine if record will be added, modified, or inactivated
. D @($S($P(CATEG,"^")="A":"ADD",$P(CATEG,"^")="M":"MOD",1:"INACT"))
D BMES^XPDUTL("...... completed.")
CATUPDQ Q
;
;
MOD ;- Update CPT Category file (#81.1) with modified names/CPT ranges
;
N CATIEN,CATNODE,CATNNDE
S CATIEN=0,(CATNODE,CATNNDE)=""
;
;- Get pieces 1-63 of "B" xref to handle lookup of long names
S CATIEN=+$O(^DIC(81.1,"B",$E($P(CATEG,"^",2),1,63),0))
;
;- Display error message if no IEN
I 'CATIEN D ERRMSG("M"),SETFLG Q
S CATNODE=$G(^DIC(81.1,CATIEN,0)) Q:CATNODE=""
;
;- Edit record
S DIE="^DIC(81.1,",DA=CATIEN,DR=".01///"_$P(CATEG,"^",3)_";4///"_$P(CATEG,"^",6)_";5///"_$P(CATEG,"^",7)
D ^DIE K DA,DIE,DR
;
;- Get new node and display old and modified values of record to screen
S CATNNDE=$G(^DIC(81.1,CATIEN,0))
D BMES^XPDUTL("Old Name: "_$P(CATNODE,"^")_" Range: "_$P(CATNODE,"^",4)_"-"_$P(CATNODE,"^",5))
D MES^XPDUTL("New Name: "_$P(CATNNDE,"^")_" Range: "_$P(CATNNDE,"^",4)_"-"_$P(CATNNDE,"^",5))
D SETFLG
Q
;
;
ADD ;- Add new categories to CPT Category file (#81.1)
;
N CATNNDE,DA,Y
;
;- Get pieces 1-63 of "B" xref to handle lookup of long names
I +$O(^DIC(81.1,"B",$E($P(CATEG,"^",2),1,63),0)) D ERRMSG("A"),SETFLG Q
;
;- Create new category record
S DIC="^DIC(81.1,",DIC(0)="LZ",DLAYGO=81.1,X=$P(CATEG,"^",2)
K DD,DO D FILE^DICN K DLAYGO,X
;
;- Display error message and exit if record was not created
I +Y=-1 D ERRMSG("A"),SETFLG Q
;
;- Add new fields to record
S DIE=DIC,DA=+Y,DR="2///"_$P(CATEG,"^",3)_";3///"_$P(CATEG,"^",4)_";4///"_$P(CATEG,"^",5)_";5///"_$P(CATEG,"^",6)_";6///"_$P(CATEG,"^",7)
D ^DIE K DIC,DIE,DR
;
;- Display new record to screen
S CATNNDE=$G(^DIC(81.1,DA,0))
D MES^XPDUTL("New Name: "_$P(CATNNDE,"^")_" Range: "_$P(CATNNDE,"^",4)_"-"_$P(CATNNDE,"^",5))
D SETFLG
Q
;
;
INACT ;- Inactivate categories from CPT Category file (#81.1)
;
N CATIEN,CATNODE
S CATIEN=0,CATNODE=""
;
;- Get pieces 1-63 of "B" xref to handle lookup of long names
S CATIEN=+$O(^DIC(81.1,"B",$E($P(CATEG,"^",2),1,63),0))
;
;- Display error message and exit if record was not found
I 'CATIEN D ERRMSG("I"),SETFLG Q
S CATNODE=$G(^DIC(81.1,CATIEN,0))
S DIE="^DIC(81.1,",DA=CATIEN
;
;- Inactivate record
S DR="4///@;5///@;6///@;100///Inactive. Use PSYCHIATRY"_$S(+$O(^DIC(81.1,"B","PSYCHIATRY",0)):" (ien = "_+$O(^DIC(81.1,"B","PSYCHIATRY",0))_")",1:"")
D ^DIE K DA,DIE,DR
;
;- Display record to screen
D MES^XPDUTL("Inactivated Name: "_$P(CATNODE,"^"))
D SETFLG
Q
;
;
ERRMSG(ACT) ;- Error message for "A"dd, "M"odify, "I"nactivate
;
N MSG
S MSG=$S(ACT="A":" already exists and could not be added.",ACT="M":" does not exist and could not be modified.",1:" does not exist and could not be inactivated.")
D BMES^XPDUTL("Category "_$P(CATEG,"^",2)_MSG)
Q
;
;
AMSG ;- Added categories message
;
D BMES^XPDUTL("Added Categories:")
D MES^XPDUTL("=================")
D MES^XPDUTL("")
Q
;
;
MMSG ;- Modified categories message
;
D BMES^XPDUTL("Modified Categories:")
D MES^XPDUTL("====================")
Q
;
;
IMSG ;- Inactive categories message
;
D BMES^XPDUTL("Inactive Categories:")
D MES^XPDUTL("====================")
D MES^XPDUTL("")
Q
;
;
SETFLG ;- Set print flag so headings will display once
;
S PRTFLG=$S($P(CATEG,"^")="A":"A",$P(CATEG,"^")="M":"M",1:"I")
Q
;
;
CATS ;- CPT Category records
;;M^MEDICINE^MEDICINE^m^^90000^99199^C
;;M^MISCELLANEOUS PROCEDURE(S)^OTHER PROCEDURE(S)^s^3^01990^01999^C
;;M^NON-INVASIVE PERIPHERAL VASCULAR DIAGNOSTIC STUDIES^NON-INVASIVE VASCULAR DIAGNOSTIC STUDIES^s^1^93875^93990^C
;;M^PHYSICAL MEDICINE^PHYSICAL MEDICINE^s^1^97001^97799^C
;;M^SPECIAL SERVICES AND REPORTS^SPECIAL SERVICES AND REPORTS^s^1^99000^99090^C
;;M^ORGAN OR DISEASE ORIENTED PANELS^ORGAN OR DISEASE ORIENTED PANELS^s^5^80049^80092^C
;;M^SURGICAL PATHOLOGY^SURGICAL PATHOLOGY^s^5^88300^88399^C
;;M^CARE PLAN OVERSIGHT SERVICES^CARE PLAN OVERSIGHT SERVICES^s^116^99374^99380^C
;;M^NURSING FACILITY SERVICES^NURSING FACILITY SERVICES^s^116^99301^99316^C
;;A^OTHER LABORATORY/PATHOLOGY^s^5^89050^89399^C
;;A^PSYCHIATRY^s^1^90801^90899^C
;;A^QUALIFYING CIRCUMSTANCES FOR ANESTHESIA^s^1^99100^99140^C
;;A^SEDATION WITH OR W/O ANALGESIA (CONSCIOUS SEDATION)^s^1^99141^99142^C
;;A^OTHER SERVICES^s^1^99175^99199^C
;;I^GENERAL CLINICAL PSYCHIATRIC DIAGNOSTIC OR EVALUATIVE INTERVIEW PROCEDURES^s^1^90801^90801^C
;;I^SPECIAL CLINICAL PSYCHIATRIC DIAGNOSTIC OR EVALUATIVE PROCEDURES^s^1^90820^90830^C
;;I^PSYCHIATRIC THERAPEUTIC PROCEDURES^s^1^90835^90899^C
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICPT63PT 6411 printed Dec 13, 2024@01:45:33 Page 2
ICPT63PT ;ALB/ESD - CPT Update '98 Post-Init Driver; 1/29/98
+1 ;;6.0;CPT/HCPCS;**3**;May 19, 1997
+2 ;
EN ;- Main entry point
+1 ;
+2 ;- Modify CPT Copyright file (#81.2)
+3 DO DISTUP
+4 ;
+5 ;- Add, revise, inactivate categories in the CPT Category file (#81.1)
+6 DO CATUPD
+7 ;
+8 ;- Add, revise, inactivate modifiers in the CPT Modifier file (#81.3)
+9 DO EN^ICPT63P2
+10 ;
+11 ;- Reminder message to users to reload the ^ICPT global
+12 DO MES^XPDUTL("")
+13 DO BMES^XPDUTL("****** YOU MUST LOAD THE CPT GLOBAL (^ICPT) FROM THE FILE ICPT6_3.GBL")
+14 DO MES^XPDUTL("UPON COMPLETION OF THIS INSTALLATION! ******")
+15 DO MES^XPDUTL("")
ENQ QUIT
+1 ;
+2 ;
DISTUP ;- Entry point for Distribution Date update
+1 ;
+2 DO MES^XPDUTL("")
+3 DO BMES^XPDUTL(">>> Updating Distribution Date in the CPT Copyright file (#81.2)......")
+4 IF '$$DISTDT
Begin DoDot:1
+5 DO BMES^XPDUTL(">>> Error updating Distribution Date field in CPT Copyright file (#81.2).")
End DoDot:1
GOTO DISTUPQ
+6 DO MES^XPDUTL("......completed.")
DISTUPQ QUIT
+1 ;
+2 ;
DISTDT() ;- Add distribution date to file #81.2
+1 NEW DIC,DIE,DR,X,Y
+2 SET DIC="^DIC(81.2,"
+3 SET DIC(0)="OX"
+4 ;
+5 ;- Get entry (currently only one entry exists in this file)
+6 SET X="CPT MESSAGE"
+7 DO ^DIC
+8 IF +Y=-1
GOTO DISTDTQ
+9 ;
+10 ;- Add date
+11 SET DA=+Y
+12 SET DIE=DIC
+13 SET DR=".02///2980201"
+14 DO ^DIE
DISTDTQ QUIT $SELECT(+$GET(DA)>0:1,1:0)
+1 ;
+2 ;
CATUPD ;- Entry point for CPT Category update
+1 ;
+2 NEW CATEG,CATI,PRTFLG
+3 SET PRTFLG=""
+4 DO BMES^XPDUTL(">>> Updating CPT Category file (#81.1)......")
+5 ;
+6 ;- Get category record from list
+7 FOR CATI=1:1
SET CATEG=$PIECE($TEXT(CATS+CATI),";;",2)
if CATEG="QUIT"
QUIT
Begin DoDot:1
+8 ;
+9 ;- Display heading on screen once
+10 IF (PRTFLG'=$PIECE(CATEG,"^"))
DO @($SELECT($PIECE(CATEG,"^")="A":"AMSG",$PIECE(CATEG,"^")="M":"MMSG",1:"IMSG"))
+11 ;
+12 ;- Determine if record will be added, modified, or inactivated
+13 DO @($SELECT($PIECE(CATEG,"^")="A":"ADD",$PIECE(CATEG,"^")="M":"MOD",1:"INACT"))
End DoDot:1
+14 DO BMES^XPDUTL("...... completed.")
CATUPDQ QUIT
+1 ;
+2 ;
MOD ;- Update CPT Category file (#81.1) with modified names/CPT ranges
+1 ;
+2 NEW CATIEN,CATNODE,CATNNDE
+3 SET CATIEN=0
SET (CATNODE,CATNNDE)=""
+4 ;
+5 ;- Get pieces 1-63 of "B" xref to handle lookup of long names
+6 SET CATIEN=+$ORDER(^DIC(81.1,"B",$EXTRACT($PIECE(CATEG,"^",2),1,63),0))
+7 ;
+8 ;- Display error message if no IEN
+9 IF 'CATIEN
DO ERRMSG("M")
DO SETFLG
QUIT
+10 SET CATNODE=$GET(^DIC(81.1,CATIEN,0))
if CATNODE=""
QUIT
+11 ;
+12 ;- Edit record
+13 SET DIE="^DIC(81.1,"
SET DA=CATIEN
SET DR=".01///"_$PIECE(CATEG,"^",3)_";4///"_$PIECE(CATEG,"^",6)_";5///"_$PIECE(CATEG,"^",7)
+14 DO ^DIE
KILL DA,DIE,DR
+15 ;
+16 ;- Get new node and display old and modified values of record to screen
+17 SET CATNNDE=$GET(^DIC(81.1,CATIEN,0))
+18 DO BMES^XPDUTL("Old Name: "_$PIECE(CATNODE,"^")_" Range: "_$PIECE(CATNODE,"^",4)_"-"_$PIECE(CATNODE,"^",5))
+19 DO MES^XPDUTL("New Name: "_$PIECE(CATNNDE,"^")_" Range: "_$PIECE(CATNNDE,"^",4)_"-"_$PIECE(CATNNDE,"^",5))
+20 DO SETFLG
+21 QUIT
+22 ;
+23 ;
ADD ;- Add new categories to CPT Category file (#81.1)
+1 ;
+2 NEW CATNNDE,DA,Y
+3 ;
+4 ;- Get pieces 1-63 of "B" xref to handle lookup of long names
+5 IF +$ORDER(^DIC(81.1,"B",$EXTRACT($PIECE(CATEG,"^",2),1,63),0))
DO ERRMSG("A")
DO SETFLG
QUIT
+6 ;
+7 ;- Create new category record
+8 SET DIC="^DIC(81.1,"
SET DIC(0)="LZ"
SET DLAYGO=81.1
SET X=$PIECE(CATEG,"^",2)
+9 KILL DD,DO
DO FILE^DICN
KILL DLAYGO,X
+10 ;
+11 ;- Display error message and exit if record was not created
+12 IF +Y=-1
DO ERRMSG("A")
DO SETFLG
QUIT
+13 ;
+14 ;- Add new fields to record
+15 SET DIE=DIC
SET DA=+Y
SET DR="2///"_$PIECE(CATEG,"^",3)_";3///"_$PIECE(CATEG,"^",4)_";4///"_$PIECE(CATEG,"^",5)_";5///"_$PIECE(CATEG,"^",6)_";6///"_$PIECE(CATEG,"^",7)
+16 DO ^DIE
KILL DIC,DIE,DR
+17 ;
+18 ;- Display new record to screen
+19 SET CATNNDE=$GET(^DIC(81.1,DA,0))
+20 DO MES^XPDUTL("New Name: "_$PIECE(CATNNDE,"^")_" Range: "_$PIECE(CATNNDE,"^",4)_"-"_$PIECE(CATNNDE,"^",5))
+21 DO SETFLG
+22 QUIT
+23 ;
+24 ;
INACT ;- Inactivate categories from CPT Category file (#81.1)
+1 ;
+2 NEW CATIEN,CATNODE
+3 SET CATIEN=0
SET CATNODE=""
+4 ;
+5 ;- Get pieces 1-63 of "B" xref to handle lookup of long names
+6 SET CATIEN=+$ORDER(^DIC(81.1,"B",$EXTRACT($PIECE(CATEG,"^",2),1,63),0))
+7 ;
+8 ;- Display error message and exit if record was not found
+9 IF 'CATIEN
DO ERRMSG("I")
DO SETFLG
QUIT
+10 SET CATNODE=$GET(^DIC(81.1,CATIEN,0))
+11 SET DIE="^DIC(81.1,"
SET DA=CATIEN
+12 ;
+13 ;- Inactivate record
+14 SET DR="4///@;5///@;6///@;100///Inactive. Use PSYCHIATRY"_$SELECT(+$ORDER(^DIC(81.1,"B","PSYCHIATRY",0)):" (ien = "_+$ORDER(^DIC(81.1,"B","PSYCHIATRY",0))_")",1:"")
+15 DO ^DIE
KILL DA,DIE,DR
+16 ;
+17 ;- Display record to screen
+18 DO MES^XPDUTL("Inactivated Name: "_$PIECE(CATNODE,"^"))
+19 DO SETFLG
+20 QUIT
+21 ;
+22 ;
ERRMSG(ACT) ;- Error message for "A"dd, "M"odify, "I"nactivate
+1 ;
+2 NEW MSG
+3 SET MSG=$SELECT(ACT="A":" already exists and could not be added.",ACT="M":" does not exist and could not be modified.",1:" does not exist and could not be inactivated.")
+4 DO BMES^XPDUTL("Category "_$PIECE(CATEG,"^",2)_MSG)
+5 QUIT
+6 ;
+7 ;
AMSG ;- Added categories message
+1 ;
+2 DO BMES^XPDUTL("Added Categories:")
+3 DO MES^XPDUTL("=================")
+4 DO MES^XPDUTL("")
+5 QUIT
+6 ;
+7 ;
MMSG ;- Modified categories message
+1 ;
+2 DO BMES^XPDUTL("Modified Categories:")
+3 DO MES^XPDUTL("====================")
+4 QUIT
+5 ;
+6 ;
IMSG ;- Inactive categories message
+1 ;
+2 DO BMES^XPDUTL("Inactive Categories:")
+3 DO MES^XPDUTL("====================")
+4 DO MES^XPDUTL("")
+5 QUIT
+6 ;
+7 ;
SETFLG ;- Set print flag so headings will display once
+1 ;
+2 SET PRTFLG=$SELECT($PIECE(CATEG,"^")="A":"A",$PIECE(CATEG,"^")="M":"M",1:"I")
+3 QUIT
+4 ;
+5 ;
CATS ;- CPT Category records
+1 ;;M^MEDICINE^MEDICINE^m^^90000^99199^C
+2 ;;M^MISCELLANEOUS PROCEDURE(S)^OTHER PROCEDURE(S)^s^3^01990^01999^C
+3 ;;M^NON-INVASIVE PERIPHERAL VASCULAR DIAGNOSTIC STUDIES^NON-INVASIVE VASCULAR DIAGNOSTIC STUDIES^s^1^93875^93990^C
+4 ;;M^PHYSICAL MEDICINE^PHYSICAL MEDICINE^s^1^97001^97799^C
+5 ;;M^SPECIAL SERVICES AND REPORTS^SPECIAL SERVICES AND REPORTS^s^1^99000^99090^C
+6 ;;M^ORGAN OR DISEASE ORIENTED PANELS^ORGAN OR DISEASE ORIENTED PANELS^s^5^80049^80092^C
+7 ;;M^SURGICAL PATHOLOGY^SURGICAL PATHOLOGY^s^5^88300^88399^C
+8 ;;M^CARE PLAN OVERSIGHT SERVICES^CARE PLAN OVERSIGHT SERVICES^s^116^99374^99380^C
+9 ;;M^NURSING FACILITY SERVICES^NURSING FACILITY SERVICES^s^116^99301^99316^C
+10 ;;A^OTHER LABORATORY/PATHOLOGY^s^5^89050^89399^C
+11 ;;A^PSYCHIATRY^s^1^90801^90899^C
+12 ;;A^QUALIFYING CIRCUMSTANCES FOR ANESTHESIA^s^1^99100^99140^C
+13 ;;A^SEDATION WITH OR W/O ANALGESIA (CONSCIOUS SEDATION)^s^1^99141^99142^C
+14 ;;A^OTHER SERVICES^s^1^99175^99199^C
+15 ;;I^GENERAL CLINICAL PSYCHIATRIC DIAGNOSTIC OR EVALUATIVE INTERVIEW PROCEDURES^s^1^90801^90801^C
+16 ;;I^SPECIAL CLINICAL PSYCHIATRIC DIAGNOSTIC OR EVALUATIVE PROCEDURES^s^1^90820^90830^C
+17 ;;I^PSYCHIATRIC THERAPEUTIC PROCEDURES^s^1^90835^90899^C
+18 ;;QUIT
