- LRSPRPT1 ;AVAMC/REG/WTY - SURG PATH RPT PRINT CONT. ; 17-Oct-2014 09:22 ; MKK
- ;;5.2;LAB SERVICE;**1030,1031,1034**;NOV 1, 1997;Build 188
- ;
- ;;VA LR Patch(s): 1,259,315
- ;
- ;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.
- ;
- ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
- EP ; EP
- NEW ACCDATE
- ; ----- END IHS/MSC/MKK - LR*5.2*1034
- ;
- 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^ICDCODE(LRX,,,1)
- ..; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
- .. S ACCDATE=+$P($G(^LR(LRDFN,LRSS,LRI,0)),".")
- .. S LRX=X,LRX=$$ICDDX^ICDEX(LRX,,,"I",1)
- ..; ----- END IHS/MSC/MKK - LR*5.2*1034
- ..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
- LRSPRPT1 ;AVAMC/REG/WTY - SURG PATH RPT PRINT CONT. ; 17-Oct-2014 09:22 ; MKK
- +1 ;;5.2;LAB SERVICE;**1030,1031,1034**;NOV 1, 1997;Build 188
- +2 ;
- +3 ;;VA LR Patch(s): 1,259,315
- +4 ;
- +5 ;25-Jul-01;WTY;In line tag L, if being called by LRAPT2, don't do
- +6 ; line tag F. Do H1^LRAPT2 instead.
- +7 ;21-Aug-01;WTY;Removed call to LRSPRPT2 which prints SNOMED codes.
- +8 ;
- +9 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
- EP ; EP
- +1 NEW ACCDATE
- +2 ; ----- END IHS/MSC/MKK - LR*5.2*1034
- +3 ;
- +4 SET A=0
- FOR
- SET A=+$ORDER(^LR(LRDFN,LRSS,LRI,2,A))
- IF 'A!(LR("Q"))
- QUIT
- Begin DoDot:1
- +5 SET T=+^LR(LRDFN,LRSS,LRI,2,A,0)
- SET X=$SELECT($DATA(^LAB(61,T,0)):^(0),1:"")
- +6 SET T(1)=$PIECE(X,"^")
- SET T(8)=$PIECE(X,"^",2)
- +7 DO SP
- IF LR("Q")
- QUIT
- +8 DO T
- End DoDot:1
- +9 IF LR("Q")
- QUIT
- +10 IF $DATA(LRS(99))
- IF '+$GET(LR("SPSM"))
- DO ^LRSPRPT2
- +11 IF LR("Q")
- QUIT
- +12 IF $DATA(LRS(99))
- WRITE !
- Begin DoDot:1
- +13 SET A=0
- FOR
- SET A=$ORDER(^LR(LRDFN,LRSS,LRI,3,A))
- IF 'A!(LR("Q"))
- QUIT
- Begin DoDot:2
- +14 IF $Y>(IOSL-12)
- DO F
- IF LR("Q")
- QUIT
- +15 SET X=+^LR(LRDFN,LRSS,LRI,3,A,0)
- +16 NEW LRX
- +17 ; S LRX=X,LRX=$$ICDDX^ICDCODE(LRX,,,1)
- +18 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
- +19 SET ACCDATE=+$PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),".")
- +20 SET LRX=X
- SET LRX=$$ICDDX^ICDEX(LRX,,,"I",1)
- +21 ; ----- END IHS/MSC/MKK - LR*5.2*1034
- +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