- 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 Feb 18, 2025@23:33:54 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
