LRAPCUM ;AVAMC/REG/KLL - AP PATIENT CUM ;9/25/00
;;5.2;LAB SERVICE;**1030**;NOV 01, 1997
;;5.2;LAB SERVICE;**34,72,173,248,259**;Sep 27, 1994
;
;Reference to ^%ZIS supported by IA #10086
;Reference to ^DIWP supported by IA #10011
;Reference to ^DIWW supported by IA #10029
;
S IOP="HOME" D ^%ZIS,L^LRU
W !!?15,LRAA(1)," PATIENT REPORT(S) DISPLAY"
P W ! S LR("Q")=0 K DIC D ^LRDPA Q:LRDFN=-1 D R G P
;
R W !!,"Is this the patient " S %=1 D YN^LRU Q:%'=1
I '$D(^LR(LRDFN,LRSS)) W $C(7),!!,"No ",LRAA(1)," reports on file",! Q
D S F LRI=0:0 W @IOF S LRA(1)=21,LRI=$O(^LR(LRDFN,LRSS,LRI)) Q:'LRI S B=$G(^(LRI,0)) I B D W Q:LRA(2)?1P
Q
C S C=0 F LRZ=0:1 S C=$O(^LR(LRDFN,LRSS,LRI,LRV,C)) Q:'C D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P W !?2,$P(^LR(LRDFN,LRSS,LRI,LRV,C,0),U)
Q
F D E
K ^UTILITY($J,"W")
S C=0 F LRZ=0:1 S C=$O(^LR(LRDFN,LRSS,LRI,LRV,C)) Q:'C!(LRA(2)?1P) D
.D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P
.S X=^LR(LRDFN,LRSS,LRI,LRV,C,0),X=$P(X,U)
.D ^DIWP
Q:LRA(2)?1P D:LRZ ^DIWW
Q
E K ^TMP($J) S DIWL=3,DIWR=IOM-3,DIWF="W" Q
W S Y=+B D D^LRU S LRW(1)=Y,Y=$P(B,"^",10) D D^LRU S LRW(10)=Y,Y=$P(B,"^",3) D D^LRU S LRW(3)=Y,X=$P(B,"^",2) D:X D^LRUA S LRW(2)=X,LRW(11)=$P(B,"^",11)
S X=$P(B,"^",4) D:X D^LRUA S LRW(4)=X,X=$P(B,"^",7) D:X D^LRUA S LRW(7)=X
W !,"Date Spec taken: ",LRW(1),?38,"Pathologist:",LRW(2),!,"Date Spec rec'd: ",LRW(10),?38,$S(LRSS="SP":"Resident: ",1:"Tech: "),LRW(4)
W !,$S($L(LRW(3)):"Date completed: ",1:"REPORT INCOMPLETE"),LRW(3),?38,"Accession #: ",$P(B,"^",6),!,"Submitted by: ",$P(B,"^",5),?38,"Practitioner:",LRW(7),!,LR("%")
I LRW(11)="" D A W !,$C(7),"Report not verified",! G MORE
I $D(^LR(LRDFN,LRSS,LRI,.1)) W !,"Specimen: " S LRV=.1 D C Q:LRA(2)?1P
I $D(^LR(LRDFN,LRSS,LRI,.2)) W !,"Brief Clinical History:" S LRV=.2 D F Q:LRA(2)?1P
I $D(^LR(LRDFN,LRSS,LRI,.3)) W !,"Preoperative Diagnosis:" S LRV=.3 D F Q:LRA(2)?1P
I $D(^LR(LRDFN,LRSS,LRI,.4)) W !,"Operative Findings:" S LRV=.4 D F Q:LRA(2)?1P
I $D(^LR(LRDFN,LRSS,LRI,.5)) W !,"Postoperative Diagnosis:" S LRV=.5 D F Q:LRA(2)?1P
D SET^LRUA
I $O(^LR(LRDFN,LRSS,LRI,1.3,0)) D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P W !,LR(69.2,.13) I $P($G(^LR(LRDFN,LRSS,LRI,6,0)),U,4) S LR(0)=6 D ^LRSPRPTM
S LRV=1.3 D F Q:LRA(2)?1P
I $O(^LR(LRDFN,LRSS,LRI,1,0)) D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P W !,LR(69.2,.03) I $P($G(^LR(LRDFN,LRSS,LRI,7,0)),U,4) S LR(0)=7 D ^LRSPRPTM
S LRV=1 D F Q:LRA(2)?1P
I $O(^LR(LRDFN,LRSS,LRI,1.1,0)) D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P W !,LR(69.2,.04)," (Date Spec taken: ",LRW(1),")" I $P($G(^LR(LRDFN,LRSS,LRI,4,0)),U,4) S LR(0)=4 D ^LRSPRPTM
S LRV=1.1 D F Q:LRA(2)?1P I $O(^LR(LRDFN,LRSS,LRI,1.4,0)) D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P W !,LR(69.2,.14) I $P($G(^LR(LRDFN,LRSS,LRI,5,0)),U,4) S LR(0)=5 D ^LRSPRPTM
S LRV=1.4 D F Q:LRA(2)?1P
I $O(^LR(LRDFN,LRSS,LRI,1.2,0)) D
.W !,"Supplementary Report:"
.F C=0:0 S C=$O(^LR(LRDFN,LRSS,LRI,1.2,C)) Q:'C!(LRA(2)?1P) D
..S X=^(C,0),Y=+X,X=$P(X,U,2) D D^LRU
..W !?3,"Date: ",Y W:'X " not verified"
..D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P
..I X,$P($G(^LR(LRDFN,LRSS,LRI,1.2,C,2,0)),U,4) D
...S LRV=C,LR("Q")=LRA(2)
...D SUPA^LRSPRPT
...S LRA(2)=LR("Q")
..D:X U Q:LRA(2)?1P
Q:LRA(2)?1P
;USER MUST POSSESS THE LRLAB KEY TO VIEW SNOMED CODES
I $D(^LR(LRDFN,LRSS,LRI,2)) D
.D B
.I $D(^XUSEC("LRLAB",DUZ)) D ^LRAPCUM1
Q:LRA(2)?1P D MORE Q
MORE R !,"'^' TO STOP: ",LRA(2):DTIME I LRA(2)["?" W $C(7) G MORE
I LRA(2)?1P S A=0 Q
S LRA(1)=LRA(1)+21
W $C(13),$J("",15),$C(13)
Q
S S (A,LRA(2))=0 Q
U D E
K ^UTILITY($J,"W")
S E=0
F LRZ=0:1 S E=$O(^LR(LRDFN,LRSS,LRI,1.2,C,1,E)) Q:'E!(LRA(2)?1P) D
.D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P
.S X=^LR(LRDFN,LRSS,LRI,1.2,C,1,E,0)
.D ^DIWP
Q:LRA(2)?1P D:LRZ ^DIWW
Q
B F C=0:0 S C=$O(^LR(LRDFN,LRSS,LRI,2,C)) Q:'C!(LRA(2)?1P) D SP
Q
SP F G=0:0 S G=$O(^LR(LRDFN,LRSS,LRI,2,C,5,G)) Q:'G S X=^(G,0),Y=$P(X,"^",2),E=$P(X,"^",3),E(1)=$P(X,"^")_":",E(1)=$P($P(LR(LRSS),E(1),2),";") D D^LRU S T(2)=Y D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P D WP
Q
WP W !,E(1)," ",E," Date: ",T(2)," ",!
D E
K ^UTILITY($J,"W")
S F=0
F LRZ=0:1 S F=$O(^LR(LRDFN,LRSS,LRI,2,C,5,G,1,F)) Q:'F!(LRA(2)?1P) D
.D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P
.S X=^LR(LRDFN,LRSS,LRI,2,C,5,G,1,F,0) D ^DIWP
Q:LRA(2)?1P D:LRZ ^DIWW
Q
A S A=0 F S A=$O(^LR(LRDFN,LRSS,LRI,97,A)) Q:'A W !,^(A,0)
Q
LRAPCUM ;AVAMC/REG/KLL - AP PATIENT CUM ;9/25/00
+1 ;;5.2;LAB SERVICE;**1030**;NOV 01, 1997
+2 ;;5.2;LAB SERVICE;**34,72,173,248,259**;Sep 27, 1994
+3 ;
+4 ;Reference to ^%ZIS supported by IA #10086
+5 ;Reference to ^DIWP supported by IA #10011
+6 ;Reference to ^DIWW supported by IA #10029
+7 ;
+8 SET IOP="HOME"
DO ^%ZIS
DO L^LRU
+9 WRITE !!?15,LRAA(1)," PATIENT REPORT(S) DISPLAY"
P WRITE !
SET LR("Q")=0
KILL DIC
DO ^LRDPA
IF LRDFN=-1
QUIT
DO R
GOTO P
+1 ;
R WRITE !!,"Is this the patient "
SET %=1
DO YN^LRU
IF %'=1
QUIT
+1 IF '$DATA(^LR(LRDFN,LRSS))
WRITE $CHAR(7),!!,"No ",LRAA(1)," reports on file",!
QUIT
+2 DO S
FOR LRI=0:0
WRITE @IOF
SET LRA(1)=21
SET LRI=$ORDER(^LR(LRDFN,LRSS,LRI))
IF 'LRI
QUIT
SET B=$GET(^(LRI,0))
IF B
DO W
IF LRA(2)?1P
QUIT
+3 QUIT
C SET C=0
FOR LRZ=0:1
SET C=$ORDER(^LR(LRDFN,LRSS,LRI,LRV,C))
IF 'C
QUIT
IF $Y>LRA(1)!'$Y
DO MORE
IF LRA(2)?1P
QUIT
WRITE !?2,$PIECE(^LR(LRDFN,LRSS,LRI,LRV,C,0),U)
+1 QUIT
F DO E
+1 KILL ^UTILITY($JOB,"W")
+2 SET C=0
FOR LRZ=0:1
SET C=$ORDER(^LR(LRDFN,LRSS,LRI,LRV,C))
IF 'C!(LRA(2)?1P)
QUIT
Begin DoDot:1
+3 IF $Y>LRA(1)!'$Y
DO MORE
IF LRA(2)?1P
QUIT
+4 SET X=^LR(LRDFN,LRSS,LRI,LRV,C,0)
SET X=$PIECE(X,U)
+5 DO ^DIWP
End DoDot:1
+6 IF LRA(2)?1P
QUIT
IF LRZ
DO ^DIWW
+7 QUIT
E KILL ^TMP($JOB)
SET DIWL=3
SET DIWR=IOM-3
SET DIWF="W"
QUIT
W SET Y=+B
DO D^LRU
SET LRW(1)=Y
SET Y=$PIECE(B,"^",10)
DO D^LRU
SET LRW(10)=Y
SET Y=$PIECE(B,"^",3)
DO D^LRU
SET LRW(3)=Y
SET X=$PIECE(B,"^",2)
IF X
DO D^LRUA
SET LRW(2)=X
SET LRW(11)=$PIECE(B,"^",11)
+1 SET X=$PIECE(B,"^",4)
IF X
DO D^LRUA
SET LRW(4)=X
SET X=$PIECE(B,"^",7)
IF X
DO D^LRUA
SET LRW(7)=X
+2 WRITE !,"Date Spec taken: ",LRW(1),?38,"Pathologist:",LRW(2),!,"Date Spec rec'd: ",LRW(10),?38,$SELECT(LRSS="SP":"Resident: ",1:"Tech: "),LRW(4)
+3 WRITE !,$SELECT($LENGTH(LRW(3)):"Date completed: ",1:"REPORT INCOMPLETE"),LRW(3),?38,"Accession #: ",$PIECE(B,"^",6),!,"Submitted by: ",$PIECE(B,"^",5),?38,"Practitioner:",LRW(7),!,LR("%")
+4 IF LRW(11)=""
DO A
WRITE !,$CHAR(7),"Report not verified",!
GOTO MORE
+5 IF $DATA(^LR(LRDFN,LRSS,LRI,.1))
WRITE !,"Specimen: "
SET LRV=.1
DO C
IF LRA(2)?1P
QUIT
+6 IF $DATA(^LR(LRDFN,LRSS,LRI,.2))
WRITE !,"Brief Clinical History:"
SET LRV=.2
DO F
IF LRA(2)?1P
QUIT
+7 IF $DATA(^LR(LRDFN,LRSS,LRI,.3))
WRITE !,"Preoperative Diagnosis:"
SET LRV=.3
DO F
IF LRA(2)?1P
QUIT
+8 IF $DATA(^LR(LRDFN,LRSS,LRI,.4))
WRITE !,"Operative Findings:"
SET LRV=.4
DO F
IF LRA(2)?1P
QUIT
+9 IF $DATA(^LR(LRDFN,LRSS,LRI,.5))
WRITE !,"Postoperative Diagnosis:"
SET LRV=.5
DO F
IF LRA(2)?1P
QUIT
+10 DO SET^LRUA
+11 IF $ORDER(^LR(LRDFN,LRSS,LRI,1.3,0))
IF $Y>LRA(1)!'$Y
DO MORE
IF LRA(2)?1P
QUIT
WRITE !,LR(69.2,.13)
IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,6,0)),U,4)
SET LR(0)=6
DO ^LRSPRPTM
+12 SET LRV=1.3
DO F
IF LRA(2)?1P
QUIT
+13 IF $ORDER(^LR(LRDFN,LRSS,LRI,1,0))
IF $Y>LRA(1)!'$Y
DO MORE
IF LRA(2)?1P
QUIT
WRITE !,LR(69.2,.03)
IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,7,0)),U,4)
SET LR(0)=7
DO ^LRSPRPTM
+14 SET LRV=1
DO F
IF LRA(2)?1P
QUIT
+15 IF $ORDER(^LR(LRDFN,LRSS,LRI,1.1,0))
IF $Y>LRA(1)!'$Y
DO MORE
IF LRA(2)?1P
QUIT
WRITE !,LR(69.2,.04)," (Date Spec taken: ",LRW(1),")"
IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,4,0)),U,4)
SET LR(0)=4
DO ^LRSPRPTM
+16 SET LRV=1.1
DO F
IF LRA(2)?1P
QUIT
IF $ORDER(^LR(LRDFN,LRSS,LRI,1.4,0))
IF $Y>LRA(1)!'$Y
DO MORE
IF LRA(2)?1P
QUIT
WRITE !,LR(69.2,.14)
IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,5,0)),U,4)
SET LR(0)=5
DO ^LRSPRPTM
+17 SET LRV=1.4
DO F
IF LRA(2)?1P
QUIT
+18 IF $ORDER(^LR(LRDFN,LRSS,LRI,1.2,0))
Begin DoDot:1
+19 WRITE !,"Supplementary Report:"
+20 FOR C=0:0
SET C=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,C))
IF 'C!(LRA(2)?1P)
QUIT
Begin DoDot:2
+21 SET X=^(C,0)
SET Y=+X
SET X=$PIECE(X,U,2)
DO D^LRU
+22 WRITE !?3,"Date: ",Y
IF 'X
WRITE " not verified"
+23 IF $Y>LRA(1)!'$Y
DO MORE
IF LRA(2)?1P
QUIT
+24 IF X
IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,1.2,C,2,0)),U,4)
Begin DoDot:3
+25 SET LRV=C
SET LR("Q")=LRA(2)
+26 DO SUPA^LRSPRPT
+27 SET LRA(2)=LR("Q")
End DoDot:3
+28 IF X
DO U
IF LRA(2)?1P
QUIT
End DoDot:2
End DoDot:1
+29 IF LRA(2)?1P
QUIT
+30 ;USER MUST POSSESS THE LRLAB KEY TO VIEW SNOMED CODES
+31 IF $DATA(^LR(LRDFN,LRSS,LRI,2))
Begin DoDot:1
+32 DO B
+33 IF $DATA(^XUSEC("LRLAB",DUZ))
DO ^LRAPCUM1
End DoDot:1
+34 IF LRA(2)?1P
QUIT
DO MORE
QUIT
MORE READ !,"'^' TO STOP: ",LRA(2):DTIME
IF LRA(2)["?"
WRITE $CHAR(7)
GOTO MORE
+1 IF LRA(2)?1P
SET A=0
QUIT
+2 SET LRA(1)=LRA(1)+21
+3 WRITE $CHAR(13),$JUSTIFY("",15),$CHAR(13)
+4 QUIT
S SET (A,LRA(2))=0
QUIT
U DO E
+1 KILL ^UTILITY($JOB,"W")
+2 SET E=0
+3 FOR LRZ=0:1
SET E=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,C,1,E))
IF 'E!(LRA(2)?1P)
QUIT
Begin DoDot:1
+4 IF $Y>LRA(1)!'$Y
DO MORE
IF LRA(2)?1P
QUIT
+5 SET X=^LR(LRDFN,LRSS,LRI,1.2,C,1,E,0)
+6 DO ^DIWP
End DoDot:1
+7 IF LRA(2)?1P
QUIT
IF LRZ
DO ^DIWW
+8 QUIT
B FOR C=0:0
SET C=$ORDER(^LR(LRDFN,LRSS,LRI,2,C))
IF 'C!(LRA(2)?1P)
QUIT
DO SP
+1 QUIT
SP FOR G=0:0
SET G=$ORDER(^LR(LRDFN,LRSS,LRI,2,C,5,G))
IF 'G
QUIT
SET X=^(G,0)
SET Y=$PIECE(X,"^",2)
SET E=$PIECE(X,"^",3)
SET E(1)=$PIECE(X,"^")_":"
SET E(1)=$PIECE($PIECE(LR(LRSS),E(1),2),";")
DO D^LRU
SET T(2)=Y
IF $Y>LRA(1)!'$Y
DO MORE
IF LRA(2)?1P
QUIT
DO WP
+1 QUIT
WP WRITE !,E(1)," ",E," Date: ",T(2)," ",!
+1 DO E
+2 KILL ^UTILITY($JOB,"W")
+3 SET F=0
+4 FOR LRZ=0:1
SET F=$ORDER(^LR(LRDFN,LRSS,LRI,2,C,5,G,1,F))
IF 'F!(LRA(2)?1P)
QUIT
Begin DoDot:1
+5 IF $Y>LRA(1)!'$Y
DO MORE
IF LRA(2)?1P
QUIT
+6 SET X=^LR(LRDFN,LRSS,LRI,2,C,5,G,1,F,0)
DO ^DIWP
End DoDot:1
+7 IF LRA(2)?1P
QUIT
IF LRZ
DO ^DIWW
+8 QUIT
A SET A=0
FOR
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,97,A))
IF 'A
QUIT
WRITE !,^(A,0)
+1 QUIT
