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

LA7VIN7.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Continuation of LA7VIN1 and is only called from there.
  1. ; Process OBX segments for "MI" subscript tests.
  1. Q
  1. ;
  1. ;
  1. OBX ;
  1. ;
  1. N ALTCONC,CODSYS,DATA,DIERR,DSOBX3,DSOBX5,ISCOMP,OBX3,OBX4,OBX5,OBX6,OBX8,OBX11,OBX15
  1. N LA76247,LA7612,LA74,LA7RLNC,LA7RNLT,LA7SCT,LA7SUBFL,LA7VTYP,LAX,LAY
  1. ;
  1. ; Note: LA7OBR25 holds the OBR's report status (OBR-25)
  1. K LA7RMK,^TMP("LA7TREE",$J)
  1. ;
  1. ; OBX Set ID
  1. S LA7SOBX=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
  1. ;
  1. ; Value type - type of data from Table 0125
  1. S LA7VTYP=$P($$P^LA7VHLU(.LA7SEG,3,LA7FS),LA7CS)
  1. ;
  1. S OBX3=$$FIELD^LA7VHLU7(3)
  1. D FLD2ARR^LA7VHLU7(.OBX3)
  1. I $D(OBX3)>1 S ISCOMP("OBX3")=1
  1. ; step through code tuplets until we find one we can process
  1. S DSOBX3=$$DBSTORE^LA7VHLU7(.OBX3,1,,,LA76248,.DATA)
  1. ; check for LN and/or 99VA64 code systems
  1. K CODSYS D CODSYS^LA7VHLU7(.OBX3,.CODSYS)
  1. ; Result's LOINC code
  1. S LAX=+$O(CODSYS("B","LN",0))
  1. S LA7RLNC=""
  1. I LAX S LA7RLNC=OBX3(LAX-2) S LA7RLNC(1)=OBX3(LAX-1)
  1. ; Result's NLT code
  1. S LAX=+$O(CODSYS("B","99VA64",0))
  1. S LA7RNLT=""
  1. I LAX S LA7RNLT=OBX3(LAX-2) S LA7RNLT(1)=OBX3(LAX-1)
  1. K CODSYS
  1. ;
  1. ; OBX3 cannot be mapped. Stop processing.
  1. ; No File #62.47 mapping found for OBX-3
  1. I +DSOBX3'>0 D Q ;
  1. . N LA7OBX3
  1. . S LA7OBX3=OBX3 ;needed for log
  1. . S LA7OBX3=$$UNESC^LA7VHLU3(LA7OBX3,LA7FS_LA7ECH)
  1. . D CREATE^LA7LOG(200)
  1. . S LA7KILAH=1 S LA7QUIT=2
  1. ;
  1. S LA76247=$P(DSOBX3,"^",1)
  1. ;
  1. ;
  1. S OBX4=$$FIELD^LA7VHLU7(4)
  1. S OBX5=$$FIELD^LA7VHLU7(5)
  1. I OBX5="" D CREATE^LA7LOG(17) Q
  1. ;
  1. S (DSOBX5,LA7SCT)="",LA7612=0
  1. ;
  1. ; String Data/ Formatted Text/ Text Data
  1. ;I LA7VTYP?1(1"FT",1"ST",1"TX") D
  1. ;I LA7VTYP="FT" D
  1. ;. K LAX
  1. ;. D PA^LA7VHLU(.LA7SEG,6,LA7FS,.LAX)
  1. ;. D UNESCFT^LA7VHLU3(.LAX,LA7FS_LA7ECH,.LA7WP)
  1. ;
  1. I LA7VTYP?1(1"CE",1"CM",1"CNE",1"CWE") D
  1. . D FLD2ARR^LA7VHLU7(.OBX5)
  1. . I $D(OBX5)>1 S ISCOMP("OBX5")=1
  1. . ; step through code tuplets until we find one we can process
  1. . K DATA
  1. . S DSOBX5=$$DBSTORE^LA7VHLU7(.OBX5,2,1,+LA76247,+$G(LA76248),.DATA)
  1. . K CODSYS
  1. . D CODSYS^LA7VHLU7(.OBX5,.CODSYS)
  1. . ; No Coding System found is an error
  1. . ; Prevent new File #61.2 entries created from bad OBX-5
  1. . I $O(CODSYS("B",0))="" D Q ;
  1. . . N LA7VOBX5
  1. . . S LA7VOBX5=OBX5
  1. . . S LA7VOBX5=$$UNESC^LA7VHLU3(LA7VOBX5,LA7FS_LA7ECH)
  1. . . D CREATE^LA7LOG(203)
  1. . . S LA7KILAH=1 S LA7QUIT=2
  1. . ;
  1. . ; get SCT code if present
  1. . S LAX=$O(CODSYS("B","SCT",0)) I LAX S LA7SCT=$G(OBX5(LAX-2))
  1. . ;
  1. ;
  1. Q:$G(LA7QUIT)
  1. ;
  1. ; Need to check data storage type of DSOBX3 and compare to data in OBX-5.
  1. ; If OBX5 is a CE but DSOBX3 shows text (data type mismatch)
  1. ; then check if there's an ALTERNATIVE CONCEPT for LA76247
  1. S ALTCONC=$$ALCONCPT^LA7VHLU6(LA76247)
  1. I ALTCONC>0 I ALTCONC'=LA76247 D ;
  1. . N R64061,SS,TLC,X,FILE,FLD,LAOUT,LAMSG,LADT1,LADT2
  1. . N DATAOK,X
  1. . S DATAOK=0
  1. . S FILE=$P(DSOBX3,"^",3)
  1. . S FLD=$P(DSOBX3,"^",4)
  1. . ; data type of current storage location
  1. . S LADT1=$$GET1^DID(FILE,FLD,"","TYPE","LAOUT","LAMSG")
  1. . I LADT1["POINTER",LA7VTYP?1(1"CE",1"CM",1"CNE",1"CWE") Q
  1. . S DATAOK=0
  1. . I LADT1="SET" D Q:DATAOK ;
  1. . . ; 7,21 can be reported as CE/SCT which get translated to SET
  1. . . I "^7^21^"[("^"_LA76247_"^") S DATAOK=1 Q
  1. . . S DATAOK=$$DATAOK(FILE,FLD,OBX5)
  1. . ;
  1. . I LADT1'="SET",LADT1'["POINTER",LA7VTYP'?1(1"CE",1"CM",1"CNE",1"CWE") Q
  1. . Q:DATAOK
  1. . ; get alternate concept data
  1. . S X=$G(^LAB(62.47,ALTCONC,0))
  1. . S R64061=$P(X,U,3)
  1. . S SS=$P(X,U,2)
  1. . S X=$G(^LAB(64.061,R64061,63))
  1. . S FILE=$P(X,U,2)
  1. . S FLD=$P(X,U,3)
  1. . I 'FILE I 'FLD Q
  1. . S TLC=$P(X,U,4) ;SCT Top Level
  1. . S LADT2=$$GET1^DID(FILE,FLD,"","TYPE","LAOUT","LAMSG")
  1. . I LADT1=LADT2 Q
  1. . I LA7VTYP?1(1"CE",1"CM",1"CNE",1"CWE") D
  1. . . I LADT1["POINTER" Q
  1. . . S DSOBX3(1)=DSOBX3
  1. . . S DSOBX3=ALTCONC_"^"_SS_"^"_FILE_"^"_FLD_"^"_TLC
  1. . I LA7VTYP'?1(1"CE",1"CM",1"CNE",1"CWE") D
  1. . . I LADT1'["POINTER" Q
  1. . . S DSOBX3(1)=DSOBX3
  1. . . S DSOBX3=ALTCONC_"^"_SS_"^"_FILE_"^"_FLD_"^"_TLC
  1. . ;
  1. ;
  1. ;
  1. I LA7VTYP?1(1"CE",1"CM",1"CNE",1"CWE") D
  1. . ; Do only if Concept (#62.47) is not a susceptibility concept (susc reported as SCT code)
  1. . ; Create new file entry if needed
  1. . I LA76247'=7,LA76247'=21,LA7SS="MI",(+DSOBX5<-1!(+DSOBX5=0)) D
  1. . . ; Stage Result may be reported as SCT code
  1. . . I LA76247=13 I LA7SCT'="" S X=$$SCT2PSTG^LA7VHLU6(LA7SCT,,"SCT") Q:X'=""
  1. . . ; add entry (add local code to #62.47 if needed?)
  1. . . ; If SCT was passed use that one, else use primary component
  1. . . N FILE,TXT,FLD,MSG
  1. . . S FILE=$P(DSOBX3,"^",3)
  1. . . S FLD=$P(DSOBX3,"^",4)
  1. . . S X=$$GET1^DID(FILE,FLD,"","TYPE","","MSG")
  1. . . I X'="POINTER" S FILE=""
  1. . . I X="POINTER" S FILE=$$GET1^DID(FILE,FLD,"","POINTER","","MSG")
  1. . . I FILE'="" D ;
  1. . . . ; no API to convert global root [ie LAHM(62.48)] to file #
  1. . . . S FILE="^"_FILE
  1. . . . S FILE=$$TRIM^XLFSTR(FILE,"R",",")
  1. . . . I $P(FILE,"(",2)'="" S FILE=FILE_"," ;^XX( or ^XX(nn
  1. . . . S FILE=FILE_"0)"
  1. . . . I FILE'="" S FILE=$G(@FILE)
  1. . . . S FILE=+$P(FILE,U,2)
  1. . . ;
  1. . . N LAHLSEGS,LA74,SCTINOBX
  1. . . S SCTINOBX=0
  1. . . ;S TXT=OBX5(2)
  1. . . I LA7SCT'="" D ;
  1. . . . S LAX=$O(CODSYS("B","SCT",0))
  1. . . . I LAX S SCTINOBX=LAX
  1. . . . ;S TXT=OBX5(LAX-1)
  1. . . ;S TXT=$$UNESC^LA7VHLU3(TXT,LA7FS_LA7ECH)
  1. . . S LA74=$$LKUP^XUAF4(LA7SFAC)
  1. . . S LAHLSEGS("R4")=LA74
  1. . . S LAHLSEGS("R6247")=$G(LA76247)
  1. . . S LAHLSEGS("FSEC")=LA7FS_LA7ECH
  1. . . S LAHLSEGS("MSH",3)=LA7SAP
  1. . . S LAHLSEGS("MSH",4)=LA7SFAC
  1. . . S LAHLSEGS("MSH",5)=LA7RAP
  1. . . S LAHLSEGS("MSH",6)=LA7RFAC
  1. . . S LAHLSEGS("MSH",11)=$G(LA7MID)
  1. . . S LAHLSEGS("OBX",3)=OBX3
  1. . . S LAHLSEGS("OBX",5)=OBX5
  1. . . ; ? Should we try SCT first no matter which codeset it is?
  1. . . ; try primary codeset first
  1. . . S TXT=$G(OBX5(2))
  1. . . S TXT=$$UNESC^LA7VHLU3(TXT,LA7FS_LA7ECH)
  1. . . S X=$S(SCTINOBX=3:LA7SCT,1:"") ;SCT in 1st component?
  1. . . S X=$$EN^LRSCTX(FILE,TXT,X,.LAHLSEGS,,1)
  1. . . ; try secondary codeset
  1. . . I X'>0 D ;
  1. . . . S TXT=$G(OBX5(5))
  1. . . . S TXT=$$UNESC^LA7VHLU3(TXT,LA7FS_LA7ECH)
  1. . . . I TXT="" S X=0 Q
  1. . . . S X=$S(SCTINOBX=6:LA7SCT,1:"") ;SCT in 2nd component?
  1. . . . S X=$$EN^LRSCTX(FILE,TXT,X,.LAHLSEGS,,1)
  1. . . ; no matches so add new entry using codeset 1
  1. . . ; if LEDI interface (10) and no matches then add new entry and codeset 1
  1. . . I LA7INTYP=10,X'>0 D ;
  1. . . . S TXT=$G(OBX5(2))
  1. . . . S TXT=$$UNESC^LA7VHLU3(TXT,LA7FS_LA7ECH)
  1. . . . S X=$S(SCTINOBX=3:LA7SCT,1:"")
  1. . . . S X=$$EN^LRSCTX(FILE,TXT,X,.LAHLSEGS)
  1. . . I X'>0 D Q ; create error log: Could not create new entry in file
  1. . . . N LA7STR,LRFILE,LRINFO
  1. . . . S LA7STR("^")="~U~",LRFILE=FILE,LRINFO="for OBX sequence "_LA7SOBX_" OBX(5) data: "_$$REPLACE^XLFSTR(OBX5,.LA7STR)
  1. . . . D CREATE^LA7LOG(206)
  1. . . . S LA7KILAH=1,LA7QUIT=2
  1. . . . ;
  1. . . I FILE=61.2 S LA7612=+X
  1. . . K DATA,LAHLSEGS
  1. . . S DSOBX5=$$DBSTORE^LA7VHLU7(.OBX5,2,1,+LA76247,+$G(LA76248),.DATA)
  1. . . K DATA
  1. . S LAX=OBX5 K OBX5 S OBX5=LAX ;delete OBX5 array but keep OBX5
  1. . K CODSYS
  1. ;
  1. Q:$G(LA7QUIT)
  1. ;
  1. ;
  1. S OBX6=$$FIELD^LA7VHLU7(6)
  1. S OBX8=$$FIELD^LA7VHLU7(8)
  1. ;
  1. ; Observation result status - Table 0085
  1. S OBX11=$$FIELD^LA7VHLU7(11)
  1. ;
  1. ; Producer's ID
  1. S OBX15=$$FIELD^LA7VHLU7(15)
  1. S (LA74,LA7PRODID)=""
  1. ; Store where test was performed except for UI (LA7INTYP=1) interfaces.
  1. I LA7INTYP'=1 S (LA74,LA7PRODID)=$$RESFID^LA7VHLU2(OBX15,LA7SFAC,LA7CS)
  1. ;
  1. ; Responsible Observer
  1. S LA7RO=$$XCNTFM^LA7VHLU9($$FIELD^LA7VHLU7(16),LA7ECH)
  1. S LA7SUBFL=""
  1. ;
  1. ; Process MI or AP subscripts
  1. I $G(LA7SS)'="" D
  1. . I LA7SS="MI" D Q
  1. . . D PROCESS^LA7VIN71
  1. . . S LA7SUBFL=63.05
  1. . I LA7SS?1(1"SP",1"CY",1"EM") D Q
  1. . . D PROCESS^LA7VIN6
  1. . . S LA7SUBFL=$S(LA7SS="SP":63.08,LA7SS="CY":63.09,LA7SS="EM":63.02,1:"")
  1. ;
  1. ; Set flags for alerts and bulletins
  1. I LA7INTYP=10,LA7MTYP="ORU",OBX11'="" D ;
  1. . I "CDW"'[OBX11 D Q
  1. . . ; flag for new results alert
  1. . . S ^TMP("LA7-ORU",$J,LA76248,LA76249,LA7SS)=""
  1. . ;
  1. . Q:'LA7SUBFL
  1. . ; Set flag to send amended results bulletin
  1. . N DATA,X,X2,Y,LA7I
  1. . S LA7I=$O(^TMP("LA7 AMENDED RESULTS",$J,""),-1)
  1. . S LA7I=LA7I+1
  1. . S DATA=LA7LWL_"^"_LA7ISQN_"^"_LA7SUBFL_"^"_LA76248_"^"_LA76249_"^"_$TR(OBX11,"^","?")
  1. . S X2=""
  1. . I LA7RNLT'="" S X2=LA7RNLT_"^"_LA7RNLT(1)
  1. . I LA7RLNC'="" S X2=LA7RLNC_"^"_LA7RLNC(1)
  1. . ; If no NLT or LOINC use 1st codeset of OBX3
  1. . I X2="" D ;
  1. . . S Y=OBX3
  1. . . D FLD2ARR^LA7VHLU7(.OBX3,LA7FS_LA7ECH)
  1. . . S X2=$$UNESC^LA7VHLU3($G(OBX3(1)),LA7FS_LA7ECH)
  1. . . S X2=X2_"^"_$$UNESC^LA7VHLU3($G(OBX3(2)),LA7FS_LA7ECH)
  1. . . K OBX3 S OBX3=Y
  1. . S DATA=DATA_"^"_X2_"^"_$TR(OBX8,"^","?")
  1. . ; only register amended if not already registered
  1. . I LA7UID'="" I '$D(^LAH("LA7 AMENDED RESULTS",LA7UID,LA7SUBFL,LA7LWL,LA7ISQN)) D ;
  1. . . S ^TMP("LA7 AMENDED RESULTS",$J,LA7I)=DATA
  1. . ;
  1. . I LA7UID'="" S ^LAH("LA7 AMENDED RESULTS",LA7UID,LA7SUBFL,LA7LWL,LA7ISQN)=DATA
  1. ;
  1. Q
  1. ;
  1. ;
  1. DATAOK(FILE,FLD,VAL) ;
  1. ; Checks if a value is appropriate for storing in the field
  1. ; Inputs
  1. ; FILE : File #
  1. ; FLD : Field #
  1. ; VAL : Value of the field
  1. ;
  1. ; Returns 0 (invalid) or 1 (valid)
  1. ;
  1. N LRNOECHO,MSG,OUT,STATUS
  1. ;
  1. ; LRNOECHO used to suppress echo when input transform calls COM^LRNUM
  1. S STATUS=0,LRNOECHO=1
  1. D CHK^DIE(FILE,FLD,"",VAL,.OUT,"MSG")
  1. I $G(OUT)'="^" S STATUS=1
  1. I $D(MSG) S STATUS=0
  1. ;
  1. Q STATUS