| [613] | 1 | LRCAPV11 ;SLC/FHS - CREAT NEW WKLD CODES ADDED BY THE SITE
|
|---|
| 2 | ;;5.2;LAB SERVICE;;Sep 27, 1994
|
|---|
| 3 | W !!?20,"ADDING A NEW WKLD CODE TO FILE ",!!
|
|---|
| 4 | EN ;
|
|---|
| 5 | W !! K DIC S (LRCDEF0X,LRCDEF0(1))="",DIC="^LAM(",DIC(0)="AQEZM",LRCAPSET=1
|
|---|
| 6 | D ^DIC G:Y<1 END S LRP=+Y,LRCODE=$P(Y(0),U,2) I Y(0)["~"!($P(LRCODE,".",2)>0) W !!?30,$C(7)," THIS CODE ALREADY HAS A SUFFIX ",!!,$C(7) G EN
|
|---|
| 7 | W !!?10,"Now enter your Suffix ",!! S DIC="^LAB(64.2," D ^DIC I Y<1 W $C(7),!!?5,"Nothing Selected " G EN
|
|---|
| 8 | S LRCDEF0=Y(0),LRCDEF=$P(Y(0),U,2) S DA=$O(^LAM("C",+LRCODE_LRCDEF_" ",0)) I DA W !!,$C(7),?10," This code ("_+LRCODE_LRCDEF_") Already exist " K DIC S DIC="^LAM(" D EN^DIQ W !! G EN
|
|---|
| 9 | S LRCODEN=+LRCODE_LRCDEF D DICN^LRCAPV1A S DA=$O(^LAM("C",LRCODEN_" ",0))
|
|---|
| 10 | I DA,$D(^LAM(DA,0))#2 S DIC="^LAM(" W !!,"# ",DA D EN^DIQ W !!,?30," NOW IN FILE ",!! G EN
|
|---|
| 11 | I 'DA W !!?5,"Nothing Added to File ",!!,$C(7) G EN
|
|---|
| 12 | Q
|
|---|
| 13 | END ;
|
|---|
| 14 | K DA,DIC,LRCDEF,LRCDEF0,LRCDER0X,LRCODE,LRCODEN,LRCAPSET,LRP,Y,X
|
|---|
| 15 | Q
|
|---|
