LRAC14 ;DALOI/DH/RLM-FIND LOCATION FOR MULTIPLE ABBREVIATION ;6/16/97 15:45
;;5.2;LAB SERVICE;**272**;SEP 27, 1994
; Reference to ^SC( supported by IA # 908
; Reference to ^%DTC supported by IA # 10000
; Reference to ^VADPT supported by IA # 10061
; Reference to ^XMD supported by IA # 10070
INIT ;
Q:'$D(LRLLOC)
S LRODT=DT
Q:'$D(^LAB(64.58,"C"))
I '$G(LRLLIN) S LRLLIN=0
;S LRLLIN=$O(^LAB(64.58,"C",LRLLOC,LRLLIN))
;I +$G(LRLLIN)>0 QUIT
CNT S LRCNT9=$G(LRCNT9)+1
Q:'$G(LRDT)
S LRODT=LRDT
Q:'$D(^LRO(69,LRODT,1,"AR",LRLLOC))
S PNM1=$O(^LRO(69,LRODT,1,"AR",LRLLOC,""))
Q:'$D(^LRO(69,LRODT,1,"AR",LRLLOC,PNM1))
S LRDFN1=$O(^LRO(69,LRODT,1,"AR",LRLLOC,PNM1,0))
S DFN=$P(^LR(LRDFN1,0),U,3) D ^VADPT
Q:'$D(^LRO(69,LRODT,1,"AR",LRLLOC,PNM1,LRDFN1))
D CH D MI D BB D SP
; ^LR(50954,"CH",7029381.94999,0) = 2970617.05001^^^^71^WUA 0616 30^^^^36560^WMHC
CH ;
S LRSUB="CH" D LR
D MAIL
K LRNODE
Q:LRLLIN=0 ;--> This happens when location is UNKNOWN
MI ;
Q:$G(LRLLIN)>0
S LRSUB="MI" D LR
Q
BB ;
Q:$G(LRLLIN)>0
S LRSUB="BB" D LR
Q
SP ;
Q:$G(LRLLIN)>0
S LRSUB="SP" D LR
Q
LR ;
Q:'$D(^LR(LRDFN1,LRSUB))
S LRIDT=$O(^LRO(69,LRODT,1,"AN",LRLLOC,LRDFN1,0)) Q:+LRIDT'>0 D
. I $D(^LR(LRDFN1,LRSUB,LRIDT,0)) S LRNODE=^LR(LRDFN1,LRSUB,LRIDT,0)
. Q:$G(LRNODE)=""
. S LRAD=9999999-LRIDT
. S LRAD=$P(LRAD,".")
. S LRACCN=$P(LRNODE,U,6)
. S LRAAN=$P(LRACCN," ") S LRAA=$O(^LRO(68,"B",LRAAN,0))
. Q:LRAA=""
. S LRAD=$S(LRSUB'="CH":$E(LRAD,1,3)_"0000",1:$E(LRAD,1,3)_$P(LRACCN," ",2))
. S LRAN=+$P(LRNODE," ",3)
. Q:LRAN'>0
. Q:LRAA'>0!(LRAD'>0)
. Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D LRO
;
;D END
Q
LRO ;
S LRLLIN=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,13)
;W !,^SC(LRLLIN,0)
;K LRLLIN
I '$G(LRLLIN) S ^TMP("LR","NO-LRLLIN",LRACCN,LRLLOC)="" D LRO69
Q
LRO69 ;
I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S LRNODE=^(0) D
. S LRODT=$P(LRNODE,U,4),LRSN=$P(LRNODE,U,5)
. Q:$G(LRSN)'>0
. Q:'$D(^LRO(69,LRODT,1,LRSN,0))
. S LRLLIN=$P(^LRO(69,LRODT,1,LRSN,0),U,9)
;K LRLLIN
I '$G(LRLLIN) D
. I '$G(PNM) S PNM=PNM1
. D PT^LRX S LRDATA=$G(PNM1)_U_$G(SSN)_U_$G(LRODT)_U_$G(DFN)
. S ^TMP("LR","LR-NO-LOC",LRLLOC)=LRDATA ;--->Send message
. D MAIL
Q
MAIL ;
; Send a message to entries in G.LMI if the
; location can't be found in ^SC
I $G(DUZ)'>0 S LRDUZ2=.5
I $G(LRDUZ2)'>0 S LRDUZ2=.5
S Y=0
S XMY("G.LMI")="" D
. S XMDUZ=LRDUZ2
. S XMTEXT="LRTXT("
. S LRTXT(1)="Flash... Have a problem with: "_$G(LRLLOC)_" "_$G(VADM(1))_" "_$G(VADM(2))_" For "_$G(LRODT)
. I $G(LRLLIN) S LRTXT(2)="I think it might be: "_$G(^SC(LRLLIN,0))
. S XMSUB="Problem resolving locations for cumulative."
. D ^XMD
QUIT
END ;
QUIT
K LRCNTCUM,LRSUB,LRDFN1,LRIDT,LRAD,LRAA,LRAN,LRACCN,LRAAN,LRODT,LRDUZ2
K LRTXT,LRTIME0,LRTIME9
Q
LOOK ;
S X=0
D NOW^%DTC S LRTIME0=%
S X=0
F S X=$O(^LAC("LRAC",X)) Q:X=""
D NOW^%DTC S LRTIME9=%
W LRTIME0," TO ",LRTIME9
; in ^LRO
; From that we get the LRDFN and look ^LR(LRDFN,"CH" or
; ^LR(LRDFN,"MI"
; fROM this we get the accn---Get the IEN from the accn area by
; --------^LRO(68,"B","ABBRV")-----
; The last peice of the 0 node is the IEN forn ^SC
; Take that and look in the B x-ref of ^LAB(64.5,1,5,"B",IEN
; ^LAB(64.5,1,5,"B",1870,422
; and get the ien for the separate location and where it should
; print
; Lastly set LRLLIN VARABLE TO to the ien in ^SC
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAC14 3524 printed Apr 09, 2024@21:11:31 Page 2
LRAC14 ;DALOI/DH/RLM-FIND LOCATION FOR MULTIPLE ABBREVIATION ;6/16/97 15:45
+1 ;;5.2;LAB SERVICE;**272**;SEP 27, 1994
+2 ; Reference to ^SC( supported by IA # 908
+3 ; Reference to ^%DTC supported by IA # 10000
+4 ; Reference to ^VADPT supported by IA # 10061
+5 ; Reference to ^XMD supported by IA # 10070
INIT ;
+1 if '$DATA(LRLLOC)
QUIT
+2 SET LRODT=DT
+3 if '$DATA(^LAB(64.58,"C"))
QUIT
+4 IF '$GET(LRLLIN)
SET LRLLIN=0
+5 ;S LRLLIN=$O(^LAB(64.58,"C",LRLLOC,LRLLIN))
+6 ;I +$G(LRLLIN)>0 QUIT
CNT SET LRCNT9=$GET(LRCNT9)+1
+1 if '$GET(LRDT)
QUIT
+2 SET LRODT=LRDT
+3 if '$DATA(^LRO(69,LRODT,1,"AR",LRLLOC))
QUIT
+4 SET PNM1=$ORDER(^LRO(69,LRODT,1,"AR",LRLLOC,""))
+5 if '$DATA(^LRO(69,LRODT,1,"AR",LRLLOC,PNM1))
QUIT
+6 SET LRDFN1=$ORDER(^LRO(69,LRODT,1,"AR",LRLLOC,PNM1,0))
+7 SET DFN=$PIECE(^LR(LRDFN1,0),U,3)
DO ^VADPT
+8 if '$DATA(^LRO(69,LRODT,1,"AR",LRLLOC,PNM1,LRDFN1))
QUIT
+9 DO CH
DO MI
DO BB
DO SP
+10 ; ^LR(50954,"CH",7029381.94999,0) = 2970617.05001^^^^71^WUA 0616 30^^^^36560^WMHC
CH ;
+1 SET LRSUB="CH"
DO LR
+2 DO MAIL
+3 KILL LRNODE
+4 ;--> This happens when location is UNKNOWN
if LRLLIN=0
QUIT
MI ;
+1 if $GET(LRLLIN)>0
QUIT
+2 SET LRSUB="MI"
DO LR
+3 QUIT
BB ;
+1 if $GET(LRLLIN)>0
QUIT
+2 SET LRSUB="BB"
DO LR
+3 QUIT
SP ;
+1 if $GET(LRLLIN)>0
QUIT
+2 SET LRSUB="SP"
DO LR
+3 QUIT
LR ;
+1 if '$DATA(^LR(LRDFN1,LRSUB))
QUIT
+2 SET LRIDT=$ORDER(^LRO(69,LRODT,1,"AN",LRLLOC,LRDFN1,0))
if +LRIDT'>0
QUIT
Begin DoDot:1
+3 IF $DATA(^LR(LRDFN1,LRSUB,LRIDT,0))
SET LRNODE=^LR(LRDFN1,LRSUB,LRIDT,0)
+4 if $GET(LRNODE)=""
QUIT
+5 SET LRAD=9999999-LRIDT
+6 SET LRAD=$PIECE(LRAD,".")
+7 SET LRACCN=$PIECE(LRNODE,U,6)
+8 SET LRAAN=$PIECE(LRACCN," ")
SET LRAA=$ORDER(^LRO(68,"B",LRAAN,0))
+9 if LRAA=""
QUIT
+10 SET LRAD=$SELECT(LRSUB'="CH":$EXTRACT(LRAD,1,3)_"0000",1:$EXTRACT(LRAD,1,3)_$PIECE(LRACCN," ",2))
+11 SET LRAN=+$PIECE(LRNODE," ",3)
+12 if LRAN'>0
QUIT
+13 if LRAA'>0!(LRAD'>0)
QUIT
+14 if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
QUIT
DO LRO
End DoDot:1
+15 ;
+16 ;D END
+17 QUIT
LRO ;
+1 SET LRLLIN=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,13)
+2 ;W !,^SC(LRLLIN,0)
+3 ;K LRLLIN
+4 IF '$GET(LRLLIN)
SET ^TMP("LR","NO-LRLLIN",LRACCN,LRLLOC)=""
DO LRO69
+5 QUIT
LRO69 ;
+1 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
SET LRNODE=^(0)
Begin DoDot:1
+2 SET LRODT=$PIECE(LRNODE,U,4)
SET LRSN=$PIECE(LRNODE,U,5)
+3 if $GET(LRSN)'>0
QUIT
+4 if '$DATA(^LRO(69,LRODT,1,LRSN,0))
QUIT
+5 SET LRLLIN=$PIECE(^LRO(69,LRODT,1,LRSN,0),U,9)
End DoDot:1
+6 ;K LRLLIN
+7 IF '$GET(LRLLIN)
Begin DoDot:1
+8 IF '$GET(PNM)
SET PNM=PNM1
+9 DO PT^LRX
SET LRDATA=$GET(PNM1)_U_$GET(SSN)_U_$GET(LRODT)_U_$GET(DFN)
+10 ;--->Send message
SET ^TMP("LR","LR-NO-LOC",LRLLOC)=LRDATA
+11 DO MAIL
End DoDot:1
+12 QUIT
MAIL ;
+1 ; Send a message to entries in G.LMI if the
+2 ; location can't be found in ^SC
+3 IF $GET(DUZ)'>0
SET LRDUZ2=.5
+4 IF $GET(LRDUZ2)'>0
SET LRDUZ2=.5
+5 SET Y=0
+6 SET XMY("G.LMI")=""
Begin DoDot:1
+7 SET XMDUZ=LRDUZ2
+8 SET XMTEXT="LRTXT("
+9 SET LRTXT(1)="Flash... Have a problem with: "_$GET(LRLLOC)_" "_$GET(VADM(1))_" "_$GET(VADM(2))_" For "_$GET(LRODT)
+10 IF $GET(LRLLIN)
SET LRTXT(2)="I think it might be: "_$GET(^SC(LRLLIN,0))
+11 SET XMSUB="Problem resolving locations for cumulative."
+12 DO ^XMD
End DoDot:1
+13 QUIT
END ;
+1 QUIT
+2 KILL LRCNTCUM,LRSUB,LRDFN1,LRIDT,LRAD,LRAA,LRAN,LRACCN,LRAAN,LRODT,LRDUZ2
+3 KILL LRTXT,LRTIME0,LRTIME9
+4 QUIT
LOOK ;
+1 SET X=0
+2 DO NOW^%DTC
SET LRTIME0=%
+3 SET X=0
+4 FOR
SET X=$ORDER(^LAC("LRAC",X))
if X=""
QUIT
+5 DO NOW^%DTC
SET LRTIME9=%
+6 WRITE LRTIME0," TO ",LRTIME9
+7 ; in ^LRO
+8 ; From that we get the LRDFN and look ^LR(LRDFN,"CH" or
+9 ; ^LR(LRDFN,"MI"
+10 ; fROM this we get the accn---Get the IEN from the accn area by
+11 ; --------^LRO(68,"B","ABBRV")-----
+12 ; The last peice of the 0 node is the IEN forn ^SC
+13 ; Take that and look in the B x-ref of ^LAB(64.5,1,5,"B",IEN
+14 ; ^LAB(64.5,1,5,"B",1870,422
+15 ; and get the ien for the separate location and where it should
+16 ; print
+17 ; Lastly set LRLLIN VARABLE TO to the ien in ^SC
+18 QUIT
