BLRLINKU ;IHS/OIT/MKK - IHS LABORATORY VISIT CREATION Utilities ; 25-Nov-2014 09:22 ; MKK
;;5.2;IHS LABORATORY;**1030,1031,1033,1034,1037,1038**;NOV 01, 1997;Build 6
;
; Need to get Reference Ranges & Units from Incoming HL7 message
; IF and ONLY IF the transaction is tied to a Reference Lab Accession
CHKINHL7 ; EP
D ENTRYAUD^BLRUTIL("CHKINHL7^BLRLINKU 0.0","BLRVAL")
NEW DNIEN,DNDESC,F60IEN,HL7TEST,LRAA,LRAD,LRAN,LRAS,STR,UID
NEW ABNFLAG,REFHIGH,REFLOW,UNITS
;
Q:+$G(BLRLOGDA)<1 ; If no BLR Txn #, skip
;
S LRAS=$P($G(^BLRTXLOG(BLRLOGDA,12)),"^",2) ; Accession number
D GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN) ; Get Accession's component parts
Q:LRAA<1!(LRAD<1)!(LRAN<1) ; Quit if Accession doesn't exist
;
D REFLAB68 ; Check on ^XTMP("BLRLINKU")
Q:$D(^XTMP("BLRLINKU",$G(DUZ(2)),LRAA))<1 ; If not a Ref Lab Accession, skip
;
S F60IEN=+$P($G(^BLRTXLOG(BLRLOGDA,0)),"^",6) ; File 60 IEN
;
S UID=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
Q:UID<1 ; If no UID, skip
;
Q:$$GETINTHU(UID)<1
;
D ENTRYAUD^BLRUTIL("CHKINHL7^BLRLINKU 4.5")
;
S STR=$G(^TMP("BLR",$J,UID,F60IEN))
Q:$L(STR)<1
;
D STORVAL(2,$P(STR,"^",2)) ; Abnormal Flag
D STORVAL(3,$P(STR,"^",5)) ; Units
D STORVAL(8,$P(STR,"^",3)) ; Reference Low
D STORVAL(9,$P(STR,"^",4)) ; Referench High
;
D ENTRYAUD^BLRUTIL("CHKINHL7^BLRLINKU 9.0","BLRVAL")
Q
;
STORVAL(WHERE,WHAT) ; EP -- Store values in the IHS LAB TRANSACTION LOG file AND the BLRVAL array
Q:$L(WHAT)<1 ; Skip if no results
;
S $P(BLRVAL(20),"^",WHERE)=WHAT
S $P(^BLRTXLOG(BLRLOGDA,20),"^",WHERE)=WHAT
Q
;
GETINTHU(UID) ; EP -- Get Reference Range information from File 4001 (UNIVERSAL INTERFACE)
D ENTRYAUD^BLRUTIL("GETINTHU^BLRLINKU 0.0")
;
; Don't search if test already stored in ^TMP global
Q:$D(^TMP("BLR",$J,UID,F60IEN))>0 1
;
NEW AUTIF60P,AUTOINSN,AUTOINSP,AUTOITST,FOUNDIT,MSGID,MSGNUM,MSGUID,MSGSEG,MSGSTR
NEW MSGRESLT,MSGUNITS,MSGRLOW,MSGRHI,MSGABN,NOTMSG
NEW LA7INST,AUTOINSP,WOTPIECE,WOTREF
;
; Retrieve "Instrument Name" for Reference Lab
S LA7INST=$$GET1^DIQ(9009029,DUZ(2),3001)
Q:$G(LA7INST)="" 0 ; Quit with zero if no Reference Lab
;
S AUTOINSP=+$O(^LAB(62.4,"B",LA7INST,"")) ; Auto Instrument IEN
Q:AUTOINSP<1 0 ; Quit with zero if No Auto Instrument
;
Q:$$LAHREFR() 1 ; IHS/MSC/MKK - LR*5.2*1038
;
; 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)
;
D:$G(SNAPSHOT) STORFIND(UID,0) ; Store Starting Time of search
S WOTREF=+$G(^XTMP("BLRLINKU",+$G(DUZ(2)))) ; Interface Destination (# 4005) IEN
Q:WOTREF<1 0 ; Quit with zero if IEN<1
;
; NEW MSGSEG2 ; IHS/MSC/MKK - LR*5.2*1034
;
; Use "AD" Cross Reference
S (FOUNDIT,MSGNUM)=0
F S MSGNUM=$O(^INTHU("AD",WOTREF,MSGNUM)) Q:MSGNUM<1!(FOUNDIT) D
. S (MSGSEG,NOTMSG)=0
. F S MSGSEG=$O(^INTHU(MSGNUM,3,MSGSEG)) Q:MSGSEG<1!(FOUNDIT) D
.. I $P($G(^INTHU(MSGNUM,3,MSGSEG,0)),"|")="OBR" D
... ; Determine if UID = UID of Message
... S:UID=+$P($G(^INTHU(MSGNUM,3,MSGSEG,0)),"|",3) FOUNDIT=MSGNUM
.. Q:'FOUNDIT
.. ;
.. ; Find OBX segment
.. S (CNT,FOUNDIT)=0
.. S MSGSEG2=MSGSEG ; IHS/MSC/MKK - LR*5.2*1034
.. ; F S MSGSEG=$O(^INTHU(MSGNUM,3,MSGSEG)) Q:MSGSEG<1!(FOUNDIT) D
.. F S MSGSEG2=$O(^INTHU(MSGNUM,3,MSGSEG2)) Q:MSGSEG2<1!(FOUNDIT) D ; IHS/MSC/MKK - LR*5.2*1034
... ; S MSGSTR=$G(^INTHU(MSGNUM,3,MSGSEG,0))
... S MSGSTR=$G(^INTHU(MSGNUM,3,MSGSEG2,0)) ; IHS/MSC/MKK - LR*5.2*1034
... Q:$P(MSGSTR,"|")'="OBX"
... ;
... S CNT=CNT+1
... S MSGTEST=$P($P(MSGSTR,"|",4),"^",WOTPIECE) ; OBX 3
... Q:$L(MSGTEST)<1 ; Don't check if not defined
... ;
... Q:$D(^LAB(62.4,AUTOINSP,3,"AC",MSGTEST))<1 ; Don't check if not in Auto Instrument file
... ;
... ; File 60 IEN from Auto Instrument file
... S AUTIF60P=$P($G(^LAB(62.4,AUTOINSP,3,$O(^LAB(62.4,AUTOINSP,3,"AC",MSGTEST,0)),0)),"^")
... ;
... S MSGRESLT=$P(MSGSTR,"|",6) ; Results
... S MSGUNITS=$P(MSGSTR,"|",7) ; Units
... S MSGRLOW=$P($P(MSGSTR,"|",8),"-") ; Reference Low
... S MSGRHI=$P($P(MSGSTR,"|",8),"-",2) ; Reference High
... S MSGABN=$P(MSGSTR,"|",9) ; Status Flag
... S MSGABN=$S(MSGABN="L":MSGABN,MSGABN="H":MSGABN,MSGABN="A":MSGABN,1:"")
... ;
... ; Store information
... S ^TMP("BLR",$J,UID,AUTIF60P)=MSGRESLT_"^"_MSGABN_"^"_MSGRLOW_"^"_MSGRHI_"^"_MSGUNITS
... S FOUNDIT=1 ; Set flag
... S ^TMP("BLRLINKU",$J,MSGNUM)=""
;
D STORFIND(UID,1) ; Store Ending Time of search
;
D ENTRYAUD^BLRUTIL("GETINTHU^BLRLINKU 9.0")
Q FOUNDIT
;
; Done to speed up Lab to PCC processing for Ref Labs
; Sets ^XTMP array to only those accessions tied to reference labs
REFLAB68 ; EP -- Setup ^XTMP global with Ref Lab Accessions' IENs
; If purge date > Today, then RETURN
Q:+$P($G(^XTMP("BLRLINKU",0)),"^")>$$DT^XLFDT
;
NEW REFLLRAA,REFLLABN,REFLLABS,LRAAREF,INCOMIEN,BLRDIVS,DESTIEN,DESTNAME,OUTARRAY
NEW INSTIEN,LOCIEN
;
K ^XTMP("BLRLINKU") ; Clear
;
; Initialize ^XTMP per SAC guidelines
S ^XTMP("BLRLINKU",0)=$$HTFM^XLFDT(+$H+30)_"^"_$$HTFM^XLFDT(+$H)_"^BLRLINK Ref Lab Data"
;
S BLRDIVS=.9999999
F S BLRDIVS=$O(^BLRSITE(BLRDIVS)) Q:BLRDIVS<1 D
. S LOCIEN=+$G(^BLRSITE(BLRDIVS,0))
. S INSTIEN=+$G(^AUTTLOC(LOCIEN,0)) ; Institution IEN
. ;
. ; ----- BEGIN IHS/MSC/MKK LR*5.2*1031
. ; Any Reference Lab that has the REF LAB USING LEDI field set to
. ; YES in the BLR MASTER CONTROL file is using LEDI for the
. ; interface. That means incoming data goes directly into 62.49,
. ; bypassing 4001, so skip this logic.
. ; Q:$$UP^XLFSTR($$GET1^DIQ(9009029,INSTIEN,3022))["Y" ; Don't do this -- IHS/MSC/MKK - LR*5.2*1033
. ; ----- END IHS/MSC/MKK LR*5.2*1031
. ;
. S REFLLABS=+$G(^BLRSITE(BLRDIVS,"RL"))
. S REFLABN=$P($G(^BLRRL(REFLLABS,0)),"^")
. S DESTNAME="HL IHS LAB R01 "_REFLABN_" IN"
. K OUTARRAY
. D FIND^DIC(4005,,,,DESTNAME,,,,,"OUTARRAY")
. S DESTIEN=$G(OUTARRAY("DILIST",2,1))
. ; Q:DESTIEN<1
. ; S ^XTMP("BLRLINKU",INSTIEN)=DESTIEN_"^"_DESTNAME
. ; S ^XTMP("BLRLINKU",INSTIEN)="" ; IHS/MSC/MKK - LR*5.2*1034
. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1037
. I +$G(DESTIEN) S ^XTMP("BLRLINKU",INSTIEN)=+$G(DESTIEN)_"^"_DESTNAME
. E S ^XTMP("BLRLINKU",INSTIEN)=""
. ; ----- END IHS/MSC/MKK - LR*5.2*1037
. S REFLLRAA=.9999999
. F S REFLLRAA=$O(^BLRRL(REFLLABS,2,REFLLRAA)) Q:REFLLRAA="" D
.. S LRAAREF=+$G(^BLRRL(REFLLABS,2,REFLLRAA,0))
.. Q:LRAAREF<1
.. S ^XTMP("BLRLINKU",INSTIEN,LRAAREF)=$P($G(^LRO(68,LRAAREF,0)),"^")
Q
;
STORFIND(UID,WOT) ; EP - Store Time Before or After $Order through the ^INTHU global
D:$D(^XTMP("BLRSRCH"))<1 RESTART
D:$$FMDIFF^XLFDT($$DT^XLFDT,$P($G(^XTMP("BLRSRCH")),"^",2),1)>7 RESTART
;
S CNT=1+$G(^XTMP("BLRSRCH",-1))
S ^XTMP("BLRSRCH",-1)=CNT
S ^XTMP("BLRSRCH",CNT,UID,WOT)=$H
Q
;
RESTART ; EP - Create ^XTMP("BLRSRCH") if it doesn't exist or restart it
K ^XTMP("BLRSRCH")
S ^XTMP("BLRSRCH")=$$HTFM^XLFDT(+$H+30)_"^"_$$HTFM^XLFDT(+$H)_"^Timing of ^INTHU Searches"
Q
;
; The following report is designed for programmers ONLY. It is used to
; determine the efficiency of the $ORDER command through the ^INTHU
; global. This could be a major issue.
; Note: this report only prints to the screen.
REPTSTOR ; EP -- Progrmmaer Mode Only Report on ^XTMP("BLRSRCH") global
NEW HEADER,HD1,LINES,MAXLINES,PG,QFLG
NEW CNT,DIFFTIME,EDT,LRAS,SDT,UID
;
D REPTSINI
;
F S CNT=$O(^XTMP("BLRSRCH",CNT)) Q:CNT<1!(QFLG="Q") D
. F S UID=$O(^XTMP("BLRSRCH",CNT,UID)) Q:UID<1!(QFLG="Q") D
.. D REPTSLIN
;
D PRESSKEY^BLRGMENU(4)
Q
;
REPTSINI ; EP -- Initialize Variables
S HEADER(1)="RPMS LAB Report"
S HEADER(2)="$ORDER Traversal Speed thru ^INTHU Global"
S HEADER(3)=$$CJ^XLFSTR($FN($P($G(^INTHU(0)),"^",3),",")_" Entries in ^INTHU",IOM)
S HEADER(4)=" "
S HEADER(5)="UID"
S $E(HEADER(5),12)="Accession"
S $E(HEADER(5),32)="Start Dt/Time"
S $E(HEADER(5),52)="End Dt/Time"
S $E(HEADER(5),73)="How Long"
;
S PG=0,MAXLINES=22,LINES=MAXLINES+10,QFLG="OKAY",HD1="NO"
S CNT=.9999999,UID=""
;
Q
;
REPTSLIN ; EP - Write a line of Data
D RPTSBRKO
;
I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HD1) Q:QFLG="Q"
;
W UID
W ?11,LRAS
W ?31,SDT
W ?51,EDT
W ?71,$J(DIFFTIME,9)
W !
S LINES=LINES+1
Q
;
; ^XTMP("BLRSRCH",CNT,UID,WOT)=$H
RPTSBRKO ; EP - Breakout values for variables
NEW HDE,HDS,LRAA,LRAD,LRAN
S (SDT,EDT,DIFFTIME,LRAS)=""
;
S LRAA=+$O(^LRO(68,"C",UID,""))
S LRAD=+$O(^LRO(68,"C",UID,LRAA,""))
S LRAN=+$O(^LRO(68,"C",UID,LRAA,LRAD,""))
S LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
;
S HDS=$G(^XTMP("BLRSRCH",CNT,UID,0))
S SDT=$$UP^XLFSTR($$HTE^XLFDT(HDS,"5MPZ"))
;
; If next entry is not the same UID, can't do a Time Comparison
Q:$O(^XTMP("BLRSRCH",CNT+1,""))'=UID
;
; Skip if no "Ending Time"
Q:$G(^XTMP("BLRSRCH",CNT+1,UID,1))=""
;
S CNT=CNT+1 ; Yes, increment $ORDER variable.
;
S HDE=$G(^XTMP("BLRSRCH",CNT,UID,1))
S EDT=$$UP^XLFSTR($$HTE^XLFDT(HDE,"5MPZ"))
;
S DIFFTIME=$$HDIFF^XLFDT(HDE,HDS,3)
Q
;
;
ICDCHEK(ICDCODE) ; EP - Check to see if passed string is in ICD dictionary.
NEW TARGET,ERRORS,X
;
I ICDCODE["^" S ICDCODE=$P(ICDCODE,"^")
Q:+ICDCODE<1 0
;
; D FIND^DIC(80,,,"M",ICDCODE,,,,,"TARGET","ERRORS")
; Q $S(+$G(TARGET("DILIST",1,1))>0:1,1:0)
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
; Q $L($$ICDDX^ICDCODE(ICDCODE))
Q $L($$ICDDX^ICDEX(ICDCODE)) ; IHS/MSC/MKK - LR*5.2*1034 - Use AICD 4.0 function
; ----- END IHS/MSC/MKK - LR*5.2*1033
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
RESETX ; EP
; Delete the ^XTMP("BLRLINKU" global. This allows
; REFLAB68 (see above) to rebuild the global with
; the latest information.
NEW HEADER
S HEADER(1)="IHS LABORATORY"
S HEADER(2)="Reset ^XTMP(""BLRLINKU"") Global"
D HEADERDT^BLRGMENU
W ?9,"This option will reset the ^XTMP(""BLRLINKU"") Global.",!
W !
W ?9,"The ^XTMP(""BLRLINKU"") Global is ONLY used for Reference Lab",!
W ?9,"processes.",!
W !
Q:$$WARNINGS("Are you SURE you want to reset the ")="Q"
;
S HEADER(3)=$$CJ^XLFSTR("SECOND CHANCE",IOM)
D HEADERDT^BLRGMENU
Q:$$WARNINGS("Are you ABSOLUTELY CERTAIN you want to reset the")="Q"
;
K HEADER(3)
S HEADER(3)=$$CJ^XLFSTR("LAST CHANCE",IOM)
D HEADERDT^BLRGMENU
Q:$$WARNINGS("FINAL WARNING. Do you REALLY want to reset the")="Q"
;
K HEADER(3)
K ^XTMP("BLRLINKU") ; Clear
D REFLAB68 ; Rebuild
;
D HEADERDT^BLRGMENU
W !!,?9,"^XTMP(""BLRLINKU"") Global has been reset.",!
D PRESSKEY^BLRGMENU(14)
Q
;
WARNINGS(MSG) ; EP
W ?9,MSG
D ^XBFMK
S DIR(0)="YO"
S DIR("A")=$J("",9)_"^XTMP(""BLRLINKU"") Global (Y/N)"
S DIR("B")="NO"
D ^DIR
I +$G(Y)<1 D Q "Q"
. W !!,?14,"Invalid/Quit/No response. Routine Ends."
. D PRESSKEY^BLRGMENU(19)
Q "OK"
; ----- END IHS/MSC/MKK - LR*5.2*1031
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
LAHREFR() ; EP - Return Flag/Ref Ranges/Units from ^LR, if possible
NEW F60IEN,ISQN,LWL,LRSB,RESULT,RHI,RLOW,TMPBLRU,UNITS
;
D ENTRYAUD^BLRUTIL("LAHREFR^BLRLINKU 1.0")
;
S LRAA=+$O(^LRO(68,"C",UID,0)),LRAD=+$O(^LRO(68,"C",UID,LRAA,0)),LRAN=+$O(^LRO(68,"C",UID,LRAA,LRAD,0))
Q:LRAA<1!(LRAD<1)!(LRAN<1) 0
;
S LRAAIEN=LRAN_","_LRAD_","_LRAA
S LRDFN=$$GET1^DIQ(68.02,LRAAIEN,.01)
S LRIDT=$$GET1^DIQ(68.02,LRAAIEN,13.5,"I")
;
S F60IEN=+$P($G(^BLRTXLOG(BLRLOGDA,0)),"^",6)
S LRSB=+$$GET1^DIQ(60,F60IEN,"DATA NAME","I")
;
S STR=$G(^LR(LRDFN,"CH",LRIDT,LRSB))
;
D ENTRYAUD^BLRUTIL("LAHREFR^BLRLINKU 3.0")
;
Q:$L(STR)<1 0
;
S RESULT=$P(STR,U) ; Results
S ABN=$P(STR,U,2) ; Status Flag
;
S OTHER=$P(STR,U,5)
S RLOW=$P(OTHER,"!",2) ; Reference Low
S RHI=$P(OTHER,"!",3) ; Reference High
S UNITS=$P(OTHER,"!",7) ; Units
;
; Store information
S ^TMP("BLR",$J,UID,F60IEN)=RESULT_"^"_ABN_"^"_RLOW_"^"_RHI_"^"_UNITS
S FOUNDIT=1 ; Set flag
;
M TMPBLRU("BLR",$J,UID,F60IEN)=^TMP("BLR",$J,UID,F60IEN)
D ENTRYAUD^BLRUTIL("LAHREFR^BLRLINKU 9.0")
Q 1
; ----- END IHS/MSC/MKK - LR*5.2*1038
BLRLINKU ;IHS/OIT/MKK - IHS LABORATORY VISIT CREATION Utilities ; 25-Nov-2014 09:22 ; MKK
+1 ;;5.2;IHS LABORATORY;**1030,1031,1033,1034,1037,1038**;NOV 01, 1997;Build 6
+2 ;
+3 ; Need to get Reference Ranges & Units from Incoming HL7 message
+4 ; IF and ONLY IF the transaction is tied to a Reference Lab Accession
CHKINHL7 ; EP
+1 DO ENTRYAUD^BLRUTIL("CHKINHL7^BLRLINKU 0.0","BLRVAL")
+2 NEW DNIEN,DNDESC,F60IEN,HL7TEST,LRAA,LRAD,LRAN,LRAS,STR,UID
+3 NEW ABNFLAG,REFHIGH,REFLOW,UNITS
+4 ;
+5 ; If no BLR Txn #, skip
IF +$GET(BLRLOGDA)<1
QUIT
+6 ;
+7 ; Accession number
SET LRAS=$PIECE($GET(^BLRTXLOG(BLRLOGDA,12)),"^",2)
+8 ; Get Accession's component parts
DO GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
+9 ; Quit if Accession doesn't exist
IF LRAA<1!(LRAD<1)!(LRAN<1)
QUIT
+10 ;
+11 ; Check on ^XTMP("BLRLINKU")
DO REFLAB68
+12 ; If not a Ref Lab Accession, skip
IF $DATA(^XTMP("BLRLINKU",$GET(DUZ(2)),LRAA))<1
QUIT
+13 ;
+14 ; File 60 IEN
SET F60IEN=+$PIECE($GET(^BLRTXLOG(BLRLOGDA,0)),"^",6)
+15 ;
+16 SET UID=+$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
+17 ; If no UID, skip
IF UID<1
QUIT
+18 ;
+19 IF $$GETINTHU(UID)<1
QUIT
+20 ;
+21 DO ENTRYAUD^BLRUTIL("CHKINHL7^BLRLINKU 4.5")
+22 ;
+23 SET STR=$GET(^TMP("BLR",$JOB,UID,F60IEN))
+24 IF $LENGTH(STR)<1
QUIT
+25 ;
+26 ; Abnormal Flag
DO STORVAL(2,$PIECE(STR,"^",2))
+27 ; Units
DO STORVAL(3,$PIECE(STR,"^",5))
+28 ; Reference Low
DO STORVAL(8,$PIECE(STR,"^",3))
+29 ; Referench High
DO STORVAL(9,$PIECE(STR,"^",4))
+30 ;
+31 DO ENTRYAUD^BLRUTIL("CHKINHL7^BLRLINKU 9.0","BLRVAL")
+32 QUIT
+33 ;
STORVAL(WHERE,WHAT) ; EP -- Store values in the IHS LAB TRANSACTION LOG file AND the BLRVAL array
+1 ; Skip if no results
IF $LENGTH(WHAT)<1
QUIT
+2 ;
+3 SET $PIECE(BLRVAL(20),"^",WHERE)=WHAT
+4 SET $PIECE(^BLRTXLOG(BLRLOGDA,20),"^",WHERE)=WHAT
+5 QUIT
+6 ;
GETINTHU(UID) ; EP -- Get Reference Range information from File 4001 (UNIVERSAL INTERFACE)
+1 DO ENTRYAUD^BLRUTIL("GETINTHU^BLRLINKU 0.0")
+2 ;
+3 ; Don't search if test already stored in ^TMP global
+4 IF $DATA(^TMP("BLR",$JOB,UID,F60IEN))>0
QUIT 1
+5 ;
+6 NEW AUTIF60P,AUTOINSN,AUTOINSP,AUTOITST,FOUNDIT,MSGID,MSGNUM,MSGUID,MSGSEG,MSGSTR
+7 NEW MSGRESLT,MSGUNITS,MSGRLOW,MSGRHI,MSGABN,NOTMSG
+8 NEW LA7INST,AUTOINSP,WOTPIECE,WOTREF
+9 ;
+10 ; Retrieve "Instrument Name" for Reference Lab
+11 SET LA7INST=$$GET1^DIQ(9009029,DUZ(2),3001)
+12 ; Quit with zero if no Reference Lab
IF $GET(LA7INST)=""
QUIT 0
+13 ;
+14 ; Auto Instrument IEN
SET AUTOINSP=+$ORDER(^LAB(62.4,"B",LA7INST,""))
+15 ; Quit with zero if No Auto Instrument
IF AUTOINSP<1
QUIT 0
+16 ;
+17 ; IHS/MSC/MKK - LR*5.2*1038
IF $$LAHREFR()
QUIT 1
+18 ;
+19 ; Determine what piece is the observation sub-id: QUEST uses OBX3.4; all others use OBX3.1
+20 SET WOTPIECE=$SELECT($$UP^XLFSTR(LA7INST)["QUEST":4,1:1)
+21 ;
+22 ; Store Starting Time of search
IF $GET(SNAPSHOT)
DO STORFIND(UID,0)
+23 ; Interface Destination (# 4005) IEN
SET WOTREF=+$GET(^XTMP("BLRLINKU",+$GET(DUZ(2))))
+24 ; Quit with zero if IEN<1
IF WOTREF<1
QUIT 0
+25 ;
+26 ; NEW MSGSEG2 ; IHS/MSC/MKK - LR*5.2*1034
+27 ;
+28 ; Use "AD" Cross Reference
+29 SET (FOUNDIT,MSGNUM)=0
+30 FOR
SET MSGNUM=$ORDER(^INTHU("AD",WOTREF,MSGNUM))
IF MSGNUM<1!(FOUNDIT)
QUIT
Begin DoDot:1
+31 SET (MSGSEG,NOTMSG)=0
+32 FOR
SET MSGSEG=$ORDER(^INTHU(MSGNUM,3,MSGSEG))
IF MSGSEG<1!(FOUNDIT)
QUIT
Begin DoDot:2
+33 IF $PIECE($GET(^INTHU(MSGNUM,3,MSGSEG,0)),"|")="OBR"
Begin DoDot:3
+34 ; Determine if UID = UID of Message
+35 IF UID=+$PIECE($GET(^INTHU(MSGNUM,3,MSGSEG,0)),"|",3)
SET FOUNDIT=MSGNUM
End DoDot:3
+36 IF 'FOUNDIT
QUIT
+37 ;
+38 ; Find OBX segment
+39 SET (CNT,FOUNDIT)=0
+40 ; IHS/MSC/MKK - LR*5.2*1034
SET MSGSEG2=MSGSEG
+41 ; F S MSGSEG=$O(^INTHU(MSGNUM,3,MSGSEG)) Q:MSGSEG<1!(FOUNDIT) D
+42 ; IHS/MSC/MKK - LR*5.2*1034
FOR
SET MSGSEG2=$ORDER(^INTHU(MSGNUM,3,MSGSEG2))
IF MSGSEG2<1!(FOUNDIT)
QUIT
Begin DoDot:3
+43 ; S MSGSTR=$G(^INTHU(MSGNUM,3,MSGSEG,0))
+44 ; IHS/MSC/MKK - LR*5.2*1034
SET MSGSTR=$GET(^INTHU(MSGNUM,3,MSGSEG2,0))
+45 IF $PIECE(MSGSTR,"|")'="OBX"
QUIT
+46 ;
+47 SET CNT=CNT+1
+48 ; OBX 3
SET MSGTEST=$PIECE($PIECE(MSGSTR,"|",4),"^",WOTPIECE)
+49 ; Don't check if not defined
IF $LENGTH(MSGTEST)<1
QUIT
+50 ;
+51 ; Don't check if not in Auto Instrument file
IF $DATA(^LAB(62.4,AUTOINSP,3,"AC",MSGTEST))<1
QUIT
+52 ;
+53 ; File 60 IEN from Auto Instrument file
+54 SET AUTIF60P=$PIECE($GET(^LAB(62.4,AUTOINSP,3,$ORDER(^LAB(62.4,AUTOINSP,3,"AC",MSGTEST,0)),0)),"^")
+55 ;
+56 ; Results
SET MSGRESLT=$PIECE(MSGSTR,"|",6)
+57 ; Units
SET MSGUNITS=$PIECE(MSGSTR,"|",7)
+58 ; Reference Low
SET MSGRLOW=$PIECE($PIECE(MSGSTR,"|",8),"-")
+59 ; Reference High
SET MSGRHI=$PIECE($PIECE(MSGSTR,"|",8),"-",2)
+60 ; Status Flag
SET MSGABN=$PIECE(MSGSTR,"|",9)
+61 SET MSGABN=$SELECT(MSGABN="L":MSGABN,MSGABN="H":MSGABN,MSGABN="A":MSGABN,1:"")
+62 ;
+63 ; Store information
+64 SET ^TMP("BLR",$JOB,UID,AUTIF60P)=MSGRESLT_"^"_MSGABN_"^"_MSGRLOW_"^"_MSGRHI_"^"_MSGUNITS
+65 ; Set flag
SET FOUNDIT=1
+66 SET ^TMP("BLRLINKU",$JOB,MSGNUM)=""
End DoDot:3
End DoDot:2
End DoDot:1
+67 ;
+68 ; Store Ending Time of search
DO STORFIND(UID,1)
+69 ;
+70 DO ENTRYAUD^BLRUTIL("GETINTHU^BLRLINKU 9.0")
+71 QUIT FOUNDIT
+72 ;
+73 ; Done to speed up Lab to PCC processing for Ref Labs
+74 ; Sets ^XTMP array to only those accessions tied to reference labs
REFLAB68 ; EP -- Setup ^XTMP global with Ref Lab Accessions' IENs
+1 ; If purge date > Today, then RETURN
+2 IF +$PIECE($GET(^XTMP("BLRLINKU",0)),"^")>$$DT^XLFDT
QUIT
+3 ;
+4 NEW REFLLRAA,REFLLABN,REFLLABS,LRAAREF,INCOMIEN,BLRDIVS,DESTIEN,DESTNAME,OUTARRAY
+5 NEW INSTIEN,LOCIEN
+6 ;
+7 ; Clear
KILL ^XTMP("BLRLINKU")
+8 ;
+9 ; Initialize ^XTMP per SAC guidelines
+10 SET ^XTMP("BLRLINKU",0)=$$HTFM^XLFDT(+$HOROLOG+30)_"^"_$$HTFM^XLFDT(+$HOROLOG)_"^BLRLINK Ref Lab Data"
+11 ;
+12 SET BLRDIVS=.9999999
+13 FOR
SET BLRDIVS=$ORDER(^BLRSITE(BLRDIVS))
IF BLRDIVS<1
QUIT
Begin DoDot:1
+14 SET LOCIEN=+$GET(^BLRSITE(BLRDIVS,0))
+15 ; Institution IEN
SET INSTIEN=+$GET(^AUTTLOC(LOCIEN,0))
+16 ;
+17 ; ----- BEGIN IHS/MSC/MKK LR*5.2*1031
+18 ; Any Reference Lab that has the REF LAB USING LEDI field set to
+19 ; YES in the BLR MASTER CONTROL file is using LEDI for the
+20 ; interface. That means incoming data goes directly into 62.49,
+21 ; bypassing 4001, so skip this logic.
+22 ; Q:$$UP^XLFSTR($$GET1^DIQ(9009029,INSTIEN,3022))["Y" ; Don't do this -- IHS/MSC/MKK - LR*5.2*1033
+23 ; ----- END IHS/MSC/MKK LR*5.2*1031
+24 ;
+25 SET REFLLABS=+$GET(^BLRSITE(BLRDIVS,"RL"))
+26 SET REFLABN=$PIECE($GET(^BLRRL(REFLLABS,0)),"^")
+27 SET DESTNAME="HL IHS LAB R01 "_REFLABN_" IN"
+28 KILL OUTARRAY
+29 DO FIND^DIC(4005,,,,DESTNAME,,,,,"OUTARRAY")
+30 SET DESTIEN=$GET(OUTARRAY("DILIST",2,1))
+31 ; Q:DESTIEN<1
+32 ; S ^XTMP("BLRLINKU",INSTIEN)=DESTIEN_"^"_DESTNAME
+33 ; S ^XTMP("BLRLINKU",INSTIEN)="" ; IHS/MSC/MKK - LR*5.2*1034
+34 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1037
+35 IF +$GET(DESTIEN)
SET ^XTMP("BLRLINKU",INSTIEN)=+$GET(DESTIEN)_"^"_DESTNAME
+36 IF '$TEST
SET ^XTMP("BLRLINKU",INSTIEN)=""
+37 ; ----- END IHS/MSC/MKK - LR*5.2*1037
+38 SET REFLLRAA=.9999999
+39 FOR
SET REFLLRAA=$ORDER(^BLRRL(REFLLABS,2,REFLLRAA))
IF REFLLRAA=""
QUIT
Begin DoDot:2
+40 SET LRAAREF=+$GET(^BLRRL(REFLLABS,2,REFLLRAA,0))
+41 IF LRAAREF<1
QUIT
+42 SET ^XTMP("BLRLINKU",INSTIEN,LRAAREF)=$PIECE($GET(^LRO(68,LRAAREF,0)),"^")
End DoDot:2
End DoDot:1
+43 QUIT
+44 ;
STORFIND(UID,WOT) ; EP - Store Time Before or After $Order through the ^INTHU global
+1 IF $DATA(^XTMP("BLRSRCH"))<1
DO RESTART
+2 IF $$FMDIFF^XLFDT($$DT^XLFDT,$PIECE($GET(^XTMP("BLRSRCH")),"^",2),1)>7
DO RESTART
+3 ;
+4 SET CNT=1+$GET(^XTMP("BLRSRCH",-1))
+5 SET ^XTMP("BLRSRCH",-1)=CNT
+6 SET ^XTMP("BLRSRCH",CNT,UID,WOT)=$HOROLOG
+7 QUIT
+8 ;
RESTART ; EP - Create ^XTMP("BLRSRCH") if it doesn't exist or restart it
+1 KILL ^XTMP("BLRSRCH")
+2 SET ^XTMP("BLRSRCH")=$$HTFM^XLFDT(+$HOROLOG+30)_"^"_$$HTFM^XLFDT(+$HOROLOG)_"^Timing of ^INTHU Searches"
+3 QUIT
+4 ;
+5 ; The following report is designed for programmers ONLY. It is used to
+6 ; determine the efficiency of the $ORDER command through the ^INTHU
+7 ; global. This could be a major issue.
+8 ; Note: this report only prints to the screen.
REPTSTOR ; EP -- Progrmmaer Mode Only Report on ^XTMP("BLRSRCH") global
+1 NEW HEADER,HD1,LINES,MAXLINES,PG,QFLG
+2 NEW CNT,DIFFTIME,EDT,LRAS,SDT,UID
+3 ;
+4 DO REPTSINI
+5 ;
+6 FOR
SET CNT=$ORDER(^XTMP("BLRSRCH",CNT))
IF CNT<1!(QFLG="Q")
QUIT
Begin DoDot:1
+7 FOR
SET UID=$ORDER(^XTMP("BLRSRCH",CNT,UID))
IF UID<1!(QFLG="Q")
QUIT
Begin DoDot:2
+8 DO REPTSLIN
End DoDot:2
End DoDot:1
+9 ;
+10 DO PRESSKEY^BLRGMENU(4)
+11 QUIT
+12 ;
REPTSINI ; EP -- Initialize Variables
+1 SET HEADER(1)="RPMS LAB Report"
+2 SET HEADER(2)="$ORDER Traversal Speed thru ^INTHU Global"
+3 SET HEADER(3)=$$CJ^XLFSTR($FNUMBER($PIECE($GET(^INTHU(0)),"^",3),",")_" Entries in ^INTHU",IOM)
+4 SET HEADER(4)=" "
+5 SET HEADER(5)="UID"
+6 SET $EXTRACT(HEADER(5),12)="Accession"
+7 SET $EXTRACT(HEADER(5),32)="Start Dt/Time"
+8 SET $EXTRACT(HEADER(5),52)="End Dt/Time"
+9 SET $EXTRACT(HEADER(5),73)="How Long"
+10 ;
+11 SET PG=0
SET MAXLINES=22
SET LINES=MAXLINES+10
SET QFLG="OKAY"
SET HD1="NO"
+12 SET CNT=.9999999
SET UID=""
+13 ;
+14 QUIT
+15 ;
REPTSLIN ; EP - Write a line of Data
+1 DO RPTSBRKO
+2 ;
+3 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,HD1)
IF QFLG="Q"
QUIT
+4 ;
+5 WRITE UID
+6 WRITE ?11,LRAS
+7 WRITE ?31,SDT
+8 WRITE ?51,EDT
+9 WRITE ?71,$JUSTIFY(DIFFTIME,9)
+10 WRITE !
+11 SET LINES=LINES+1
+12 QUIT
+13 ;
+14 ; ^XTMP("BLRSRCH",CNT,UID,WOT)=$H
RPTSBRKO ; EP - Breakout values for variables
+1 NEW HDE,HDS,LRAA,LRAD,LRAN
+2 SET (SDT,EDT,DIFFTIME,LRAS)=""
+3 ;
+4 SET LRAA=+$ORDER(^LRO(68,"C",UID,""))
+5 SET LRAD=+$ORDER(^LRO(68,"C",UID,LRAA,""))
+6 SET LRAN=+$ORDER(^LRO(68,"C",UID,LRAA,LRAD,""))
+7 SET LRAS=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
+8 ;
+9 SET HDS=$GET(^XTMP("BLRSRCH",CNT,UID,0))
+10 SET SDT=$$UP^XLFSTR($$HTE^XLFDT(HDS,"5MPZ"))
+11 ;
+12 ; If next entry is not the same UID, can't do a Time Comparison
+13 IF $ORDER(^XTMP("BLRSRCH",CNT+1,""))'=UID
QUIT
+14 ;
+15 ; Skip if no "Ending Time"
+16 IF $GET(^XTMP("BLRSRCH",CNT+1,UID,1))=""
QUIT
+17 ;
+18 ; Yes, increment $ORDER variable.
SET CNT=CNT+1
+19 ;
+20 SET HDE=$GET(^XTMP("BLRSRCH",CNT,UID,1))
+21 SET EDT=$$UP^XLFSTR($$HTE^XLFDT(HDE,"5MPZ"))
+22 ;
+23 SET DIFFTIME=$$HDIFF^XLFDT(HDE,HDS,3)
+24 QUIT
+25 ;
+26 ;
ICDCHEK(ICDCODE) ; EP - Check to see if passed string is in ICD dictionary.
+1 NEW TARGET,ERRORS,X
+2 ;
+3 IF ICDCODE["^"
SET ICDCODE=$PIECE(ICDCODE,"^")
+4 IF +ICDCODE<1
QUIT 0
+5 ;
+6 ; D FIND^DIC(80,,,"M",ICDCODE,,,,,"TARGET","ERRORS")
+7 ; Q $S(+$G(TARGET("DILIST",1,1))>0:1,1:0)
+8 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
+9 ; Q $L($$ICDDX^ICDCODE(ICDCODE))
+10 ; IHS/MSC/MKK - LR*5.2*1034 - Use AICD 4.0 function
QUIT $LENGTH($$ICDDX^ICDEX(ICDCODE))
+11 ; ----- END IHS/MSC/MKK - LR*5.2*1033
+12 ;
+13 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
RESETX ; EP
+1 ; Delete the ^XTMP("BLRLINKU" global. This allows
+2 ; REFLAB68 (see above) to rebuild the global with
+3 ; the latest information.
+4 NEW HEADER
+5 SET HEADER(1)="IHS LABORATORY"
+6 SET HEADER(2)="Reset ^XTMP(""BLRLINKU"") Global"
+7 DO HEADERDT^BLRGMENU
+8 WRITE ?9,"This option will reset the ^XTMP(""BLRLINKU"") Global.",!
+9 WRITE !
+10 WRITE ?9,"The ^XTMP(""BLRLINKU"") Global is ONLY used for Reference Lab",!
+11 WRITE ?9,"processes.",!
+12 WRITE !
+13 IF $$WARNINGS("Are you SURE you want to reset the ")="Q"
QUIT
+14 ;
+15 SET HEADER(3)=$$CJ^XLFSTR("SECOND CHANCE",IOM)
+16 DO HEADERDT^BLRGMENU
+17 IF $$WARNINGS("Are you ABSOLUTELY CERTAIN you want to reset the")="Q"
QUIT
+18 ;
+19 KILL HEADER(3)
+20 SET HEADER(3)=$$CJ^XLFSTR("LAST CHANCE",IOM)
+21 DO HEADERDT^BLRGMENU
+22 IF $$WARNINGS("FINAL WARNING. Do you REALLY want to reset the")="Q"
QUIT
+23 ;
+24 KILL HEADER(3)
+25 ; Clear
KILL ^XTMP("BLRLINKU")
+26 ; Rebuild
DO REFLAB68
+27 ;
+28 DO HEADERDT^BLRGMENU
+29 WRITE !!,?9,"^XTMP(""BLRLINKU"") Global has been reset.",!
+30 DO PRESSKEY^BLRGMENU(14)
+31 QUIT
+32 ;
WARNINGS(MSG) ; EP
+1 WRITE ?9,MSG
+2 DO ^XBFMK
+3 SET DIR(0)="YO"
+4 SET DIR("A")=$JUSTIFY("",9)_"^XTMP(""BLRLINKU"") Global (Y/N)"
+5 SET DIR("B")="NO"
+6 DO ^DIR
+7 IF +$GET(Y)<1
Begin DoDot:1
+8 WRITE !!,?14,"Invalid/Quit/No response. Routine Ends."
+9 DO PRESSKEY^BLRGMENU(19)
End DoDot:1
QUIT "Q"
+10 QUIT "OK"
+11 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+12 ;
+13 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
LAHREFR() ; EP - Return Flag/Ref Ranges/Units from ^LR, if possible
+1 NEW F60IEN,ISQN,LWL,LRSB,RESULT,RHI,RLOW,TMPBLRU,UNITS
+2 ;
+3 DO ENTRYAUD^BLRUTIL("LAHREFR^BLRLINKU 1.0")
+4 ;
+5 SET LRAA=+$ORDER(^LRO(68,"C",UID,0))
SET LRAD=+$ORDER(^LRO(68,"C",UID,LRAA,0))
SET LRAN=+$ORDER(^LRO(68,"C",UID,LRAA,LRAD,0))
+6 IF LRAA<1!(LRAD<1)!(LRAN<1)
QUIT 0
+7 ;
+8 SET LRAAIEN=LRAN_","_LRAD_","_LRAA
+9 SET LRDFN=$$GET1^DIQ(68.02,LRAAIEN,.01)
+10 SET LRIDT=$$GET1^DIQ(68.02,LRAAIEN,13.5,"I")
+11 ;
+12 SET F60IEN=+$PIECE($GET(^BLRTXLOG(BLRLOGDA,0)),"^",6)
+13 SET LRSB=+$$GET1^DIQ(60,F60IEN,"DATA NAME","I")
+14 ;
+15 SET STR=$GET(^LR(LRDFN,"CH",LRIDT,LRSB))
+16 ;
+17 DO ENTRYAUD^BLRUTIL("LAHREFR^BLRLINKU 3.0")
+18 ;
+19 IF $LENGTH(STR)<1
QUIT 0
+20 ;
+21 ; Results
SET RESULT=$PIECE(STR,U)
+22 ; Status Flag
SET ABN=$PIECE(STR,U,2)
+23 ;
+24 SET OTHER=$PIECE(STR,U,5)
+25 ; Reference Low
SET RLOW=$PIECE(OTHER,"!",2)
+26 ; Reference High
SET RHI=$PIECE(OTHER,"!",3)
+27 ; Units
SET UNITS=$PIECE(OTHER,"!",7)
+28 ;
+29 ; Store information
+30 SET ^TMP("BLR",$JOB,UID,F60IEN)=RESULT_"^"_ABN_"^"_RLOW_"^"_RHI_"^"_UNITS
+31 ; Set flag
SET FOUNDIT=1
+32 ;
+33 MERGE TMPBLRU("BLR",$JOB,UID,F60IEN)=^TMP("BLR",$JOB,UID,F60IEN)
+34 DO ENTRYAUD^BLRUTIL("LAHREFR^BLRLINKU 9.0")
+35 QUIT 1
+36 ; ----- END IHS/MSC/MKK - LR*5.2*1038
