ACPT29L ;IHS/SD/SDR - ACPT 2.09 install ; 12/29/2008 11:32
;;2.09;CPT FILES;;JAN 2, 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
K ^TMP("ACPT-IMP",$J),^TMP("ACPT-CPTS",$J),^TMP("ACPT-CNT",$J)
N POP D Q:POP
.D OPEN^%ZISH("CPTHFILE",ACPTPTH,"acpt2009.l","R") ; open read-only
.U IO(0) ; use terminal
.I POP D MES^XPDUTL("Could not open CPT file.")
.E D MES^XPDUTL("Reading CPT file.")
;
W !
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
.S ACPTFIEN=$P(ACPTLINE,"|") ;file IEN (concept ID)
.S ACPTPID=$P(ACPTLINE,"|",2) ;property ID
.;the below check has to be done for long description; it could be spread over
.;multiple lines and have 01, 02 etc on each line.
.S ACPTLCNT=$S(ACPTPID=106:1,$P(ACPTLINE,"|",3)[":"&($P(+$P(ACPTLINE,"|",3),":")'=0):+$P($P(ACPTLINE,"|",3),":"),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))
.S ^TMP("ACPT-IMP",$J,ACPTFIEN,ACPTPID,ACPTLCNT)=ACPTDATA
.I ACPTPID=104,($P(ACPTLINE,"|",3)'="") D
..S ^TMP("ACPT-CPTS",$J,ACPTFIEN,$P(ACPTLINE,"|",3),ACPTPID)="" ;only CPT entries
..S ^TMP("ACPT-CNT",$J)=+$G(^TMP("ACPT-CNT",$J))+1 ;count
..I '(ACPTFIEN#100) U IO(0) W "."
D ^%ZISC ; close the file
;now actually load codes
W !,"ADDING CODES:"
S ACPTFIEN=0
F S ACPTFIEN=$O(^TMP("ACPT-CPTS",$J,ACPTFIEN)) Q:+ACPTFIEN=0 D
.S ACPTCODE=""
.F S ACPTCODE=$O(^TMP("ACPT-CPTS",$J,ACPTFIEN,ACPTCODE)) Q:ACPTCODE="" D
..D LOADCODE ;this will actually load code into ^ICPT
..I $G(ACPTNEW)=1 W !?5,ACPTCODE,?15,ACPTSHRT
Q
LOADCODE ; load CPTs from ^TMP("ACPT-IMP",$J)
;
K ACPTNEW,ACPTIEN,ACPTSHRT,ACPTDESC
Q:(ACPTCODE'?5N)&(ACPTCODE'?4N1U) ;cpt of ####F
;
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 ACPTNEW=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)
.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 3080000
;
S ACPTNODE=$G(^ICPT(ACPTIEN,0)) ; get record's header node
S ACPTSHRT=$$CLEAN($G(^TMP("ACPT-IMP",$J,ACPTFIEN,111,1))) ; clean up the Short Name
I ACPTSHRT'="" S $P(ACPTNODE,U,2)=ACPTSHRT ; update it
;
I $G(ACPTNEW)=1 D ; handle new codes specially
.;S $P(ACPTNODE,U,4)=1 ; Inactive Flag (5) is true till step 6
.S $P(ACPTNODE,U,6)=ACPTYR ; use special Date Added (7) flag
E D ; for all other codes:
.S $P(ACPTNODE,U,4)="" ; Inactive Flag is cleared
.I $P(ACPTNODE,U,6)="" S $P(ACPTNODE,U,6)=ACPTYR ; set Date Added
;
S $P(ACPTNODE,U,7)="" ; clear Date Deleted field (8)
;
S ^ICPT(ACPTIEN,0)=ACPTNODE ; update header node
;
S ACPTL=0
S ACPTDESC=""
F S ACPTL=$O(^TMP("ACPT-IMP",$J,ACPTFIEN,106,ACPTL)) Q:+ACPTL=0 D
.I ACPTDESC'="" S ACPTDESC=ACPTDESC_" "_$G(^TMP("ACPT-IMP",$J,ACPTFIEN,106,ACPTL))
.I ACPTDESC="" S ACPTDESC=$G(^TMP("ACPT-IMP",$J,ACPTFIEN,106,ACPTL))
S ACPTDESC=$$CLEAN(ACPTDESC) ; 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/2008
.S DIC("DR")=".02////1" ; with Status = 1 (active)
.N DLAYGO,Y,DTOUT,DUOUT ; other parameters
.D ^DIC ; Fileman LAYGO lookup
;
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
DELETE ; this tag will load the complete file into ^TMP("ACPT-DEL",$J) using the concept ID
; and the property ID as the identifiers
K ^TMP("ACPT-DEL",$J),^TMP("ACPT-DCNT",$J)
N POP D Q:POP
.D OPEN^%ZISH("CPTHFILE",ACPTPTH,"acpt2009.d","R") ; open read-only
.U IO(0) ; use terminal
.I POP D MES^XPDUTL("Could not open CPT delete file.")
.E D MES^XPDUTL("Reading CPT delete file.")
;
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
.S ACPTFIEN=$P(ACPTLINE,"|") ;file IEN (concept ID)
.Q:+ACPTFIEN=0 ;no file IEN
.S ACPTCD=$P(ACPTLINE,"|",2) ;code
.Q:$L(ACPTCD)'=5 ;all codes should be 5 chars
.Q:$P(ACPTLINE,"|",3)'=2009 ;only do 2009 deletes
.S ^TMP("ACPT-DEL",$J,ACPTFIEN,ACPTCD)=$P(ACPTLINE,"|",3),^TMP("ACPT-DCNT",$J)=+$G(^TMP("ACPT-DCNT",$J))+1 ;only CPT entries
D ^%ZISC ; close the file
;now actually load codes
W !,"Deleting Codes:"
S ACPTFIEN=0
F S ACPTFIEN=$O(^TMP("ACPT-DEL",$J,ACPTFIEN)) Q:+ACPTFIEN=0 D
.S ACPTCODE=0
.F S ACPTCODE=$O(^TMP("ACPT-DEL",$J,ACPTFIEN,ACPTCODE)) Q:+ACPTCODE=0 D
..D DELCODE ;this will actually flag code as deleted in ^ICPT
..W !?3,ACPTCODE_" "_ACPTDESC
Q
DELCODE ;
S ACPTIEN=0
S ACPTDESC="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)'="" ACPTDESC=$P(^ICPT(ACPTIEN,0),U,2)
.S $P(^ICPT(ACPTIEN,0),U,7)=ACPTYR ; Date Deleted (8) to 3081231
.;
.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
.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
ACPT29L ;IHS/SD/SDR - ACPT 2.09 install ; 12/29/2008 11:32
+1 ;;2.09;CPT FILES;;JAN 2, 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 KILL ^TMP("ACPT-IMP",$JOB),^TMP("ACPT-CPTS",$JOB),^TMP("ACPT-CNT",$JOB)
+3 NEW POP
Begin DoDot:1
+4 ; open read-only
DO OPEN^%ZISH("CPTHFILE",ACPTPTH,"acpt2009.l","R")
+5 ; use terminal
USE IO(0)
+6 IF POP
DO MES^XPDUTL("Could not open CPT file.")
+7 IF '$TEST
DO MES^XPDUTL("Reading CPT file.")
End DoDot:1
IF POP
QUIT
+8 ;
+9 WRITE !
+10 ; count entries to print a dot for every 100
KILL ACPTCNT
+11 ; loop until end of file
FOR ACPTCNT=1:1
Begin DoDot:1
+12 ;
+13 ; each line extracted from the file
KILL ACPTLINE
+14 USE IO
READ ACPTLINE
IF $$STATUS^%ZISH
QUIT
+15 ;file IEN (concept ID)
SET ACPTFIEN=$PIECE(ACPTLINE,"|")
+16 ;property ID
SET ACPTPID=$PIECE(ACPTLINE,"|",2)
+17 ;the below check has to be done for long description; it could be spread over
+18 ;multiple lines and have 01, 02 etc on each line.
+19 SET ACPTLCNT=$SELECT(ACPTPID=106:1,$PIECE(ACPTLINE,"|",3)[":"&($PIECE(+$PIECE(ACPTLINE,"|",3),":")'=0):+$PIECE($PIECE(ACPTLINE,"|",3),":"),1:1)
+20 SET ACPTDATA=$SELECT(+$PIECE($PIECE(ACPTLINE,"|",3),":",2)'=0&(ACPTPID'=106):$PIECE($PIECE(ACPTLINE,"|",3),":",2),(+$PIECE($PIECE(ACPTLINE,"|",3),":",2)=0)&(ACPTPID'=106):$PIECE(ACPTLINE,"|",3),1:$PIECE(ACPTLINE,"|",3))
+21 SET ^TMP("ACPT-IMP",$JOB,ACPTFIEN,ACPTPID,ACPTLCNT)=ACPTDATA
+22 IF ACPTPID=104
IF ($PIECE(ACPTLINE,"|",3)'="")
Begin DoDot:2
+23 ;only CPT entries
SET ^TMP("ACPT-CPTS",$JOB,ACPTFIEN,$PIECE(ACPTLINE,"|",3),ACPTPID)=""
+24 ;count
SET ^TMP("ACPT-CNT",$JOB)=+$GET(^TMP("ACPT-CNT",$JOB))+1
+25 IF '(ACPTFIEN#100)
USE IO(0)
WRITE "."
End DoDot:2
End DoDot:1
IF $$STATUS^%ZISH
QUIT
+26 ; close the file
DO ^%ZISC
+27 ;now actually load codes
+28 WRITE !,"ADDING CODES:"
+29 SET ACPTFIEN=0
+30 FOR
SET ACPTFIEN=$ORDER(^TMP("ACPT-CPTS",$JOB,ACPTFIEN))
IF +ACPTFIEN=0
QUIT
Begin DoDot:1
+31 SET ACPTCODE=""
+32 FOR
SET ACPTCODE=$ORDER(^TMP("ACPT-CPTS",$JOB,ACPTFIEN,ACPTCODE))
IF ACPTCODE=""
QUIT
Begin DoDot:2
+33 ;this will actually load code into ^ICPT
DO LOADCODE
+34 IF $GET(ACPTNEW)=1
WRITE !?5,ACPTCODE,?15,ACPTSHRT
End DoDot:2
End DoDot:1
+35 QUIT
LOADCODE ; load CPTs from ^TMP("ACPT-IMP",$J)
+1 ;
+2 KILL ACPTNEW,ACPTIEN,ACPTSHRT,ACPTDESC
+3 ;cpt of ####F
IF (ACPTCODE'?5N)&(ACPTCODE'?4N1U)
QUIT
+4 ;
+5 ; find the code's record number
SET ACPTIEN=$ORDER(^ICPT("B",ACPTCODE,0))
+6 ; if there isn't one, create it
IF '$DATA(^ICPT("B",ACPTCODE))
Begin DoDot:1
+7 SET ACPTNEW=1
+8 SET ACPTIEN=$SELECT(ACPTCODE?4N1U:$ASCII($EXTRACT(ACPTCODE,1))_$ASCII($EXTRACT(ACPTCODE,2))_$ASCII($EXTRACT(ACPTCODE,3))_$ASCII($EXTRACT(ACPTCODE,4))_$ASCII($EXTRACT(ACPTCODE,5)),1:+ACPTCODE)
+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 3080000
SET $PIECE(^ICPT(ACPTIEN,0),U,6)=ACPTYR
End DoDot:1
+12 ;
+13 ; get record's header node
SET ACPTNODE=$GET(^ICPT(ACPTIEN,0))
+14 ; clean up the Short Name
SET ACPTSHRT=$$CLEAN($GET(^TMP("ACPT-IMP",$JOB,ACPTFIEN,111,1)))
+15 ; update it
IF ACPTSHRT'=""
SET $PIECE(ACPTNODE,U,2)=ACPTSHRT
+16 ;
+17 ; handle new codes specially
IF $GET(ACPTNEW)=1
Begin DoDot:1
+18 ;S $P(ACPTNODE,U,4)=1 ; Inactive Flag (5) is true till step 6
+19 ; use special Date Added (7) flag
SET $PIECE(ACPTNODE,U,6)=ACPTYR
End DoDot:1
+20 ; for all other codes:
IF '$TEST
Begin DoDot:1
+21 ; Inactive Flag is cleared
SET $PIECE(ACPTNODE,U,4)=""
+22 ; set Date Added
IF $PIECE(ACPTNODE,U,6)=""
SET $PIECE(ACPTNODE,U,6)=ACPTYR
End DoDot:1
+23 ;
+24 ; clear Date Deleted field (8)
SET $PIECE(ACPTNODE,U,7)=""
+25 ;
+26 ; update header node
SET ^ICPT(ACPTIEN,0)=ACPTNODE
+27 ;
+28 SET ACPTL=0
+29 SET ACPTDESC=""
+30 FOR
SET ACPTL=$ORDER(^TMP("ACPT-IMP",$JOB,ACPTFIEN,106,ACPTL))
IF +ACPTL=0
QUIT
Begin DoDot:1
+31 IF ACPTDESC'=""
SET ACPTDESC=ACPTDESC_" "_$GET(^TMP("ACPT-IMP",$JOB,ACPTFIEN,106,ACPTL))
+32 IF ACPTDESC=""
SET ACPTDESC=$GET(^TMP("ACPT-IMP",$JOB,ACPTFIEN,106,ACPTL))
End DoDot:1
+33 ; clean up the Description
SET ACPTDESC=$$CLEAN(ACPTDESC)
+34 ; convert string to WP array
DO TEXT(.ACPTDESC)
+35 ; clean out old Description (50)
KILL ^ICPT(ACPTIEN,"D")
+36 ; copy array to field, incl. header
MERGE ^ICPT(ACPTIEN,"D")=ACPTDESC
+37 ;
+38 ; find the last
SET ACPTEDT=$ORDER(^ICPT(ACPTIEN,60,"B",9999999),-1)
+39 ; its IEN
NEW ACPTEIEN
SET ACPTEIEN=$ORDER(^ICPT(ACPTIEN,60,"B",+ACPTEDT,0))
+40 ;
+41 ; if there is one for this install date
IF ACPTEDT=3090101
IF ACPTEIEN
Begin DoDot:1
+42 ; if active, we're fine
IF $PIECE($GET(^ICPT(ACPTIEN,60,ACPTEIEN,0)),U,2)
QUIT
+43 ; otherwise, we need to activate it:
+44 KILL DIC,DIE,DA,DIR,X,Y
+45 ; IEN of last Effective Date
SET DA=+ACPTEIEN
+46 ; IEN of its parent CPT
SET DA(1)=ACPTIEN
+47 ; Effective Date (60/81.02)
SET DIE="^ICPT("_DA(1)_",60,"
+48 ; set Status field to ACTIVE
SET DR=".02////1"
+49 ; other parameters for DIE
NEW DIDEL,DTOUT
+50 ; Fileman Data Edit call
DO ^DIE
End DoDot:1
+51 ;
+52 ; if not, then we need one
IF '$TEST
Begin DoDot:1
+53 KILL DIC,DIE,DA,X,Y,DIR
+54 ; into subfile under new entry
SET DA(1)=ACPTIEN
+55 ; Effective Date (60/81.02)
SET DIC="^ICPT("_DA(1)_",60,"
+56 ; LAYGO
SET DIC(0)="L"
+57 ; subfile # & specifier codes
SET DIC("P")=$PIECE(^DD(81,60,0),U,2)
+58 ; new entry for 1/1/2008
SET X="01/01/2009"
+59 ; with Status = 1 (active)
SET DIC("DR")=".02////1"
+60 ; other parameters
NEW DLAYGO,Y,DTOUT,DUOUT
+61 ; Fileman LAYGO lookup
DO ^DIC
End DoDot:1
+62 ;
+63 USE IO(0)
IF '(ACPTCNT#100)
WRITE "."
+64 QUIT
+65 ;
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
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
+2 KILL ^TMP("ACPT-DEL",$JOB),^TMP("ACPT-DCNT",$JOB)
+3 NEW POP
Begin DoDot:1
+4 ; open read-only
DO OPEN^%ZISH("CPTHFILE",ACPTPTH,"acpt2009.d","R")
+5 ; use terminal
USE IO(0)
+6 IF POP
DO MES^XPDUTL("Could not open CPT delete file.")
+7 IF '$TEST
DO MES^XPDUTL("Reading CPT delete file.")
End DoDot:1
IF POP
QUIT
+8 ;
+9 ; count entries to print a dot for every 100
KILL ACPTCNT
+10 ; loop until end of file
FOR ACPTCNT=1:1
Begin DoDot:1
+11 ;
+12 ; each line extracted from the file
KILL ACPTLINE
+13 USE IO
READ ACPTLINE
IF $$STATUS^%ZISH
QUIT
+14 ;file IEN (concept ID)
SET ACPTFIEN=$PIECE(ACPTLINE,"|")
+15 ;no file IEN
IF +ACPTFIEN=0
QUIT
+16 ;code
SET ACPTCD=$PIECE(ACPTLINE,"|",2)
+17 ;all codes should be 5 chars
IF $LENGTH(ACPTCD)'=5
QUIT
+18 ;only do 2009 deletes
IF $PIECE(ACPTLINE,"|",3)'=2009
QUIT
+19 ;only CPT entries
SET ^TMP("ACPT-DEL",$JOB,ACPTFIEN,ACPTCD)=$PIECE(ACPTLINE,"|",3)
SET ^TMP("ACPT-DCNT",$JOB)=+$GET(^TMP("ACPT-DCNT",$JOB))+1
End DoDot:1
IF $$STATUS^%ZISH
QUIT
+20 ; close the file
DO ^%ZISC
+21 ;now actually load codes
+22 WRITE !,"Deleting Codes:"
+23 SET ACPTFIEN=0
+24 FOR
SET ACPTFIEN=$ORDER(^TMP("ACPT-DEL",$JOB,ACPTFIEN))
IF +ACPTFIEN=0
QUIT
Begin DoDot:1
+25 SET ACPTCODE=0
+26 FOR
SET ACPTCODE=$ORDER(^TMP("ACPT-DEL",$JOB,ACPTFIEN,ACPTCODE))
IF +ACPTCODE=0
QUIT
Begin DoDot:2
+27 ;this will actually flag code as deleted in ^ICPT
DO DELCODE
+28 WRITE !?3,ACPTCODE_" "_ACPTDESC
End DoDot:2
End DoDot:1
+29 QUIT
DELCODE ;
+1 SET ACPTIEN=0
+2 SET ACPTDESC="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 ACPTDESC=$PIECE(^ICPT(ACPTIEN,0),U,2)
+5 ; Date Deleted (8) to 3081231
SET $PIECE(^ICPT(ACPTIEN,0),U,7)=ACPTYR
+6 ;
+7 KILL DIC,DIE,DIR,X,Y,DA,DR
+8 ; parent record, i.e., the CPT code
SET DA(1)=ACPTIEN
+9 ; Effective Date subfile (60/81.02)
SET DIC="^ICPT("_DA(1)_",60,"
+10 ; allow LAYGO (Learn As You Go, i.e., add if not found)
SET DIC(0)="L"
+11 ; subfile # & specifier codes
SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)
+12 ; value to lookup in the subfile
SET X="01/01/2009"
+13 ; other parameters for DIC
NEW DLAYGO,Y,DTOUT,DUOUT
+14 ; Fileman Lookup call
DO ^DIC
+15 ; save IEN of found/added record for next call below
SET DA=+Y
+16 ;
+17 KILL DIR,DIE,DIC,X,Y,DR
+18 SET DA(1)=ACPTIEN
+19 ; Effective Date subfile (60/81.02)
SET DIE="^ICPT("_DA(1)_",60,"
+20 ; set Status field to INACTIVE
SET DR=".02////0"
+21 ; other parameters for DIE
NEW DIDEL,DTOUT
+22 ; Fileman Data Edit call
DO ^DIE
End DoDot:1
+23 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
