LRDPAREF ;DALOI/FHS - PENDING ORDER FILE PATIENT LOOKUP ; 12/3/1997
;;5.2;LAB SERVICE;**153,222,286**;Sep 27, 1994
; Special patient lookup of Lab Orders Pending File
;
EN ; From ^LRDPA
; Initialize array LRSD.
; CDT=collection date/time
; DFN=ien of patient in selected file
; DOB=patient's date of birth
; DPF=source file (2, or 67)
; ERROR=0
; LPC=longitudinal parity check
; PNM=patient name
; RIEN=IEN of ^LRT(67
; RPSITE=primary sending site
; RSITE=sending site
; RSITEN=sending site name
; RUID=specimen unique identifier
; SEX=patient's sex
; SSN=patient's SSN
; LA7PNM=Patient Bar code read if lookup fails
; On exit LRDPF set to '67^LRT(67, DFN=RIEN
;
N DA,DIC,DIE,DIR,DIRUT,DTOUT,DUOUT
;
K LRSD,LA7PNM
;
F Y="CDT","DFN","DOB","DPF","ERROR","LPC","PNM","RIEN","RPSITE","RSITE","RUID","SEX","SSN" S LRSD(Y)=""
S LREND=0
D:'$D(LRLABKY) LABKEY^LRPARAM
I $G(LRREFBAR) D Q:$G(LREND)
. D BAR K LA7PNM
. I LRSD("ERROR") D
. . D ERRMSG(LRSD("ERROR"),"Barcode error #")
. . I +LRSD("ERROR")=1 D CLEAN
I '$G(LRREFBAR)!(LRSD("ERROR")) D MAN
I $G(LREND) D CLEAN Q
I LRSD("ERROR") D Q
. I LRSD("ERROR") D ERRMSG(LRSD("ERROR"),"Error #")
. D CLEAN
S LRSD("RPSITE")=LRRSITE("RPSITE")
CK ;S PNM=LRSD("PNM"),SSN=LRSD("SSN"),DOB=LRSD("DOB"),SEX=LRSD("SEX"),LRXDPF=LRSD("DPF"),LRXDFN=LRSD("DFN")
D ^LRDPAREX
I $G(LREND)!($G(LRSD("ERROR"))) D G CLEAN
. S LRSD("ERROR",1)="12^Validation Failure "
. W !,$C(7),$P(LRSD("ERROR"),"^",2),!
OK ;
S:'$G(DFN) DFN=-1 S Y=DFN
I DFN=-1 S LRDFN=-1 K DIC S VA200="" Q
S X="^"_$P(LRDPF,"^",2)_Y_",""LR"")",LRDFN=+$S($D(@X):@X,1:-1) G E3:LRDFN>0
L +^LR(0):999999
S LRDFN=$P(^LR(0),U,3) S:LRDFN<1 LRDFN=1
F LRDFN=LRDFN:1 Q:'$D(^LR(LRDFN,0))#2
S ^LR(0)=$P(^LR(0),"^",1,2)_"^"_LRDFN_"^"_(1+$P(^(0),"^",4))
E2 L +^LR(LRDFN):999999
S ^LR(LRDFN,0)=LRDFN_"^"_+LRDPF_"^"_DFN
S ^LR("B",LRDFN,LRDFN)=""
S @X=LRDFN,^LRT(67,LRSD("RIEN"),"LR")=LRDFN
L -(^LR(0),^LR(LRDFN))
E3 I '$D(^LR(LRDFN,0))#2 D Q
. W !!,"Internal patient ID incorrect in ^LR( for ",PNM,"."
. W !,"Contact Lab Coordinator.",$C(7)
. S LRDFN=-1
I LRDFN>0,$P(^LR(LRDFN,0),"^",2)'=+LRDPF!($P(^(0),"^",3)'=DFN) D Q
. W !,$C(7),"Internal patient ID incorrect for ",PNM,"."
. W !,"Contact Lab Coordinator."
. S LRDFN=-1
D INF^LRX,PT^LRX
RUID ;
I LRSD("RUID")="" D
. N DIR,DIRUT,DTOUT,X,Y
. ; If VA facility, require 10 character UID.
. I LRRSITE("RSITE"),$$GET1^DIQ(4,+LRRSITE("RSITE")_",",95,"I")="V" D
. . S DIR(0)="F^10:10^K:X'?1(10N,1U9N,2U8N,1N1U8N) X"
. . S DIR("?")="Enter the sending facility's ten character UID for this specimen"
. E S DIR(0)="F^1:30",DIR("?")="Enter sending facility's specimen ID, 1-30 characters"
. S DIR("A")="Enter Remote UID"
. D ^DIR
. I $D(DIRUT) D CLEAN Q
. S LRSD("RUID")=Y
;
Q
DUP W !?5,"There are duplicate SSNs in the Referral File <abort>",!,$C(7)
ERR ;
S LRDFN=-1 W !,"ERROR",!
Q
;
ERR1 ;
S LRDFN=-1 W !,"ERROR1",!
Q
;
CLEAN ;
S LRDFN=-1,LREND=1
Q
;
;
BAR ; Scan PD bar code for patient/specimen info
;
N DA,DIC,DIR,DIRUT,DR,DTOUT,DUOUT
;
D PT^LA7SBCR1(.LRSD,"Scan Patient/Accession Barcode (PD)",.LRRSITE)
I LRSD("ERROR") Q
D DIQ
Q
;
;
MAN ; Manual referral patient lookup
;
N DIR,DIC,DA,X,Y
K ^DISV(DUZ,"^DPT("),^("^LRT(67,")
;
; Lookup using file #69.6 if manifest exists and not using bar code scanner
I '$G(LRREFBAR),$G(LRRSITE("SMID-OK")),LRRSITE("SMID")'="",$D(^LRO(69.6,"D",LRRSITE("SMID"))) D MF696 Q
;
; Ask user for information
S LRSD("ERROR")=""
S DIR(0)="67,3",DIR("A")="Select Patient Name -'^M' To enter New Name "
D ^DIR
I $D(DIRUT) S LRSD("ERROR")="1^User timeout/abort or Up-arrow entered"
I Y["DPT(" D DPTSET^LA7SBCR1(.LRSD,+Y)
I Y["LRT(" D LRTSET^LA7SBCR1(.LRSD,+Y)
I $E(X,1,2)="^M" D Q
. K DIRUT,DIR
. D KEYIN^LRDPAREX
. S:$G(LREND) LRSD("ERROR")="15^Manual Patient entry not complete"
I LRSD("ERROR") Q
D DIQ K DIR
S DIR(0)="Y",DIR("A")="Is this the correct patient" D ^DIR
I Y'=1 S LRSD("ERROR")="5^Unsuccessful patient lookup" D CLEAN
Q
;
;
MF696 ; Manual lookup of file #69.6
N DIR,DIC,LAIEN,LRSCN696,X,Y
S Y=$$FIND1^DIC(64.061,"","OMX","In-Transit","","I $P(^LAB(64.061,Y,0),U,7)=""U""")
I Y>0 S LRSCN696=+Y
E S LRSCN696=""
S DIR(0)="PO^69.6:NEMQZ"
S DIR("S")="I $P(^(0),U,10)="_LRSCN696_",$D(^LRO(69.6,""D"",LRRSITE(""SMID""),Y))"
S DIR("A")="Enter UID of specimen"
D ^DIR
I $D(DIRUT) S LREND=1 Q
S LAIEN=Y,(LA7Y(0),LAIEN(0))=Y(0)
D GETS^DIQ(69.6,+LAIEN_",","*","IE","LAIEN")
S LRSD("DPF")="67^LRT(67,"
S LRSD("PNM")=LAIEN(69.6,+LAIEN_",",.01,"I")
S LRSD("DOB")=LAIEN(69.6,+LAIEN_",",.03,"I")
S LRSD("SEX")=LAIEN(69.6,+LAIEN_",",.02,"I")
S LRSD("RACE")=LAIEN(69.6,+LAIEN_",",.06,"I")
S LRSD("SSN")=LAIEN(69.6,+LAIEN_",",.09,"I")
S LRSD("CDT")=LAIEN(69.6,+LAIEN_",",11,"I")
S (LRRSITE("RPSITE"),LRSD("RPSITE"))=LAIEN(69.6,+LAIEN_",",1,"I")
S LRSD("RSITE")=LAIEN(69.6,+LAIEN_",",2,"I")
S LRSD("RSITEN")=$E(LAIEN(69.6,+LAIEN_",",2,"E"),1,19)
S LRSD("RUID")=LAIEN(69.6,+LAIEN_",",3,"I")
S LRSD("SMID")=LRRSITE("SMID")
I LRSD("SSN")="" S LRSD("SSN")=LAIEN(69.6,+LAIEN_",",700.04,"I")
I LRSD("SSN")="" S LRSD("ERROR")="2^Patient Identifier Absent" Q
S LRSD("RIEN")=$O(^LRT(67,"C",LRSD("SSN"),0))
I $G(LRSD("RIEN")),$G(^LRT(67,LRSD("RIEN"),"LR")) S LRSD("LRDFN")=^("LR"),LRSD("DFN")=LRSD("RIEN")
Q
;
;
DIQ ; Display patient info
Q:'$G(LRSD("DFN"))
N DA,DIC,DX,S
S DIC=$S(+LRSD("DPF")=2:"^DPT(",+LRSD("DPF")=67:"^LRT(67,",1:"")
I DIC="" Q
S DA=LRSD("DFN"),DR=0,S=0
W @IOF
D EN^LRDIQ
Q
;
ERRMSG(X,Y) ; Display error message to user
; Call with X=error message code^error message text
; Y=message prefix
S X=Y_$P(LRSD("ERROR"),"^")_" - "_$P(LRSD("ERROR"),"^",2)
D EN^DDIOL(X,"","!?5")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRDPAREF 5898 printed Dec 13, 2024@02:14:04 Page 2
LRDPAREF ;DALOI/FHS - PENDING ORDER FILE PATIENT LOOKUP ; 12/3/1997
+1 ;;5.2;LAB SERVICE;**153,222,286**;Sep 27, 1994
+2 ; Special patient lookup of Lab Orders Pending File
+3 ;
EN ; From ^LRDPA
+1 ; Initialize array LRSD.
+2 ; CDT=collection date/time
+3 ; DFN=ien of patient in selected file
+4 ; DOB=patient's date of birth
+5 ; DPF=source file (2, or 67)
+6 ; ERROR=0
+7 ; LPC=longitudinal parity check
+8 ; PNM=patient name
+9 ; RIEN=IEN of ^LRT(67
+10 ; RPSITE=primary sending site
+11 ; RSITE=sending site
+12 ; RSITEN=sending site name
+13 ; RUID=specimen unique identifier
+14 ; SEX=patient's sex
+15 ; SSN=patient's SSN
+16 ; LA7PNM=Patient Bar code read if lookup fails
+17 ; On exit LRDPF set to '67^LRT(67, DFN=RIEN
+18 ;
+19 NEW DA,DIC,DIE,DIR,DIRUT,DTOUT,DUOUT
+20 ;
+21 KILL LRSD,LA7PNM
+22 ;
+23 FOR Y="CDT","DFN","DOB","DPF","ERROR","LPC","PNM","RIEN","RPSITE","RSITE","RUID","SEX","SSN"
SET LRSD(Y)=""
+24 SET LREND=0
+25 if '$DATA(LRLABKY)
DO LABKEY^LRPARAM
+26 IF $GET(LRREFBAR)
Begin DoDot:1
+27 DO BAR
KILL LA7PNM
+28 IF LRSD("ERROR")
Begin DoDot:2
+29 DO ERRMSG(LRSD("ERROR"),"Barcode error #")
+30 IF +LRSD("ERROR")=1
DO CLEAN
End DoDot:2
End DoDot:1
if $GET(LREND)
QUIT
+31 IF '$GET(LRREFBAR)!(LRSD("ERROR"))
DO MAN
+32 IF $GET(LREND)
DO CLEAN
QUIT
+33 IF LRSD("ERROR")
Begin DoDot:1
+34 IF LRSD("ERROR")
DO ERRMSG(LRSD("ERROR"),"Error #")
+35 DO CLEAN
End DoDot:1
QUIT
+36 SET LRSD("RPSITE")=LRRSITE("RPSITE")
CK ;S PNM=LRSD("PNM"),SSN=LRSD("SSN"),DOB=LRSD("DOB"),SEX=LRSD("SEX"),LRXDPF=LRSD("DPF"),LRXDFN=LRSD("DFN")
+1 DO ^LRDPAREX
+2 IF $GET(LREND)!($GET(LRSD("ERROR")))
Begin DoDot:1
+3 SET LRSD("ERROR",1)="12^Validation Failure "
+4 WRITE !,$CHAR(7),$PIECE(LRSD("ERROR"),"^",2),!
End DoDot:1
GOTO CLEAN
OK ;
+1 if '$GET(DFN)
SET DFN=-1
SET Y=DFN
+2 IF DFN=-1
SET LRDFN=-1
KILL DIC
SET VA200=""
QUIT
+3 SET X="^"_$PIECE(LRDPF,"^",2)_Y_",""LR"")"
SET LRDFN=+$SELECT($DATA(@X):@X,1:-1)
if LRDFN>0
GOTO E3
+4 LOCK +^LR(0):999999
+5 SET LRDFN=$PIECE(^LR(0),U,3)
if LRDFN<1
SET LRDFN=1
+6 FOR LRDFN=LRDFN:1
if '$DATA(^LR(LRDFN,0))#2
QUIT
+7 SET ^LR(0)=$PIECE(^LR(0),"^",1,2)_"^"_LRDFN_"^"_(1+$PIECE(^(0),"^",4))
E2 LOCK +^LR(LRDFN):999999
+1 SET ^LR(LRDFN,0)=LRDFN_"^"_+LRDPF_"^"_DFN
+2 SET ^LR("B",LRDFN,LRDFN)=""
+3 SET @X=LRDFN
SET ^LRT(67,LRSD("RIEN"),"LR")=LRDFN
+4 LOCK -(^LR(0),^LR(LRDFN))
E3 IF '$DATA(^LR(LRDFN,0))#2
Begin DoDot:1
+1 WRITE !!,"Internal patient ID incorrect in ^LR( for ",PNM,"."
+2 WRITE !,"Contact Lab Coordinator.",$CHAR(7)
+3 SET LRDFN=-1
End DoDot:1
QUIT
+4 IF LRDFN>0
IF $PIECE(^LR(LRDFN,0),"^",2)'=+LRDPF!($PIECE(^(0),"^",3)'=DFN)
Begin DoDot:1
+5 WRITE !,$CHAR(7),"Internal patient ID incorrect for ",PNM,"."
+6 WRITE !,"Contact Lab Coordinator."
+7 SET LRDFN=-1
End DoDot:1
QUIT
+8 DO INF^LRX
DO PT^LRX
RUID ;
+1 IF LRSD("RUID")=""
Begin DoDot:1
+2 NEW DIR,DIRUT,DTOUT,X,Y
+3 ; If VA facility, require 10 character UID.
+4 IF LRRSITE("RSITE")
IF $$GET1^DIQ(4,+LRRSITE("RSITE")_",",95,"I")="V"
Begin DoDot:2
+5 SET DIR(0)="F^10:10^K:X'?1(10N,1U9N,2U8N,1N1U8N) X"
+6 SET DIR("?")="Enter the sending facility's ten character UID for this specimen"
End DoDot:2
+7 IF '$TEST
SET DIR(0)="F^1:30"
SET DIR("?")="Enter sending facility's specimen ID, 1-30 characters"
+8 SET DIR("A")="Enter Remote UID"
+9 DO ^DIR
+10 IF $DATA(DIRUT)
DO CLEAN
QUIT
+11 SET LRSD("RUID")=Y
End DoDot:1
+12 ;
+13 QUIT
DUP WRITE !?5,"There are duplicate SSNs in the Referral File <abort>",!,$CHAR(7)
ERR ;
+1 SET LRDFN=-1
WRITE !,"ERROR",!
+2 QUIT
+3 ;
ERR1 ;
+1 SET LRDFN=-1
WRITE !,"ERROR1",!
+2 QUIT
+3 ;
CLEAN ;
+1 SET LRDFN=-1
SET LREND=1
+2 QUIT
+3 ;
+4 ;
BAR ; Scan PD bar code for patient/specimen info
+1 ;
+2 NEW DA,DIC,DIR,DIRUT,DR,DTOUT,DUOUT
+3 ;
+4 DO PT^LA7SBCR1(.LRSD,"Scan Patient/Accession Barcode (PD)",.LRRSITE)
+5 IF LRSD("ERROR")
QUIT
+6 DO DIQ
+7 QUIT
+8 ;
+9 ;
MAN ; Manual referral patient lookup
+1 ;
+2 NEW DIR,DIC,DA,X,Y
+3 KILL ^DISV(DUZ,"^DPT("),^("^LRT(67,")
+4 ;
+5 ; Lookup using file #69.6 if manifest exists and not using bar code scanner
+6 IF '$GET(LRREFBAR)
IF $GET(LRRSITE("SMID-OK"))
IF LRRSITE("SMID")'=""
IF $DATA(^LRO(69.6,"D",LRRSITE("SMID")))
DO MF696
QUIT
+7 ;
+8 ; Ask user for information
+9 SET LRSD("ERROR")=""
+10 SET DIR(0)="67,3"
SET DIR("A")="Select Patient Name -'^M' To enter New Name "
+11 DO ^DIR
+12 IF $DATA(DIRUT)
SET LRSD("ERROR")="1^User timeout/abort or Up-arrow entered"
+13 IF Y["DPT("
DO DPTSET^LA7SBCR1(.LRSD,+Y)
+14 IF Y["LRT("
DO LRTSET^LA7SBCR1(.LRSD,+Y)
+15 IF $EXTRACT(X,1,2)="^M"
Begin DoDot:1
+16 KILL DIRUT,DIR
+17 DO KEYIN^LRDPAREX
+18 if $GET(LREND)
SET LRSD("ERROR")="15^Manual Patient entry not complete"
End DoDot:1
QUIT
+19 IF LRSD("ERROR")
QUIT
+20 DO DIQ
KILL DIR
+21 SET DIR(0)="Y"
SET DIR("A")="Is this the correct patient"
DO ^DIR
+22 IF Y'=1
SET LRSD("ERROR")="5^Unsuccessful patient lookup"
DO CLEAN
+23 QUIT
+24 ;
+25 ;
MF696 ; Manual lookup of file #69.6
+1 NEW DIR,DIC,LAIEN,LRSCN696,X,Y
+2 SET Y=$$FIND1^DIC(64.061,"","OMX","In-Transit","","I $P(^LAB(64.061,Y,0),U,7)=""U""")
+3 IF Y>0
SET LRSCN696=+Y
+4 IF '$TEST
SET LRSCN696=""
+5 SET DIR(0)="PO^69.6:NEMQZ"
+6 SET DIR("S")="I $P(^(0),U,10)="_LRSCN696_",$D(^LRO(69.6,""D"",LRRSITE(""SMID""),Y))"
+7 SET DIR("A")="Enter UID of specimen"
+8 DO ^DIR
+9 IF $DATA(DIRUT)
SET LREND=1
QUIT
+10 SET LAIEN=Y
SET (LA7Y(0),LAIEN(0))=Y(0)
+11 DO GETS^DIQ(69.6,+LAIEN_",","*","IE","LAIEN")
+12 SET LRSD("DPF")="67^LRT(67,"
+13 SET LRSD("PNM")=LAIEN(69.6,+LAIEN_",",.01,"I")
+14 SET LRSD("DOB")=LAIEN(69.6,+LAIEN_",",.03,"I")
+15 SET LRSD("SEX")=LAIEN(69.6,+LAIEN_",",.02,"I")
+16 SET LRSD("RACE")=LAIEN(69.6,+LAIEN_",",.06,"I")
+17 SET LRSD("SSN")=LAIEN(69.6,+LAIEN_",",.09,"I")
+18 SET LRSD("CDT")=LAIEN(69.6,+LAIEN_",",11,"I")
+19 SET (LRRSITE("RPSITE"),LRSD("RPSITE"))=LAIEN(69.6,+LAIEN_",",1,"I")
+20 SET LRSD("RSITE")=LAIEN(69.6,+LAIEN_",",2,"I")
+21 SET LRSD("RSITEN")=$EXTRACT(LAIEN(69.6,+LAIEN_",",2,"E"),1,19)
+22 SET LRSD("RUID")=LAIEN(69.6,+LAIEN_",",3,"I")
+23 SET LRSD("SMID")=LRRSITE("SMID")
+24 IF LRSD("SSN")=""
SET LRSD("SSN")=LAIEN(69.6,+LAIEN_",",700.04,"I")
+25 IF LRSD("SSN")=""
SET LRSD("ERROR")="2^Patient Identifier Absent"
QUIT
+26 SET LRSD("RIEN")=$ORDER(^LRT(67,"C",LRSD("SSN"),0))
+27 IF $GET(LRSD("RIEN"))
IF $GET(^LRT(67,LRSD("RIEN"),"LR"))
SET LRSD("LRDFN")=^("LR")
SET LRSD("DFN")=LRSD("RIEN")
+28 QUIT
+29 ;
+30 ;
DIQ ; Display patient info
+1 if '$GET(LRSD("DFN"))
QUIT
+2 NEW DA,DIC,DX,S
+3 SET DIC=$SELECT(+LRSD("DPF")=2:"^DPT(",+LRSD("DPF")=67:"^LRT(67,",1:"")
+4 IF DIC=""
QUIT
+5 SET DA=LRSD("DFN")
SET DR=0
SET S=0
+6 WRITE @IOF
+7 DO EN^LRDIQ
+8 QUIT
+9 ;
ERRMSG(X,Y) ; Display error message to user
+1 ; Call with X=error message code^error message text
+2 ; Y=message prefix
+3 SET X=Y_$PIECE(LRSD("ERROR"),"^")_" - "_$PIECE(LRSD("ERROR"),"^",2)
+4 DO EN^DDIOL(X,"","!?5")
+5 QUIT
