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