Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRWU5

LRWU5.m

Go to the documentation of this file. 
  1. LRWU5 ;SLC/RWF/BA - ADD A NEW DATA NAME TO FILE 63 ; Sep 14, 2021@10:02
  1.  ;;5.2;LAB SERVICE;**140,171,177,206,316,519,552,558**;Sep 27, 1994;Build 4
  1.  ;
  1.  ; Reference to ^DD(63.04 supported by DBIA #7053
  1.  ; Reference to ^XMB(1 supported by DBIA #10091
  1.  ; Reference to ^XUSEC supported by DBIA #10076
  1.  ;
  1. ACCESS ;
  1.  I '$D(^XUSEC("LRLIASON",DUZ)) W $C(7),!,"You do not have access to this option" Q
  1. BEGIN ;
  1.  N LRMOD
  1.  S U="^",LREND=0,DTIME=$S($D(DTIME):DTIME,1:300),LRMOD=0
  1.  W !!,"This option will add a new data name to the lab package." D DT^LRX,TEST
  1. END ;
  1.  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
  1.  I $G(DA)]"" L -^DD(63.04,DA)
  1.  Q
  1. TEST ;
  1.  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)
  1.  Q:LREND=1
  1.  I 'DA Q:'$T!(X[U)!'$L(X)
  1.  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 '^'"
  1.  I X=""!(X[U) Q
  1.  ;VMP OIFO BAY PINES;VGF;LR*5.2*316; H 5 IF ERROR
  1.  S Q1=X D @$S(Q1="N":"NUM",Q1="S":"CODES",1:"FREE") I 'LROK W !,"Nothing has been added." H 5 Q
  1.  ;
  1.  S $P(^DD(63.04,0),U,4)=$P(^DD(63.04,0),U,4)+1
  1.  S DIK="^DD(63.04,",DA(1)=63.04 D IX1^DIK
  1.  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."
  1.  Q
  1. CHECK ;
  1.  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
  1.  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
  1.  ;checking "B" cross reference since non-locking in FileMan
  1.  ;could create data corruption - LR*5.2*519
  1.  I $D(^DD(63.04,"B",LRNAME)) D  Q
  1.  . S LROK=0
  1.  . W $C(7),!,"This data name exists in the ^DD(63.04,""B"" cross reference only."
  1.  . W !,"Enter a support ticket if assistance is needed to correct this file."
  1.  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))
  1.  ;
  1. LOCK ;
  1.  ;adding lock - LR*5.2*519
  1.  ;not attempting to determine the next IEN by checking the
  1.  ;zero node because last ien pointer appears to be inaccurate
  1.  ;in several environments
  1.  ;
  1.  W !!,"Please wait a maximum of "_$G(DILOCKTM,5)_" seconds while it is"
  1.  W !,"determined whether internal entry number "_DA_" is available....."
  1.  L +^DD(63.04,DA):$G(DILOCKTM,5)
  1.  I '$T D  G:'$G(DUOUT)&'$G(DTOUT) LOCK I $G(DUOUT)!($G(DTOUT)) S LREND=1
  1.  . W !!,"Someone else is defining this internal entry number."
  1.  . W !,"Trying again to find a new internal entry number."
  1.  . F I=0:0 S DA=DA+1 Q:'$D(^DD(63.04,DA))
  1.  . ;giving the user a chance to exit gracefully in case the process
  1.  . ;of trying to find a new IEN ends up in an endless loop due to too 
  1.  . ;many users defining new entries.
  1.  . W !
  1.  . S DIR(0)="E",DIR("A")="Press ENTER to continue or ^ to exit" D ^DIR
  1.  Q:LREND
  1.  W !!,"Internal entry number "_DA_" is available.",!!
  1.  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."
  1.  I %'=1 S LROK=0 Q
  1.  Q
  1. SITE ;
  1.  W !,"Your site number is not defined, indicating that fileman was not ",!,"installed correctly.  Contact your site manager!"
  1.  S LROK=0,LREND=1 Q
  1. NUM ;
  1.  ;
  1. DECIMAL ;LR*5.2*558: decimal query moved to be ask first so that
  1.  ;the number of decimal places can be used for the Minimum value
  1.  ;and Maximum value queries
  1.  ;LR*5.2*552: require numeric entries - not free text
  1.  ;            also corrected typos in variables DTOUT and DUOUT
  1.  K DTOUT,DUOUT
  1.  N DIR,Y
  1.  ;Prior to LR*5.2*552, DIR(0) was set as "F".
  1.  S DIR(0)="N"
  1.  S DIR("A")="Decimal value"
  1.  S DIR("B")=1
  1.  S DIR("?")="The number of decimal places this result will need"
  1.  D ^DIR
  1.  I $D(DUOUT)!($D(DTOUT))!(Y<0) S LROK=0 QUIT
  1.  S Q5=Y
  1.  ;
  1. MIN ;
  1.  K DTOUT,DUOUT
  1.  ;LR*5.2*552: Require numeric entries - not free text
  1.  ;            Some latitude is given for "<" and ">" since sites might be
  1.  ;            defining such values in combination with other configuration logic.
  1.  N LRPREFIX,LRLOW,DIR,Y
  1.  ;Prior to LR*5.2*552, DIR(0) was set as "F".
  1.  ;LR*5.2*558: use Q5 to determine the allowable decimal places for Minimum value
  1.  S DIR(0)="N^0::"_Q5
  1.  ;Allow for prefix of < or > which are sometimes used at sites.
  1.  ;Prefix of > doesn't make sense for a minimum value but allowing since maybe it is valid in this case.
  1.  ;Also preserve negative indicator since this DIR call does not allow negative numbers.
  1.  S DIR("PRE")="S LRPREFIX="""" I '$D(DTOUT),'$D(DUOUT),X'[""^"",$E(X)'?1N.N S LRPREFIX=$E(X) I ""-<>""[LRPREFIX S X=$E(X,2,99)"
  1.  S DIR("A")="Minimum value"
  1.  ;S DIR("B")=1
  1.  S DIR("?")="The smallest result value"
  1.  D ^DIR
  1.  I $D(DUOUT)!($D(DTOUT)) S LROK=0 QUIT
  1.  S (Q3,LRLOW)=Y
  1.  I LRPREFIX]"",LRPREFIX'="." S Q3=LRPREFIX_Q3
  1.  ;If prefix is "-", reflect LRLOW as a negative number.
  1.  I LRPREFIX="-" S LRLOW=Q3
  1. MAX ;
  1.  K DTOUT,DUOUT
  1.  ;LR*5.2*552: require numeric entries - not free text
  1.  ;            Some latitude is given for "<" and ">" since sites might be
  1.  ;            defining such values in combination with other configuration logic.
  1.  N LRPREFIX,LRHIGH,LRVALHIT,DIR,Y
  1.  S LRVALHIT=1
  1.  ;Prior to LR*5.2*552, DIR(0) was set as "F".
  1.  ;LR*5.2*558: use Q5 to determine the allowable decimal places for Maximim value
  1.  S DIR(0)="N^0::"_Q5
  1.  ;Allow for prefix of < or > which are sometimes used at sites.
  1.  ;Prefix of < doesn't make sense for a maximum value but allowing since maybe it is valid in this case.
  1.  ;Also preserve negative indicator since this DIR call does not allow negative numbers.
  1.  S DIR("PRE")="S LRPREFIX="""" I '$D(DTOUT),'$D(DUOUT),X'[""^"",$E(X)'?1N.N S LRPREFIX=$E(X) I ""-<>""[LRPREFIX S X=$E(X,2,99)"
  1.  S DIR("A")="Maximum value"
  1.  ;LR*5.2*552: Not sure why a default of 1 is given since the DIR("B") setting was
  1.  ;            commented out for the MIN value by a previous patch. Validating to 
  1.  ;            only default if "1" is greater than the minimum value or the minimum
  1.  ;            is prefixed with "<" or ">".
  1.  I LRLOW'>1!("<>"[$E(Q3)) S DIR("B")=1
  1.  S DIR("?")="The maximum result THIS TEST will ever be"
  1.  D ^DIR
  1.  I $D(DUOUT)!($D(DTOUT))!(Y<0) S LROK=0 QUIT
  1.  S (Q4,LRHIGH)=Y
  1.  I LRPREFIX]"",LRPREFIX'="." S Q4=LRPREFIX_Q4
  1.  I LRPREFIX="-" S LRHIGH=Q4
  1.  I LRLOW'<LRHIGH D  I 'LRVALHIT G MIN
  1.  . ;For some tests with accompanying configurations, this might be the
  1.  . ;desired minimum and maximum values - not requiring minimum entry to
  1.  . ;be less than maximum entry just in case.
  1.  . N DIR,Y
  1.  . S DIR("A",1)="The minimum value is not less than the maximum value."
  1.  . S DIR("A")="Are you sure these entries are correct"
  1.  . S DIR("B")="NO",DIR(0)="Y"
  1.  . D ^DIR
  1.  . S LRVALHIT=+Y
  1.  ;
  1.  D NAME
  1.  Q:'LROK
  1.  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
  1.  Q
  1. CODES ;
  1.  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
  1.  I '$L(Q2) S LROK=0 Q
  1.  D NAME
  1.  Q:'LROK
  1.  S ^DD(63.04,DA,0)=LRNAME_"^S^"_Q2_"^"_DA_";1^Q",^(3)="",^("DT")=DT
  1.  Q
  1. CHK1 I X[U!'$T!'$L(X) S LROK1=0 Q
  1.  ;VMP OIFO BAY PINES;VGF;LR*5.2*316
  1.  I X[";"!(X[":") W !,": and ; not allowed ",$C(7) S Q3="",LROK1=0 Q
  1.  S Q3=X
  1.  Q
  1. CHK2 I X[U!'$T!'$L(X) S LROK1=0 Q
  1.  ;VMP OIFO BAY PINES;VGF;LR*5.2*316
  1.  I X[";"!(X[":") W !,": and ; not allowed ",$C(7) S Q2="",LROK1=0 Q
  1.  S Q4=X,Q2=Q2_Q3_":"_Q4_";" I $L(Q2)+$L(LRNAME)+9>245 W !,"Too many codes* ",$C(7) S Q2="",LROK1=0
  1.  Q
  1. FREE ;
  1.  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"
  1.  I X[U!'$T S LROK=0 Q
  1.  S Q3=X
  1.  ;---LR*5.2*140 Changed max length from 80 to 50
  1.  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"
  1.  I X[U!'$T S LROK=0 Q
  1.  S Q4=X
  1.  D NAME
  1.  Q:'LROK
  1.  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
  1.  Q
  1.  ;
  1. NAME ;check before filing to make sure a user on another session
  1.  ;isn't filing the same name under a different IEN
  1.  ;Variable LRMOD is passed as 1 from LRWU6 from the option
  1.  ;"Modify an Existing Data Name"
  1.  ;
  1.  I $D(^DD(63.04,"B",LRNAME)),'$G(LRMOD) D
  1.  . S LROK=0
  1.  . W !,"This data name has already been added by someone else"
  1.  . W !,"in another session after you selected the data name."
  1.  . W !,"Nothing is being saved from your session since the data name is now on file."
  1.  Q