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

BLRLINKU.m

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