LA7VIN7 ;DALOI/JDB - HANDLE ORU OBX FOR MICRO/AP ;12/20/16 11:20
;;5.2;AUTOMATED LAB INSTRUMENTS;**74,90**;Sep 27, 1994;Build 17
;
; Continuation of LA7VIN1 and is only called from there.
; Process OBX segments for "MI" subscript tests.
Q
;
;
OBX ;
;
N ALTCONC,CODSYS,DATA,DIERR,DSOBX3,DSOBX5,ISCOMP,OBX3,OBX4,OBX5,OBX6,OBX8,OBX11,OBX15
N LA76247,LA7612,LA74,LA7RLNC,LA7RNLT,LA7SCT,LA7SUBFL,LA7VTYP,LAX,LAY
;
; Note: LA7OBR25 holds the OBR's report status (OBR-25)
K LA7RMK,^TMP("LA7TREE",$J)
;
; OBX Set ID
S LA7SOBX=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
;
; Value type - type of data from Table 0125
S LA7VTYP=$P($$P^LA7VHLU(.LA7SEG,3,LA7FS),LA7CS)
;
S OBX3=$$FIELD^LA7VHLU7(3)
D FLD2ARR^LA7VHLU7(.OBX3)
I $D(OBX3)>1 S ISCOMP("OBX3")=1
; step through code tuplets until we find one we can process
S DSOBX3=$$DBSTORE^LA7VHLU7(.OBX3,1,,,LA76248,.DATA)
; check for LN and/or 99VA64 code systems
K CODSYS D CODSYS^LA7VHLU7(.OBX3,.CODSYS)
; Result's LOINC code
S LAX=+$O(CODSYS("B","LN",0))
S LA7RLNC=""
I LAX S LA7RLNC=OBX3(LAX-2) S LA7RLNC(1)=OBX3(LAX-1)
; Result's NLT code
S LAX=+$O(CODSYS("B","99VA64",0))
S LA7RNLT=""
I LAX S LA7RNLT=OBX3(LAX-2) S LA7RNLT(1)=OBX3(LAX-1)
K CODSYS
;
; OBX3 cannot be mapped. Stop processing.
; No File #62.47 mapping found for OBX-3
I +DSOBX3'>0 D Q ;
. N LA7OBX3
. S LA7OBX3=OBX3 ;needed for log
. S LA7OBX3=$$UNESC^LA7VHLU3(LA7OBX3,LA7FS_LA7ECH)
. D CREATE^LA7LOG(200)
. S LA7KILAH=1 S LA7QUIT=2
;
S LA76247=$P(DSOBX3,"^",1)
;
;
S OBX4=$$FIELD^LA7VHLU7(4)
S OBX5=$$FIELD^LA7VHLU7(5)
I OBX5="" D CREATE^LA7LOG(17) Q
;
S (DSOBX5,LA7SCT)="",LA7612=0
;
; String Data/ Formatted Text/ Text Data
;I LA7VTYP?1(1"FT",1"ST",1"TX") D
;I LA7VTYP="FT" D
;. K LAX
;. D PA^LA7VHLU(.LA7SEG,6,LA7FS,.LAX)
;. D UNESCFT^LA7VHLU3(.LAX,LA7FS_LA7ECH,.LA7WP)
;
I LA7VTYP?1(1"CE",1"CM",1"CNE",1"CWE") D
. D FLD2ARR^LA7VHLU7(.OBX5)
. I $D(OBX5)>1 S ISCOMP("OBX5")=1
. ; step through code tuplets until we find one we can process
. K DATA
. S DSOBX5=$$DBSTORE^LA7VHLU7(.OBX5,2,1,+LA76247,+$G(LA76248),.DATA)
. K CODSYS
. D CODSYS^LA7VHLU7(.OBX5,.CODSYS)
. ; No Coding System found is an error
. ; Prevent new File #61.2 entries created from bad OBX-5
. I $O(CODSYS("B",0))="" D Q ;
. . N LA7VOBX5
. . S LA7VOBX5=OBX5
. . S LA7VOBX5=$$UNESC^LA7VHLU3(LA7VOBX5,LA7FS_LA7ECH)
. . D CREATE^LA7LOG(203)
. . S LA7KILAH=1 S LA7QUIT=2
. ;
. ; get SCT code if present
. S LAX=$O(CODSYS("B","SCT",0)) I LAX S LA7SCT=$G(OBX5(LAX-2))
. ;
;
Q:$G(LA7QUIT)
;
; Need to check data storage type of DSOBX3 and compare to data in OBX-5.
; If OBX5 is a CE but DSOBX3 shows text (data type mismatch)
; then check if there's an ALTERNATIVE CONCEPT for LA76247
S ALTCONC=$$ALCONCPT^LA7VHLU6(LA76247)
I ALTCONC>0 I ALTCONC'=LA76247 D ;
. N R64061,SS,TLC,X,FILE,FLD,LAOUT,LAMSG,LADT1,LADT2
. N DATAOK,X
. S DATAOK=0
. S FILE=$P(DSOBX3,"^",3)
. S FLD=$P(DSOBX3,"^",4)
. ; data type of current storage location
. S LADT1=$$GET1^DID(FILE,FLD,"","TYPE","LAOUT","LAMSG")
. I LADT1["POINTER",LA7VTYP?1(1"CE",1"CM",1"CNE",1"CWE") Q
. S DATAOK=0
. I LADT1="SET" D Q:DATAOK ;
. . ; 7,21 can be reported as CE/SCT which get translated to SET
. . I "^7^21^"[("^"_LA76247_"^") S DATAOK=1 Q
. . S DATAOK=$$DATAOK(FILE,FLD,OBX5)
. ;
. I LADT1'="SET",LADT1'["POINTER",LA7VTYP'?1(1"CE",1"CM",1"CNE",1"CWE") Q
. Q:DATAOK
. ; get alternate concept data
. S X=$G(^LAB(62.47,ALTCONC,0))
. S R64061=$P(X,U,3)
. S SS=$P(X,U,2)
. S X=$G(^LAB(64.061,R64061,63))
. S FILE=$P(X,U,2)
. S FLD=$P(X,U,3)
. I 'FILE I 'FLD Q
. S TLC=$P(X,U,4) ;SCT Top Level
. S LADT2=$$GET1^DID(FILE,FLD,"","TYPE","LAOUT","LAMSG")
. I LADT1=LADT2 Q
. I LA7VTYP?1(1"CE",1"CM",1"CNE",1"CWE") D
. . I LADT1["POINTER" Q
. . S DSOBX3(1)=DSOBX3
. . S DSOBX3=ALTCONC_"^"_SS_"^"_FILE_"^"_FLD_"^"_TLC
. I LA7VTYP'?1(1"CE",1"CM",1"CNE",1"CWE") D
. . I LADT1'["POINTER" Q
. . S DSOBX3(1)=DSOBX3
. . S DSOBX3=ALTCONC_"^"_SS_"^"_FILE_"^"_FLD_"^"_TLC
. ;
;
;
I LA7VTYP?1(1"CE",1"CM",1"CNE",1"CWE") D
. ; Do only if Concept (#62.47) is not a susceptibility concept (susc reported as SCT code)
. ; Create new file entry if needed
. I LA76247'=7,LA76247'=21,LA7SS="MI",(+DSOBX5<-1!(+DSOBX5=0)) D
. . ; Stage Result may be reported as SCT code
. . I LA76247=13 I LA7SCT'="" S X=$$SCT2PSTG^LA7VHLU6(LA7SCT,,"SCT") Q:X'=""
. . ; add entry (add local code to #62.47 if needed?)
. . ; If SCT was passed use that one, else use primary component
. . N FILE,TXT,FLD,MSG
. . S FILE=$P(DSOBX3,"^",3)
. . S FLD=$P(DSOBX3,"^",4)
. . S X=$$GET1^DID(FILE,FLD,"","TYPE","","MSG")
. . I X'="POINTER" S FILE=""
. . I X="POINTER" S FILE=$$GET1^DID(FILE,FLD,"","POINTER","","MSG")
. . I FILE'="" D ;
. . . ; no API to convert global root [ie LAHM(62.48)] to file #
. . . S FILE="^"_FILE
. . . S FILE=$$TRIM^XLFSTR(FILE,"R",",")
. . . I $P(FILE,"(",2)'="" S FILE=FILE_"," ;^XX( or ^XX(nn
. . . S FILE=FILE_"0)"
. . . I FILE'="" S FILE=$G(@FILE)
. . . S FILE=+$P(FILE,U,2)
. . ;
. . N LAHLSEGS,LA74,SCTINOBX
. . S SCTINOBX=0
. . ;S TXT=OBX5(2)
. . I LA7SCT'="" D ;
. . . S LAX=$O(CODSYS("B","SCT",0))
. . . I LAX S SCTINOBX=LAX
. . . ;S TXT=OBX5(LAX-1)
. . ;S TXT=$$UNESC^LA7VHLU3(TXT,LA7FS_LA7ECH)
. . S LA74=$$LKUP^XUAF4(LA7SFAC)
. . S LAHLSEGS("R4")=LA74
. . S LAHLSEGS("R6247")=$G(LA76247)
. . S LAHLSEGS("FSEC")=LA7FS_LA7ECH
. . S LAHLSEGS("MSH",3)=LA7SAP
. . S LAHLSEGS("MSH",4)=LA7SFAC
. . S LAHLSEGS("MSH",5)=LA7RAP
. . S LAHLSEGS("MSH",6)=LA7RFAC
. . S LAHLSEGS("MSH",11)=$G(LA7MID)
. . S LAHLSEGS("OBX",3)=OBX3
. . S LAHLSEGS("OBX",5)=OBX5
. . ; ? Should we try SCT first no matter which codeset it is?
. . ; try primary codeset first
. . S TXT=$G(OBX5(2))
. . S TXT=$$UNESC^LA7VHLU3(TXT,LA7FS_LA7ECH)
. . S X=$S(SCTINOBX=3:LA7SCT,1:"") ;SCT in 1st component?
. . S X=$$EN^LRSCTX(FILE,TXT,X,.LAHLSEGS,,1)
. . ; try secondary codeset
. . I X'>0 D ;
. . . S TXT=$G(OBX5(5))
. . . S TXT=$$UNESC^LA7VHLU3(TXT,LA7FS_LA7ECH)
. . . I TXT="" S X=0 Q
. . . S X=$S(SCTINOBX=6:LA7SCT,1:"") ;SCT in 2nd component?
. . . S X=$$EN^LRSCTX(FILE,TXT,X,.LAHLSEGS,,1)
. . ; no matches so add new entry using codeset 1
. . ; if LEDI interface (10) and no matches then add new entry and codeset 1
. . I LA7INTYP=10,X'>0 D ;
. . . S TXT=$G(OBX5(2))
. . . S TXT=$$UNESC^LA7VHLU3(TXT,LA7FS_LA7ECH)
. . . S X=$S(SCTINOBX=3:LA7SCT,1:"")
. . . S X=$$EN^LRSCTX(FILE,TXT,X,.LAHLSEGS)
. . I X'>0 D Q ; create error log: Could not create new entry in file
. . . N LA7STR,LRFILE,LRINFO
. . . S LA7STR("^")="~U~",LRFILE=FILE,LRINFO="for OBX sequence "_LA7SOBX_" OBX(5) data: "_$$REPLACE^XLFSTR(OBX5,.LA7STR)
. . . D CREATE^LA7LOG(206)
. . . S LA7KILAH=1,LA7QUIT=2
. . . ;
. . I FILE=61.2 S LA7612=+X
. . K DATA,LAHLSEGS
. . S DSOBX5=$$DBSTORE^LA7VHLU7(.OBX5,2,1,+LA76247,+$G(LA76248),.DATA)
. . K DATA
. S LAX=OBX5 K OBX5 S OBX5=LAX ;delete OBX5 array but keep OBX5
. K CODSYS
;
Q:$G(LA7QUIT)
;
;
S OBX6=$$FIELD^LA7VHLU7(6)
S OBX8=$$FIELD^LA7VHLU7(8)
;
; Observation result status - Table 0085
S OBX11=$$FIELD^LA7VHLU7(11)
;
; Producer's ID
S OBX15=$$FIELD^LA7VHLU7(15)
S (LA74,LA7PRODID)=""
; Store where test was performed except for UI (LA7INTYP=1) interfaces.
I LA7INTYP'=1 S (LA74,LA7PRODID)=$$RESFID^LA7VHLU2(OBX15,LA7SFAC,LA7CS)
;
; Responsible Observer
S LA7RO=$$XCNTFM^LA7VHLU9($$FIELD^LA7VHLU7(16),LA7ECH)
S LA7SUBFL=""
;
; Process MI or AP subscripts
I $G(LA7SS)'="" D
. I LA7SS="MI" D Q
. . D PROCESS^LA7VIN71
. . S LA7SUBFL=63.05
. I LA7SS?1(1"SP",1"CY",1"EM") D Q
. . D PROCESS^LA7VIN6
. . S LA7SUBFL=$S(LA7SS="SP":63.08,LA7SS="CY":63.09,LA7SS="EM":63.02,1:"")
;
; Set flags for alerts and bulletins
I LA7INTYP=10,LA7MTYP="ORU",OBX11'="" D ;
. I "CDW"'[OBX11 D Q
. . ; flag for new results alert
. . S ^TMP("LA7-ORU",$J,LA76248,LA76249,LA7SS)=""
. ;
. Q:'LA7SUBFL
. ; Set flag to send amended results bulletin
. N DATA,X,X2,Y,LA7I
. S LA7I=$O(^TMP("LA7 AMENDED RESULTS",$J,""),-1)
. S LA7I=LA7I+1
. S DATA=LA7LWL_"^"_LA7ISQN_"^"_LA7SUBFL_"^"_LA76248_"^"_LA76249_"^"_$TR(OBX11,"^","?")
. S X2=""
. I LA7RNLT'="" S X2=LA7RNLT_"^"_LA7RNLT(1)
. I LA7RLNC'="" S X2=LA7RLNC_"^"_LA7RLNC(1)
. ; If no NLT or LOINC use 1st codeset of OBX3
. I X2="" D ;
. . S Y=OBX3
. . D FLD2ARR^LA7VHLU7(.OBX3,LA7FS_LA7ECH)
. . S X2=$$UNESC^LA7VHLU3($G(OBX3(1)),LA7FS_LA7ECH)
. . S X2=X2_"^"_$$UNESC^LA7VHLU3($G(OBX3(2)),LA7FS_LA7ECH)
. . K OBX3 S OBX3=Y
. S DATA=DATA_"^"_X2_"^"_$TR(OBX8,"^","?")
. ; only register amended if not already registered
. I LA7UID'="" I '$D(^LAH("LA7 AMENDED RESULTS",LA7UID,LA7SUBFL,LA7LWL,LA7ISQN)) D ;
. . S ^TMP("LA7 AMENDED RESULTS",$J,LA7I)=DATA
. ;
. I LA7UID'="" S ^LAH("LA7 AMENDED RESULTS",LA7UID,LA7SUBFL,LA7LWL,LA7ISQN)=DATA
;
Q
;
;
DATAOK(FILE,FLD,VAL) ;
; Checks if a value is appropriate for storing in the field
; Inputs
; FILE : File #
; FLD : Field #
; VAL : Value of the field
;
; Returns 0 (invalid) or 1 (valid)
;
N LRNOECHO,MSG,OUT,STATUS
;
; LRNOECHO used to suppress echo when input transform calls COM^LRNUM
S STATUS=0,LRNOECHO=1
D CHK^DIE(FILE,FLD,"",VAL,.OUT,"MSG")
I $G(OUT)'="^" S STATUS=1
I $D(MSG) S STATUS=0
;
Q STATUS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VIN7 9529 printed Apr 09, 2024@20:44:03 Page 2
LA7VIN7 ;DALOI/JDB - HANDLE ORU OBX FOR MICRO/AP ;12/20/16 11:20
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74,90**;Sep 27, 1994;Build 17
+2 ;
+3 ; Continuation of LA7VIN1 and is only called from there.
+4 ; Process OBX segments for "MI" subscript tests.
+5 QUIT
+6 ;
+7 ;
OBX ;
+1 ;
+2 NEW ALTCONC,CODSYS,DATA,DIERR,DSOBX3,DSOBX5,ISCOMP,OBX3,OBX4,OBX5,OBX6,OBX8,OBX11,OBX15
+3 NEW LA76247,LA7612,LA74,LA7RLNC,LA7RNLT,LA7SCT,LA7SUBFL,LA7VTYP,LAX,LAY
+4 ;
+5 ; Note: LA7OBR25 holds the OBR's report status (OBR-25)
+6 KILL LA7RMK,^TMP("LA7TREE",$JOB)
+7 ;
+8 ; OBX Set ID
+9 SET LA7SOBX=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
+10 ;
+11 ; Value type - type of data from Table 0125
+12 SET LA7VTYP=$PIECE($$P^LA7VHLU(.LA7SEG,3,LA7FS),LA7CS)
+13 ;
+14 SET OBX3=$$FIELD^LA7VHLU7(3)
+15 DO FLD2ARR^LA7VHLU7(.OBX3)
+16 IF $DATA(OBX3)>1
SET ISCOMP("OBX3")=1
+17 ; step through code tuplets until we find one we can process
+18 SET DSOBX3=$$DBSTORE^LA7VHLU7(.OBX3,1,,,LA76248,.DATA)
+19 ; check for LN and/or 99VA64 code systems
+20 KILL CODSYS
DO CODSYS^LA7VHLU7(.OBX3,.CODSYS)
+21 ; Result's LOINC code
+22 SET LAX=+$ORDER(CODSYS("B","LN",0))
+23 SET LA7RLNC=""
+24 IF LAX
SET LA7RLNC=OBX3(LAX-2)
SET LA7RLNC(1)=OBX3(LAX-1)
+25 ; Result's NLT code
+26 SET LAX=+$ORDER(CODSYS("B","99VA64",0))
+27 SET LA7RNLT=""
+28 IF LAX
SET LA7RNLT=OBX3(LAX-2)
SET LA7RNLT(1)=OBX3(LAX-1)
+29 KILL CODSYS
+30 ;
+31 ; OBX3 cannot be mapped. Stop processing.
+32 ; No File #62.47 mapping found for OBX-3
+33 ;
IF +DSOBX3'>0
Begin DoDot:1
+34 NEW LA7OBX3
+35 ;needed for log
SET LA7OBX3=OBX3
+36 SET LA7OBX3=$$UNESC^LA7VHLU3(LA7OBX3,LA7FS_LA7ECH)
+37 DO CREATE^LA7LOG(200)
+38 SET LA7KILAH=1
SET LA7QUIT=2
End DoDot:1
QUIT
+39 ;
+40 SET LA76247=$PIECE(DSOBX3,"^",1)
+41 ;
+42 ;
+43 SET OBX4=$$FIELD^LA7VHLU7(4)
+44 SET OBX5=$$FIELD^LA7VHLU7(5)
+45 IF OBX5=""
DO CREATE^LA7LOG(17)
QUIT
+46 ;
+47 SET (DSOBX5,LA7SCT)=""
SET LA7612=0
+48 ;
+49 ; String Data/ Formatted Text/ Text Data
+50 ;I LA7VTYP?1(1"FT",1"ST",1"TX") D
+51 ;I LA7VTYP="FT" D
+52 ;. K LAX
+53 ;. D PA^LA7VHLU(.LA7SEG,6,LA7FS,.LAX)
+54 ;. D UNESCFT^LA7VHLU3(.LAX,LA7FS_LA7ECH,.LA7WP)
+55 ;
+56 IF LA7VTYP?1(1"CE",1"CM",1"CNE",1"CWE")
Begin DoDot:1
+57 DO FLD2ARR^LA7VHLU7(.OBX5)
+58 IF $DATA(OBX5)>1
SET ISCOMP("OBX5")=1
+59 ; step through code tuplets until we find one we can process
+60 KILL DATA
+61 SET DSOBX5=$$DBSTORE^LA7VHLU7(.OBX5,2,1,+LA76247,+$GET(LA76248),.DATA)
+62 KILL CODSYS
+63 DO CODSYS^LA7VHLU7(.OBX5,.CODSYS)
+64 ; No Coding System found is an error
+65 ; Prevent new File #61.2 entries created from bad OBX-5
+66 ;
IF $ORDER(CODSYS("B",0))=""
Begin DoDot:2
+67 NEW LA7VOBX5
+68 SET LA7VOBX5=OBX5
+69 SET LA7VOBX5=$$UNESC^LA7VHLU3(LA7VOBX5,LA7FS_LA7ECH)
+70 DO CREATE^LA7LOG(203)
+71 SET LA7KILAH=1
SET LA7QUIT=2
End DoDot:2
QUIT
+72 ;
+73 ; get SCT code if present
+74 SET LAX=$ORDER(CODSYS("B","SCT",0))
IF LAX
SET LA7SCT=$GET(OBX5(LAX-2))
+75 ;
End DoDot:1
+76 ;
+77 if $GET(LA7QUIT)
QUIT
+78 ;
+79 ; Need to check data storage type of DSOBX3 and compare to data in OBX-5.
+80 ; If OBX5 is a CE but DSOBX3 shows text (data type mismatch)
+81 ; then check if there's an ALTERNATIVE CONCEPT for LA76247
+82 SET ALTCONC=$$ALCONCPT^LA7VHLU6(LA76247)
+83 ;
IF ALTCONC>0
IF ALTCONC'=LA76247
Begin DoDot:1
+84 NEW R64061,SS,TLC,X,FILE,FLD,LAOUT,LAMSG,LADT1,LADT2
+85 NEW DATAOK,X
+86 SET DATAOK=0
+87 SET FILE=$PIECE(DSOBX3,"^",3)
+88 SET FLD=$PIECE(DSOBX3,"^",4)
+89 ; data type of current storage location
+90 SET LADT1=$$GET1^DID(FILE,FLD,"","TYPE","LAOUT","LAMSG")
+91 IF LADT1["POINTER"
IF LA7VTYP?1(1"CE",1"CM",1"CNE",1"CWE")
QUIT
+92 SET DATAOK=0
+93 ;
IF LADT1="SET"
Begin DoDot:2
+94 ; 7,21 can be reported as CE/SCT which get translated to SET
+95 IF "^7^21^"[("^"_LA76247_"^")
SET DATAOK=1
QUIT
+96 SET DATAOK=$$DATAOK(FILE,FLD,OBX5)
End DoDot:2
if DATAOK
QUIT
+97 ;
+98 IF LADT1'="SET"
IF LADT1'["POINTER"
IF LA7VTYP'?1(1"CE",1"CM",1"CNE",1"CWE")
QUIT
+99 if DATAOK
QUIT
+100 ; get alternate concept data
+101 SET X=$GET(^LAB(62.47,ALTCONC,0))
+102 SET R64061=$PIECE(X,U,3)
+103 SET SS=$PIECE(X,U,2)
+104 SET X=$GET(^LAB(64.061,R64061,63))
+105 SET FILE=$PIECE(X,U,2)
+106 SET FLD=$PIECE(X,U,3)
+107 IF 'FILE
IF 'FLD
QUIT
+108 ;SCT Top Level
SET TLC=$PIECE(X,U,4)
+109 SET LADT2=$$GET1^DID(FILE,FLD,"","TYPE","LAOUT","LAMSG")
+110 IF LADT1=LADT2
QUIT
+111 IF LA7VTYP?1(1"CE",1"CM",1"CNE",1"CWE")
Begin DoDot:2
+112 IF LADT1["POINTER"
QUIT
+113 SET DSOBX3(1)=DSOBX3
+114 SET DSOBX3=ALTCONC_"^"_SS_"^"_FILE_"^"_FLD_"^"_TLC
End DoDot:2
+115 IF LA7VTYP'?1(1"CE",1"CM",1"CNE",1"CWE")
Begin DoDot:2
+116 IF LADT1'["POINTER"
QUIT
+117 SET DSOBX3(1)=DSOBX3
+118 SET DSOBX3=ALTCONC_"^"_SS_"^"_FILE_"^"_FLD_"^"_TLC
End DoDot:2
+119 ;
End DoDot:1
+120 ;
+121 ;
+122 IF LA7VTYP?1(1"CE",1"CM",1"CNE",1"CWE")
Begin DoDot:1
+123 ; Do only if Concept (#62.47) is not a susceptibility concept (susc reported as SCT code)
+124 ; Create new file entry if needed
+125 IF LA76247'=7
IF LA76247'=21
IF LA7SS="MI"
IF (+DSOBX5<-1!(+DSOBX5=0))
Begin DoDot:2
+126 ; Stage Result may be reported as SCT code
+127 IF LA76247=13
IF LA7SCT'=""
SET X=$$SCT2PSTG^LA7VHLU6(LA7SCT,,"SCT")
if X'=""
QUIT
+128 ; add entry (add local code to #62.47 if needed?)
+129 ; If SCT was passed use that one, else use primary component
+130 NEW FILE,TXT,FLD,MSG
+131 SET FILE=$PIECE(DSOBX3,"^",3)
+132 SET FLD=$PIECE(DSOBX3,"^",4)
+133 SET X=$$GET1^DID(FILE,FLD,"","TYPE","","MSG")
+134 IF X'="POINTER"
SET FILE=""
+135 IF X="POINTER"
SET FILE=$$GET1^DID(FILE,FLD,"","POINTER","","MSG")
+136 ;
IF FILE'=""
Begin DoDot:3
+137 ; no API to convert global root [ie LAHM(62.48)] to file #
+138 SET FILE="^"_FILE
+139 SET FILE=$$TRIM^XLFSTR(FILE,"R",",")
+140 ;^XX( or ^XX(nn
IF $PIECE(FILE,"(",2)'=""
SET FILE=FILE_","
+141 SET FILE=FILE_"0)"
+142 IF FILE'=""
SET FILE=$GET(@FILE)
+143 SET FILE=+$PIECE(FILE,U,2)
End DoDot:3
+144 ;
+145 NEW LAHLSEGS,LA74,SCTINOBX
+146 SET SCTINOBX=0
+147 ;S TXT=OBX5(2)
+148 ;
IF LA7SCT'=""
Begin DoDot:3
+149 SET LAX=$ORDER(CODSYS("B","SCT",0))
+150 IF LAX
SET SCTINOBX=LAX
+151 ;S TXT=OBX5(LAX-1)
End DoDot:3
+152 ;S TXT=$$UNESC^LA7VHLU3(TXT,LA7FS_LA7ECH)
+153 SET LA74=$$LKUP^XUAF4(LA7SFAC)
+154 SET LAHLSEGS("R4")=LA74
+155 SET LAHLSEGS("R6247")=$GET(LA76247)
+156 SET LAHLSEGS("FSEC")=LA7FS_LA7ECH
+157 SET LAHLSEGS("MSH",3)=LA7SAP
+158 SET LAHLSEGS("MSH",4)=LA7SFAC
+159 SET LAHLSEGS("MSH",5)=LA7RAP
+160 SET LAHLSEGS("MSH",6)=LA7RFAC
+161 SET LAHLSEGS("MSH",11)=$GET(LA7MID)
+162 SET LAHLSEGS("OBX",3)=OBX3
+163 SET LAHLSEGS("OBX",5)=OBX5
+164 ; ? Should we try SCT first no matter which codeset it is?
+165 ; try primary codeset first
+166 SET TXT=$GET(OBX5(2))
+167 SET TXT=$$UNESC^LA7VHLU3(TXT,LA7FS_LA7ECH)
+168 ;SCT in 1st component?
SET X=$SELECT(SCTINOBX=3:LA7SCT,1:"")
+169 SET X=$$EN^LRSCTX(FILE,TXT,X,.LAHLSEGS,,1)
+170 ; try secondary codeset
+171 ;
IF X'>0
Begin DoDot:3
+172 SET TXT=$GET(OBX5(5))
+173 SET TXT=$$UNESC^LA7VHLU3(TXT,LA7FS_LA7ECH)
+174 IF TXT=""
SET X=0
QUIT
+175 ;SCT in 2nd component?
SET X=$SELECT(SCTINOBX=6:LA7SCT,1:"")
+176 SET X=$$EN^LRSCTX(FILE,TXT,X,.LAHLSEGS,,1)
End DoDot:3
+177 ; no matches so add new entry using codeset 1
+178 ; if LEDI interface (10) and no matches then add new entry and codeset 1
+179 ;
IF LA7INTYP=10
IF X'>0
Begin DoDot:3
+180 SET TXT=$GET(OBX5(2))
+181 SET TXT=$$UNESC^LA7VHLU3(TXT,LA7FS_LA7ECH)
+182 SET X=$SELECT(SCTINOBX=3:LA7SCT,1:"")
+183 SET X=$$EN^LRSCTX(FILE,TXT,X,.LAHLSEGS)
End DoDot:3
+184 ; create error log: Could not create new entry in file
IF X'>0
Begin DoDot:3
+185 NEW LA7STR,LRFILE,LRINFO
+186 SET LA7STR("^")="~U~"
SET LRFILE=FILE
SET LRINFO="for OBX sequence "_LA7SOBX_" OBX(5) data: "_$$REPLACE^XLFSTR(OBX5,.LA7STR)
+187 DO CREATE^LA7LOG(206)
+188 SET LA7KILAH=1
SET LA7QUIT=2
+189 ;
End DoDot:3
QUIT
+190 IF FILE=61.2
SET LA7612=+X
+191 KILL DATA,LAHLSEGS
+192 SET DSOBX5=$$DBSTORE^LA7VHLU7(.OBX5,2,1,+LA76247,+$GET(LA76248),.DATA)
+193 KILL DATA
End DoDot:2
+194 ;delete OBX5 array but keep OBX5
SET LAX=OBX5
KILL OBX5
SET OBX5=LAX
+195 KILL CODSYS
End DoDot:1
+196 ;
+197 if $GET(LA7QUIT)
QUIT
+198 ;
+199 ;
+200 SET OBX6=$$FIELD^LA7VHLU7(6)
+201 SET OBX8=$$FIELD^LA7VHLU7(8)
+202 ;
+203 ; Observation result status - Table 0085
+204 SET OBX11=$$FIELD^LA7VHLU7(11)
+205 ;
+206 ; Producer's ID
+207 SET OBX15=$$FIELD^LA7VHLU7(15)
+208 SET (LA74,LA7PRODID)=""
+209 ; Store where test was performed except for UI (LA7INTYP=1) interfaces.
+210 IF LA7INTYP'=1
SET (LA74,LA7PRODID)=$$RESFID^LA7VHLU2(OBX15,LA7SFAC,LA7CS)
+211 ;
+212 ; Responsible Observer
+213 SET LA7RO=$$XCNTFM^LA7VHLU9($$FIELD^LA7VHLU7(16),LA7ECH)
+214 SET LA7SUBFL=""
+215 ;
+216 ; Process MI or AP subscripts
+217 IF $GET(LA7SS)'=""
Begin DoDot:1
+218 IF LA7SS="MI"
Begin DoDot:2
+219 DO PROCESS^LA7VIN71
+220 SET LA7SUBFL=63.05
End DoDot:2
QUIT
+221 IF LA7SS?1(1"SP",1"CY",1"EM")
Begin DoDot:2
+222 DO PROCESS^LA7VIN6
+223 SET LA7SUBFL=$SELECT(LA7SS="SP":63.08,LA7SS="CY":63.09,LA7SS="EM":63.02,1:"")
End DoDot:2
QUIT
End DoDot:1
+224 ;
+225 ; Set flags for alerts and bulletins
+226 ;
IF LA7INTYP=10
IF LA7MTYP="ORU"
IF OBX11'=""
Begin DoDot:1
+227 IF "CDW"'[OBX11
Begin DoDot:2
+228 ; flag for new results alert
+229 SET ^TMP("LA7-ORU",$JOB,LA76248,LA76249,LA7SS)=""
End DoDot:2
QUIT
+230 ;
+231 if 'LA7SUBFL
QUIT
+232 ; Set flag to send amended results bulletin
+233 NEW DATA,X,X2,Y,LA7I
+234 SET LA7I=$ORDER(^TMP("LA7 AMENDED RESULTS",$JOB,""),-1)
+235 SET LA7I=LA7I+1
+236 SET DATA=LA7LWL_"^"_LA7ISQN_"^"_LA7SUBFL_"^"_LA76248_"^"_LA76249_"^"_$TRANSLATE(OBX11,"^","?")
+237 SET X2=""
+238 IF LA7RNLT'=""
SET X2=LA7RNLT_"^"_LA7RNLT(1)
+239 IF LA7RLNC'=""
SET X2=LA7RLNC_"^"_LA7RLNC(1)
+240 ; If no NLT or LOINC use 1st codeset of OBX3
+241 ;
IF X2=""
Begin DoDot:2
+242 SET Y=OBX3
+243 DO FLD2ARR^LA7VHLU7(.OBX3,LA7FS_LA7ECH)
+244 SET X2=$$UNESC^LA7VHLU3($GET(OBX3(1)),LA7FS_LA7ECH)
+245 SET X2=X2_"^"_$$UNESC^LA7VHLU3($GET(OBX3(2)),LA7FS_LA7ECH)
+246 KILL OBX3
SET OBX3=Y
End DoDot:2
+247 SET DATA=DATA_"^"_X2_"^"_$TRANSLATE(OBX8,"^","?")
+248 ; only register amended if not already registered
+249 ;
IF LA7UID'=""
IF '$DATA(^LAH("LA7 AMENDED RESULTS",LA7UID,LA7SUBFL,LA7LWL,LA7ISQN))
Begin DoDot:2
+250 SET ^TMP("LA7 AMENDED RESULTS",$JOB,LA7I)=DATA
End DoDot:2
+251 ;
+252 IF LA7UID'=""
SET ^LAH("LA7 AMENDED RESULTS",LA7UID,LA7SUBFL,LA7LWL,LA7ISQN)=DATA
End DoDot:1
+253 ;
+254 QUIT
+255 ;
+256 ;
DATAOK(FILE,FLD,VAL) ;
+1 ; Checks if a value is appropriate for storing in the field
+2 ; Inputs
+3 ; FILE : File #
+4 ; FLD : Field #
+5 ; VAL : Value of the field
+6 ;
+7 ; Returns 0 (invalid) or 1 (valid)
+8 ;
+9 NEW LRNOECHO,MSG,OUT,STATUS
+10 ;
+11 ; LRNOECHO used to suppress echo when input transform calls COM^LRNUM
+12 SET STATUS=0
SET LRNOECHO=1
+13 DO CHK^DIE(FILE,FLD,"",VAL,.OUT,"MSG")
+14 IF $GET(OUT)'="^"
SET STATUS=1
+15 IF $DATA(MSG)
SET STATUS=0
+16 ;
+17 QUIT STATUS
