20 lines
986 B
Mathematica
20 lines
986 B
Mathematica
LRCAPV1A ;SLC/FHS - SET NEW WKLD CODE INTO ^LAM
|
|
;;5.2;LAB SERVICE;**105,127,163**;Sep 27, 1994
|
|
SET ;from LRCAPV1
|
|
S LRCDEF0X="" I LRCDEF0(1) S LRCDEF0X=LRCDEF0 S:'$D(^LAM(LRP,0))#2 LRNOCODE=1 Q:LRNOCODE S LRCDEF0=^(0)
|
|
S LRCODEN=$P(LRCODE,".")_"."_LRCDEF,LRPN=$O(^LAM("C",LRCODEN_" ",0)) G:LRPN<1 DICN S LRP=LRPN
|
|
I LRCDEF0(1) S LRCDEF0=LRCDEF0X
|
|
Q
|
|
DICN N DIC,DR,DD,DIE
|
|
Q:'$D(^LAM(LRP,0))#2
|
|
S X=$E($P(^LAM(LRP,0),U)_"~"_$S('LRCDEF0(1):$P(LRCDEF0,U),1:$P(LRCDEF0X,U)),1,60),DIC(0)="L",DLAYGO=64,DIC="^LAM(" D FILE^DICN
|
|
S LRCY=Y,LRSTR=^LAM(LRP,0),$P(LRSTR,U)=$P(LRCY,U,2),$P(LRSTR,U,2)=LRCODEN
|
|
S $P(LRSTR,U,14)=$S($P($G(LRCDEF0),U,14):$P($G(LRCDEF0),U,14),1:1)
|
|
I $P($P(LRSTR,U,2),".")=82410 S $P(LRSTR,U,11)=""
|
|
I $P($P(LRSTR,U,2),".")'=82410 S $P(LRSTR,U,3)=""
|
|
S ^LAM(+LRCY,0)=LRSTR,^LAM("C",LRCODEN_" ",+LRCY)="",^LAM("E",LRCODEN,+LRCY)="",(DA,LRP)=+LRCY
|
|
I $G(LRCAPSET) K DR S DR="4;7;8;9;13;14;15;21;19",DIE=DIC D ^DIE
|
|
K DLAYGO,LRCY,LRSTR
|
|
I LRCDEF0(1) S LRCDEF0=LRCDEF0X
|
|
Q
|