PRC182P1.m

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 ---PRC182P1   1452     printed  Apr 09, 2024@21:13:49                                                                                                                                                                                                    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