source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRCAPV1A.m@ 1389

Last change on this file since 1389 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 986 bytes
RevLine 
[613]1LRCAPV1A ;SLC/FHS - SET NEW WKLD CODE INTO ^LAM
2 ;;5.2;LAB SERVICE;**105,127,163**;Sep 27, 1994
3SET ;from LRCAPV1
4 S LRCDEF0X="" I LRCDEF0(1) S LRCDEF0X=LRCDEF0 S:'$D(^LAM(LRP,0))#2 LRNOCODE=1 Q:LRNOCODE S LRCDEF0=^(0)
5 S LRCODEN=$P(LRCODE,".")_"."_LRCDEF,LRPN=$O(^LAM("C",LRCODEN_" ",0)) G:LRPN<1 DICN S LRP=LRPN
6 I LRCDEF0(1) S LRCDEF0=LRCDEF0X
7 Q
8DICN N DIC,DR,DD,DIE
9 Q:'$D(^LAM(LRP,0))#2
10 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
11 S LRCY=Y,LRSTR=^LAM(LRP,0),$P(LRSTR,U)=$P(LRCY,U,2),$P(LRSTR,U,2)=LRCODEN
12 S $P(LRSTR,U,14)=$S($P($G(LRCDEF0),U,14):$P($G(LRCDEF0),U,14),1:1)
13 I $P($P(LRSTR,U,2),".")=82410 S $P(LRSTR,U,11)=""
14 I $P($P(LRSTR,U,2),".")'=82410 S $P(LRSTR,U,3)=""
15 S ^LAM(+LRCY,0)=LRSTR,^LAM("C",LRCODEN_" ",+LRCY)="",^LAM("E",LRCODEN,+LRCY)="",(DA,LRP)=+LRCY
16 I $G(LRCAPSET) K DR S DR="4;7;8;9;13;14;15;21;19",DIE=DIC D ^DIE
17 K DLAYGO,LRCY,LRSTR
18 I LRCDEF0(1) S LRCDEF0=LRCDEF0X
19 Q
Note: See TracBrowser for help on using the repository browser.