LRSPRPT1 ;AVAMC/REG/WTY - SURG PATH RPT PRINT CONT. ;10/16/01
;;5.2;LAB SERVICE;**1,259,315,422**;Sep 27, 1994;Build 29
;
;25-Jul-01;WTY;In line tag L, if being called by LRAPT2, don't do
; line tag F. Do H1^LRAPT2 instead.
;21-Aug-01;WTY;Removed call to LRSPRPT2 which prints SNOMED codes.
; Reference to $$ICDDX^ICDEX supported by ICR #5747
;
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),X=$S($D(^LAB(61,T,0)):^(0),1:"")
.S T(1)=$P(X,"^"),T(8)=$P(X,"^",2)
.D SP Q:LR("Q")
.D T
Q:LR("Q")
I $D(LRS(99)),'+$G(LR("SPSM")) D ^LRSPRPT2
Q:LR("Q")
I $D(LRS(99)) W ! D
.S A=0 F S A=$O(^LR(LRDFN,LRSS,LRI,3,A)) Q:'A!(LR("Q")) D
..D:$Y>(IOSL-12) F Q:LR("Q")
..S X=+^LR(LRDFN,LRSS,LRI,3,A,0)
..N LRX
..S LRX=X,LRX=$$ICDDX^ICDEX(LRX,,,"I")
..S X=$P(LRX,U,4)
..W !,"ICD code: ",$P(LRX,U,2),?20 D:LR(69.2,.05) C^LRUA W X
Q
SP ;
S C=0 F S C=$O(^LR(LRDFN,LRSS,LRI,2,A,5,C)) Q:'C!(LR("Q")) D
.S T(3)=^LR(LRDFN,LRSS,LRI,2,A,5,C,0)
.S Y=$P(T(3),"^",2),E=$P(T(3),"^",3)
.S T(4)=$P(T(3),"^")_":",T(4)=$P($P(LR(LRSS),T(4),2),";",1)
.D D^LRU S T(2)=Y
.D:$Y>(IOSL-12) F Q:LR("Q") D WP
Q
WP ;
W !!,T(4)," ",E," Date: ",T(2)," ",!,T(1),!
D E S B=0
F LRZ=0:1 S B=$O(^LR(LRDFN,LRSS,LRI,2,A,5,C,1,B)) Q:'B!(LR("Q")) D
.D:$Y>(IOSL-12) F Q:LR("Q")
.S X=^LR(LRDFN,LRSS,LRI,2,A,5,C,1,B,0) D ^DIWP
Q:LR("Q") D:LRZ ^DIWW
Q
E ;
K ^UTILITY($J) S DIWR=IOM-10,DIWL=10,DIWF="W"
Q
T ;
S T(3)=T,T(4)=61 D EN
S M=0 F S M=$O(^LR(LRDFN,LRSS,LRI,2,A,2,M)) Q:'M!(LR("Q")) D
.S T(3)=+^LR(LRDFN,LRSS,LRI,2,A,2,M,0),T(4)=61.1 D EN Q:LR("Q") D
..S N=0 F S N=$O(^LR(LRDFN,LRSS,LRI,2,A,2,M,1,N)) Q:'N!(LR("Q")) D
...S T(3)=+^LR(LRDFN,LRSS,LRI,2,A,2,M,1,N,0),T(4)=61.2 D EN
Q:LR("Q")
S M=0 F S M=$O(^LR(LRDFN,LRSS,LRI,2,A,1,M)) Q:'M!(LR("Q")) D
.S T(3)=+^LR(LRDFN,LRSS,LRI,2,A,1,M,0),T(4)=61.4 D EN
Q:LR("Q")
S M=0 F S M=$O(^LR(LRDFN,LRSS,LRI,2,A,3,M)) Q:'M!(LR("Q")) D
.S T(3)=+^LR(LRDFN,LRSS,LRI,2,A,3,M,0),T(4)=61.3 D EN
Q
EN ;also from LRAPT2
S C(1)=0
F S C(1)=$O(^LAB(T(4),T(3),"JR",C(1))) Q:'C(1)!(LR("Q")) D
.I $P(^LAB(T(4),T(3),"JR",C(1),0),"^",7) S T(9)=^(0),T(5)=1 D L
Q
L ;
S X=$O(^LAB(T(4),T(3),"JR",C(1),1,0))
I X K T(5) D
.S X=0 F S X=$O(^LAB(T(4),T(3),"JR",C(1),1,X)) Q:'X D
..S Y=$P(^LAB(T(4),T(3),"JR",C(1),1,X,0),"^")
..I Y=$E(T(8),1,$L(Y)) S T(5)=1
Q:'$D(T(5))
D PGCHK
Q:LR("Q")
W ! D PGCHK Q:LR("Q")
W !,"Reference: "
D PGCHK Q:LR("Q")
W !,$P(T(9),"^")
D PGCHK Q:LR("Q")
W !,$P(T(9),"^",2)
D PGCHK Q:LR("Q")
W !
I $P(T(9),"^",3) D
.W $P(^LAB(95,$P(T(9),"^",3),0),"^")," vol.",$P(T(9),"^",4)
.W " pg.",$P(T(9),"^",5)
S Y=$P(T(9),"^",6) D D^LRU W " Date: ",Y
Q
F ;
D F^LRAPF,^LRAPF
Q
PGCHK ;
I $Y>(IOSL-12) D
.I LRSS="AU" D Q
..I '+$G(LRSF515) D H1^LRAPT Q
..D:+$G(LRSF515) FT^LRAURPT,H^LRAURPT
.D F
Q
END ;
W $C(7),!!,"OK TO DELETE THE ",LRAA(1)," FINAL REPORT LIST"
S %=2 D YN^LRU
I %=1 K ^LRO(69.2,LRAA,2) S ^LRO(69.2,LRAA,2,0)="^69.23A^0^0" D Q
.W $C(7),!,"LIST DELETED !"
W !!,"FINE, LET'S FORGET IT",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSPRPT1 3152 printed Dec 13, 2024@02:20:39 Page 2
LRSPRPT1 ;AVAMC/REG/WTY - SURG PATH RPT PRINT CONT. ;10/16/01
+1 ;;5.2;LAB SERVICE;**1,259,315,422**;Sep 27, 1994;Build 29
+2 ;
+3 ;25-Jul-01;WTY;In line tag L, if being called by LRAPT2, don't do
+4 ; line tag F. Do H1^LRAPT2 instead.
+5 ;21-Aug-01;WTY;Removed call to LRSPRPT2 which prints SNOMED codes.
+6 ; Reference to $$ICDDX^ICDEX supported by ICR #5747
+7 ;
+8 SET A=0
FOR
SET A=+$ORDER(^LR(LRDFN,LRSS,LRI,2,A))
if 'A!(LR("Q"))
QUIT
Begin DoDot:1
+9 SET T=+^LR(LRDFN,LRSS,LRI,2,A,0)
SET X=$SELECT($DATA(^LAB(61,T,0)):^(0),1:"")
+10 SET T(1)=$PIECE(X,"^")
SET T(8)=$PIECE(X,"^",2)
+11 DO SP
if LR("Q")
QUIT
+12 DO T
End DoDot:1
+13 if LR("Q")
QUIT
+14 IF $DATA(LRS(99))
IF '+$GET(LR("SPSM"))
DO ^LRSPRPT2
+15 if LR("Q")
QUIT
+16 IF $DATA(LRS(99))
WRITE !
Begin DoDot:1
+17 SET A=0
FOR
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,3,A))
if 'A!(LR("Q"))
QUIT
Begin DoDot:2
+18 if $Y>(IOSL-12)
DO F
if LR("Q")
QUIT
+19 SET X=+^LR(LRDFN,LRSS,LRI,3,A,0)
+20 NEW LRX
+21 SET LRX=X
SET LRX=$$ICDDX^ICDEX(LRX,,,"I")
+22 SET X=$PIECE(LRX,U,4)
+23 WRITE !,"ICD code: ",$PIECE(LRX,U,2),?20
if LR(69.2,.05)
DO C^LRUA
WRITE X
End DoDot:2
End DoDot:1
+24 QUIT
SP ;
+1 SET C=0
FOR
SET C=$ORDER(^LR(LRDFN,LRSS,LRI,2,A,5,C))
if 'C!(LR("Q"))
QUIT
Begin DoDot:1
+2 SET T(3)=^LR(LRDFN,LRSS,LRI,2,A,5,C,0)
+3 SET Y=$PIECE(T(3),"^",2)
SET E=$PIECE(T(3),"^",3)
+4 SET T(4)=$PIECE(T(3),"^")_":"
SET T(4)=$PIECE($PIECE(LR(LRSS),T(4),2),";",1)
+5 DO D^LRU
SET T(2)=Y
+6 if $Y>(IOSL-12)
DO F
if LR("Q")
QUIT
DO WP
End DoDot:1
+7 QUIT
WP ;
+1 WRITE !!,T(4)," ",E," Date: ",T(2)," ",!,T(1),!
+2 DO E
SET B=0
+3 FOR LRZ=0:1
SET B=$ORDER(^LR(LRDFN,LRSS,LRI,2,A,5,C,1,B))
if 'B!(LR("Q"))
QUIT
Begin DoDot:1
+4 if $Y>(IOSL-12)
DO F
if LR("Q")
QUIT
+5 SET X=^LR(LRDFN,LRSS,LRI,2,A,5,C,1,B,0)
DO ^DIWP
End DoDot:1
+6 if LR("Q")
QUIT
if LRZ
DO ^DIWW
+7 QUIT
E ;
+1 KILL ^UTILITY($JOB)
SET DIWR=IOM-10
SET DIWL=10
SET DIWF="W"
+2 QUIT
T ;
+1 SET T(3)=T
SET T(4)=61
DO EN
+2 SET M=0
FOR
SET M=$ORDER(^LR(LRDFN,LRSS,LRI,2,A,2,M))
if 'M!(LR("Q"))
QUIT
Begin DoDot:1
+3 SET T(3)=+^LR(LRDFN,LRSS,LRI,2,A,2,M,0)
SET T(4)=61.1
DO EN
if LR("Q")
QUIT
Begin DoDot:2
+4 SET N=0
FOR
SET N=$ORDER(^LR(LRDFN,LRSS,LRI,2,A,2,M,1,N))
if 'N!(LR("Q"))
QUIT
Begin DoDot:3
+5 SET T(3)=+^LR(LRDFN,LRSS,LRI,2,A,2,M,1,N,0)
SET T(4)=61.2
DO EN
End DoDot:3
End DoDot:2
End DoDot:1
+6 if LR("Q")
QUIT
+7 SET M=0
FOR
SET M=$ORDER(^LR(LRDFN,LRSS,LRI,2,A,1,M))
if 'M!(LR("Q"))
QUIT
Begin DoDot:1
+8 SET T(3)=+^LR(LRDFN,LRSS,LRI,2,A,1,M,0)
SET T(4)=61.4
DO EN
End DoDot:1
+9 if LR("Q")
QUIT
+10 SET M=0
FOR
SET M=$ORDER(^LR(LRDFN,LRSS,LRI,2,A,3,M))
if 'M!(LR("Q"))
QUIT
Begin DoDot:1
+11 SET T(3)=+^LR(LRDFN,LRSS,LRI,2,A,3,M,0)
SET T(4)=61.3
DO EN
End DoDot:1
+12 QUIT
EN ;also from LRAPT2
+1 SET C(1)=0
+2 FOR
SET C(1)=$ORDER(^LAB(T(4),T(3),"JR",C(1)))
if 'C(1)!(LR("Q"))
QUIT
Begin DoDot:1
+3 IF $PIECE(^LAB(T(4),T(3),"JR",C(1),0),"^",7)
SET T(9)=^(0)
SET T(5)=1
DO L
End DoDot:1
+4 QUIT
L ;
+1 SET X=$ORDER(^LAB(T(4),T(3),"JR",C(1),1,0))
+2 IF X
KILL T(5)
Begin DoDot:1
+3 SET X=0
FOR
SET X=$ORDER(^LAB(T(4),T(3),"JR",C(1),1,X))
if 'X
QUIT
Begin DoDot:2
+4 SET Y=$PIECE(^LAB(T(4),T(3),"JR",C(1),1,X,0),"^")
+5 IF Y=$EXTRACT(T(8),1,$LENGTH(Y))
SET T(5)=1
End DoDot:2
End DoDot:1
+6 if '$DATA(T(5))
QUIT
+7 DO PGCHK
+8 if LR("Q")
QUIT
+9 WRITE !
DO PGCHK
if LR("Q")
QUIT
+10 WRITE !,"Reference: "
+11 DO PGCHK
if LR("Q")
QUIT
+12 WRITE !,$PIECE(T(9),"^")
+13 DO PGCHK
if LR("Q")
QUIT
+14 WRITE !,$PIECE(T(9),"^",2)
+15 DO PGCHK
if LR("Q")
QUIT
+16 WRITE !
+17 IF $PIECE(T(9),"^",3)
Begin DoDot:1
+18 WRITE $PIECE(^LAB(95,$PIECE(T(9),"^",3),0),"^")," vol.",$PIECE(T(9),"^",4)
+19 WRITE " pg.",$PIECE(T(9),"^",5)
End DoDot:1
+20 SET Y=$PIECE(T(9),"^",6)
DO D^LRU
WRITE " Date: ",Y
+21 QUIT
F ;
+1 DO F^LRAPF
DO ^LRAPF
+2 QUIT
PGCHK ;
+1 IF $Y>(IOSL-12)
Begin DoDot:1
+2 IF LRSS="AU"
Begin DoDot:2
+3 IF '+$GET(LRSF515)
DO H1^LRAPT
QUIT
+4 if +$GET(LRSF515)
DO FT^LRAURPT
DO H^LRAURPT
End DoDot:2
QUIT
+5 DO F
End DoDot:1
+6 QUIT
END ;
+1 WRITE $CHAR(7),!!,"OK TO DELETE THE ",LRAA(1)," FINAL REPORT LIST"
+2 SET %=2
DO YN^LRU
+3 IF %=1
KILL ^LRO(69.2,LRAA,2)
SET ^LRO(69.2,LRAA,2,0)="^69.23A^0^0"
Begin DoDot:1
+4 WRITE $CHAR(7),!,"LIST DELETED !"
End DoDot:1
QUIT
+5 WRITE !!,"FINE, LET'S FORGET IT",!
+6 QUIT
