- 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 Feb 18, 2025@23:06:54 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