BLRLDFIS ; IHS/MSC/MKK - Add data to "IHS" Lab Data file ; 22-Oct-2013 09:22 ; MKK
;;5.2;IHS LABORATORY;**1033,1034**;NOV 01, 1997;Build 88
;
EEP ; Ersatz EP
D EEP^BLRGMENU
Q
;
EP ; EP
PEP ; EP
NEW (APCDALVR,BLRLOGDA,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,REFLABF,U,XPARSYS,XQXFLG)
;
Q:$$INITVARS()<1
;
D STORDATA
Q
;
INITVARS() ; EP - Initialization of variables
S (ICD,LOCDN,LOINC,NOTE,RESULTDT,SNOMED)=""
;
Q:+$G(APCDALVR("APCDTRES"))<1 0 ; If no RESULT data, skip
;
S LRAS=$$GET1^DIQ(9009022,BLRLOGDA,"ACCESSION NUMBER")
Q:$L(LRAS)<1 0 ; If no Accession number, skip
;
S X=$$GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
Q:X<1 0 ; If cannot "break apart" accession number, skip
;
S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),UID=$G(^(.3)),LRIDT=+$P($G(^(3)),"^",5)
Q:LRDFN<1!(LRIDT<1) 0 ; If no Lab Data file pointers, skip
;
S RESULTDT=+$$GET1^DIQ(9009022,BLRLOGDA,"ENTRY DATE/TIME","I")
Q:RESULTDT<1 0 ; If no date, skip
;
S F60IEN=+$$GET1^DIQ(9009022,BLRLOGDA,"PANEL/TEST POINTER","I")
Q:F60IEN<1 0 ; If no Test, skip
;
S LOCDN=+$P($$GET1^DIQ(60,F60IEN,"LOCATION (DATA NAME)"),";",2)
Q:LOCDN<1 0 ; If no DataName, skip
;
S LOINC=$TR($G(APCDALVR("APCDTLNC")),"`")
S ICD=$TR($G(APCDALVR("APCDTLPV")),"`")
S:$L(ICD)&(+ICD<1) ICD="" ; If ICD not a number, set to null
;
D:REFLABF ICOMDATA
;
Q 1
;
ICOMDATA ; EP - Retreive necessary data from the Incoming HL7 message in the UNIVERSAL INTERFACE (#4001) file.
; Note that BLRLINKU routine stores the data in the ^TMP global when called earlier in the BLRLINK3 routine,
; which means no need to re-examine 4001.
S STR=$G(^TMP("BLR",$J,UID,F60IEN))
S RESULTDT=$P(STR,"^",6)
S LOINC=$P(STR,"^",7)
Q
;
STORDATA ; EP - Store the Data
K FDA S FDA(90479.5,"?+1,",.01)=LRDFN
K ERRS D UPDATE^DIE("S","FDA",,"ERRS")
Q:$$CHKERRS("ERRS","Error Adding LRDFN")
;
S IEN0=+$$FIND1^DIC(90479.5,,,LRDFN)
I IEN0<1 D NOTFOUND("LRDFN "_LRDFN) Q
;
K FDA
S FDA(90479.51,"?+1,"_IEN0_",",.01)=LRIDT
S FDA(90479.51,"?+1,"_IEN0_",",1)=LRAS
S FDA(90479.51,"?+1,"_IEN0_",",2)=UID
;
K ERRS D UPDATE^DIE("S","FDA",,"ERRS")
Q:$$CHKERRS("ERRS","LRIDT, LRAS, & UID")
;
S IEN1=+$$FIND1^DIC(90479.51,","_IEN0_",",,LRIDT)
I IEN1<1 D NOTFOUND("LRIDT "_LRIDT) Q
;
K FDA
S FDA(90479.513,"?+1,"_IEN1_","_IEN0_",",.01)=LOCDN
;
K ERRS D UPDATE^DIE("S","FDA",,"ERRS")
Q:$$CHKERRS("ERRS","LOCATION (DATA NAME)")
;
S IEN2=+$$FIND1^DIC(90479.513,","_IEN1_","_IEN0_",",,LOCDN)
I IEN1<1 D NOTFOUND("LOCATION (DATA NAME) "_LOCDN) Q
;
K FDA
S FDA(90479.5131,"?+1,"_IEN2_","_IEN1_","_IEN0_",",.01)=RESULTDT
S:$L($G(LOINC)) FDA(90479.5131,"?+1,"_IEN2_","_IEN1_","_IEN0_",",1)=LOINC
S:$L($G(ICD)) FDA(90479.5131,"?+1,"_IEN2_","_IEN1_","_IEN0_",",2)=ICD
S:$L($G(SNOMED)) FDA(90479.5131,"?+1,"_IEN2_","_IEN1_","_IEN0_",",3)=SNOMED
;
K ERRS D UPDATE^DIE("S","FDA",,"ERRS")
Q:$$CHKERRS("ERRS","RESULT DATE")
;
D OTHRSEGS(IEN0,IEN1,IEN2)
Q
;
OTHRSEGS(IEN0,IEN1,IEN2) ; EP - Store Other Data
Q
;
CHKERRS(ERRS,SUBJECT) ; EP - If ERRS array is empty, just return zero, otherwise send MailMan message and return 1
Q:$D(ERRS)<1 0
;
NEW LN,MSGARRAY,STR1
;
S MSGARRAY(1)="BLRLDFIS Routine ERROR"
S $E(MSGARRAY(2),5)="Accession:"_LRAS
S $E(MSGARRAY(3),5)="UID:"_UID
S LN=3
;
; "Dump" ERRS array into the MailMan Message array
S STR1=$Q(@ERRS@(""))
S $E(MSGARRAY(4),10)=@STR1
S LN=4
F S STR1=$Q(@STR1) Q:STR1="" D
. S LN=LN+1
. S $E(MSGARRAY(LN),10)=@STR1
;
S SUBJECT="Error Adding "_SUBJECT_" to 90475.7"
D MAILALMI^BLRUTIL3(SUBJECT,.MSGARRAY,"BLRLDFIS")
;
Q 1
;
NOTFOUND(SUBJECT) ; EP - If could not retrieve IEN, send Message
NEW LN,MSGARRAY,STR1
;
S MSGARRAY(1)="BLRLDFIS Routine ERROR"
S $E(MSGARRAY(2),5)="Accession:"_LRAS
S $E(MSGARRAY(3),5)="UID:"_UID
;
S SUBJECT="Error Finding "_SUBJECT_" in 90475.7 File"
D MAILALMI^BLRUTIL3(SUBJECT,.MSGARRAY,"BLRLDFIS")
Q
;
TESTSTOR ; EP - Test the STORDATA routine
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D ^LRWU4
;
I $D(^LRO(68,LRAA,1,LRAD,1,LRAN))<1 D Q
. W !!,?4,"Invalid Accession. Routine Ends.",!
;
S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),LRAS=$G(^(.2)),UID=+$G(^(.3)),LRIDT=+$P($G(^(3)),"^",5)
S FIRST=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)),DATALN=+$G(^LAB(60,FIRST,.2)),LOINC=$G(^LAB(60,FIRST,1,70,95.3))
S RESULTDT=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,FIRST,0)),"^",5)
S:RESULTDT<1 RESULTDT=$$NOW^XLFDT
S (ICD,SNOMED)=""
;
D STORDATA
Q
;
RETDATA(UID) ; EP - Given UID, retrieve all the informatoin that's available in ^BLRMULDA global
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,UID,XPARSYS,XQXFLG)
;
Q
;
CHEK69 ; EP
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S HEADER(1)="Laboratory Order File"
; S HEADER(2)="Orders with SIGN OR SYMPTOM Data"
S HEADER(2)="Orders with Clinical Indication Data" ; IHS/MSC/MKK - LR*5.2*1034
S HEADER(3)=" "
S $E(HEADER(4),5)="LRODT"
S $E(HEADER(4),15)="LRSPN"
S $E(HEADER(4),25)="LROT"
S $E(HEADER(4),35)="SIGNSYMP"
S $E(HEADER(4),45)="INDICATION CODE"
;
D HEADERDT^BLRGMENU
;
S (CNT,LRODT)=0
F S LRODT=$O(^LRO(69,LRODT)) Q:LRODT<1 D
. S LRSPN=0
. F S LRSPN=$O(^LRO(69,LRODT,1,LRSPN)) Q:LRSPN<1 D
.. S LROT=0
.. F S LROT=$O(^LRO(69,LRODT,1,LRSPN,2,LROT)) Q:LROT<1 D
... S STR=$G(^LRO(69,LRODT,1,LRSPN,2,LROT,9999999))
... Q:$L(STR)<1
... ;
... W ?4,LRODT,?14,LRSPN,?24,LROT,?34,$P(STR,"^"),?44,$P(STR,"^",2),!
... S CNT=CNT+1
;
Q
BLRLDFIS ; IHS/MSC/MKK - Add data to "IHS" Lab Data file ; 22-Oct-2013 09:22 ; MKK
+1 ;;5.2;IHS LABORATORY;**1033,1034**;NOV 01, 1997;Build 88
+2 ;
EEP ; Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
EP ; EP
PEP ; EP
+1 NEW (APCDALVR,BLRLOGDA,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,REFLABF,U,XPARSYS,XQXFLG)
+2 ;
+3 IF $$INITVARS()<1
QUIT
+4 ;
+5 DO STORDATA
+6 QUIT
+7 ;
INITVARS() ; EP - Initialization of variables
+1 SET (ICD,LOCDN,LOINC,NOTE,RESULTDT,SNOMED)=""
+2 ;
+3 ; If no RESULT data, skip
IF +$GET(APCDALVR("APCDTRES"))<1
QUIT 0
+4 ;
+5 SET LRAS=$$GET1^DIQ(9009022,BLRLOGDA,"ACCESSION NUMBER")
+6 ; If no Accession number, skip
IF $LENGTH(LRAS)<1
QUIT 0
+7 ;
+8 SET X=$$GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
+9 ; If cannot "break apart" accession number, skip
IF X<1
QUIT 0
+10 ;
+11 SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
SET UID=$GET(^(.3))
SET LRIDT=+$PIECE($GET(^(3)),"^",5)
+12 ; If no Lab Data file pointers, skip
IF LRDFN<1!(LRIDT<1)
QUIT 0
+13 ;
+14 SET RESULTDT=+$$GET1^DIQ(9009022,BLRLOGDA,"ENTRY DATE/TIME","I")
+15 ; If no date, skip
IF RESULTDT<1
QUIT 0
+16 ;
+17 SET F60IEN=+$$GET1^DIQ(9009022,BLRLOGDA,"PANEL/TEST POINTER","I")
+18 ; If no Test, skip
IF F60IEN<1
QUIT 0
+19 ;
+20 SET LOCDN=+$PIECE($$GET1^DIQ(60,F60IEN,"LOCATION (DATA NAME)"),";",2)
+21 ; If no DataName, skip
IF LOCDN<1
QUIT 0
+22 ;
+23 SET LOINC=$TRANSLATE($GET(APCDALVR("APCDTLNC")),"`")
+24 SET ICD=$TRANSLATE($GET(APCDALVR("APCDTLPV")),"`")
+25 ; If ICD not a number, set to null
IF $LENGTH(ICD)&(+ICD<1)
SET ICD=""
+26 ;
+27 IF REFLABF
DO ICOMDATA
+28 ;
+29 QUIT 1
+30 ;
ICOMDATA ; EP - Retreive necessary data from the Incoming HL7 message in the UNIVERSAL INTERFACE (#4001) file.
+1 ; Note that BLRLINKU routine stores the data in the ^TMP global when called earlier in the BLRLINK3 routine,
+2 ; which means no need to re-examine 4001.
+3 SET STR=$GET(^TMP("BLR",$JOB,UID,F60IEN))
+4 SET RESULTDT=$PIECE(STR,"^",6)
+5 SET LOINC=$PIECE(STR,"^",7)
+6 QUIT
+7 ;
STORDATA ; EP - Store the Data
+1 KILL FDA
SET FDA(90479.5,"?+1,",.01)=LRDFN
+2 KILL ERRS
DO UPDATE^DIE("S","FDA",,"ERRS")
+3 IF $$CHKERRS("ERRS","Error Adding LRDFN")
QUIT
+4 ;
+5 SET IEN0=+$$FIND1^DIC(90479.5,,,LRDFN)
+6 IF IEN0<1
DO NOTFOUND("LRDFN "_LRDFN)
QUIT
+7 ;
+8 KILL FDA
+9 SET FDA(90479.51,"?+1,"_IEN0_",",.01)=LRIDT
+10 SET FDA(90479.51,"?+1,"_IEN0_",",1)=LRAS
+11 SET FDA(90479.51,"?+1,"_IEN0_",",2)=UID
+12 ;
+13 KILL ERRS
DO UPDATE^DIE("S","FDA",,"ERRS")
+14 IF $$CHKERRS("ERRS","LRIDT, LRAS, & UID")
QUIT
+15 ;
+16 SET IEN1=+$$FIND1^DIC(90479.51,","_IEN0_",",,LRIDT)
+17 IF IEN1<1
DO NOTFOUND("LRIDT "_LRIDT)
QUIT
+18 ;
+19 KILL FDA
+20 SET FDA(90479.513,"?+1,"_IEN1_","_IEN0_",",.01)=LOCDN
+21 ;
+22 KILL ERRS
DO UPDATE^DIE("S","FDA",,"ERRS")
+23 IF $$CHKERRS("ERRS","LOCATION (DATA NAME)")
QUIT
+24 ;
+25 SET IEN2=+$$FIND1^DIC(90479.513,","_IEN1_","_IEN0_",",,LOCDN)
+26 IF IEN1<1
DO NOTFOUND("LOCATION (DATA NAME) "_LOCDN)
QUIT
+27 ;
+28 KILL FDA
+29 SET FDA(90479.5131,"?+1,"_IEN2_","_IEN1_","_IEN0_",",.01)=RESULTDT
+30 IF $LENGTH($GET(LOINC))
SET FDA(90479.5131,"?+1,"_IEN2_","_IEN1_","_IEN0_",",1)=LOINC
+31 IF $LENGTH($GET(ICD))
SET FDA(90479.5131,"?+1,"_IEN2_","_IEN1_","_IEN0_",",2)=ICD
+32 IF $LENGTH($GET(SNOMED))
SET FDA(90479.5131,"?+1,"_IEN2_","_IEN1_","_IEN0_",",3)=SNOMED
+33 ;
+34 KILL ERRS
DO UPDATE^DIE("S","FDA",,"ERRS")
+35 IF $$CHKERRS("ERRS","RESULT DATE")
QUIT
+36 ;
+37 DO OTHRSEGS(IEN0,IEN1,IEN2)
+38 QUIT
+39 ;
OTHRSEGS(IEN0,IEN1,IEN2) ; EP - Store Other Data
+1 QUIT
+2 ;
CHKERRS(ERRS,SUBJECT) ; EP - If ERRS array is empty, just return zero, otherwise send MailMan message and return 1
+1 IF $DATA(ERRS)<1
QUIT 0
+2 ;
+3 NEW LN,MSGARRAY,STR1
+4 ;
+5 SET MSGARRAY(1)="BLRLDFIS Routine ERROR"
+6 SET $EXTRACT(MSGARRAY(2),5)="Accession:"_LRAS
+7 SET $EXTRACT(MSGARRAY(3),5)="UID:"_UID
+8 SET LN=3
+9 ;
+10 ; "Dump" ERRS array into the MailMan Message array
+11 SET STR1=$QUERY(@ERRS@(""))
+12 SET $EXTRACT(MSGARRAY(4),10)=@STR1
+13 SET LN=4
+14 FOR
SET STR1=$QUERY(@STR1)
IF STR1=""
QUIT
Begin DoDot:1
+15 SET LN=LN+1
+16 SET $EXTRACT(MSGARRAY(LN),10)=@STR1
End DoDot:1
+17 ;
+18 SET SUBJECT="Error Adding "_SUBJECT_" to 90475.7"
+19 DO MAILALMI^BLRUTIL3(SUBJECT,.MSGARRAY,"BLRLDFIS")
+20 ;
+21 QUIT 1
+22 ;
NOTFOUND(SUBJECT) ; EP - If could not retrieve IEN, send Message
+1 NEW LN,MSGARRAY,STR1
+2 ;
+3 SET MSGARRAY(1)="BLRLDFIS Routine ERROR"
+4 SET $EXTRACT(MSGARRAY(2),5)="Accession:"_LRAS
+5 SET $EXTRACT(MSGARRAY(3),5)="UID:"_UID
+6 ;
+7 SET SUBJECT="Error Finding "_SUBJECT_" in 90475.7 File"
+8 DO MAILALMI^BLRUTIL3(SUBJECT,.MSGARRAY,"BLRLDFIS")
+9 QUIT
+10 ;
TESTSTOR ; EP - Test the STORDATA routine
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 DO ^LRWU4
+4 ;
+5 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN))<1
Begin DoDot:1
+6 WRITE !!,?4,"Invalid Accession. Routine Ends.",!
End DoDot:1
QUIT
+7 ;
+8 SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
SET LRAS=$GET(^(.2))
SET UID=+$GET(^(.3))
SET LRIDT=+$PIECE($GET(^(3)),"^",5)
+9 SET FIRST=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
SET DATALN=+$GET(^LAB(60,FIRST,.2))
SET LOINC=$GET(^LAB(60,FIRST,1,70,95.3))
+10 SET RESULTDT=+$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,FIRST,0)),"^",5)
+11 IF RESULTDT<1
SET RESULTDT=$$NOW^XLFDT
+12 SET (ICD,SNOMED)=""
+13 ;
+14 DO STORDATA
+15 QUIT
+16 ;
RETDATA(UID) ; EP - Given UID, retrieve all the informatoin that's available in ^BLRMULDA global
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,UID,XPARSYS,XQXFLG)
+2 ;
+3 QUIT
+4 ;
CHEK69 ; EP
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 SET HEADER(1)="Laboratory Order File"
+4 ; S HEADER(2)="Orders with SIGN OR SYMPTOM Data"
+5 ; IHS/MSC/MKK - LR*5.2*1034
SET HEADER(2)="Orders with Clinical Indication Data"
+6 SET HEADER(3)=" "
+7 SET $EXTRACT(HEADER(4),5)="LRODT"
+8 SET $EXTRACT(HEADER(4),15)="LRSPN"
+9 SET $EXTRACT(HEADER(4),25)="LROT"
+10 SET $EXTRACT(HEADER(4),35)="SIGNSYMP"
+11 SET $EXTRACT(HEADER(4),45)="INDICATION CODE"
+12 ;
+13 DO HEADERDT^BLRGMENU
+14 ;
+15 SET (CNT,LRODT)=0
+16 FOR
SET LRODT=$ORDER(^LRO(69,LRODT))
IF LRODT<1
QUIT
Begin DoDot:1
+17 SET LRSPN=0
+18 FOR
SET LRSPN=$ORDER(^LRO(69,LRODT,1,LRSPN))
IF LRSPN<1
QUIT
Begin DoDot:2
+19 SET LROT=0
+20 FOR
SET LROT=$ORDER(^LRO(69,LRODT,1,LRSPN,2,LROT))
IF LROT<1
QUIT
Begin DoDot:3
+21 SET STR=$GET(^LRO(69,LRODT,1,LRSPN,2,LROT,9999999))
+22 IF $LENGTH(STR)<1
QUIT
+23 ;
+24 WRITE ?4,LRODT,?14,LRSPN,?24,LROT,?34,$PIECE(STR,"^"),?44,$PIECE(STR,"^",2),!
+25 SET CNT=CNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+26 ;
+27 QUIT
