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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPV1A 1005 printed Dec 13, 2024@02:13:28 Page 2
LRCAPV1A ;SLC/FHS - SET NEW WKLD CODE INTO ^LAM
+1 ;;5.2;LAB SERVICE;**105,127,163**;Sep 27, 1994
SET ;from LRCAPV1
+1 SET LRCDEF0X=""
IF LRCDEF0(1)
SET LRCDEF0X=LRCDEF0
if '$DATA(^LAM(LRP,0))#2
SET LRNOCODE=1
if LRNOCODE
QUIT
SET LRCDEF0=^(0)
+2 SET LRCODEN=$PIECE(LRCODE,".")_"."_LRCDEF
SET LRPN=$ORDER(^LAM("C",LRCODEN_" ",0))
if LRPN<1
GOTO DICN
SET LRP=LRPN
+3 IF LRCDEF0(1)
SET LRCDEF0=LRCDEF0X
+4 QUIT
DICN NEW DIC,DR,DD,DIE
+1 if '$DATA(^LAM(LRP,0))#2
QUIT
+2 SET X=$EXTRACT($PIECE(^LAM(LRP,0),U)_"~"_$SELECT('LRCDEF0(1):$PIECE(LRCDEF0,U),1:$PIECE(LRCDEF0X,U)),1,60)
SET DIC(0)="L"
SET DLAYGO=64
SET DIC="^LAM("
DO FILE^DICN
+3 SET LRCY=Y
SET LRSTR=^LAM(LRP,0)
SET $PIECE(LRSTR,U)=$PIECE(LRCY,U,2)
SET $PIECE(LRSTR,U,2)=LRCODEN
+4 SET $PIECE(LRSTR,U,14)=$SELECT($PIECE($GET(LRCDEF0),U,14):$PIECE($GET(LRCDEF0),U,14),1:1)
+5 IF $PIECE($PIECE(LRSTR,U,2),".")=82410
SET $PIECE(LRSTR,U,11)=""
+6 IF $PIECE($PIECE(LRSTR,U,2),".")'=82410
SET $PIECE(LRSTR,U,3)=""
+7 SET ^LAM(+LRCY,0)=LRSTR
SET ^LAM("C",LRCODEN_" ",+LRCY)=""
SET ^LAM("E",LRCODEN,+LRCY)=""
SET (DA,LRP)=+LRCY
+8 IF $GET(LRCAPSET)
KILL DR
SET DR="4;7;8;9;13;14;15;21;19"
SET DIE=DIC
DO ^DIE
+9 KILL DLAYGO,LRCY,LRSTR
+10 IF LRCDEF0(1)
SET LRCDEF0=LRCDEF0X
+11 QUIT
