LRDPA1 ;AVAMC/REG/DALISC/FHS - PT LOOKUP IN FILES FOR LAB ;9/6/94 09:03 ;
;;5.2;LR;**1,153,201,310,1022**;September 20, 2007
;;
; VA Patch 310 included in IHS Lab Patch 1022
;;
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,!
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
W !,LRP," ID: ",HRCN," " W:LRMD]"" "Physician: ",LRMD,! ;IHS/ANMC/CLS 11/1/95
;----- END IHS MODIFICATIONS
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)
.;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
.D @$S($$ISPIMS^BLRUTIL:"IN5^VADPT",1:"IN5^BLRDPT") I $G(VAIP(5)) S LRAWRD=$P($G(^SC(+$G(^DIC(42,+VAIP(5),44)),0)),U,2) ;IHS/DIR TUC/AAB 06/18/98
.;----- END IHS MODIFICATIONS
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
LRDPA1 ;AVAMC/REG/DALISC/FHS - PT LOOKUP IN FILES FOR LAB ;9/6/94 09:03 ;
+1 ;;5.2;LR;**1,153,201,310,1022**;September 20, 2007
+2 ;;
+3 ; VA Patch 310 included in IHS Lab Patch 1022
+4 ;;
+5 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 ; W !,LRP," ID: ",SSN," " W:LRMD]"" "Physician: ",LRMD,!
+9 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+10 ;IHS/ANMC/CLS 11/1/95
WRITE !,LRP," ID: ",HRCN," "
IF LRMD]""
WRITE "Physician: ",LRMD,!
+11 ;----- END IHS MODIFICATIONS
+12 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
+13 IF $DATA(^LR(LRDFN,.091))
IF ^(.091)]""
WRITE !!,"Infection control warning:",$CHAR(7),!?5,^(.091),!
+14 IF $GET(VAIN(3))
SET (LRS(1),LRSVC)=+VAIN(3)
SET LRS=$PIECE(VAIN(3),U,2)
+15 IF $GET(VADM(3))
SET DOB=$PIECE(VADM(3),U,2)
+16 IF '$TEST
SET DOB=$$FMTE^XLFDT(DOB)
+17 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
+18 IF AGE
WRITE !,"AGE: ",AGE
WRITE " DATE OF BIRTH: ",DOB
+19 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 ; D IN5^VADPT I $G(VAIP(5)) S LRAWRD=$P($G(^SC(+$G(^DIC(42,+VAIP(5),44)),0)),U,2)
+6 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+7 ;IHS/DIR TUC/AAB 06/18/98
DO @$SELECT($$ISPIMS^BLRUTIL:"IN5^VADPT",1:"IN5^BLRDPT")
IF $GET(VAIP(5))
SET LRAWRD=$PIECE($GET(^SC(+$GET(^DIC(42,+VAIP(5),44)),0)),U,2)
+8 ;----- END IHS MODIFICATIONS
End DoDot:1
+9 WRITE !,"Ward on Adm: ",LRAWRD," Service: ",LRS,!,"Adm Date: ",LRADM," Adm DX: ",LRADX,!,"Present Ward: ",LRLLOC,?30,"Primary MD: ",LRMD
+10 IF $GET(VAIN(11))
WRITE !?28,"Attending MD: ",$PIECE(VAIN(11),U,2)
+11 KILL VAIP
+12 QUIT
