LRDPA1 ;AVAMC/REG/DALISC/FHS - PT LOOKUP IN FILES FOR LAB ;9/6/94 09:03 ;
;;5.2;LAB SERVICE;**1,153,201,310**;Sep 27, 1994
N X
EN K LREXP S (LRS,LRS(1),LRSVC,LRAWRD,LRMD,LRMD(1),LRADX,LRADM)="",LRPF="^"_$P(LRDPF,"^",2),LRPFN=+LRDPF,LRFNAM=$P(^DIC(LRPFN,0),"^")
S LRP=PNM
S:$D(VAIN(2)) LRMD(2)=+VAIN(2),LRMD=$P(VAIN(2),U,2)
I '$G(LRMD(2)) S X=$S($D(^LR(LRDFN,.2)):+^(.2),1:"") I X,$D(^VA(200,X,0)) S LRMD=$P(^(0),U),LRMD(1)=X
S LRCAPLOC=$S($G(^LR(LRDFN,.092)):^(.092),1:"") S:LRCAPLOC="" LRCAPLOC="Z"
I $G(VAIN(4)) S LRLLOC=$P($G(^SC(+$G(^DIC(42,+VAIN(4),44)),0)),U,2),LRCAPLOC="W"
E S LRLLOC=$G(^LR(LRDFN,.1)) I $L(LRLLOC) S X=+$O(^SC("B",LRLLOC,0)) I $D(^SC(X,0)) S LRSVC=$P(^(0),"^",20)
S:LRLLOC="" LRLLOC="???"
W !,LRP," ID: ",SSN," " W:LRMD]"" "Physician: ",LRMD,!
I $D(LRSS),LRSS="BB" S X=^LR(LRDFN,0),LRPABO=$P(X,"^",5),LRPRH=$P(X,"^",6) W !,"ABO group: ",LRPABO," Rh type: ",LRPRH
I $D(^LR(LRDFN,.091)),^(.091)]"" W !!,"Infection control warning:",$C(7),!?5,^(.091),!
S:$G(VAIN(3)) (LRS(1),LRSVC)=+VAIN(3),LRS=$P(VAIN(3),U,2)
I $G(VADM(3)) S DOB=$P(VADM(3),U,2)
E S DOB=$$FMTE^XLFDT(DOB)
I $D(@(LRPF_DFN_",.35)")),$P(@(LRPF_DFN_",.35)"),"^") S (LREXP,Y)=+^(.35) D D^LRU S (LRLLOC,^LR(LRDFN,.1))="DIED "_Y W $C(7),!!,?34,"",LRLLOC,"",! Q
W:AGE !,"AGE: ",AGE W " DATE OF BIRTH: ",DOB
D:+LRDPF=2 A
L I '$D(LRQ),$D(LRLABKY) S LRSVC="" D ASK^LRWU S:X["^"!(X="") (LRDFN,DFN)=-1 Q:DFN=-1 S LRLLOC=$G(^LR(LRDFN,.1)) I $L(LRLLOC) S X=+$O(^SC("B",LRLLOC,0)) I $D(^SC(X,0)) S LRSVC=$P(^(0),"^",20)
I $D(LRSS),LRSS="BB" D ^LRDPA2
Q
A I $A(LRLLOC)<33 W $C(7),!!,"Patient in hospital but Ward Location begins with a space !!!",!,"Location =>",LRLLOC,"<=",!,"Ask MAS to fix it",! S LRLLOC="???"
Q:+$G(LRDPF)'=2!('$G(VAIN(1))) S:$D(VAIN(9)) LRADX=VAIN(9)
S:$G(VAIN(7)) LRADM=$P(VAIN(7),U,2)
I $G(VAIN(7)) S VAIP("D")=$P(VAIN(7),U) D
. N X,I,N,Y
. D IN5^VADPT I $G(VAIP(5)) S LRAWRD=$P($G(^SC(+$G(^DIC(42,+VAIP(5),44)),0)),U,2)
W !,"Ward on Adm: ",LRAWRD," Service: ",LRS,!,"Adm Date: ",LRADM," Adm DX: ",LRADX,!,"Present Ward: ",LRLLOC,?30,"Primary MD: ",LRMD
W:$G(VAIN(11)) !?28,"Attending MD: ",$P(VAIN(11),U,2)
K VAIP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRDPA1 2185 printed Sep 23, 2025@19:49:42 Page 2
LRDPA1 ;AVAMC/REG/DALISC/FHS - PT LOOKUP IN FILES FOR LAB ;9/6/94 09:03 ;
+1 ;;5.2;LAB SERVICE;**1,153,201,310**;Sep 27, 1994
+2 NEW X
EN KILL LREXP
SET (LRS,LRS(1),LRSVC,LRAWRD,LRMD,LRMD(1),LRADX,LRADM)=""
SET LRPF="^"_$PIECE(LRDPF,"^",2)
SET LRPFN=+LRDPF
SET LRFNAM=$PIECE(^DIC(LRPFN,0),"^")
+1 SET LRP=PNM
+2 if $DATA(VAIN(2))
SET LRMD(2)=+VAIN(2)
SET LRMD=$PIECE(VAIN(2),U,2)
+3 IF '$GET(LRMD(2))
SET X=$SELECT($DATA(^LR(LRDFN,.2)):+^(.2),1:"")
IF X
IF $DATA(^VA(200,X,0))
SET LRMD=$PIECE(^(0),U)
SET LRMD(1)=X
+4 SET LRCAPLOC=$SELECT($GET(^LR(LRDFN,.092)):^(.092),1:"")
if LRCAPLOC=""
SET LRCAPLOC="Z"
+5 IF $GET(VAIN(4))
SET LRLLOC=$PIECE($GET(^SC(+$GET(^DIC(42,+VAIN(4),44)),0)),U,2)
SET LRCAPLOC="W"
+6 IF '$TEST
SET LRLLOC=$GET(^LR(LRDFN,.1))
IF $LENGTH(LRLLOC)
SET X=+$ORDER(^SC("B",LRLLOC,0))
IF $DATA(^SC(X,0))
SET LRSVC=$PIECE(^(0),"^",20)
+7 if LRLLOC=""
SET LRLLOC="???"
+8 WRITE !,LRP," ID: ",SSN," "
if LRMD]""
WRITE "Physician: ",LRMD,!
+9 IF $DATA(LRSS)
IF LRSS="BB"
SET X=^LR(LRDFN,0)
SET LRPABO=$PIECE(X,"^",5)
SET LRPRH=$PIECE(X,"^",6)
WRITE !,"ABO group: ",LRPABO," Rh type: ",LRPRH
+10 IF $DATA(^LR(LRDFN,.091))
IF ^(.091)]""
WRITE !!,"Infection control warning:",$CHAR(7),!?5,^(.091),!
+11 if $GET(VAIN(3))
SET (LRS(1),LRSVC)=+VAIN(3)
SET LRS=$PIECE(VAIN(3),U,2)
+12 IF $GET(VADM(3))
SET DOB=$PIECE(VADM(3),U,2)
+13 IF '$TEST
SET DOB=$$FMTE^XLFDT(DOB)
+14 IF $DATA(@(LRPF_DFN_",.35)"))
IF $PIECE(@(LRPF_DFN_",.35)"),"^")
SET (LREXP,Y)=+^(.35)
DO D^LRU
SET (LRLLOC,^LR(LRDFN,.1))="DIED "_Y
WRITE $CHAR(7),!!,?34,"",LRLLOC,"",!
QUIT
+15 if AGE
WRITE !,"AGE: ",AGE
WRITE " DATE OF BIRTH: ",DOB
+16 if +LRDPF=2
DO A
L IF '$DATA(LRQ)
IF $DATA(LRLABKY)
SET LRSVC=""
DO ASK^LRWU
if X["^"!(X="")
SET (LRDFN,DFN)=-1
if DFN=-1
QUIT
SET LRLLOC=$GET(^LR(LRDFN,.1))
IF $LENGTH(LRLLOC)
SET X=+$ORDER(^SC("B",LRLLOC,0))
IF $DATA(^SC(X,0))
SET LRSVC=$PIECE(^(0),"^",20)
+1 IF $DATA(LRSS)
IF LRSS="BB"
DO ^LRDPA2
+2 QUIT
A IF $ASCII(LRLLOC)<33
WRITE $CHAR(7),!!,"Patient in hospital but Ward Location begins with a space !!!",!,"Location =>",LRLLOC,"<=",!,"Ask MAS to fix it",!
SET LRLLOC="???"
+1 if +$GET(LRDPF)'=2!('$GET(VAIN(1)))
QUIT
if $DATA(VAIN(9))
SET LRADX=VAIN(9)
+2 if $GET(VAIN(7))
SET LRADM=$PIECE(VAIN(7),U,2)
+3 IF $GET(VAIN(7))
SET VAIP("D")=$PIECE(VAIN(7),U)
Begin DoDot:1
+4 NEW X,I,N,Y
+5 DO IN5^VADPT
IF $GET(VAIP(5))
SET LRAWRD=$PIECE($GET(^SC(+$GET(^DIC(42,+VAIP(5),44)),0)),U,2)
End DoDot:1
+6 WRITE !,"Ward on Adm: ",LRAWRD," Service: ",LRS,!,"Adm Date: ",LRADM," Adm DX: ",LRADX,!,"Present Ward: ",LRLLOC,?30,"Primary MD: ",LRMD
+7 if $GET(VAIN(11))
WRITE !?28,"Attending MD: ",$PIECE(VAIN(11),U,2)
+8 KILL VAIP
+9 QUIT
