LRAPCUM ;DALOI/STAFF - AP PATIENT CUM ;03/21/13 15:28
;;5.2;LAB SERVICE;**34,72,173,248,259,350,427**;Sep 27, 1994;Build 33
;
;
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
; DALOI/LMT - LR,427 - Removed comments from report to restore pre-LR,350 behavior
;I $D(^LR(LRDFN,LRSS,LRI,99)) D
;. N A
;. W !,"Comments:" S A=0
;. F S A=$O(^LR(LRDFN,LRSS,LRI,99,A)) Q:'A W !,$P(^(A,0),"^")
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPCUM 4525 printed Apr 09, 2024@21:05:28 Page 2
LRAPCUM ;DALOI/STAFF - AP PATIENT CUM ;03/21/13 15:28
+1 ;;5.2;LAB SERVICE;**34,72,173,248,259,350,427**;Sep 27, 1994;Build 33
+2 ;
+3 ;
+4 SET IOP="HOME"
DO ^%ZIS
DO L^LRU
+5 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
+8 ;
+9 ;
E KILL ^TMP($JOB)
SET DIWL=3
SET DIWR=IOM-3
SET DIWF="W"
+1 QUIT
+2 ;
+3 ;
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 ;
+3 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)
+4 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("%")
+5 IF LRW(11)=""
DO A
WRITE !,$CHAR(7),"Report not verified",!
GOTO MORE
+6 IF $DATA(^LR(LRDFN,LRSS,LRI,.1))
WRITE !,"Specimen: "
SET LRV=.1
DO C
if LRA(2)?1P
QUIT
+7 IF $DATA(^LR(LRDFN,LRSS,LRI,.2))
WRITE !,"Brief Clinical History:"
SET LRV=.2
DO F
if LRA(2)?1P
QUIT
+8 IF $DATA(^LR(LRDFN,LRSS,LRI,.3))
WRITE !,"Preoperative Diagnosis:"
SET LRV=.3
DO F
if LRA(2)?1P
QUIT
+9 IF $DATA(^LR(LRDFN,LRSS,LRI,.4))
WRITE !,"Operative Findings:"
SET LRV=.4
DO F
if LRA(2)?1P
QUIT
+10 IF $DATA(^LR(LRDFN,LRSS,LRI,.5))
WRITE !,"Postoperative Diagnosis:"
SET LRV=.5
DO F
if LRA(2)?1P
QUIT
+11 DO SET^LRUA
+12 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
+13 SET LRV=1.3
DO F
if LRA(2)?1P
QUIT
+14 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
+15 SET LRV=1
DO F
if LRA(2)?1P
QUIT
+16 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
+17 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
+18 SET LRV=1.4
DO F
if LRA(2)?1P
QUIT
+19 IF $ORDER(^LR(LRDFN,LRSS,LRI,1.2,0))
Begin DoDot:1
+20 WRITE !,"Supplementary Report:"
+21 FOR C=0:0
SET C=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,C))
if 'C!(LRA(2)?1P)
QUIT
Begin DoDot:2
+22 SET X=^(C,0)
SET Y=+X
SET X=$PIECE(X,U,2)
DO D^LRU
+23 WRITE !?3,"Date: ",Y
if 'X
WRITE " not verified"
+24 if $Y>LRA(1)!'$Y
DO MORE
if LRA(2)?1P
QUIT
+25 IF X
IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,1.2,C,2,0)),U,4)
Begin DoDot:3
+26 SET LRV=C
SET LR("Q")=LRA(2)
+27 DO SUPA^LRSPRPT
+28 SET LRA(2)=LR("Q")
End DoDot:3
+29 if X
DO U
if LRA(2)?1P
QUIT
End DoDot:2
End DoDot:1
+30 if LRA(2)?1P
QUIT
+31 ;
+32 ; User must possess the LRLAB key to view SNOMED codes
+33 IF $DATA(^LR(LRDFN,LRSS,LRI,2))
Begin DoDot:1
+34 DO B
+35 IF $DATA(^XUSEC("LRLAB",DUZ))
DO ^LRAPCUM1
End DoDot:1
+36 if LRA(2)?1P
QUIT
+37 ; DALOI/LMT - LR,427 - Removed comments from report to restore pre-LR,350 behavior
+38 ;I $D(^LR(LRDFN,LRSS,LRI,99)) D
+39 ;. N A
+40 ;. W !,"Comments:" S A=0
+41 ;. F S A=$O(^LR(LRDFN,LRSS,LRI,99,A)) Q:'A W !,$P(^(A,0),"^")
+42 DO MORE
+43 QUIT
+44 ;
+45 ;
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
+5 ;
+6 ;
S SET (A,LRA(2))=0
+1 QUIT
+2 ;
+3 ;
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
+9 ;
+10 ;
B FOR C=0:0
SET C=$ORDER(^LR(LRDFN,LRSS,LRI,2,C))
if 'C!(LRA(2)?1P)
QUIT
DO SP
+1 QUIT
+2 ;
+3 ;
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
+2 ;
+3 ;
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
+9 ;
+10 ;
A SET A=0
FOR
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,97,A))
if 'A
QUIT
WRITE !,^(A,0)
+1 QUIT
