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

ACPT28PC.m

Go to the documentation of this file. 
  1. ACPT28PC ;IHS/VEN/TOAD - ACPT*2.08*1 postinit step 4.1 ; 04/21/2008 11:32
  1.  ;;2.08;CPT FILES;**1**;DEC 17, 2007
  1.  ;
  1.  ; This subroutine of the post-init for ACPT*2.08*1 loads the HCPCS 2008
  1.  ; codes from the American Medical Association's text file acpt2008.01h
  1.  ; and installs them in the RPMS CPT file (81). It does not do all of the
  1.  ; actions needed to install those codes, only the initial cleanup of the
  1.  ; file and raw loading of the codes. See routine ACPT28PA for the
  1.  ; complete algorithm and overview.
  1.  ;
  1.  QUIT  ; This routine should not be called at the top or anywhere
  1.  ; else. It is only to be called at LOADCODE by ACPT28PA as part of the
  1.  ; post-init for ACPT*2.08*1.
  1.  ;
  1.  ; 2008 04 16 Rick Marshall created this routine because ACPTPOST (now
  1.  ; ACPT28PA) expanded beyond the 10,000 character routine portability
  1.  ; limit when it was refactored for ACPT*2.08*1. All of the code in this
  1.  ; routine was previously in ACPT28PA. In addition to the refactoring,
  1.  ; this patch fixes two bugs: 1) undeleted codes are properly
  1.  ; reactivated, and (2) when the AMA shortened its long description, old
  1.  ; nodes left over from the previous, longer description were left; this
  1.  ; routine now kills the description before setting the new nodes.
  1.  ;
  1.  ; 2008 04 17-20 Rick Marshall did invasive surgery on the algorithm,
  1.  ; which was full of so many holes I cannot even summarize them
  1.  ; effectively here. In short, the code had been patched so many times
  1.  ; the logic was frayed and failed to handle any but the most typical
  1.  ; cases. Just about every unexpected case resulted in incorrect
  1.  ; behavior. A corresponding change was made to ACTIV8^ACPT28PE (used to
  1.  ; be ACT^ACPTSINF). Fixed bug in nonportable handling of Description
  1.  ; field.
  1.  ;
  1.  ; The original code in ACPTPOST upon which this was based was written by
  1.  ; IHS/ASDST/DMJ and Shonda Render (SDR).
  1.  ;
  1.  ;
  1. LOADCODE ; load HCPCS codes from AMA HCPCS Description file
  1.  ;
  1.  ; private: called only by step 4 of routine ACPT28PA
  1.  ;
  1.  ; input: ACPTPTH = path to directory where file is stored
  1.  ;
  1.  N POP D  Q:POP
  1.  . D OPEN^%ZISH("CPTHFILE",ACPTPTH,"acpt2008.01h","R") ; open read-only
  1.  . U IO(0) ; use terminal
  1.  . I POP D MES^XPDUTL($$T("MSG+1")) ; Could not open HCPCS file.
  1.  . E  D MES^XPDUTL($$T("MSG+2")) ; Reading HCPCS Codes file.
  1.  ;
  1.  N ACPTCNT ; count entries to print a dot for every 100
  1.  F ACPTCNT=1:1 D  Q:$$STATUS^%ZISH  ; loop until end of file
  1.  . ;
  1.  . N ACPTLINE ; each line extracted from the file
  1.  . U IO R ACPTLINE Q:$$STATUS^%ZISH
  1.  . ;
  1.  . N ACPTCODE ; HCPCS code
  1.  . S ACPTCODE=$E(ACPTLINE,1,5) ; first 5 chars contain the HCPCS code
  1.  . Q:ACPTCODE'?1U4N  ; skip any non-HCPCS codes found (should be none)
  1.  . ;
  1.  . N ACPTACT ; action code, if any
  1.  . S ACPTACT=$E(ACPTLINE,6)  ; action code
  1.  . ;
  1.  . N ACPTIEN ; IEN of entry in CPT file
  1.  . S ACPTIEN=$O(^ICPT("B",ACPTCODE,0)) ; find the code's record number
  1.  . I '$D(^ICPT("B",ACPTCODE)) D  ; if there isn't one, create it
  1.  . . S ACPTIEN=$A($E(ACPTCODE))_$E(ACPTCODE,2,5) ; CPT range three
  1.  . . S ^ICPT(ACPTIEN,0)=ACPTCODE ; CPT Code field (.01)
  1.  . . S ^ICPT("B",ACPTCODE,ACPTIEN)="" ; index of CPT Codes
  1.  . . S $P(^ICPT(ACPTIEN,0),U,6)=ACPTYR ; Date Added (7) to 3080000
  1.  . ;
  1.  . N ACPTNODE S ACPTNODE=$G(^ICPT(ACPTIEN,0)) ; get record's header node
  1.  . ;
  1.  . ; Q:ACPTACT=""  ; no action code (unchanged code, so do nothing)
  1.  . ; TOAD: I am not convinced the action codes are always correct.
  1.  . ; If a code has no action code but has actually been changed, this
  1.  . ; line will prevent the change from being applied. Someone should
  1.  . ; write some code to check out the validity of these action codes.
  1.  . ; This version of the patch will be conservative and not trust the
  1.  . ; data at the sites to be completely in synch with AMA; this patch
  1.  . ; will run more slowly, but subsequent HCPCS updates may then
  1.  . ; reinstate this line for improved efficiency knowing the data's in
  1.  . ; synch to begin with.
  1.  . ;
  1.  . N ACPTSHRT ; Short Name (2)
  1.  . S ACPTSHRT=$$CLEAN($E(ACPTLINE,7,41),1) ; clean up the Short Name
  1.  . I ACPTSHRT'="" S $P(ACPTNODE,U,2)=ACPTSHRT ; update it
  1.  . ;
  1.  . I ACPTACT="A" D  ; handle new codes specially:
  1.  . . S $P(ACPTNODE,U,4)=1 ; Inactive Flag (5) is true till step 6
  1.  . . S $P(ACPTNODE,U,6)=ACPTYR ; use special Date Added (7) flag
  1.  . E  D  ; for all other codes:
  1.  . . S $P(ACPTNODE,U,4)="" ; Inactive Flag is cleared
  1.  . . I $P(ACPTNODE,U,6)="" S $P(ACPTNODE,U,6)=3080101 ; set Date Added
  1.  . ;
  1.  . S $P(ACPTNODE,U,7)="" ; clear Date Deleted field (8)
  1.  . ;
  1.  . S ^ICPT(ACPTIEN,0)=ACPTNODE ; update header node
  1.  . ;
  1.  . N ACPTDESC ; Description field (50)
  1.  . S ACPTDESC=$$CLEAN($E(ACPTLINE,42,1097)) ; clean up the Description
  1.  . D TEXT(.ACPTDESC) ; convert string to WP array
  1.  . K ^ICPT(ACPTIEN,"D") ; clean out old Description (50)
  1.  . M ^ICPT(ACPTIEN,"D")=ACPTDESC ; copy array to field, incl. header
  1.  . ;
  1.  . N ACPTEDT ; last Effective Date
  1.  . S ACPTEDT=$O(^ICPT(ACPTIEN,60,"B",9999999),-1) ; find the last
  1.  . N ACPTEIEN S ACPTEIEN=$O(^ICPT(ACPTIEN,60,"B",+ACPTEDT,0)) ; its IEN
  1.  . ;
  1.  . I ACPTEDT=3080101,ACPTEIEN D  ; if there is one for this install date
  1.  . . Q:$P($G(^ICPT(ACPTIEN,60,ACPTEIEN,0)),U,2)  ; if active, we're fine
  1.  . . ; otherwise, we need to activate it:
  1.  . . N DA S DA=+ACPTEIEN ; IEN of last Effective Date
  1.  . . S DA(1)=ACPTIEN ; IEN of its parent CPT
  1.  . . N DIE S DIE="^ICPT("_DA(1)_",60," ; Effective Date (60/81.02)
  1.  . . N DR S DR=".02////1" ; set Status field to ACTIVE
  1.  . . N DIDEL,DTOUT ; other parameters for DIE
  1.  . . D ^DIE ; Fileman Data Edit call
  1.  . ;
  1.  . E  D  ; if not, then we need one
  1.  . . N DA S DA(1)=ACPTIEN ; into subfile under new entry
  1.  . . N DIC S DIC="^ICPT("_DA(1)_",60," ; Effective Date (60/81.02)
  1.  . . S DIC(0)="L" ; LAYGO
  1.  . . S DIC("P")=$P(^DD(81,60,0),U,2) ; subfile # & specifier codes
  1.  . . N X S X="01/01/2008" ; new entry for 1/1/2008
  1.  . . S DIC("DR")=".02////1" ; with Status = 1 (active)
  1.  . . N DLAYGO,Y,DTOUT,DUOUT ; other parameters
  1.  . . D ^DIC ; Fileman LAYGO lookup
  1.  . ;
  1.  . U IO(0) W:'(ACPTCNT#100) "."
  1.  ;
  1.  D ^%ZISC ; close the file
  1.  ;
  1.  QUIT  ; end of LOADCODE
  1.  ;
  1.  ;
  1. T(TAG) QUIT $P($T(@TAG),";;",2)
  1.  ;
  1.  ;
  1. MSG ; messages to display
  1.  ;;Could not open HCPCS file.
  1.  ;;Reading HCPCS Codes file.
  1.  ;
  1.  ;
  1. CLEAN(ACPTDESC,ACPTUP) ; clean up description field
  1.  ;
  1.  ; private, called only by LOADCODE above
  1.  ;
  1.  ; 1) strip out control characters
  1.  I ACPTDESC?.E1C.E D CLEAN^ACPT28P1(.ACPTDESC)
  1.  ;
  1.  ; 2) trim extra spaces
  1.  N ACPTCLN S ACPTCLN=""
  1.  N ACPTPIEC F ACPTPIEC=1:1:$L(ACPTDESC," ") D  ; traverse words
  1.  . N ACPTWORD S ACPTWORD=$P(ACPTDESC," ",ACPTPIEC) ; grab each word
  1.  . Q:ACPTWORD=""  ; skip empty words (multiple spaces together)
  1.  . S ACPTCLN=ACPTCLN_" "_ACPTWORD ; reassemble words with 1 space between
  1.  S $E(ACPTCLN)="" ; remove extraneous leading space
  1.  ;
  1.  ; 3) optionally, convert to upper case
  1.  I $G(ACPTUP) S ACPTDESC=$$UP^XLFSTR(ACPTCLN)
  1.  ;
  1.  QUIT ACPTCLN ; end of CLEAN
  1.  ;
  1.  ;
  1. TEXT(ACPTDESC) ; convert Description text to Word-Processing data type
  1.  ;
  1.  ; private, called only by LOADCODE above
  1.  ;
  1.  ; input: .ACPTDESC = passed by reference, starts out as long string,
  1.  ; ends as Fileman WP-format array complete with header
  1.  ;
  1.  N ACPTSTRN S ACPTSTRN=ACPTDESC ; copy string out
  1.  K ACPTDESC ; clear what will now become a WP array
  1.  N ACPTCNT S ACPTCNT=0 ; count WP lines for header
  1.  ;
  1.  F  Q:ACPTSTRN=""  D  ; loop until ACPTSTRN is fully transformed
  1.  . ;
  1.  . N ACPTBRK S ACPTBRK=0 ; character position to break at
  1.  . ;
  1.  . D  ; find the character position to break at
  1.  . . N ACPTRY ; break position to try
  1.  . . S ACPTRY=$L(ACPTSTRN) ; how long is the string?
  1.  . . I ACPTRY<81 S ACPTBRK=ACPTRY Q  ; if 1 full line or less, we're done
  1.  . . ;
  1.  . . F ACPTRY=80:-1:2 D  Q:ACPTBRK
  1.  . . . I $E(ACPTSTRN,ACPTRY+1)=" " D  Q  ; can break on a space
  1.  . . . . S $E(ACPTSTRN,ACPTRY+1)="" ; remove the space
  1.  . . . . S ACPTBRK=ACPTRY ; and let's break here
  1.  . . . ;
  1.  . . . I "&_+-*/<=>}])|:;,.?!"[$E(ACPTSTRN,ACPTRY) D  Q  ; on delimiter?
  1.  . . . . S ACPTBRK=ACPTRY ; so let's break here
  1.  . . ;
  1.  . . Q:ACPTBRK  ; if we found a good spot to break, we're done
  1.  . . ;
  1.  . . S ACPTBRK=80 ; otherwise, hard-break on 80 (weird content)
  1.  . ;
  1.  . S ACPTCNT=ACPTCNT+1 ; one more line
  1.  . S ACPTDESC(ACPTCNT,0)=$E(ACPTSTRN,1,ACPTBRK) ; copy line into array
  1.  . S $E(ACPTSTRN,1,ACPTBRK)="" ; & remove it from the string
  1.  ;
  1.  S ACPTDESC(0)="^81.01A^"_ACPTCNT_U_ACPTCNT_U_DT ; set WP header
  1.  ;
  1.  QUIT  ; end of TEXT
  1.  ;
  1.  ;
  1.  ; end of routine ACPT28PC