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

ACPT291L.m

Go to the documentation of this file. 
  1. ACPT291L ;IHS/SD/SDR - ACPT*2.09*1 install ; 12/29/2008 11:32
  1.  ;;2.09;CPT FILES;**1**;JAN 8, 2009
  1.  ;
  1.  Q  ;
  1.  ;
  1.  ;
  1. 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
  1.  N POP D  Q:POP
  1.  .D OPEN^%ZISH("CPTHFILE",ACPTPTH,"acpt2009.01h","R")  ; open read-only
  1.  .U IO(0)  ; use terminal
  1.  .I POP D MES^XPDUTL("Could not open HCPCS file.")
  1.  .E  D MES^XPDUTL("Reading HCPCS file.")
  1.  ;
  1.  ; Fields that will be used with their character counts
  1.  ; Chars   Field
  1.  ; 1-5     HCPCS code
  1.  ; 4-5     HCPCS modifier
  1.  ; 6-10    HCPCS Sequence # - used to group proc or modifier codes together
  1.  ; 11-11   HCPCS Rec ID code
  1.  ;   3=First line of proc code
  1.  ;   4=Second, third, fourth, etc. desc of proc
  1.  ;   7=First line of mod code
  1.  ;   8=Second, third, fourth, etc desc of mod
  1.  ; 12-91   Long description
  1.  ; 92-119  Short description
  1.  ; 269-276 HCPCS Code Added Date
  1.  ;;;; 277-284 HCPCS Action Effective Date (not used)
  1.  ; 285-292 HCPCS Termination Date
  1.  ; 293-293 HCPCS Action Code
  1.  ;  a A=Add proc or mod code
  1.  ;  c B=Change in both admin data field & long desc.
  1.  ;  c C=Change in long desc
  1.  ;  d D=Discontinued
  1.  ;  n F=Change in admin data field
  1.  ;  n N=No maintenance for this code
  1.  ;  n P=Payment change
  1.  ;  a R=Reactivate disc/deleted code
  1.  ;  c S=Change in short desc
  1.  ;  n T=Misc change (TOS, BETOS, etc)
  1.  ;
  1.  W !
  1.  K ^TMP("ACPT-HCPCS")
  1.  K 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.  .K ACPTLINE  ; each line extracted from the file
  1.  .U IO R ACPTLINE Q:$$STATUS^%ZISH
  1.  .;
  1.  .I $E(ACPTLINE,1)=" " D  ;this is a modifier
  1.  ..S ACPTMOD=$E(ACPTLINE,4,5)  ;modifier code
  1.  ..I $E(ACPTLINE,11)=7 D  ;first line of mod
  1.  ...S ACPTLONG=$E(ACPTLINE,12,91)  ;mod long desc.
  1.  ...S ACPTSHRT=$E(ACPTLINE,92,119)  ;mod short desc.
  1.  ...S ^TMP("ACPT-HCPCS",$J,"M",ACPTMOD)=ACPTSHRT_"^"_ACPTLONG
  1.  ..I $E(ACPTLINE,11)=8 D  ;second line of mod
  1.  ...S $P(^TMP("ACPT-HCPCS",$J,"M",ACPTMOD),U,2)=$P(^TMP("ACPT-HCPCS",$J,"M",ACPTMOD),U,2)_" "_ACPTLONG
  1.  .;
  1.  .I $E(ACPTLINE,1)'=" " D  ;this is a proc code
  1.  ..S ACPTCODE=$E(ACPTLINE,1,5)  ;Proc code
  1.  ..I $E(ACPTLINE,11)=3 D  ;first line of proc
  1.  ...S ACPTLONG=$E(ACPTLINE,12,91)  ;proc long desc.
  1.  ...S ACPTSHRT=$E(ACPTLINE,92,119)  ;proc short desc.
  1.  ...S ACPTACT=$E(ACPTLINE,293)  ;proc action code
  1.  ...S ACPTACT=$S(ACPTACT="R":"A",ACPTACT="B"!(ACPTACT="S"):"C",ACPTACT="F"!(ACPTACT="P")!(ACPTACT="T"):"N",1:ACPTACT)
  1.  ...Q:ACPTACT="N"  ;no maintenance codes are skipped
  1.  ...S ^TMP("ACPT-HCPCS",$J,ACPTACT,ACPTCODE)=ACPTSHRT_"^"_ACPTLONG
  1.  ..I $E(ACPTLINE,11)=4 D  ;second line of proc
  1.  ...Q:'$D(^TMP("ACPT-HCPCS",$J,"A",ACPTCODE))&'$D(^TMP("ACPT-HCPCS",$J,"C",ACPTCODE))&'$D(^TMP("ACPT-HCPCS",$J,"D",ACPTCODE))
  1.  ...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:"")
  1.  ...Q:ACPTACT=""
  1.  ...S ACPTLONG=$E(ACPTLINE,12,91)
  1.  ...S $P(^TMP("ACPT-HCPCS",$J,ACPTACT,ACPTCODE),U,2)=$P(^TMP("ACPT-HCPCS",$J,ACPTACT,ACPTCODE),U,2)_" "_ACPTLONG
  1.  .;
  1.  .I '(ACPTCNT#100) U IO(0) W "."
  1.  D ^%ZISC  ; close the file
  1.  ;
  1.  ;now actually load codes
  1.  F ACPTACT="A","C","D","M" D
  1.  .W !!,$S(ACPTACT="A":"ADDING",ACPTACT="C":"Modifying",ACPTACT="D":"Deleting",1:"Modifier")_" Codes:"
  1.  .S ACPTCODE=""
  1.  .F  S ACPTCODE=$O(^TMP("ACPT-HCPCS",$J,ACPTACT,ACPTCODE)) Q:ACPTCODE=""  D
  1.  ..I ACPTACT'="D" D LOADCODE  ;this will actually load code into ^ICPT
  1.  ..I ACPTACT="D" D DELCODE  ;delete codes
  1.  ..W !?5,ACPTCODE,?15,ACPTSHRT
  1.  Q
  1. LOADCODE ; load CPTs from ^TMP("ACPT-IMP",$J)
  1.  ;
  1.  K ACPTNEW,ACPTIEN,ACPTSHRT,ACPTDESC
  1.  Q:(ACPTCODE'?1U4N)&(ACPTCODE'?2U)&(ACPTCODE'?1U1N)  ;check format of code
  1.  ;
  1.  I ACPTCODE?1U4N D  ;HCPCS codes
  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,1))_$E(ACPTCODE,2,5)
  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 3090000
  1.  ..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
  1.  .;
  1.  .S ACPTNODE=$G(^ICPT(ACPTIEN,0))  ; get record's header node
  1.  .S ACPTSHRT=$$CLEAN($P($G(^TMP("ACPT-HCPCS",$J,ACPTACT,ACPTCODE)),U))  ; clean up the Short Name
  1.  .I ACPTSHRT'="" S $P(ACPTNODE,U,2)=ACPTSHRT  ; update it
  1.  .S $P(ACPTNODE,U,7)=""  ; clear Date Deleted field (8)
  1.  .S ^ICPT(ACPTIEN,0)=ACPTNODE  ; update header node
  1.  .;
  1.  .S ACPTDESC=$$CLEAN($P($G(^TMP("ACPT-HCPCS",$J,ACPTACT,ACPTCODE)),U,2))  ; 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.  .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=3090101,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.  ..K DIC,DIE,DA,DIR,X,Y
  1.  ..S DA=+ACPTEIEN  ; IEN of last Effective Date
  1.  ..S DA(1)=ACPTIEN  ; IEN of its parent CPT
  1.  ..S DIE="^ICPT("_DA(1)_",60,"  ; Effective Date (60/81.02)
  1.  ..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.  ..K DIC,DIE,DA,X,Y,DIR
  1.  ..S DA(1)=ACPTIEN  ; into subfile under new entry
  1.  ..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.  ..S X="01/01/2009"  ; new entry for 1/1/2009
  1.  ..S:ACPTCODE="K0739"!(ACPTCODE="K0740")!(ACPTCODE="S3865")!(ACPTCODE="S3866")!(ACPTCODE="S3870") X="04/01/2009"  ;this codes are effective 4/1/09
  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.  ; add modifiers
  1.  I ACPTCODE?2U!(ACPTCODE?1U1N) D
  1.  .S ACPTIEN=$O(^AUTTCMOD("B",ACPTCODE,0)) ; find code's record number
  1.  .I 'ACPTIEN D  ; if there isn't one yet, create it
  1.  ..S ACPTIEN=$A(ACPTCODE)_$A(ACPTCODE,2) ; DINUM based on ASCII of code
  1.  ..S ^AUTTCMOD(ACPTIEN,0)=ACPTCODE_U_U_ACPTYR ; set Code & Date Added
  1.  ..S ^AUTTCMOD("B",ACPTCODE,ACPTIEN)="" ; and cross-reference it
  1.  .;
  1.  .S ACPTSHRT=$$CLEAN($P($G(^TMP("ACPT-HCPCS",$J,"M",ACPTCODE)),U),1)  ;Short desc
  1.  .I ACPTSHRT'="" D  ; if a description is present in the AMA file
  1.  ..S $P(^AUTTCMOD(ACPTIEN,0),U,2)=ACPTSHRT ; set the field
  1.  .S $P(^AUTTCMOD(ACPTIEN,0),U,4)="" ; clear Date Deleted (.04)
  1.  .;
  1.  .N ACPTDESC ; Long Description (1)
  1.  .S ACPTDESC=$$CLEAN($P($G(^TMP("ACPT-HCPCS",$J,"M",ACPTCODE)),U,2))  ;Long Desc
  1.  .D TEXT(.ACPTDESC) ; convert string to WP array
  1.  .K ^AUTTCMOD(ACPTIEN,1) ; delete its subtree
  1.  .M ^AUTTCMOD(ACPTIEN,1)=ACPTDESC  ; copy array to field, incl. header
  1.  ;
  1.  U IO(0) W:'(ACPTCNT#100) "."
  1.  Q
  1.  ;
  1. CLEAN(ACPTDESC,ACPTUP) ; clean up description field
  1.  ;
  1.  ;strip out control characters
  1.  I ACPTDESC?.E1C.E D CLEAN^ACPT28P1(.ACPTDESC)
  1.  ;
  1.  ;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.  ;optionally, convert to upper case
  1.  I $G(ACPTUP) S ACPTDESC=$$UP^XLFSTR(ACPTCLN)
  1.  ;
  1.  Q ACPTCLN
  1. DELCODE ;
  1.  S ACPTIEN=0
  1.  S ACPTSHRT="Couldn't find code to inactivate"
  1.  F  S ACPTIEN=$O(^ICPT("B",ACPTCODE,ACPTIEN)) Q:'ACPTIEN  D  ; find the code's record number
  1.  .S:$P($G(^ICPT(ACPTIEN,0)),U,2)'="" ACPTSHRT=$P(^ICPT(ACPTIEN,0),U,2)
  1.  .S $P(^ICPT(ACPTIEN,0),U,7)=ACPTYR  ; Date Deleted (8) to 3081231
  1.  .S:ACPTCODE="S8190" $P(^ICPT(ACPTIEN,0),U,7)=3090401
  1.  .;
  1.  .K DIC,DIE,DIR,X,Y,DA,DR
  1.  .S DA(1)=ACPTIEN  ; parent record, i.e., the CPT code
  1.  .S DIC="^ICPT("_DA(1)_",60,"  ; Effective Date subfile (60/81.02)
  1.  .S DIC(0)="L"  ; allow LAYGO (Learn As You Go, i.e., add if not found)
  1.  .S DIC("P")=$P(^DD(81,60,0),"^",2)  ; subfile # & specifier codes
  1.  .S X="01/01/2009"  ; value to lookup in the subfile
  1.  .S:ACPTCODE="S8190" X="04/01/2009"
  1.  .N DLAYGO,Y,DTOUT,DUOUT  ; other parameters for DIC
  1.  .D ^DIC  ; Fileman Lookup call
  1.  .S DA=+Y  ; save IEN of found/added record for next call below
  1.  .;
  1.  .K DIR,DIE,DIC,X,Y,DR
  1.  .S DA(1)=ACPTIEN
  1.  .S DIE="^ICPT("_DA(1)_",60,"  ; Effective Date subfile (60/81.02)
  1.  .S DR=".02////0"  ; set Status field to INACTIVE
  1.  .N DIDEL,DTOUT  ; other parameters for DIE
  1.  .D ^DIE  ; Fileman Data Edit call
  1.  Q
  1. TEXT(ACPTDESC) ; convert Description text to Word-Processing data type
  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.  Q