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

ACPT29L.m

Go to the documentation of this file. 
  1. ACPT29L ;IHS/SD/SDR - ACPT 2.09 install ; 12/29/2008 11:32
  1.  ;;2.09;CPT FILES;;JAN 2, 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.  K ^TMP("ACPT-IMP",$J),^TMP("ACPT-CPTS",$J),^TMP("ACPT-CNT",$J)
  1.  N POP D  Q:POP
  1.  .D OPEN^%ZISH("CPTHFILE",ACPTPTH,"acpt2009.l","R")  ; open read-only
  1.  .U IO(0)  ; use terminal
  1.  .I POP D MES^XPDUTL("Could not open CPT file.")
  1.  .E  D MES^XPDUTL("Reading CPT file.")
  1.  ;
  1.  W !
  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.  .S ACPTFIEN=$P(ACPTLINE,"|")  ;file IEN (concept ID)
  1.  .S ACPTPID=$P(ACPTLINE,"|",2)  ;property ID
  1.  .;the below check has to be done for long description; it could be spread over
  1.  .;multiple lines and have 01, 02 etc on each line.
  1.  .S ACPTLCNT=$S(ACPTPID=106:1,$P(ACPTLINE,"|",3)[":"&($P(+$P(ACPTLINE,"|",3),":")'=0):+$P($P(ACPTLINE,"|",3),":"),1:1)
  1.  .S ACPTDATA=$S(+$P($P(ACPTLINE,"|",3),":",2)'=0&(ACPTPID'=106):$P($P(ACPTLINE,"|",3),":",2),(+$P($P(ACPTLINE,"|",3),":",2)=0)&(ACPTPID'=106):$P(ACPTLINE,"|",3),1:$P(ACPTLINE,"|",3))
  1.  .S ^TMP("ACPT-IMP",$J,ACPTFIEN,ACPTPID,ACPTLCNT)=ACPTDATA
  1.  .I ACPTPID=104,($P(ACPTLINE,"|",3)'="") D
  1.  ..S ^TMP("ACPT-CPTS",$J,ACPTFIEN,$P(ACPTLINE,"|",3),ACPTPID)=""  ;only CPT entries
  1.  ..S ^TMP("ACPT-CNT",$J)=+$G(^TMP("ACPT-CNT",$J))+1  ;count
  1.  ..I '(ACPTFIEN#100) U IO(0) W "."
  1.  D ^%ZISC  ; close the file
  1.  ;now actually load codes
  1.  W !,"ADDING CODES:"
  1.  S ACPTFIEN=0
  1.  F  S ACPTFIEN=$O(^TMP("ACPT-CPTS",$J,ACPTFIEN)) Q:+ACPTFIEN=0  D
  1.  .S ACPTCODE=""
  1.  .F  S ACPTCODE=$O(^TMP("ACPT-CPTS",$J,ACPTFIEN,ACPTCODE)) Q:ACPTCODE=""  D
  1.  ..D LOADCODE  ;this will actually load code into ^ICPT
  1.  ..I $G(ACPTNEW)=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'?5N)&(ACPTCODE'?4N1U)  ;cpt of ####F
  1.  ;
  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 ACPTNEW=1
  1.  .S ACPTIEN=$S(ACPTCODE?4N1U:$A($E(ACPTCODE,1))_$A($E(ACPTCODE,2))_$A($E(ACPTCODE,3))_$A($E(ACPTCODE,4))_$A($E(ACPTCODE,5)),1:+ACPTCODE)
  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.  S ACPTNODE=$G(^ICPT(ACPTIEN,0))  ; get record's header node
  1.  S ACPTSHRT=$$CLEAN($G(^TMP("ACPT-IMP",$J,ACPTFIEN,111,1)))  ; clean up the Short Name
  1.  I ACPTSHRT'="" S $P(ACPTNODE,U,2)=ACPTSHRT  ; update it
  1.  ;
  1.  I $G(ACPTNEW)=1 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)=ACPTYR  ; 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.  S ACPTL=0
  1.  S ACPTDESC=""
  1.  F  S ACPTL=$O(^TMP("ACPT-IMP",$J,ACPTFIEN,106,ACPTL)) Q:+ACPTL=0  D
  1.  .I ACPTDESC'="" S ACPTDESC=ACPTDESC_" "_$G(^TMP("ACPT-IMP",$J,ACPTFIEN,106,ACPTL))
  1.  .I ACPTDESC="" S ACPTDESC=$G(^TMP("ACPT-IMP",$J,ACPTFIEN,106,ACPTL))
  1.  S ACPTDESC=$$CLEAN(ACPTDESC)  ; 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/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.  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. DELETE ;  this tag will load the complete file into ^TMP("ACPT-DEL",$J) using the concept ID
  1.  ;  and the property ID as the identifiers
  1.  K ^TMP("ACPT-DEL",$J),^TMP("ACPT-DCNT",$J)
  1.  N POP D  Q:POP
  1.  .D OPEN^%ZISH("CPTHFILE",ACPTPTH,"acpt2009.d","R")  ; open read-only
  1.  .U IO(0)  ; use terminal
  1.  .I POP D MES^XPDUTL("Could not open CPT delete file.")
  1.  .E  D MES^XPDUTL("Reading CPT delete file.")
  1.  ;
  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.  .S ACPTFIEN=$P(ACPTLINE,"|")  ;file IEN (concept ID)
  1.  .Q:+ACPTFIEN=0  ;no file IEN
  1.  .S ACPTCD=$P(ACPTLINE,"|",2)  ;code
  1.  .Q:$L(ACPTCD)'=5  ;all codes should be 5 chars
  1.  .Q:$P(ACPTLINE,"|",3)'=2009  ;only do 2009 deletes
  1.  .S ^TMP("ACPT-DEL",$J,ACPTFIEN,ACPTCD)=$P(ACPTLINE,"|",3),^TMP("ACPT-DCNT",$J)=+$G(^TMP("ACPT-DCNT",$J))+1  ;only CPT entries
  1.  D ^%ZISC  ; close the file
  1.  ;now actually load codes
  1.  W !,"Deleting Codes:"
  1.  S ACPTFIEN=0
  1.  F  S ACPTFIEN=$O(^TMP("ACPT-DEL",$J,ACPTFIEN)) Q:+ACPTFIEN=0  D
  1.  .S ACPTCODE=0
  1.  .F  S ACPTCODE=$O(^TMP("ACPT-DEL",$J,ACPTFIEN,ACPTCODE)) Q:+ACPTCODE=0  D
  1.  ..D DELCODE  ;this will actually flag code as deleted in ^ICPT
  1.  ..W !?3,ACPTCODE_" "_ACPTDESC
  1.  Q
  1. DELCODE ;
  1.  S ACPTIEN=0
  1.  S ACPTDESC="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)'="" ACPTDESC=$P(^ICPT(ACPTIEN,0),U,2)
  1.  .S $P(^ICPT(ACPTIEN,0),U,7)=ACPTYR  ; Date Deleted (8) to 3081231
  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.  .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