GMRCPREF.m

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

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