PRC182P1 ;FW/RB-PRE INSTALL PRC*182 TO FLAF FILE ^PRC(441.2) DELTED CODES WITH '*' ;4-26-94/3:45 PM
V ;;5.1;IFCAP;**182**;Oct 20, 2000;Build 40
;Per VA Directive 6402, this routine should not be modified.
Q
START ;PRC*5.1*182 Order through file 441.2 looking for DELETED
; where piece 4 = 'D'. For each deleted code
; will kill the current code 'B" x-ref and add
; new 'B' x-ref with '*' concatenated with code
; to signify deleted code which can no longer be
; pulled in search. Also, did the same thing
; 'D' x-ref for brief description to insure user
; cannot pull old description during search.
;
K ^XTMP("PRC182P1")
D NOW^%DTC S PRCSTART=%
S ^XTMP("PRC182P1","START DELETE FLAG")=PRCSTART
S ^XTMP("PRC182P1","END DELETE FLAGP")="RUNNING"
S ^XTMP("PRC182P1",0)=$$FMADD^XLFDT(PRCSTART,180)_"^"_PRCSTART
S U="^",PRCT1=0,PRCIEN=0
1 F S PRCIEN=$O(^PRC(441.2,PRCIEN)) Q:'PRCIEN D
. S PRCR0=^PRC(441.2,PRCIEN,0) Q:$P(PRCR0,U,4)'="D"
. S PRCT1=PRCT1+1
. K ^PRC(441.2,"B",$P(PRCR0,U),PRCIEN) S ^PRC(441.2,"B","*"_$P(PRCR0,U),PRCIEN)=""
. S PRCBDCP=$E($P(PRCR0,U,2),1,30)
. K ^PRC(441.2,"D",PRCBDCP,PRCIEN) S ^PRC(441.2,"D","*"_$E(PRCBDCP,1,29),PRCIEN)=""
D NOW^%DTC S PRCEND=%
S ^XTMP("PRC182P1","END DELETE FLAG")=PRCEND
S ^XTMP("PRC182P1","TOTAL DELETE FLAGS")=PRCT1
K %,PRCSTART,PRCEND,PRCT1,PRCIEN,PRCR0,PRCBDCP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRC182P1 1452 printed Nov 22, 2024@17:09:37 Page 2
PRC182P1 ;FW/RB-PRE INSTALL PRC*182 TO FLAF FILE ^PRC(441.2) DELTED CODES WITH '*' ;4-26-94/3:45 PM
V ;;5.1;IFCAP;**182**;Oct 20, 2000;Build 40
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 QUIT
START ;PRC*5.1*182 Order through file 441.2 looking for DELETED
+1 ; where piece 4 = 'D'. For each deleted code
+2 ; will kill the current code 'B" x-ref and add
+3 ; new 'B' x-ref with '*' concatenated with code
+4 ; to signify deleted code which can no longer be
+5 ; pulled in search. Also, did the same thing
+6 ; 'D' x-ref for brief description to insure user
+7 ; cannot pull old description during search.
+8 ;
+9 KILL ^XTMP("PRC182P1")
+10 DO NOW^%DTC
SET PRCSTART=%
+11 SET ^XTMP("PRC182P1","START DELETE FLAG")=PRCSTART
+12 SET ^XTMP("PRC182P1","END DELETE FLAGP")="RUNNING"
+13 SET ^XTMP("PRC182P1",0)=$$FMADD^XLFDT(PRCSTART,180)_"^"_PRCSTART
+14 SET U="^"
SET PRCT1=0
SET PRCIEN=0
1 FOR
SET PRCIEN=$ORDER(^PRC(441.2,PRCIEN))
if 'PRCIEN
QUIT
Begin DoDot:1
+1 SET PRCR0=^PRC(441.2,PRCIEN,0)
if $PIECE(PRCR0,U,4)'="D"
QUIT
+2 SET PRCT1=PRCT1+1
+3 KILL ^PRC(441.2,"B",$PIECE(PRCR0,U),PRCIEN)
SET ^PRC(441.2,"B","*"_$PIECE(PRCR0,U),PRCIEN)=""
+4 SET PRCBDCP=$EXTRACT($PIECE(PRCR0,U,2),1,30)
+5 KILL ^PRC(441.2,"D",PRCBDCP,PRCIEN)
SET ^PRC(441.2,"D","*"_$EXTRACT(PRCBDCP,1,29),PRCIEN)=""
End DoDot:1
+6 DO NOW^%DTC
SET PRCEND=%
+7 SET ^XTMP("PRC182P1","END DELETE FLAG")=PRCEND
+8 SET ^XTMP("PRC182P1","TOTAL DELETE FLAGS")=PRCT1
+9 KILL %,PRCSTART,PRCEND,PRCT1,PRCIEN,PRCR0,PRCBDCP
+10 QUIT
