- 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 Feb 18, 2025@23:46:19 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