ACPT28PD ;IHS/VEN/TOAD - ACPT*2.08*1 postinit step 4.2 ; 04/21/2008 11:24
;;2.08;CPT FILES;**1**;DEC 17, 2007
;
; This subroutine of the post-init for ACPT*2.08*1 loads the HCPCS 2008
; modifiers from the American Medical Association's text file
; acpt2008.01c and installs them in the RPMS CPT Modifier file
; (9999999.88). It does not do all of the actions needed to install
; those modifiers, only the raw loading. 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 LOADMOD by ACPT28PA as part of the
; post-init for ACPT*2.08*1.
;
; 2008 04 16-20 Rick Marshall refactored this routine for
; maintainability. All commented-out code was removed so this version of
; the routine handles only HCPCS codes. Fixed bug in unportable handling
; of Description & Long Description fields. Renamed routine from
; ACPTPST2 to ACPT28PD.
;
; The original code was written by IHS/ASDST/DMJ and Shonda Render
; (SDR).
;
;
LOADMOD ;load HCPCS modifiers from AMA HCPCS Modifiers file
;
; private: called only by step 4 of routine ACPT28PA
;
; input: ACPTPTH = path to directory where file is stored
; ACPTYR = flag to identify newly added entries (3080000)
;
N POP D Q:POP
. D OPEN^%ZISH("CPTHFILE",ACPTPTH,"acpt2008.01c","R") ; open read-only
. U IO(0) ; use terminal
. I POP D MES^XPDUTL($$T("MSG+1")) ; Could not open HCPCS Modifiers f...
. E D MES^XPDUTL($$T("MSG+2")) ; Reading HCPCS Modifiers file.
;
N ACPTCNT ; count entries to print a dot for every 100
F ACPTCNT=1:1 D Q:$$STATUS^%ZISH ; loop until end of file
. ;
. N ACPTLINE ; each line extracted from the file
. U IO R ACPTLINE Q:$$STATUS^%ZISH
. ;
. N ACPTCODE ; HCPCS modifier, aka Code (.01)
. S ACPTCODE=$E(ACPTLINE,1,2) ; 1st 2 chars contain the HCPCS modifier
. ;
. N ACPTIEN ; IEN of entry in CPT Modifier file
. S ACPTIEN=$O(^AUTTCMOD("B",ACPTCODE,0)) ; find code's record number
. I 'ACPTIEN D ; if there isn't one yet, create it
. . S ACPTIEN=$A(ACPTCODE)_$A(ACPTCODE,2) ; DINUM based on ASCII of code
. . S ^AUTTCMOD(ACPTIEN,0)=ACPTCODE_U_U_ACPTYR ; set Code & Date Added
. . S ^AUTTCMOD("B",ACPTCODE,ACPTIEN)="" ; and cross-reference it
. ;
. N ACPTDESC ; Description (.02)
. S ACPTDESC=$$CLEAN($E(ACPTLINE,3,153),1) ; Description up to 150 chars
. I ACPTDESC'="" D ; if a description is present in the AMA file
. . S $P(^AUTTCMOD(ACPTIEN,0),U,2)=ACPTDESC ; set the field
. I "^AE^AF^AG^AK^CB^FP^QA^"[(U_ACPTCODE_U) D ; if one of these codes
. . S $P(^AUTTCMOD(ACPTIEN,0),U,2)="" ; description is wrong, so delete
. ;
. S $P(^AUTTCMOD(ACPTIEN,0),U,4)="" ; clear Date Deleted (.04)
. ;
. N ACPTLONG ; Long Description (1)
. S ACPTLONG=$$CLEAN($E(ACPTLINE,3,536)) ; rest of up to 536 = Long Desc
. D TEXT(.ACPTLONG) ; convert string to WP array
. K ^AUTTCMOD(ACPTIEN,1) ; delete its subtree
. M ^AUTTCMOD(ACPTIEN,1)=ACPTLONG ; copy array to field, incl. header
. ;
. U IO(0) W:'(ACPTCNT#100) "."
;
D ^%ZISC ; close the file
;
QUIT ; end of LOADMOD
;
;
T(TAG) QUIT $P($T(@TAG),";;",2)
;
;
MSG ; messages to display
;;Could not open HCPCS Modifiers file.
;;Reading HCPCS Modifiers file.
;
;
CLEAN(ACPTDESC,ACPTUP) ; clean up description field
;
; private, called only by LOADCODE above
;
; 1) strip out control characters
I ACPTDESC?.E1C.E D CLEAN^ACPT28P1(.ACPTDESC)
;
; 2) trim extra spaces
N ACPTCLN S ACPTCLN=""
N ACPTPIEC F ACPTPIEC=1:1:$L(ACPTDESC," ") D ; traverse words
. N ACPTWORD S ACPTWORD=$P(ACPTDESC," ",ACPTPIEC) ; grab each word
. Q:ACPTWORD="" ; skip empty words (multiple spaces together)
. S ACPTCLN=ACPTCLN_" "_ACPTWORD ; reassemble words with 1 space between
S $E(ACPTCLN)="" ; remove extraneous leading space
;
; 3) optionally, convert to upper case
I $G(ACPTUP) S ACPTDESC=$$UP^XLFSTR(ACPTCLN)
;
QUIT ACPTCLN ; end of CLEAN
;
;
TEXT(ACPTLONG) ; convert Long Description text to Word-Processing data type
;
; private, called only by LOADCODE above
;
; input: .ACPTLONG = passed by reference, starts out as long string,
; ends as Fileman WP-format array complete with header
;
N ACPTSTRN S ACPTSTRN=ACPTLONG ; copy string out
K ACPTLONG ; clear what will now become a WP array
N ACPTCNT S ACPTCNT=0 ; count WP lines for header
;
F Q:ACPTSTRN="" D ; loop until ACPTSTRN is fully transformed
. ;
. N ACPTBRK S ACPTBRK=0 ; character position to break at
. ;
. D ; find the character position to break at
. . N ACPTRY ; break position to try
. . S ACPTRY=$L(ACPTSTRN) ; how long is the string?
. . I ACPTRY<81 S ACPTBRK=ACPTRY Q ; if 1 full line or less, we're done
. . ;
. . F ACPTRY=80:-1:2 D Q:ACPTBRK
. . . I $E(ACPTSTRN,ACPTRY+1)=" " D Q ; can break on a space
. . . . S $E(ACPTSTRN,ACPTRY+1)="" ; remove the space
. . . . S ACPTBRK=ACPTRY ; and let's break here
. . . ;
. . . I "&_+-*/<=>}])|:;,.?!"[$E(ACPTSTRN,ACPTRY) D Q ; on delimiter?
. . . . S ACPTBRK=ACPTRY ; so let's break here
. . ;
. . Q:ACPTBRK ; if we found a good spot to break, we're done
. . ;
. . S ACPTBRK=80 ; otherwise, hard-break on 80 (weird content)
. ;
. S ACPTCNT=ACPTCNT+1 ; one more line
. S ACPTLONG(ACPTCNT,0)=$E(ACPTSTRN,1,ACPTBRK) ; copy line into array
. S $E(ACPTSTRN,1,ACPTBRK)="" ; & remove it from the string
;
S ACPTLONG(0)="^9999999.881^"_ACPTCNT_U_ACPTCNT_U_DT ; set WP header
;
QUIT ; end of TEXT
;
;
; end of routine ACPT28PD
ACPT28PD ;IHS/VEN/TOAD - ACPT*2.08*1 postinit step 4.2 ; 04/21/2008 11:24
+1 ;;2.08;CPT FILES;**1**;DEC 17, 2007
+2 ;
+3 ; This subroutine of the post-init for ACPT*2.08*1 loads the HCPCS 2008
+4 ; modifiers from the American Medical Association's text file
+5 ; acpt2008.01c and installs them in the RPMS CPT Modifier file
+6 ; (9999999.88). It does not do all of the actions needed to install
+7 ; those modifiers, only the raw loading. See routine ACPT28PA for the
+8 ; complete algorithm and overview.
+9 ;
+10 ; This routine should not be called at the top or anywhere
QUIT
+11 ; else. It is only to be called at LOADMOD by ACPT28PA as part of the
+12 ; post-init for ACPT*2.08*1.
+13 ;
+14 ; 2008 04 16-20 Rick Marshall refactored this routine for
+15 ; maintainability. All commented-out code was removed so this version of
+16 ; the routine handles only HCPCS codes. Fixed bug in unportable handling
+17 ; of Description & Long Description fields. Renamed routine from
+18 ; ACPTPST2 to ACPT28PD.
+19 ;
+20 ; The original code was written by IHS/ASDST/DMJ and Shonda Render
+21 ; (SDR).
+22 ;
+23 ;
LOADMOD ;load HCPCS modifiers from AMA HCPCS Modifiers file
+1 ;
+2 ; private: called only by step 4 of routine ACPT28PA
+3 ;
+4 ; input: ACPTPTH = path to directory where file is stored
+5 ; ACPTYR = flag to identify newly added entries (3080000)
+6 ;
+7 NEW POP
Begin DoDot:1
+8 ; open read-only
DO OPEN^%ZISH("CPTHFILE",ACPTPTH,"acpt2008.01c","R")
+9 ; use terminal
USE IO(0)
+10 ; Could not open HCPCS Modifiers f...
IF POP
DO MES^XPDUTL($$T("MSG+1"))
+11 ; Reading HCPCS Modifiers file.
IF '$TEST
DO MES^XPDUTL($$T("MSG+2"))
End DoDot:1
IF POP
QUIT
+12 ;
+13 ; count entries to print a dot for every 100
NEW ACPTCNT
+14 ; loop until end of file
FOR ACPTCNT=1:1
Begin DoDot:1
+15 ;
+16 ; each line extracted from the file
NEW ACPTLINE
+17 USE IO
READ ACPTLINE
IF $$STATUS^%ZISH
QUIT
+18 ;
+19 ; HCPCS modifier, aka Code (.01)
NEW ACPTCODE
+20 ; 1st 2 chars contain the HCPCS modifier
SET ACPTCODE=$EXTRACT(ACPTLINE,1,2)
+21 ;
+22 ; IEN of entry in CPT Modifier file
NEW ACPTIEN
+23 ; find code's record number
SET ACPTIEN=$ORDER(^AUTTCMOD("B",ACPTCODE,0))
+24 ; if there isn't one yet, create it
IF 'ACPTIEN
Begin DoDot:2
+25 ; DINUM based on ASCII of code
SET ACPTIEN=$ASCII(ACPTCODE)_$ASCII(ACPTCODE,2)
+26 ; set Code & Date Added
SET ^AUTTCMOD(ACPTIEN,0)=ACPTCODE_U_U_ACPTYR
+27 ; and cross-reference it
SET ^AUTTCMOD("B",ACPTCODE,ACPTIEN)=""
End DoDot:2
+28 ;
+29 ; Description (.02)
NEW ACPTDESC
+30 ; Description up to 150 chars
SET ACPTDESC=$$CLEAN($EXTRACT(ACPTLINE,3,153),1)
+31 ; if a description is present in the AMA file
IF ACPTDESC'=""
Begin DoDot:2
+32 ; set the field
SET $PIECE(^AUTTCMOD(ACPTIEN,0),U,2)=ACPTDESC
End DoDot:2
+33 ; if one of these codes
IF "^AE^AF^AG^AK^CB^FP^QA^"[(U_ACPTCODE_U)
Begin DoDot:2
+34 ; description is wrong, so delete
SET $PIECE(^AUTTCMOD(ACPTIEN,0),U,2)=""
End DoDot:2
+35 ;
+36 ; clear Date Deleted (.04)
SET $PIECE(^AUTTCMOD(ACPTIEN,0),U,4)=""
+37 ;
+38 ; Long Description (1)
NEW ACPTLONG
+39 ; rest of up to 536 = Long Desc
SET ACPTLONG=$$CLEAN($EXTRACT(ACPTLINE,3,536))
+40 ; convert string to WP array
DO TEXT(.ACPTLONG)
+41 ; delete its subtree
KILL ^AUTTCMOD(ACPTIEN,1)
+42 ; copy array to field, incl. header
MERGE ^AUTTCMOD(ACPTIEN,1)=ACPTLONG
+43 ;
+44 USE IO(0)
IF '(ACPTCNT#100)
WRITE "."
End DoDot:1
IF $$STATUS^%ZISH
QUIT
+45 ;
+46 ; close the file
DO ^%ZISC
+47 ;
+48 ; end of LOADMOD
QUIT
+49 ;
+50 ;
T(TAG) QUIT $PIECE($TEXT(@TAG),";;",2)
+1 ;
+2 ;
MSG ; messages to display
+1 ;;Could not open HCPCS Modifiers file.
+2 ;;Reading HCPCS Modifiers file.
+3 ;
+4 ;
CLEAN(ACPTDESC,ACPTUP) ; clean up description field
+1 ;
+2 ; private, called only by LOADCODE above
+3 ;
+4 ; 1) strip out control characters
+5 IF ACPTDESC?.E1C.E
DO CLEAN^ACPT28P1(.ACPTDESC)
+6 ;
+7 ; 2) trim extra spaces
+8 NEW ACPTCLN
SET ACPTCLN=""
+9 ; traverse words
NEW ACPTPIEC
FOR ACPTPIEC=1:1:$LENGTH(ACPTDESC," ")
Begin DoDot:1
+10 ; grab each word
NEW ACPTWORD
SET ACPTWORD=$PIECE(ACPTDESC," ",ACPTPIEC)
+11 ; skip empty words (multiple spaces together)
IF ACPTWORD=""
QUIT
+12 ; reassemble words with 1 space between
SET ACPTCLN=ACPTCLN_" "_ACPTWORD
End DoDot:1
+13 ; remove extraneous leading space
SET $EXTRACT(ACPTCLN)=""
+14 ;
+15 ; 3) optionally, convert to upper case
+16 IF $GET(ACPTUP)
SET ACPTDESC=$$UP^XLFSTR(ACPTCLN)
+17 ;
+18 ; end of CLEAN
QUIT ACPTCLN
+19 ;
+20 ;
TEXT(ACPTLONG) ; convert Long Description text to Word-Processing data type
+1 ;
+2 ; private, called only by LOADCODE above
+3 ;
+4 ; input: .ACPTLONG = passed by reference, starts out as long string,
+5 ; ends as Fileman WP-format array complete with header
+6 ;
+7 ; copy string out
NEW ACPTSTRN
SET ACPTSTRN=ACPTLONG
+8 ; clear what will now become a WP array
KILL ACPTLONG
+9 ; count WP lines for header
NEW ACPTCNT
SET ACPTCNT=0
+10 ;
+11 ; loop until ACPTSTRN is fully transformed
FOR
IF ACPTSTRN=""
QUIT
Begin DoDot:1
+12 ;
+13 ; character position to break at
NEW ACPTBRK
SET ACPTBRK=0
+14 ;
+15 ; find the character position to break at
Begin DoDot:2
+16 ; break position to try
NEW ACPTRY
+17 ; how long is the string?
SET ACPTRY=$LENGTH(ACPTSTRN)
+18 ; if 1 full line or less, we're done
IF ACPTRY<81
SET ACPTBRK=ACPTRY
QUIT
+19 ;
+20 FOR ACPTRY=80:-1:2
Begin DoDot:3
+21 ; can break on a space
IF $EXTRACT(ACPTSTRN,ACPTRY+1)=" "
Begin DoDot:4
+22 ; remove the space
SET $EXTRACT(ACPTSTRN,ACPTRY+1)=""
+23 ; and let's break here
SET ACPTBRK=ACPTRY
End DoDot:4
QUIT
+24 ;
+25 ; on delimiter?
IF "&_+-*/<=>}])|:;,.?!"[$EXTRACT(ACPTSTRN,ACPTRY)
Begin DoDot:4
+26 ; so let's break here
SET ACPTBRK=ACPTRY
End DoDot:4
QUIT
End DoDot:3
IF ACPTBRK
QUIT
+27 ;
+28 ; if we found a good spot to break, we're done
IF ACPTBRK
QUIT
+29 ;
+30 ; otherwise, hard-break on 80 (weird content)
SET ACPTBRK=80
End DoDot:2
+31 ;
+32 ; one more line
SET ACPTCNT=ACPTCNT+1
+33 ; copy line into array
SET ACPTLONG(ACPTCNT,0)=$EXTRACT(ACPTSTRN,1,ACPTBRK)
+34 ; & remove it from the string
SET $EXTRACT(ACPTSTRN,1,ACPTBRK)=""
End DoDot:1
+35 ;
+36 ; set WP header
SET ACPTLONG(0)="^9999999.881^"_ACPTCNT_U_ACPTCNT_U_DT
+37 ;
+38 ; end of TEXT
QUIT
+39 ;
+40 ;
+41 ; end of routine ACPT28PD