- 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 23, 2025@18:21:07 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
