LRAPS ;AVAMC/REG/CYM - AP PATIENT SCREEN DISPLAY ;8/6/97 14:06 ;
;;5.2;LAB SERVICE;**173**;Sep 27, 1994
Q:'$D(DUZ)
S LR("Q")=0,LRS(5)=1,IOP="HOME" D L^LRU,EN^LRUA,^%ZIS S LRDPAF=1
W @IOF,!?15,"DISPLAY cum path data summary for a patient"
GETP W ! S LRA("A")="" K DIC D ^LRDPA I LRDFN=-1 D V^LRU Q
W !!,"Is this the patient " S %=1 D YN^LRU Q:%<1 G:%=2 GETP
I '$D(^LR(LRDFN,"CY")),'$D(^("SP")),'$D(^("EM")),'$D(^("AU")) W $C(7),!!,"No tissue pathology results for this patient.",!! G GETP
I DOB[1700 S DOB=""
G:'$D(^LR(LRDFN,"SP"))&('$D(^("CY")))&('$D(^("EM"))) AU
D HDR,S^LRAPS1 G:LRA("A")]"" GETP
AU I $D(^LR(LRDFN,"AU")),+^("AU") D ^LRAPS2 K LRAU
G GETP
M F X=0:0 Q:$Y>(IOSL-4) W !
Q:LRA("A")]"" R !!,"'^' TO STOP: ",LRA("A"):DTIME S:'$T LRA("A")="^" Q:LRA("A")="^" I LRA("A")]"" S LRA("A")="" W $C(7) G M
Q
HDR W @IOF,$E(LRP,1,30),?31,SSN,?50,"DOB: ",DOB,?68,"LOC: ",$E(LRLLOC,1,5) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPS 921 printed Dec 13, 2024@02:08:11 Page 2
LRAPS ;AVAMC/REG/CYM - AP PATIENT SCREEN DISPLAY ;8/6/97 14:06 ;
+1 ;;5.2;LAB SERVICE;**173**;Sep 27, 1994
+2 if '$DATA(DUZ)
QUIT
+3 SET LR("Q")=0
SET LRS(5)=1
SET IOP="HOME"
DO L^LRU
DO EN^LRUA
DO ^%ZIS
SET LRDPAF=1
+4 WRITE @IOF,!?15,"DISPLAY cum path data summary for a patient"
GETP WRITE !
SET LRA("A")=""
KILL DIC
DO ^LRDPA
IF LRDFN=-1
DO V^LRU
QUIT
+1 WRITE !!,"Is this the patient "
SET %=1
DO YN^LRU
if %<1
QUIT
if %=2
GOTO GETP
+2 IF '$DATA(^LR(LRDFN,"CY"))
IF '$DATA(^("SP"))
IF '$DATA(^("EM"))
IF '$DATA(^("AU"))
WRITE $CHAR(7),!!,"No tissue pathology results for this patient.",!!
GOTO GETP
+3 IF DOB[1700
SET DOB=""
+4 if '$DATA(^LR(LRDFN,"SP"))&('$DATA(^("CY")))&('$DATA(^("EM")))
GOTO AU
+5 DO HDR
DO S^LRAPS1
if LRA("A")]""
GOTO GETP
AU IF $DATA(^LR(LRDFN,"AU"))
IF +^("AU")
DO ^LRAPS2
KILL LRAU
+1 GOTO GETP
M FOR X=0:0
if $Y>(IOSL-4)
QUIT
WRITE !
+1 if LRA("A")]""
QUIT
READ !!,"'^' TO STOP: ",LRA("A"):DTIME
if '$TEST
SET LRA("A")="^"
if LRA("A")="^"
QUIT
IF LRA("A")]""
SET LRA("A")=""
WRITE $CHAR(7)
GOTO M
+2 QUIT
HDR WRITE @IOF,$EXTRACT(LRP,1,30),?31,SSN,?50,"DOB: ",DOB,?68,"LOC: ",$EXTRACT(LRLLOC,1,5)
QUIT
