source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAC14.m@ 1604

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

initial load of WorldVistAEHR

File size: 3.3 KB
Line 
1LRAC14 ;DALOI/DH/RLM-FIND LOCATION FOR MULTIPLE ABBREVIATION ;6/16/97 15:45
2 ;;5.2;LAB SERVICE;**272**;SEP 27, 1994
3 ; Reference to ^SC( supported by IA # 908
4 ; Reference to ^%DTC supported by IA # 10000
5 ; Reference to ^VADPT supported by IA # 10061
6 ; Reference to ^XMD supported by IA # 10070
7INIT ;
8 Q:'$D(LRLLOC)
9 S LRODT=DT
10 Q:'$D(^LAB(64.58,"C"))
11 I '$G(LRLLIN) S LRLLIN=0
12 ;S LRLLIN=$O(^LAB(64.58,"C",LRLLOC,LRLLIN))
13 ;I +$G(LRLLIN)>0 QUIT
14CNT S LRCNT9=$G(LRCNT9)+1
15 Q:'$G(LRDT)
16 S LRODT=LRDT
17 Q:'$D(^LRO(69,LRODT,1,"AR",LRLLOC))
18 S PNM1=$O(^LRO(69,LRODT,1,"AR",LRLLOC,""))
19 Q:'$D(^LRO(69,LRODT,1,"AR",LRLLOC,PNM1))
20 S LRDFN1=$O(^LRO(69,LRODT,1,"AR",LRLLOC,PNM1,0))
21 S DFN=$P(^LR(LRDFN1,0),U,3) D ^VADPT
22 Q:'$D(^LRO(69,LRODT,1,"AR",LRLLOC,PNM1,LRDFN1))
23 D CH D MI D BB D SP
24 ; ^LR(50954,"CH",7029381.94999,0) = 2970617.05001^^^^71^WUA 0616 30^^^^36560^WMHC
25CH ;
26 S LRSUB="CH" D LR
27 D MAIL
28 K LRNODE
29 Q:LRLLIN=0 ;--> This happens when location is UNKNOWN
30MI ;
31 Q:$G(LRLLIN)>0
32 S LRSUB="MI" D LR
33 Q
34BB ;
35 Q:$G(LRLLIN)>0
36 S LRSUB="BB" D LR
37 Q
38SP ;
39 Q:$G(LRLLIN)>0
40 S LRSUB="SP" D LR
41 Q
42LR ;
43 Q:'$D(^LR(LRDFN1,LRSUB))
44 S LRIDT=$O(^LRO(69,LRODT,1,"AN",LRLLOC,LRDFN1,0)) Q:+LRIDT'>0 D
45 . I $D(^LR(LRDFN1,LRSUB,LRIDT,0)) S LRNODE=^LR(LRDFN1,LRSUB,LRIDT,0)
46 . Q:$G(LRNODE)=""
47 . S LRAD=9999999-LRIDT
48 . S LRAD=$P(LRAD,".")
49 . S LRACCN=$P(LRNODE,U,6)
50 . S LRAAN=$P(LRACCN," ") S LRAA=$O(^LRO(68,"B",LRAAN,0))
51 . Q:LRAA=""
52 . S LRAD=$S(LRSUB'="CH":$E(LRAD,1,3)_"0000",1:$E(LRAD,1,3)_$P(LRACCN," ",2))
53 . S LRAN=+$P(LRNODE," ",3)
54 . Q:LRAN'>0
55 . Q:LRAA'>0!(LRAD'>0)
56 . Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D LRO
57 ;
58 ;D END
59 Q
60LRO ;
61 S LRLLIN=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,13)
62 ;W !,^SC(LRLLIN,0)
63 ;K LRLLIN
64 I '$G(LRLLIN) S ^TMP("LR","NO-LRLLIN",LRACCN,LRLLOC)="" D LRO69
65 Q
66LRO69 ;
67 I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S LRNODE=^(0) D
68 . S LRODT=$P(LRNODE,U,4),LRSN=$P(LRNODE,U,5)
69 . Q:$G(LRSN)'>0
70 . Q:'$D(^LRO(69,LRODT,1,LRSN,0))
71 . S LRLLIN=$P(^LRO(69,LRODT,1,LRSN,0),U,9)
72 ;K LRLLIN
73 I '$G(LRLLIN) D
74 . I '$G(PNM) S PNM=PNM1
75 . D PT^LRX S LRDATA=$G(PNM1)_U_$G(SSN)_U_$G(LRODT)_U_$G(DFN)
76 . S ^TMP("LR","LR-NO-LOC",LRLLOC)=LRDATA ;--->Send message
77 . D MAIL
78 Q
79MAIL ;
80 ; Send a message to entries in G.LMI if the
81 ; location can't be found in ^SC
82 I $G(DUZ)'>0 S LRDUZ2=.5
83 I $G(LRDUZ2)'>0 S LRDUZ2=.5
84 S Y=0
85 S XMY("G.LMI")="" D
86 . S XMDUZ=LRDUZ2
87 . S XMTEXT="LRTXT("
88 . S LRTXT(1)="Flash... Have a problem with: "_$G(LRLLOC)_" "_$G(VADM(1))_" "_$G(VADM(2))_" For "_$G(LRODT)
89 . I $G(LRLLIN) S LRTXT(2)="I think it might be: "_$G(^SC(LRLLIN,0))
90 . S XMSUB="Problem resolving locations for cumulative."
91 . D ^XMD
92 QUIT
93END ;
94 QUIT
95 K LRCNTCUM,LRSUB,LRDFN1,LRIDT,LRAD,LRAA,LRAN,LRACCN,LRAAN,LRODT,LRDUZ2
96 K LRTXT,LRTIME0,LRTIME9
97 Q
98LOOK ;
99 S X=0
100 D NOW^%DTC S LRTIME0=%
101 S X=0
102 F S X=$O(^LAC("LRAC",X)) Q:X=""
103 D NOW^%DTC S LRTIME9=%
104 W LRTIME0," TO ",LRTIME9
105 ; in ^LRO
106 ; From that we get the LRDFN and look ^LR(LRDFN,"CH" or
107 ; ^LR(LRDFN,"MI"
108 ; fROM this we get the accn---Get the IEN from the accn area by
109 ; --------^LRO(68,"B","ABBRV")-----
110 ; The last peice of the 0 node is the IEN forn ^SC
111 ; Take that and look in the B x-ref of ^LAB(64.5,1,5,"B",IEN
112 ; ^LAB(64.5,1,5,"B",1870,422
113 ; and get the ien for the separate location and where it should
114 ; print
115 ; Lastly set LRLLIN VARABLE TO to the ien in ^SC
116 QUIT
Note: See TracBrowser for help on using the repository browser.