ACPT28PD.m

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