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

BLRRLMU4.m

Go to the documentation of this file. 
  1. BLRRLMU4 ; IHS/MSC/MKK - Reference Lab Meaningful use Utilities, Part 4  ; 22-Oct-2013 09:22 ; MKK
  1.  ;;5.2;IHS LABORATORY;**1033**;NOV 1, 1997
  1.  ;
  1. EEP ; Ersatz EP
  1.  D EEP^BLRGMENU
  1.  Q
  1.  ;
  1. PEP ; EP
  1. UNIVMENU ; EP - UNIVERSAL INTERFACE Menu
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S BLRVERN=$TR($P($T(+1),";")," ")
  1.  ;
  1.  D ADDTMENU^BLRGMENU("UNIVERSE^BLRRLMU4","UIDs Report")	
  1.  D ADDTMENU^BLRGMENU("UNIVERUD^BLRRLMU4","Enter UID & Display HL7 Segs")
  1.  ;
  1.  ; Main Menu driver
  1.  D MENUDRVR^BLRGMENU("RPMS Lab MU Stage 2","Miscellaneous Debug Utilities",$$CJ^XLFSTR("Universal Interface (#4001) File Reports",IOM))
  1.  Q
  1.  ;
  1. UNIVERSE ; EP - Universal Interface UIDs Report
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D UNIVERSI
  1.  ;
  1.  F  S MSGNUM=$O(^INTHU("AD",WOTREF,MSGNUM),-1)  Q:MSGNUM<1!(QFLG="Q")  D
  1.  . S DATETIME=$$UP^XLFSTR($$FMTE^XLFDT($$GET1^DIQ(4001,MSGNUM,.01,"I"),"5MPZ"))
  1.  . S DATETIME=$P(DATETIME," ")_$J($P(DATETIME," ",2,3),9)
  1.  . S (MSGSEG,NOTMSG)=0
  1.  . F  S MSGSEG=$O(^INTHU(MSGNUM,3,MSGSEG))  Q:MSGSEG<1!(QFLG="Q")  D
  1.  .. I $P($G(^INTHU(MSGNUM,3,MSGSEG,0)),"|")="OBR" D
  1.  ... S UID=$P($G(^INTHU(MSGNUM,3,MSGSEG,0)),"|",3)
  1.  ... Q:$L(UID)<1
  1.  ... I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,"NO")  Q:QFLG="Q"
  1.  ... ;
  1.  ... W ?4,MSGNUM,?19,DATETIME,?40,MSGSEG,?50,$P(UID,"^"),?65,$P(UID,"^",2),!
  1.  ... S LINES=LINES+1
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. UNIVERSI ; EP - Initialization
  1.  S BLRVERN=$TR($P($T(+1),";")," ")
  1.  S BLVERN2="UNIVERSE"
  1.  ;
  1.  S WOTREF=+$$FIND1^DIC(4005,,,"HL IHS LAB R01 MU IN")
  1.  Q:WOTREF<1 0                                      ; Quit with zero if IEN<1
  1.  ;
  1.  S HEADER(1)="UNIVERSAL INTERFACE"
  1.  S HEADER(2)="Incoming Interface: HL IHS LAB R01 MU IN"
  1.  S HEADER(3)=" "
  1.  S $E(HEADER(4),5)="Message #"
  1.  S $E(HEADER(4),22)="Date"
  1.  S $E(HEADER(4),32)="Time"
  1.  S $E(HEADER(4),41)="Seg #"
  1.  S $E(HEADER(4),51)="UID"
  1.  S $E(HEADER(4),66)="'$P(UID,""^"",2)'"
  1.  ;
  1.  S FOUNDIT=0
  1.  S (CNT,PG)=0
  1.  S QFLG="NO"
  1.  S MAXLINES=20,LINES=MAXLINES+10
  1.  S MSGNUM="AAA"
  1.  Q
  1.  ;
  1. UNIVERUD ; EP - For UNIVERSAL INTERFACE, Enter UID & Display ALL HL7 Segs
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S BLRVERN=$TR($P($T(+1),";")," ")
  1.  ;
  1.  S WOTREF=+$$FIND1^DIC(4005,,,"HL IHS LAB R01 MU IN")
  1.  ;
  1.  I WOTREF<1 D  Q
  1.  . W !,?4,"Could not determine IEN of 'HL IHS LAB R01 MU IN' Interface.  Routine Ends."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  D ^XBFMK
  1.  S DIR(0)="NO"
  1.  S DIR("A")="Enter UID"
  1.  D ^DIR
  1.  I +$G(DIRUT) D  Q
  1.  . W !!,?4,"No/Invalid Entry.  Routine Ends."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  S LRUID=X
  1.  W !!,"LRUID:",LRUID,!,?4,"Searching"
  1.  ;
  1.  S MSGNUM="AAA",FOUNDIT=0
  1.  F  S MSGNUM=$O(^INTHU("AD",WOTREF,MSGNUM),-1)  Q:MSGNUM<1!(FOUNDIT)  D
  1.  . S DATETIME=$$UP^XLFSTR($$FMTE^XLFDT($$GET1^DIQ(4001,MSGNUM,.01,"I"),"5MPZ"))
  1.  . S (MSGSEG,NOTMSG)=0
  1.  . W "."  W:$X>74 !,?4
  1.  . F  S MSGSEG=$O(^INTHU(MSGNUM,3,MSGSEG))  Q:MSGSEG<1!(FOUNDIT)  D
  1.  .. I $P($G(^INTHU(MSGNUM,3,MSGSEG,0)),"|")="OBR" D
  1.  ... S UID=$P($P($G(^INTHU(MSGNUM,3,MSGSEG,0)),"|",3),"^")
  1.  ... S:UID=LRUID FOUNDIT=MSGNUM
  1.  ;
  1.  ;
  1.  W !!
  1.  I FOUNDIT<1 D  Q
  1.  . W ?4,"Could not find UID ",LRUID," in File 4001.  Routine Ends."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  I FOUNDIT W ?4,"Found UID ",LRUID," in File 4001 at MSGNUM:",FOUNDIT
  1.  D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  W !!
  1.  ;
  1.  S MAXLINES=IOSL-4
  1.  S LINES=MAXLINES+10
  1.  S (CNT,PG,UID6249)=0
  1.  S (HDRONE,QFLG)="NO"
  1.  S BLRVERN="BLRRLMU4",BLRVERN2="UNIVERUD"
  1.  S HEADER(1)="UNIVERSAL INTERFACE"
  1.  S HEADER(2)="UID "_LRUID_" HL7 Segments"
  1.  ; S HEADER(3)=" "
  1.  ;
  1.  ; Display the various HL7 segments' data
  1.  D HEADERDT^BLRGMENU
  1.  S SEGIEN=.9999999
  1.  F  S SEGIEN=$O(^INTHU(FOUNDIT,3,SEGIEN))  Q:SEGIEN<1!(QFLG="Q")  D
  1.  . S SEG=$P($G(^INTHU(FOUNDIT,3,SEGIEN,0)),"|")
  1.  . Q:$L(SEG)>3
  1.  . S DOTELL="DISP"_SEG
  1.  . D @DOTELL
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. DISPMSH ; EP - Don't process anything in the MSH Segment
  1.  NEW STR
  1.  D SHOWSEG
  1.  Q
  1.  ;
  1. DISPPID ; EP - Don't process anything in the PID Segment
  1.  NEW STR
  1.  D SHOWSEG
  1.  Q
  1.  ;
  1. DISPOBR ; EP
  1.  NEW CHNGDTT,DATANAME,DNDTT,F60IEN,OBRIEN,OBSDTT,RCTOSTR,STR,TESTNAME,TSTLOINC
  1.  ;
  1.  D SHOWSEG
  1.  ;
  1.  S TSTLOINC=$P($P(STR,"|",5),"^")
  1.  S TESTNAME=$P($P(STR,"|",5),"^",2)
  1.  S ORIGTEXT=$P($P(STR,"|",5),"^",9)
  1.  ;
  1.  W ?9,"TSTLOINC:",TSTLOINC,?39,"TESTNAME:"
  1.  W:$L(TESTNAME)<31 TESTNAME,!
  1.  I $L(TESTNAME)>30 D LINEWRAP^BLRGMENU(49,TESTNAME,30)  W !
  1.  W ?9,"ORIGTEXT:",ORIGTEXT,!
  1.  ;
  1.  S F60IEN=$$FIND1^DIC(60,,,ORIGTEXT_",")
  1.  W ?9,"F60IEN:",F60IEN,!
  1.  ;
  1.  S DATANAME=$$GET1^DIQ(60,+F60IEN,400,"I")
  1.  W ?9,"DATANAME:",DATANAME,!
  1.  ;
  1.  S OBSDTT=$P($P(STR,"|",8),"^")               ; Observation Date/Time
  1.  W ?9,"OBSDTT:",OBSDTT
  1.  D:$L(OBSDTT) SHOWDATE(OBSDTT)
  1.  W !
  1.  ;
  1.  S CHNGDTT=$P($P(STR,"|",23),"^")             ; Status/Result Change Date/Time
  1.  W ?9,"CHNGDTT:",CHNGDTT
  1.  D:$L(CHNGDTT) SHOWDATE(CHNGDTT)
  1.  W !
  1.  ;
  1.  S DNDTT=$S($L(CHNGDTT):CHNGDTT,1:OBSDTT)     ; DataName Date/Time
  1.  W ?9,"DNDTT:",DNDTT
  1.  D:$L(DNDTT) SHOWDATE(DNDTT)
  1.  W !
  1.  ;
  1.  S RCTOSTR=$P(STR,"|",29)                     ; Result Copies To
  1.  I $L(RCTOSTR) D
  1.  . S SUBSTR2=$TR($P(RCTOSTR,"^",2,6),"^"," ")
  1.  . Q:$L($TR(SUBSTR2," "))<1                   ; If only spaces, skip
  1.  . ;
  1.  . W ?9,"RCTOSTR:",RCTOSTR,!,?14,"SUBSTR2:",SUBSTR2,!
  1.  . ;
  1.  . ; Assumption is that the NAME is in $P(SUBSTR," ",1,3)
  1.  . S SUBSTR2=$P(SUBSTR2," ")_","_$P(SUBSTR2," ",2,$L(SUBSTR2," "))
  1.  . W ?19,"SUBSTR2:",SUBSTR2,!
  1.  ;
  1.  Q
  1.  ;
  1. SHOWSEG ; EP - Show segment and setup STR variable
  1.  W ?4,SEG,!,?9,"FOUNDIT:",FOUNDIT,?39,"SEGIEN:",SEGIEN,!
  1.  S STR=$G(^INTHU(FOUNDIT,3,SEGIEN,0))
  1.  Q
  1.  ;
  1. SHOWDATE(HL7DT) ; EP - Take HL7 Date and display FM & External Date
  1.  NEW FMDT
  1.  ;
  1.  S TAB=$G(TAB,9)
  1.  S FMDT=$$HL7TFM^XLFDT(HL7DT)
  1.  W ?39,FMDT
  1.  W ?59,$$FMTE^XLFDT(FMDT,"5MZ")
  1.  Q
  1.  ;
  1. DISPOBX ; EP
  1.  NEW ANSDTT,DATANAME,F60IEN,OBRIEN,STATUS,STR,TESTNAME,TSTLOINC
  1.  ;
  1.  D SHOWSEG
  1.  ;
  1.  S TSTLOINC=$P($P(STR,"|",4),"^")
  1.  S TESTNAME=$P($P(STR,"|",4),"^",2)
  1.  S ORIGTEXT=$P($P(STR,"|",4),"^",9)
  1.  ;
  1.  W ?9,"TSTLOINC:",TSTLOINC,?39,"TESTNAME:"
  1.  W:$L(TESTNAME)<31 TESTNAME,!
  1.  I $L(TESTNAME)>30 D LINEWRAP^BLRGMENU(49,TESTNAME,30)  W !
  1.  W ?9,"ORIGTEXT:",ORIGTEXT,!
  1.  ;
  1.  S F60IEN=$$FIND1^DIC(60,,,ORIGTEXT_",")
  1.  W ?9,"F60IEN:",F60IEN,!
  1.  ;
  1.  S DATANAME=$$GET1^DIQ(60,+F60IEN,400,"I")
  1.  W ?9,"DATANAME:",DATANAME,!
  1.  ;
  1.  S ANSDTT=$P($P(STR,"|",15),"^")               ; Analysis Date/Time
  1.  W ?9,"ANSDTT:",ANSDTT
  1.  D:$L(ANSDTT) SHOWDATE(ANSDTT)
  1.  W !
  1.  ;
  1.  S STATUS=$P(STR,"|",12)
  1.  W ?9,"STATUS:",STATUS,!
  1.  ;
  1.  Q
  1.  ;
  1. DISPORC ; EP - Don't process anything in the PID Segment
  1.  NEW STR
  1.  D SHOWSEG
  1.  Q
  1.  ;
  1. DISPSPM ; EP
  1.  NEW CONDSPEC,SPMIEN,STR
  1.  ;
  1.  D SHOWSEG
  1.  ;
  1.  S CONDSPEC=$P($P(STR,"|",25),"^")            ; SPECIMEN CONDITION
  1.  W ?9,"CONDSPEC:",CONDSPEC,!
  1.  ;
  1.  S REJREASN=$P($P(STR,"|",22),"^",2)          ; REJECTION REASON
  1.  W ?9,"REJREASN:",REJREASN,!
  1.  Q
  1.  ;
  1. DISPNTE ; EP - Don't process anything in the NTE Segment
  1.  NEW STR
  1.  D SHOWSEG
  1.  Q
  1.  ;
  1. DISPTQ1 ; EP - Don't process anything in the TQ1 Segment
  1.  NEW STR
  1.  D SHOWSEG
  1.  Q