- LRCAPV11 ;SLC/FHS - CREAT NEW WKLD CODES ADDED BY THE SITE
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- W !!?20,"ADDING A NEW WKLD CODE TO FILE ",!!
- EN ;
- W !! K DIC S (LRCDEF0X,LRCDEF0(1))="",DIC="^LAM(",DIC(0)="AQEZM",LRCAPSET=1
- 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
- W !!?10,"Now enter your Suffix ",!! S DIC="^LAB(64.2," D ^DIC I Y<1 W $C(7),!!?5,"Nothing Selected " G EN
- 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
- S LRCODEN=+LRCODE_LRCDEF D DICN^LRCAPV1A S DA=$O(^LAM("C",LRCODEN_" ",0))
- I DA,$D(^LAM(DA,0))#2 S DIC="^LAM(" W !!,"# ",DA D EN^DIQ W !!,?30," NOW IN FILE ",!! G EN
- I 'DA W !!?5,"Nothing Added to File ",!!,$C(7) G EN
- Q
- END ;
- K DA,DIC,LRCDEF,LRCDEF0,LRCDER0X,LRCODE,LRCODEN,LRCAPSET,LRP,Y,X
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPV11 966 printed Jan 18, 2025@03:14:10 Page 2
- LRCAPV11 ;SLC/FHS - CREAT NEW WKLD CODES ADDED BY THE SITE
- +1 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +2 WRITE !!?20,"ADDING A NEW WKLD CODE TO FILE ",!!
- EN ;
- +1 WRITE !!
- KILL DIC
- SET (LRCDEF0X,LRCDEF0(1))=""
- SET DIC="^LAM("
- SET DIC(0)="AQEZM"
- SET LRCAPSET=1
- +2 DO ^DIC
- if Y<1
- GOTO END
- SET LRP=+Y
- SET LRCODE=$PIECE(Y(0),U,2)
- IF Y(0)["~"!($PIECE(LRCODE,".",2)>0)
- WRITE !!?30,$CHAR(7)," THIS CODE ALREADY HAS A SUFFIX ",!!,$CHAR(7)
- GOTO EN
- +3 WRITE !!?10,"Now enter your Suffix ",!!
- SET DIC="^LAB(64.2,"
- DO ^DIC
- IF Y<1
- WRITE $CHAR(7),!!?5,"Nothing Selected "
- GOTO EN
- +4 SET LRCDEF0=Y(0)
- SET LRCDEF=$PIECE(Y(0),U,2)
- SET DA=$ORDER(^LAM("C",+LRCODE_LRCDEF_" ",0))
- IF DA
- WRITE !!,$CHAR(7),?10," This code ("_+LRCODE_LRCDEF_") Already exist "
- KILL DIC
- SET DIC="^LAM("
- DO EN^DIQ
- WRITE !!
- GOTO EN
- +5 SET LRCODEN=+LRCODE_LRCDEF
- DO DICN^LRCAPV1A
- SET DA=$ORDER(^LAM("C",LRCODEN_" ",0))
- +6 IF DA
- IF $DATA(^LAM(DA,0))#2
- SET DIC="^LAM("
- WRITE !!,"# ",DA
- DO EN^DIQ
- WRITE !!,?30," NOW IN FILE ",!!
- GOTO EN
- +7 IF 'DA
- WRITE !!?5,"Nothing Added to File ",!!,$CHAR(7)
- GOTO EN
- +8 QUIT
- END ;
- +1 KILL DA,DIC,LRCDEF,LRCDEF0,LRCDER0X,LRCODE,LRCODEN,LRCAPSET,LRP,Y,X
- +2 QUIT