LA7SBCR1 ;DALOI/JMC - Shipping Barcode Reader Utility ; 23 Feb 2004
;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,64**;Sep 27, 1994
Q
;
PT(LA7,LA7PROM,LA7SCFG) ; Setup patient/ordering site info from barcode.
; Input:
; LA7=array to return values
; LA7PROM=array of prompts to display to user
; LA7SCFG=array of shipping configuration info
;
; Returns array LA7()
; If successful DFN=ien of patient in #2, if DPF=2
; DOB=patient's date of birth
; DPF=source file (2, 67, or 537010)
; CDT=collection date/time
; ERROR=0
; PNM=patient name
; RSITE=sending site
; RUID=specimen unique identifier
; SEX=patient's sex
; SSN=patient's SSN
;
; unsuccessful ERROR=>0
;
N LA7BCS,LA7IEN,LA7X,LA7Y,LA7Z,Y
S LA7="",LA7BCS=0,LA7PNM=""
S LA7PROM=$G(LA7PROM,"Patient/Accession Info (PD)")
S Y=$$RD^LA7SBCR(.LA7PROM,1)
;
I Y=0 D Q
. S LA7("ERROR")="1^User timeout/abort"
;
I Y<1 D Q
. S LA7("ERROR")="2^Incorrect bar-code format"
;
; barcode info & longitudinal parity check
; original style bar code
I $E(Y,1,9)="1^STX^PD^" D
. S LA7=$P(Y,"STX^PD^",2)
. S LA7=$P(LA7,"^ETX",1)
. S LA7("LPC")=$P(Y,"^ETX",2)
; new style bar code
I $E(Y,1,5)="1^PD^" D
. S LA7=$P(Y,"^",3,6)
. S LA7("LPC")=$P(Y,"^",7)
. S LA7BCS=1
;
I LA7="" D Q
. S LA7("ERROR")="2^Incorrect bar-code format"
;
I $G(LA7("LPC"))'=$G(LA7SCFG("LPC")) D Q
. S LA7("ERROR")="9^Parity check does not match on (SM) and (PD) barcodes"
;
S LA7("RSITE")=$P(LA7,"^",2)
I LA7("RSITE")'=$P(LA7SCFG("RSITE"),"^",3) D
. S LA7("ERROR")="31^Site in PD barcode does not match shipping configuration file"
;
; Remote specimen identifier
S LA7("RUID")=$P(LA7,"^",3)
;
; Specimen collection date, using either old or new style(LA7BCS=1) bar code
I 'LA7BCS,$P(LA7,"^",5) S LA7("CDT")=$$DT^LA7SBCR($P(LA7,"^",5))
I LA7BCS,$P(LA7,"^",4) S LA7("CDT")=$$DT^LA7SBCR($P(LA7,"^",4))
;
; Patient identifier
S LA7X=$P(LA7,"^") ; Patient's ID
;
; No SSN in first piece
I LA7X="" S LA7("ERROR")="3^No SSN in barcode" Q
S LA7("SSN")=LA7X
;
; Try LAB PENDING ORDERS file
D LPO(.LA7,LA7SCFG("SMID"))
;
; Check for patient in file #2.
I $G(LA7("ERROR")) D DPT(.LA7,LA7X)
;
; Else try Lab Referral file.
I $G(LA7("ERROR")) D LRT(.LA7,LA7X)
;
; Get additional info from PD1 bar code
I +$G(LA7("ERROR"))=4 D PD1
Q
;
;
DPT(LA7,LA7X) ; Lookup in Patient file.
; Check for patient in file #2.
S LA7Y=$O(^DPT("SSN",LA7X,0))
; SSN not found.
I 'LA7Y S LA7("ERROR")="4^Unsuccessful SSN lookup" Q
S LA7Y(0)=$G(^DPT(LA7Y,0))
; SSN not found.
I LA7Y(0)="" S LA7("ERROR")="4^Unsuccessful SSN lookup" Q
;
D DPTSET(.LA7,LA7Y)
Q
;
;
LRT(LA7,LA7X) ; Lookup in Lab Referral file.
; Clear error flag.
S LA7("ERROR")=""
S LA7Y=$O(^LRT(67,"C",LA7X,0))
; SSN not found.
I 'LA7Y S LA7("ERROR")="4^Unsuccessful SSN lookup" Q
S LA7Y(0)=$G(^LRT(67,LA7Y,0))
; SSN not found.
I LA7Y(0)="" S LA7("ERROR")="4^Unsuccessful SSN lookup" Q
D LRTSET(.LA7,LA7Y)
Q
;
;
LPO(LA7,LA7SM) ; Lookup in LAB PENDING ORDERS file #69.6
;
N LA7696,LA7RUID
S LA7RUID=LA7("RUID"),LA7696=""
I LA7SM'="",LA7RUID'="" S LA7696=$O(^LRO(69.6,"AD",LA7SM,LA7RUID,0))
I 'LA7696 S LA7("ERROR")="4^Unsuccessful SSN lookup" Q
D LPOSET(.LA7,LA7696)
Q
;
;
DPTSET(LA7,LA7Y) ; Setup array from Patient file.
;
N RACE,LA7ERR
S LA7Y(0)=$G(^DPT(LA7Y,0))
; Zeroth node not found.
I LA7Y(0)="" S LA7("ERROR")="6^No zeroth node in file" Q
S LA7("DFN")=LA7Y
S LA7("DOB")=$P(LA7Y(0),"^",3)
; Source file
S:LA7Y LA7("DPF")=2_U_"DPT("
S LA7("PNM")=$P(LA7Y(0),"^")
S LA7("RIEN")=+$G(^DPT(LA7Y,"LRT"))
S LA7("SEX")=$P(LA7Y(0),"^",2)
S LA7("SSN")=$P(LA7Y(0),"^",9)
D GETS^DIQ(2,LA7Y_",","2*","I","RACE","LA7ERR")
I '$D(LA7ERR) D
. S X=$Q(RACE(2.02)) Q:X=""
. S LA7("RACE")=$P(@X,"^")
Q
;
;
LRTSET(LA7,LA7Y) ; Setup array from Lab Referral file.
S LA7Y(0)=$G(^LRT(67,LA7Y,0))
; Zeroth node not found.
I LA7Y(0)="" S LA7("ERROR")="6^No zeroth node in file" Q
S LA7("DFN")=LA7Y
S LA7("DOB")=$P(LA7Y(0),"^",3)
;
; Source file
S:LA7Y LA7("DPF")=67_U_"LRT(67,"
;
S LA7("PNM")=$P(LA7Y(0),"^")
S LA7("RIEN")=LA7Y
S LA7("SEX")=$P(LA7Y(0),"^",2)
S LA7("SSN")=$P(LA7Y(0),"^",9)
Q
;
;
LPOSET(LA7,LA7Y) ; Setup array from LAB PENDING ORDERS file #69.6
;
N I
F I=0,.1 S LA7Y(I)=$G(^LRO(69.6,LA7Y,I))
; Zeroth node not found.
I LA7Y(0)="" D Q
. S LA7("ERROR")="6^No zeroth node in file"
; Patient identifiers don't match
I LA7("SSN")'=$P(LA7Y(0),U,9) Q
;
S LA7("PNM")=$P(LA7Y(0),U,1)
S LA7("DOB")=$P(LA7Y(0),U,3)
S LA7("SEX")=$P(LA7Y(0),U,2)
S LA7("DPF")="67^LRT(67,"
S LA7("RACE")=$P(LA7Y(.1),U)
S LA7("ERROR")=""
S LA7("RIEN")=$O(^LRT(67,"C",LA7("SSN"),0))
I $G(LA7("RIEN")),$G(^LRT(67,LA7("RIEN"),"LR")) D
. S LA7("LRDFN")=^LRT(67,LA7("RIEN"),"LR")
. S LA7("DFN")=LA7("RIEN")
Q
;
;
PD1 ; Read PD1 bar code information
;
N LA7PROM
;
S LA7PROM="Scan Patient Name Barcode (PD1)"
S LA7PROM(1)="Patient Demographics not found"
S LA7("ERROR")="",LA7Z=""
S Y=$$RD^LA7SBCR(.LA7PROM,1)
I Y<1 D Q
. S LA7("ERROR")="2^Incorrect bar-code format"
;
; barcode info & longitudinal parity check
; original style bar code
I $E(Y,1,10)="1^STX^PD1^" D
. S LA7Z=$P(Y,"STX^PD1^",2)
. S LA7Z=$P(LA7Z,"^ETX")
. S LA7Z("LPC")=$P(Y,"^ETX",2)
; new style bar code
I $E(Y,1,6)="1^PD1^" D
. S LA7Z=$P(Y,"^",3,6)
. S LA7Z("LPC")=$P(Y,"^",7)
;
I LA7Z="" D Q
. S LA7("ERROR")="2^Incorrect bar-code format"
;
I $G(LA7Z("LPC"))'=$G(LA7SCFG("LPC")) D Q
. S LA7("ERROR")="10^Parity check does not match on (SM) and (PD1) barcodes"
;
; Name not found.
I $L($P(LA7Z,U,2))<2 D Q
. S LA7("ERROR")="21^Unsuccessful name scan"
;
; wrong patient scanned not found.
I $P(LA7Z,U)'=LA7("SSN") D Q
. S LA7("ERROR")="22^SSN does not match PD barcode"
;
; Wrong DOB format.
I $P(LA7Z,U,3)'?7N D Q
. S LA7("ERROR")="23^Incorrect DOB"
;
S LA7("PNM")=$P(LA7Z,U,2)
S LA7("DOB")=$P(LA7Z,U,3)
S LA7("SEX")=$P(LA7Z,U,4)
S LA7("DPF")="67^LRT(67,"
S LA7("ERROR")=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7SBCR1 6331 printed Oct 16, 2024@17:40:12 Page 2
LA7SBCR1 ;DALOI/JMC - Shipping Barcode Reader Utility ; 23 Feb 2004
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,64**;Sep 27, 1994
+2 QUIT
+3 ;
PT(LA7,LA7PROM,LA7SCFG) ; Setup patient/ordering site info from barcode.
+1 ; Input:
+2 ; LA7=array to return values
+3 ; LA7PROM=array of prompts to display to user
+4 ; LA7SCFG=array of shipping configuration info
+5 ;
+6 ; Returns array LA7()
+7 ; If successful DFN=ien of patient in #2, if DPF=2
+8 ; DOB=patient's date of birth
+9 ; DPF=source file (2, 67, or 537010)
+10 ; CDT=collection date/time
+11 ; ERROR=0
+12 ; PNM=patient name
+13 ; RSITE=sending site
+14 ; RUID=specimen unique identifier
+15 ; SEX=patient's sex
+16 ; SSN=patient's SSN
+17 ;
+18 ; unsuccessful ERROR=>0
+19 ;
+20 NEW LA7BCS,LA7IEN,LA7X,LA7Y,LA7Z,Y
+21 SET LA7=""
SET LA7BCS=0
SET LA7PNM=""
+22 SET LA7PROM=$GET(LA7PROM,"Patient/Accession Info (PD)")
+23 SET Y=$$RD^LA7SBCR(.LA7PROM,1)
+24 ;
+25 IF Y=0
Begin DoDot:1
+26 SET LA7("ERROR")="1^User timeout/abort"
End DoDot:1
QUIT
+27 ;
+28 IF Y<1
Begin DoDot:1
+29 SET LA7("ERROR")="2^Incorrect bar-code format"
End DoDot:1
QUIT
+30 ;
+31 ; barcode info & longitudinal parity check
+32 ; original style bar code
+33 IF $EXTRACT(Y,1,9)="1^STX^PD^"
Begin DoDot:1
+34 SET LA7=$PIECE(Y,"STX^PD^",2)
+35 SET LA7=$PIECE(LA7,"^ETX",1)
+36 SET LA7("LPC")=$PIECE(Y,"^ETX",2)
End DoDot:1
+37 ; new style bar code
+38 IF $EXTRACT(Y,1,5)="1^PD^"
Begin DoDot:1
+39 SET LA7=$PIECE(Y,"^",3,6)
+40 SET LA7("LPC")=$PIECE(Y,"^",7)
+41 SET LA7BCS=1
End DoDot:1
+42 ;
+43 IF LA7=""
Begin DoDot:1
+44 SET LA7("ERROR")="2^Incorrect bar-code format"
End DoDot:1
QUIT
+45 ;
+46 IF $GET(LA7("LPC"))'=$GET(LA7SCFG("LPC"))
Begin DoDot:1
+47 SET LA7("ERROR")="9^Parity check does not match on (SM) and (PD) barcodes"
End DoDot:1
QUIT
+48 ;
+49 SET LA7("RSITE")=$PIECE(LA7,"^",2)
+50 IF LA7("RSITE")'=$PIECE(LA7SCFG("RSITE"),"^",3)
Begin DoDot:1
+51 SET LA7("ERROR")="31^Site in PD barcode does not match shipping configuration file"
End DoDot:1
+52 ;
+53 ; Remote specimen identifier
+54 SET LA7("RUID")=$PIECE(LA7,"^",3)
+55 ;
+56 ; Specimen collection date, using either old or new style(LA7BCS=1) bar code
+57 IF 'LA7BCS
IF $PIECE(LA7,"^",5)
SET LA7("CDT")=$$DT^LA7SBCR($PIECE(LA7,"^",5))
+58 IF LA7BCS
IF $PIECE(LA7,"^",4)
SET LA7("CDT")=$$DT^LA7SBCR($PIECE(LA7,"^",4))
+59 ;
+60 ; Patient identifier
+61 ; Patient's ID
SET LA7X=$PIECE(LA7,"^")
+62 ;
+63 ; No SSN in first piece
+64 IF LA7X=""
SET LA7("ERROR")="3^No SSN in barcode"
QUIT
+65 SET LA7("SSN")=LA7X
+66 ;
+67 ; Try LAB PENDING ORDERS file
+68 DO LPO(.LA7,LA7SCFG("SMID"))
+69 ;
+70 ; Check for patient in file #2.
+71 IF $GET(LA7("ERROR"))
DO DPT(.LA7,LA7X)
+72 ;
+73 ; Else try Lab Referral file.
+74 IF $GET(LA7("ERROR"))
DO LRT(.LA7,LA7X)
+75 ;
+76 ; Get additional info from PD1 bar code
+77 IF +$GET(LA7("ERROR"))=4
DO PD1
+78 QUIT
+79 ;
+80 ;
DPT(LA7,LA7X) ; Lookup in Patient file.
+1 ; Check for patient in file #2.
+2 SET LA7Y=$ORDER(^DPT("SSN",LA7X,0))
+3 ; SSN not found.
+4 IF 'LA7Y
SET LA7("ERROR")="4^Unsuccessful SSN lookup"
QUIT
+5 SET LA7Y(0)=$GET(^DPT(LA7Y,0))
+6 ; SSN not found.
+7 IF LA7Y(0)=""
SET LA7("ERROR")="4^Unsuccessful SSN lookup"
QUIT
+8 ;
+9 DO DPTSET(.LA7,LA7Y)
+10 QUIT
+11 ;
+12 ;
LRT(LA7,LA7X) ; Lookup in Lab Referral file.
+1 ; Clear error flag.
+2 SET LA7("ERROR")=""
+3 SET LA7Y=$ORDER(^LRT(67,"C",LA7X,0))
+4 ; SSN not found.
+5 IF 'LA7Y
SET LA7("ERROR")="4^Unsuccessful SSN lookup"
QUIT
+6 SET LA7Y(0)=$GET(^LRT(67,LA7Y,0))
+7 ; SSN not found.
+8 IF LA7Y(0)=""
SET LA7("ERROR")="4^Unsuccessful SSN lookup"
QUIT
+9 DO LRTSET(.LA7,LA7Y)
+10 QUIT
+11 ;
+12 ;
LPO(LA7,LA7SM) ; Lookup in LAB PENDING ORDERS file #69.6
+1 ;
+2 NEW LA7696,LA7RUID
+3 SET LA7RUID=LA7("RUID")
SET LA7696=""
+4 IF LA7SM'=""
IF LA7RUID'=""
SET LA7696=$ORDER(^LRO(69.6,"AD",LA7SM,LA7RUID,0))
+5 IF 'LA7696
SET LA7("ERROR")="4^Unsuccessful SSN lookup"
QUIT
+6 DO LPOSET(.LA7,LA7696)
+7 QUIT
+8 ;
+9 ;
DPTSET(LA7,LA7Y) ; Setup array from Patient file.
+1 ;
+2 NEW RACE,LA7ERR
+3 SET LA7Y(0)=$GET(^DPT(LA7Y,0))
+4 ; Zeroth node not found.
+5 IF LA7Y(0)=""
SET LA7("ERROR")="6^No zeroth node in file"
QUIT
+6 SET LA7("DFN")=LA7Y
+7 SET LA7("DOB")=$PIECE(LA7Y(0),"^",3)
+8 ; Source file
+9 if LA7Y
SET LA7("DPF")=2_U_"DPT("
+10 SET LA7("PNM")=$PIECE(LA7Y(0),"^")
+11 SET LA7("RIEN")=+$GET(^DPT(LA7Y,"LRT"))
+12 SET LA7("SEX")=$PIECE(LA7Y(0),"^",2)
+13 SET LA7("SSN")=$PIECE(LA7Y(0),"^",9)
+14 DO GETS^DIQ(2,LA7Y_",","2*","I","RACE","LA7ERR")
+15 IF '$DATA(LA7ERR)
Begin DoDot:1
+16 SET X=$QUERY(RACE(2.02))
if X=""
QUIT
+17 SET LA7("RACE")=$PIECE(@X,"^")
End DoDot:1
+18 QUIT
+19 ;
+20 ;
LRTSET(LA7,LA7Y) ; Setup array from Lab Referral file.
+1 SET LA7Y(0)=$GET(^LRT(67,LA7Y,0))
+2 ; Zeroth node not found.
+3 IF LA7Y(0)=""
SET LA7("ERROR")="6^No zeroth node in file"
QUIT
+4 SET LA7("DFN")=LA7Y
+5 SET LA7("DOB")=$PIECE(LA7Y(0),"^",3)
+6 ;
+7 ; Source file
+8 if LA7Y
SET LA7("DPF")=67_U_"LRT(67,"
+9 ;
+10 SET LA7("PNM")=$PIECE(LA7Y(0),"^")
+11 SET LA7("RIEN")=LA7Y
+12 SET LA7("SEX")=$PIECE(LA7Y(0),"^",2)
+13 SET LA7("SSN")=$PIECE(LA7Y(0),"^",9)
+14 QUIT
+15 ;
+16 ;
LPOSET(LA7,LA7Y) ; Setup array from LAB PENDING ORDERS file #69.6
+1 ;
+2 NEW I
+3 FOR I=0,.1
SET LA7Y(I)=$GET(^LRO(69.6,LA7Y,I))
+4 ; Zeroth node not found.
+5 IF LA7Y(0)=""
Begin DoDot:1
+6 SET LA7("ERROR")="6^No zeroth node in file"
End DoDot:1
QUIT
+7 ; Patient identifiers don't match
+8 IF LA7("SSN")'=$PIECE(LA7Y(0),U,9)
QUIT
+9 ;
+10 SET LA7("PNM")=$PIECE(LA7Y(0),U,1)
+11 SET LA7("DOB")=$PIECE(LA7Y(0),U,3)
+12 SET LA7("SEX")=$PIECE(LA7Y(0),U,2)
+13 SET LA7("DPF")="67^LRT(67,"
+14 SET LA7("RACE")=$PIECE(LA7Y(.1),U)
+15 SET LA7("ERROR")=""
+16 SET LA7("RIEN")=$ORDER(^LRT(67,"C",LA7("SSN"),0))
+17 IF $GET(LA7("RIEN"))
IF $GET(^LRT(67,LA7("RIEN"),"LR"))
Begin DoDot:1
+18 SET LA7("LRDFN")=^LRT(67,LA7("RIEN"),"LR")
+19 SET LA7("DFN")=LA7("RIEN")
End DoDot:1
+20 QUIT
+21 ;
+22 ;
PD1 ; Read PD1 bar code information
+1 ;
+2 NEW LA7PROM
+3 ;
+4 SET LA7PROM="Scan Patient Name Barcode (PD1)"
+5 SET LA7PROM(1)="Patient Demographics not found"
+6 SET LA7("ERROR")=""
SET LA7Z=""
+7 SET Y=$$RD^LA7SBCR(.LA7PROM,1)
+8 IF Y<1
Begin DoDot:1
+9 SET LA7("ERROR")="2^Incorrect bar-code format"
End DoDot:1
QUIT
+10 ;
+11 ; barcode info & longitudinal parity check
+12 ; original style bar code
+13 IF $EXTRACT(Y,1,10)="1^STX^PD1^"
Begin DoDot:1
+14 SET LA7Z=$PIECE(Y,"STX^PD1^",2)
+15 SET LA7Z=$PIECE(LA7Z,"^ETX")
+16 SET LA7Z("LPC")=$PIECE(Y,"^ETX",2)
End DoDot:1
+17 ; new style bar code
+18 IF $EXTRACT(Y,1,6)="1^PD1^"
Begin DoDot:1
+19 SET LA7Z=$PIECE(Y,"^",3,6)
+20 SET LA7Z("LPC")=$PIECE(Y,"^",7)
End DoDot:1
+21 ;
+22 IF LA7Z=""
Begin DoDot:1
+23 SET LA7("ERROR")="2^Incorrect bar-code format"
End DoDot:1
QUIT
+24 ;
+25 IF $GET(LA7Z("LPC"))'=$GET(LA7SCFG("LPC"))
Begin DoDot:1
+26 SET LA7("ERROR")="10^Parity check does not match on (SM) and (PD1) barcodes"
End DoDot:1
QUIT
+27 ;
+28 ; Name not found.
+29 IF $LENGTH($PIECE(LA7Z,U,2))<2
Begin DoDot:1
+30 SET LA7("ERROR")="21^Unsuccessful name scan"
End DoDot:1
QUIT
+31 ;
+32 ; wrong patient scanned not found.
+33 IF $PIECE(LA7Z,U)'=LA7("SSN")
Begin DoDot:1
+34 SET LA7("ERROR")="22^SSN does not match PD barcode"
End DoDot:1
QUIT
+35 ;
+36 ; Wrong DOB format.
+37 IF $PIECE(LA7Z,U,3)'?7N
Begin DoDot:1
+38 SET LA7("ERROR")="23^Incorrect DOB"
End DoDot:1
QUIT
+39 ;
+40 SET LA7("PNM")=$PIECE(LA7Z,U,2)
+41 SET LA7("DOB")=$PIECE(LA7Z,U,3)
+42 SET LA7("SEX")=$PIECE(LA7Z,U,4)
+43 SET LA7("DPF")="67^LRT(67,"
+44 SET LA7("ERROR")=""
+45 QUIT
