ACPT28PB ;IHS/VEN/TOAD - ACPT*2.08*1 postinit step 3 ; 04/20/2008 23:03
;;2.08;CPT FILES;**1**;DEC 17, 2007
;
; This subroutine of the post-init for ACPT*2.08*1 preps the existing
; HCPCS codes in the site's CPT file (81) for the loading of the new
; 2008 AMA codes. See routine ACPT28PA for the complete algorithm and
; overview.
;
QUIT ; This routine should not be called at the top or anywhere
; else. It is only to be called at PREPCODE by ACPT28PA as part of the
; post-init for ACPT*2.08*1.
;
; 2008 04 16-20 Rick Marshall created this routine to handle the HCPCS
; prep step of the post-init (step 3). Previously this step just set the
; Date Deleted field (8) to a special value (3080000) prior to loading
; the AMS's 2008 HCPCS codes. As each AMA code was loaded, the Date
; Deleted was cleared, so that after loading the "deleted" codes in need
; of inactivation could be easily identified. The loop to handle this
; was originally in routine ACPTPOST (now called ACPT28PA). During
; testing, numerous data integrity problems were found in the CPT file,
; so this subroutine was split off into its own new routine and expanded
; to include cleanup of the existing HCPCS data. Problems were mainly
; found in the Effective Date subfile, which contained duplicate entries
; and sometimes an erroneous -1 node. The subfile also contained traces
; of entries that were deleted though they should not have been; the B
; index is used to recreate these lost entries, and the subfile as a
; whole is renumbered and reindexed.
;
; The original loop from ACPTPOST was the work of IHS/ASDST/DMJ and
; Shonda Render (SDR).
;
;
PREPCODE ; step 3 of post-init: prep site's existing HCPCS codes
;
; private: called only by step 3 of routine ACPT28PA
;
; input: ACPTYR = 3080000, to use as the flag value for the Date Deleted
; field.
;
; 3.1. traverse site's existing HCPCS codes in the CPT file
;
N ACPTCNT
N ACPTIEN S ACPTIEN=99999 ; IENs of HCPCS entries, start just before
N ACPTTO S ACPTTO=999999 ; last IEN in HCPCS range
F ACPTCNT=1:1 S ACPTIEN=$O(^ICPT(ACPTIEN)) Q:ACPTIEN>ACPTTO!'ACPTIEN D
. ;
. ; 3.2. set Date Deleted field to flag value
. ;
. I '$P($G(^ICPT(ACPTIEN,0)),U,7) D ; if it hasn't already been deleted
. . S $P(^ICPT(ACPTIEN,0),U,7)=ACPTYR ; set its Date Deleted field (8)
. ;
. ; 3.3. clean up Effective Date subfile
. ;
. D CLEANUP(ACPTIEN)
. I '(ACPTCNT#100) U IO(0) W "." ; print a dot every 100 records
;
;
QUIT ; end of PREPCODE
;
;
CLEANUP(ACPTIEN) ; clean up Effective Date subfile for a CPT entry
;
; private, called only by PREPCODE above
;
; this subroutine has been separated from PREPCODE to make
; testing easier.
;
; a. build local subfile, dinummed by date, out of subentries
;
N ACPTDATE ; local subfile
N ACPTEDI S ACPTEDI=0 ; Effective Date IEN
F S ACPTEDI=$O(^ICPT(ACPTIEN,60,ACPTEDI)) Q:'ACPTEDI D
. N ACPTNODE S ACPTNODE=$G(^ICPT(ACPTIEN,60,ACPTEDI,0)) Q:ACPTNODE=""
. N ACPTED S ACPTED=$P(ACPTNODE,U) Q:'ACPTED ; skip nonnumerics
. D ; handle insertions into the list
. . I '$D(ACPTDATE(ACPTED)) D Q ; if new to the local list, add it
. . . S ACPTDATE(ACPTED)=ACPTNODE ; later entries overwrite earlier
. . N ACPTSTAT S ACPTSTAT=$P(ACPTNODE,U,2) ; Status field (.02)
. . I ACPTSTAT'="" D Q ; if it has a status
. . . S $P(ACPTDATE(ACPTED),U,2)=ACPTSTAT ; it overrides the older entry
. K ^ICPT(ACPTIEN,60,"B",ACPTED) ; remove found dates
;
; b. extend local subfile with lost entries in B index
;
N ACPTS1 S ACPTS1="" ; 1st subscript of B index entries
F S ACPTS1=$O(^ICPT(ACPTIEN,60,"B",ACPTS1)) Q:ACPTS1="" D
. Q:'ACPTS1 ; skip nonnumeric entries
. Q:$D(ACPTDATE(ACPTS1)) ; skip if already found (just in case)
. S ACPTDATE(ACPTS1)=ACPTS1 ; create stub entries for lost entries
;
; c. replace global subfile with local subfile
;
K ^ICPT(ACPTIEN,60) ; first clear out old subfile (incl -1 nodes)
;
; then copy local subfile to global subfile
N ACPTEMP S ACPTEMP=0 ; temporary IENs in local subfile
N ACPTNEW ; new IEN for each subentry
F ACPTNEW=1:1 S ACPTEMP=$O(ACPTDATE(ACPTEMP)) Q:'ACPTEMP D
. S ^ICPT(ACPTIEN,60,ACPTNEW,0)=ACPTDATE(ACPTEMP) ; move entry
. S ^ICPT(ACPTIEN,60,"B",ACPTEMP,ACPTNEW)="" ; create B index entry
S ACPTNEW=ACPTNEW-1 ; reduce to actual number of subentries
;
; last, reset the subheader
S ^ICPT(ACPTIEN,60,0)="^81.02DA^"_ACPTNEW_U_ACPTNEW
;
QUIT ; end of CLEANUP
;
;
; end of routine ACPT28PB
ACPT28PB ;IHS/VEN/TOAD - ACPT*2.08*1 postinit step 3 ; 04/20/2008 23:03
+1 ;;2.08;CPT FILES;**1**;DEC 17, 2007
+2 ;
+3 ; This subroutine of the post-init for ACPT*2.08*1 preps the existing
+4 ; HCPCS codes in the site's CPT file (81) for the loading of the new
+5 ; 2008 AMA codes. See routine ACPT28PA for the complete algorithm and
+6 ; overview.
+7 ;
+8 ; This routine should not be called at the top or anywhere
QUIT
+9 ; else. It is only to be called at PREPCODE by ACPT28PA as part of the
+10 ; post-init for ACPT*2.08*1.
+11 ;
+12 ; 2008 04 16-20 Rick Marshall created this routine to handle the HCPCS
+13 ; prep step of the post-init (step 3). Previously this step just set the
+14 ; Date Deleted field (8) to a special value (3080000) prior to loading
+15 ; the AMS's 2008 HCPCS codes. As each AMA code was loaded, the Date
+16 ; Deleted was cleared, so that after loading the "deleted" codes in need
+17 ; of inactivation could be easily identified. The loop to handle this
+18 ; was originally in routine ACPTPOST (now called ACPT28PA). During
+19 ; testing, numerous data integrity problems were found in the CPT file,
+20 ; so this subroutine was split off into its own new routine and expanded
+21 ; to include cleanup of the existing HCPCS data. Problems were mainly
+22 ; found in the Effective Date subfile, which contained duplicate entries
+23 ; and sometimes an erroneous -1 node. The subfile also contained traces
+24 ; of entries that were deleted though they should not have been; the B
+25 ; index is used to recreate these lost entries, and the subfile as a
+26 ; whole is renumbered and reindexed.
+27 ;
+28 ; The original loop from ACPTPOST was the work of IHS/ASDST/DMJ and
+29 ; Shonda Render (SDR).
+30 ;
+31 ;
PREPCODE ; step 3 of post-init: prep site's existing HCPCS codes
+1 ;
+2 ; private: called only by step 3 of routine ACPT28PA
+3 ;
+4 ; input: ACPTYR = 3080000, to use as the flag value for the Date Deleted
+5 ; field.
+6 ;
+7 ; 3.1. traverse site's existing HCPCS codes in the CPT file
+8 ;
+9 NEW ACPTCNT
+10 ; IENs of HCPCS entries, start just before
NEW ACPTIEN
SET ACPTIEN=99999
+11 ; last IEN in HCPCS range
NEW ACPTTO
SET ACPTTO=999999
+12 FOR ACPTCNT=1:1
SET ACPTIEN=$ORDER(^ICPT(ACPTIEN))
IF ACPTIEN>ACPTTO!'ACPTIEN
QUIT
Begin DoDot:1
+13 ;
+14 ; 3.2. set Date Deleted field to flag value
+15 ;
+16 ; if it hasn't already been deleted
IF '$PIECE($GET(^ICPT(ACPTIEN,0)),U,7)
Begin DoDot:2
+17 ; set its Date Deleted field (8)
SET $PIECE(^ICPT(ACPTIEN,0),U,7)=ACPTYR
End DoDot:2
+18 ;
+19 ; 3.3. clean up Effective Date subfile
+20 ;
+21 DO CLEANUP(ACPTIEN)
+22 ; print a dot every 100 records
IF '(ACPTCNT#100)
USE IO(0)
WRITE "."
End DoDot:1
+23 ;
+24 ;
+25 ; end of PREPCODE
QUIT
+26 ;
+27 ;
CLEANUP(ACPTIEN) ; clean up Effective Date subfile for a CPT entry
+1 ;
+2 ; private, called only by PREPCODE above
+3 ;
+4 ; this subroutine has been separated from PREPCODE to make
+5 ; testing easier.
+6 ;
+7 ; a. build local subfile, dinummed by date, out of subentries
+8 ;
+9 ; local subfile
NEW ACPTDATE
+10 ; Effective Date IEN
NEW ACPTEDI
SET ACPTEDI=0
+11 FOR
SET ACPTEDI=$ORDER(^ICPT(ACPTIEN,60,ACPTEDI))
IF 'ACPTEDI
QUIT
Begin DoDot:1
+12 NEW ACPTNODE
SET ACPTNODE=$GET(^ICPT(ACPTIEN,60,ACPTEDI,0))
IF ACPTNODE=""
QUIT
+13 ; skip nonnumerics
NEW ACPTED
SET ACPTED=$PIECE(ACPTNODE,U)
IF 'ACPTED
QUIT
+14 ; handle insertions into the list
Begin DoDot:2
+15 ; if new to the local list, add it
IF '$DATA(ACPTDATE(ACPTED))
Begin DoDot:3
+16 ; later entries overwrite earlier
SET ACPTDATE(ACPTED)=ACPTNODE
End DoDot:3
QUIT
+17 ; Status field (.02)
NEW ACPTSTAT
SET ACPTSTAT=$PIECE(ACPTNODE,U,2)
+18 ; if it has a status
IF ACPTSTAT'=""
Begin DoDot:3
+19 ; it overrides the older entry
SET $PIECE(ACPTDATE(ACPTED),U,2)=ACPTSTAT
End DoDot:3
QUIT
End DoDot:2
+20 ; remove found dates
KILL ^ICPT(ACPTIEN,60,"B",ACPTED)
End DoDot:1
+21 ;
+22 ; b. extend local subfile with lost entries in B index
+23 ;
+24 ; 1st subscript of B index entries
NEW ACPTS1
SET ACPTS1=""
+25 FOR
SET ACPTS1=$ORDER(^ICPT(ACPTIEN,60,"B",ACPTS1))
IF ACPTS1=""
QUIT
Begin DoDot:1
+26 ; skip nonnumeric entries
IF 'ACPTS1
QUIT
+27 ; skip if already found (just in case)
IF $DATA(ACPTDATE(ACPTS1))
QUIT
+28 ; create stub entries for lost entries
SET ACPTDATE(ACPTS1)=ACPTS1
End DoDot:1
+29 ;
+30 ; c. replace global subfile with local subfile
+31 ;
+32 ; first clear out old subfile (incl -1 nodes)
KILL ^ICPT(ACPTIEN,60)
+33 ;
+34 ; then copy local subfile to global subfile
+35 ; temporary IENs in local subfile
NEW ACPTEMP
SET ACPTEMP=0
+36 ; new IEN for each subentry
NEW ACPTNEW
+37 FOR ACPTNEW=1:1
SET ACPTEMP=$ORDER(ACPTDATE(ACPTEMP))
IF 'ACPTEMP
QUIT
Begin DoDot:1
+38 ; move entry
SET ^ICPT(ACPTIEN,60,ACPTNEW,0)=ACPTDATE(ACPTEMP)
+39 ; create B index entry
SET ^ICPT(ACPTIEN,60,"B",ACPTEMP,ACPTNEW)=""
End DoDot:1
+40 ; reduce to actual number of subentries
SET ACPTNEW=ACPTNEW-1
+41 ;
+42 ; last, reset the subheader
+43 SET ^ICPT(ACPTIEN,60,0)="^81.02DA^"_ACPTNEW_U_ACPTNEW
+44 ;
+45 ; end of CLEANUP
QUIT
+46 ;
+47 ;
+48 ; end of routine ACPT28PB
