LRWU5.m

LRWU5 ;SLC/RWF/BA - ADD A NEW DATA NAME TO FILE 63 ; 22-Oct-2013 09:22 ; MKK

 ;;5.2;LAB SERVICE;**140,171,177,206,316,1027,1032,1033**;NOV 01, 1997

 ;

 ; Reference to ^DD supported by DBIA #29

 ; Reference to ^XMB(1 supported by DBIA #10091

 ; Reference to ^XUSEC supported by DBIA #10076

 ;

ACCESS ;

 I '$D(^XUSEC("LRLIASON",DUZ)) W $C(7),!,"You do not have access to this option" Q

BEGIN ;

 S U="^",LREND=0,DTIME=$S($D(DTIME):DTIME,1:300) W !!,"This option will add a new data name to the lab package." D DT^LRX,TEST

END ;

 K %,DA,DIC,DIK,DIR,I,LRDEC,LREND,LRI,LRLO,LMX,LRMIN,LRNAME,LROK,LRPIECE,LRSET,LRTYPE,LROK1,Q1,Q2,Q3,Q4,Q5,X,Y

 Q

TEST ;

 F I=0:0 S LROK=1,DA=0 R !,"DATA NAME: ",X:DTIME Q:'$T!(X[U)!'$L(X)  S:X["?" X="=" D CHECK Q:LROK!(LREND)

 Q:LREND=1

 I 'DA Q:'$T!(X[U)!'$L(X)

 F I=0:0 R !,"Enter data type for test: (N)umeric, (S)et of Codes, or (F)ree text? ",X:DTIME Q:X[U!(X="")!(X="N")!(X="S")!(X="F")  W !,"Enter 'N', 'S', 'F', or '^'"

 I X=""!(X[U) Q

 ;VMP OIFO BAY PINES;VGF;LR*5.2*316; H 5 IF ERROR

 S Q1=X D @$S(Q1="N":"NUM",Q1="S":"CODES",1:"FREE") I 'LROK W !,"Nothing has been added." H 5 Q

 S $P(^DD(63.04,0),U,4)=$P(^DD(63.04,0),U,4)+1

 S DIK="^DD(63.04,",DA(1)=63.04 D IX1^DIK

 W !!,"'",LRNAME,"' added as a new data name" D DISPLAY^LRWU6 W !!,"You must now add a new test in the LABORATORY TEST file and use",!,LRNAME," as the entry for the DATA NAME field."

 Q

CHECK ;

 X $P(^DD(0,.01,0),U,5) I '$D(X) W $C(7)," ??",!,"ANSWER MUST BE 2-30 CHARACTERS AND NOT CONTAIN '='" S LROK=0 Q

 Q:$$IHSDNBAD(X)   ; IHS/MSC/MKK - LR*5.2*1032

 S LRNAME=X,DIC="^DD(63.04,",DIC(0)="XM" D ^DIC I Y>0 W $C(7),!,"This data name already exists" S LROK=0 Q

 S DA=$S($P($G(^XMB(1,1,"XUS")),U,17):$P(^("XUS"),U,17),1:0)*1000 D:'DA SITE Q:'LROK  F I=0:0 S DA=DA+1 Q:'$D(^DD(63.04,DA))

 F I=0:0 W !,"ARE YOU ADDING ",LRNAME," (SUBFIELD # ",DA,") AS A NEW DATA NAME" S %=2 D YN^DICN Q:%  W " Answer 'Y'es or 'N'o."

 I %'=1 S LROK=0 Q

 Q

 ;

 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1032

IHSDNBAD(DNSTR) ; EP - Check to make sure new DataName only contains valid characters

 NEW BADCHAR,CHAR,I,OKAY

 ;

 S OKAY=1,BADCHAR=""

 F I=1:1:$L(DNSTR) D

 . S CHAR=$E(DNSTR,I)

 . ; Q:CHAR?1N!(CHAR?1A)!(CHAR=" ")!(CHAR="_")     ; Only Numeric, Alphabetic, Space, and Underline Characters allowed

 . Q:CHAR?1N!(CHAR?1A)!(CHAR=" ")!(CHAR="_")!(CHAR="(")!(CHAR=")")     ; Only Numeric, Alphabetic, Space, Underline, (, and ) Characters allowed -- IHS/MSC/MKK - LR*5.2*1033

 . S OKAY=0

 . S BADCHAR=BADCHAR_CHAR

 ;

 Q:OKAY 0

 ;

 W $C(7)," ??",!,"ANSWER MUST BE 2-30 CHARACTERS AND NOT CONTAIN '",BADCHAR,"'"

 S LROK=0

 Q 1

 ; ----- END IHS/MSC/MKK - LR*5.2*1032

 ;

SITE ;

 W !,"Your site number is not defined, indicating that fileman was not ",!,"installed correctly.  Contact your site manager!"

 S LROK=0,LREND=1 Q

NUM ;

 ;

MIN ;

 K DTOUT,DUOUT

 S DIR(0)="F"

 S DIR("A")="Minimum value: "

 ;S DIR("B")=1

 S DIR("?")="The smallest result value: "

 D ^DIR

 I $D(DUOUT)!($D(DTOUT)) S LROK=0 QUIT

 S Q3=Y

MAX ;

 K DTOUT,DUOUT

 S DIR(0)="F"

 S DIR("A")="Maximum value: "

 S DIR("B")=1

 S DIR("?")="The maximum result THIS TEST will ever be: "

 D ^DIR

 I $D(DUOUT)!($D(DTOUT))!(Y<0) S LROK=0 QUIT

 S Q4=Y

DECIMAL ;

 K DTDOUT,DUTOU

 S DIR(0)="F"

 S DIR("A")="Decimal value: "

 S DIR("B")=1

 S DIR("?")="The number of decimal places this result will need: "

 D ^DIR

 I $D(DUOUT)!($D(DTOUT))!(Y<0) S LROK=0 QUIT

 S Q5=Y

 ;

 S ^DD(63.04,DA,0)=LRNAME_"^NXJ"_($L(Q4)+Q5+$S(Q5:1,1:0))_","_Q5_"^^"_DA_";1^"_"S Q9="""_Q3_","_Q4_","_Q5_""" D ^LRNUM",^(3)="TYPE A "_$S(Q5:"",1:"WHOLE ")_"NUMBER BETWEEN "_Q3_" AND "_Q4,^("DT")=DT

 Q

CODES ;

 S Q2="",LROK1=1 F I=0:0 R !,"INTERNALLY-STORED CODE: // ",X:DTIME D CHK1 Q:'LROK1  R "   WILL STAND FOR: // ",X:DTIME D CHK2 Q:'LROK1

 I '$L(Q2) S LROK=0 Q

 S ^DD(63.04,DA,0)=LRNAME_"^S^"_Q2_"^"_DA_";1^Q",^(3)="",^("DT")=DT

 Q

CHK1 I X[U!'$T!'$L(X) S LROK1=0 Q

 ;VMP OIFO BAY PINES;VGF;LR*5.2*316

 I X[";"!(X[":") W !,": and ; not allowed ",$C(7) S Q3="",LROK1=0 Q

 S Q3=X

 Q

CHK2 I X[U!'$T!'$L(X) S LROK1=0 Q

 ;VMP OIFO BAY PINES;VGF;LR*5.2*316

 I X[";"!(X[":") W !,": and ; not allowed ",$C(7) S Q2="",LROK1=0 Q

 S Q4=X,Q2=Q2_Q3_":"_Q4_";" I $L(Q2)+$L(LRNAME)+9>245 W !,"Too many codes* ",$C(7) S Q2="",LROK1=0

 Q

FREE ;

 F I=0:0 R !,"Minimum length: ",X:DTIME Q:X[U!'$T!(X'<1&(X'>20)&(+X=X))  W " Enter a whole number from 1 to 20"

 I X[U!'$T S LROK=0 Q

 S Q3=X

 ;---LR*5.2*140 Changed max legnth from 80 to 50

 F I=0:0 R !,"Maximum length: ",X:DTIME Q:X[U!'$T!(X'<Q3&(X'>50)&(+X=X))  W " Enter a whole number between ",Q3," to 50"

 I X[U!'$T S LROK=0 Q

 S Q4=X

 S ^DD(63.04,DA,0)=LRNAME_"^F^^"_DA_";1^K:$L(X)>"_Q4_"!($L(X)<"_Q3_") X",^(3)="ANSWER MUST BE "_Q3_"-"_Q4_" CHARACTERS IN LENGTH",^("DT")=DT

 Q

LRWU5     ;SLC/RWF/BA - ADD A NEW DATA NAME TO FILE 63 ; 22-Oct-2013 09:22 ; MKK

 +1       ;;5.2;LAB SERVICE;**140,171,177,206,316,1027,1032,1033**;NOV 01, 1997

 +2       ;

 +3       ; Reference to ^DD supported by DBIA #29

 +4       ; Reference to ^XMB(1 supported by DBIA #10091

 +5       ; Reference to ^XUSEC supported by DBIA #10076

 +6       ;

ACCESS    ;

 +1        IF '$DATA(^XUSEC("LRLIASON",DUZ))

               WRITE $CHAR(7),!,"You do not have access to this option"

               QUIT 

BEGIN     ;

 +1        SET U="^"

           SET LREND=0

           SET DTIME=$SELECT($DATA(DTIME):DTIME,1:300)

           WRITE !!,"This option will add a new data name to the lab package."

           DO DT^LRX

           DO TEST

END       ;

 +1        KILL %,DA,DIC,DIK,DIR,I,LRDEC,LREND,LRI,LRLO,LMX,LRMIN,LRNAME,LROK,LRPIECE,LRSET,LRTYPE,LROK1,Q1,Q2,Q3,Q4,Q5,X,Y

 +2        QUIT 

TEST      ;

 +1        FOR I=0:0

               SET LROK=1

               SET DA=0

               READ !,"DATA NAME: ",X:DTIME

               IF '$TEST!(X[U)!'$LENGTH(X)

                   QUIT 

               IF X["?"

                   SET X="="

               DO CHECK

               IF LROK!(LREND)

                   QUIT 

 +2        IF LREND=1

               QUIT 

 +3        IF 'DA

               IF '$TEST!(X[U)!'$LENGTH(X)

                   QUIT 

 +4        FOR I=0:0

               READ !,"Enter data type for test: (N)umeric, (S)et of Codes, or (F)ree text? ",X:DTIME

               IF X[U!(X="")!(X="N")!(X="S")!(X="F")

                   QUIT 

               WRITE !,"Enter 'N', 'S', 'F', or '^'"

 +5        IF X=""!(X[U)

               QUIT 

 +6       ;VMP OIFO BAY PINES;VGF;LR*5.2*316; H 5 IF ERROR

 +7        SET Q1=X

           DO @$SELECT(Q1="N":"NUM",Q1="S":"CODES",1:"FREE")

           IF 'LROK

               WRITE !,"Nothing has been added."

               HANG 5

               QUIT 

 +8        SET $PIECE(^DD(63.04,0),U,4)=$PIECE(^DD(63.04,0),U,4)+1

 +9        SET DIK="^DD(63.04,"

           SET DA(1)=63.04

           DO IX1^DIK

 +10       WRITE !!,"'",LRNAME,"' added as a new data name"

           DO DISPLAY^LRWU6

           WRITE !!,"You must now add a new test in the LABORATORY TEST file and use",!,LRNAME," as the entry for the DATA NAME field."

 +11       QUIT 

CHECK     ;

 +1        XECUTE $PIECE(^DD(0,.01,0),U,5)

           IF '$DATA(X)

               WRITE $CHAR(7)," ??",!,"ANSWER MUST BE 2-30 CHARACTERS AND NOT CONTAIN '='"

               SET LROK=0

               QUIT 

 +2       ; IHS/MSC/MKK - LR*5.2*1032

           IF $$IHSDNBAD(X)

               QUIT 

 +3        SET LRNAME=X

           SET DIC="^DD(63.04,"

           SET DIC(0)="XM"

           DO ^DIC

           IF Y>0

               WRITE $CHAR(7),!,"This data name already exists"

               SET LROK=0

               QUIT 

 +4        SET DA=$SELECT($PIECE($GET(^XMB(1,1,"XUS")),U,17):$PIECE(^("XUS"),U,17),1:0)*1000

           IF 'DA

               DO SITE

           IF 'LROK

               QUIT 

           FOR I=0:0

               SET DA=DA+1

               IF '$DATA(^DD(63.04,DA))

                   QUIT 

 +5        FOR I=0:0

               WRITE !,"ARE YOU ADDING ",LRNAME," (SUBFIELD # ",DA,") AS A NEW DATA NAME"

               SET %=2

               DO YN^DICN

               IF %

                   QUIT 

               WRITE " Answer 'Y'es or 'N'o."

 +6        IF %'=1

               SET LROK=0

               QUIT 

 +7        QUIT 

 +8       ;

 +9       ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1032

IHSDNBAD(DNSTR) ; EP - Check to make sure new DataName only contains valid characters

 +1        NEW BADCHAR,CHAR,I,OKAY

 +2       ;

 +3        SET OKAY=1

           SET BADCHAR=""

 +4        FOR I=1:1:$LENGTH(DNSTR)

               Begin DoDot:1

 +5                SET CHAR=$EXTRACT(DNSTR,I)

 +6       ; Q:CHAR?1N!(CHAR?1A)!(CHAR=" ")!(CHAR="_")     ; Only Numeric, Alphabetic, Space, and Underline Characters allowed

 +7       ; Only Numeric, Alphabetic, Space, Underline, (, and ) Characters allowed -- IHS/MSC/MKK - LR*5.2*1033

                   IF CHAR?1N!(CHAR?1A)!(CHAR=" ")!(CHAR="_")!(CHAR="(")!(CHAR=")")

                       QUIT 

 +8                SET OKAY=0

 +9                SET BADCHAR=BADCHAR_CHAR

               End DoDot:1

 +10      ;

 +11       IF OKAY

               QUIT 0

 +12      ;

 +13       WRITE $CHAR(7)," ??",!,"ANSWER MUST BE 2-30 CHARACTERS AND NOT CONTAIN '",BADCHAR,"'"

 +14       SET LROK=0

 +15       QUIT 1

 +16      ; ----- END IHS/MSC/MKK - LR*5.2*1032

 +17      ;

SITE      ;

 +1        WRITE !,"Your site number is not defined, indicating that fileman was not ",!,"installed correctly.  Contact your site manager!"

 +2        SET LROK=0

           SET LREND=1

           QUIT 

NUM       ;

 +1       ;

MIN       ;

 +1        KILL DTOUT,DUOUT

 +2        SET DIR(0)="F"

 +3        SET DIR("A")="Minimum value: "

 +4       ;S DIR("B")=1

 +5        SET DIR("?")="The smallest result value: "

 +6        DO ^DIR

 +7        IF $DATA(DUOUT)!($DATA(DTOUT))

               SET LROK=0

               QUIT 

 +8        SET Q3=Y

MAX       ;

 +1        KILL DTOUT,DUOUT

 +2        SET DIR(0)="F"

 +3        SET DIR("A")="Maximum value: "

 +4        SET DIR("B")=1

 +5        SET DIR("?")="The maximum result THIS TEST will ever be: "

 +6        DO ^DIR

 +7        IF $DATA(DUOUT)!($DATA(DTOUT))!(Y<0)

               SET LROK=0

               QUIT 

 +8        SET Q4=Y

DECIMAL   ;

 +1        KILL DTDOUT,DUTOU

 +2        SET DIR(0)="F"

 +3        SET DIR("A")="Decimal value: "

 +4        SET DIR("B")=1

 +5        SET DIR("?")="The number of decimal places this result will need: "

 +6        DO ^DIR

 +7        IF $DATA(DUOUT)!($DATA(DTOUT))!(Y<0)

               SET LROK=0

               QUIT 

 +8        SET Q5=Y

 +9       ;

 +10       SET ^DD(63.04,DA,0)=LRNAME_"^NXJ"_($LENGTH(Q4)+Q5+$SELECT(Q5:1,1:0))_","_Q5_"^^"_DA_";1^"_"S Q9="""_Q3_","_Q4_","_Q5_""" D ^LRNUM"

           SET ^(3)="TYPE A "_$SELECT(Q5:"",1:"WHOLE ")_"NUMBER BETWEEN "_Q3_" AND "_Q4

           SET ^("DT")=DT

 +11       QUIT 

CODES     ;

 +1        SET Q2=""

           SET LROK1=1

           FOR I=0:0

               READ !,"INTERNALLY-STORED CODE: // ",X:DTIME

               DO CHK1

               IF 'LROK1

                   QUIT 

               READ "   WILL STAND FOR: // ",X:DTIME

               DO CHK2

               IF 'LROK1

                   QUIT 

 +2        IF '$LENGTH(Q2)

               SET LROK=0

               QUIT 

 +3        SET ^DD(63.04,DA,0)=LRNAME_"^S^"_Q2_"^"_DA_";1^Q"

           SET ^(3)=""

           SET ^("DT")=DT

 +4        QUIT 

CHK1       IF X[U!'$TEST!'$LENGTH(X)

               SET LROK1=0

               QUIT 

 +1       ;VMP OIFO BAY PINES;VGF;LR*5.2*316

 +2        IF X[";"!(X[":")

               WRITE !,": and ; not allowed ",$CHAR(7)

               SET Q3=""

               SET LROK1=0

               QUIT 

 +3        SET Q3=X

 +4        QUIT 

CHK2       IF X[U!'$TEST!'$LENGTH(X)

               SET LROK1=0

               QUIT 

 +1       ;VMP OIFO BAY PINES;VGF;LR*5.2*316

 +2        IF X[";"!(X[":")

               WRITE !,": and ; not allowed ",$CHAR(7)

               SET Q2=""

               SET LROK1=0

               QUIT 

 +3        SET Q4=X

           SET Q2=Q2_Q3_":"_Q4_";"

           IF $LENGTH(Q2)+$LENGTH(LRNAME)+9>245

               WRITE !,"Too many codes* ",$CHAR(7)

               SET Q2=""

               SET LROK1=0

 +4        QUIT 

FREE      ;

 +1        FOR I=0:0

               READ !,"Minimum length: ",X:DTIME

               IF X[U!'$TEST!(X'<1&(X'>20)&(+X=X))

                   QUIT 

               WRITE " Enter a whole number from 1 to 20"

 +2        IF X[U!'$TEST

               SET LROK=0

               QUIT 

 +3        SET Q3=X

 +4       ;---LR*5.2*140 Changed max legnth from 80 to 50

 +5        FOR I=0:0

               READ !,"Maximum length: ",X:DTIME

               IF X[U!'$TEST!(X'<Q3&(X'>50)&(+X=X))

                   QUIT 

               WRITE " Enter a whole number between ",Q3," to 50"

 +6        IF X[U!'$TEST

               SET LROK=0

               QUIT 

 +7        SET Q4=X

 +8        SET ^DD(63.04,DA,0)=LRNAME_"^F^^"_DA_";1^K:$L(X)>"_Q4_"!($L(X)<"_Q3_") X"

           SET ^(3)="ANSWER MUST BE "_Q3_"-"_Q4_" CHARACTERS IN LENGTH"

           SET ^("DT")=DT

 +9        QUIT