LRAPONC ;AVAMC/REG - FIND MALIGNANCIES FOR ONCOLOGY ;5/21/91 11:43
;;5.2;LAB SERVICE;;Sep 27, 1994
D END W !!?31,"Find Malignancies for Oncology" D A G:'$D(Y) END D XR^LRU
I LRSS="CY" W !!,"Include suspicious for malignancy cases " S %=1 D YN^LRU G:%<1 END S:%=1 LRB=1
S S(2)="ALL",S(1)=3
W ! D B^LRU G:Y<0 END S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
F X=8,9 F Y=1,2,3,6,9 S Z=X_"***"_Y,LRM(Z)=5,LRN(Z)=Z
I $D(LRB) S LRM(69760)=5,LRN(69760)=69760
D WAIT^LRU
F LR=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D LRDFN
Q
Y I $E(X,1,Y(1))=Y(2) S I=1 Q
Y1 S I=1 F I(1)=1:1:Y(1) S I(2)=$E(Y(2),I(1)) I I(2)'="*",I(2)'=$E(X,I(1)) S I=0 Q
Q
LRDFN F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN D @$S(LRSS'="AU":"LRI",1:"AU")
Q
LRI F LRI=0:0 S LRI=$O(^LR(LRXR,LRSDT,LRDFN,LRI)) Q:'LRI D T
Q
T F T=0:0 S T=$O(^LR(LRDFN,LRSS,LRI,2,T)) Q:'T S LRT=+^(T,0) D M
Q
M F M=0:0 S M=$O(^LR(LRDFN,LRSS,LRI,2,T,2,M)) Q:'M S X=^(M,0),LRD=+X,LRM=$P(X,"^",2) D MX
Q
MX Q:'$D(^LAB(61.1,LRD,0)) S W=^(0),X=$P(W,"^",2),Y=0 F Z=1:1 S Y=$O(LRN(Y)) Q:Y="" S Y(1)=LRM(Y),Y(2)=LRN(Y) D Y I I S ^TMP($J,LRDFN,LRI)=""
Q
AU S LRI=9999999 F T=0:0 S T=$O(^LR(LRDFN,"AY",T)) Q:'T S LRT=+^(T,0) D AUM
Q
AUM F M=0:0 S M=$O(^LR(LRDFN,"AY",T,2,M)) Q:'M S X=^(M,0),LRD=+X,LRM=$P(X,"^",2) D MX
Q
L S X=^LR(LRDFN,0),Y=$P(X,"^",3),(LRDPF,X)=^DIC($P(X,"^",2),0,"GL"),LRPPT=@(X_Y_",0)")
S LRQ=0,LRP=$P(LRPPT,"^"),SEX=$P(LRPPT,"^",2),Y=$P(LRPPT,"^",3),SSN=$P(LRPPT,"^",9) D D^LRU,SSN^LRU S DOB=$S(Y[1700:"",1:Y)
Q
A ;
W ! S DIC=68,DIC(0)="AEOQMZ",DIC("A")="Select ANATOMIC PATHOLOGY section: ",DIC("S")="I ""AUSPCYEM""[$P(^(0),U,2)&($P(^(0),U,2)]"""")" D ^DIC K DIC G:Y<1 END
D ^LRUTL G:Y=-1 END Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPONC 1745 printed Sep 23, 2025@19:43:26 Page 2
LRAPONC ;AVAMC/REG - FIND MALIGNANCIES FOR ONCOLOGY ;5/21/91 11:43
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
+2 DO END
WRITE !!?31,"Find Malignancies for Oncology"
DO A
if '$DATA(Y)
GOTO END
DO XR^LRU
+3 IF LRSS="CY"
WRITE !!,"Include suspicious for malignancy cases "
SET %=1
DO YN^LRU
if %<1
GOTO END
if %=1
SET LRB=1
+4 SET S(2)="ALL"
SET S(1)=3
+5 WRITE !
DO B^LRU
if Y<0
GOTO END
SET LRSDT=LRSDT-.01
SET LRLDT=LRLDT+.99
+6 FOR X=8,9
FOR Y=1,2,3,6,9
SET Z=X_"***"_Y
SET LRM(Z)=5
SET LRN(Z)=Z
+7 IF $DATA(LRB)
SET LRM(69760)=5
SET LRN(69760)=69760
+8 DO WAIT^LRU
+9 FOR LR=0:0
SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
if 'LRSDT!(LRSDT>LRLDT)
QUIT
DO LRDFN
+10 QUIT
Y IF $EXTRACT(X,1,Y(1))=Y(2)
SET I=1
QUIT
Y1 SET I=1
FOR I(1)=1:1:Y(1)
SET I(2)=$EXTRACT(Y(2),I(1))
IF I(2)'="*"
IF I(2)'=$EXTRACT(X,I(1))
SET I=0
QUIT
+1 QUIT
LRDFN FOR LRDFN=0:0
SET LRDFN=$ORDER(^LR(LRXR,LRSDT,LRDFN))
if 'LRDFN
QUIT
DO @$SELECT(LRSS'="AU":"LRI",1:"AU")
+1 QUIT
LRI FOR LRI=0:0
SET LRI=$ORDER(^LR(LRXR,LRSDT,LRDFN,LRI))
if 'LRI
QUIT
DO T
+1 QUIT
T FOR T=0:0
SET T=$ORDER(^LR(LRDFN,LRSS,LRI,2,T))
if 'T
QUIT
SET LRT=+^(T,0)
DO M
+1 QUIT
M FOR M=0:0
SET M=$ORDER(^LR(LRDFN,LRSS,LRI,2,T,2,M))
if 'M
QUIT
SET X=^(M,0)
SET LRD=+X
SET LRM=$PIECE(X,"^",2)
DO MX
+1 QUIT
MX if '$DATA(^LAB(61.1,LRD,0))
QUIT
SET W=^(0)
SET X=$PIECE(W,"^",2)
SET Y=0
FOR Z=1:1
SET Y=$ORDER(LRN(Y))
if Y=""
QUIT
SET Y(1)=LRM(Y)
SET Y(2)=LRN(Y)
DO Y
IF I
SET ^TMP($JOB,LRDFN,LRI)=""
+1 QUIT
AU SET LRI=9999999
FOR T=0:0
SET T=$ORDER(^LR(LRDFN,"AY",T))
if 'T
QUIT
SET LRT=+^(T,0)
DO AUM
+1 QUIT
AUM FOR M=0:0
SET M=$ORDER(^LR(LRDFN,"AY",T,2,M))
if 'M
QUIT
SET X=^(M,0)
SET LRD=+X
SET LRM=$PIECE(X,"^",2)
DO MX
+1 QUIT
L SET X=^LR(LRDFN,0)
SET Y=$PIECE(X,"^",3)
SET (LRDPF,X)=^DIC($PIECE(X,"^",2),0,"GL")
SET LRPPT=@(X_Y_",0)")
+1 SET LRQ=0
SET LRP=$PIECE(LRPPT,"^")
SET SEX=$PIECE(LRPPT,"^",2)
SET Y=$PIECE(LRPPT,"^",3)
SET SSN=$PIECE(LRPPT,"^",9)
DO D^LRU
DO SSN^LRU
SET DOB=$SELECT(Y[1700:"",1:Y)
+2 QUIT
A ;
+1 WRITE !
SET DIC=68
SET DIC(0)="AEOQMZ"
SET DIC("A")="Select ANATOMIC PATHOLOGY section: "
SET DIC("S")="I ""AUSPCYEM""[$P(^(0),U,2)&($P(^(0),U,2)]"""")"
DO ^DIC
KILL DIC
if Y<1
GOTO END
+2 DO ^LRUTL
if Y=-1
GOTO END
QUIT
+3 ;
END DO V^LRU
QUIT
