- 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 ---[H[J[2J[HDG53178P 565 printed Jan 18, 2025@03:37:10 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