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

BLRRLHL2.m

Go to the documentation of this file. 
  1. BLRRLHL2 ;IHS/MSC/MKK - BLR HL7 Utilities for Reference Lab, part 2 ; 09-Mar-2015 06:30 ; MKK
  1.  ;;5.2;IHS LABORATORY;**1034,1035**;NOV 01, 1997;Build 5
  1.  ; 
  1.  ; Routines moved here from BLRRLHL because BLRRLHL got too large.
  1.  ; 
  1.  Q
  1.  ;
  1. DX2(PAT) ; EP - Continuation from DX^BLRRLHL
  1.  K DIC,BLRDXS,BLRADX,BLRDXA
  1.  S BLRADX=1
  1.  S DIC="^ICD9("
  1.  ; S DIC("S")="I '$P($G(^(0)),U,9)"
  1.  ;
  1.  ; AICD 4.0 re-did File 80.  There is no longer an INACTIVE FLAG.
  1.  ; STATUS is now a multiple.  Note that STATUS=1 is ACTIVE; STATUS=0 is INACTIVE.
  1.  ; Have to fully specify the global so the $O will work.
  1.  S DIC("S")="I $P($G(^ICD9(Y,66,+$O(^ICD9(Y,66,""A""),-1),0)),""^"",2)"  ; Most Current Status
  1.  ;
  1.  S DIC(0)="AEMQZ",DIC("A")="What is the ICD Diagnosis code for billing: "
  1.  D ^DIC
  1.  I Y<0 D  Q
  1.  . D ADDDX(BLRTSTDA)
  1.  . K BLRADX
  1.  S BLRDXS=$$ICDDX^ICDEX(+Y)
  1.  I $G(BLRDXA(+Y)) D  G ENDDX
  1.  . W !,"You have already selected this Diagnosis"
  1.  ;
  1.  G:$G(BLRDXS)="" ENDDX  ; IHS/MSC/MKK - LR*5.2*1034
  1.  ;
  1.  S BLRDXA(+Y)=1
  1.  S BLRDX(DXCNT)=BLRDXS
  1.  ;
  1. SETDX I '$G(BLRADX) D ADDDX(BLRO) Q
  1.  S BLRRL("DX",DXCNT)=$P(BLRDXS,U,2)
  1.  S BLRRL("DX")=$P(BLRDXS,U,2)
  1.  S DXCNT=DXCNT+1
  1. ENDDX D DX2(BLRRL("PAT"))
  1.  Q
  1.  ;
  1. ADDDX(RO) ;-- add the diagnosis to the test since it is not there, this happens when they want all dx for mult accessions
  1.  ;ihs/cmi/maw added dx type LR*5.2*1034  
  1.  N TDA,DXCNT,ORI,TSTDA
  1.  S TSTDA=$G(BLRTS)
  1.  K BLRRL(TSTDA,"DX")
  1.  K BLRRL(TSTDA,"DXE")
  1.  K BLRRL(TSTDA,"DXT")
  1.  S DXCNT=0
  1.  S ORI=$O(^BLRRLO("B",RO,0))
  1.  S TDA=0 F  S TDA=$O(^BLRRLO(ORI,1,TDA)) Q:'TDA  D
  1.  . N DXS
  1.  . S DXCNT=DXCNT+1
  1.  . ;S DXS=$G(BLRDX(TDA))
  1.  . S DXS=$S($D(^ICDS(0)):$$ICDDX^ICDEX($P($G(^BLRRLO(ORI,1,TDA,0)),U)),1:$$ICDDX^ICDCODE($P($G(^BLRRLO(ORI,1,TDA,0)),U)))
  1.  . S BLRRL("DX",DXCNT)=$P(DXS,U,2)
  1.  . S BLRRL("DX")=$P(DXS,U,2)
  1.  . S BLRRL(TSTDA,"DX",TDA)=$P(DXS,U,2)
  1.  . S BLRRL(TSTDA,"DXE",TDA)=$P(DXS,U,4)
  1.  . S BLRRL(TSTDA,"DXT",TDA)=$S($P(DXS,U,20)'=30:"I9",1:"I10")
  1.  . S BLRRL(TSTDA,"DX")=$P(DXS,U,2)  ;cmi/maw 01/20/2010
  1.  . S BLRRL(TSTDA,"DXE")=$P(DXS,U,4)  ;cmi/maw 01/20/2010
  1.  . S BLRRL(TSTDA,"DXT")=$S($P(DXS,U,20)'=30:"I9",1:"I10")  ;cmi/maw 01/20/2010
  1.  Q
  1.  ;
  1. HLSET(BLRINS) ;-- setup hl7 variables
  1.  S INSCNT=BLRINS
  1.  S BLRRL(BLRTSTDA,"INSE",INSCNT)=$P(AGINS(BLRINS),U)
  1.  S BLRRL("INSE",INSCNT)=$P(AGINS(BLRINS),U)
  1.  S BLRRL(BLRTSTDA,"INSI",INSCNT)=$P(AGINS(BLRINS),U,2)
  1.  ;S BLRRL(BLRTSTDA,"INSCOV")=$P(AGINS(BLRINS),U,4)
  1.  S BLRRL(BLRTSTDA,"INSCOV",INSCNT)=$E($G(BLRRL("BILL TYPE")),1,1)
  1.  S BLRRL(BLRTSTDA,"INSPH",INSCNT)=$P(AGINS(BLRINS),U,7)
  1.  S BLRRL(BLRTSTDA,"INSGRP",INSCNT)=$P(AGINS(BLRINS),U,20)
  1.  S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S($P(AGINS(BLRINS),U,16):$P($G(^AUTTRLSH($P(AGINS(BLRINS),U,16),0)),U),1:"")
  1.  S BLRRL(BLRTSTDA,"INSRELE",INSCNT)=BLRRL(BLRTSTDA,"INSREL",INSCNT)
  1.  I $G(BLRRL(BLRTSTDA,"INSREL",INSCNT))]"" D
  1.  . I BLRRL(BLRTSTDA,"INSREL",INSCNT)="SELF" S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":2,1:1) Q
  1.  . I BLRRL(BLRTSTDA,"INSREL",INSCNT)="SPOUSE" S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":2,1:2),BLRRL(BLRTSTDA,"INSRELE",INSCNT)="SPOUSE" Q
  1.  . I BLRRL(BLRTSTDA,"INSREL",INSCNT)="HUSBAND" S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":2,1:2),BLRRL(BLRTSTDA,"INSRELE",INSCNT)="SPOUSE" Q
  1.  . I BLRRL(BLRTSTDA,"INSREL",INSCNT)="WIFE" S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":2,1:2),BLRRL(BLRTSTDA,"INSRELE",INSCNT)="SPOUSE" Q
  1.  . S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":8,1:3),BLRRL(BLRTSTDA,"INSRELE",INSCNT)="OTHER" Q
  1.  I $G(BLRRL(BLRTSTDA,"INSREL",INSCNT))="" S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":1,1:1),BLRRL(BLRTSTDA,"INSRELE",INSCNT)="SELF"
  1.  S BLRRL(BLRTSTDA,"INSPOL",INSCNT)=$P(AGINS(BLRINS),U,9)
  1.  S BLRRL(BLRTSTDA,"INSELG",INSCNT)=$P(AGINS(BLRINS),U,5)
  1.  S BLRRL(BLRTSTDA,"INSEXP",INSCNT)=$P(AGINS(BLRINS),U,6)
  1.  S BLRRL(BLRTSTDA,"INSPLN",INSCNT)=$S(BLRRL(BLRTSTDA,"INSE",INSCNT)["MEDICARE":"MC",BLRRL(BLRTSTDA,"INSE",INSCNT)["MEDICAID":"MD",1:"PI")
  1.  S BLRRL(BLRTSTDA,"INSTYP",INSCNT)=$P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI",INSCNT),2)),U)
  1.  I BLRRL(BLRTSTDA,"INSI",INSCNT)]"" D
  1.  . S BLRRL(BLRTSTDA,"INSID",INSCNT)=$TR($P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI",INSCNT),2)),U,19),"~")  ;cmi/maw 2/17/2009 changed to piece 10 external group name from external id 2
  1.  . S BLRRL(BLRTSTDA,"INSCNME",INSCNT)=$P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI",INSCNT),0)),U)  ;insurance company name
  1.  . S BLRRL(BLRTSTDA,"INSADD",INSCNT)=$$INSADD^BLRRLHL(BLRRL(BLRTSTDA,"INSI",INSCNT))
  1.  . S BLRRL(BLRTSTDA,"INSADDE",INSCNT)=$TR($P(BLRRL(BLRTSTDA,"INSADD",INSCNT),U),U," ")_"~"_$TR($P(BLRRL(BLRTSTDA,"INSADD",INSCNT),U,3,99),U," ")
  1.  . S BLRRL(BLRTSTDA,"INSPHO",INSCNT)=$P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),0)),U,6)
  1.  . S BLRRL(BLRTSTDA,"INSTYP",INSCNT)=$P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),2)),U)
  1.  S BLRRL(BLRTSTDA,"INSEMP",INSCNT)=$$GET1^DIQ(2,PAT,.3111)
  1.  S BLRRL(BLRTSTDA,"INSNOI",INSCNT)=$$HLNAME^XLFNAME($P(^DPT(PAT,0),U))
  1.  S BLRRL(BLRTSTDA,"INSNOIE",INSCNT)=$P(^DPT(PAT,0),U)
  1.  S INSCNT=INSCNT+1
  1.  ;end of hl7 lines
  1.  Q
  1.  ;
  1. O01(BHL) ;PEP - Order Message
  1.  ;ihs/cmi/maw - added this sub from BHLEVENT so can be update by lab without GIS patch LR*5.2*1034
  1.  K INDA,INA
  1.  I '$G(BHL("PAT")) Q $$MSG(0)
  1.  S INDA=BHL("PAT")
  1.  S INA("DUZ2")=$S($G(BHL("ALTDUZ2")):BHL("ALTDUZ2"),1:DUZ(2))  ;cmi/maw 4/25/2006 DUZ(2) gets reset by GIS
  1.  ;cmi/maw 4/25/2006 changed below code due to lapcorp inadequacy
  1.  I BHL("RLE")'="LABCORP" S INA("SF")=$G(BHL("CLIENT")) ;maw 3/3/2006 dynamic account number in MSH
  1.  S INA("PID20LABO",1)=$G(BHL("CLIENT"))_"^^^"_$S($E($G(BHL("BILL TYPE")),1,1)="T":$G(BHL("INSTYP")),$E($G(BHL("BILL TYPE")),1,1)="P":"P",1:"C")  ;quest client id
  1.  I BHL("RLE")="LABCORP" S INA("PID20LABO",1)=$G(BHL("CLIENT"))_"^^^"_$S($E($G(BHL("BILL TYPE")),1,1)="T":"T",$E($G(BHL("BILL TYPE")),1,1)="P":"P",1:"C")  ;labcorp client id
  1.  S INA("ORC2LABO")=$G(BHL("UID"))
  1.  S INA("ORC12LABO")=$G(BHL("ORDP"))
  1.  S INA("ORC11LABO")=$$DATE^INHUT($G(BHL("CDT")),1)
  1.  S BHLDA=0 F  S BHLDA=$O(BHL(BHLDA)) Q:'BHLDA  D
  1.  . S INA("ORC2LABO",BHLDA)=$G(BHL("UID"))
  1.  . S INA("ORC11LABO",BHLDA)=$G(BHL(BHLDA,"CDT"))
  1.  . S INA("ORC12LABO",BHLDA)=$G(BHL(BHLDA,"ORDP"))
  1.  . S INA("OBR4LABO",BHLDA)=U_U_U_$G(BHL(BHLDA,"TCNM"))
  1.  . S INA("OBR4LABOL",BHLDA)=$G(BHL(BHLDA,"TCNM"))
  1.  . S INA("OBR7LABO",BHLDA)=$G(BHL(BHLDA,"CDT"))
  1.  . S INA("OBR13LABO",BHLDA)="N"
  1.  . S INA("OBR15LABO",BHLDA)=$G(BHL(BHLDA,"SRC"))
  1.  . S INA("OBR18LC",BHLDA)=$G(BHL(BHLDA,"ORD"))
  1.  . S INA("OBR27LABO",BHLDA)="^^^^^"_$S($G(BHL("URG"))=1:"S",$G(BHL("URG"))=10:"A",1:"R")
  1.  . N IDA
  1.  . S IDA=0 F  S IDA=$O(BHL(BHLDA,"INSE",IDA)) Q:'IDA  D
  1.  .. S INDA("IN1",IDA)=""
  1.  .. S INA("IN13LABO",IDA)=$S($G(BHL("RLE"))="LABCORP":U_$G(BHL(BHLDA,"INSID",IDA)),1:$G(BHL(BHLDA,"INSID",IDA)))
  1.  .. S INA("IN14LABO",IDA)=$G(BHL(BHLDA,"INSE",IDA))
  1.  .. S INA("IN15LABO",IDA)=$G(BHL(BHLDA,"INSADD",IDA))
  1.  .. S INA("IN17LABO",IDA)=$G(BHL(BHLDA,"INSPHO",IDA))
  1.  .. S INA("IN18LABO",IDA)=$G(BHL(BHLDA,"INSGRP",IDA))
  1.  .. S INA("IN111LABO",IDA)=$G(BHL(BHLDA,"INSEMP",IDA))
  1.  .. S INA("IN112LABO",IDA)=$$DATE^INHUT($G(BHL(BHLDA,"INSELG",IDA)),1)
  1.  .. S INA("IN113LABO",IDA)=$$DATE^INHUT($G(BHL(BHLDA,"INSEXP",IDA)),1)
  1.  .. S INA("IN115LABO",IDA)=$G(BHL(BHLDA,"INSPLN",IDA))
  1.  .. S INA("IN116LABO",IDA)=$G(BHL(BHLDA,"INSNOI",IDA))
  1.  .. S INA("IN117LABO",IDA)=$G(BHL(BHLDA,"INSREL",IDA))
  1.  .. S INA("IN119LABO",IDA)=$G(BHL(BHLDA,"INSADD",IDA))
  1.  .. S INA("IN136LABO",IDA)=$G(BHL(BHLDA,"INSPOL",IDA))
  1.  .. S INA("IN147LABO",IDA)=$S($G(BHL(BHLDA,"INSCOV",IDA))]"":$E(BHL(BHLDA,"INSCOV",IDA),1,1),1:"C")
  1.  . S INA("GT13LABO",BHLDA)=$G(BHL(BHLDA,"GT1NM"))
  1.  . S INA("GT15LABO",BHLDA)=$G(BHL(BHLDA,"GT1ADD"))
  1.  . S INA("GT16LABO",BHLDA)=$G(BHL(BHLDA,"GT1PHO"))
  1.  . ;cmi/maw 4/4/2008 end of insurance info
  1.  . ;cmi/maw 4/4/2008 beginning of dx
  1.  . S INA("GT13LABO")=$G(BHL(BHLDA,"GT1NM"))
  1.  . S INA("GT15LABO")=$G(BHL(BHLDA,"GT1ADD"))
  1.  . S INA("GT16LABO")=$G(BHL(BHLDA,"GT1PHO"))
  1.  . ;cmi/maw 4/4/2008 end of insurance info
  1.  . ;cmi/maw 4/4/2008 beginning of dx
  1.  . N DGDA
  1.  . S DGDA=0 F  S DGDA=$O(BHL(BHLDA,"DX",DGDA)) Q:'DGDA  D
  1.  .. S INDA("DG1",DGDA)=""
  1.  .. S INA("DG12LABO",DGDA)=$G(BHL(BHLDA,"DXT",DGDA))
  1.  .. S INA("DG13LABO",DGDA)=$G(BHL(BHLDA,"DX",DGDA))_U_$G(BHL(BHLDA,"DXE",DGDA))_U_$G(BHL(BHLDA,"DXT",DGDA))
  1.  .. I BHL("RLE")'="LABCORP" S INA("DG13LABO",DGDA)=$G(BHL(BHLDA,"DX",DGDA))
  1.  .. S INA("DG14LABO",DGDA)=$G(BHL(BHLDA,"DXE",DGDA))
  1.  .. S INA("DG12LABO")=$G(BHL(BHLDA,"DXT",DGDA))
  1.  .. S INA("DG13LABO")=$G(BHL(BHLDA,"DX",DGDA))_U_$G(BHL(BHLDA,"DXE",DGDA))_U_$G(BHL(BHLDA,"DXT",DGDA))
  1.  .. I BHL("RLE")'="LABCORP" S INA("DG13LABO",DGDA)=$G(BHL(BHLDA,"DX",DGDA))
  1.  .. S INA("DG14LABO")=$G(BHL(BHLDA,"DXE",DGDA))
  1.  . ;cmi/maw 4/4/2008 end of dx 
  1.  . S INDA("ORC",BHLDA)=""
  1.  . S INDA("OBR",BHLDA)=""
  1.  . S BHLCDA=0 F  S BHLCDA=$O(BHL(BHLDA,"COMMENT",BHLCDA)) Q:'BHLCDA  D
  1.  .. S INDA("OBX",BHLCDA)=""
  1.  .. S BHLCOM1=$P(BHL(BHLDA,"COMMENT",BHLCDA),U)
  1.  .. S BHLCOM2=$P(BHL(BHLDA,"COMMENT",BHLCDA),U,2)
  1.  .. S BHLCOM3=$P(BHL(BHLDA,"COMMENT",BHLCDA),U,3)
  1.  .. S INA("OBX3LABO",BHLDA,BHLCDA)=U_U_U_BHLCOM1_U_BHLCOM2
  1.  .. S INA("OBX2LABOL",BHLDA,BHLCDA)="ST"
  1.  .. S INA("OBX3LABOL1",BHLDA,BHLCDA)=BHLCOM1
  1.  .. S INA("OBX3LABOL2",BHLDA,BHLCDA)=BHLCOM2
  1.  .. S INA("OBX14LABO",BHLDA,BHLCDA)=$G(BHL("CDT"))
  1.  .. S INA("OBX5LABO",BHLDA,BHLCDA)=BHLCOM3
  1.  .. S INA("OBX3LABLC3",BHLDA,BHLCDA)=$G(BHL("RLE"))
  1.  S INA("ORC2LABO")=$G(BHL("UID"))
  1.  S INA("ORC11LABO")=$G(BHL("CDT"))
  1.  S INA("ORC12LABO")=$G(BHL("ORDP"))
  1.  S INA("OBR4LABO")=U_U_U_$G(BHL("TCNM"))
  1.  S INA("OBR4LABOL")=$G(BHL("TCNM"))
  1.  S INA("OBR7LABO")=$G(BHL("CDT"))
  1.  S INA("OBR13LABO")="N"
  1.  S INA("OBR27LABO")="^^^^^"_$S($G(BHL("URG"))=1:"S",$G(BHL("URG"))=10:"A",1:"R")
  1.  S INDA("ORC")=""
  1.  S INDA("OBR")=""
  1.  S BHLCDA=0 F  S BHLCDA=$O(BHL("COMMENT",BHLCDA)) Q:'BHLCDA  D
  1.  . S INDA("OBX",BHLCDA)=""
  1.  . S BHLCOM1=$P(BHL("COMMENT",BHLCDA),U)
  1.  . S BHLCOM2=$P(BHL("COMMENT",BHLCDA),U,2)
  1.  . S BHLCOM3=$P(BHL("COMMENT",BHLCDA),U,3)
  1.  . S INA("OBX2LABOL",BHLCDA)="ST"
  1.  . S INA("OBX3LABOL1",BHLCDA)=BHLCOM1
  1.  . S INA("OBX3LABOL2",BHLCDA)=BHLCOM2
  1.  . S INA("OBX14LABO",BHLCDA)=$G(BHL("CDT"))
  1.  . S INA("OBX3LABO",BHLCDA)=U_U_U_BHLCOM1_U_BHLCOM2
  1.  . S INA("OBX5LABO",BHLCDA)=BHLCOM3
  1.  . S INA("OBX3LABLC3",BHLCDA)=$G(BHL("RLE"))
  1.  D ^INHF("HL IHS O01 OUT PARENT",.INDA,.INA)
  1.  Q $$MSG(INHF)
  1.  ;
  1. MSG(BHLMVAR)        ;-- return message defining status
  1.  I BHLMVAR="PAT" S BHLRMSG="Patient Not Passed In, Message Not Created"
  1.  I BHLMVAR="VST" S BHLRMSG="Visit Not Passed In, Message Not Created"
  1.  I BHLMVAR="VLAB" S BHLRMSG="VLAB Not Passed In, Message Not Created"
  1.  I BHLMVAR="MFL" S BHLRMSG="Mstr File Not Passed In, Message Not Created"
  1.  I BHLMVAR=0 S BHLRMSG="Message Not Created, problem with GIS call"
  1.  I BHLMVAR S BHLRMSG=BHLMVAR_U_"Message Created Successfully"
  1.  Q $G(BHLRMSG)
  1.  ;