DG53178P.m

DG53178P ;ALB/ABR - RESTORE NAME TO ICD (DRG) GLOBAL - AUG 9 1996

 ;;5.3;Registration;**178**;Aug 13, 1993

 ;This routine will restore the .01 name value in file 80.2

 ;

EN ;

 N X,Y,DA,DIK,XPDIDTOT,TEXT,DRG,NODE

 D BMES^XPDUTL(">> Restoring 0-node in DRG file.")

 S DA=0,XPDIDTOT=500

 S DIK="^ICD(",DIK(1)=".01^B"

 F DA=1:1:503 I $D(^ICD(DA)) D

 . S TEXT=DA_"^DG53178"_$S(DA>340:"C",DA>170:"B",1:"A"),NODE=$T(@(TEXT))

 . Q:NODE=""

 . S $P(^ICD(DA,0),U,1,8)=$P(NODE,";;",2)

 . D EN1^DIK

 . I '(DA#50) D UPDATE^XPDID(DA)

 D MES^XPDUTL(">> DONE!")

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DG53178P   565     printed  Apr 09, 2024@21:57:46                                                                                                                                                                                                     Page 2

DG53178P  ;ALB/ABR - RESTORE NAME TO ICD (DRG) GLOBAL - AUG 9 1996

 +1       ;;5.3;Registration;**178**;Aug 13, 1993

 +2       ;This routine will restore the .01 name value in file 80.2

 +3       ;

EN        ;

 +1        NEW X,Y,DA,DIK,XPDIDTOT,TEXT,DRG,NODE

 +2        DO BMES^XPDUTL(">> Restoring 0-node in DRG file.")

 +3        SET DA=0

           SET XPDIDTOT=500

 +4        SET DIK="^ICD("

           SET DIK(1)=".01^B"

 +5        FOR DA=1:1:503

               IF $DATA(^ICD(DA))

                   Begin DoDot:1

 +6                    SET TEXT=DA_"^DG53178"_$SELECT(DA>340:"C",DA>170:"B",1:"A")

                       SET NODE=$TEXT(@(TEXT))

 +7                    if NODE=""

                           QUIT 

 +8                    SET $PIECE(^ICD(DA,0),U,1,8)=$PIECE(NODE,";;",2)

 +9                    DO EN1^DIK

 +10                   IF '(DA#50)

                           DO UPDATE^XPDID(DA)

                   End DoDot:1

 +11       DO MES^XPDUTL(">> DONE!")

 +12       QUIT