LRNUM ;SLC/BA-NUMERIC INPUT TRANSFORM ;2/6/91 08:55
;;5.2;LAB SERVICE;**153,221,386**;Sep 27, 1994;Build 1
BEGIN Q:X="pending"
S LRLOW=$P(Q9,","),LRHIGH=$P(Q9,",",2),LRDEC=$P(Q9,",",3),Q8="" S:"<>"[$E(X,1) Q8=$E(X,1),X=$E(X,2,99) S Q1=$P(X,"."),Q2=$E($P(X,".",2),1,99) D CHECK
END K LRLOW,LRHIGH,LRDEC,Q1,Q2,Q8,Q9
Q
CHECK I $L(Q1),Q1'="-",Q1'="-0",+Q1'=Q1 K X Q
I $L(Q2),Q2'?1N.N K X Q
I $L(Q2)>LRDEC K X Q
I X>LRHIGH!(X<LRLOW)!($L(X,".")>2)!(X["..")!(X["-"&(+X=0)) K X Q
S X=Q8_X
Q
COM ;expands lab description from LRMISTF1, dd
S LRMIN=$P(Q9,","),LRMAX=$P(Q9,",",2),LRSCN=$P(Q9,",",3) D COMCHK
K LRMIN,LRMAX,LRSCN,Q1,Q2,Q8,Q9
Q
COMCHK I $L(X)>LRMAX!($L(X)<LRMIN)!(X'?.ANP) K X Q
N LRL,LRS,LRZ,LRY
S LRS="" D COMCHK1 Q:'$D(X) I '$D(LRNOECHO) N LRX S LRX=" ("_$E(LRS,1,$L(LRS)-1)_")" D EN^DDIOL(LRX) ; LRNOECHO SET IN LRVR4 TO PREVENT ECHO WHEN STUFFING COMMENTS.
S X=LRS
K LRMAX,LRMIN,LRSCN
Q
COMCHK1 F I=1:1 Q:$P(X," ",I,99)="" S LRZ=$P(X," ",I),Y="" D:LRZ]"" SWITCH S LRL=$L(LRS)+$L(LRZ) S:LRL'>LRMAX LRS=LRS_LRZ_" " I LRL>LRMAX D K X Q
. N LRJ,LRX
. S LRX=" ... TOO LONG ... Expanded text is limited to "_LRMAX_" characters."
. F LRJ=$C(7),LRZ,LRX D EN^DDIOL(LRJ)
S LRS=$TR(LRS,";","-") ; Strip ";" - FileMan uses ";" to parse DR string.
Q
SWITCH Q:$G(LRNOEXPD)
S LRY=0 F S LRY=$O(^LAB(62.5,"B",LRZ,LRY)) Q:LRY<1 I $L($P($G(^LAB(62.5,LRY,0)),U,4)),LRSCN[$P(^(0),U,4) S LRZ=$P(^LAB(62.5,LRY,0),U,2) Q:'$L($G(^(9))) S LRY=$P(X," ",I-1),LRY=$E(LRY,$L(LRY)) S:LRY>1 LRZ=^(9)
Q
PN ;checks for positive or negative entry from LRMISTF1
I "PN"'[X!($L(X)'=1) K X W $C(7),!,"Enter 'N' for NEGATIVE or 'P' for POSITIVE" Q
W " (",$S(X="P":"POSITIVE",1:"NEGATIVE"),")"
Q
AFS ;checks for acid fast stain entry from LRMISTF1
I '(X="DP"!(X="DN")!(X="CP")!(X="CN")) K X W $C(7),!,"Enter 'DP' for DIRECT POSITIVE, 'DN' for DIRECT NEGATIVE,",!,"'CP' for CONCENTRATE POSITIVE, or 'CN' for CONCENTRATE NEGATIVE" Q
W " (",$S(X="DP":"DIRECT POSITIVE",X="DN":"DIRECT NEGATIVE",X="CP":"CONCENTRATE POSITIVE",1:"CONCENTRATE NEGATIVE"),")"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRNUM 2097 printed Apr 09, 2024@21:24:54 Page 2
LRNUM ;SLC/BA-NUMERIC INPUT TRANSFORM ;2/6/91 08:55
+1 ;;5.2;LAB SERVICE;**153,221,386**;Sep 27, 1994;Build 1
BEGIN if X="pending"
QUIT
+1 SET LRLOW=$PIECE(Q9,",")
SET LRHIGH=$PIECE(Q9,",",2)
SET LRDEC=$PIECE(Q9,",",3)
SET Q8=""
if "<>"[$EXTRACT(X,1)
SET Q8=$EXTRACT(X,1)
SET X=$EXTRACT(X,2,99)
SET Q1=$PIECE(X,".")
SET Q2=$EXTRACT($PIECE(X,".",2),1,99)
DO CHECK
END KILL LRLOW,LRHIGH,LRDEC,Q1,Q2,Q8,Q9
+1 QUIT
CHECK IF $LENGTH(Q1)
IF Q1'="-"
IF Q1'="-0"
IF +Q1'=Q1
KILL X
QUIT
+1 IF $LENGTH(Q2)
IF Q2'?1N.N
KILL X
QUIT
+2 IF $LENGTH(Q2)>LRDEC
KILL X
QUIT
+3 IF X>LRHIGH!(X<LRLOW)!($LENGTH(X,".")>2)!(X["..")!(X["-"&(+X=0))
KILL X
QUIT
+4 SET X=Q8_X
+5 QUIT
COM ;expands lab description from LRMISTF1, dd
+1 SET LRMIN=$PIECE(Q9,",")
SET LRMAX=$PIECE(Q9,",",2)
SET LRSCN=$PIECE(Q9,",",3)
DO COMCHK
+2 KILL LRMIN,LRMAX,LRSCN,Q1,Q2,Q8,Q9
+3 QUIT
COMCHK IF $LENGTH(X)>LRMAX!($LENGTH(X)<LRMIN)!(X'?.ANP)
KILL X
QUIT
+1 NEW LRL,LRS,LRZ,LRY
+2 ; LRNOECHO SET IN LRVR4 TO PREVENT ECHO WHEN STUFFING COMMENTS.
SET LRS=""
DO COMCHK1
if '$DATA(X)
QUIT
IF '$DATA(LRNOECHO)
NEW LRX
SET LRX=" ("_$EXTRACT(LRS,1,$LENGTH(LRS)-1)_")"
DO EN^DDIOL(LRX)
+3 SET X=LRS
+4 KILL LRMAX,LRMIN,LRSCN
+5 QUIT
COMCHK1 FOR I=1:1
if $PIECE(X," ",I,99)=""
QUIT
SET LRZ=$PIECE(X," ",I)
SET Y=""
if LRZ]""
DO SWITCH
SET LRL=$LENGTH(LRS)+$LENGTH(LRZ)
if LRL'>LRMAX
SET LRS=LRS_LRZ_" "
IF LRL>LRMAX
Begin DoDot:1
+1 NEW LRJ,LRX
+2 SET LRX=" ... TOO LONG ... Expanded text is limited to "_LRMAX_" characters."
+3 FOR LRJ=$CHAR(7),LRZ,LRX
DO EN^DDIOL(LRJ)
End DoDot:1
KILL X
QUIT
+4 ; Strip ";" - FileMan uses ";" to parse DR string.
SET LRS=$TRANSLATE(LRS,";","-")
+5 QUIT
SWITCH if $GET(LRNOEXPD)
QUIT
+1 SET LRY=0
FOR
SET LRY=$ORDER(^LAB(62.5,"B",LRZ,LRY))
if LRY<1
QUIT
IF $LENGTH($PIECE($GET(^LAB(62.5,LRY,0)),U,4))
IF LRSCN[$PIECE(^(0),U,4)
SET LRZ=$PIECE(^LAB(62.5,LRY,0),U,2)
if '$LENGTH($GET(^(9)))
QUIT
SET LRY=$PIECE(X," ",I-1)
SET LRY=$EXTRACT(LRY,$LENGTH(LRY))
if LRY>1
SET LRZ=^(9)
+2 QUIT
PN ;checks for positive or negative entry from LRMISTF1
+1 IF "PN"'[X!($LENGTH(X)'=1)
KILL X
WRITE $CHAR(7),!,"Enter 'N' for NEGATIVE or 'P' for POSITIVE"
QUIT
+2 WRITE " (",$SELECT(X="P":"POSITIVE",1:"NEGATIVE"),")"
+3 QUIT
AFS ;checks for acid fast stain entry from LRMISTF1
+1 IF '(X="DP"!(X="DN")!(X="CP")!(X="CN"))
KILL X
WRITE $CHAR(7),!,"Enter 'DP' for DIRECT POSITIVE, 'DN' for DIRECT NEGATIVE,",!,"'CP' for CONCENTRATE POSITIVE, or 'CN' for CONCENTRATE NEGATIVE"
QUIT
+2 WRITE " (",$SELECT(X="DP":"DIRECT POSITIVE",X="DN":"DIRECT NEGATIVE",X="CP":"CONCENTRATE POSITIVE",1:"CONCENTRATE NEGATIVE"),")"
+3 QUIT
