GMRCPREF ;SLC/DCM - Setup package/procedure protocols ;5/20/98 14:20
;;3.0;CONSULT/REQUEST TRACKING;**1**;DEC 27, 1997
A ;Setup package and procedure
K ORDR I $D(ORDA),ORDA,$D(^ORD(101,ORDA)),$P(^(ORDA,0),"^",12)=ORPKG S ORIN=ORDA,ORNAME=$P(^(0),"^") G A1
S X=$S($D(ORDANM):ORDANM,1:$$GET1^DIQ(9.4,+ORPKG_",",1)_+ORFL_" "_X),X=$E(X,1,63)
I $D(^ORD(101,"B",X)) S Y=$O(^(X,0)),ORNAME=X,ORDR="" I $D(^ORD(101,Y,0)) W !,X_" PROTOCOL Updated",! S:ORTXT'=$P(^(0),"^",2) ORDR="1///"_ORTXT
I '$D(^ORD(101,"B",X)) S ORNAME=X,DIC(0)="XZL",(DLAYGO,DIC)=101 D ^DIC S:Y'<1 ORNAME=$P(Y,"^",2) W:Y>0 !,ORNAME_" PROTOCOL Created" I Y<1 W $C(7),!,"Unable to create "_ORNAME_" as an entry in the PROTOCOL file." Q
;
A1 ;Entry point given a protocol ien
S:'$D(ORIN) ORIN=+Y I '$D(ORDA) S %X="^ORD(101,"_ORDEF_",",%Y="^ORD(101,"_+Y_"," D %XY^%RCR S:ORTXT=$P(^ORD(101,+Y,0),"^",2) ORDR="" S $P(^ORD(101,+Y,0),"^",1)=ORNAME
I $D(OREA),$L(OREA) S ^ORD(101,ORIN,20)=OREA
S:'$D(ORDR) ORDR=".01////"_$S($D(ORDANM):ORDANM,1:ORNAME)_$S($D(ORTXT):";1////"_ORTXT,1:"") S:$D(ORFL) ORDR=ORDR_";6////^S X=ORFL" I $L(ORDR) S DR=ORDR,DA=ORIN,DIE="^ORD(101," D ^DIE
Q
;
EN3 ;On the fly protocol setup
Q:'$D(ORPKG)!('$D(ORDEF))!('$D(ORFL)) Q:'ORPKG!('ORDEF)
Q:'$D(^ORD(101,ORDEF,0))
Q:'$L($$GET1^DIQ(9.4,+ORPKG_",",.01))
I ORFL Q:'$D(@("^"_$P(ORFL,";",2)_+ORFL_",0)")) S:'$D(ORTXT) ORTXT=$P(^(0),"^")
Q:'$D(ORTXT) S X=ORTXT D A
K ORDA,ORDANM,ORDEF,ORDR,OREA,ORIN,ORNAME,ORTXT,ORIN,%X,%Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCPREF 1496 printed Sep 23, 2025@19:22:51 Page 2
GMRCPREF ;SLC/DCM - Setup package/procedure protocols ;5/20/98 14:20
+1 ;;3.0;CONSULT/REQUEST TRACKING;**1**;DEC 27, 1997
A ;Setup package and procedure
+1 KILL ORDR
IF $DATA(ORDA)
IF ORDA
IF $DATA(^ORD(101,ORDA))
IF $PIECE(^(ORDA,0),"^",12)=ORPKG
SET ORIN=ORDA
SET ORNAME=$PIECE(^(0),"^")
GOTO A1
+2 SET X=$SELECT($DATA(ORDANM):ORDANM,1:$$GET1^DIQ(9.4,+ORPKG_",",1)_+ORFL_" "_X)
SET X=$EXTRACT(X,1,63)
+3 IF $DATA(^ORD(101,"B",X))
SET Y=$ORDER(^(X,0))
SET ORNAME=X
SET ORDR=""
IF $DATA(^ORD(101,Y,0))
WRITE !,X_" PROTOCOL Updated",!
if ORTXT'=$PIECE(^(0),"^",2)
SET ORDR="1///"_ORTXT
+4 IF '$DATA(^ORD(101,"B",X))
SET ORNAME=X
SET DIC(0)="XZL"
SET (DLAYGO,DIC)=101
DO ^DIC
if Y'<1
SET ORNAME=$PIECE(Y,"^",2)
if Y>0
WRITE !,ORNAME_" PROTOCOL Created"
IF Y<1
WRITE $CHAR(7),!,"Unable to create "_ORNAME_" as an entry in the PROTOCOL file."
QUIT
+5 ;
A1 ;Entry point given a protocol ien
+1 if '$DATA(ORIN)
SET ORIN=+Y
IF '$DATA(ORDA)
SET %X="^ORD(101,"_ORDEF_","
SET %Y="^ORD(101,"_+Y_","
DO %XY^%RCR
if ORTXT=$PIECE(^ORD(101,+Y,0),"^",2)
SET ORDR=""
SET $PIECE(^ORD(101,+Y,0),"^",1)=ORNAME
+2 IF $DATA(OREA)
IF $LENGTH(OREA)
SET ^ORD(101,ORIN,20)=OREA
+3 if '$DATA(ORDR)
SET ORDR=".01////"_$SELECT($DATA(ORDANM):ORDANM,1:ORNAME)_$SELECT($DATA(ORTXT):";1////"_ORTXT,1:"")
if $DATA(ORFL)
SET ORDR=ORDR_";6////^S X=ORFL"
IF $LENGTH(ORDR)
SET DR=ORDR
SET DA=ORIN
SET DIE="^ORD(101,"
DO ^DIE
+4 QUIT
+5 ;
EN3 ;On the fly protocol setup
+1 if '$DATA(ORPKG)!('$DATA(ORDEF))!('$DATA(ORFL))
QUIT
if 'ORPKG!('ORDEF)
QUIT
+2 if '$DATA(^ORD(101,ORDEF,0))
QUIT
+3 if '$LENGTH($$GET1^DIQ(9.4,+ORPKG_",",.01))
QUIT
+4 IF ORFL
if '$DATA(@("^"_$PIECE(ORFL,";",2)_+ORFL_",0)"))
QUIT
if '$DATA(ORTXT)
SET ORTXT=$PIECE(^(0),"^")
+5 if '$DATA(ORTXT)
QUIT
SET X=ORTXT
DO A
+6 KILL ORDA,ORDANM,ORDEF,ORDR,OREA,ORIN,ORNAME,ORTXT,ORIN,%X,%Y
+7 QUIT
