source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRDPAREX.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1LRDPAREX ;DALOI/FHS -VALIDATE PENDING ORDER FILE PATIENT LOOKUP ; Feb 18, 2004
2 ;;5.2;LAB SERVICE;**153,286**;Sep 27, 1994
3 ; Special patient lookup of Lab Orders Pending File
4 ; From ^LRDPAREF after patient selection
5 ; Initialize array.
6 ; CDT=collection date/time
7 ; DFN=ien of patient in selected file
8 ; DOB=patient's date of birth
9 ; DPF=67^LRT(67,
10 ; LRXDPF=source file (2,67)
11 ; ERROR=0
12 ; PNM=patient name
13 ; RIEN=IEN of ^LRT(67
14 ; RPSITE=primary sending site
15 ; RSITE=sending site
16 ; RSITEN=sending site name
17 ; RUID=specimen unique identifier
18 ; SEX=patient's sex
19 ; SSN=patient's SSN
20EN ;
21 N DA,DIC,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,DLAYGO
22 S PNM=LRSD("PNM"),SSN=LRSD("SSN"),DOB=LRSD("DOB"),SEX=LRSD("SEX")
23 ;
24 S LRXDPF=LRSD("DPF"),LRXDFN=LRSD("DFN"),LRDPF="67^LRT(67,"
25 ;
26 I +LRXDPF=67,$G(LRXDFN) D Q
27 . S DFN=LRXDFN
28 . D UPDATE
29 ;
30 I LRSD("RIEN"),'$D(^LRT(67,+LRSD("RIEN"),0))#2 S LRSD("ERROR")="16^Missing pointed to LRT(67,"_LRSD("RIEN")_",0)" Q
31 ;
32 I LRSD("RIEN") D Q
33 . I +LRXDPF=2,LRXDFN'=$G(^LRT(67,LRSD("RIEN"),"DPT")) S LREND=1,LRSD("ERROR")="10^Database Degrade "
34 . I '$G(LREND) D UPDATE
35 ;
36 I 'LRSD("RIEN") S LRSD("RIEN")=$O(^LRT(67,"C",SSN,0)) I LRSD("RIEN"),$O(^(LRSD("RIEN"))) D DUP Q
37 ;
38 I LRSD("RIEN") D Q
39 . I '$D(^LRT(67,LRSD("RIEN"),0)) D Q
40 . . K ^LRT(67,"C",SSN,LRSD("RIEN"))
41 . . S LRSD("ERROR")="13^Missing Zero Node for "_LRSD("RIEN")_" SSN X Ref Entry Removed"
42 . D LINK Q:$G(LREND)
43 . I +LRXDPF=2 S X="^"_$P(LRXDPF,"^",2)_LRXDFN_",""LRT"")",@X=LRSD("RIEN")
44 ;
45 I 'LRSD("RIEN") D SET G ERR:LREND
46 S DFN=LRSD("RIEN"),LRDPF="67^LRT(67,"
47END ;
48 Q
49 ;
50 ;
51SET ;Create new entry in ^LRT(67
52 I +$G(LRXDPF)'=67,LRXDFN<1 D Q
53 . S LREND=1,LRSD("ERROR")="14^No LRXDFN defined"
54 ;
55SET1 N DIC,DIE,DA,Y
56 L +^LRT(67,0):999
57 S DIC(0)="L",DLAYGO=67
58 S X=PNM,DIC="^LRT(67,"
59 S DIC("DR")=".01////"_PNM_";.02////"_SEX_";.03////"_DOB_";.09////"_SSN
60 I $G(LRSD("RACE"))'="" D RACE
61 S:+LRXDPF=2 DIC("DR")=DIC("DR")_";2////"_LRXDFN
62 K DD,DO
63 D FILE^DICN K DLAYGO
64 L -^LRT(67,0)
65 I Y<1 S LREND=1,LRSB("ERROR")="11^Failure attempting to add patient to LRT(67)",LRDFN=-1 Q
66 S LRSD("RIEN")=+Y S:+LRXDPF=2 ^DPT(LRXDFN,"LRT")=LRSD("RIEN")
67 S (DFN,LRSD("RIEN"))=+Y S LRSD("ERROR")=""
68 Q
69 ;
70 ;
71LINK ; Create back pointer for existing LRT(67 entries
72 N DA,DIC,DIE,DR
73 S (DFN,DA)=LRSD("RIEN") L +^LRT(67,DA)
74 S DIC(0)="LMN",DIE="^LRT(67,"
75 S DR=".01////"_PNM_";.02////"_SEX_";.03////"_DOB_";.09////"_SSN
76 I $G(LRSD("RACE"))'="" D RACE
77 S:+LRXDPF=2 DR=DR_";2////"_LRXDFN
78 S DIC=DIE D ^DIE S LREND=+$G(Y) L -^LRT(67,LRSD("RIEN"))
79 I LREND S DFN=-1,LRSD("ERROR")="17^ Unable to link "_LRSD("RIEN") Q
80 Q
81 ;
82 ;
83UPDATE ; Store updated demographics
84 N DA,DR,DIE,DIC,RACE
85 S (DFN,DA)=LRSD("RIEN")
86 S DIE="^LRT(67,"
87 S DR=".01////"_PNM_";.02////"_SEX_";.03////"_DOB_";.09////"_SSN
88 I $G(LRSD("RACE"))'="" D RACE
89 D ^DIE S LREND=+$G(Y)
90 I LREND S DFN=-1,LRSD("ERROR")="18^Unable to update demographics" Q
91 Q
92 ;
93 ;
94ERR1 W !?5,"Error1 ",!
95 Q
96 ;
97ERR W !?5,"Error ",!
98 Q
99 ;
100 ;
101DUP ;
102 S LRSD("ERROR")="15^Duplicate "_SSN_" SSN nunbers in LRT(67 ",LREND=1
103 W !?5,$P(LRSD("ERROR"),U,2)
104 Q
105 ;
106 ;
107KEYIN ;
108 S LRSD("ERROR")="16^Error During Manual Patient Entry"
109 W !!?30,"Manual Referral Patient Entry",!!
110 K DIR
111 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"
112 S DIR("A")="Patient ID (SSN)",DIR("?")="Enter New Patient ID Nunber "
113 S DIR("?",1)="9-12 Number string '-' character or duplicates are Not allowed"
114 D RDDIR Q:LREND
115 S (LRSD("SSN"),SSN)=Y,Y=0
116 K DIR S DIR(0)="67,.01",DIR("A")="Patient Name"
117 D RDDIR Q:LREND S (LRSD("PNM"),PNM)=Y
118 ;
119 K DIR S DIR(0)="67,.02" D RDDIR Q:LREND S (LRSD("SEX"),SEX)=Y
120 K DIR S DIR(0)="67,.03" D RDDIR Q:LREND S (LRSD("DOB"),DOB)=Y
121 S (LRXDPF,LRSD("LRXDPF"))="67^LRT(67," D SET1
122 Q
123 ;
124 ;
125RDDIR ;
126 S LREND=0
127 D ^DIR
128 S:$D(DUOUT)!($D(DTOUT)) LREND=1 K DIR
129 S:Y="" LREND=1
130 Q
131 ;
132 ;
133RACE ; Resolve race pointer
134 N RACE
135 S RACE=""
136 I $P(LRSD("RACE"),":",3)="" S RACE=$$CODE2PTR^DGUTL4(+LRSD("RACE"),1,1)
137 I $P(LRSD("RACE"),":",3)="HL70005" S RACE=$$CODE2PTR^DGUTL4($P($P(LRSD("RACE"),":"),"-",1,2),1,2)
138 I RACE>0 D
139 . I $D(DR) S DR=DR_";.06////"_RACE Q
140 . I $D(DIC("DR")) S DIC("DR")=DIC("DR")_";.06////"_RACE
141 Q
Note: See TracBrowser for help on using the repository browser.