LRDPAREX ;DALOI/FHS -VALIDATE PENDING ORDER FILE PATIENT LOOKUP ; Feb 18, 2004
;;5.2;LAB SERVICE;**153,286**;Sep 27, 1994
; Special patient lookup of Lab Orders Pending File
; From ^LRDPAREF after patient selection
; Initialize array.
; CDT=collection date/time
; DFN=ien of patient in selected file
; DOB=patient's date of birth
; DPF=67^LRT(67,
; LRXDPF=source file (2,67)
; ERROR=0
; 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
EN ;
N DA,DIC,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,DLAYGO
S PNM=LRSD("PNM"),SSN=LRSD("SSN"),DOB=LRSD("DOB"),SEX=LRSD("SEX")
;
S LRXDPF=LRSD("DPF"),LRXDFN=LRSD("DFN"),LRDPF="67^LRT(67,"
;
I +LRXDPF=67,$G(LRXDFN) D Q
. S DFN=LRXDFN
. D UPDATE
;
I LRSD("RIEN"),'$D(^LRT(67,+LRSD("RIEN"),0))#2 S LRSD("ERROR")="16^Missing pointed to LRT(67,"_LRSD("RIEN")_",0)" Q
;
I LRSD("RIEN") D Q
. I +LRXDPF=2,LRXDFN'=$G(^LRT(67,LRSD("RIEN"),"DPT")) S LREND=1,LRSD("ERROR")="10^Database Degrade "
. I '$G(LREND) D UPDATE
;
I 'LRSD("RIEN") S LRSD("RIEN")=$O(^LRT(67,"C",SSN,0)) I LRSD("RIEN"),$O(^(LRSD("RIEN"))) D DUP Q
;
I LRSD("RIEN") D Q
. I '$D(^LRT(67,LRSD("RIEN"),0)) D Q
. . K ^LRT(67,"C",SSN,LRSD("RIEN"))
. . S LRSD("ERROR")="13^Missing Zero Node for "_LRSD("RIEN")_" SSN X Ref Entry Removed"
. D LINK Q:$G(LREND)
. I +LRXDPF=2 S X="^"_$P(LRXDPF,"^",2)_LRXDFN_",""LRT"")",@X=LRSD("RIEN")
;
I 'LRSD("RIEN") D SET G ERR:LREND
S DFN=LRSD("RIEN"),LRDPF="67^LRT(67,"
END ;
Q
;
;
SET ;Create new entry in ^LRT(67
I +$G(LRXDPF)'=67,LRXDFN<1 D Q
. S LREND=1,LRSD("ERROR")="14^No LRXDFN defined"
;
SET1 N DIC,DIE,DA,Y
L +^LRT(67,0):999
S DIC(0)="L",DLAYGO=67
S X=PNM,DIC="^LRT(67,"
S DIC("DR")=".01////"_PNM_";.02////"_SEX_";.03////"_DOB_";.09////"_SSN
I $G(LRSD("RACE"))'="" D RACE
S:+LRXDPF=2 DIC("DR")=DIC("DR")_";2////"_LRXDFN
K DD,DO
D FILE^DICN K DLAYGO
L -^LRT(67,0)
I Y<1 S LREND=1,LRSB("ERROR")="11^Failure attempting to add patient to LRT(67)",LRDFN=-1 Q
S LRSD("RIEN")=+Y S:+LRXDPF=2 ^DPT(LRXDFN,"LRT")=LRSD("RIEN")
S (DFN,LRSD("RIEN"))=+Y S LRSD("ERROR")=""
Q
;
;
LINK ; Create back pointer for existing LRT(67 entries
N DA,DIC,DIE,DR
S (DFN,DA)=LRSD("RIEN") L +^LRT(67,DA)
S DIC(0)="LMN",DIE="^LRT(67,"
S DR=".01////"_PNM_";.02////"_SEX_";.03////"_DOB_";.09////"_SSN
I $G(LRSD("RACE"))'="" D RACE
S:+LRXDPF=2 DR=DR_";2////"_LRXDFN
S DIC=DIE D ^DIE S LREND=+$G(Y) L -^LRT(67,LRSD("RIEN"))
I LREND S DFN=-1,LRSD("ERROR")="17^ Unable to link "_LRSD("RIEN") Q
Q
;
;
UPDATE ; Store updated demographics
N DA,DR,DIE,DIC,RACE
S (DFN,DA)=LRSD("RIEN")
S DIE="^LRT(67,"
S DR=".01////"_PNM_";.02////"_SEX_";.03////"_DOB_";.09////"_SSN
I $G(LRSD("RACE"))'="" D RACE
D ^DIE S LREND=+$G(Y)
I LREND S DFN=-1,LRSD("ERROR")="18^Unable to update demographics" Q
Q
;
;
ERR1 W !?5,"Error1 ",!
Q
;
ERR W !?5,"Error ",!
Q
;
;
DUP ;
S LRSD("ERROR")="15^Duplicate "_SSN_" SSN nunbers in LRT(67 ",LREND=1
W !?5,$P(LRSD("ERROR"),U,2)
Q
;
;
KEYIN ;
S LRSD("ERROR")="16^Error During Manual Patient Entry"
W !!?30,"Manual Referral Patient Entry",!!
K DIR
S DIR(0)="F^9:12^K:X?1""-""!(X'?1N.N)!(X?1"" "") X I $D(X),$D(^LRT(67,""C"",X)) W !!?15,X,"" Already Exist"" K X"
S DIR("A")="Patient ID (SSN)",DIR("?")="Enter New Patient ID Nunber "
S DIR("?",1)="9-12 Number string '-' character or duplicates are Not allowed"
D RDDIR Q:LREND
S (LRSD("SSN"),SSN)=Y,Y=0
K DIR S DIR(0)="67,.01",DIR("A")="Patient Name"
D RDDIR Q:LREND S (LRSD("PNM"),PNM)=Y
;
K DIR S DIR(0)="67,.02" D RDDIR Q:LREND S (LRSD("SEX"),SEX)=Y
K DIR S DIR(0)="67,.03" D RDDIR Q:LREND S (LRSD("DOB"),DOB)=Y
S (LRXDPF,LRSD("LRXDPF"))="67^LRT(67," D SET1
Q
;
;
RDDIR ;
S LREND=0
D ^DIR
S:$D(DUOUT)!($D(DTOUT)) LREND=1 K DIR
S:Y="" LREND=1
Q
;
;
RACE ; Resolve race pointer
N RACE
S RACE=""
I $P(LRSD("RACE"),":",3)="" S RACE=$$CODE2PTR^DGUTL4(+LRSD("RACE"),1,1)
I $P(LRSD("RACE"),":",3)="HL70005" S RACE=$$CODE2PTR^DGUTL4($P($P(LRSD("RACE"),":"),"-",1,2),1,2)
I RACE>0 D
. I $D(DR) S DR=DR_";.06////"_RACE Q
. I $D(DIC("DR")) S DIC("DR")=DIC("DR")_";.06////"_RACE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRDPAREX 4358 printed Apr 09, 2024@21:22:45 Page 2
LRDPAREX ;DALOI/FHS -VALIDATE PENDING ORDER FILE PATIENT LOOKUP ; Feb 18, 2004
+1 ;;5.2;LAB SERVICE;**153,286**;Sep 27, 1994
+2 ; Special patient lookup of Lab Orders Pending File
+3 ; From ^LRDPAREF after patient selection
+4 ; Initialize array.
+5 ; CDT=collection date/time
+6 ; DFN=ien of patient in selected file
+7 ; DOB=patient's date of birth
+8 ; DPF=67^LRT(67,
+9 ; LRXDPF=source file (2,67)
+10 ; ERROR=0
+11 ; PNM=patient name
+12 ; RIEN=IEN of ^LRT(67
+13 ; RPSITE=primary sending site
+14 ; RSITE=sending site
+15 ; RSITEN=sending site name
+16 ; RUID=specimen unique identifier
+17 ; SEX=patient's sex
+18 ; SSN=patient's SSN
EN ;
+1 NEW DA,DIC,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,DLAYGO
+2 SET PNM=LRSD("PNM")
SET SSN=LRSD("SSN")
SET DOB=LRSD("DOB")
SET SEX=LRSD("SEX")
+3 ;
+4 SET LRXDPF=LRSD("DPF")
SET LRXDFN=LRSD("DFN")
SET LRDPF="67^LRT(67,"
+5 ;
+6 IF +LRXDPF=67
IF $GET(LRXDFN)
Begin DoDot:1
+7 SET DFN=LRXDFN
+8 DO UPDATE
End DoDot:1
QUIT
+9 ;
+10 IF LRSD("RIEN")
IF '$DATA(^LRT(67,+LRSD("RIEN"),0))#2
SET LRSD("ERROR")="16^Missing pointed to LRT(67,"_LRSD("RIEN")_",0)"
QUIT
+11 ;
+12 IF LRSD("RIEN")
Begin DoDot:1
+13 IF +LRXDPF=2
IF LRXDFN'=$GET(^LRT(67,LRSD("RIEN"),"DPT"))
SET LREND=1
SET LRSD("ERROR")="10^Database Degrade "
+14 IF '$GET(LREND)
DO UPDATE
End DoDot:1
QUIT
+15 ;
+16 IF 'LRSD("RIEN")
SET LRSD("RIEN")=$ORDER(^LRT(67,"C",SSN,0))
IF LRSD("RIEN")
IF $ORDER(^(LRSD("RIEN")))
DO DUP
QUIT
+17 ;
+18 IF LRSD("RIEN")
Begin DoDot:1
+19 IF '$DATA(^LRT(67,LRSD("RIEN"),0))
Begin DoDot:2
+20 KILL ^LRT(67,"C",SSN,LRSD("RIEN"))
+21 SET LRSD("ERROR")="13^Missing Zero Node for "_LRSD("RIEN")_" SSN X Ref Entry Removed"
End DoDot:2
QUIT
+22 DO LINK
if $GET(LREND)
QUIT
+23 IF +LRXDPF=2
SET X="^"_$PIECE(LRXDPF,"^",2)_LRXDFN_",""LRT"")"
SET @X=LRSD("RIEN")
End DoDot:1
QUIT
+24 ;
+25 IF 'LRSD("RIEN")
DO SET
if LREND
GOTO ERR
+26 SET DFN=LRSD("RIEN")
SET LRDPF="67^LRT(67,"
END ;
+1 QUIT
+2 ;
+3 ;
SET ;Create new entry in ^LRT(67
+1 IF +$GET(LRXDPF)'=67
IF LRXDFN<1
Begin DoDot:1
+2 SET LREND=1
SET LRSD("ERROR")="14^No LRXDFN defined"
End DoDot:1
QUIT
+3 ;
SET1 NEW DIC,DIE,DA,Y
+1 LOCK +^LRT(67,0):999
+2 SET DIC(0)="L"
SET DLAYGO=67
+3 SET X=PNM
SET DIC="^LRT(67,"
+4 SET DIC("DR")=".01////"_PNM_";.02////"_SEX_";.03////"_DOB_";.09////"_SSN
+5 IF $GET(LRSD("RACE"))'=""
DO RACE
+6 if +LRXDPF=2
SET DIC("DR")=DIC("DR")_";2////"_LRXDFN
+7 KILL DD,DO
+8 DO FILE^DICN
KILL DLAYGO
+9 LOCK -^LRT(67,0)
+10 IF Y<1
SET LREND=1
SET LRSB("ERROR")="11^Failure attempting to add patient to LRT(67)"
SET LRDFN=-1
QUIT
+11 SET LRSD("RIEN")=+Y
if +LRXDPF=2
SET ^DPT(LRXDFN,"LRT")=LRSD("RIEN")
+12 SET (DFN,LRSD("RIEN"))=+Y
SET LRSD("ERROR")=""
+13 QUIT
+14 ;
+15 ;
LINK ; Create back pointer for existing LRT(67 entries
+1 NEW DA,DIC,DIE,DR
+2 SET (DFN,DA)=LRSD("RIEN")
LOCK +^LRT(67,DA)
+3 SET DIC(0)="LMN"
SET DIE="^LRT(67,"
+4 SET DR=".01////"_PNM_";.02////"_SEX_";.03////"_DOB_";.09////"_SSN
+5 IF $GET(LRSD("RACE"))'=""
DO RACE
+6 if +LRXDPF=2
SET DR=DR_";2////"_LRXDFN
+7 SET DIC=DIE
DO ^DIE
SET LREND=+$GET(Y)
LOCK -^LRT(67,LRSD("RIEN"))
+8 IF LREND
SET DFN=-1
SET LRSD("ERROR")="17^ Unable to link "_LRSD("RIEN")
QUIT
+9 QUIT
+10 ;
+11 ;
UPDATE ; Store updated demographics
+1 NEW DA,DR,DIE,DIC,RACE
+2 SET (DFN,DA)=LRSD("RIEN")
+3 SET DIE="^LRT(67,"
+4 SET DR=".01////"_PNM_";.02////"_SEX_";.03////"_DOB_";.09////"_SSN
+5 IF $GET(LRSD("RACE"))'=""
DO RACE
+6 DO ^DIE
SET LREND=+$GET(Y)
+7 IF LREND
SET DFN=-1
SET LRSD("ERROR")="18^Unable to update demographics"
QUIT
+8 QUIT
+9 ;
+10 ;
ERR1 WRITE !?5,"Error1 ",!
+1 QUIT
+2 ;
ERR WRITE !?5,"Error ",!
+1 QUIT
+2 ;
+3 ;
DUP ;
+1 SET LRSD("ERROR")="15^Duplicate "_SSN_" SSN nunbers in LRT(67 "
SET LREND=1
+2 WRITE !?5,$PIECE(LRSD("ERROR"),U,2)
+3 QUIT
+4 ;
+5 ;
KEYIN ;
+1 SET LRSD("ERROR")="16^Error During Manual Patient Entry"
+2 WRITE !!?30,"Manual Referral Patient Entry",!!
+3 KILL DIR
+4 SET DIR(0)="F^9:12^K:X?1""-""!(X'?1N.N)!(X?1"" "") X I $D(X),$D(^LRT(67,""C"",X)) W !!?15,X,"" Already Exist"" K X"
+5 SET DIR("A")="Patient ID (SSN)"
SET DIR("?")="Enter New Patient ID Nunber "
+6 SET DIR("?",1)="9-12 Number string '-' character or duplicates are Not allowed"
+7 DO RDDIR
if LREND
QUIT
+8 SET (LRSD("SSN"),SSN)=Y
SET Y=0
+9 KILL DIR
SET DIR(0)="67,.01"
SET DIR("A")="Patient Name"
+10 DO RDDIR
if LREND
QUIT
SET (LRSD("PNM"),PNM)=Y
+11 ;
+12 KILL DIR
SET DIR(0)="67,.02"
DO RDDIR
if LREND
QUIT
SET (LRSD("SEX"),SEX)=Y
+13 KILL DIR
SET DIR(0)="67,.03"
DO RDDIR
if LREND
QUIT
SET (LRSD("DOB"),DOB)=Y
+14 SET (LRXDPF,LRSD("LRXDPF"))="67^LRT(67,"
DO SET1
+15 QUIT
+16 ;
+17 ;
RDDIR ;
+1 SET LREND=0
+2 DO ^DIR
+3 if $DATA(DUOUT)!($DATA(DTOUT))
SET LREND=1
KILL DIR
+4 if Y=""
SET LREND=1
+5 QUIT
+6 ;
+7 ;
RACE ; Resolve race pointer
+1 NEW RACE
+2 SET RACE=""
+3 IF $PIECE(LRSD("RACE"),":",3)=""
SET RACE=$$CODE2PTR^DGUTL4(+LRSD("RACE"),1,1)
+4 IF $PIECE(LRSD("RACE"),":",3)="HL70005"
SET RACE=$$CODE2PTR^DGUTL4($PIECE($PIECE(LRSD("RACE"),":"),"-",1,2),1,2)
+5 IF RACE>0
Begin DoDot:1
+6 IF $DATA(DR)
SET DR=DR_";.06////"_RACE
QUIT
+7 IF $DATA(DIC("DR"))
SET DIC("DR")=DIC("DR")_";.06////"_RACE
End DoDot:1
+8 QUIT
