BLRRLMU2 ; IHS/MSC/MKK - Reference Lab Meaningful use Utilities, Part 2 ; 22-Oct-2013 09:22 ; MKK
;;5.2;IHS LABORATORY;**1033**;NOV 1, 1997
;
EEP ; Ersatz EP
D EEP^BLRGMENU
Q
;
PEP ; EP
DEBUGIT ; EP
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S BLRVERN=$TR($P($T(+1),";")," ")
;
D ADDTMENU^BLRGMENU("LAHMMENU^BLRRLMU2","LA7 MESSAGE QUEUE Reports ...")
D ADDTMENU^BLRGMENU("LAHMENU^BLRRLMU3","^LAH Global Reports ...")
D ADDTMENU^BLRGMENU("UNIVMENU^BLRRLMU4","UNIVERSAL INTERFACE Reports ...")
;
; Main Menu driver
D MENUDRVR^BLRGMENU("RPMS Lab MU Stage 2","Miscellaneous Debug Utilities")
Q
;
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D SETBLRVS("LAHMMENU")
;
D ADDTMENU^BLRGMENU("LAHMUIDS^BLRRLMU2","Incoming Matching UIDs in 62.49")
D ADDTMENU^BLRGMENU("SPECSEGS^BLRRLMU2","User Chosen Segments in 62.49")
D ADDTMENU^BLRGMENU("LAHMAUID^BLRRLMU2","All Matching UIDs in ^LAHM(62.49")
; D ADDTMENU^BLRGMENU("MU2TEST^BLRRLMUA","Enter UID & Display HL7 Segs")
D ADDTMENU^BLRGMENU("PIDUIDSR^BLRRLMU2","ALL 62.49 Incoming PIDs")
D ADDTMENU^BLRGMENU("UIDPALL^BLRRLMU2","Enter UID & Display 62.49 Data")
;
; Main Menu driver
D MENUDRVR^BLRGMENU("RPMS Lab MU Stage 2","Miscellaneous Debug Utilities",$$CJ^XLFSTR("LA7 MESSAGE QUEUE (#62.49) Reports",IOM))
Q
;
SHOWDATE(HL7DT) ; EP - Take HL7 Date and display FM & External Date
NEW FMDT
;
S TAB=$G(TAB,9)
S FMDT=$$HL7TFM^XLFDT(HL7DT)
W ?39,FMDT
W ?59,$$FMTE^XLFDT(FMDT,"5MZ")
Q
;
LAHTESTS ; EP - ^LAH 62.49 Tests Report
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
;
Q:$$LAHTESTI()="Q"
;
F S LAHIEN=$O(^LAH(LRLL,1,LAHIEN)) Q:LAHIEN<1 D
. S UID=$G(^LAH(LRLL,1,LAHIEN,.3))
. Q:$L(UID)<1
. Q:$D(^TMP("BLRRLMUU",$J,"UID",UID))<1
. ;
. W ?4,LAHIEN,?19,UID,?34,$G(^TMP("BLRRLMUU",$J,"UID",UID)),!
. S LINES=LINES+1
. S CNT=CNT+1
;
W !!
;
W:CNT<1 ?4,"No UIDs in ^LAH match 62.49",!
W:CNT ?4,"Number of UIDs in ^LAH that Match 62.49 = ",CNT,!
;
W !,?9,"Number of UIDs in 62.49 = ",UID6249,!
;
D PRESSKEY^BLRGMENU
Q
;
LAHTESTI() ; EP - Initialization
S BLRVERN=$TR($P($T(+1),";")," ")
;
Q:$$GETLWLID(.LRLL)<1 "Q"
;
S HEADER(1)="^LAH NIST Entries with 62.49 Data"
;
S HEADER(2)=" "
S $E(HEADER(3),5)="IEN"
S $E(HEADER(3),20)="UID"
S $E(HEADER(3),35)="IHSSPM"
;
S MAXLINES=IOSL-4
S LINES=MAXLINES+10
S (CNT,PG,UID6249)=0
S (HDRONE,QFLG)="NO"
;
D LAHTESTU(.UID6249)
;
S LAHIEN=.9999999
D HEADERDT^BLRGMENU
;
Q "OK"
;
LAHTESTU(UID6249) ; EP - Create UID index into 62.49
NEW IEN,INST,UID
;
K ^TMP("BLRRLMUU",$J,"UID")
;
S INST=""
F S INST=$O(^LAHM(62.49,"C",INST)) Q:INST="" D
. S UID=$P(INST,"-",3)
. Q:$L(UID)<1
. ;
. S IEN=$O(^LAHM(62.49,"C",INST,"A"),-1)
. S ^TMP("BLRRLMUU",$J,"UID",UID)=IEN
. S UID6249=UID6249+1
Q
;
LAHSPMS ; EP - ^LAH IHSSPM Values
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
;
Q:$$LAHSPMSI()="Q"
;
F S IEN=$O(^LAH(LOADWORK,1,IEN),-1) Q:IEN<1 D
. Q:$D(^LAH(LOADWORK,1,IEN,"IHSSPM"))<1
. W IEN
. W ?9,$G(^LAH(LOADWORK,1,IEN,.3))
. W ?24,$E($G(^LAH(LOADWORK,1,IEN,"IHSSPM")),1,60)
. W !
;
D PRESSKEY^BLRGMENU(4)
Q
;
LAHSPMSI() ; EP - Initialization
S BLRVERN=$TR($P($T(+1),";")," ")
;
S HEADER(1)="^LAH IHSSPM Entries"
S HEADER(2)=" "
S HEADER(3)="IEN"
S $E(HEADER(3),10)="UID"
S $E(HEADER(3),25)="IHSSPM"
;
S LA7INST=$$GET1^DIQ(9009029,DUZ(2),3001)
I $G(LA7INST)=""
Q:$G(LA7INST)="" "Q" ; Quit with zero if no Reference Lab
;
S AUTOIEN=+$O(^LAB(62.4,"B",LA7INST,"")) ; Auto Instrument IEN
Q:AUTOIEN<1 "Q" ; Quit with zero if No Auto Instrument
;
S LOADWORK=$$GET1^DIQ(62.4,AUTOIEN,"LOAD/WORK LIST","I")
;
S MAXLINES=IOSL-4
S LINES=MAXLINES+10
S (CNT,PG)=0
S (HDRONE,QFLG)="NO"
S IEN="AA"
D HEADERDT^BLRGMENU
Q "OK"
;
LAHLRASR ; EP - LAH LRAS Report
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
;
Q:$$LAHLRASI()="Q"
;
F S LAHIEN=$O(^LAH(LRLL,1,LAHIEN)) Q:LAHIEN<1 D
. S UID=$G(^LAH(LRLL,1,LAHIEN,.3))
. Q:$L(UID)<1
. ;
. ; Try to get LRAS
. S X=$Q(^LRO(68,"C",UID,0)),LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6),LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
. ;
. W ?4,LAHIEN,?19,UID,?34,$G(^TMP("BLRRLMUU",$J,"UID",UID)),?54,LRAS,!
. S LINES=LINES+1
. S CNT=CNT+1
;
W !!
;
W:CNT<1 ?4,"No UIDs in ^LAH",!
W:CNT ?4,"Number of UIDs in ^LAH = ",CNT,!
;
D PRESSKEY^BLRGMENU
Q
;
LAHLRASI ; EP - Initialization
Q:$$GETLWLID(.LRLL)<1 "Q"
;
D LAHTESTI
K HEADER(1)
S HEADER(1)="^LAH NIST Entries"
S $E(HEADER(3),55)="LRAS"
;
S LAHIEN=.9999999
D HEADERDT^BLRGMENU
Q "OK"
;
PIDUIDSR ; EP - PID Segments with UIDS report
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
;
Q:$$PIDUIDSI()="Q"
;
F S IEN=$O(^LAHM(62.49,IEN),-1) Q:IEN<1!(QFLG="Q") D
. Q:$P($G(^LAHM(62.49,IEN,0)),"^",2)'="I" ; Only INCOMING messages
. ;
. S ENTERDTT=$$GET1^DIQ(62.49,IEN,4,"I")
. S:$L(ENTERDTT) ENTERDTT=$$FMTE^XLFDT(ENTERDTT,"2DZ")
. ;
. S IENCNT=IENCNT+1
. S TYPEMSG=$P($G(^LAHM(62.49,IEN,0)),"^",2)
. S SEGCNT=0
. F S SEGCNT=$O(^LAHM(62.49,IEN,150,SEGCNT)) Q:SEGCNT<1!(QFLG="Q") D
.. S STR=$G(^LAHM(62.49,IEN,150,SEGCNT,0))
.. Q:$P(STR,"|")'="OBR"
.. Q:$P($P(STR,"|",3),"^")=""
.. ;
.. ; Only list IEN once
.. Q:$D(UNIQUE(IEN))
.. S UNIQUE(IEN)=""
.. ;
.. S UID=$P($P(STR,"|",3),"^")
.. Q:$D(UID(UID)) ; Skip if already listed
.. ;
.. W ?TAB(TAB,1),IEN
.. W ?TAB(TAB,2),UID
.. W ?TAB(TAB,3),ENTERDTT
.. S TAB=TAB+1
.. I TAB>2 S TAB=1 W !
.. S CNT=CNT+1
.. S UID(UID)=""
;
W !!!
W ?4,"Number of Incoming Messages = ",IENCNT,!!
W:CNT<1 ?9,"No UIDs Found."
W:CNT ?9,"Number of UIDs = ",CNT
D PRESSKEY^BLRGMENU(14)
Q
;
PIDUIDSI() ; EP - Initializatioin
S BLRVERN=$TR($P($T(+1),";")," ")
;
S HEADER(1)="LA7 MESSAGE QUEUE (#62.49) File"
S HEADER(2)="ALL INCOMING MESSAGES"
S HEADER(3)=$$CJ^XLFSTR("Reverse Date Sort",IOM)
S HEADER(4)=" "
S HEADER(5)="IEN"
S $E(HEADER(5),10)="UID"
S $E(HEADER(5),25)="Enter Dt"
S $E(HEADER(5),40)="IEN"
S $E(HEADER(5),50)="UID"
S $E(HEADER(5),63)="Entr Dt"
;
S MAXLINES=IOSL-4
S LINES=MAXLINES+10
S (CNT,IENCNT,PG)=0
S QFLG="NO"
S IEN="AAA"
;
S TAB(1,1)=0,TAB(1,2)=9,TAB(1,3)=24
S TAB(2,1)=39,TAB(2,2)=49,TAB(2,3)=62
S TAB=1
;
D HEADERDT^BLRGMENU
;
Q "OK"
;
LAHMUIDS ; EP - List the UIDs found in the ^LAHM(62.49 global
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,LRPARAM,IOXY,TESTDESC,U,UID,XPARSYS,XQXFLG)
;
Q:$$LAHMUIDI()="Q"
;
F S IEN=$O(^LAHM(62.49,IEN),-1) Q:IEN<1!(QFLG="Q") D
. Q:$P($G(^LAHM(62.49,IEN,0)),"^",2)'="I" ; Only INCOMING messages
. ;
. S TYPEMSG=$P($G(^LAHM(62.49,IEN,0)),"^",2)
. S SEGCNT=0
. F S SEGCNT=$O(^LAHM(62.49,IEN,150,SEGCNT)) Q:SEGCNT<1!(QFLG="Q") D LAHMUIDL
;
W !!,?4,"Number of UIDs = ",CNT
D PRESSKEY^BLRGMENU(9)
K ^TMP("BLRRLMUU",$J,"LAHMUIDL")
Q
;
LAHMUIDI(TYPEFLAG) ; EP - Initialization
S BLRVERN=$TR($P($T(+1),";")," ")
;
S HEADER(1)="LA7 MESSAGE QUEUE (#62.49) File"
D HEADERDT^BLRGMENU
D HEADONE^BLRGMENU(.HDRONE)
;
S STR=$S($L($G(TYPEFLAG)):"ALL INCOMING MESSAGES",1:"INCOMING MESSAGES ONLY")
S HEADER(2)=STR
S HEADER(3)=$$CJ^XLFSTR("Reverse Order Sort",IOM)
S HEADER(4)=" "
S HEADER(5)="IEN"
S $E(HEADER(5),15)="UID"
S $E(HEADER(5),30)="Accession"
S $E(HEADER(5),50)="Entry Date/Time"
S $E(HEADER(5),68)="DFN"
S:+$G(TYPEFLAG) $E(HEADER(5),78)="Typ"
;
S MAXLINES=IOSL-4
S LINES=MAXLINES+10
S (CNT,PG)=0
S QFLG="NO"
S IEN="AAA"
;
K ^TMP("BLRRLMUU",$J,"LAHMUIDL")
Q "OK"
;
LAHMUIDL ; EP - Line of Data
S STR=$G(^LAHM(62.49,IEN,150,SEGCNT,0))
Q:$P(STR,"|")'="OBR"
Q:$P($P(STR,"|",3),"^")=""
;
S UID=$P($P(STR,"|",3),"^")
Q:$D(^LRO(68,"C",UID))<1 ; Skip if no UID data
;
S X=$Q(^LRO(68,"C",UID,0)),LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6),LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),LRDONEDT=$P($G(^(3)),"^",4),DFN=$P($G(^LR(LRDFN,0)),"^",3)
;
; Q:$D(^TMP("BLRRLMUU",$J,"LAHMUIDL",UID)) ; Only list UID once
; S ^TMP("BLRRLMUU",$J,"LAHMUIDL",UID)=""
;
I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE) Q:QFLG="Q"
;
S ENTRYDT=+$P($G(^LAHM(62.49,IEN,0)),"^",5)
S ENTRYDT=$$FMTE^XLFDT(ENTRYDT,"5MZ")
;
S LRAS=$$LAHMUIDA(UID)
;
W IEN,?14,UID,?27,$S(+LRDONEDT:"C",1:" "),?29,LRAS,?49,ENTRYDT,?67,$G(DFN)
W:+$G(TYPEFLAG) ?77,$$CJ^XLFSTR(TYPEMSG,3)
W !
S CNT=CNT+1
S LINES=LINES+1
Q
;
LAHMUIDA(UID) ; EP - Get Accession Number
Q:UID["ORD" " "
;
S UID=$P(UID,"A")
Q:$D(^LRO(68,"C",UID))<1 "<>" ; Skip if no UID data
;
S X=$Q(^LRO(68,"C",UID,0)),LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6)
Q $G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
;
SPECSEGS ; EP - List the User chosen Segments in 62.49
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,LRPARAM,IOXY,TESTDESC,U,UID,XPARSYS,XQXFLG)
;
D ^XBFMK
S DIR(0)="FO"
S DIR("A")="SEGMENT"
D ^DIR
I +$G(DIRUT) D Q
. W !,?4,"Invalid/No Entry. Routine Ends."
. D PRESSKEY^BLRGMENU(9)
;
S SEGMENT=$$UP^XLFSTR(X)
;
S IEN="AAA",QFLG="NO",PUTCNT=0,LINES=0
F S IEN=$O(^LAHM(62.49,IEN),-1) Q:IEN<1!(QFLG="Q") D
. Q:$P($G(^LAHM(62.49,IEN,0)),"^",2)'="I" ; Only INCOMING messages
. ;
. S SEGCNT=0
. F S SEGCNT=$O(^LAHM(62.49,IEN,150,SEGCNT)) Q:SEGCNT<1!(QFLG="Q") D
.. S STR=$G(^LAHM(62.49,IEN,150,SEGCNT,0))
.. Q:$P(STR,"|")'=SEGMENT
.. ;
.. W:PUTCNT=0 !!,"IEN",?14,"CNT",?24,"Segment",!,$TR($J("",IOM)," ","-"),!
.. W IEN,?14,SEGCNT
.. D LINEWRAP^BZHHUTLM(24,STR,56)
.. W !!
.. S PUTCNT=PUTCNT+1
. D:PUTCNT PRESSKEY^BLRGMENU(4) W !!
Q
;
LAHMAUID ; EP - All UIDs in ^LAHM(62.49
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,LRPARAM,IOXY,TESTDESC,U,UID,XPARSYS,XQXFLG)
;
S TYPEFLAG=1
Q:$$LAHMUIDI(TYPEFLAG)="Q"
K HEADER(2)
S HEADER(2)="All Matching UIDs"
;
F S IEN=$O(^LAHM(62.49,IEN),-1) Q:IEN<1!(QFLG="Q") D
. S TYPEMSG=$$GET1^DIQ(62.49,IEN,"TYPE","I")
. S:$L(TYPEMSG)<1 TYPEMSG="<"_$$GET1^DIQ(62.49,IEN,"STATUS","I")_">"
. S SEGCNT=0
. F S SEGCNT=$O(^LAHM(62.49,IEN,150,SEGCNT)) Q:SEGCNT<1!(QFLG="Q") D LAHMUIDL
;
W:CNT<1 !!,?4,"No Matching UIDs entries found in the LA7 MESSAGE QUEUE (#62.49) file."
;
D PRESSKEY^BLRGMENU(9)
Q
;
GETLWLID(LRLL) ; EP - Return LOAD/WORK LIST IEN
NEW LA7INST,AUTINSP
;
S LA7INST=$$GET1^DIQ(9009029,DUZ(2),3001) ; Reference Lab
S AUTOINSP=$S($L(LA7INST):+$O(^LAB(62.4,"B",LA7INST,"")),1:0) ; Auto Instrument IEN
;
S LRLL=+$$GET1^DIQ(62.4,AUTOINSP,3,"I") ; LOAD/WORK List
;
I LRLL<1 D ENDMESG("Could not Determine Load/Work List. Routine Ends.") Q
;
Q LRLL
;
UIDPALL ; EP - Select UID & Display All 62.49 Data using EN^DIQ
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
;
S HEADER(1)="File 62.49 Data Display"
D HEADERDT^BLRGMENU
;
S STR=$$F6249UID
S IEN6249=$P(STR,U,6)
Q:IEN6249<1
;
S LRUID=+STR,LRAS=$P(STR,U,5)
;
S HEADER(2)="UID:"_LRUID_" ["_LRAS_"]"
D HEADERDT^BLRGMENU
;
D HEAD6249(IEN6249)
;
S SEQ=0,QFLG="NO"
F S SEQ=$O(^LAHM(62.49,IEN6249,150,SEQ)) Q:SEQ<1!(QFLG="Q") D
. S STR=$G(^LAHM(62.49,IEN6249,150,SEQ,0))
. Q:$L(STR)<1
. W !!,$P(STR,"|"),! ; Segment Identifier
. F SEG=2:1:$L(STR,"|") D
.. S SUBSEG=$$TRIM^XLFSTR($P(STR,"|",SEG),"LR"," ")
.. Q:$L(SUBSEG)<1
.. W ?4,$J((SEG-1),2),")"
.. W:$L(SUBSEG)<60 ?14,SUBSEG,!
.. I $L(SUBSEG)>59 D LINEWRAP^BLRGMENU(14,SUBSEG,60) W !
. D PRESSKEY^BLRGMENU(9)
;
I QFLG'="Q" D
. W !!,?4,"All sequences have been displayed."
. D PRESSKEY^BLRGMENU(9)
;
Q
;
HEAD6249(IEN) ; EP - Display variables in header of File 62.49
D ^XBFMK
S DIC="^LAHM(62.49,",DA=IEN,DIQ(0)="CR",DR="0:100"
D EN^DIQ
;
Q
;
ENDMESG(TEXT) ; EP - Ending Message
W !,?4,TEXT
D PRESSKEY^BLRGMENU(9)
Q
;
F6249UID() ; EP - Get UIDs from 62.49 & setup DIR call for user to select one
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S DIRZERO="SO^"
S (CNT,ENTRY)=0
;
S IEN="A"
F S IEN=$O(^LAHM(62.49,IEN),-1) Q:IEN<1 D
. S TYPEMSG=$P($G(^LAHM(62.49,IEN,0)),"^",2)
. ;
. S SEG=0,STR=""
. F S SEG=$O(^LAHM(62.49,IEN,150,SEG)) Q:SEG<1 D
.. S STR=$G(^LAHM(62.49,IEN,150,SEG,0))
.. Q:$P(STR,"|")'="OBR"
.. ;
.. S LRUID=$P($P(STR,"|",3),"^")
.. Q:$L(LRUID)<1
.. ;
.. ; Make certain entry only shows once
.. Q:$D(UNIQUE(IEN))
.. S UNIQUE(IEN)=""
.. ;
.. S X=$Q(^LRO(68,"C",LRUID,0)),LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6)
.. Q:LRAA<1!(LRAD<1)!(LRAN<1) ; If no Accession, skip
.. ;
.. S IENSTR=LRAN_","_LRAD_","_LRAA_","
.. S LRAS=$$GET1^DIQ(68.02,IENSTR,"ACCESSION")
.. S CNT=CNT+1
.. S DIRZERO=DIRZERO_CNT_":"_LRUID_";"
.. S DIRZERO(CNT)=$$LJ^XLFSTR($J(CNT,2)_") "_$$LJ^XLFSTR(LRUID,11)_LRAS,27)
.. S LUIDINDX(CNT)=LRUID_U_LRAA_U_LRAD_U_LRAN_U_LRAS_U_IEN
S CNT=CNT+1
S DIRZERO=DIRZERO_(CNT)_":AL"
;
I $D(LUIDINDX)<1 D Q 0
. W !!,?4,"No matching UID Entries found in the LA7 MESSAGE QUEUE (#62.49) file."
. D PRESSKEY^BLRGMENU(9)
. S LREND=1
;
S NUMCOL=3
K LRUID
D ^XBFMK
S DIR(0)=DIRZERO
S DIR("L",1)=" UID Accession UID Accession UID Accession"
S DIR("L",2)=" ---------- ----------- ---------- ----------- ---------- ----------"
S BELOW=3
S CNT=0
F S CNT=$O(DIRZERO(CNT)) Q:CNT<1 D
. S:(CNT#NUMCOL)=1 DIR("L",BELOW)=""
. S DIR("L",BELOW)=$G(DIR("L",BELOW))_$S((CNT#NUMCOL)=0:$$TRIM^XLFSTR(DIRZERO(CNT),"R"," "),1:DIRZERO(CNT))
. S:(CNT#NUMCOL)=0 BELOW=BELOW+1
;
S DIR("L")=""
S DIR("A")="Select number" ; Change default prompt
;
S HEADER(1)="LA7 MESSAGE QUEUE (#62.49) File"
S HEADER(2)="UID Selection"
;
D HEADERDT^BLRGMENU
;
D ^DIR
I +Y<1!(+$G(DIRUT)) D Q 0
. W !,?4,"No/Invalid Entry. Routine Ends."
. D PRESSKEY^BLRGMENU(9)
. S LREND=1
;
Q $G(LUIDINDX(+$G(Y)))
;
SETBLRVS(TWO) ; EP - Set BLRVERN variable(s)
S BLRVERN=$TR($P($T(+1),";")," ")
S:$L($G(TWO)) BLRVERN2=TWO
Q
BLRRLMU2 ; IHS/MSC/MKK - Reference Lab Meaningful use Utilities, Part 2 ; 22-Oct-2013 09:22 ; MKK
+1 ;;5.2;IHS LABORATORY;**1033**;NOV 1, 1997
+2 ;
EEP ; Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
PEP ; EP
DEBUGIT ; EP
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+4 ;
+5 DO ADDTMENU^BLRGMENU("LAHMMENU^BLRRLMU2","LA7 MESSAGE QUEUE Reports ...")
+6 DO ADDTMENU^BLRGMENU("LAHMENU^BLRRLMU3","^LAH Global Reports ...")
+7 DO ADDTMENU^BLRGMENU("UNIVMENU^BLRRLMU4","UNIVERSAL INTERFACE Reports ...")
+8 ;
+9 ; Main Menu driver
+10 DO MENUDRVR^BLRGMENU("RPMS Lab MU Stage 2","Miscellaneous Debug Utilities")
+11 QUIT
+12 ;
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 DO SETBLRVS("LAHMMENU")
+4 ;
+5 DO ADDTMENU^BLRGMENU("LAHMUIDS^BLRRLMU2","Incoming Matching UIDs in 62.49")
+6 DO ADDTMENU^BLRGMENU("SPECSEGS^BLRRLMU2","User Chosen Segments in 62.49")
+7 DO ADDTMENU^BLRGMENU("LAHMAUID^BLRRLMU2","All Matching UIDs in ^LAHM(62.49")
+8 ; D ADDTMENU^BLRGMENU("MU2TEST^BLRRLMUA","Enter UID & Display HL7 Segs")
+9 DO ADDTMENU^BLRGMENU("PIDUIDSR^BLRRLMU2","ALL 62.49 Incoming PIDs")
+10 DO ADDTMENU^BLRGMENU("UIDPALL^BLRRLMU2","Enter UID & Display 62.49 Data")
+11 ;
+12 ; Main Menu driver
+13 DO MENUDRVR^BLRGMENU("RPMS Lab MU Stage 2","Miscellaneous Debug Utilities",$$CJ^XLFSTR("LA7 MESSAGE QUEUE (#62.49) Reports",IOM))
+14 QUIT
+15 ;
SHOWDATE(HL7DT) ; EP - Take HL7 Date and display FM & External Date
+1 NEW FMDT
+2 ;
+3 SET TAB=$GET(TAB,9)
+4 SET FMDT=$$HL7TFM^XLFDT(HL7DT)
+5 WRITE ?39,FMDT
+6 WRITE ?59,$$FMTE^XLFDT(FMDT,"5MZ")
+7 QUIT
+8 ;
LAHTESTS ; EP - ^LAH 62.49 Tests Report
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
+2 ;
+3 IF $$LAHTESTI()="Q"
QUIT
+4 ;
+5 FOR
SET LAHIEN=$ORDER(^LAH(LRLL,1,LAHIEN))
IF LAHIEN<1
QUIT
Begin DoDot:1
+6 SET UID=$GET(^LAH(LRLL,1,LAHIEN,.3))
+7 IF $LENGTH(UID)<1
QUIT
+8 IF $DATA(^TMP("BLRRLMUU",$JOB,"UID",UID))<1
QUIT
+9 ;
+10 WRITE ?4,LAHIEN,?19,UID,?34,$GET(^TMP("BLRRLMUU",$JOB,"UID",UID)),!
+11 SET LINES=LINES+1
+12 SET CNT=CNT+1
End DoDot:1
+13 ;
+14 WRITE !!
+15 ;
+16 IF CNT<1
WRITE ?4,"No UIDs in ^LAH match 62.49",!
+17 IF CNT
WRITE ?4,"Number of UIDs in ^LAH that Match 62.49 = ",CNT,!
+18 ;
+19 WRITE !,?9,"Number of UIDs in 62.49 = ",UID6249,!
+20 ;
+21 DO PRESSKEY^BLRGMENU
+22 QUIT
+23 ;
LAHTESTI() ; EP - Initialization
+1 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+2 ;
+3 IF $$GETLWLID(.LRLL)<1
QUIT "Q"
+4 ;
+5 SET HEADER(1)="^LAH NIST Entries with 62.49 Data"
+6 ;
+7 SET HEADER(2)=" "
+8 SET $EXTRACT(HEADER(3),5)="IEN"
+9 SET $EXTRACT(HEADER(3),20)="UID"
+10 SET $EXTRACT(HEADER(3),35)="IHSSPM"
+11 ;
+12 SET MAXLINES=IOSL-4
+13 SET LINES=MAXLINES+10
+14 SET (CNT,PG,UID6249)=0
+15 SET (HDRONE,QFLG)="NO"
+16 ;
+17 DO LAHTESTU(.UID6249)
+18 ;
+19 SET LAHIEN=.9999999
+20 DO HEADERDT^BLRGMENU
+21 ;
+22 QUIT "OK"
+23 ;
LAHTESTU(UID6249) ; EP - Create UID index into 62.49
+1 NEW IEN,INST,UID
+2 ;
+3 KILL ^TMP("BLRRLMUU",$JOB,"UID")
+4 ;
+5 SET INST=""
+6 FOR
SET INST=$ORDER(^LAHM(62.49,"C",INST))
IF INST=""
QUIT
Begin DoDot:1
+7 SET UID=$PIECE(INST,"-",3)
+8 IF $LENGTH(UID)<1
QUIT
+9 ;
+10 SET IEN=$ORDER(^LAHM(62.49,"C",INST,"A"),-1)
+11 SET ^TMP("BLRRLMUU",$JOB,"UID",UID)=IEN
+12 SET UID6249=UID6249+1
End DoDot:1
+13 QUIT
+14 ;
LAHSPMS ; EP - ^LAH IHSSPM Values
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
+2 ;
+3 IF $$LAHSPMSI()="Q"
QUIT
+4 ;
+5 FOR
SET IEN=$ORDER(^LAH(LOADWORK,1,IEN),-1)
IF IEN<1
QUIT
Begin DoDot:1
+6 IF $DATA(^LAH(LOADWORK,1,IEN,"IHSSPM"))<1
QUIT
+7 WRITE IEN
+8 WRITE ?9,$GET(^LAH(LOADWORK,1,IEN,.3))
+9 WRITE ?24,$EXTRACT($GET(^LAH(LOADWORK,1,IEN,"IHSSPM")),1,60)
+10 WRITE !
End DoDot:1
+11 ;
+12 DO PRESSKEY^BLRGMENU(4)
+13 QUIT
+14 ;
LAHSPMSI() ; EP - Initialization
+1 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+2 ;
+3 SET HEADER(1)="^LAH IHSSPM Entries"
+4 SET HEADER(2)=" "
+5 SET HEADER(3)="IEN"
+6 SET $EXTRACT(HEADER(3),10)="UID"
+7 SET $EXTRACT(HEADER(3),25)="IHSSPM"
+8 ;
+9 SET LA7INST=$$GET1^DIQ(9009029,DUZ(2),3001)
+10 IF $GET(LA7INST)=""
+11 ; Quit with zero if no Reference Lab
IF $GET(LA7INST)=""
QUIT "Q"
+12 ;
+13 ; Auto Instrument IEN
SET AUTOIEN=+$ORDER(^LAB(62.4,"B",LA7INST,""))
+14 ; Quit with zero if No Auto Instrument
IF AUTOIEN<1
QUIT "Q"
+15 ;
+16 SET LOADWORK=$$GET1^DIQ(62.4,AUTOIEN,"LOAD/WORK LIST","I")
+17 ;
+18 SET MAXLINES=IOSL-4
+19 SET LINES=MAXLINES+10
+20 SET (CNT,PG)=0
+21 SET (HDRONE,QFLG)="NO"
+22 SET IEN="AA"
+23 DO HEADERDT^BLRGMENU
+24 QUIT "OK"
+25 ;
LAHLRASR ; EP - LAH LRAS Report
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
+2 ;
+3 IF $$LAHLRASI()="Q"
QUIT
+4 ;
+5 FOR
SET LAHIEN=$ORDER(^LAH(LRLL,1,LAHIEN))
IF LAHIEN<1
QUIT
Begin DoDot:1
+6 SET UID=$GET(^LAH(LRLL,1,LAHIEN,.3))
+7 IF $LENGTH(UID)<1
QUIT
+8 ;
+9 ; Try to get LRAS
+10 SET X=$QUERY(^LRO(68,"C",UID,0))
SET LRAA=+$QSUBSCRIPT(X,4)
SET LRAD=+$QSUBSCRIPT(X,5)
SET LRAN=+$QSUBSCRIPT(X,6)
SET LRAS=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
+11 ;
+12 WRITE ?4,LAHIEN,?19,UID,?34,$GET(^TMP("BLRRLMUU",$JOB,"UID",UID)),?54,LRAS,!
+13 SET LINES=LINES+1
+14 SET CNT=CNT+1
End DoDot:1
+15 ;
+16 WRITE !!
+17 ;
+18 IF CNT<1
WRITE ?4,"No UIDs in ^LAH",!
+19 IF CNT
WRITE ?4,"Number of UIDs in ^LAH = ",CNT,!
+20 ;
+21 DO PRESSKEY^BLRGMENU
+22 QUIT
+23 ;
LAHLRASI ; EP - Initialization
+1 IF $$GETLWLID(.LRLL)<1
QUIT "Q"
+2 ;
+3 DO LAHTESTI
+4 KILL HEADER(1)
+5 SET HEADER(1)="^LAH NIST Entries"
+6 SET $EXTRACT(HEADER(3),55)="LRAS"
+7 ;
+8 SET LAHIEN=.9999999
+9 DO HEADERDT^BLRGMENU
+10 QUIT "OK"
+11 ;
PIDUIDSR ; EP - PID Segments with UIDS report
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
+2 ;
+3 IF $$PIDUIDSI()="Q"
QUIT
+4 ;
+5 FOR
SET IEN=$ORDER(^LAHM(62.49,IEN),-1)
IF IEN<1!(QFLG="Q")
QUIT
Begin DoDot:1
+6 ; Only INCOMING messages
IF $PIECE($GET(^LAHM(62.49,IEN,0)),"^",2)'="I"
QUIT
+7 ;
+8 SET ENTERDTT=$$GET1^DIQ(62.49,IEN,4,"I")
+9 IF $LENGTH(ENTERDTT)
SET ENTERDTT=$$FMTE^XLFDT(ENTERDTT,"2DZ")
+10 ;
+11 SET IENCNT=IENCNT+1
+12 SET TYPEMSG=$PIECE($GET(^LAHM(62.49,IEN,0)),"^",2)
+13 SET SEGCNT=0
+14 FOR
SET SEGCNT=$ORDER(^LAHM(62.49,IEN,150,SEGCNT))
IF SEGCNT<1!(QFLG="Q")
QUIT
Begin DoDot:2
+15 SET STR=$GET(^LAHM(62.49,IEN,150,SEGCNT,0))
+16 IF $PIECE(STR,"|")'="OBR"
QUIT
+17 IF $PIECE($PIECE(STR,"|",3),"^")=""
QUIT
+18 ;
+19 ; Only list IEN once
+20 IF $DATA(UNIQUE(IEN))
QUIT
+21 SET UNIQUE(IEN)=""
+22 ;
+23 SET UID=$PIECE($PIECE(STR,"|",3),"^")
+24 ; Skip if already listed
IF $DATA(UID(UID))
QUIT
+25 ;
+26 WRITE ?TAB(TAB,1),IEN
+27 WRITE ?TAB(TAB,2),UID
+28 WRITE ?TAB(TAB,3),ENTERDTT
+29 SET TAB=TAB+1
+30 IF TAB>2
SET TAB=1
WRITE !
+31 SET CNT=CNT+1
+32 SET UID(UID)=""
End DoDot:2
End DoDot:1
+33 ;
+34 WRITE !!!
+35 WRITE ?4,"Number of Incoming Messages = ",IENCNT,!!
+36 IF CNT<1
WRITE ?9,"No UIDs Found."
+37 IF CNT
WRITE ?9,"Number of UIDs = ",CNT
+38 DO PRESSKEY^BLRGMENU(14)
+39 QUIT
+40 ;
PIDUIDSI() ; EP - Initializatioin
+1 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+2 ;
+3 SET HEADER(1)="LA7 MESSAGE QUEUE (#62.49) File"
+4 SET HEADER(2)="ALL INCOMING MESSAGES"
+5 SET HEADER(3)=$$CJ^XLFSTR("Reverse Date Sort",IOM)
+6 SET HEADER(4)=" "
+7 SET HEADER(5)="IEN"
+8 SET $EXTRACT(HEADER(5),10)="UID"
+9 SET $EXTRACT(HEADER(5),25)="Enter Dt"
+10 SET $EXTRACT(HEADER(5),40)="IEN"
+11 SET $EXTRACT(HEADER(5),50)="UID"
+12 SET $EXTRACT(HEADER(5),63)="Entr Dt"
+13 ;
+14 SET MAXLINES=IOSL-4
+15 SET LINES=MAXLINES+10
+16 SET (CNT,IENCNT,PG)=0
+17 SET QFLG="NO"
+18 SET IEN="AAA"
+19 ;
+20 SET TAB(1,1)=0
SET TAB(1,2)=9
SET TAB(1,3)=24
+21 SET TAB(2,1)=39
SET TAB(2,2)=49
SET TAB(2,3)=62
+22 SET TAB=1
+23 ;
+24 DO HEADERDT^BLRGMENU
+25 ;
+26 QUIT "OK"
+27 ;
LAHMUIDS ; EP - List the UIDs found in the ^LAHM(62.49 global
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,LRPARAM,IOXY,TESTDESC,U,UID,XPARSYS,XQXFLG)
+2 ;
+3 IF $$LAHMUIDI()="Q"
QUIT
+4 ;
+5 FOR
SET IEN=$ORDER(^LAHM(62.49,IEN),-1)
IF IEN<1!(QFLG="Q")
QUIT
Begin DoDot:1
+6 ; Only INCOMING messages
IF $PIECE($GET(^LAHM(62.49,IEN,0)),"^",2)'="I"
QUIT
+7 ;
+8 SET TYPEMSG=$PIECE($GET(^LAHM(62.49,IEN,0)),"^",2)
+9 SET SEGCNT=0
+10 FOR
SET SEGCNT=$ORDER(^LAHM(62.49,IEN,150,SEGCNT))
IF SEGCNT<1!(QFLG="Q")
QUIT
DO LAHMUIDL
End DoDot:1
+11 ;
+12 WRITE !!,?4,"Number of UIDs = ",CNT
+13 DO PRESSKEY^BLRGMENU(9)
+14 KILL ^TMP("BLRRLMUU",$JOB,"LAHMUIDL")
+15 QUIT
+16 ;
LAHMUIDI(TYPEFLAG) ; EP - Initialization
+1 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+2 ;
+3 SET HEADER(1)="LA7 MESSAGE QUEUE (#62.49) File"
+4 DO HEADERDT^BLRGMENU
+5 DO HEADONE^BLRGMENU(.HDRONE)
+6 ;
+7 SET STR=$SELECT($LENGTH($GET(TYPEFLAG)):"ALL INCOMING MESSAGES",1:"INCOMING MESSAGES ONLY")
+8 SET HEADER(2)=STR
+9 SET HEADER(3)=$$CJ^XLFSTR("Reverse Order Sort",IOM)
+10 SET HEADER(4)=" "
+11 SET HEADER(5)="IEN"
+12 SET $EXTRACT(HEADER(5),15)="UID"
+13 SET $EXTRACT(HEADER(5),30)="Accession"
+14 SET $EXTRACT(HEADER(5),50)="Entry Date/Time"
+15 SET $EXTRACT(HEADER(5),68)="DFN"
+16 IF +$GET(TYPEFLAG)
SET $EXTRACT(HEADER(5),78)="Typ"
+17 ;
+18 SET MAXLINES=IOSL-4
+19 SET LINES=MAXLINES+10
+20 SET (CNT,PG)=0
+21 SET QFLG="NO"
+22 SET IEN="AAA"
+23 ;
+24 KILL ^TMP("BLRRLMUU",$JOB,"LAHMUIDL")
+25 QUIT "OK"
+26 ;
LAHMUIDL ; EP - Line of Data
+1 SET STR=$GET(^LAHM(62.49,IEN,150,SEGCNT,0))
+2 IF $PIECE(STR,"|")'="OBR"
QUIT
+3 IF $PIECE($PIECE(STR,"|",3),"^")=""
QUIT
+4 ;
+5 SET UID=$PIECE($PIECE(STR,"|",3),"^")
+6 ; Skip if no UID data
IF $DATA(^LRO(68,"C",UID))<1
QUIT
+7 ;
+8 SET X=$QUERY(^LRO(68,"C",UID,0))
SET LRAA=+$QSUBSCRIPT(X,4)
SET LRAD=+$QSUBSCRIPT(X,5)
SET LRAN=+$QSUBSCRIPT(X,6)
SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
SET LRDONEDT=$PIECE($GET(^(3)),"^",4)
SET DFN=$PIECE($GET(^LR(LRDFN,0)),"^",3)
+9 ;
+10 ; Q:$D(^TMP("BLRRLMUU",$J,"LAHMUIDL",UID)) ; Only list UID once
+11 ; S ^TMP("BLRRLMUU",$J,"LAHMUIDL",UID)=""
+12 ;
+13 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)
IF QFLG="Q"
QUIT
+14 ;
+15 SET ENTRYDT=+$PIECE($GET(^LAHM(62.49,IEN,0)),"^",5)
+16 SET ENTRYDT=$$FMTE^XLFDT(ENTRYDT,"5MZ")
+17 ;
+18 SET LRAS=$$LAHMUIDA(UID)
+19 ;
+20 WRITE IEN,?14,UID,?27,$SELECT(+LRDONEDT:"C",1:" "),?29,LRAS,?49,ENTRYDT,?67,$GET(DFN)
+21 IF +$GET(TYPEFLAG)
WRITE ?77,$$CJ^XLFSTR(TYPEMSG,3)
+22 WRITE !
+23 SET CNT=CNT+1
+24 SET LINES=LINES+1
+25 QUIT
+26 ;
LAHMUIDA(UID) ; EP - Get Accession Number
+1 IF UID["ORD"
QUIT " "
+2 ;
+3 SET UID=$PIECE(UID,"A")
+4 ; Skip if no UID data
IF $DATA(^LRO(68,"C",UID))<1
QUIT "<>"
+5 ;
+6 SET X=$QUERY(^LRO(68,"C",UID,0))
SET LRAA=+$QSUBSCRIPT(X,4)
SET LRAD=+$QSUBSCRIPT(X,5)
SET LRAN=+$QSUBSCRIPT(X,6)
+7 QUIT $GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
+8 ;
SPECSEGS ; EP - List the User chosen Segments in 62.49
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,LRPARAM,IOXY,TESTDESC,U,UID,XPARSYS,XQXFLG)
+2 ;
+3 DO ^XBFMK
+4 SET DIR(0)="FO"
+5 SET DIR("A")="SEGMENT"
+6 DO ^DIR
+7 IF +$GET(DIRUT)
Begin DoDot:1
+8 WRITE !,?4,"Invalid/No Entry. Routine Ends."
+9 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+10 ;
+11 SET SEGMENT=$$UP^XLFSTR(X)
+12 ;
+13 SET IEN="AAA"
SET QFLG="NO"
SET PUTCNT=0
SET LINES=0
+14 FOR
SET IEN=$ORDER(^LAHM(62.49,IEN),-1)
IF IEN<1!(QFLG="Q")
QUIT
Begin DoDot:1
+15 ; Only INCOMING messages
IF $PIECE($GET(^LAHM(62.49,IEN,0)),"^",2)'="I"
QUIT
+16 ;
+17 SET SEGCNT=0
+18 FOR
SET SEGCNT=$ORDER(^LAHM(62.49,IEN,150,SEGCNT))
IF SEGCNT<1!(QFLG="Q")
QUIT
Begin DoDot:2
+19 SET STR=$GET(^LAHM(62.49,IEN,150,SEGCNT,0))
+20 IF $PIECE(STR,"|")'=SEGMENT
QUIT
+21 ;
+22 IF PUTCNT=0
WRITE !!,"IEN",?14,"CNT",?24,"Segment",!,$TRANSLATE($JUSTIFY("",IOM)," ","-"),!
+23 WRITE IEN,?14,SEGCNT
+24 DO LINEWRAP^BZHHUTLM(24,STR,56)
+25 WRITE !!
+26 SET PUTCNT=PUTCNT+1
End DoDot:2
+27 IF PUTCNT
DO PRESSKEY^BLRGMENU(4)
WRITE !!
End DoDot:1
+28 QUIT
+29 ;
LAHMAUID ; EP - All UIDs in ^LAHM(62.49
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,LRPARAM,IOXY,TESTDESC,U,UID,XPARSYS,XQXFLG)
+2 ;
+3 SET TYPEFLAG=1
+4 IF $$LAHMUIDI(TYPEFLAG)="Q"
QUIT
+5 KILL HEADER(2)
+6 SET HEADER(2)="All Matching UIDs"
+7 ;
+8 FOR
SET IEN=$ORDER(^LAHM(62.49,IEN),-1)
IF IEN<1!(QFLG="Q")
QUIT
Begin DoDot:1
+9 SET TYPEMSG=$$GET1^DIQ(62.49,IEN,"TYPE","I")
+10 IF $LENGTH(TYPEMSG)<1
SET TYPEMSG="<"_$$GET1^DIQ(62.49,IEN,"STATUS","I")_">"
+11 SET SEGCNT=0
+12 FOR
SET SEGCNT=$ORDER(^LAHM(62.49,IEN,150,SEGCNT))
IF SEGCNT<1!(QFLG="Q")
QUIT
DO LAHMUIDL
End DoDot:1
+13 ;
+14 IF CNT<1
WRITE !!,?4,"No Matching UIDs entries found in the LA7 MESSAGE QUEUE (#62.49) file."
+15 ;
+16 DO PRESSKEY^BLRGMENU(9)
+17 QUIT
+18 ;
GETLWLID(LRLL) ; EP - Return LOAD/WORK LIST IEN
+1 NEW LA7INST,AUTINSP
+2 ;
+3 ; Reference Lab
SET LA7INST=$$GET1^DIQ(9009029,DUZ(2),3001)
+4 ; Auto Instrument IEN
SET AUTOINSP=$SELECT($LENGTH(LA7INST):+$ORDER(^LAB(62.4,"B",LA7INST,"")),1:0)
+5 ;
+6 ; LOAD/WORK List
SET LRLL=+$$GET1^DIQ(62.4,AUTOINSP,3,"I")
+7 ;
+8 IF LRLL<1
DO ENDMESG("Could not Determine Load/Work List. Routine Ends.")
QUIT
+9 ;
+10 QUIT LRLL
+11 ;
UIDPALL ; EP - Select UID & Display All 62.49 Data using EN^DIQ
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
+2 ;
+3 SET HEADER(1)="File 62.49 Data Display"
+4 DO HEADERDT^BLRGMENU
+5 ;
+6 SET STR=$$F6249UID
+7 SET IEN6249=$PIECE(STR,U,6)
+8 IF IEN6249<1
QUIT
+9 ;
+10 SET LRUID=+STR
SET LRAS=$PIECE(STR,U,5)
+11 ;
+12 SET HEADER(2)="UID:"_LRUID_" ["_LRAS_"]"
+13 DO HEADERDT^BLRGMENU
+14 ;
+15 DO HEAD6249(IEN6249)
+16 ;
+17 SET SEQ=0
SET QFLG="NO"
+18 FOR
SET SEQ=$ORDER(^LAHM(62.49,IEN6249,150,SEQ))
IF SEQ<1!(QFLG="Q")
QUIT
Begin DoDot:1
+19 SET STR=$GET(^LAHM(62.49,IEN6249,150,SEQ,0))
+20 IF $LENGTH(STR)<1
QUIT
+21 ; Segment Identifier
WRITE !!,$PIECE(STR,"|"),!
+22 FOR SEG=2:1:$LENGTH(STR,"|")
Begin DoDot:2
+23 SET SUBSEG=$$TRIM^XLFSTR($PIECE(STR,"|",SEG),"LR"," ")
+24 IF $LENGTH(SUBSEG)<1
QUIT
+25 WRITE ?4,$JUSTIFY((SEG-1),2),")"
+26 IF $LENGTH(SUBSEG)<60
WRITE ?14,SUBSEG,!
+27 IF $LENGTH(SUBSEG)>59
DO LINEWRAP^BLRGMENU(14,SUBSEG,60)
WRITE !
End DoDot:2
+28 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
+29 ;
+30 IF QFLG'="Q"
Begin DoDot:1
+31 WRITE !!,?4,"All sequences have been displayed."
+32 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
+33 ;
+34 QUIT
+35 ;
HEAD6249(IEN) ; EP - Display variables in header of File 62.49
+1 DO ^XBFMK
+2 SET DIC="^LAHM(62.49,"
SET DA=IEN
SET DIQ(0)="CR"
SET DR="0:100"
+3 DO EN^DIQ
+4 ;
+5 QUIT
+6 ;
ENDMESG(TEXT) ; EP - Ending Message
+1 WRITE !,?4,TEXT
+2 DO PRESSKEY^BLRGMENU(9)
+3 QUIT
+4 ;
F6249UID() ; EP - Get UIDs from 62.49 & setup DIR call for user to select one
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 SET DIRZERO="SO^"
+4 SET (CNT,ENTRY)=0
+5 ;
+6 SET IEN="A"
+7 FOR
SET IEN=$ORDER(^LAHM(62.49,IEN),-1)
IF IEN<1
QUIT
Begin DoDot:1
+8 SET TYPEMSG=$PIECE($GET(^LAHM(62.49,IEN,0)),"^",2)
+9 ;
+10 SET SEG=0
SET STR=""
+11 FOR
SET SEG=$ORDER(^LAHM(62.49,IEN,150,SEG))
IF SEG<1
QUIT
Begin DoDot:2
+12 SET STR=$GET(^LAHM(62.49,IEN,150,SEG,0))
+13 IF $PIECE(STR,"|")'="OBR"
QUIT
+14 ;
+15 SET LRUID=$PIECE($PIECE(STR,"|",3),"^")
+16 IF $LENGTH(LRUID)<1
QUIT
+17 ;
+18 ; Make certain entry only shows once
+19 IF $DATA(UNIQUE(IEN))
QUIT
+20 SET UNIQUE(IEN)=""
+21 ;
+22 SET X=$QUERY(^LRO(68,"C",LRUID,0))
SET LRAA=+$QSUBSCRIPT(X,4)
SET LRAD=+$QSUBSCRIPT(X,5)
SET LRAN=+$QSUBSCRIPT(X,6)
+23 ; If no Accession, skip
IF LRAA<1!(LRAD<1)!(LRAN<1)
QUIT
+24 ;
+25 SET IENSTR=LRAN_","_LRAD_","_LRAA_","
+26 SET LRAS=$$GET1^DIQ(68.02,IENSTR,"ACCESSION")
+27 SET CNT=CNT+1
+28 SET DIRZERO=DIRZERO_CNT_":"_LRUID_";"
+29 SET DIRZERO(CNT)=$$LJ^XLFSTR($JUSTIFY(CNT,2)_") "_$$LJ^XLFSTR(LRUID,11)_LRAS,27)
+30 SET LUIDINDX(CNT)=LRUID_U_LRAA_U_LRAD_U_LRAN_U_LRAS_U_IEN
End DoDot:2
End DoDot:1
+31 SET CNT=CNT+1
+32 SET DIRZERO=DIRZERO_(CNT)_":AL"
+33 ;
+34 IF $DATA(LUIDINDX)<1
Begin DoDot:1
+35 WRITE !!,?4,"No matching UID Entries found in the LA7 MESSAGE QUEUE (#62.49) file."
+36 DO PRESSKEY^BLRGMENU(9)
+37 SET LREND=1
End DoDot:1
QUIT 0
+38 ;
+39 SET NUMCOL=3
+40 KILL LRUID
+41 DO ^XBFMK
+42 SET DIR(0)=DIRZERO
+43 SET DIR("L",1)=" UID Accession UID Accession UID Accession"
+44 SET DIR("L",2)=" ---------- ----------- ---------- ----------- ---------- ----------"
+45 SET BELOW=3
+46 SET CNT=0
+47 FOR
SET CNT=$ORDER(DIRZERO(CNT))
IF CNT<1
QUIT
Begin DoDot:1
+48 IF (CNT#NUMCOL)=1
SET DIR("L",BELOW)=""
+49 SET DIR("L",BELOW)=$GET(DIR("L",BELOW))_$SELECT((CNT#NUMCOL)=0:$$TRIM^XLFSTR(DIRZERO(CNT),"R"," "),1:DIRZERO(CNT))
+50 IF (CNT#NUMCOL)=0
SET BELOW=BELOW+1
End DoDot:1
+51 ;
+52 SET DIR("L")=""
+53 ; Change default prompt
SET DIR("A")="Select number"
+54 ;
+55 SET HEADER(1)="LA7 MESSAGE QUEUE (#62.49) File"
+56 SET HEADER(2)="UID Selection"
+57 ;
+58 DO HEADERDT^BLRGMENU
+59 ;
+60 DO ^DIR
+61 IF +Y<1!(+$GET(DIRUT))
Begin DoDot:1
+62 WRITE !,?4,"No/Invalid Entry. Routine Ends."
+63 DO PRESSKEY^BLRGMENU(9)
+64 SET LREND=1
End DoDot:1
QUIT 0
+65 ;
+66 QUIT $GET(LUIDINDX(+$GET(Y)))
+67 ;
SETBLRVS(TWO) ; EP - Set BLRVERN variable(s)
+1 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+2 IF $LENGTH($GET(TWO))
SET BLRVERN2=TWO
+3 QUIT
