- 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 Feb 18, 2025@23:31:58 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