ACPT291L ;IHS/SD/SDR - ACPT*2.09*1 install ; 12/29/2008 11:32
;;2.09;CPT FILES;**1**;JAN 8, 2009
;
Q ;
;
;
IMPORT ; this tag will load the complete file into ^TMP("ACPT-IMP",$J) using the concept ID
; and the property ID as the identifiers
N POP D Q:POP
.D OPEN^%ZISH("CPTHFILE",ACPTPTH,"acpt2009.01h","R") ; open read-only
.U IO(0) ; use terminal
.I POP D MES^XPDUTL("Could not open HCPCS file.")
.E D MES^XPDUTL("Reading HCPCS file.")
;
; Fields that will be used with their character counts
; Chars Field
; 1-5 HCPCS code
; 4-5 HCPCS modifier
; 6-10 HCPCS Sequence # - used to group proc or modifier codes together
; 11-11 HCPCS Rec ID code
; 3=First line of proc code
; 4=Second, third, fourth, etc. desc of proc
; 7=First line of mod code
; 8=Second, third, fourth, etc desc of mod
; 12-91 Long description
; 92-119 Short description
; 269-276 HCPCS Code Added Date
;;;; 277-284 HCPCS Action Effective Date (not used)
; 285-292 HCPCS Termination Date
; 293-293 HCPCS Action Code
; a A=Add proc or mod code
; c B=Change in both admin data field & long desc.
; c C=Change in long desc
; d D=Discontinued
; n F=Change in admin data field
; n N=No maintenance for this code
; n P=Payment change
; a R=Reactivate disc/deleted code
; c S=Change in short desc
; n T=Misc change (TOS, BETOS, etc)
;
W !
K ^TMP("ACPT-HCPCS")
K ACPTCNT ; count entries to print a dot for every 100
F ACPTCNT=1:1 D Q:$$STATUS^%ZISH ; loop until end of file
.;
.K ACPTLINE ; each line extracted from the file
.U IO R ACPTLINE Q:$$STATUS^%ZISH
.;
.I $E(ACPTLINE,1)=" " D ;this is a modifier
..S ACPTMOD=$E(ACPTLINE,4,5) ;modifier code
..I $E(ACPTLINE,11)=7 D ;first line of mod
...S ACPTLONG=$E(ACPTLINE,12,91) ;mod long desc.
...S ACPTSHRT=$E(ACPTLINE,92,119) ;mod short desc.
...S ^TMP("ACPT-HCPCS",$J,"M",ACPTMOD)=ACPTSHRT_"^"_ACPTLONG
..I $E(ACPTLINE,11)=8 D ;second line of mod
...S $P(^TMP("ACPT-HCPCS",$J,"M",ACPTMOD),U,2)=$P(^TMP("ACPT-HCPCS",$J,"M",ACPTMOD),U,2)_" "_ACPTLONG
.;
.I $E(ACPTLINE,1)'=" " D ;this is a proc code
..S ACPTCODE=$E(ACPTLINE,1,5) ;Proc code
..I $E(ACPTLINE,11)=3 D ;first line of proc
...S ACPTLONG=$E(ACPTLINE,12,91) ;proc long desc.
...S ACPTSHRT=$E(ACPTLINE,92,119) ;proc short desc.
...S ACPTACT=$E(ACPTLINE,293) ;proc action code
...S ACPTACT=$S(ACPTACT="R":"A",ACPTACT="B"!(ACPTACT="S"):"C",ACPTACT="F"!(ACPTACT="P")!(ACPTACT="T"):"N",1:ACPTACT)
...Q:ACPTACT="N" ;no maintenance codes are skipped
...S ^TMP("ACPT-HCPCS",$J,ACPTACT,ACPTCODE)=ACPTSHRT_"^"_ACPTLONG
..I $E(ACPTLINE,11)=4 D ;second line of proc
...Q:'$D(^TMP("ACPT-HCPCS",$J,"A",ACPTCODE))&'$D(^TMP("ACPT-HCPCS",$J,"C",ACPTCODE))&'$D(^TMP("ACPT-HCPCS",$J,"D",ACPTCODE))
...S ACPTACT=$S($D(^TMP("ACPT-HCPCS",$J,"A",ACPTCODE)):"A",$D(^TMP("ACPT-HCPCS",$J,"C",ACPTCODE)):"C",$D(^TMP("ACPT-HCPCS",$J,"D",ACPTCODE)):"D",1:"")
...Q:ACPTACT=""
...S ACPTLONG=$E(ACPTLINE,12,91)
...S $P(^TMP("ACPT-HCPCS",$J,ACPTACT,ACPTCODE),U,2)=$P(^TMP("ACPT-HCPCS",$J,ACPTACT,ACPTCODE),U,2)_" "_ACPTLONG
.;
.I '(ACPTCNT#100) U IO(0) W "."
D ^%ZISC ; close the file
;
;now actually load codes
F ACPTACT="A","C","D","M" D
.W !!,$S(ACPTACT="A":"ADDING",ACPTACT="C":"Modifying",ACPTACT="D":"Deleting",1:"Modifier")_" Codes:"
.S ACPTCODE=""
.F S ACPTCODE=$O(^TMP("ACPT-HCPCS",$J,ACPTACT,ACPTCODE)) Q:ACPTCODE="" D
..I ACPTACT'="D" D LOADCODE ;this will actually load code into ^ICPT
..I ACPTACT="D" D DELCODE ;delete codes
..W !?5,ACPTCODE,?15,ACPTSHRT
Q
LOADCODE ; load CPTs from ^TMP("ACPT-IMP",$J)
;
K ACPTNEW,ACPTIEN,ACPTSHRT,ACPTDESC
Q:(ACPTCODE'?1U4N)&(ACPTCODE'?2U)&(ACPTCODE'?1U1N) ;check format of code
;
I ACPTCODE?1U4N D ;HCPCS codes
.S ACPTIEN=$O(^ICPT("B",ACPTCODE,0)) ; find the code's record number
.I '$D(^ICPT("B",ACPTCODE)) D ; if there isn't one, create it
..S ACPTIEN=$A($E(ACPTCODE,1))_$E(ACPTCODE,2,5)
..S ^ICPT(ACPTIEN,0)=ACPTCODE ; CPT Code field (.01)
..S ^ICPT("B",ACPTCODE,ACPTIEN)="" ; index of CPT Codes
..S $P(^ICPT(ACPTIEN,0),U,6)=ACPTYR ; Date Added (7) to 3090000
..S:ACPTCODE="K0739"!(ACPTCODE="K0740")!(ACPTCODE="S3865")!(ACPTCODE="S3866")!(ACPTCODE="S3870") $P(^ICPT(ACPTIEN,0),U,6)=3090401 ;this codes are effective 4/1/09
.;
.S ACPTNODE=$G(^ICPT(ACPTIEN,0)) ; get record's header node
.S ACPTSHRT=$$CLEAN($P($G(^TMP("ACPT-HCPCS",$J,ACPTACT,ACPTCODE)),U)) ; clean up the Short Name
.I ACPTSHRT'="" S $P(ACPTNODE,U,2)=ACPTSHRT ; update it
.S $P(ACPTNODE,U,7)="" ; clear Date Deleted field (8)
.S ^ICPT(ACPTIEN,0)=ACPTNODE ; update header node
.;
.S ACPTDESC=$$CLEAN($P($G(^TMP("ACPT-HCPCS",$J,ACPTACT,ACPTCODE)),U,2)) ; clean up the Description
.D TEXT(.ACPTDESC) ; convert string to WP array
.K ^ICPT(ACPTIEN,"D") ; clean out old Description (50)
.M ^ICPT(ACPTIEN,"D")=ACPTDESC ; copy array to field, incl. header
.;
.S ACPTEDT=$O(^ICPT(ACPTIEN,60,"B",9999999),-1) ; find the last
.N ACPTEIEN S ACPTEIEN=$O(^ICPT(ACPTIEN,60,"B",+ACPTEDT,0)) ; its IEN
.;
.I ACPTEDT=3090101,ACPTEIEN D ; if there is one for this install date
..Q:$P($G(^ICPT(ACPTIEN,60,ACPTEIEN,0)),U,2) ; if active, we're fine
..; otherwise, we need to activate it:
..K DIC,DIE,DA,DIR,X,Y
..S DA=+ACPTEIEN ; IEN of last Effective Date
..S DA(1)=ACPTIEN ; IEN of its parent CPT
..S DIE="^ICPT("_DA(1)_",60," ; Effective Date (60/81.02)
..S DR=".02////1" ; set Status field to ACTIVE
..N DIDEL,DTOUT ; other parameters for DIE
..D ^DIE ; Fileman Data Edit call
.;
.E D ; if not, then we need one
..K DIC,DIE,DA,X,Y,DIR
..S DA(1)=ACPTIEN ; into subfile under new entry
..S DIC="^ICPT("_DA(1)_",60," ; Effective Date (60/81.02)
..S DIC(0)="L" ; LAYGO
..S DIC("P")=$P(^DD(81,60,0),U,2) ; subfile # & specifier codes
..S X="01/01/2009" ; new entry for 1/1/2009
..S:ACPTCODE="K0739"!(ACPTCODE="K0740")!(ACPTCODE="S3865")!(ACPTCODE="S3866")!(ACPTCODE="S3870") X="04/01/2009" ;this codes are effective 4/1/09
..S DIC("DR")=".02////1" ; with Status = 1 (active)
..N DLAYGO,Y,DTOUT,DUOUT ; other parameters
..D ^DIC ; Fileman LAYGO lookup
;
; add modifiers
I ACPTCODE?2U!(ACPTCODE?1U1N) D
.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
.;
.S ACPTSHRT=$$CLEAN($P($G(^TMP("ACPT-HCPCS",$J,"M",ACPTCODE)),U),1) ;Short desc
.I ACPTSHRT'="" D ; if a description is present in the AMA file
..S $P(^AUTTCMOD(ACPTIEN,0),U,2)=ACPTSHRT ; set the field
.S $P(^AUTTCMOD(ACPTIEN,0),U,4)="" ; clear Date Deleted (.04)
.;
.N ACPTDESC ; Long Description (1)
.S ACPTDESC=$$CLEAN($P($G(^TMP("ACPT-HCPCS",$J,"M",ACPTCODE)),U,2)) ;Long Desc
.D TEXT(.ACPTDESC) ; convert string to WP array
.K ^AUTTCMOD(ACPTIEN,1) ; delete its subtree
.M ^AUTTCMOD(ACPTIEN,1)=ACPTDESC ; copy array to field, incl. header
;
U IO(0) W:'(ACPTCNT#100) "."
Q
;
CLEAN(ACPTDESC,ACPTUP) ; clean up description field
;
;strip out control characters
I ACPTDESC?.E1C.E D CLEAN^ACPT28P1(.ACPTDESC)
;
;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
;
;optionally, convert to upper case
I $G(ACPTUP) S ACPTDESC=$$UP^XLFSTR(ACPTCLN)
;
Q ACPTCLN
DELCODE ;
S ACPTIEN=0
S ACPTSHRT="Couldn't find code to inactivate"
F S ACPTIEN=$O(^ICPT("B",ACPTCODE,ACPTIEN)) Q:'ACPTIEN D ; find the code's record number
.S:$P($G(^ICPT(ACPTIEN,0)),U,2)'="" ACPTSHRT=$P(^ICPT(ACPTIEN,0),U,2)
.S $P(^ICPT(ACPTIEN,0),U,7)=ACPTYR ; Date Deleted (8) to 3081231
.S:ACPTCODE="S8190" $P(^ICPT(ACPTIEN,0),U,7)=3090401
.;
.K DIC,DIE,DIR,X,Y,DA,DR
.S DA(1)=ACPTIEN ; parent record, i.e., the CPT code
.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
.S X="01/01/2009" ; value to lookup in the subfile
.S:ACPTCODE="S8190" X="04/01/2009"
.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
.;
.K DIR,DIE,DIC,X,Y,DR
.S DA(1)=ACPTIEN
.S DIE="^ICPT("_DA(1)_",60," ; Effective Date subfile (60/81.02)
.S DR=".02////0" ; set Status field to INACTIVE
.N DIDEL,DTOUT ; other parameters for DIE
.D ^DIE ; Fileman Data Edit call
Q
TEXT(ACPTDESC) ; convert Description text to Word-Processing data type
; input: .ACPTDESC = passed by reference, starts out as long string,
; ends as Fileman WP-format array complete with header
;
N ACPTSTRN S ACPTSTRN=ACPTDESC ; copy string out
K ACPTDESC ; 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 ACPTDESC(ACPTCNT,0)=$E(ACPTSTRN,1,ACPTBRK) ; copy line into array
.S $E(ACPTSTRN,1,ACPTBRK)="" ; & remove it from the string
;
S ACPTDESC(0)="^81.01A^"_ACPTCNT_U_ACPTCNT_U_DT ; set WP header
;
Q
ACPT291L ;IHS/SD/SDR - ACPT*2.09*1 install ; 12/29/2008 11:32
+1 ;;2.09;CPT FILES;**1**;JAN 8, 2009
+2 ;
+3 ;
QUIT
+4 ;
+5 ;
IMPORT ; this tag will load the complete file into ^TMP("ACPT-IMP",$J) using the concept ID
+1 ; and the property ID as the identifiers
+2 NEW POP
Begin DoDot:1
+3 ; open read-only
DO OPEN^%ZISH("CPTHFILE",ACPTPTH,"acpt2009.01h","R")
+4 ; use terminal
USE IO(0)
+5 IF POP
DO MES^XPDUTL("Could not open HCPCS file.")
+6 IF '$TEST
DO MES^XPDUTL("Reading HCPCS file.")
End DoDot:1
IF POP
QUIT
+7 ;
+8 ; Fields that will be used with their character counts
+9 ; Chars Field
+10 ; 1-5 HCPCS code
+11 ; 4-5 HCPCS modifier
+12 ; 6-10 HCPCS Sequence # - used to group proc or modifier codes together
+13 ; 11-11 HCPCS Rec ID code
+14 ; 3=First line of proc code
+15 ; 4=Second, third, fourth, etc. desc of proc
+16 ; 7=First line of mod code
+17 ; 8=Second, third, fourth, etc desc of mod
+18 ; 12-91 Long description
+19 ; 92-119 Short description
+20 ; 269-276 HCPCS Code Added Date
+21 ;;;; 277-284 HCPCS Action Effective Date (not used)
+22 ; 285-292 HCPCS Termination Date
+23 ; 293-293 HCPCS Action Code
+24 ; a A=Add proc or mod code
+25 ; c B=Change in both admin data field & long desc.
+26 ; c C=Change in long desc
+27 ; d D=Discontinued
+28 ; n F=Change in admin data field
+29 ; n N=No maintenance for this code
+30 ; n P=Payment change
+31 ; a R=Reactivate disc/deleted code
+32 ; c S=Change in short desc
+33 ; n T=Misc change (TOS, BETOS, etc)
+34 ;
+35 WRITE !
+36 KILL ^TMP("ACPT-HCPCS")
+37 ; count entries to print a dot for every 100
KILL ACPTCNT
+38 ; loop until end of file
FOR ACPTCNT=1:1
Begin DoDot:1
+39 ;
+40 ; each line extracted from the file
KILL ACPTLINE
+41 USE IO
READ ACPTLINE
IF $$STATUS^%ZISH
QUIT
+42 ;
+43 ;this is a modifier
IF $EXTRACT(ACPTLINE,1)=" "
Begin DoDot:2
+44 ;modifier code
SET ACPTMOD=$EXTRACT(ACPTLINE,4,5)
+45 ;first line of mod
IF $EXTRACT(ACPTLINE,11)=7
Begin DoDot:3
+46 ;mod long desc.
SET ACPTLONG=$EXTRACT(ACPTLINE,12,91)
+47 ;mod short desc.
SET ACPTSHRT=$EXTRACT(ACPTLINE,92,119)
+48 SET ^TMP("ACPT-HCPCS",$JOB,"M",ACPTMOD)=ACPTSHRT_"^"_ACPTLONG
End DoDot:3
+49 ;second line of mod
IF $EXTRACT(ACPTLINE,11)=8
Begin DoDot:3
+50 SET $PIECE(^TMP("ACPT-HCPCS",$JOB,"M",ACPTMOD),U,2)=$PIECE(^TMP("ACPT-HCPCS",$JOB,"M",ACPTMOD),U,2)_" "_ACPTLONG
End DoDot:3
End DoDot:2
+51 ;
+52 ;this is a proc code
IF $EXTRACT(ACPTLINE,1)'=" "
Begin DoDot:2
+53 ;Proc code
SET ACPTCODE=$EXTRACT(ACPTLINE,1,5)
+54 ;first line of proc
IF $EXTRACT(ACPTLINE,11)=3
Begin DoDot:3
+55 ;proc long desc.
SET ACPTLONG=$EXTRACT(ACPTLINE,12,91)
+56 ;proc short desc.
SET ACPTSHRT=$EXTRACT(ACPTLINE,92,119)
+57 ;proc action code
SET ACPTACT=$EXTRACT(ACPTLINE,293)
+58 SET ACPTACT=$SELECT(ACPTACT="R":"A",ACPTACT="B"!(ACPTACT="S"):"C",ACPTACT="F"!(ACPTACT="P")!(ACPTACT="T"):"N",1:ACPTACT)
+59 ;no maintenance codes are skipped
IF ACPTACT="N"
QUIT
+60 SET ^TMP("ACPT-HCPCS",$JOB,ACPTACT,ACPTCODE)=ACPTSHRT_"^"_ACPTLONG
End DoDot:3
+61 ;second line of proc
IF $EXTRACT(ACPTLINE,11)=4
Begin DoDot:3
+62 IF '$DATA(^TMP("ACPT-HCPCS",$JOB,"A",ACPTCODE))&'$DATA(^TMP("ACPT-HCPCS",$JOB,"C",ACPTCODE))&'$DATA(^TMP("ACPT-HCPCS",$JOB,"D",ACPTCODE))
QUIT
+63 SET ACPTACT=$SELECT($DATA(^TMP("ACPT-HCPCS",$JOB,"A",ACPTCODE)):"A",$DATA(^TMP("ACPT-HCPCS",$JOB,"C",ACPTCODE)):"C",$DATA(^TMP("ACPT-HCPCS",$JOB,"D",ACPTCODE)):"D",1:"")
+64 IF ACPTACT=""
QUIT
+65 SET ACPTLONG=$EXTRACT(ACPTLINE,12,91)
+66 SET $PIECE(^TMP("ACPT-HCPCS",$JOB,ACPTACT,ACPTCODE),U,2)=$PIECE(^TMP("ACPT-HCPCS",$JOB,ACPTACT,ACPTCODE),U,2)_" "_ACPTLONG
End DoDot:3
End DoDot:2
+67 ;
+68 IF '(ACPTCNT#100)
USE IO(0)
WRITE "."
End DoDot:1
IF $$STATUS^%ZISH
QUIT
+69 ; close the file
DO ^%ZISC
+70 ;
+71 ;now actually load codes
+72 FOR ACPTACT="A","C","D","M"
Begin DoDot:1
+73 WRITE !!,$SELECT(ACPTACT="A":"ADDING",ACPTACT="C":"Modifying",ACPTACT="D":"Deleting",1:"Modifier")_" Codes:"
+74 SET ACPTCODE=""
+75 FOR
SET ACPTCODE=$ORDER(^TMP("ACPT-HCPCS",$JOB,ACPTACT,ACPTCODE))
IF ACPTCODE=""
QUIT
Begin DoDot:2
+76 ;this will actually load code into ^ICPT
IF ACPTACT'="D"
DO LOADCODE
+77 ;delete codes
IF ACPTACT="D"
DO DELCODE
+78 WRITE !?5,ACPTCODE,?15,ACPTSHRT
End DoDot:2
End DoDot:1
+79 QUIT
LOADCODE ; load CPTs from ^TMP("ACPT-IMP",$J)
+1 ;
+2 KILL ACPTNEW,ACPTIEN,ACPTSHRT,ACPTDESC
+3 ;check format of code
IF (ACPTCODE'?1U4N)&(ACPTCODE'?2U)&(ACPTCODE'?1U1N)
QUIT
+4 ;
+5 ;HCPCS codes
IF ACPTCODE?1U4N
Begin DoDot:1
+6 ; find the code's record number
SET ACPTIEN=$ORDER(^ICPT("B",ACPTCODE,0))
+7 ; if there isn't one, create it
IF '$DATA(^ICPT("B",ACPTCODE))
Begin DoDot:2
+8 SET ACPTIEN=$ASCII($EXTRACT(ACPTCODE,1))_$EXTRACT(ACPTCODE,2,5)
+9 ; CPT Code field (.01)
SET ^ICPT(ACPTIEN,0)=ACPTCODE
+10 ; index of CPT Codes
SET ^ICPT("B",ACPTCODE,ACPTIEN)=""
+11 ; Date Added (7) to 3090000
SET $PIECE(^ICPT(ACPTIEN,0),U,6)=ACPTYR
+12 ;this codes are effective 4/1/09
IF ACPTCODE="K0739"!(ACPTCODE="K0740")!(ACPTCODE="S3865")!(ACPTCODE="S3866")!(ACPTCODE="S3870")
SET $PIECE(^ICPT(ACPTIEN,0),U,6)=3090401
End DoDot:2
+13 ;
+14 ; get record's header node
SET ACPTNODE=$GET(^ICPT(ACPTIEN,0))
+15 ; clean up the Short Name
SET ACPTSHRT=$$CLEAN($PIECE($GET(^TMP("ACPT-HCPCS",$JOB,ACPTACT,ACPTCODE)),U))
+16 ; update it
IF ACPTSHRT'=""
SET $PIECE(ACPTNODE,U,2)=ACPTSHRT
+17 ; clear Date Deleted field (8)
SET $PIECE(ACPTNODE,U,7)=""
+18 ; update header node
SET ^ICPT(ACPTIEN,0)=ACPTNODE
+19 ;
+20 ; clean up the Description
SET ACPTDESC=$$CLEAN($PIECE($GET(^TMP("ACPT-HCPCS",$JOB,ACPTACT,ACPTCODE)),U,2))
+21 ; convert string to WP array
DO TEXT(.ACPTDESC)
+22 ; clean out old Description (50)
KILL ^ICPT(ACPTIEN,"D")
+23 ; copy array to field, incl. header
MERGE ^ICPT(ACPTIEN,"D")=ACPTDESC
+24 ;
+25 ; find the last
SET ACPTEDT=$ORDER(^ICPT(ACPTIEN,60,"B",9999999),-1)
+26 ; its IEN
NEW ACPTEIEN
SET ACPTEIEN=$ORDER(^ICPT(ACPTIEN,60,"B",+ACPTEDT,0))
+27 ;
+28 ; if there is one for this install date
IF ACPTEDT=3090101
IF ACPTEIEN
Begin DoDot:2
+29 ; if active, we're fine
IF $PIECE($GET(^ICPT(ACPTIEN,60,ACPTEIEN,0)),U,2)
QUIT
+30 ; otherwise, we need to activate it:
+31 KILL DIC,DIE,DA,DIR,X,Y
+32 ; IEN of last Effective Date
SET DA=+ACPTEIEN
+33 ; IEN of its parent CPT
SET DA(1)=ACPTIEN
+34 ; Effective Date (60/81.02)
SET DIE="^ICPT("_DA(1)_",60,"
+35 ; set Status field to ACTIVE
SET DR=".02////1"
+36 ; other parameters for DIE
NEW DIDEL,DTOUT
+37 ; Fileman Data Edit call
DO ^DIE
End DoDot:2
+38 ;
+39 ; if not, then we need one
IF '$TEST
Begin DoDot:2
+40 KILL DIC,DIE,DA,X,Y,DIR
+41 ; into subfile under new entry
SET DA(1)=ACPTIEN
+42 ; Effective Date (60/81.02)
SET DIC="^ICPT("_DA(1)_",60,"
+43 ; LAYGO
SET DIC(0)="L"
+44 ; subfile # & specifier codes
SET DIC("P")=$PIECE(^DD(81,60,0),U,2)
+45 ; new entry for 1/1/2009
SET X="01/01/2009"
+46 ;this codes are effective 4/1/09
IF ACPTCODE="K0739"!(ACPTCODE="K0740")!(ACPTCODE="S3865")!(ACPTCODE="S3866")!(ACPTCODE="S3870")
SET X="04/01/2009"
+47 ; with Status = 1 (active)
SET DIC("DR")=".02////1"
+48 ; other parameters
NEW DLAYGO,Y,DTOUT,DUOUT
+49 ; Fileman LAYGO lookup
DO ^DIC
End DoDot:2
End DoDot:1
+50 ;
+51 ; add modifiers
+52 IF ACPTCODE?2U!(ACPTCODE?1U1N)
Begin DoDot:1
+53 ; find code's record number
SET ACPTIEN=$ORDER(^AUTTCMOD("B",ACPTCODE,0))
+54 ; if there isn't one yet, create it
IF 'ACPTIEN
Begin DoDot:2
+55 ; DINUM based on ASCII of code
SET ACPTIEN=$ASCII(ACPTCODE)_$ASCII(ACPTCODE,2)
+56 ; set Code & Date Added
SET ^AUTTCMOD(ACPTIEN,0)=ACPTCODE_U_U_ACPTYR
+57 ; and cross-reference it
SET ^AUTTCMOD("B",ACPTCODE,ACPTIEN)=""
End DoDot:2
+58 ;
+59 ;Short desc
SET ACPTSHRT=$$CLEAN($PIECE($GET(^TMP("ACPT-HCPCS",$JOB,"M",ACPTCODE)),U),1)
+60 ; if a description is present in the AMA file
IF ACPTSHRT'=""
Begin DoDot:2
+61 ; set the field
SET $PIECE(^AUTTCMOD(ACPTIEN,0),U,2)=ACPTSHRT
End DoDot:2
+62 ; clear Date Deleted (.04)
SET $PIECE(^AUTTCMOD(ACPTIEN,0),U,4)=""
+63 ;
+64 ; Long Description (1)
NEW ACPTDESC
+65 ;Long Desc
SET ACPTDESC=$$CLEAN($PIECE($GET(^TMP("ACPT-HCPCS",$JOB,"M",ACPTCODE)),U,2))
+66 ; convert string to WP array
DO TEXT(.ACPTDESC)
+67 ; delete its subtree
KILL ^AUTTCMOD(ACPTIEN,1)
+68 ; copy array to field, incl. header
MERGE ^AUTTCMOD(ACPTIEN,1)=ACPTDESC
End DoDot:1
+69 ;
+70 USE IO(0)
IF '(ACPTCNT#100)
WRITE "."
+71 QUIT
+72 ;
CLEAN(ACPTDESC,ACPTUP) ; clean up description field
+1 ;
+2 ;strip out control characters
+3 IF ACPTDESC?.E1C.E
DO CLEAN^ACPT28P1(.ACPTDESC)
+4 ;
+5 ;trim extra spaces
+6 NEW ACPTCLN
SET ACPTCLN=""
+7 ; traverse words
NEW ACPTPIEC
FOR ACPTPIEC=1:1:$LENGTH(ACPTDESC," ")
Begin DoDot:1
+8 ; grab each word
NEW ACPTWORD
SET ACPTWORD=$PIECE(ACPTDESC," ",ACPTPIEC)
+9 ; skip empty words (multiple spaces together)
IF ACPTWORD=""
QUIT
+10 ; reassemble words with 1 space between
SET ACPTCLN=ACPTCLN_" "_ACPTWORD
End DoDot:1
+11 ; remove extraneous leading space
SET $EXTRACT(ACPTCLN)=""
+12 ;
+13 ;optionally, convert to upper case
+14 IF $GET(ACPTUP)
SET ACPTDESC=$$UP^XLFSTR(ACPTCLN)
+15 ;
+16 QUIT ACPTCLN
DELCODE ;
+1 SET ACPTIEN=0
+2 SET ACPTSHRT="Couldn't find code to inactivate"
+3 ; find the code's record number
FOR
SET ACPTIEN=$ORDER(^ICPT("B",ACPTCODE,ACPTIEN))
IF 'ACPTIEN
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^ICPT(ACPTIEN,0)),U,2)'=""
SET ACPTSHRT=$PIECE(^ICPT(ACPTIEN,0),U,2)
+5 ; Date Deleted (8) to 3081231
SET $PIECE(^ICPT(ACPTIEN,0),U,7)=ACPTYR
+6 IF ACPTCODE="S8190"
SET $PIECE(^ICPT(ACPTIEN,0),U,7)=3090401
+7 ;
+8 KILL DIC,DIE,DIR,X,Y,DA,DR
+9 ; parent record, i.e., the CPT code
SET DA(1)=ACPTIEN
+10 ; Effective Date subfile (60/81.02)
SET DIC="^ICPT("_DA(1)_",60,"
+11 ; allow LAYGO (Learn As You Go, i.e., add if not found)
SET DIC(0)="L"
+12 ; subfile # & specifier codes
SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)
+13 ; value to lookup in the subfile
SET X="01/01/2009"
+14 IF ACPTCODE="S8190"
SET X="04/01/2009"
+15 ; other parameters for DIC
NEW DLAYGO,Y,DTOUT,DUOUT
+16 ; Fileman Lookup call
DO ^DIC
+17 ; save IEN of found/added record for next call below
SET DA=+Y
+18 ;
+19 KILL DIR,DIE,DIC,X,Y,DR
+20 SET DA(1)=ACPTIEN
+21 ; Effective Date subfile (60/81.02)
SET DIE="^ICPT("_DA(1)_",60,"
+22 ; set Status field to INACTIVE
SET DR=".02////0"
+23 ; other parameters for DIE
NEW DIDEL,DTOUT
+24 ; Fileman Data Edit call
DO ^DIE
End DoDot:1
+25 QUIT
TEXT(ACPTDESC) ; convert Description text to Word-Processing data type
+1 ; input: .ACPTDESC = passed by reference, starts out as long string,
+2 ; ends as Fileman WP-format array complete with header
+3 ;
+4 ; copy string out
NEW ACPTSTRN
SET ACPTSTRN=ACPTDESC
+5 ; clear what will now become a WP array
KILL ACPTDESC
+6 ; count WP lines for header
NEW ACPTCNT
SET ACPTCNT=0
+7 ;
+8 ; loop until ACPTSTRN is fully transformed
FOR
IF ACPTSTRN=""
QUIT
Begin DoDot:1
+9 ;
+10 ; character position to break at
NEW ACPTBRK
SET ACPTBRK=0
+11 ;
+12 ; find the character position to break at
Begin DoDot:2
+13 ; break position to try
NEW ACPTRY
+14 ; how long is the string?
SET ACPTRY=$LENGTH(ACPTSTRN)
+15 ; if 1 full line or less, we're done
IF ACPTRY<81
SET ACPTBRK=ACPTRY
QUIT
+16 ;
+17 FOR ACPTRY=80:-1:2
Begin DoDot:3
+18 ; can break on a space
IF $EXTRACT(ACPTSTRN,ACPTRY+1)=" "
Begin DoDot:4
+19 ; remove the space
SET $EXTRACT(ACPTSTRN,ACPTRY+1)=""
+20 ; and let's break here
SET ACPTBRK=ACPTRY
End DoDot:4
QUIT
+21 ;
+22 ; on delimiter?
IF "&_+-*/<=>}])|:;,.?!"[$EXTRACT(ACPTSTRN,ACPTRY)
Begin DoDot:4
+23 ; so let's break here
SET ACPTBRK=ACPTRY
End DoDot:4
QUIT
End DoDot:3
IF ACPTBRK
QUIT
+24 ;
+25 ; if we found a good spot to break, we're done
IF ACPTBRK
QUIT
+26 ;
+27 ; otherwise, hard-break on 80 (weird content)
SET ACPTBRK=80
End DoDot:2
+28 ;
+29 ; one more line
SET ACPTCNT=ACPTCNT+1
+30 ; copy line into array
SET ACPTDESC(ACPTCNT,0)=$EXTRACT(ACPTSTRN,1,ACPTBRK)
+31 ; & remove it from the string
SET $EXTRACT(ACPTSTRN,1,ACPTBRK)=""
End DoDot:1
+32 ;
+33 ; set WP header
SET ACPTDESC(0)="^81.01A^"_ACPTCNT_U_ACPTCNT_U_DT
+34 ;
+35 QUIT
