LRSORA1 ;SLC/KCM - CREATE SEARCH LOGIC ; 8/5/87 11:40 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
EN W ! F J=1:1:LRTST W !,"-",$C(64+J),"-"," ",$P(LRTST(J,2),U,1) W:$P(LRTST(J,2),U,2)]"" " (",$P(LRTST(J,2),U,2),")" W " ",$P(LRTST(J,2),U,3)
S LRA="A" F I=1:1:LRTST-1 S LRA=LRA_" OR "_$C(65+I)
S Y=-1 F I=0:0 W !!,"Enter SEARCH LOGIC: ",LRA,"// " R X:DTIME S:'$T X="^" S:X["^" LREND=1 D:X["?" HLP0 S:'$L(X) X=LRA D:(X'["?")&(X'["^") PLOG Q:Y'<0!LREND
S LRTST(0)=Y Q
PLOG F %=1:1 S T=$T(SWAP+%) Q:$P(T,";",3)="ZZZZ" S LROLD=$P(T,";",3),LRNEW=$P(T,";",4) D PARSE
S Y="" F %=1:1:$L(X) S:$E(X,%)'=" " Y=Y_$E(X,%)
F %=1:1:$L(Y) S T=$A(Y,%) S LROK=0 D TSTLIM I 'LROK S Y=-1 Q
I Y'=-1 S X="I "_Y D ^DIM S:'$D(X) Y=-1
STOP W:Y<0 " ??" K LRPNT,LROLD,LRNEW,LROK,LRI,LRJ,X,T,% Q
TSTLIM F LRJ=33,38,39,40,41,65:1:64+LRTST S:T=LRJ LROK=1
Q
PARSE F LRI=1:1:$L(LROLD)-$L(LRNEW) S LRNEW=LRNEW_" "
S LRPNT(0)=0 F LRI=1:1 S LRPNT(LRI)=$F(X,LROLD,LRPNT(LRI-1)) Q:LRPNT(LRI)=0
F LRJ=1:1:LRI-1 S X=$E(X,1,LRPNT(LRJ)-$L(LROLD)-1)_LRNEW_$E(X,LRPNT(LRJ),99)
Q
SWAP ;;LROLD;LRNEW; NOTE: $L(LROLD) MUST BE >= $L(LRNEW)
;;AND;&
;;OR;!
;;NOT;'
;;,;&
;;ZZZZ
HLP0 W !!,"Enter a logical expression (i.e., A AND B OR C or A&B!C)."
W !," NOTE: AND will compare only values from the -same- accession."
W !," To print all results that fall within the search criteria,"
W !," accept the default search logic (OR)."
SUMMARY ;
Q
SORTBY ;
K DIR S DIR("B")="P",DIR("A")="Sort by PATIENT or by LOCATION"
S DIR(0)="S^P:PATIENT;L:LOCATION",DIR("?")="Choose print sorting order."
D ^DIR S:($D(DUOUT))!($D(DTOUT)) LREND=1 S:'LREND LRSRT=Y Q
PATS ;
S LRPTS=0
K DIC S DIC="^DPT(",DIC(0)="AEMQ",DIC("A")="Select PATIENT NAME: All//"
F I=1:1 D ^DIC Q:Y=-1 S LRPTS(+Y)=$P(Y,U,2),DIC("A")="Select another PATIENT: ",LRPTS=I
S:($D(DUOUT))!($D(DTOUT)) LREND=1 Q
LOCS ;
S LRLCS=0
K DIC S DIC="^SC(",DIC(0)="AEMQZ",DIC("A")="Select LOCATION: All//"
F I=1:1 D ^DIC Q:Y=-1 D
.S DIC("A")="Select another LOCATION: "
.I $P(Y(0),U,2)="" D NOABRV Q:%'=1
.S LRLCS($S($L($P(Y(0),U,2)):$P(Y(0),U,2),1:"NO ABRV"))=+Y,LRLCS=I
S:($D(DUOUT))!($D(DTOUT)) LREND=1 K %,%Y Q
NOABRV ;
W !!,"The location you have selected does not have an abbreviation."
W !,"If you use this location, the report will list all records without"
W " location",!,"abbreviations (as long as they also meet the date and"
W " patient selections)",!,"This may include data from several "
W "locations, with no way to be sure which is",!,"which. They will be "
W "listed with the abbreviation of 'NO ABRV' or 'UNK'."
S %=1 W !!,"Do you still want to select this location (Y/N)?//"
D YN^DICN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSORA1 2709 printed Sep 23, 2025@19:56:06 Page 2
LRSORA1 ;SLC/KCM - CREATE SEARCH LOGIC ; 8/5/87 11:40 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
EN WRITE !
FOR J=1:1:LRTST
WRITE !,"-",$CHAR(64+J),"-"," ",$PIECE(LRTST(J,2),U,1)
if $PIECE(LRTST(J,2),U,2)]""
WRITE " (",$PIECE(LRTST(J,2),U,2),")"
WRITE " ",$PIECE(LRTST(J,2),U,3)
+1 SET LRA="A"
FOR I=1:1:LRTST-1
SET LRA=LRA_" OR "_$CHAR(65+I)
+2 SET Y=-1
FOR I=0:0
WRITE !!,"Enter SEARCH LOGIC: ",LRA,"// "
READ X:DTIME
if '$TEST
SET X="^"
if X["^"
SET LREND=1
if X["?"
DO HLP0
if '$LENGTH(X)
SET X=LRA
if (X'["?")&(X'["^")
DO PLOG
if Y'<0!LREND
QUIT
+3 SET LRTST(0)=Y
QUIT
PLOG FOR %=1:1
SET T=$TEXT(SWAP+%)
if $PIECE(T,";",3)="ZZZZ"
QUIT
SET LROLD=$PIECE(T,";",3)
SET LRNEW=$PIECE(T,";",4)
DO PARSE
+1 SET Y=""
FOR %=1:1:$LENGTH(X)
if $EXTRACT(X,%)'=" "
SET Y=Y_$EXTRACT(X,%)
+2 FOR %=1:1:$LENGTH(Y)
SET T=$ASCII(Y,%)
SET LROK=0
DO TSTLIM
IF 'LROK
SET Y=-1
QUIT
+3 IF Y'=-1
SET X="I "_Y
DO ^DIM
if '$DATA(X)
SET Y=-1
STOP if Y<0
WRITE " ??"
KILL LRPNT,LROLD,LRNEW,LROK,LRI,LRJ,X,T,%
QUIT
TSTLIM FOR LRJ=33,38,39,40,41,65:1:64+LRTST
if T=LRJ
SET LROK=1
+1 QUIT
PARSE FOR LRI=1:1:$LENGTH(LROLD)-$LENGTH(LRNEW)
SET LRNEW=LRNEW_" "
+1 SET LRPNT(0)=0
FOR LRI=1:1
SET LRPNT(LRI)=$FIND(X,LROLD,LRPNT(LRI-1))
if LRPNT(LRI)=0
QUIT
+2 FOR LRJ=1:1:LRI-1
SET X=$EXTRACT(X,1,LRPNT(LRJ)-$LENGTH(LROLD)-1)_LRNEW_$EXTRACT(X,LRPNT(LRJ),99)
+3 QUIT
SWAP ;;LROLD;LRNEW; NOTE: $L(LROLD) MUST BE >= $L(LRNEW)
+1 ;;AND;&
+2 ;;OR;!
+3 ;;NOT;'
+4 ;;,;&
+5 ;;ZZZZ
HLP0 WRITE !!,"Enter a logical expression (i.e., A AND B OR C or A&B!C)."
+1 WRITE !," NOTE: AND will compare only values from the -same- accession."
+2 WRITE !," To print all results that fall within the search criteria,"
+3 WRITE !," accept the default search logic (OR)."
SUMMARY ;
+1 QUIT
SORTBY ;
+1 KILL DIR
SET DIR("B")="P"
SET DIR("A")="Sort by PATIENT or by LOCATION"
+2 SET DIR(0)="S^P:PATIENT;L:LOCATION"
SET DIR("?")="Choose print sorting order."
+3 DO ^DIR
if ($DATA(DUOUT))!($DATA(DTOUT))
SET LREND=1
if 'LREND
SET LRSRT=Y
QUIT
PATS ;
+1 SET LRPTS=0
+2 KILL DIC
SET DIC="^DPT("
SET DIC(0)="AEMQ"
SET DIC("A")="Select PATIENT NAME: All//"
+3 FOR I=1:1
DO ^DIC
if Y=-1
QUIT
SET LRPTS(+Y)=$PIECE(Y,U,2)
SET DIC("A")="Select another PATIENT: "
SET LRPTS=I
+4 if ($DATA(DUOUT))!($DATA(DTOUT))
SET LREND=1
QUIT
LOCS ;
+1 SET LRLCS=0
+2 KILL DIC
SET DIC="^SC("
SET DIC(0)="AEMQZ"
SET DIC("A")="Select LOCATION: All//"
+3 FOR I=1:1
DO ^DIC
if Y=-1
QUIT
Begin DoDot:1
+4 SET DIC("A")="Select another LOCATION: "
+5 IF $PIECE(Y(0),U,2)=""
DO NOABRV
if %'=1
QUIT
+6 SET LRLCS($SELECT($LENGTH($PIECE(Y(0),U,2)):$PIECE(Y(0),U,2),1:"NO ABRV"))=+Y
SET LRLCS=I
End DoDot:1
+7 if ($DATA(DUOUT))!($DATA(DTOUT))
SET LREND=1
KILL %,%Y
QUIT
NOABRV ;
+1 WRITE !!,"The location you have selected does not have an abbreviation."
+2 WRITE !,"If you use this location, the report will list all records without"
+3 WRITE " location",!,"abbreviations (as long as they also meet the date and"
+4 WRITE " patient selections)",!,"This may include data from several "
+5 WRITE "locations, with no way to be sure which is",!,"which. They will be "
+6 WRITE "listed with the abbreviation of 'NO ABRV' or 'UNK'."
+7 SET %=1
WRITE !!,"Do you still want to select this location (Y/N)?//"
+8 DO YN^DICN
+9 QUIT
