DG53357T ; ALB/GRR - POST INIT TO REMOVE INSTITUTION NAME FOR PROTOCOLS ; 10-14-99
;;5.3;Registration;**357**;Aug 13, 1993
;
EN ;
W @IOF,"Post Init routine started"
N DGPROT,DGPIEN,DGPNAME,DGNEWN
;
S DGPROT="DGRU-"
F S DGPROT=$O(^ORD(101,"B",DGPROT)) Q:$E(DGPROT,1,5)'="DGRU-" D
.I $E(DGPROT,1,8)'="DGRU-RAI"&($E(DGPROT,1,12)'="DGRU-PATIENT") Q ;not an RAI/MDS protocol
.I DGPROT["ROUTER"!(DGPROT["SERVER") Q ;don't rename router and server protocols
.S DGPIEN=$O(^ORD(101,"B",DGPROT,0)) ;get ien of protocol
.S DGPNAME=$$GET1^DIQ(101,DGPIEN,.01,"I") ;get current protocol name
.S DGPAPP=$$GET1^DIQ(101,DGPIEN,770.2,"I") ;get ien of receiving application
.S DGNEWN=$P(DGPNAME,"-",1,3)_"-"_DGPAPP
.S FDA(1,101,DGPIEN_",",.01)=DGNEWN
.D FILE^DIE("","FDA(1)")
W !,"Post init routine completed",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53357T 836 printed Nov 22, 2024@17:47:14 Page 2
DG53357T ; ALB/GRR - POST INIT TO REMOVE INSTITUTION NAME FOR PROTOCOLS ; 10-14-99
+1 ;;5.3;Registration;**357**;Aug 13, 1993
+2 ;
EN ;
+1 WRITE @IOF,"Post Init routine started"
+2 NEW DGPROT,DGPIEN,DGPNAME,DGNEWN
+3 ;
+4 SET DGPROT="DGRU-"
+5 FOR
SET DGPROT=$ORDER(^ORD(101,"B",DGPROT))
if $EXTRACT(DGPROT,1,5)'="DGRU-"
QUIT
Begin DoDot:1
+6 ;not an RAI/MDS protocol
IF $EXTRACT(DGPROT,1,8)'="DGRU-RAI"&($EXTRACT(DGPROT,1,12)'="DGRU-PATIENT")
QUIT
+7 ;don't rename router and server protocols
IF DGPROT["ROUTER"!(DGPROT["SERVER")
QUIT
+8 ;get ien of protocol
SET DGPIEN=$ORDER(^ORD(101,"B",DGPROT,0))
+9 ;get current protocol name
SET DGPNAME=$$GET1^DIQ(101,DGPIEN,.01,"I")
+10 ;get ien of receiving application
SET DGPAPP=$$GET1^DIQ(101,DGPIEN,770.2,"I")
+11 SET DGNEWN=$PIECE(DGPNAME,"-",1,3)_"-"_DGPAPP
+12 SET FDA(1,101,DGPIEN_",",.01)=DGNEWN
+13 DO FILE^DIE("","FDA(1)")
End DoDot:1
+14 WRITE !,"Post init routine completed",!
+15 QUIT
