LRUG ;AVAMC/REG/CYM - GET LRDFN ;9/3/97 09:18 ;
;;5.2;LAB SERVICE;**90**;Sep 27, 1994
S LRA=X I $D(LRT),LRT="A" D AUTO Q:'$D(X)
N LRSAVE S LRSAVE=$G(DIC),LRSAVE(0)=$G(DIC(0)),LRSAVE("W")=$G(DIC("W"))
K DIC S DIC(0)="EMZ",X=LRA W !!,"PATIENT: " D EN1^LRDPA K DIC,LRA I LRDFN>0 S A=^LR(LRDFN,0),B=^DIC($P(A,"^",2),0,"GL"),A=$P(A,"^",3),A=@(B_A_",0)"),LRD(1)=$P(A,"^",3),LRP(1)=$P(A,"^") W !,LRP(1)
S DIC=LRSAVE,DIC(0)=LRSAVE(0),DIC("W")=LRSAVE("W")
S LRA="" I LRDFN<1 K X Q
I $D(LRT),LRT="A" D CK Q:'$D(X)
S X=LRDFN Q
CK I LRP(0)'=LRP(1) W $C(7),!!,LRP(0)," does not equal ",LRP(1)," " K X Q
I LRD'=LRD(1) W $C(7),!!,"Dates of birth are different" K X Q
Q
AUTO ;Check for autologous donor in patient file
Q:X["?" W !!,"Donor:",LRP," DOB:",LRB W:LRS(2)]"" " SSN:",LRS(2)
I '$D(^DPT("B",LRP(0))) W $C(7),!,LRP(0)," not entered in PATIENT FILE" K X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUG 877 printed Dec 13, 2024@02:21:33 Page 2
LRUG ;AVAMC/REG/CYM - GET LRDFN ;9/3/97 09:18 ;
+1 ;;5.2;LAB SERVICE;**90**;Sep 27, 1994
+2 SET LRA=X
IF $DATA(LRT)
IF LRT="A"
DO AUTO
if '$DATA(X)
QUIT
+3 NEW LRSAVE
SET LRSAVE=$GET(DIC)
SET LRSAVE(0)=$GET(DIC(0))
SET LRSAVE("W")=$GET(DIC("W"))
+4 KILL DIC
SET DIC(0)="EMZ"
SET X=LRA
WRITE !!,"PATIENT: "
DO EN1^LRDPA
KILL DIC,LRA
IF LRDFN>0
SET A=^LR(LRDFN,0)
SET B=^DIC($PIECE(A,"^",2),0,"GL")
SET A=$PIECE(A,"^",3)
SET A=@(B_A_",0)")
SET LRD(1)=$PIECE(A,"^",3)
SET LRP(1)=$PIECE(A,"^")
WRITE !,LRP(1)
+5 SET DIC=LRSAVE
SET DIC(0)=LRSAVE(0)
SET DIC("W")=LRSAVE("W")
+6 SET LRA=""
IF LRDFN<1
KILL X
QUIT
+7 IF $DATA(LRT)
IF LRT="A"
DO CK
if '$DATA(X)
QUIT
+8 SET X=LRDFN
QUIT
CK IF LRP(0)'=LRP(1)
WRITE $CHAR(7),!!,LRP(0)," does not equal ",LRP(1)," "
KILL X
QUIT
+1 IF LRD'=LRD(1)
WRITE $CHAR(7),!!,"Dates of birth are different"
KILL X
QUIT
+2 QUIT
AUTO ;Check for autologous donor in patient file
+1 if X["?"
QUIT
WRITE !!,"Donor:",LRP," DOB:",LRB
if LRS(2)]""
WRITE " SSN:",LRS(2)
+2 IF '$DATA(^DPT("B",LRP(0)))
WRITE $CHAR(7),!,LRP(0)," not entered in PATIENT FILE"
KILL X
+3 QUIT
