BLRLDFIS.m

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