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

BLRLINK3.m

Go to the documentation of this file. 
  1. BLRLINK3 ; IHS/HQT/MJL - CONT. OF BLR - IHS LABORATORY VISIT CREATION ; 13-Oct-2017 14:04 ; MKK
  1.  ;;5.2;IHS LABORATORY;**1010,1011,1014,1015,1018,1021,1022,1024,1025,1027,1028,1029,1030,1031,1033,1034,1037,1039,1041**;NOV 01, 1997;Build 23
  1.  ;
  1. EP ; EP
  1.  S BLRVFILE="9000010"_$S(BLRSS="CH":".09",BLRSS="MI":".25",BLRSS="BB":".31",1:"??")
  1.  I BLRVFILE["??" S BLRERR=1,BLRBUL=2,BLRPCC="Unknown Test Subscript - link not yet implemented" Q
  1.  ;
  1.  S BLRVGL=$$GETGREF(BLRVFILE)
  1.  D VBUILD Q:BLRERR
  1.  D VEDIT
  1.  Q
  1.  ;
  1. VBUILD ; EP create APCDALVR array which is the array containing the elements to be passed to PCC
  1.  ;--- BEGIN cmi/anch/maw REF LAB -- LR*5.2*1021
  1.  I $G(^BLRTXLOG("BVER",BLRIEN))]"" D  Q  ;cmi/maw don't move to pcc if held for verification, ref lab
  1.  . S BLRERR=1,BLRBUL=0
  1.  . S BLRPCC="Result being held for verification"
  1.  ;--- END cmi/anch/maw end REF LAB -- LR*5.2*1021
  1.  ;
  1.  ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1022
  1.  ; Make sure CLINIC STOP CODE of LABORATORY SERVICES is used, if it exists
  1.  NEW LABCLIN,OUT
  1.  D FIND^DIC(40.7,"","","","LABORATORY SERVICES","","","","","OUT")
  1.  S LABCLIN=+$G(OUT("DILIST",2,1))
  1.  I LABCLIN>0 D
  1.  . Q:$D(APCDALVR("APCDTCLN"))           ; If and Only If APCDALVR("APCDCLN")=""  -- IHS/MSC/MKK - LR*5.2*1031
  1.  . ; S APCDALVR("APCDTCLN")="`"_LABCLIN
  1.  . ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
  1.  . NEW LOGSTOP
  1.  . S LOGSTOP=+$$GET1^DIQ(9009022,BLRLOGDA,109,"I")
  1.  . S APCDALVR("APCDTCLN")="`"_$S(LOGSTOP:LOGSTOP,1:LABCLIN)
  1.  . ; ----- END IHS/MSC/MKK - LR*5.2*1039
  1.  ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1022
  1.  ;
  1.  S APCDALVR("APCDTCSF")=BLRSTAT
  1.  S APCDALVR("APCDTLAB")=$S(BLRTLAB="":BLRTNAM,1:"`"_BLRTLAB)
  1.  S APCDALVR("APCDTORD")=BLRORD
  1.  S APCDALVR("APCDTCDT")=BLRCDT
  1.  S APCDALVR("APCDTODT")=BLRODT
  1.  S APCDALVR("APCDTACC")=BLRACC
  1.  ;
  1.  ; send parent ien of V file entry for children of panel
  1.  S:BLRPAREN'="" APCDALVR("APCDTPNT")="`"_$P($G(^BLRTXLOG(BLRPAREN,1)),U,5)
  1.  ;ADDED FOR LOINC PROJECT
  1.  S:$G(APCDALVR("APCDTPNT"))="`" APCDALVR("APCDTPNT")=""  ;ITSC/IHS/TPF 03/04/02 ADDED FOR LOINC
  1.  S APCDALVR("APCDTLNC")="`"_$G(BLRLOINC)
  1.  ;
  1.  ;----- BEGIN LR*5.2*1028;08/18/10;IHS/OIT/MPW - IHS LOINC/UCUM MODIFICATIONS
  1.  ; N XXX,LRIEN,BLRUNIT,SIEN
  1.  N XXX,LRIEN,SIEN            ; IHS/MSC/MKK - LR*5.2*1033
  1.  S XXX=$G(BLRVAL(0)),LRIEN=+$P(XXX,U,6)
  1.  I LRIEN,$P(^LAB(60,LRIEN,0),U,5)="" S APCDALVR("APCDTLNC")="`"_$P($G(^LAB(60,LRIEN,9999999)),U,2)
  1.  ; K XXX,LRIEN,BLRUNIT,SIEN
  1.  K XXX,LRIEN,SIEN            ; IHS/MSC/MKK - LR*5.2*1033
  1.  ;----- END LR*5.2*1028 - IHS LOINC/UCUM MODIFICATIONS - IHS/OIT/MPW
  1.  ;
  1.  D:+$L($G(BLRCOMDT))<1 GETCOMPD(BLRLOGDA,BLRACC,$S(BLRTLAB="":BLRTNAM,1:BLRTLAB),.BLRCOMDT)     ; IHS/OIT/MKK - LR*5.2*1031
  1.  ;
  1.  S APCDALVR("APCDTRDT")=$G(BLRCOMDT)
  1.  S APCDALVR("APCDTCLS")="`"_$G(BLRCOLSA)
  1.  S:$G(APCDALVR("APCDTLNC"))="`" APCDALVR("APCDTLNC")=""
  1.  S:APCDALVR("APCDTCLS")="`" APCDALVR("APCDTCLS")=""
  1.  ;END LOINC STUFF
  1.  ;
  1.  S APCDALVR("APCDTCOS")=BLRCOST
  1.  S APCDALVR("APCDTBIL")=BLRBILL
  1.  S APCDALVR("APCDTCPS")=BLRCPTST
  1.  S APCDALVR("APCDTSDI")=BLRSDI
  1.  ;
  1.  ;[LR*5.2*1028;08/18/10;IHS/OIT/MPW]S:$G(BLRUNIT)'="" APCDALVR("APCDTUNI")=BLRUNIT
  1.  I $G(BLRUNIT)'="",'$D(APCDALVR("APCDTUNI")) S APCDALVR("APCDTUNI")=BLRUNIT
  1.  ;
  1.  S APCDALVR("APCDTRFL")=BLRRFL
  1.  S APCDALVR("APCDTRFH")=BLRRFH
  1.  ;
  1.  ;S APCDALVR("APCDTRES")=$E(BLRRES,1,10)
  1.  D:$G(BLRRES)'="" CHSETCOD^BLRLINK4   ; IHS/MSC/MKK - LR*5.2*1031
  1.  S APCDALVR("APCDTRES")=$E(BLRRES,1,30)  ;cmi/maw 3/25/03 changed for ref lab
  1.  ;S APCDALVR("APCDTRES")=BLRRES   ;IHS/ITSC/TPF 03/25/02 WHY A LIMIT OF 10?
  1.  ;THIS IS OLD COMMENT STUFF
  1.  ;I $D(BLRCOM(1)) S APCDALVR("APCDTLC1")=BLRCOM(1)
  1.  ;I $D(BLRCOM(2)) S APCDALVR("APCDTLC2")=BLRCOM(2)
  1.  ;I $D(BLRCOM(3)) S APCDALVR("APCDTLC3")=BLRCOM(3)
  1.  ;
  1.  ;create micro or Blood Bank specific elements in the APCDALVR array
  1.  I BLRSS="MI" D  ;IHS/DIR TUC/FJE 12/08/98
  1.  . S APCDALVR("APCDTORG")=$S(BLRORG="":BLRORGN,1:"`"_BLRORG),APCDALVR("APCDTANT")=$S(BLRANT="":BLRANTN,1:"`"_BLRANT) ; IHS/DIR TUC/FJE 12/08/98
  1.  . S:$G(BLRCOLSP)="" BLRCOLSP=$P($G(^LAB(60,+$G(BLRTEST),0)),"^",9)                                                 ; IHS/MSC/MKK - LR*5.2*1031
  1.  . ;S APCDALVR("APCDTCOL")=$S($G(BLCOLSP)="":$G(BLCOLSP),1:"`"_BLRCOLSP) S:+BLRCOMPD APCDALVR("APCDTCMD")=BLRCOMPD   ; IHS/DIR TUC/FJE 12/08/98
  1.  . S APCDALVR("APCDTCOL")=$S($G(BLCOLSP)'="":$G(BLCOLSP),1:"`"_BLRCOLSP) S:+BLRCOMPD APCDALVR("APCDTCMD")=BLRCOMPD   ; IHS/ITSC/TPF CHINLE FIX 08/16/02
  1.  ;
  1.  D:BLRSS="CH" ADDORDL^BLRLNKU2(BLRLOGDA,.APCDALVR)    ; IHS/MSC/MKK - LR*5.2*1039 - Add in Ordering Location for CH tests if missing
  1.  ;
  1.  S:BLRSS="BB" APCDALVR("APCDTBTN")=BLRBTN,APCDALVR("APCDTANT")=$S(BLRANT="":BLRANTN,1:"`"_BLRANT)
  1.  ;
  1.  S:BLREPRV'="" APCDALVR("APCDTEPR")="`"_BLREPRV
  1.  S:BLROPRV'="" APCDALVR("APCDTPRV")="`"_BLROPRV
  1.  S:BLROPRV="" APCDALVR("APCDTOPR")=$S(BLROPNM="":BLREPNM,1:BLROPNM)
  1.  S:BLRSITE'="" APCDALVR("APCDTSTE")="`"_BLRSITE
  1.  I BLRCPT,$D(^BLRCPT(BLRCPT,0)) S:BLRCPT'="" APCDALVR("APCDTCPT")="`"_BLRCPT ;FJE 1/25/2000
  1.  I BLRVIEN'="" S BLRMOD=1,APCDALVR("APCDLOOK")=BLRVIEN ; do mod
  1.  Q
  1.  ;
  1. VEDIT ; EP update V file entries
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
  1.  NEW REFLABF              ; REFerence LAB Flag
  1.  ;
  1.  S REFLABF=0              ; Initialize to FALSE
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1031
  1.  ;
  1.  I BLRSTAT="D" S DIK=BLRVGL,DA=BLRVIEN D CALLDIK^BLRNLINK Q  ;;results null - do delete
  1.  S BLRTRAN=1
  1.  ;M ^BLRAPCD=APCDALVR
  1.  ; S APCDALVR("APCDTABN")=$S('$D(BLRMOD):BLRABNL,BLRABNL'="":BLRABNL,BLRVIEN="":"",$P($G(@(BLRVGL_"BLRVIEN,0)")),U,5)'="":"@",1:"") ;must be deleted if result value changes
  1.  ;
  1.  S APCDALVR("APCDTABN")=$S('$D(BLRMOD):$G(BLRABNL),BLRVIEN="":"",$P($G(@(BLRVGL_"BLRVIEN,11)")),U,9)="R":"@",$G(BLRABNL)'="":BLRABNL,1:"")  ; IHS/MSC/MKK - LR*5.2*1031 - code will delete flag if result value changes
  1.  ;
  1.  ; S APCDALVR("APCDATMP")=$S($D(BLRMOD):"[APCDALVR "_BLRVFILE_" (MOD)]",1:"[APCDALVR "_BLRVFILE_" (ADD)]") D ^APCDALVR
  1.  ; ----- BEGIN IHS/OIT/MKK LR*5.2*1024 MODIFICATIONS
  1.  ;   Several entries in the APCDALVR array were being cleared, so they are now being
  1.  ;   double-checked BEFORE the call to APCDALVR.
  1.  S APCDALVR("APCDATMP")=$S($D(BLRMOD):"[APCDALVR "_BLRVFILE_" (MOD)]",1:"[APCDALVR "_BLRVFILE_" (ADD)]")
  1.  I $G(APCDALVR("APCDDATE"))="" S APCDALVR("APCDDATE")=$G(BLRCD)
  1.  I $G(APCDALVR("APCDLOC"))="" S APCDALVR("APCDLOC")=$G(BLR("SITE"))
  1.  I $G(APCDALVR("APCDPAT"))="" S APCDALVR("APCDPAT")=$G(BLRVADFN)
  1.  I $G(APCDALVR("APCDCAT"))="" S APCDALVR("APCDCAT")=$G(BLRVCAT)
  1.  I $G(APCDALVR("APCDTYPE"))="" S APCDALVR("APCDTYPE")=$S($P($G(^APCCCTRL(BLR("SITE"),0)),U,4)'="":$P($G(^(0)),U,4),1:"I")
  1.  ;
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
  1.  I $G(APCDALVR("APCDTLPV"))=""&($G(BLRLPOV)'="") D
  1.  . NEW IHSLPOV
  1.  . I $G(BLRLPOV)["^" S IHSLPOV=$P(BLRLPOV,"^",2)
  1.  . S:$G(IHSLPOV)="" IHSLPOV="`"_$P(BLRLPOV,"^")
  1.  . ; I +$$ICDDX^ICDCODE($P(IHSLPOV,"`",2))<1 S IHSLPOV=$P(IHSLPOV,"`",2)    ; IHS/MSC/MKK - LR*5.2*1031
  1.  . ; I +$$ICDDX^ICDCODE($TR($P(IHSLPOV,"`",2),$C(34)))<1 S IHSLPOV=$P(IHSLPOV,"`",2)    ; IHS/MSC/MKK - LR*5.2*1033 -- Make certain no quotes are passed to the ICDCODE routine.
  1.  . I +$$ICDDX^ICDEX($P(IHSLPOV,"`",2),,,"I")<1 S IHSLPOV=$P(IHSLPOV,"`",2)              ; IHS/MSC/MKK - LR*5.2*1034 -- Use AICD 4.0 function
  1.  . S APCDALVR("APCDTLPV")=IHSLPOV
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1027
  1.  ;
  1.  ;APCDTLPV
  1.  ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1025
  1.  ; USER LAST UPDATE field in Visit file is populated by the DUZ.
  1.  ; Temporarily change the DUZ, if possible
  1.  NEW OLDDUZ,USER,TSTR
  1.  M OLDDUZ=DUZ
  1.  ; I +$G(BLRLOGDA)>0 S USER=$P($G(^BLRTXLOG(BLRLOGDA,20)),"^",6)
  1.  ; I +$G(USER)>0 S TSTR="DUZ"_"=USER"  S @TSTR
  1.  ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1025
  1.  ;
  1.  ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
  1.  D RESETDUZ^BLRPCCVC
  1.  ; S APCDALVR("APCDTEPR")="`"_DUZ      ; IHS/OIT/MKK - LR*5.2*1029 - Line commented out
  1.  ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
  1.  ;
  1.  I $G(APCDALVR("BLRLINK"))="" S APCDALVR("BLRLINK")=1
  1.  ;
  1.  ; D HL7REFLR   ; IHS/OIT/MKK - LR*5.2*1027 -- Make sure Ref Lab Reference Ranges used, if they exist
  1.  D HL7REFLR^BLRLINK4(.REFLABF)    ; IHS/MSC/MKK - LR*5.2*1031 -- External Routine
  1.  ;
  1.  ; D CHKPCCRU   ; IHS/OIT/MKK - LR*5.2*1030
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
  1.  I 'REFLABF D
  1.  . D CHKPCCRU^BLRLINK4
  1.  . D CHKREFA^BLRLINK4
  1.  . D LOTZERO^BLRLINK4(.APCDALVR)
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1031
  1.  ;
  1.  ; D RESETLOI        ; IHS/MSC/MKK - LR*5.2*1031 -- Have to reset LOINC each time
  1.  D RESETLOI^BLRLNKU1    ; IHS/MSC/MKK - LR*5.2*1041
  1.  ;
  1.  D RESETPOV^BLRLINK4    ; IHS/MSC/MKK - LR*5.2*1033 -- Make Certain Lab POV valid
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
  1.  D
  1.  . NEW ICDNAME
  1.  . S ICDNAME=$$GET1^DIQ(80,+$P($G(APCDALVR("APCDTICD")),"`",2),.01)
  1.  . I ICDNAME=".9999"!(ICDNAME="ZZZ.999") K APCDALVR("APCDTICD")
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1033
  1.  ;
  1.  D RESETABN   ; IHS/MSC/MKK - LR*5.2*1041 - Set ABNORMAL flag to value in the Lab Data file every time
  1.  ;
  1.  D ^APCDALVR
  1.  ;
  1.  ; ----- END IHS/OIT/MKK LR*5.2*1024 MODIFICATIONS
  1.  ;
  1.  D MSNOMED^BLRLINK4     ; IHS/MSC/MKK - LR*5.2*1033 -- Make Certain VLAB SNOMED field is set
  1.  ;
  1.  ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1025
  1.  S TSTR="DUZ"_"=OLDDUZ"
  1.  ; S @TSTR                          ; Change DUZ back
  1.  M @TSTR                          ; Change DUZ back -- LR*5.2*1027
  1.  ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1025
  1.  ;
  1.  I '$D(APCDALVR("APCDAFLG")) D
  1.  .S:'BLRVIEN BLRVIEN=$G(APCDALVR("APCDADFN"))
  1.  .I 'BLRVIEN,$D(@(BLRVGL_"""ALR"",APCDALVR(""APCDVSIT""),BLRACC,BLRTLAB)")) S BLRVIEN=$O(@(BLRVGL_"""ALR"",APCDALVR(""APCDVSIT""),BLRACC,BLRTLAB,0)"))
  1.  .K DIE,DA,DR
  1.  .S DIE="^BLRTXLOG(",DA=BLRIEN,DR="104///^S X="_BLRVFILE_";105///^S X=BLRVIEN"
  1.  .D ^DIE
  1.  .K BLRCMSG  ;IHS/ITSC/TPF 02/17/2004 ADDED TO CLEAR ERRO MESSAGE FOR COMMENTS LR*5.2*1018 RESULT OF "No V Lab Entry" message showing up in Tuba City EHR alpha testing
  1.  .I $O(BLRCOM("")) D
  1.  ..S BLRCMSG=$$LABC^APCDALVR(BLRVIEN,.BLRCOM)  ;maw comments
  1.  .. K BLRCOM  ; IHS/MSC/MKK - LR*5.2*1041 - Make sure array is cleared after it's stored once.
  1.  .I $G(BLRCMSG)]"" S BLRBUL=2,BLRERR=1,BLRPCC=$P($G(BLRCMSG),U,2)  ;maw
  1.  .K BLRCMSG  ;IHS/ITSC/TPF 02/17/2004 ADDED TO CLEAR ERRO MESSAGE FOR COMMENTS
  1.  .Q
  1.  .S BLRBUL=2,BLRPCC="Another user is editing this TX file entry..."_BLRIEN S BLRERR=1
  1.  .W:'BLRQUIET !,"Another user is editing this TX file entry..."_BLRIEN,! S BLRERR=1
  1.  ;	
  1.  I $G(APCDALVR("APCDAFLG"))=1 S BLRBUL=2,BLRPCC="Invalid template for result display"_" FLG = 1" W:'BLRQUIET !,BLRPCC,!
  1.  ;
  1.  D ^BLRLINKP:$G(APCDALVR("APCDAFLG"))=2
  1.  ;
  1.  K APCDALVR
  1.  Q
  1.  ;
  1. GETGREF(BLRX) ; EP
  1.  Q $G(^DIC(BLRX,0,"GL"))
  1.  ;
  1.  ; If Complete Date variable is null, but there is a complete date, reset it
  1. GETCOMPD(BLRLOGDA,LRAS,F60IEN,COMPDATE) ; EP
  1.  NEW LRAA,LRAD,LRAN,LOGCOMPD,PTR,RESULTDT
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
  1.  Q:+$G(BLRLOGDA)<1
  1.  Q:$L(LRAS)<1
  1.  Q:+$G(F60IEN)<1
  1.  Q:BLRSTAT'="R"    ; Has to have status of "RESULTED"
  1.  ;
  1.  ; If COMPLETE DATE in 9009022, use it
  1.  S RESULTDT=$$GET1^DIQ(9009022,BLRLOGDA,1309,"I")
  1.  I RESULTDT S COMPDATE=RESULTDT  Q
  1.  ;
  1.  Q:$$RDINF63^BLRLNKU2(BLRLOGDA,LRAS,F60IEN,.COMPDATE)    ; IHS/MSC/MKK - LR*5.2*1039
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1039
  1.  ;
  1.  Q:$$GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)<1
  1.  ;
  1.  ; Check Accession file for COMPLETE DATE
  1.  S PTR=+$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",F60IEN,0))
  1.  Q:PTR<1
  1.  ;
  1.  S RESULTDT=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,PTR,0)),"^",5)
  1.  Q:RESULTDT<1
  1.  ;
  1.  S COMPDATE=RESULTDT
  1.  ;
  1.  ; If Complete Date not in ^BLRTXLOG, set it
  1.  S:+$P($G(^BLRTXLOG(BLRLOGDA,13)),"^",9)<1 $P(^BLRTXLOG(BLRLOGDA,13),"^",9)=RESULTDT
  1.  Q
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1031
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
  1. RESETABN ; EP - For "CH" tests only, make sure "Abnormal" Flag is the same as the one in the LAB DATA file
  1.  NEW (APCDALVR,BLRACCN,BLRTLAB,BLRTEST,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q:+$G(BLRTLAB)<1               ; Skip if no test variable
  1.  Q:$L($G(BLRACCN))<1            ; Skip if no Accession string
  1.  ;
  1.  S X=$$GETACCCP^BLRUTIL3(BLRACCN,.LRAA,.LRAD,.LRAN)
  1.  Q:LRAA<1!(LRAD<1)!(LRAN<1)
  1.  ;
  1.  S LRSS=$$GET1^DIQ(68,LRAA,.02,"I")
  1.  Q:LRSS'="CH"
  1.  ;
  1.  S LRAAIEN=LRAN_","_LRAD_","_LRAA
  1.  S LRDFN=$$GET1^DIQ(68.02,LRAAIEN,.01,"I")
  1.  Q:LRDFN<1
  1.  ;
  1.  S LRAT=BLRTLAB
  1.  S BLRDATAN=$$GET1^DIQ(60,LRAT,400,"I")
  1.  Q:BLRDATAN<1
  1.  ;
  1.  S LRIDT=$$GET1^DIQ(68.02,LRAAIEN,13.5,"I")
  1.  Q:LRIDT<1
  1.  ; 
  1.  S LRDATABN=$P($G(^LR(LRDFN,LRSS,LRIDT,BLRDATAN)),U,2)
  1.  S APCDALVR("APCDTABN")=$S($L(LRDATABN):LRDATABN,1:"@")
  1.  Q
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1041