LRSPRPT2 ;AVAMC/REG/WTY - SURG PATH PRINT SNOMED;09/06/01
;;5.2;LAB SERVICE;**72,259**;Sep 27, 1994
;
D:$Y>(IOSL-13) F Q:LR("Q")
I $D(^LR(LRDFN,LRSS,LRI,2,A)) W !,"SNOMED code(s):"
S A=0 F S A=$O(^LR(LRDFN,LRSS,LRI,2,A)) Q:'A!(LR("Q")) D
.S T=+^LR(LRDFN,LRSS,LRI,2,A,0),T=^LAB(61,T,0)
.D:$Y>(IOSL-12) F Q:LR("Q")
.W !,"T-",$P(T,"^",2),": "
.S X=$P(T,"^") D:LR(69.2,.05) C^LRUA W X
.D M
Q
M ;
S B=0 F S B=$O(^LR(LRDFN,LRSS,LRI,2,A,2,B)) Q:'B!(LR("Q")) D
.S M=+^LR(LRDFN,LRSS,LRI,2,A,2,B,0),M=^LAB(61.1,M,0)
.D:$Y>(IOSL-12) F Q:LR("Q")
.W !?5,"M-",$P(M,"^",2),": "
.S X=$P(M,"^") D:LR(69.2,.05) C^LRUA W X
.D E
D ;
Q:LR("Q")
F B=1.4,3.3,4.5 D
.S C=0 F S C=$O(^LR(LRDFN,LRSS,LRI,2,A,$P(B,"."),C)) Q:'C!(LR("Q")) D
..S X=^LR(LRDFN,LRSS,LRI,2,A,$P(B,"."),C,0)
..D A
Q
A ;
S M=+X,M(2)=$P(X,"^",2),E="61."_$P(B,".",2),M=^LAB(E,M,0)
D:$Y>(IOSL-12) F Q:LR("Q")
W !?5,$S(B=1.4:"D-",B=3.3:"F-",B=4.5:"P-",1:""),$P(M,"^",2),?12,": "
S X=$P(M,"^") D:LR(69.2,.05) C^LRUA W X
I B=4.5,M(2)]"" D W
Q
E ;
S C=0 F S C=$O(^LR(LRDFN,LRSS,LRI,2,A,2,B,1,C)) Q:'C!(LR("Q")) D
.S E=+^LR(LRDFN,LRSS,LRI,2,A,2,B,1,C,0),E=^LAB(61.2,E,0)
.D:$Y>(IOSL-12) F Q:LR("Q")
.W !?10,"E-",$P(E,"^",2),": " S X=$P(E,"^") D:LR(69.2,.05) C^LRUA W X
Q
F ;
D F^LRAPF,^LRAPF
Q
W ;
W " (",$S(M(2)=0:"negative",M(2)=1:"positive",1:"?"),")"
Q
EN ;from LRSPRPT,LRSPT
Q:'LRAPX(1)
W !!,"Add/Delete reports to/from print queue for ",LRH(0)," "
S %=2 D YN^LRU I %=1 D AD
I '$O(^LRO(69.2,LRAA,LRAPX(1),0)) D Q
.W $C(7),!!,"NO ",$S(LRAPX(1)=2:"FINAL",1:"PRELIMINARY")
.W " REPORTS CURRRENTLY ON THE PRINT QUEUE" S %=0
Q
AD ;
D XR^LRU S LRY=$E(LRAD,1,3),LRY(1)=LRY+1700
I '$O(^LR(LRXREF,LRY,LRABV,0)) D Q
.W $C(7),!,"No accessions for ",LRY(1)
ACC ;
W !!,"Select ",LRO(68)," accession number: " R X:DTIME Q:X=""!(X[U)
I +X'=X W $C(7),!,"Enter NUMBERS only." G ACC
I '$O(^LR(LRXREF,LRY,LRABV,X,0)) D G ACC
.W $C(7),!,"Accession number doesn't exist for ",LRY(1)
S LRDFN=$O(^LR(LRXREF,LRY,LRABV,X,0)),LRI=$O(^(LRDFN,0))
S LRAN=X,X=^LR(LRDFN,0) D ^LRUP W !,LRP," ID: ",SSN
I $D(^LRO(69.2,LRAA,LRAPX(1),LRAN,0)) D DEL G ACC
I LRAPX(1)=2,'$P(^LR(LRDFN,LRSS,LRI,0),"^",3) D G ACC
.W $C(7),!,LRO(68)," Accession ",LRAN," for ",LRH(0),!,"does not "
.W "have a complete date."
W !!,"Add ",LRO(68)," accession ",LRAN," for ",LRY(1)," to"
W !,$S(LRAPX(1)=2:"final",1:"preliminary")," rpt print queue "
S %=2 D YN^LRU D:%=1 ADD
G ACC
DEL ;
W !!,"Delete ",LRO(68)," accession ",LRAN," for ",LRY(1),!,"from "
W $S(LRAPX(1)=2:"final",1:"preliminary")," rpt print queue "
S %=2 D YN^LRU Q:%'=1
K ^LRO(69.2,LRAA,LRAPX(1),LRAN)
L +^LRO(69.2,LRAA,LRAPX(1))
S X=^LRO(69.2,LRAA,LRAPX(1),0)
S X(1)=$O(^LRO(69.2,LRAA,LRAPX(1),0))
S ^LRO(69.2,LRAA,LRAPX(1),0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1)
L -^LRO(69.2,LRAA,LRAPX(1))
Q
ADD ;
S ^LRO(69.2,LRAA,LRAPX(1),LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0)
L +^LRO(69.2,LRAA,LRAPX(1))
S X=^LRO(69.2,LRAA,LRAPX(1),0)
S ^LRO(69.2,LRAA,LRAPX(1),0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
L -^LRO(69.2,LRAA,LRAPX(1))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSPRPT2 3160 printed Dec 13, 2024@02:20:40 Page 2
LRSPRPT2 ;AVAMC/REG/WTY - SURG PATH PRINT SNOMED;09/06/01
+1 ;;5.2;LAB SERVICE;**72,259**;Sep 27, 1994
+2 ;
+3 if $Y>(IOSL-13)
DO F
if LR("Q")
QUIT
+4 IF $DATA(^LR(LRDFN,LRSS,LRI,2,A))
WRITE !,"SNOMED code(s):"
+5 SET A=0
FOR
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,2,A))
if 'A!(LR("Q"))
QUIT
Begin DoDot:1
+6 SET T=+^LR(LRDFN,LRSS,LRI,2,A,0)
SET T=^LAB(61,T,0)
+7 if $Y>(IOSL-12)
DO F
if LR("Q")
QUIT
+8 WRITE !,"T-",$PIECE(T,"^",2),": "
+9 SET X=$PIECE(T,"^")
if LR(69.2,.05)
DO C^LRUA
WRITE X
+10 DO M
End DoDot:1
+11 QUIT
M ;
+1 SET B=0
FOR
SET B=$ORDER(^LR(LRDFN,LRSS,LRI,2,A,2,B))
if 'B!(LR("Q"))
QUIT
Begin DoDot:1
+2 SET M=+^LR(LRDFN,LRSS,LRI,2,A,2,B,0)
SET M=^LAB(61.1,M,0)
+3 if $Y>(IOSL-12)
DO F
if LR("Q")
QUIT
+4 WRITE !?5,"M-",$PIECE(M,"^",2),": "
+5 SET X=$PIECE(M,"^")
if LR(69.2,.05)
DO C^LRUA
WRITE X
+6 DO E
End DoDot:1
D ;
+1 if LR("Q")
QUIT
+2 FOR B=1.4,3.3,4.5
Begin DoDot:1
+3 SET C=0
FOR
SET C=$ORDER(^LR(LRDFN,LRSS,LRI,2,A,$PIECE(B,"."),C))
if 'C!(LR("Q"))
QUIT
Begin DoDot:2
+4 SET X=^LR(LRDFN,LRSS,LRI,2,A,$PIECE(B,"."),C,0)
+5 DO A
End DoDot:2
End DoDot:1
+6 QUIT
A ;
+1 SET M=+X
SET M(2)=$PIECE(X,"^",2)
SET E="61."_$PIECE(B,".",2)
SET M=^LAB(E,M,0)
+2 if $Y>(IOSL-12)
DO F
if LR("Q")
QUIT
+3 WRITE !?5,$SELECT(B=1.4:"D-",B=3.3:"F-",B=4.5:"P-",1:""),$PIECE(M,"^",2),?12,": "
+4 SET X=$PIECE(M,"^")
if LR(69.2,.05)
DO C^LRUA
WRITE X
+5 IF B=4.5
IF M(2)]""
DO W
+6 QUIT
E ;
+1 SET C=0
FOR
SET C=$ORDER(^LR(LRDFN,LRSS,LRI,2,A,2,B,1,C))
if 'C!(LR("Q"))
QUIT
Begin DoDot:1
+2 SET E=+^LR(LRDFN,LRSS,LRI,2,A,2,B,1,C,0)
SET E=^LAB(61.2,E,0)
+3 if $Y>(IOSL-12)
DO F
if LR("Q")
QUIT
+4 WRITE !?10,"E-",$PIECE(E,"^",2),": "
SET X=$PIECE(E,"^")
if LR(69.2,.05)
DO C^LRUA
WRITE X
End DoDot:1
+5 QUIT
F ;
+1 DO F^LRAPF
DO ^LRAPF
+2 QUIT
W ;
+1 WRITE " (",$SELECT(M(2)=0:"negative",M(2)=1:"positive",1:"?"),")"
+2 QUIT
EN ;from LRSPRPT,LRSPT
+1 if 'LRAPX(1)
QUIT
+2 WRITE !!,"Add/Delete reports to/from print queue for ",LRH(0)," "
+3 SET %=2
DO YN^LRU
IF %=1
DO AD
+4 IF '$ORDER(^LRO(69.2,LRAA,LRAPX(1),0))
Begin DoDot:1
+5 WRITE $CHAR(7),!!,"NO ",$SELECT(LRAPX(1)=2:"FINAL",1:"PRELIMINARY")
+6 WRITE " REPORTS CURRRENTLY ON THE PRINT QUEUE"
SET %=0
End DoDot:1
QUIT
+7 QUIT
AD ;
+1 DO XR^LRU
SET LRY=$EXTRACT(LRAD,1,3)
SET LRY(1)=LRY+1700
+2 IF '$ORDER(^LR(LRXREF,LRY,LRABV,0))
Begin DoDot:1
+3 WRITE $CHAR(7),!,"No accessions for ",LRY(1)
End DoDot:1
QUIT
ACC ;
+1 WRITE !!,"Select ",LRO(68)," accession number: "
READ X:DTIME
if X=""!(X[U)
QUIT
+2 IF +X'=X
WRITE $CHAR(7),!,"Enter NUMBERS only."
GOTO ACC
+3 IF '$ORDER(^LR(LRXREF,LRY,LRABV,X,0))
Begin DoDot:1
+4 WRITE $CHAR(7),!,"Accession number doesn't exist for ",LRY(1)
End DoDot:1
GOTO ACC
+5 SET LRDFN=$ORDER(^LR(LRXREF,LRY,LRABV,X,0))
SET LRI=$ORDER(^(LRDFN,0))
+6 SET LRAN=X
SET X=^LR(LRDFN,0)
DO ^LRUP
WRITE !,LRP," ID: ",SSN
+7 IF $DATA(^LRO(69.2,LRAA,LRAPX(1),LRAN,0))
DO DEL
GOTO ACC
+8 IF LRAPX(1)=2
IF '$PIECE(^LR(LRDFN,LRSS,LRI,0),"^",3)
Begin DoDot:1
+9 WRITE $CHAR(7),!,LRO(68)," Accession ",LRAN," for ",LRH(0),!,"does not "
+10 WRITE "have a complete date."
End DoDot:1
GOTO ACC
+11 WRITE !!,"Add ",LRO(68)," accession ",LRAN," for ",LRY(1)," to"
+12 WRITE !,$SELECT(LRAPX(1)=2:"final",1:"preliminary")," rpt print queue "
+13 SET %=2
DO YN^LRU
if %=1
DO ADD
+14 GOTO ACC
DEL ;
+1 WRITE !!,"Delete ",LRO(68)," accession ",LRAN," for ",LRY(1),!,"from "
+2 WRITE $SELECT(LRAPX(1)=2:"final",1:"preliminary")," rpt print queue "
+3 SET %=2
DO YN^LRU
if %'=1
QUIT
+4 KILL ^LRO(69.2,LRAA,LRAPX(1),LRAN)
+5 LOCK +^LRO(69.2,LRAA,LRAPX(1))
+6 SET X=^LRO(69.2,LRAA,LRAPX(1),0)
+7 SET X(1)=$ORDER(^LRO(69.2,LRAA,LRAPX(1),0))
+8 SET ^LRO(69.2,LRAA,LRAPX(1),0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)-1)
+9 LOCK -^LRO(69.2,LRAA,LRAPX(1))
+10 QUIT
ADD ;
+1 SET ^LRO(69.2,LRAA,LRAPX(1),LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0)
+2 LOCK +^LRO(69.2,LRAA,LRAPX(1))
+3 SET X=^LRO(69.2,LRAA,LRAPX(1),0)
+4 SET ^LRO(69.2,LRAA,LRAPX(1),0)=$PIECE(X,"^",1,2)_"^"_LRAN_"^"_($PIECE(X,"^",4)+1)
+5 LOCK -^LRO(69.2,LRAA,LRAPX(1))
+6 QUIT
