Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BLRRLTDR

BLRRLTDR.m

Go to the documentation of this file. 
  1. BLRRLTDR ; IHS/MSC/MKK - Reference Lab Test "Delete" Routine  ; 22-Oct-2013 09:22 ; MKK
  1.  ;;5.2;IHS LABORATORY;**1033**;NOV 1, 1997
  1.  ;
  1.  ; Code cloned from LRTSTOUT
  1.  ;
  1.  ; This routine will mark all tests on an Accession as Not Performed when the incoming HL7 message
  1.  ; from a Reference Lab has the OBX "not performed" flag set.  No output.
  1.  ;
  1.  ; NOTE: There will be no check on the LRLABKY variable.
  1.  ;       It is assumed that the process running this routine MUST be able to mark test NOT PERFORMED.
  1.  ;
  1. EEP ; Ersatz EP
  1.  D EEP^BLRGMENU
  1.  Q
  1.  ;
  1. PEP ; EP 
  1. EP ; EP
  1. NOTPERF(UID,CANCLRSN) ; EP - Not Performed
  1.  NEW (CANCLRSN,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,TESTDESC,U,UID,XPARSYS,XQXFLG)
  1.  ;
  1.  D ^LRPARAM
  1.  S BLRLOG=1
  1.  ;
  1.  S X=$Q(^LRO(68,"C",UID)),LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6)
  1.  ;
  1.  ; Skip if no Accession variables
  1.  I LRAA<1!(LRAD<1)!(LRAN<1) D XTMPISET^BLRRLTDU("Could not determine Accession variables from UID:"_UID_".","BLRRLTDR")  Q
  1.  ;
  1.  S SAVLRAA=LRAA,SAVLRAD=LRAD,SAVLRAN=LRAN
  1.  ;
  1.  S LRSS=$$GET1^DIQ(68,LRAA,"LR SUBSCRIPT","I")
  1.  S IEN=LRAN_","_LRAD_","_LRAA_","
  1.  S LRDFN=$$GET1^DIQ(68.02,IEN,"LRDFN","I")
  1.  S LRIDT=$$GET1^DIQ(68.02,IEN,"INVERSE DATE","I")
  1.  ; 
  1.  S BLROPT="DELACC"
  1.  ;
  1.  ; S CANCLRSN=$$GETCANCL^BLRRLMUU(UID)     ; Get Cancel reason from 62.49
  1.  ;
  1.  K LRXX,LRSCNXB
  1.  F  S (LREND,LRNOP)=0 D FIX D  I $G(LREND) D END Q
  1.  . I $G(LREND) D END S LREND=1 Q
  1.  . K DIC D:'$G(LRNOP) CHG D END
  1.  ;
  1.  D COMPDATE(SAVLRAA,SAVLRAD,SAVLRAN)
  1.  ;
  1.  D LMIMAIL(UID,CANCLRSN)
  1.  Q
  1.  ;
  1. COMPDATE(LRAA,LRAD,LRAN) ; EP - Put Completed Date on Accession
  1.  NEW CANCELDT,ERRS,FDA,IEN
  1.  ;
  1.  S IEN=LRAN_","_LRAD_","_LRAA_","
  1.  ;
  1.  K FDA
  1.  S CANCELDT=$$NOW^XLFDT
  1.  S FDA(68.02,IEN,13)=CANCELDT
  1.  D UPDATE^DIE(,"FDA","IEN","ERRS")
  1.  Q
  1.  ;
  1. LMIMAIL(UID,CANCLRSN) ; EP - E-mail LMI Mail Group with Ref Lab Cancellations
  1.  NEW LRAA,LRAD,LRAN,LRAS,MSGARRAY,REFLAB,TAB
  1.  ;
  1.  S REFLAB=$$GET1^DIQ(9009029,DUZ(2),3001)   ; Get Reference Lab Name
  1.  ;
  1.  NEW DUZ
  1.  D DUZ^XUP(.5)  ; Set DUZ to POSTMASTER since "GIS,USER" cannot send MailMan messages
  1.  ;
  1.  S X=$Q(^LRO(68,"C",UID)),LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6)
  1.  S LRAS=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA,15)
  1.  ;
  1.  S TAB=$J("",5)
  1.  S MSGARRAY(1)=TAB_"Reference Lab "_REFLAB,MSGARRAY(2)=" "
  1.  S MSGARRAY(3)=TAB_"Accession "_LRAS_" has been rejected.",MSGARRAY(4)=" "
  1.  S MSGARRAY(5)=TAB_"Cancellation Reason:",MSGARRAY(6)=TAB_TAB_CANCLRSN
  1.  ;
  1.  D MAILALMI^BLRUTIL3("Accession "_LRAS_" Rejected",.MSGARRAY,"HL7 Interface",1)
  1.  Q
  1.  ;
  1. FIX ; EP
  1.  S (LREND,LRNOP)=0,LRNOW=$$NOW^XLFDT
  1.  S LRACC=1 D LRACC Q:$G(LRNOP)
  1.  ;
  1.  K LRACC,LRNATURE I $G(LRAN)<1 S LREND=1 Q
  1.  ;
  1.  I '$P($G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),0)),U,2) D XTMPISET^BLRRLTDU("Accession has no Test.","BLRRLTDR") S LRNOP=1  Q
  1.  ;
  1.  L +^LRO(68,LRAA,1,LRAD,1,LRAN):1 I '$T D XTMPISET^BLRRLTDU("Someone else is working on this accession.","BLRRLTDR") S LRNOP=1 Q
  1.  ;
  1.  S LRX=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRACN=$P(^(.2),U),LRUID=$P(^(.3),U)
  1.  S LRDFN=+LRX,LRSN=+$P(LRX,U,5),LRODT=+$P(LRX,U,4)
  1.  S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
  1.  ;
  1.  D PT^LRX
  1.  ;
  1.  S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5) L +^LR(LRDFN,LRSS,LRIDT):1  I '$T D XTMPISET^BLRRLTDU("Someone else is working on this data.","BLRRLTDR")  L -^LRO(68,LRAA,1,LRAD,1,LRAN) S LRNOP=1 Q
  1.  ;
  1.  I '$G(^LR(LRDFN,LRSS,LRIDT,0)) D XTMPISET^BLRRLTDU("Can't find Lab Data for this accession.","BLRRLTDR") D UNLOCK S LRNOP=1 Q
  1.  ;
  1. FX1 ; EP
  1.  S LRTSTS=0
  1.  F  S LRTSTS=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS))  Q:LRTSTS<1  D
  1.  . S F60IEN=$$GET1^DIQ(68.04,LRTSTS_","_LRAN_","_LRAD_","_LRAA_",",.01,"I")
  1.  . D:F60IEN&(LRTSTS) CHG
  1.  Q
  1.  ;
  1. TESTGET ; EP - IEN into 62.49 Passed in
  1.  S F60IEN=0
  1.  S LA7INST=$$GET1^DIQ(9009029,DUZ(2),3001)
  1.  Q:$G(LA7INST)="" 0                                ; Quit with zero if no Reference Lab
  1.  ;
  1.  ; Determine what piece is the observation sub-id: QUEST uses OBX3.4; all others use OBX3.1
  1.  S WOTPIECE=$S($$UP^XLFSTR(LA7INST)["QUEST":4,1:1)
  1.  ;
  1.  S SEG=0,F60SYN=""
  1.  F  S SEG=$O(^LAHM(62.49,LA76249,150,SEG))  Q:SEG=""!($L(F60SYN))  D
  1.  . Q:$G(^LAHM(62.49,LA76249,150,SEG,0))'["OBR"
  1.  . S F60SYN=$P($P($G(^LAHM(62.49,LA76249,150,SEG,0)),"|",5),"^",WOTPIECE)
  1.  ;
  1.  Q:$L(F60SYN)<1
  1.  ;
  1.  ; Have to use $O(^LAB(60,"B",OBRIEN,0)) because FIND1^DIC does not work correctly if the synonym is purely numeric
  1.  S F60IEN=+$O(^LAB(60,"B",F60SYN,0))
  1.  ;
  1.  NEW WHCHTEST
  1.  S (WHCHTEST,LRTSTS)=0
  1.  F  S WHCHTEST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,WHCHTEST))  Q:WHCHTEST<1!(LRTSTS)  D
  1.  . S:$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,WHCHTEST,0)),"^")=F60IEN LRTSTS=WHCHTEST
  1.  ;
  1.  Q
  1.  ;
  1. CHG ; EP
  1.  ; Have LRACN,LRUID,LRDFN,LRSS,LRIDT and CANCLRSN
  1.  ;
  1.  K LRCCOM,LRCTST,DIC
  1.  N LRIFN
  1.  ;
  1.  S LRCCOM="",LREND=0
  1.  I '$D(^LRO(69,LRODT,1,LRSN,0))#2 D XTMPISET^BLRRLTDU("There is no Order for this Accession","BLRRLTDR")  D UNLOCK,END Q
  1.  ;
  1.  D FX2 Q:$G(LREND)
  1.  ;
  1.  Q:'$D(^LAB(60,LRTSTS,0))#2
  1.  S LRTNM=$P(^(0),U)
  1.  ;
  1.  S LRORDTST=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0),U,9) D SET,CLNPENDG
  1.  ;
  1.  ; The following line added per appendix A of RPMS Lab
  1.  ; E-Sig Enhancement clinical manual IHS/HQW/SCR - 8/23/01 
  1.  I $$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",DUZ(2)) D ^BLRALAF
  1.  ;
  1.  ; Send over changes to PCC
  1.  D:BLRLOG ^BLREVTQ("M","D",$G(BLROPT),,LRAA_","_LRAD_","_LRAN)
  1.  ;
  1.  S LREND=0 K LRCTST
  1.  Q
  1.  ;
  1. SHOWTST ; EP
  1.  Q    ; Skip entirely.  No output.
  1.  ;
  1.  N LRI,LRN,DIR,LRY,LRIC,X
  1.  S DIR(0)="E"
  1.  D DEMO
  1.  S LRN=0,LRI=0 F  S LRI=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI)) Q:LRI<1!($G(LRY))  D
  1.  . S LRIC=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0)),U,4,6) Q:'$D(^LAB(60,+LRI,0))#2  W !,?5,$P(^(0),U) S LRN=LRN+1 I LRIC  D
  1.  . . W ?35,"  "_$S($L($P(LRIC,U,3)):$P(LRIC,U,3),1:"Completed")_"  "_$$FMTE^XLFDT($P(LRIC,U,2),"5FMPZ")_" by "_$P(LRIC,U)
  1.  . I LRN>18 D ^DIR S:$E(X)=U LRY=1 Q:$G(LRY)  D DEMO S LRN=0
  1.   S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRODT=$P(X,U,4),LRSN=$P(X,U,5)
  1.  Q
  1.  ;
  1. DEMO ; EP
  1.  W !,PNM,?50,HRCN
  1.  W !,"TESTS ON ACCESSION: ",LRACN,?40,"UID: ",LRUID
  1.  Q
  1.  ;
  1. SET ; EP
  1.  S:'$G(LRNOW) LRNOW=$$NOW^XLFDT
  1.  S LRLLOC=$P(^LRO(69,LRODT,1,LRSN,0),U,7) D
  1.  . N II,X,LRI,LRSTATUS,OCXTRACE
  1.  . S:$G(LRDBUG) OCXTRACE=1
  1.  . S LRI=0 F  S LRI=$O(^LRO(69,LRODT,1,LRSN,2,LRI)) Q:LRI<1  I $D(^(LRI,0))#2,LRTSTS=+^(0) S (LRSTATUS,II(LRTSTS))="" D  K II
  1.  . . Q:$P(^LRO(69,LRODT,1,LRSN,2,LRI,0),U,11)  S ORIFN=$P(^(0),U,7)
  1.  . . S $P(^LRO(69,LRODT,1,LRSN,2,LRI,0),U,11)=DUZ
  1.  . . S X=1+$O(^LRO(69,LRODT,1,LRSN,2,LRI,1.1,"A"),-1),X(1)=$P($G(^(0)),U,4)
  1.  . . S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,X,0)=$P($G(LRNATURE),U,5)_": "_LRCCOM,X=X+1,X(1)=X(1)+1
  1.  . . S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,X,0)="*NP Action:"_$$FMTE^XLFDT(LRNOW,"5MZ")
  1.  . . S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,0)="^^"_X_"^"_X(1)_"^"_DT
  1.  . . I $G(ORIFN),$D(II) D NEW^LR7OB1(LRODT,LRSN,$S($G(LRMSTATI)=""!($G(LRMSTATI)=1):"OC",1:"SC"),$G(LRNATURE),.II,LRSTATUS)
  1.  . . I ORIFN,$$VER^LR7OU1<3 D DC^LRCENDE1
  1.  . . S $P(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",9)="CA",$P(^(0),U,10)="L",$P(^(0),U,11)=DUZ
  1.  . . S:$D(^LRO(69,LRODT,1,LRSN,"PCE")) ^LRO(69,"AE",DUZ,LRODT,LRSN,LRI)=""
  1.  K ORIFN,ORSTS
  1.  I $D(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),0))#2,$D(^(4,$G(LRTSTS),0))#2 S $P(^(0),U,4,6)=DUZ_U_LRNOW_U_"*Not Performed" D
  1.  . D XTMPNSET^BLRRLTDU(+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0)),"*NP:Set Accs")
  1.  . D STORTXNS^BLRRLTDU(LRTSTS,$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"N")
  1.  . S LROWDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,3) I LROWDT,LROWDT'=LRAD D ROL Q
  1.  . S LROWDT=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,9)) I LROWDT D ROL
  1.  I $G(LRIDT),$L($G(LRSS)),$L(LRCCOM),$G(^LR(LRDFN,LRSS,LRIDT,0)) D
  1.  . D 63(LRDFN,LRSS,LRIDT,LRTNM,LRCCOM)
  1.  . D:'$D(^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)) XREF^LRVER3A
  1.  D EN^LA7ADL($P($G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),.3)),"^")) ; Put in list to check for auto download.
  1.  ;
  1.  Q
  1.  ;
  1. ROL ; EP
  1.  Q:+$G(^LRO(68,LRAA,1,LROWDT,1,LRAN,0))'=LRDFN  Q:'$D(^(4,LRTSTS,0))#2
  1.  S $P(^LRO(68,LRAA,1,LROWDT,1,LRAN,4,LRTSTS,0),U,4,6)=DUZ_U_LRNOW_U_"*Not performed"
  1.  Q
  1.  ;
  1. LRACC ; EP
  1.  S LREND=0,LREXMPT=1 K LREXMPT
  1.  ;
  1.  Q:'$G(LRAA)!('$G(LRAN))
  1.  Q:'$D(^LRO(68,LRAA,0))#2
  1.  ;
  1.  S DA(2)=LRAA,DA(1)=LRAD,LRSS=$P(^LRO(68,LRAA,0),U,2)
  1.  I '$L(LRSS) S LRAN=0,LRNOP=1 D XTMPISET^BLRRLTDU("No Subscript for this Accession Area","BLRRLTDR")
  1.  ;
  1.  Q
  1.  ;
  1. LREND ; EP
  1.  S LREND=1
  1.  Q
  1.  ;
  1. UNLOCK ; EP
  1.  L -(^LR($G(LRDFN),$G(LRSS),$G(LRIDT)),^LRO(68,$G(LRAA),1,$G(LRAD),1,$G(LRAN)))
  1.  D END
  1.  Q
  1.  ;
  1. EXIT ; EP
  1.  K LRSCNX,LRNOECHO,LRACN,LRLABRV,LRNOW
  1.  ;
  1. END ; EP
  1.  K LRCCOM0,LRCCOM1,LRCCOMX,LREND,LRI,LRL,LRNATURE,LRNOP,LRSCN,LRMSTATI,LRORDTST,LROWDT,LRPRAC,LRTSTS,LRUID
  1.  K Q9,LRXX,DIR,LRCOM,LRAGE,DI,LRCTST,LRACN,LRACN0,LRDOC,LRLL,LRNOW
  1.  K LROD0,LROD1,LROD3,LROOS,LROS,LROSD,LROT,LRROD,LRTT,X4
  1.  D @$S($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")
  1.  D END^LRTSTJAM
  1.  K HRCN
  1.  Q
  1.  ;
  1. FX2 ; EP
  1.  S LREND=0
  1.  S LRL=52
  1.  ;
  1.  ; Hard set the necessary variables
  1.  S X="L",Y="L",Y(0)="LAB"
  1.  ;
  1.  K LRSCNXB,LRNOECHO
  1.  S:'$D(LRSCN) LRSCN="AKL"
  1.  ;
  1.  S LRSCNXB=Y(0),LRSCN=LRSCN_Y
  1.  ;
  1. FX3 ; EP
  1.  ; S (LRCCOM,LRCCOMX)="*NP Reason:Reference Lab Rejected Test."
  1.  S (LRCCOM,LRCCOMX)="*NP Reason:"_$G(CANCLRSN,"Reference Lab Rejected Test.")
  1.  Q
  1.  ;
  1. 63(LRDFN,LRSS,LRIDT,LRTNM,LRCCOM) ; EP
  1.  N X,Y,D0,D1,DA,DR,DIC,DIE,LRCCOM0,LRNOECHO,DLAYGO
  1.  NEW TMPSTR,PRNTNAM
  1.  ;
  1.  S DLAYGO=63,DIC(0)="SL"
  1.  S:'$G(LRNOW) LRNOW=$$NOW^XLFDT
  1.  S LRNOECHO=1
  1.  ;
  1.  ; Make certain Comment string within field length; if not, use PRINT NAME from file 60
  1.  S TMPSTR="*"_LRTNM_" Not Performed: "_$$FMTE^XLFDT(LRNOW,"5FMPZ")_" by "_DUZ
  1.  I $L(TMPSTR)>68 D
  1.  . S PRNTNAM=$$GET1^DIQ(60,LRTSTS,"PRINT NAME")
  1.  . S LRCCOM0=$E("*"_PRNTNAM_" Not Performed: "_$$FMTE^XLFDT(LRNOW,"5FMPZ")_" by "_DUZ,1,68)
  1.  ;
  1.  ; Full name of test can be used in Comment string
  1.  I $L(TMPSTR)<69 S LRCCOM0=$E("*"_LRTNM_" Not Performed: "_$$FMTE^XLFDT(LRNOW,"5FMPZ")_" by "_DUZ,1,68)
  1.  ;
  1.  S DA=LRIDT,DA(1)=LRDFN,DIE="^LR("_LRDFN_","""_LRSS_""","
  1.  S LRCCOM0=$TR(LRCCOM0,";","-") ; Strip ";" - FileMan uses ";" to parse DR string.
  1.  S DR=".99////^S X="_""""_LRCCOM0_"""" D ^DIE
  1.  ;
  1.  D ADDSPCON(UID)   ; Add the SPECIMEN CONDITION, if it exists
  1.  ;
  1.  Q:LRSS="MI"
  1.  ;
  1. 631 ; EP
  1.  K D0,D1,DA,DR,DIC,DIE
  1.  S DIC(0)="SL"
  1.  S DA=LRIDT,DA(1)=LRDFN,DIE="^LR("_LRDFN_","""_LRSS_""",",DIC=DIE
  1.  S LRCCOM=$TR(LRCCOM,";","-") ; Strip ";" - FileMan uses ";" to parse DR string.
  1.  S LRCCOM=$TR(LRCCOM,"""","'") ; Change " to ' -- " causes FileMan error.
  1.  S DR=".99///^S X="_""""_LRCCOM_""""
  1.  D ^DIE
  1.  Q
  1. CLNPENDG ;Remove pending from Lab test when set to not performed
  1.  N LRIFN
  1.  S LRIFN=$P($G(^LAB(60,LRTSTS,.2)),U)
  1.  Q:LRIFN=""
  1.  S:$P($G(^LR(LRDFN,LRSS,LRIDT,LRIFN)),U)="pending" $P(^LR(LRDFN,LRSS,LRIDT,LRIFN),U)=""
  1.  Q
  1.  ;
  1. ADDCOMNT(LRDFN,LRIDT,MSG) ; EP - Add the Ref Lab comments from the NTE segments to file 63
  1.  NEW ARRAYL,CL,COMARRAY,FDA,IENS,SEG,STR
  1.  ;
  1.  S ARRAYL=$$GETNTEC(MSG,.COMARRAY)
  1.  Q:ARRAYL<1
  1.  ;
  1.  F CL=1:1:ARRAYL D
  1.  . S IENS(1)=$O(^LR(LRDFN,"CH",LRIDT,1,"B"),-1)+1  ; Get next COMMENT line
  1.  . S FDA(63.041,"+1,"_LRIDT_","_LRDFN_",",.01)=$G(COMARRAY(CL))
  1.  . ;
  1.  . D UPDATE^DIE(,"FDA","IENS","ERRS")
  1.  . ;
  1.  . ; D:$D(ERRS("DIERR"))>0 ADDERRS(WOT,.ERRS,.ERRCNT)   ; Errors
  1.  Q
  1.  ;
  1. GETNTEC(MSG,ARRAY) ; EP - Stuff ARRAY with NTE comments from message
  1.  NEW COML,COMLS,SEG,STR
  1.  ;
  1.  S (COML,SEG)=0
  1.  F  S SEG=$O(^LAHM(62.49,MSG,150,SEG))  Q:SEG<1  D
  1.  . Q:$G(^LAHM(62.49,MSG,150,SEG,0))'["NTE"
  1.  . ;
  1.  . S STR=$G(^LAHM(62.49,MSG,150,SEG,0))
  1.  . Q:$TR($P(STR,"|",4)," ")=""    ; Don't bother with blank lines
  1.  . ;
  1.  . S COMLS=$$TRIM^XLFSTR($P(STR,"|",4),"LR"," ")
  1.  . ;
  1.  . Q:$D(COMLS(COMLS))>0           ; Don't store duplicate comments
  1.  . ;
  1.  . S COML=COML+1
  1.  . S ARRAY(COML)=COMLS
  1.  . S COMLS(COMLS)=""              ; Store comment so no duplicates
  1.  ;
  1.  Q COML                           ; Return # of lines stored
  1.  ;
  1. GETSPMC(MSG,ARRAY) ; EP - Stuff ARRAY with SPM comments from message
  1.  NEW COML,COMLS,SEG,STR
  1.  ;
  1.  S (COML,SEG)=0
  1.  F  S SEG=$O(^LAHM(62.49,MSG,150,SEG))  Q:SEG<1  D
  1.  . Q:$G(^LAHM(62.49,MSG,150,SEG,0))'["SPM"
  1.  . ;
  1.  . S STR=$G(^LAHM(62.49,MSG,150,SEG,0))
  1.  . Q:$TR($P(STR,"|",4)," ")=""    ; Don't bother with blank lines
  1.  . ;
  1.  . S COMLS=$$TRIM^XLFSTR($P(STR,"|",4),"LR"," ")
  1.  . ;
  1.  . Q:$D(COMLS(COMLS))>0           ; Don't store duplicate comments
  1.  . ;
  1.  . S COML=COML+1
  1.  . S ARRAY(COML)=COMLS
  1.  . S COMLS(COMLS)=""              ; Store comment so no duplicates
  1.  ;
  1.  Q COML                           ; Return # of lines stored
  1.  ;
  1. ADDSPCON(UID) ; EP - Add the SPECIMEN CONDITION from the SPM segment, if it exists
  1.  NEW AUTOIEN,AUTOINSP,FOUNDIT,IEN,INST,INSTUID,LA7INST,LOADWORK,SEGCNT
  1.  ;
  1.  Q:$$USELAHG(UID)="OK"    ; Check the LAH global.  If successful, quit
  1.  ;
  1.  S PIEN=$$RELAHMID^BLRRLMUU(UID)
  1.  Q:PIEN<1              ; Could not determine IEN of UID, so quit
  1.  ;
  1.  S (FOUNDIT,SEGCNT)=0
  1.  F  S SEGCNT=$O(^LAHM(62.49,PIEN,150,SEGCNT))  Q:SEGCNT<1!(FOUNDIT)  D
  1.  . S:$P($G(^LAHM(62.49,PIEN,150,SEGCNT,0)),"|")="SPM" FOUNDIT=SEGCNT
  1.  ;
  1.  Q:FOUNDIT<1                        ; Could not find "SPM" segment, so quit
  1.  ;
  1.  S STR=$G(^LAHM(62.49,PIEN,150,FOUNDIT,0))
  1.  ;
  1.  S CONDSPEC=$P($P(STR,"|",25),"^")            ; SPECIMEN CONDITION
  1.  Q:$L(CONDSPEC)<1                             ; Skip if no SPECIMEN CONDITION
  1.  ;
  1.  S X=$Q(^LRO(68,"C",UID)),LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6)
  1.  S LRSS=$$GET1^DIQ(68,LRAA,"LR SUBSCRIPT","I")
  1.  S IEN=LRAN_","_LRAD_","_LRAA_","
  1.  S LRDFN=$$GET1^DIQ(68.02,IEN,"LRDFN","I")
  1.  S LRIDT=$$GET1^DIQ(68.02,IEN,"INVERSE DATE","I")
  1.  ;
  1.  S $P(^LR(LRDFN,LRSS,LRIDT,"IHS"),"^")=CONDSPEC
  1.  S $P(^LR(LRDFN,LRSS,LRIDT,"HL7"),"^")=PIEN    ; Store 62.49 IEN
  1.  Q
  1.  ;
  1. USELAHG(UID) ; EP - Use the LAH global.  If successful, quit with "OK"
  1.  NEW AUTOIEN,CONDSPEC,LA7INST,LOADWORK
  1.  ;
  1.  S LA7INST=$$GET1^DIQ(9009029,DUZ(2),3001)
  1.  Q:$G(LA7INST)="" 0                                ; Quit with zero if no Reference Lab
  1.  ;
  1.  S AUTOIEN=+$O(^LAB(62.4,"B",LA7INST,""))          ; Auto Instrument IEN
  1.  Q:AUTOIEN<1 0                                     ; Quit with zero if No Auto Instrument
  1.  ;
  1.  S LOADWORK=$$GET1^DIQ(62.4,AUTOIEN,"LOAD/WORK LIST","I")
  1.  ;
  1.  ; First, look at the ^LAH global
  1.  S IEN=+$O(^LAH(LOADWORK,1,"C",UID,"A"),-1)        ; Get UID's most recent IEN
  1.  ;
  1.  S STR=$G(^LAH(LOADWORK,1,IEN,"IHSSPM"))
  1.  ;
  1.  ; Q 0                                               ; As of 19-Apr-2013, not being stored in ^LAH, so just Quit
  1.  ;
  1.  S CONDSPEC=$P(STR,"^",4)                          ; SPECIMEN CONDITION
  1.  Q:$L(CONDSPEC)<1 0                                ; Quit with zero if no SPECIMEN CONDITION string
  1.  ;
  1.  S $P(^LR(LRDFN,LRSS,LRIDT,"IHS"),"^")=CONDSPEC
  1.  Q "OK"