- 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