LRCAPV11.m

LRCAPV11 ; IHS/DIR/FJE - CREAT NEW WKLD CODES ADDED BY THE SITE ;

 ;;5.2;LR;;NOV 01, 1997

 ;

 ;;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

LRCAPV11  ; IHS/DIR/FJE - CREAT NEW WKLD CODES ADDED BY THE SITE ;

 +1       ;;5.2;LR;;NOV 01, 1997

 +2       ;

 +3       ;;5.2;LAB SERVICE;;Sep 27, 1994

 +4        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