LRAPQAT ;AVAMC/REG/CYM - TC CODE SEARCH ;7/31/97 09:38
;;5.2;LAB SERVICE;**72,85,173**;Sep 27, 1994
D END,A^LRAPD G:'$D(Y) END D W G:%'=1 END
W ! F B=1:1 D ASK Q:Z=""!(Z[U)
G:B<2 END W ! D B^LRU G:Y<0 END S LRA=LRSDT-.01,LRLDT=LRLDT+.99
W !!,"Also print cumulative path data summaries " S %=2 D YN^LRU G:%<1 END S:%=1 LRG=1
S ZTRTN="QUE^LRAPQAT" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) S (LRZ,LRM("NONE"))=0,LRQ(9)=1,LRM("NONE",0)="" D L^LRU,S^LRU,XR^LRU,H S LR("F")=1
F LRX=0:0 S LRA=$O(^LR(LRXR,LRA)) Q:'LRA!(LRA>LRLDT) F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRA,LRDFN)) Q:'LRDFN F LRI=0:0 S LRI=$O(^LR(LRXR,LRA,LRDFN,LRI)) Q:'LRI I $P($P($G(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")=LRABV S X=^(0),Y=$P(X,U,14) D X
S LRA=-1 F LRB=0:0 S LRA=$O(LRM(LRA)) Q:LRA=""!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") W !!,"TC Code: ",LRA," ",LRM(LRA,0) S LRP=0 D P
D H2 Q:LR("Q") W !,LR("%") I LRZ=0 W !!?15,"No Accesions in Time period" Q
W !!?10,"TC Code",?20,"Count",?30,"% of Accessions" S LRA=-1 F LRB=0:0 S LRA=$O(LRM(LRA)) Q:LRA=""!(LR("Q")) W !?12,LRA,?20,$J(LRM(LRA),5),?35,$J(LRM(LRA)*100/LRZ,5,2)
W !?20,"-----",!,"Total",?20,$J(LRZ,5),! S LRA=-1 F LRB=0:0 S LRA=$O(LRM(LRA)) Q:LRA="" W !,"TC Code: ",LRA,?12,LRM(LRA,0)
D:$D(LRG) ^LRAPQAT1 D END,END^LRUTL Q
P F LRC=0:0 S LRP=$O(^TMP("LRAP",$J,LRP)) Q:LRP="" F LRDFN=0:0 S LRDFN=$O(^TMP("LRAP",$J,LRP,LRDFN)) Q:'LRDFN S LRX=^(LRDFN) D Y
Q
Y Q:'$D(^TMP($J,LRA,LRDFN)) F LRD=0:0 S LRD=$O(^TMP($J,LRA,LRDFN,LRD)) Q:'LRD!(LR("Q")) D D
Q
D S LRE=0 F LRF=0:0 S LRE=$O(^TMP($J,LRA,LRDFN,LRD,LRE)) Q:LRE=""!(LR("Q")) D:$Y>(IOSL-6) H1 Q:LR("Q") W !,LRP,?32,$P(LRX,"^"),?46,$J(LRE,5),?62 S Y=LRD D D^LRU W Y
Q
X S LRZ=LRZ+1,A=$P(X,"^",6) S:A="" A="?" I Y="" S LRM("NONE")=LRM("NONE")+1,^TMP($J,"NONE",LRDFN,+X,A)="" D B Q
I $D(LRM(Y)) S ^TMP($J,Y,LRDFN,+X,A)="",LRM(Y)=LRM(Y)+1 D B
Q
B S X=^LR(LRDFN,0),Y=$P(X,"^",3),(LRDPF,LR)=$P(X,"^",2),X=^DIC(LR,0,"GL"),X=@(X_Y_",0)"),SSN=$P(X,"^",9) D SSN^LRU S ^TMP("LRAP",$J,$P(X,"^"),LRDFN)=SSN_"^"_$S(LR=2:Y,1:"")_"^"_$P(X,"^",3)_"^"_$P(X,"^",2) Q
;
ASK W !,"Select a number from 0 to 9 (Choice# ",B,"): " R Z:DTIME Q:Z=""!(Z[U) I Z'?1N W $C(7),!!?18,"Only numbers 0,1,2,3,4,5,6,7,8 or 9 allowed.",!?18,"A repeat selection replaces the original one.",! G ASK
A S L(1)="S",L=68,X=Z D ^LRUB
C W !,"ENTER IDENTIFYING COMMENT: ",X,"// " R X(1):DTIME I '$T!(X(1)[U) W $C(7),!,"You must enter an identifying comment <SELECTION DELETED>",! K LRM(Z) S B=B-1 G ASK
S:X(1)="" X(1)=X I X(1)["?" S L(1)="S" D Q^LRUB G A
I X(1)["@" W $C(7),!,"Deletion not allowed" G A
I X(1)'?1ANP.ANP!($L(X(1))<1)!($L(X(1))>68)!(X(1)["?") W $C(7),!!,"Enter free text 2-68 characters." G A
S LRM(Z,0)=X(1),LRM(Z)=0 Q
H2 I $D(LR("F")),$E(IOST,1,2)="C-" D M^LRU Q:LR("Q")
D F^LRU W !,LRO(68)," -TC Code Search from ",LRSTR," to ",LRLST Q
H D H2 W !,"Patient",?35,"SSN",?45,"Acc#",?60,"Date obtained",!,LR("%") Q
H1 D H W !!,"TC Code: ",LRA," ",LRM(LRA,0) Q
;
END K ^TMP("LRAP",$J) D V^LRU Q
W W !!?10,LRO(68)," (",LRABV,") -TC CODE SEARCH",!!,"This report may take a while and should be queued to print at non-peak hours.",!?32,"OK to continue " S %=2 D YN^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPQAT 3186 printed Apr 09, 2024@21:12:51 Page 2
LRAPQAT ;AVAMC/REG/CYM - TC CODE SEARCH ;7/31/97 09:38
+1 ;;5.2;LAB SERVICE;**72,85,173**;Sep 27, 1994
+2 DO END
DO A^LRAPD
if '$DATA(Y)
GOTO END
DO W
if %'=1
GOTO END
+3 WRITE !
FOR B=1:1
DO ASK
if Z=""!(Z[U)
QUIT
+4 if B<2
GOTO END
WRITE !
DO B^LRU
if Y<0
GOTO END
SET LRA=LRSDT-.01
SET LRLDT=LRLDT+.99
+5 WRITE !!,"Also print cumulative path data summaries "
SET %=2
DO YN^LRU
if %<1
GOTO END
if %=1
SET LRG=1
+6 SET ZTRTN="QUE^LRAPQAT"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB)
SET (LRZ,LRM("NONE"))=0
SET LRQ(9)=1
SET LRM("NONE",0)=""
DO L^LRU
DO S^LRU
DO XR^LRU
DO H
SET LR("F")=1
+1 FOR LRX=0:0
SET LRA=$ORDER(^LR(LRXR,LRA))
if 'LRA!(LRA>LRLDT)
QUIT
FOR LRDFN=0:0
SET LRDFN=$ORDER(^LR(LRXR,LRA,LRDFN))
if 'LRDFN
QUIT
FOR LRI=0:0
SET LRI=$ORDER(^LR(LRXR,LRA,LRDFN,LRI))
if 'LRI
QUIT
IF $PIECE($PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")=LRABV
SET X=^(0)
SET Y=$PIECE(X,U,14)
DO X
+2 SET LRA=-1
FOR LRB=0:0
SET LRA=$ORDER(LRM(LRA))
if LRA=""!(LR("Q"))
QUIT
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
WRITE !!,"TC Code: ",LRA," ",LRM(LRA,0)
SET LRP=0
DO P
+3 DO H2
if LR("Q")
QUIT
WRITE !,LR("%")
IF LRZ=0
WRITE !!?15,"No Accesions in Time period"
QUIT
+4 WRITE !!?10,"TC Code",?20,"Count",?30,"% of Accessions"
SET LRA=-1
FOR LRB=0:0
SET LRA=$ORDER(LRM(LRA))
if LRA=""!(LR("Q"))
QUIT
WRITE !?12,LRA,?20,$JUSTIFY(LRM(LRA),5),?35,$JUSTIFY(LRM(LRA)*100/LRZ,5,2)
+5 WRITE !?20,"-----",!,"Total",?20,$JUSTIFY(LRZ,5),!
SET LRA=-1
FOR LRB=0:0
SET LRA=$ORDER(LRM(LRA))
if LRA=""
QUIT
WRITE !,"TC Code: ",LRA,?12,LRM(LRA,0)
+6 if $DATA(LRG)
DO ^LRAPQAT1
DO END
DO END^LRUTL
QUIT
P FOR LRC=0:0
SET LRP=$ORDER(^TMP("LRAP",$JOB,LRP))
if LRP=""
QUIT
FOR LRDFN=0:0
SET LRDFN=$ORDER(^TMP("LRAP",$JOB,LRP,LRDFN))
if 'LRDFN
QUIT
SET LRX=^(LRDFN)
DO Y
+1 QUIT
Y if '$DATA(^TMP($JOB,LRA,LRDFN))
QUIT
FOR LRD=0:0
SET LRD=$ORDER(^TMP($JOB,LRA,LRDFN,LRD))
if 'LRD!(LR("Q"))
QUIT
DO D
+1 QUIT
D SET LRE=0
FOR LRF=0:0
SET LRE=$ORDER(^TMP($JOB,LRA,LRDFN,LRD,LRE))
if LRE=""!(LR("Q"))
QUIT
if $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
WRITE !,LRP,?32,$PIECE(LRX,"^"),?46,$JUSTIFY(LRE,5),?62
SET Y=LRD
DO D^LRU
WRITE Y
+1 QUIT
X SET LRZ=LRZ+1
SET A=$PIECE(X,"^",6)
if A=""
SET A="?"
IF Y=""
SET LRM("NONE")=LRM("NONE")+1
SET ^TMP($JOB,"NONE",LRDFN,+X,A)=""
DO B
QUIT
+1 IF $DATA(LRM(Y))
SET ^TMP($JOB,Y,LRDFN,+X,A)=""
SET LRM(Y)=LRM(Y)+1
DO B
+2 QUIT
B SET X=^LR(LRDFN,0)
SET Y=$PIECE(X,"^",3)
SET (LRDPF,LR)=$PIECE(X,"^",2)
SET X=^DIC(LR,0,"GL")
SET X=@(X_Y_",0)")
SET SSN=$PIECE(X,"^",9)
DO SSN^LRU
SET ^TMP("LRAP",$JOB,$PIECE(X,"^"),LRDFN)=SSN_"^"_$SELECT(LR=2:Y,1:"")_"^"_$PIECE(X,"^",3)_"^"_$PIECE(X,"^",2)
QUIT
+1 ;
ASK WRITE !,"Select a number from 0 to 9 (Choice# ",B,"): "
READ Z:DTIME
if Z=""!(Z[U)
QUIT
IF Z'?1N
WRITE $CHAR(7),!!?18,"Only numbers 0,1,2,3,4,5,6,7,8 or 9 allowed.",!?18,"A repeat selection replaces the original one.",!
GOTO ASK
A SET L(1)="S"
SET L=68
SET X=Z
DO ^LRUB
C WRITE !,"ENTER IDENTIFYING COMMENT: ",X,"// "
READ X(1):DTIME
IF '$TEST!(X(1)[U)
WRITE $CHAR(7),!,"You must enter an identifying comment <SELECTION DELETED>",!
KILL LRM(Z)
SET B=B-1
GOTO ASK
+1 if X(1)=""
SET X(1)=X
IF X(1)["?"
SET L(1)="S"
DO Q^LRUB
GOTO A
+2 IF X(1)["@"
WRITE $CHAR(7),!,"Deletion not allowed"
GOTO A
+3 IF X(1)'?1ANP.ANP!($LENGTH(X(1))<1)!($LENGTH(X(1))>68)!(X(1)["?")
WRITE $CHAR(7),!!,"Enter free text 2-68 characters."
GOTO A
+4 SET LRM(Z,0)=X(1)
SET LRM(Z)=0
QUIT
H2 IF $DATA(LR("F"))
IF $EXTRACT(IOST,1,2)="C-"
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !,LRO(68)," -TC Code Search from ",LRSTR," to ",LRLST
QUIT
H DO H2
WRITE !,"Patient",?35,"SSN",?45,"Acc#",?60,"Date obtained",!,LR("%")
QUIT
H1 DO H
WRITE !!,"TC Code: ",LRA," ",LRM(LRA,0)
QUIT
+1 ;
END KILL ^TMP("LRAP",$JOB)
DO V^LRU
QUIT
W WRITE !!?10,LRO(68)," (",LRABV,") -TC CODE SEARCH",!!,"This report may take a while and should be queued to print at non-peak hours.",!?32,"OK to continue "
SET %=2
DO YN^LRU
QUIT
