- 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 Jan 18, 2025@02:48:02 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