Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACPT29AD

ACPT29AD.m

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