PRCP185P.m

PRCP185P ;RB-PRE INSTALL PRC*185 TO RE-INDEX FILE 445, FIELD .8 ;4-26-94/3:45 PM

V ;;5.1;IFCAP;**185**;Oct 20, 2000;Build 3

 ;Per VHA Directive 2004-038, this routine should not be modified.

 Q

START ;PRC*5.1*185 Process to re-index file 445, field .8 [ABBREVIATED NAME]

 ;            due to adding new CROSS REFERENCE ('CAB') to field.

 ;

 K ^XTMP("PRCP185P")

 D NOW^%DTC S RMSTART=%

 S ^XTMP("PRCP185P","START COMPILE")=RMSTART

 S ^XTMP("PRCP185P","END COMPILE")="RUNNING"

 S ^XTMP("PRCP185P",0)=$$FMADD^XLFDT(RMSTART,180)_"^"_RMSTART

 S PRCIEN=0

BB F  S PRCIEN=$O(^PRCP(445,PRCIEN)) Q:'PRCIEN  D

 . Q:'$D(^PRCP(445,PRCIEN,0))  S DA=PRCIEN

 . S PRCPR0=^PRCP(445,PRCIEN,0) S PRCABRV=$P(PRCPR0,"^",5) Q:PRCABRV=""

 . S ^XTMP("PRCP185P",DA,PRCABRV)="" K DIC

 . S DIK="^PRCP(445,",DIK(1)=".8^2" D EN^DIK K DIK

 . S ^XTMP("PRCP185P",DA,PRCABRV,"CAB")=$S('$D(^PRCP(445,"CAB",PRCABRV,DA)):0,1:1)

 D NOW^%DTC S RMEND=%

 S ^XTMP("PRCP185P","END REINDEX")=RMEND

 K %,RMSTART,RMEND,PRCIEN,PRCABRV,DA,PRCPR0

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCP185P   1024     printed  Apr 09, 2024@21:07:08                                                                                                                                                                                                    Page 2

PRCP185P  ;RB-PRE INSTALL PRC*185 TO RE-INDEX FILE 445, FIELD .8 ;4-26-94/3:45 PM

V         ;;5.1;IFCAP;**185**;Oct 20, 2000;Build 3

 +1       ;Per VHA Directive 2004-038, this routine should not be modified.

 +2        QUIT 

START     ;PRC*5.1*185 Process to re-index file 445, field .8 [ABBREVIATED NAME]

 +1       ;            due to adding new CROSS REFERENCE ('CAB') to field.

 +2       ;

 +3        KILL ^XTMP("PRCP185P")

 +4        DO NOW^%DTC

           SET RMSTART=%

 +5        SET ^XTMP("PRCP185P","START COMPILE")=RMSTART

 +6        SET ^XTMP("PRCP185P","END COMPILE")="RUNNING"

 +7        SET ^XTMP("PRCP185P",0)=$$FMADD^XLFDT(RMSTART,180)_"^"_RMSTART

 +8        SET PRCIEN=0

BB         FOR 

               SET PRCIEN=$ORDER(^PRCP(445,PRCIEN))

               if 'PRCIEN

                   QUIT 

               Begin DoDot:1

 +1                if '$DATA(^PRCP(445,PRCIEN,0))

                       QUIT 

                   SET DA=PRCIEN

 +2                SET PRCPR0=^PRCP(445,PRCIEN,0)

                   SET PRCABRV=$PIECE(PRCPR0,"^",5)

                   if PRCABRV=""

                       QUIT 

 +3                SET ^XTMP("PRCP185P",DA,PRCABRV)=""

                   KILL DIC

 +4                SET DIK="^PRCP(445,"

                   SET DIK(1)=".8^2"

                   DO EN^DIK

                   KILL DIK

 +5                SET ^XTMP("PRCP185P",DA,PRCABRV,"CAB")=$SELECT('$DATA(^PRCP(445,"CAB",PRCABRV,DA)):0,1:1)

               End DoDot:1

 +6        DO NOW^%DTC

           SET RMEND=%

 +7        SET ^XTMP("PRCP185P","END REINDEX")=RMEND

 +8        KILL %,RMSTART,RMEND,PRCIEN,PRCABRV,DA,PRCPR0

 +9        QUIT