LA7VCMI ;IHS/CMI/MAW - Micro Filing Pre LEDI IV ; 22-Oct-2013 09:22 ; MAW
;;5.2;AUTOMATED LAB INSTRUMENTS;**1033**;NOV 01, 1997
;
;
;borrowed and modified code from david hoak
;;5.2;AUTOMATED LAB INSTRUMENTS;**41**;Sep 27, 1994
;
;-->P.R.O.T.O.T.Y.P.E.--P.R.O.T.O.T.Y.P.E--P.R.O.T.O.T.Y.P.E
;
;-------------------------------> MICROSCAN->OBX|1|ST||1|150||||||F
; /\
;---------------------------ORGANISM--------------------|
;
;---^LAHM(62.49,61,150,11,0)=OBR|2||^ANTIBIOTIC MIC^VANLT||||19861210083
;--- |||||||||^^BLOOD|||||||||||87993.0000^1
;
EPI ;---^LAHM(62.49,61,150,13,0) = OBX|1|ST|81812.0000^Neomycin^VANLT^18^NEO
;---MYCN^VA62.06|||||R
;
;
;--> CONTINUE DOWN LAHM GLOBAL
;
MI ;
; Don't do anything, for now.
;Q
;
; I $G(^LAHM(62.49,LA76249,0))["IM-VITEK" D MI^LA7ZV3 QUIT
K LRISOX
;QUIT
OBX ;
;I $G(LA7AN)'>0 D ^AGNQBLOD ;BLOOD CULTURE ACCN AREA
;I $L(LA7AN)=8 S LA7AN=+$E(LA7AN,2,8)/1 D BC^AGNQBLOD
;
I $G(LRMIFLAG)=LA7OBR S LA7QUIT=1 D END QUIT
;--> Don't pay for the same realestate twice. gsp
K ^TMP("LRISO"),^TMP("LRORG")
;
;ihs/cmi/maw 03/08/2013 added for MU and LEDI III
S LRMIFLAG=LA7OBR
S LRMIEN=LA762495
S LA7OBX=$G(LA7SEG(0))
Q:$G(LA7OBX)=""
D BUGS
D CH1
Q
;
BACK ;
F S LA762495=$O(^LAHM(62.49,LA76249,150,LA762495)) Q:'LA762495 S LA7OBX=^LAHM(62.49,LA76249,150,LA762495,0) D CHOBR Q:$E(LA7OBX,1,3)'="OBX" D
. ;
. S LRMIFLAG=LA7OBR
. ;-->MICROSCAN data inovations OBX|1|ST|DRUG|ORGANISM|MIC|UNITS|||||F
. S LRMIEN=LA762495
. D BUGS ;I '$G(LRORGNM) D CREATE^LA7LOG(52) ;-->NO ORG
. ;D DRUGS
;
CH1 I $E($G(LA7OBX),1,3)="OBR" G BACK
K LA7CNT D END
QUIT
CHOBR ;
;ZW LRISOX
Q:$E(LA7OBX,1,3)'="OBR"
I LA7OBX["IM-MISCN" S LRISOX=$P(LA7OBX,U,2)
QUIT
;
;
BUGS ;
;
; ZW LA7OBX
; VITEK
; I $G(LRORGNUM) G DRUG
; ***
; I +$P(LA7OBX,LA7FS,5) G DRUG
; LAHM(62.49,1525185,150,5,0) = OBX|1|ST|ISO1||1||||||F
I LA7OBX["ISO" S LRISO=+$P(LA7OBX,"ISO",2) D QUIT
. S LRORG=+$P(LA7OBX,LA7FS,6)
. I '$G(LRISOX) S LRISOX=1
. E S LRISOX=LRISOX+1
. S ^TMP("LRISO",$J,LRISOX,LRORG,LRISO)=""
; Look in auto inst 62.4 then Get the ien for 61.2
;S LRORG=$P($P($G(LA7OBX),LA7FS,5),LA7CS) ;ihs/cmi/maw 03/08/2013 for MU orig line
;ihs/cmi/maw MU2 below code for filing MICRO
N LA7MRES,LA7MUNIT,LA7MABN,LA7MRS,LA7MRSDT,LA7MPO
S (LA7MRES,LRORG)=$P($P($G(LA7OBX),LA7FS,6),LA7CS) ;ihs/cmi/maw 03/08/2013 for MU
S LA7MUNIT=$P($G(LA7OBX),LA7FS,7)
I LA7MUNIT]"" S LA7MUNIT=$TR($$TRIM^XLFSTR(LA7MUNIT,"LR"," "),"^","~")
S LA7MABN=$P($G(LA7OBX),LA7FS,9)
S LA7MRS=$P($G(LA7OBX),LA7FS,12)
S LA7MRSDT=$$HL7TFM^XLFDT($$P^LA7VHLU(.LA7SEG,15,LA7FS),"L")
S LA7MPO=$P($P($G(LA7OBX),LA7FS,24),LA7CS,10)
S LA7MPO=$$RPTFAC(LA7MPO,LA7SFAC,LA7CS)
S LRISO=$P(LA7OBX,LA7FS,5) ; ihs/cmi/maw 03/08/2013 for MU
I $P(LA7OBX,LA7FS,3)="SN" D Q ; ihs/cmi/maw MU2 these are drugs so dont worry about the org here
. ;S LA7MRES=$P($P($G(LA7OBX),LA7FS,6),LA7CS,2)
. S LA7MRES=$TR($P($G(LA7OBX),LA7FS,6),LA7CS,"")
. S LRISO=LA7MPN ;this is the parent node in OBR
. D DRUGS
;ihs/cmi/maw MU2 end of mods
I +LRORG>0 S LRORGNUM=$O(^LAB(62.4,LA7624,7,1,1,"C",LRORG,0)) D
. Q:'LRORGNUM ;62.4,3,7,1,1=ORGS 62.4,3,7,1,2=DRUGS
. ;
. S LRORGNUM=+$G(^LAB(62.4,LA7624,7,1,1,LRORGNUM,0)) D
.. I LRORGNUM S LRORGNM=$P($G(^LAB(61.2,LRORGNUM,0)),U)
N LA7VRS
S LA7VRS=$P(LA7OBX,LA7FS,12) ;result status
D FILE Q ; ihs/cmi/maw 03/08/2013 for MU
I +$G(LRORGNUM)>0 G MSCAN QUIT
;
BU1 Q:$G(LRORG)="" S LRORGNUM=$O(^LAB(61.39,1,1,"B",LRORG,0)) D
. Q:'LRORGNUM
. I LRORGNUM S LRORGNUM=$G(^LAB(61.39,1,1,LRORGNUM,1)) D
.. I LRORGNUM S LRORGNM=$P($G(^LAB(61.2,LRORGNUM,0)),U)
;I $D(^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)) D
; . ;***
; . ;S LRISO=LRISO+1 S ^TMP("LRISO",$J,LRISO)=""
;***
;I LRISO>1 Q:LRORGNUM=+$G(^LAH(LA7LWL,1,LA7ISQN,3,LRISO-1,0))
MSCAN ;
; The microscan sends a number for the organism.
; 1 of two possible conditions may exist for the Microscan
; 1 the OBX is an ISOn or a DRUG
;I '$G(LRISO) S LRISO=$O(^TMP("LRISO",$J,0))
;I '$G(LRISO) S LRISO=1
;I LRORG S ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)=$G(LRORG)_U_U D
; . S ^TMP("LRISO",$J,LRISO,LRORG)=""
; . S ^TMP("LRORG",$J,LRORG,LRISO)=""
;
;Q:+$G(LRORGNUM)>0 ; --This segment has an org in 4th piece
;
Q:LA7OBX["ISO"
DRUG ; -->VITEK
;
Q:'+$P(LA7OBX,LA7FS,5)
;
;
SETISO ;I '$O(^TMP("LRISO",$J,LRISO)) S LRIS0=0 D
; . F S LRISO=$O(^TMP("LRISO",$J,LRISO)) Q:+LRISO
;
S LRORG=$P(LA7OBX,LA7FS,5)
;S LRISO=$O(^TMP("LRORG",$J,LRORG,0))
;
;
;
I $P(LA7OBX,LA7FS,5) I LRORG'=$P($P($G(LA7OBX),LA7FS,5),LA7CS) S LRORG=$P($P($G(LA7OBX),LA7FS,5),LA7CS) I $D(LRORG) G BU1
;
;I LRISO>1 I LRORGNUM=+$G(^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)) D QUIT
; . K ^LAH(LA7LWL,1,LA7ISQN,3,LRISO)
;
; ^LAB(61.39,1,2,"B","cec",100)
; -->OBX|1|ST|Gm|126|4|ug/ml||||F
S LRD1=$P($P($G(LA7OBX),LA7FS,4),LA7CS)
S LRD=$O(^LAB(61.39,1,2,"B",LRD1,0)) ;-->LIC FILE
;I $G(LRD) S LRDNUM=$G(^LAB(61.39,1,2,LRD,1)) D
;. S LRMIC=$P($G(LA7OBX),LA7FS,6)
;. S LRINTRP=$P(LA7OBX,LA7FS,9)
;. S LRDNODE=$P(^LAB(62.06,LRDNUM,0),U,2) ; Pull out drug node (n.xxxx)
;. D INTERP
;
I '$G(LRD) D DRUGS
QUIT ;ihs/cmi/maw 03/08/2013 for MU removed quit
;
;---^LAHM(62.49,61,150,9,0) = OBX|1|CE|87993.0000^BACTERIOLOGY CULTURE^
;---VANLT|1|^ESCHERICHIA COLI
;
;
; OBX|1|ST|126^^^||||||||F
; OBX-1 = 1
; OBX-2 = ST
; OBX-3 = 126^^^
; OBX-3-1 = 126
; OBX-11 = F
; OBR|2|3207||||||||||||||||MSCAN||||||||^1
; OBR-1 = 2
; OBR-2 = 3207
; OBR-18 = MSCAN
; OBR-26 = ^1
; OBR-26-2 = 1
; OBX|1|ST|Gm|126|4|ug/ml||||F
;
;
I $E(LA7OBX,1,3)="OBX",$P(LA7OBX,LA7FS,3)="CWE" D QUIT ;--ledi
. S LRMIOBX=LA7OBX S LRORG=$P($P(LA7OBX,LA7FS,6),LA7CS) ;-->NLT^Name
. ;
. I $G(LRORG)'="" S LRORGNM=LRORG D ORG
;
;--->accomadate multiple life forms----\/
;
;
;I $E(LA7OBX,1,3)="OBX",+$P(LA7OBX,LA7FS,6) S LRORGX=+$P(LA7OBX,LA7FS,6) D
;
;-->MICROSCAN data innovations OBX|1|ST|ORGANISM|||||F
;
; check for culture ID only
I $E(LA7OBX,1,3)="OBX",+$P(LA7OBX,LA7FS,4) D QUIT
. S LRORGX=+$P(LA7OBX,LA7FS,4)
. I $G(LRORGX),$D(^LAB(61,2,LRORGX,0)) D LRORGX
;
;
;
;
; These bugs have susceptabilities
I $E(LA7OBX,1,3)="OBX",+$P(LA7OBX,LA7FS,5) D
. S LRORGX=+$P(LA7OBX,LA7FS,5)
. I $G(LRORGX),$D(^LAB(61,2,LRORGX,0)) D LRORGX
;
;
;
QUIT
;
DRUGS ;
;---> all forms of HL7 can use this format
;
; OBX|1|ST|Gm|126|4|ug/ml||||F
I $E(LA7OBX,1,3)="OBX",$P(LA7OBX,LA7FS,3)="SN" D
. S LRAB=$P(LA7OBX,LA7FS,4) ;-->NLT^Name
. Q:$G(LRAB)["ISO"
. S LRMIC=$P(LA7OBX,LA7FS,6),LRINTRP=$P(LA7OBX,LA7FS,9)
. I LRMIC="" D CREATE^LA7LOG(51)
. ;I LRAB'="" D AB ihs/cmi/maw MU2 orig code
. I LRAB'="" D MS ;ihs/cmi/maw MU2 lets try to get the drug
QUIT
END ;
K LRORG,LRORGX,LRORGNM,LRORGNUM,LRDNODE,LA7OBX,LRMIC,LRAB,LRINTRP,J,MIC,ISOL
K LRISO,LRMIFLAG,K1,ORG,LRSP
S LA7QUIT=1
QUIT
;
ORG ;
;***S LRISO=$P(LA7OBX,LA7FS,2)
; ^LAB(61.2,1,64) = 923 ---> NLT for E.COLI
; ^LAB(61.2,"NLT","87016.0000",1)
;
;---^LAH(65,1,12,0) = 1^1^12^2970000^6^^VITEK^6 --> set in LA7UIIN1
;---^LAH(65,1,12,2,2) = CARD^gns-f6 ---> NA for Microscan
;
;---^LAH(65,1,12,3,4,0) = 1^^gns-f6 ---> organism
;---^LAH(65,1,12,3,4,1,0) = ^F --> status
;
NLT S LRNLT=+LRORGNM I LRNLT S LRORGNUM=$O(^LAB(61.2,"NLT",LRNLT,0)) D
. I LRORGNUM S ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)=LRORGNUM_U_U
Q:$G(LRORGNUM)
;
LIC ;
S LRORGN=LRORGNM
I LRORGN S LRORGN=$O(^LAB(61.39,1,1,"B",LRORGN,0))
I LRORGN S LRORGNUM=^LAB(61.39,1,1,LRORGN,1) ; IEN ETIOLOGY FIELD
I $G(LRORGNUM),$D(^LAB(61.2,LRORGNUM,0)) D QUIT
. S ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)=LRORGNUM_U_U
;
FILE ;
S LRORGN=$G(LRORGNM)
I $D(LRORGN) S LRORGNUM=$O(^LAB(61.2,"B",LRORGN,0))
LRORGX I $G(LRORGNUM),$D(^LAB(61.2,LRORGNUM,0)) D QUIT
. S ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)=LRORGNUM_U_U_U
. S ^LAH(LA7LWL,1,LA7ISQN,"IHS")=$G(LA7VRS) ;result status
. ; D MKKDEBUG(LA7OBX,LA7MABN,"LRORGX")
. S ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,"IHSOBX")=LA7MRES_U_LA7MUNIT_U_LA7MABN_U_LA7MRS_U_LA7MRSDT_U_LA7MPO_U_$G(LA7MPN)_U_$G(LA7PMD)
;
;
QUIT
AB ;
;---^LAHM(62.49,61,150,13,0) = OBX|1|ST|81812.0000^Neomycin^VANLT^18^NEO
;---MYCN^VA62.06||MIC|||R
;
NLTA ;
S LRABNLT=$P(LRAB,U) Q:LRABNLT="" ; ---> Need nlt error code here?
;---^LAB(62.06,"NLT","81098.0000",1)
I +LRABNLT S LRDRUG=$O(^LAB(62.06,"NLT",LRABNLT,0))
I $G(LRDRUG) S LRDNODE=$P(^LAB(62.06,LRDRUG,0),U,2) D QUIT
. I LRDNODE D INTERP
;
;
LIC1 ;
;--> checks the LIC file for translation like for the Vitek
;***** CHANGE----\/ To a variable
I '$P(LRAB,LA7CS,5) D MS QUIT
I '$D(^LAB(61.39,1,2,"B",$P(LRAB,LA7CS,5))) D MS QUIT
S LRAB=$P(LRAB,LA7CS,5)
S LRAB=$O(^LAB(61.39,1,2,"B",LRAB,""))
I +LRAB S LRAB=^LAB(61.39,1,2,LRAB,1) ; IEN ANTIMICROBIAL SUSCEP
S LRDNODE=$P(^LAB(62.06,LRAB,0),U,2) ; Pull out drug node (n.xxxx)
I LRDNODE D INTERP QUIT
;
;
MS ;
;
I '$O(^LAB(62.4,LA7624,7,1,2,0)) D LAB6204 QUIT
S LRAB=$P(LRAB,U)
; LA7624 = ien of instrument in file #62.4
;---> ^LAB(62.4,LA7624,7,1,2,40,0) = 67^2.00693023^^AmS^9
;---> OBX|1|ST|A/S^^^||<8/4|ug/ml|||||F
S LRTIC=0
;---------------->TEST TEST\/
S LRABIEN=$O(^LAB(62.4,LA7624,7,1,2,"C",LRAB,0))
I LRABIEN S LRNODE=LRABIEN ;D INTERP
Q:'LRABIEN ;->FIX DRUG TX
S LRABIEN=+$G(^LAB(62.4,LA7624,7,1,2,LRABIEN,0))
S LRDNODE=$P($G(^LAB(62.06,LRABIEN,0)),U,2)
I LRDNODE D GETM
;
;
QUIT
F S LRTIC=$O(^LAB(62.4,LA7624,7,1,2,LRTIC)) Q:+LRTIC'>0 S LRN=^(LRTIC,0) D
. I $P(LRN,U,4)=LRAB S LRDNODE=$P(LRN,U,2) D
.. I LRDNODE D GETM
;
QUIT
LAB6204 ;
;
S LRN=$P(LRAB,LA7CS,5)
S LRNONDE=$P(^LAB(62.04,$O(^LAB(62.04,"B",LRN,0)),0),U,2)
;---> LA7LOG LOGS THE ERRORS
;
;
INTERP ;------->all drugs go through here
;------------------------------------------------------------------
;---^LAH(65,1,12,3,4,2.0012) = 2^S^A --->DRUG MIC^INTERP^DISPLAY
;
;---> Need to apply the 69.9 challenge here...not for prototype.
; --> ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)=$G(LRORGNUM)_U_U
;
;I '$G(LRORGNUM) S LRORGNUM=$O(^LAB(61.2,"B",LRORGNM,0))
;S LRISO=0
;F S LRISO=$O(^TMP("LRISO",$J,LRISO)) Q:+LRISO'>0 D GETM
D GETM
Q
GETM ;
;I ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)=$G(^LAH(LA7LWL,1,LA7ISQN,3,LRISO-1,0))
; stop if no inter in la7obx
; OBX|1|ST|Ak|620|<=16|ug/ml||S||F
I $P(LA7OBX,LA7FS,6)'="" Q:$P(LA7OBX,LA7FS,9)=""
S LRORG=$P(LA7OBX,LA7FS,5)
S LA7ICNT=LA7ICNT+1
;S LRISO=$O(^TMP("LRISO",$J,LRISOX,LRORG,0))
;I '$G(LRISO) S LRISO=$O(^TMP("LRISO",$J,0))
;I '$G(LRISO) S LRISO=1
D MKKDEBUG(LA7OBX,LA7MABN,"GETM")
S ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,"ISO",LA7ICNT)=$G(LRABIEN)_U_$G(LRDNODE)_U
S ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,"ISO","IHSOBX",LA7ICNT)=LA7MRES_U_LA7MUNIT_U_LA7MABN_U_LA7MRS_U_LA7MRSDT_U_LA7MPO_U_$G(LA7MPN)_U_$G(LA7PMD)
QUIT
; . S ^TMP("LRISO",$J,LRISO,LRORG)=""
; . S ^TMP("LRORG",$J,LRORG,LRISO)=""
K MIC
S LRSP=LA761
;I '$G(LRORGNUM) D
; . I $G(LRORGNUM)'=$P(LA7OBX,LA7FS,5) S LRORGNUM=$P(LA7OBX,LA7FS,5) D
; .. S ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)=LRORGNUM_U_U
;I '$D(LRORGNUM) D CREATE^LA7LOG(52) ;-->NO ORG
;I '$D(LRDNODE) D CREATE^LA7LOG(53) ;-->NO DRUG
S K1=$G(LRMIC)
Q:'$G(LRISO)
S ISOL=+$G(^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0))
;
;
Q:ISOL'>0
Q:'$G(LRDNODE)
;S ORG(ISOL)=$P($G(^LAB(61.2,ISOL,0)),U)
S ORG(ISOL)=ISOL
S MIC(ISOL,LRDNODE)=$G(LRMIC)
S J=0
;QUIT
F S J=$O(MIC(ISOL,J)) Q:J<1 D
. S K=MIC(ISOL,J)_"^"
. D INTRP^LAMIVTE6 D QUIT ;--> Franko's interp program.
.. S ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,J)=LRMIC_"^"_S
.. S LA7INTRP=$P(LA7OBX,"|",9),LA7MIC=$P(LA7OBX,"|",6)
.. S ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,J)=LA7MIC_U_LA7INTRP
;
;I LRISO>1 I ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)=$G(^LAH(LA7LWL,1,LA7ISQN,3,LRISO-1,0)) K ^LAH(LA7LWL,1,LA7ISQN,3,LRISO)
QUIT
;
RPTFAC(LA7PRDID,LA7SFAC,LA7CS) ; Process/Store Producer's ID
; Store where test was performed.
; Call with LA7PRDID = Producer's ID field
; LA7SFAC = sending facility
; LA7CS = component encoding character
;
N LA74,LA7X,LA7Y
;
;S LA7X=$P(LA7PRDID,LA7CS,2),LA74=""
S LA7X=LA7PRDID,LA74=""
;
I $P(LA7PRDID,LA7CS,3)="99VA4" S LA74=$$FIND1^DIC(4,"","OMX",$P(LA7PRDID,LA7CS))
I 'LA74 S LA74=$$FINDSITE^LA7VHLU2($P(LA7PRDID,LA7CS),1,1)
;I 'LA74 S LA74=$$FINDSITE^LA7VHLU2($P(LA7SFAC,LA7CS),1,1)
;
; Store producer's id in LAH global with results.
;I LA74 S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",9)=LA74
;
Q $G(LA74)
;
MKKDEBUG(OBXSEG,ABNFLG,LABEL) ; EP - DEBUG
Q ; Don't use except during development
;
S ^XTMP("LA7VCMI",$$HTE^XLFDT($H,"2MZ"),$J,LABEL,"ABNFLG")=ABNFLG
S ^XTMP("LA7VCMI",$$HTE^XLFDT($H,"2MZ"),$J,LABEL,"OBXSEG")=OBXSEG
Q
LA7VCMI ;IHS/CMI/MAW - Micro Filing Pre LEDI IV ; 22-Oct-2013 09:22 ; MAW
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**1033**;NOV 01, 1997
+2 ;
+3 ;
+4 ;borrowed and modified code from david hoak
+5 ;;5.2;AUTOMATED LAB INSTRUMENTS;**41**;Sep 27, 1994
+6 ;
+7 ;-->P.R.O.T.O.T.Y.P.E.--P.R.O.T.O.T.Y.P.E--P.R.O.T.O.T.Y.P.E
+8 ;
+9 ;-------------------------------> MICROSCAN->OBX|1|ST||1|150||||||F
+10 ; /\
+11 ;---------------------------ORGANISM--------------------|
+12 ;
+13 ;---^LAHM(62.49,61,150,11,0)=OBR|2||^ANTIBIOTIC MIC^VANLT||||19861210083
+14 ;--- |||||||||^^BLOOD|||||||||||87993.0000^1
+15 ;
EPI ;---^LAHM(62.49,61,150,13,0) = OBX|1|ST|81812.0000^Neomycin^VANLT^18^NEO
+1 ;---MYCN^VA62.06|||||R
+2 ;
+3 ;
+4 ;--> CONTINUE DOWN LAHM GLOBAL
+5 ;
MI ;
+1 ; Don't do anything, for now.
+2 ;Q
+3 ;
+4 ; I $G(^LAHM(62.49,LA76249,0))["IM-VITEK" D MI^LA7ZV3 QUIT
+5 KILL LRISOX
+6 ;QUIT
OBX ;
+1 ;I $G(LA7AN)'>0 D ^AGNQBLOD ;BLOOD CULTURE ACCN AREA
+2 ;I $L(LA7AN)=8 S LA7AN=+$E(LA7AN,2,8)/1 D BC^AGNQBLOD
+3 ;
+4 IF $GET(LRMIFLAG)=LA7OBR
SET LA7QUIT=1
DO END
QUIT
+5 ;--> Don't pay for the same realestate twice. gsp
+6 KILL ^TMP("LRISO"),^TMP("LRORG")
+7 ;
+8 ;ihs/cmi/maw 03/08/2013 added for MU and LEDI III
+9 SET LRMIFLAG=LA7OBR
+10 SET LRMIEN=LA762495
+11 SET LA7OBX=$GET(LA7SEG(0))
+12 IF $GET(LA7OBX)=""
QUIT
+13 DO BUGS
+14 DO CH1
+15 QUIT
+16 ;
BACK ;
+1 FOR
SET LA762495=$ORDER(^LAHM(62.49,LA76249,150,LA762495))
IF 'LA762495
QUIT
SET LA7OBX=^LAHM(62.49,LA76249,150,LA762495,0)
DO CHOBR
IF $EXTRACT(LA7OBX,1,3)'="OBX"
QUIT
Begin DoDot:1
+2 ;
+3 SET LRMIFLAG=LA7OBR
+4 ;-->MICROSCAN data inovations OBX|1|ST|DRUG|ORGANISM|MIC|UNITS|||||F
+5 SET LRMIEN=LA762495
+6 ;I '$G(LRORGNM) D CREATE^LA7LOG(52) ;-->NO ORG
DO BUGS
+7 ;D DRUGS
End DoDot:1
+8 ;
CH1 IF $EXTRACT($GET(LA7OBX),1,3)="OBR"
GOTO BACK
+1 KILL LA7CNT
DO END
+2 QUIT
CHOBR ;
+1 ;ZW LRISOX
+2 IF $EXTRACT(LA7OBX,1,3)'="OBR"
QUIT
+3 IF LA7OBX["IM-MISCN"
SET LRISOX=$PIECE(LA7OBX,U,2)
+4 QUIT
+5 ;
+6 ;
BUGS ;
+1 ;
+2 ; ZW LA7OBX
+3 ; VITEK
+4 ; I $G(LRORGNUM) G DRUG
+5 ; ***
+6 ; I +$P(LA7OBX,LA7FS,5) G DRUG
+7 ; LAHM(62.49,1525185,150,5,0) = OBX|1|ST|ISO1||1||||||F
+8 IF LA7OBX["ISO"
SET LRISO=+$PIECE(LA7OBX,"ISO",2)
Begin DoDot:1
+9 SET LRORG=+$PIECE(LA7OBX,LA7FS,6)
+10 IF '$GET(LRISOX)
SET LRISOX=1
+11 IF '$TEST
SET LRISOX=LRISOX+1
+12 SET ^TMP("LRISO",$JOB,LRISOX,LRORG,LRISO)=""
End DoDot:1
QUIT
+13 ; Look in auto inst 62.4 then Get the ien for 61.2
+14 ;S LRORG=$P($P($G(LA7OBX),LA7FS,5),LA7CS) ;ihs/cmi/maw 03/08/2013 for MU orig line
+15 ;ihs/cmi/maw MU2 below code for filing MICRO
+16 NEW LA7MRES,LA7MUNIT,LA7MABN,LA7MRS,LA7MRSDT,LA7MPO
+17 ;ihs/cmi/maw 03/08/2013 for MU
SET (LA7MRES,LRORG)=$PIECE($PIECE($GET(LA7OBX),LA7FS,6),LA7CS)
+18 SET LA7MUNIT=$PIECE($GET(LA7OBX),LA7FS,7)
+19 IF LA7MUNIT]""
SET LA7MUNIT=$TRANSLATE($$TRIM^XLFSTR(LA7MUNIT,"LR"," "),"^","~")
+20 SET LA7MABN=$PIECE($GET(LA7OBX),LA7FS,9)
+21 SET LA7MRS=$PIECE($GET(LA7OBX),LA7FS,12)
+22 SET LA7MRSDT=$$HL7TFM^XLFDT($$P^LA7VHLU(.LA7SEG,15,LA7FS),"L")
+23 SET LA7MPO=$PIECE($PIECE($GET(LA7OBX),LA7FS,24),LA7CS,10)
+24 SET LA7MPO=$$RPTFAC(LA7MPO,LA7SFAC,LA7CS)
+25 ; ihs/cmi/maw 03/08/2013 for MU
SET LRISO=$PIECE(LA7OBX,LA7FS,5)
+26 ; ihs/cmi/maw MU2 these are drugs so dont worry about the org here
IF $PIECE(LA7OBX,LA7FS,3)="SN"
Begin DoDot:1
+27 ;S LA7MRES=$P($P($G(LA7OBX),LA7FS,6),LA7CS,2)
+28 SET LA7MRES=$TRANSLATE($PIECE($GET(LA7OBX),LA7FS,6),LA7CS,"")
+29 ;this is the parent node in OBR
SET LRISO=LA7MPN
+30 DO DRUGS
End DoDot:1
QUIT
+31 ;ihs/cmi/maw MU2 end of mods
+32 IF +LRORG>0
SET LRORGNUM=$ORDER(^LAB(62.4,LA7624,7,1,1,"C",LRORG,0))
Begin DoDot:1
+33 ;62.4,3,7,1,1=ORGS 62.4,3,7,1,2=DRUGS
IF 'LRORGNUM
QUIT
+34 ;
+35 SET LRORGNUM=+$GET(^LAB(62.4,LA7624,7,1,1,LRORGNUM,0))
Begin DoDot:2
+36 IF LRORGNUM
SET LRORGNM=$PIECE($GET(^LAB(61.2,LRORGNUM,0)),U)
End DoDot:2
End DoDot:1
+37 NEW LA7VRS
+38 ;result status
SET LA7VRS=$PIECE(LA7OBX,LA7FS,12)
+39 ; ihs/cmi/maw 03/08/2013 for MU
DO FILE
QUIT
+40 IF +$GET(LRORGNUM)>0
GOTO MSCAN
QUIT
+41 ;
BU1 IF $GET(LRORG)=""
QUIT
SET LRORGNUM=$ORDER(^LAB(61.39,1,1,"B",LRORG,0))
Begin DoDot:1
+1 IF 'LRORGNUM
QUIT
+2 IF LRORGNUM
SET LRORGNUM=$GET(^LAB(61.39,1,1,LRORGNUM,1))
Begin DoDot:2
+3 IF LRORGNUM
SET LRORGNM=$PIECE($GET(^LAB(61.2,LRORGNUM,0)),U)
End DoDot:2
End DoDot:1
+4 ;I $D(^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)) D
+5 ; . ;***
+6 ; . ;S LRISO=LRISO+1 S ^TMP("LRISO",$J,LRISO)=""
+7 ;***
+8 ;I LRISO>1 Q:LRORGNUM=+$G(^LAH(LA7LWL,1,LA7ISQN,3,LRISO-1,0))
MSCAN ;
+1 ; The microscan sends a number for the organism.
+2 ; 1 of two possible conditions may exist for the Microscan
+3 ; 1 the OBX is an ISOn or a DRUG
+4 ;I '$G(LRISO) S LRISO=$O(^TMP("LRISO",$J,0))
+5 ;I '$G(LRISO) S LRISO=1
+6 ;I LRORG S ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)=$G(LRORG)_U_U D
+7 ; . S ^TMP("LRISO",$J,LRISO,LRORG)=""
+8 ; . S ^TMP("LRORG",$J,LRORG,LRISO)=""
+9 ;
+10 ;Q:+$G(LRORGNUM)>0 ; --This segment has an org in 4th piece
+11 ;
+12 IF LA7OBX["ISO"
QUIT
DRUG ; -->VITEK
+1 ;
+2 IF '+$PIECE(LA7OBX,LA7FS,5)
QUIT
+3 ;
+4 ;
SETISO ;I '$O(^TMP("LRISO",$J,LRISO)) S LRIS0=0 D
+1 ; . F S LRISO=$O(^TMP("LRISO",$J,LRISO)) Q:+LRISO
+2 ;
+3 SET LRORG=$PIECE(LA7OBX,LA7FS,5)
+4 ;S LRISO=$O(^TMP("LRORG",$J,LRORG,0))
+5 ;
+6 ;
+7 ;
+8 IF $PIECE(LA7OBX,LA7FS,5)
IF LRORG'=$PIECE($PIECE($GET(LA7OBX),LA7FS,5),LA7CS)
SET LRORG=$PIECE($PIECE($GET(LA7OBX),LA7FS,5),LA7CS)
IF $DATA(LRORG)
GOTO BU1
+9 ;
+10 ;I LRISO>1 I LRORGNUM=+$G(^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)) D QUIT
+11 ; . K ^LAH(LA7LWL,1,LA7ISQN,3,LRISO)
+12 ;
+13 ; ^LAB(61.39,1,2,"B","cec",100)
+14 ; -->OBX|1|ST|Gm|126|4|ug/ml||||F
+15 SET LRD1=$PIECE($PIECE($GET(LA7OBX),LA7FS,4),LA7CS)
+16 ;-->LIC FILE
SET LRD=$ORDER(^LAB(61.39,1,2,"B",LRD1,0))
+17 ;I $G(LRD) S LRDNUM=$G(^LAB(61.39,1,2,LRD,1)) D
+18 ;. S LRMIC=$P($G(LA7OBX),LA7FS,6)
+19 ;. S LRINTRP=$P(LA7OBX,LA7FS,9)
+20 ;. S LRDNODE=$P(^LAB(62.06,LRDNUM,0),U,2) ; Pull out drug node (n.xxxx)
+21 ;. D INTERP
+22 ;
+23 IF '$GET(LRD)
DO DRUGS
+24 ;ihs/cmi/maw 03/08/2013 for MU removed quit
QUIT
+25 ;
+26 ;---^LAHM(62.49,61,150,9,0) = OBX|1|CE|87993.0000^BACTERIOLOGY CULTURE^
+27 ;---VANLT|1|^ESCHERICHIA COLI
+28 ;
+29 ;
+30 ; OBX|1|ST|126^^^||||||||F
+31 ; OBX-1 = 1
+32 ; OBX-2 = ST
+33 ; OBX-3 = 126^^^
+34 ; OBX-3-1 = 126
+35 ; OBX-11 = F
+36 ; OBR|2|3207||||||||||||||||MSCAN||||||||^1
+37 ; OBR-1 = 2
+38 ; OBR-2 = 3207
+39 ; OBR-18 = MSCAN
+40 ; OBR-26 = ^1
+41 ; OBR-26-2 = 1
+42 ; OBX|1|ST|Gm|126|4|ug/ml||||F
+43 ;
+44 ;
+45 ;--ledi
IF $EXTRACT(LA7OBX,1,3)="OBX"
IF $PIECE(LA7OBX,LA7FS,3)="CWE"
Begin DoDot:1
+46 ;-->NLT^Name
SET LRMIOBX=LA7OBX
SET LRORG=$PIECE($PIECE(LA7OBX,LA7FS,6),LA7CS)
+47 ;
+48 IF $GET(LRORG)'=""
SET LRORGNM=LRORG
DO ORG
End DoDot:1
QUIT
+49 ;
+50 ;--->accomadate multiple life forms----\/
+51 ;
+52 ;
+53 ;I $E(LA7OBX,1,3)="OBX",+$P(LA7OBX,LA7FS,6) S LRORGX=+$P(LA7OBX,LA7FS,6) D
+54 ;
+55 ;-->MICROSCAN data innovations OBX|1|ST|ORGANISM|||||F
+56 ;
+57 ; check for culture ID only
+58 IF $EXTRACT(LA7OBX,1,3)="OBX"
IF +$PIECE(LA7OBX,LA7FS,4)
Begin DoDot:1
+59 SET LRORGX=+$PIECE(LA7OBX,LA7FS,4)
+60 IF $GET(LRORGX)
IF $DATA(^LAB(61,2,LRORGX,0))
DO LRORGX
End DoDot:1
QUIT
+61 ;
+62 ;
+63 ;
+64 ;
+65 ; These bugs have susceptabilities
+66 IF $EXTRACT(LA7OBX,1,3)="OBX"
IF +$PIECE(LA7OBX,LA7FS,5)
Begin DoDot:1
+67 SET LRORGX=+$PIECE(LA7OBX,LA7FS,5)
+68 IF $GET(LRORGX)
IF $DATA(^LAB(61,2,LRORGX,0))
DO LRORGX
End DoDot:1
+69 ;
+70 ;
+71 ;
+72 QUIT
+73 ;
DRUGS ;
+1 ;---> all forms of HL7 can use this format
+2 ;
+3 ; OBX|1|ST|Gm|126|4|ug/ml||||F
+4 IF $EXTRACT(LA7OBX,1,3)="OBX"
IF $PIECE(LA7OBX,LA7FS,3)="SN"
Begin DoDot:1
+5 ;-->NLT^Name
SET LRAB=$PIECE(LA7OBX,LA7FS,4)
+6 IF $GET(LRAB)["ISO"
QUIT
+7 SET LRMIC=$PIECE(LA7OBX,LA7FS,6)
SET LRINTRP=$PIECE(LA7OBX,LA7FS,9)
+8 IF LRMIC=""
DO CREATE^LA7LOG(51)
+9 ;I LRAB'="" D AB ihs/cmi/maw MU2 orig code
+10 ;ihs/cmi/maw MU2 lets try to get the drug
IF LRAB'=""
DO MS
End DoDot:1
+11 QUIT
END ;
+1 KILL LRORG,LRORGX,LRORGNM,LRORGNUM,LRDNODE,LA7OBX,LRMIC,LRAB,LRINTRP,J,MIC,ISOL
+2 KILL LRISO,LRMIFLAG,K1,ORG,LRSP
+3 SET LA7QUIT=1
+4 QUIT
+5 ;
ORG ;
+1 ;***S LRISO=$P(LA7OBX,LA7FS,2)
+2 ; ^LAB(61.2,1,64) = 923 ---> NLT for E.COLI
+3 ; ^LAB(61.2,"NLT","87016.0000",1)
+4 ;
+5 ;---^LAH(65,1,12,0) = 1^1^12^2970000^6^^VITEK^6 --> set in LA7UIIN1
+6 ;---^LAH(65,1,12,2,2) = CARD^gns-f6 ---> NA for Microscan
+7 ;
+8 ;---^LAH(65,1,12,3,4,0) = 1^^gns-f6 ---> organism
+9 ;---^LAH(65,1,12,3,4,1,0) = ^F --> status
+10 ;
NLT SET LRNLT=+LRORGNM
IF LRNLT
SET LRORGNUM=$ORDER(^LAB(61.2,"NLT",LRNLT,0))
Begin DoDot:1
+1 IF LRORGNUM
SET ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)=LRORGNUM_U_U
End DoDot:1
+2 IF $GET(LRORGNUM)
QUIT
+3 ;
LIC ;
+1 SET LRORGN=LRORGNM
+2 IF LRORGN
SET LRORGN=$ORDER(^LAB(61.39,1,1,"B",LRORGN,0))
+3 ; IEN ETIOLOGY FIELD
IF LRORGN
SET LRORGNUM=^LAB(61.39,1,1,LRORGN,1)
+4 IF $GET(LRORGNUM)
IF $DATA(^LAB(61.2,LRORGNUM,0))
Begin DoDot:1
+5 SET ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)=LRORGNUM_U_U
End DoDot:1
QUIT
+6 ;
FILE ;
+1 SET LRORGN=$GET(LRORGNM)
+2 IF $DATA(LRORGN)
SET LRORGNUM=$ORDER(^LAB(61.2,"B",LRORGN,0))
LRORGX IF $GET(LRORGNUM)
IF $DATA(^LAB(61.2,LRORGNUM,0))
Begin DoDot:1
+1 SET ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)=LRORGNUM_U_U_U
+2 ;result status
SET ^LAH(LA7LWL,1,LA7ISQN,"IHS")=$GET(LA7VRS)
+3 ; D MKKDEBUG(LA7OBX,LA7MABN,"LRORGX")
+4 SET ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,"IHSOBX")=LA7MRES_U_LA7MUNIT_U_LA7MABN_U_LA7MRS_U_LA7MRSDT_U_LA7MPO_U_$GET(LA7MPN)_U_$GET(LA7PMD)
End DoDot:1
QUIT
+5 ;
+6 ;
+7 QUIT
AB ;
+1 ;---^LAHM(62.49,61,150,13,0) = OBX|1|ST|81812.0000^Neomycin^VANLT^18^NEO
+2 ;---MYCN^VA62.06||MIC|||R
+3 ;
NLTA ;
+1 ; ---> Need nlt error code here?
SET LRABNLT=$PIECE(LRAB,U)
IF LRABNLT=""
QUIT
+2 ;---^LAB(62.06,"NLT","81098.0000",1)
+3 IF +LRABNLT
SET LRDRUG=$ORDER(^LAB(62.06,"NLT",LRABNLT,0))
+4 IF $GET(LRDRUG)
SET LRDNODE=$PIECE(^LAB(62.06,LRDRUG,0),U,2)
Begin DoDot:1
+5 IF LRDNODE
DO INTERP
End DoDot:1
QUIT
+6 ;
+7 ;
LIC1 ;
+1 ;--> checks the LIC file for translation like for the Vitek
+2 ;***** CHANGE----\/ To a variable
+3 IF '$PIECE(LRAB,LA7CS,5)
DO MS
QUIT
+4 IF '$DATA(^LAB(61.39,1,2,"B",$PIECE(LRAB,LA7CS,5)))
DO MS
QUIT
+5 SET LRAB=$PIECE(LRAB,LA7CS,5)
+6 SET LRAB=$ORDER(^LAB(61.39,1,2,"B",LRAB,""))
+7 ; IEN ANTIMICROBIAL SUSCEP
IF +LRAB
SET LRAB=^LAB(61.39,1,2,LRAB,1)
+8 ; Pull out drug node (n.xxxx)
SET LRDNODE=$PIECE(^LAB(62.06,LRAB,0),U,2)
+9 IF LRDNODE
DO INTERP
QUIT
+10 ;
+11 ;
MS ;
+1 ;
+2 IF '$ORDER(^LAB(62.4,LA7624,7,1,2,0))
DO LAB6204
QUIT
+3 SET LRAB=$PIECE(LRAB,U)
+4 ; LA7624 = ien of instrument in file #62.4
+5 ;---> ^LAB(62.4,LA7624,7,1,2,40,0) = 67^2.00693023^^AmS^9
+6 ;---> OBX|1|ST|A/S^^^||<8/4|ug/ml|||||F
+7 SET LRTIC=0
+8 ;---------------->TEST TEST\/
+9 SET LRABIEN=$ORDER(^LAB(62.4,LA7624,7,1,2,"C",LRAB,0))
+10 ;D INTERP
IF LRABIEN
SET LRNODE=LRABIEN
+11 ;->FIX DRUG TX
IF 'LRABIEN
QUIT
+12 SET LRABIEN=+$GET(^LAB(62.4,LA7624,7,1,2,LRABIEN,0))
+13 SET LRDNODE=$PIECE($GET(^LAB(62.06,LRABIEN,0)),U,2)
+14 IF LRDNODE
DO GETM
+15 ;
+16 ;
+17 QUIT
+18 FOR
SET LRTIC=$ORDER(^LAB(62.4,LA7624,7,1,2,LRTIC))
IF +LRTIC'>0
QUIT
SET LRN=^(LRTIC,0)
Begin DoDot:1
+19 IF $PIECE(LRN,U,4)=LRAB
SET LRDNODE=$PIECE(LRN,U,2)
Begin DoDot:2
+20 IF LRDNODE
DO GETM
End DoDot:2
End DoDot:1
+21 ;
+22 QUIT
LAB6204 ;
+1 ;
+2 SET LRN=$PIECE(LRAB,LA7CS,5)
+3 SET LRNONDE=$PIECE(^LAB(62.04,$ORDER(^LAB(62.04,"B",LRN,0)),0),U,2)
+4 ;---> LA7LOG LOGS THE ERRORS
+5 ;
+6 ;
INTERP ;------->all drugs go through here
+1 ;------------------------------------------------------------------
+2 ;---^LAH(65,1,12,3,4,2.0012) = 2^S^A --->DRUG MIC^INTERP^DISPLAY
+3 ;
+4 ;---> Need to apply the 69.9 challenge here...not for prototype.
+5 ; --> ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)=$G(LRORGNUM)_U_U
+6 ;
+7 ;I '$G(LRORGNUM) S LRORGNUM=$O(^LAB(61.2,"B",LRORGNM,0))
+8 ;S LRISO=0
+9 ;F S LRISO=$O(^TMP("LRISO",$J,LRISO)) Q:+LRISO'>0 D GETM
+10 DO GETM
+11 QUIT
GETM ;
+1 ;I ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)=$G(^LAH(LA7LWL,1,LA7ISQN,3,LRISO-1,0))
+2 ; stop if no inter in la7obx
+3 ; OBX|1|ST|Ak|620|<=16|ug/ml||S||F
+4 IF $PIECE(LA7OBX,LA7FS,6)'=""
IF $PIECE(LA7OBX,LA7FS,9)=""
QUIT
+5 SET LRORG=$PIECE(LA7OBX,LA7FS,5)
+6 SET LA7ICNT=LA7ICNT+1
+7 ;S LRISO=$O(^TMP("LRISO",$J,LRISOX,LRORG,0))
+8 ;I '$G(LRISO) S LRISO=$O(^TMP("LRISO",$J,0))
+9 ;I '$G(LRISO) S LRISO=1
+10 DO MKKDEBUG(LA7OBX,LA7MABN,"GETM")
+11 SET ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,"ISO",LA7ICNT)=$GET(LRABIEN)_U_$GET(LRDNODE)_U
+12 SET ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,"ISO","IHSOBX",LA7ICNT)=LA7MRES_U_LA7MUNIT_U_LA7MABN_U_LA7MRS_U_LA7MRSDT_U_LA7MPO_U_$GET(LA7MPN)_U_$GET(LA7PMD)
+13 QUIT
+14 ; . S ^TMP("LRISO",$J,LRISO,LRORG)=""
+15 ; . S ^TMP("LRORG",$J,LRORG,LRISO)=""
+16 KILL MIC
+17 SET LRSP=LA761
+18 ;I '$G(LRORGNUM) D
+19 ; . I $G(LRORGNUM)'=$P(LA7OBX,LA7FS,5) S LRORGNUM=$P(LA7OBX,LA7FS,5) D
+20 ; .. S ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)=LRORGNUM_U_U
+21 ;I '$D(LRORGNUM) D CREATE^LA7LOG(52) ;-->NO ORG
+22 ;I '$D(LRDNODE) D CREATE^LA7LOG(53) ;-->NO DRUG
+23 SET K1=$GET(LRMIC)
+24 IF '$GET(LRISO)
QUIT
+25 SET ISOL=+$GET(^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0))
+26 ;
+27 ;
+28 IF ISOL'>0
QUIT
+29 IF '$GET(LRDNODE)
QUIT
+30 ;S ORG(ISOL)=$P($G(^LAB(61.2,ISOL,0)),U)
+31 SET ORG(ISOL)=ISOL
+32 SET MIC(ISOL,LRDNODE)=$GET(LRMIC)
+33 SET J=0
+34 ;QUIT
+35 FOR
SET J=$ORDER(MIC(ISOL,J))
IF J<1
QUIT
Begin DoDot:1
+36 SET K=MIC(ISOL,J)_"^"
+37 ;--> Franko's interp program.
DO INTRP^LAMIVTE6
Begin DoDot:2
+38 SET ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,J)=LRMIC_"^"_S
+39 SET LA7INTRP=$PIECE(LA7OBX,"|",9)
SET LA7MIC=$PIECE(LA7OBX,"|",6)
+40 SET ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,J)=LA7MIC_U_LA7INTRP
End DoDot:2
QUIT
End DoDot:1
+41 ;
+42 ;I LRISO>1 I ^LAH(LA7LWL,1,LA7ISQN,3,LRISO,0)=$G(^LAH(LA7LWL,1,LA7ISQN,3,LRISO-1,0)) K ^LAH(LA7LWL,1,LA7ISQN,3,LRISO)
+43 QUIT
+44 ;
RPTFAC(LA7PRDID,LA7SFAC,LA7CS) ; Process/Store Producer's ID
+1 ; Store where test was performed.
+2 ; Call with LA7PRDID = Producer's ID field
+3 ; LA7SFAC = sending facility
+4 ; LA7CS = component encoding character
+5 ;
+6 NEW LA74,LA7X,LA7Y
+7 ;
+8 ;S LA7X=$P(LA7PRDID,LA7CS,2),LA74=""
+9 SET LA7X=LA7PRDID
SET LA74=""
+10 ;
+11 IF $PIECE(LA7PRDID,LA7CS,3)="99VA4"
SET LA74=$$FIND1^DIC(4,"","OMX",$PIECE(LA7PRDID,LA7CS))
+12 IF 'LA74
SET LA74=$$FINDSITE^LA7VHLU2($PIECE(LA7PRDID,LA7CS),1,1)
+13 ;I 'LA74 S LA74=$$FINDSITE^LA7VHLU2($P(LA7SFAC,LA7CS),1,1)
+14 ;
+15 ; Store producer's id in LAH global with results.
+16 ;I LA74 S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",9)=LA74
+17 ;
+18 QUIT $GET(LA74)
+19 ;
MKKDEBUG(OBXSEG,ABNFLG,LABEL) ; EP - DEBUG
+1 ; Don't use except during development
QUIT
+2 ;
+3 SET ^XTMP("LA7VCMI",$$HTE^XLFDT($HOROLOG,"2MZ"),$JOB,LABEL,"ABNFLG")=ABNFLG
+4 SET ^XTMP("LA7VCMI",$$HTE^XLFDT($HOROLOG,"2MZ"),$JOB,LABEL,"OBXSEG")=OBXSEG
+5 QUIT
