LRCAPV1A.m

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 ---LRCAPV1A   1005     printed  Apr 09, 2024@21:06:15                                                                                                                                                                                                    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