ACPT29AD ;IHS/SD/SDR - ACPT*2.09 activate/deactivate codes ; 12/21/2008 00:29
;;2.09;CPT FILES;;JAN 2, 2009
;
EN ;activate 2009 CPT codes, deactivate deleted ones
; input: ACPTYR = 3090000, to use as the flag value for the Date Deleted
; field.
; loop: traverse the entries for CPT codes in the CPT file (81)).
; For each, activate if new, inactivate if deleted.
;
N ACPTDA S ACPTDA=0 ; CPT file entry #
N ACPTDOTS ; count, so that a dot is printed every 100 codes
F ACPTDOTS=1:1 S ACPTDA=$O(^ICPT(ACPTDA)) Q:'ACPTDA!(ACPTDA>99999) D
.D ACTIV8(ACPTDA,ACPTYR) ; activate 2009 CPTs
.D DEACTIV8(ACPTDA,ACPTYR) ; deact codes not in 2009 CPT delete file
.Q:$D(ZTQUEUED) ; if this has been queued, skip the dots
.W:'(ACPTDOTS#100) "." ; otherwise, write a dot for every 100 codes
;
Q
;
;
ACTIV8(ACPTDA,ACPTYR) ; activate 2009 CPT codes
; called only by the main procedure above; only ACPTDA passed in (by
; value), though the major input is the corresponding CPT record;
; likewise the output is to the record: the Inactive Flag field (5) of
; the CPT record, the creation if missing of a new Effective Date
; subfile (60/81.02) record, and the Status field (.02) of that
; subrecord. The Status Field is a set of codes: 0 = INACTIVE,
; 1 = ACTIVE.
;
N ACPTNODE S ACPTNODE=$G(^ICPT(ACPTDA,0)) ; get CPT's header node
Q:ACPTNODE="" ; skip bad records with no header
;
N ACPTADD S ACPTADD=$P(ACPTNODE,U,6) ; CPT's Date Added (7)
Q:ACPTADD'=ACPTYR ; if new, Date Added = 3090000
;
N ACPTINAC S ACPTINAC=$P(ACPTNODE,U,4) ; CPT's Inactive Flag (5)
Q:'ACPTINAC ; new codes also have this flag set to INACTIVE (1)
;
S $P(ACPTNODE,U,4)="" ; clear the Inactive Flag
S $P(ACPTNODE,U,6)=3090101 ; set Date Added to a real date
;
S ^ICPT(ACPTDA,0)=ACPTNODE ; copy results back to CPT's header node
;
Q
;
;
DEACTIV8(ACPTDA,ACPTYR) ; deactivate codes not in 2009 CPT
; called only by the main procedure above; only ACPTDA passed in (by
; value), though the major input is the corresponding CPT record;
; likewise the output is to the record: the Inactive Flag (5) and Date
; Deleted (8) fields of the CPT record, the creation if missing of a new
; Effective Date subfile (60/81.02) record, and the Status field (.02)
; of that subrecord. The Status Field is a set of codes: 0 = INACTIVE,
; 1 = ACTIVE.
;
N ACPTDEL S ACPTDEL=$P($G(^ICPT(ACPTDA,0)),U,7) ; CPT's Date Deleted (8)
Q:ACPTDEL'=ACPTYR ; skip codes not deleted by this post-init
;
; otherwise, let's inactivate it:
S $P(^ICPT(ACPTDA,0),U,4)=1 ; first, set the Inactive Flag
S $P(^ICPT(ACPTDA,0),U,7)=3090101 ; 2nd, set Date Deleted to a real date
;
; third, let's find or add the current Effective Date (1/1/2008)
N DA S DA(1)=ACPTDA ; parent record, i.e., the CPT code
N DIC S DIC="^ICPT("_DA(1)_",60," ; Effective Date subfile (60/81.02)
S DIC(0)="L" ; allow LAYGO (Learn As You Go, i.e., add if not found)
S DIC("P")=$P(^DD(81,60,0),"^",2) ; subfile # & specifier codes
N X S X="01/01/2009" ; value to lookup in the subfile
N DLAYGO,Y,DTOUT,DUOUT ; other parameters for DIC
D ^DIC ; Fileman Lookup call
S DA=+Y ; save IEN of found/added record for next call below
;
; third, let's inactivate it
N DIE S DIE="^ICPT("_DA(1)_",60," ; Effective Date subfile (60/81.02)
N DR S DR=".02////0" ; set Status field to INACTIVE
N DIDEL,DTOUT ; other parameters for DIE
D ^DIE ; Fileman Data Edit call
;
Q
ACPT29AD ;IHS/SD/SDR - ACPT*2.09 activate/deactivate codes ; 12/21/2008 00:29
+1 ;;2.09;CPT FILES;;JAN 2, 2009
+2 ;
EN ;activate 2009 CPT codes, deactivate deleted ones
+1 ; input: ACPTYR = 3090000, to use as the flag value for the Date Deleted
+2 ; field.
+3 ; loop: traverse the entries for CPT codes in the CPT file (81)).
+4 ; For each, activate if new, inactivate if deleted.
+5 ;
+6 ; CPT file entry #
NEW ACPTDA
SET ACPTDA=0
+7 ; count, so that a dot is printed every 100 codes
NEW ACPTDOTS
+8 FOR ACPTDOTS=1:1
SET ACPTDA=$ORDER(^ICPT(ACPTDA))
IF 'ACPTDA!(ACPTDA>99999)
QUIT
Begin DoDot:1
+9 ; activate 2009 CPTs
DO ACTIV8(ACPTDA,ACPTYR)
+10 ; deact codes not in 2009 CPT delete file
DO DEACTIV8(ACPTDA,ACPTYR)
+11 ; if this has been queued, skip the dots
IF $DATA(ZTQUEUED)
QUIT
+12 ; otherwise, write a dot for every 100 codes
IF '(ACPTDOTS#100)
WRITE "."
End DoDot:1
+13 ;
+14 QUIT
+15 ;
+16 ;
ACTIV8(ACPTDA,ACPTYR) ; activate 2009 CPT codes
+1 ; called only by the main procedure above; only ACPTDA passed in (by
+2 ; value), though the major input is the corresponding CPT record;
+3 ; likewise the output is to the record: the Inactive Flag field (5) of
+4 ; the CPT record, the creation if missing of a new Effective Date
+5 ; subfile (60/81.02) record, and the Status field (.02) of that
+6 ; subrecord. The Status Field is a set of codes: 0 = INACTIVE,
+7 ; 1 = ACTIVE.
+8 ;
+9 ; get CPT's header node
NEW ACPTNODE
SET ACPTNODE=$GET(^ICPT(ACPTDA,0))
+10 ; skip bad records with no header
IF ACPTNODE=""
QUIT
+11 ;
+12 ; CPT's Date Added (7)
NEW ACPTADD
SET ACPTADD=$PIECE(ACPTNODE,U,6)
+13 ; if new, Date Added = 3090000
IF ACPTADD'=ACPTYR
QUIT
+14 ;
+15 ; CPT's Inactive Flag (5)
NEW ACPTINAC
SET ACPTINAC=$PIECE(ACPTNODE,U,4)
+16 ; new codes also have this flag set to INACTIVE (1)
IF 'ACPTINAC
QUIT
+17 ;
+18 ; clear the Inactive Flag
SET $PIECE(ACPTNODE,U,4)=""
+19 ; set Date Added to a real date
SET $PIECE(ACPTNODE,U,6)=3090101
+20 ;
+21 ; copy results back to CPT's header node
SET ^ICPT(ACPTDA,0)=ACPTNODE
+22 ;
+23 QUIT
+24 ;
+25 ;
DEACTIV8(ACPTDA,ACPTYR) ; deactivate codes not in 2009 CPT
+1 ; called only by the main procedure above; only ACPTDA passed in (by
+2 ; value), though the major input is the corresponding CPT record;
+3 ; likewise the output is to the record: the Inactive Flag (5) and Date
+4 ; Deleted (8) fields of the CPT record, the creation if missing of a new
+5 ; Effective Date subfile (60/81.02) record, and the Status field (.02)
+6 ; of that subrecord. The Status Field is a set of codes: 0 = INACTIVE,
+7 ; 1 = ACTIVE.
+8 ;
+9 ; CPT's Date Deleted (8)
NEW ACPTDEL
SET ACPTDEL=$PIECE($GET(^ICPT(ACPTDA,0)),U,7)
+10 ; skip codes not deleted by this post-init
IF ACPTDEL'=ACPTYR
QUIT
+11 ;
+12 ; otherwise, let's inactivate it:
+13 ; first, set the Inactive Flag
SET $PIECE(^ICPT(ACPTDA,0),U,4)=1
+14 ; 2nd, set Date Deleted to a real date
SET $PIECE(^ICPT(ACPTDA,0),U,7)=3090101
+15 ;
+16 ; third, let's find or add the current Effective Date (1/1/2008)
+17 ; parent record, i.e., the CPT code
NEW DA
SET DA(1)=ACPTDA
+18 ; Effective Date subfile (60/81.02)
NEW DIC
SET DIC="^ICPT("_DA(1)_",60,"
+19 ; allow LAYGO (Learn As You Go, i.e., add if not found)
SET DIC(0)="L"
+20 ; subfile # & specifier codes
SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)
+21 ; value to lookup in the subfile
NEW X
SET X="01/01/2009"
+22 ; other parameters for DIC
NEW DLAYGO,Y,DTOUT,DUOUT
+23 ; Fileman Lookup call
DO ^DIC
+24 ; save IEN of found/added record for next call below
SET DA=+Y
+25 ;
+26 ; third, let's inactivate it
+27 ; Effective Date subfile (60/81.02)
NEW DIE
SET DIE="^ICPT("_DA(1)_",60,"
+28 ; set Status field to INACTIVE
NEW DR
SET DR=".02////0"
+29 ; other parameters for DIE
NEW DIDEL,DTOUT
+30 ; Fileman Data Edit call
DO ^DIE
+31 ;
+32 QUIT
