- 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
