BLR6249R ; IHS/MSC/MKK - LA7 MESSAGE QUEUE incoming messages only Report ; [ February 29, 2012 8:00 AM ]
;;5.2;LAB SERVICE;**1031**;Nov 1, 1997
;
EEP ; Ersatz EP
D EEP^BLRGMENU
Q
;
EP ; EP
PEP ; EP
NEW CNT,IEN,IEN2,IEN3,STR
NEW BLRVERN,HD1,HEADER,LINES,MAXLINES,PG,QFLG
NEW INSTR,LRAA,LRAD,LRAN,LRAS,ENTRYDTT,MSGNUM,STATUS,UID
NEW LRANYAA,LRLL,LRPROF,REFLABIN
;
D INITVARS
;
F S IEN=$O(^LAHM(62.49,IEN)) Q:IEN<1!(QFLG="Q") D
. Q:$P($G(^LAHM(62.49,IEN,0)),"^",2)'="I" ; Only Incoming messages
. Q:$P($G(^LAHM(62.49,IEN,0)),"^",3)="X" ; Only Non-Purgeable messages
. ;
. D PRNTLINE
;
W:CNT>0 !,?4,"Number of Non-Purgeable, Incoming messages = ",CNT,!
;
D ^%ZISC
;
I CNT<1 D
. W $J("",20),$C(13)
. W !,?9,"No Messages in 62.49",!
;
D PRESSKEY^BLRGMENU(4)
Q
;
INITVARS ; EP - Initialization
S BLRVERN=$$TRIM^XLFSTR($P($T(+1),";"),"R"," ")
;
S REFLABIN=$$GET1^DIQ(9009029,DUZ(2),3001)
;
S HEADER(1)="LA7 MESSAGE QUEUE (#62.49) File"
S HEADER(2)=REFLABIN_" Incoming Messages"
S HEADER(3)=$$CJ^XLFSTR("Non-Purgeable Statuses Only",IOM)
S HEADER(4)=" "
;
D HEADONE(.HD1)
;
S HEADER(5)="Msg #"
S $E(HEADER(5),9)="STS"
S $E(HEADER(5),14)="UID"
S $E(HEADER(5),26)="Accession"
S $E(HEADER(5),46)="Entry Date/Time"
S $E(HEADER(5),67)="Instrument"
;
S IEN=.9999999,(CNT,INCNT,OUTCNT)=0
S (PG,WOT)=0
;
S QFLG="N"
;
D ^%ZIS
U IO
S MAXLINES=IOSL-4
S LINES=MAXLINES+10
Q
;
HEADONE(HD1) ; EP -- Asks if user wants only 1 header line
D HEADERDT^BLRGMENU
;
D ^XBFMK
S DIR("A")="One Header Line ONLY"
S DIR("B")="NO"
S DIR(0)="YO"
D ^DIR
S HD1=$S(+$G(Y)=1:"YES",1:"NO")
D ^XBFMK
D HEADERDT^BLRGMENU
Q
;
PRNTLINE ; EP - Print a line of data
D BREAKOUT
;
Q:INSTR'=REFLABIN ; Only messages for Reference Lab
;
I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HD1) Q:QFLG="Q"
;
W MSGNUM
W ?9,STATUS
W ?13,UID
W ?25,LRAS
W ?45,ENTRYDTT
W ?66,$E(INSTR,1,14)
W !
S LINES=LINES+1
S CNT=CNT+1
;
Q
;
BREAKOUT ; EP - "Break Out" variables
NEW IEN2,STR,X
;
S STR=$G(^LAHM(62.49,IEN,0))
;
S MSGNUM=$P(STR,"^",1)
S STATUS=$P(STR,"^",3)
S X=$$UP^XLFSTR($$FMTE^XLFDT($P(STR,"^",5),"5MPZ"))
S INSTR=$P($P(STR,"^",6),"-")
S ENTRYDTT=$P(X," ")_$$RJ^XLFSTR($P(X," ",2,3),9)
;
S UID=0,IEN2=.9999999
F S IEN2=$O(^LAHM(62.49,IEN,150,IEN2)) Q:IEN2<1!(UID) D
. Q:$G(^LAHM(62.49,IEN,150,IEN2,0))'["OBR"
. ;
. S UID=$TR($$LJ^XLFSTR(+$RE(+$RE($P($G(^LAHM(62.49,IEN,150,IEN2,0)),"|",3))),10)," ","0")
;
I UID<1 S (UID,LRAS)="" Q
;
S LRAA=+$O(^LRO(68,"C",UID,0))
S LRAD=+$O(^LRO(68,"C",UID,LRAA,0))
S LRAN=+$O(^LRO(68,"C",UID,LRAA,LRAD,0))
;
S LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
;
Q
;
ONELRASR ; EP - Report on 1 Accession: INCOMING and OUTGOING messages
NEW BLRVERN,HD1,HEADER,LINES,MAXLINES,PG,QFLG
NEW CNT,DAYSAGO2,ENTRYDT,CNTINCOM,HEADER,INDEXDT,INSTALLN,INSTLLDT
NEW INSTR,LABPATCH,LRAS,LRODT,MAX,OBRCNT,OBRSTR,OBRTXN,STATUS,STR,TXN,TXNCNT,TYPE
;
Q:$$ONELRASI()="Q"
;
F S INDEXDT=$O(^LAHM(62.49,"AD",INDEXDT)) Q:INDEXDT=""!(CNT>MAX) D
. F S TXN=$O(^LAHM(62.49,"AD",INDEXDT,TXN)) Q:TXN=""!(TXN'?.N)!(CNT>MAX) D
.. D TXNVARS
.. F S OBRTXN=$O(^LAHM(62.49,TXN,150,OBRTXN)) Q:OBRTXN<1!(CNT>MAX)!($L(OBRLRAS)>0) D
... D ONELRASL
;
W:INDEXDT=""!(CNT>MAX) !!,?4,"Number of Transactions:",TXNCNT,!
W:OBRCNT>0&((INDEXDT="")!(CNT>MAX)) ?9,"Number of TXNs with OBR Segments:",OBRCNT,!!
Q
;
ONELRASI() ; EP - Initialization of variables
S BLRVERN=$$TRIM^XLFSTR($P($T(+1),";"),"R"," ")
;
W !!
D ^LRWU4
S LRAS=$G(^LRO(68,+LRAA,1,+LRAD,1,+LRAN,.2))
;
I $L(LRAS)<1 D Q 0
. W !!,?4,"Accession Does not Exist.. Routine Ends."
. D PRESSKEY^BLRGMENU(9)
;
S HEADER(1)="LA7 Message Queue (#62.49)"
S HEADER(2)="Accession "_LRAS_" Transactions"
S HEADER(3)=" "
S HEADER(4)="Txn"
S $E(HEADER(4),10)="EntryDt"
S $E(HEADER(4),20)="Instrument"
S $E(HEADER(4),35)="Type"
S $E(HEADER(4),40)="STS"
S $E(HEADER(4),45)="PID"
S $E(HEADER(4),55)="DFN"
S $E(HEADER(4),65)="LogP"
S $E(HEADER(4),75)="OrdL"
;
S MAXLINES=IOSL-4,LINES=MAXLINES+10,(NOPG,QFLG)="N"
S INDEXDT=.9999999
S TXN=0
K INSTR,OBRLRAS
S (CNT,CNTINCOM,OBRCNT,TXN,TXNCNT)=0
S MAX=9999
Q 1
;
TXNVARS ; EP - Setup variables at TXN level
S TXNCNT=TXNCNT+1
S STR=$G(^LAHM(62.49,TXN,0))
S TYPE=$P(STR,"^",2)
S STATUS=$P(STR,"^",3)
S ENTRYDT=$P(STR,"^",5)
S INSTR=$P($P(STR,"^",6),"-",1)
S CNTINCOM=1+CNTINCOM
S PID=$P($G(^LAHM(62.49,TXN,150,2,0)),"|",4)
S OBRLRAS=""
S OBRTXN=0
Q
;
ONELRASL ; EP - Write a line of data
S OBRSTR=$G(^LAHM(62.49,TXN,150,OBRTXN,0))
Q:$P(OBRSTR,"|",1)'="OBR"
;
S OBRCNT=1+$G(OBRCNT)
S OBRLRAS=$P($P(OBRSTR,"|",17),"^",6)
S:$L(OBRLRAS)<1 OBRLRAS=$P($P(OBRSTR,"|",20),"^",6)
Q:OBRLRAS'=LRAS
;
D ONELRASB
;
I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,NOPG) Q:QFLG="Q"
;
W TXN
W ?9,$P(ENTRYDT,".")
W ?19,$E(INSTR,1,13)
W ?35,TYPE
W ?40,$E(STATUS,1)
W ?44,PID
W ?54,DFN
W ?64,LOGINP
W ?74,ORDLOC
W !
S CNT=CNT+1
Q
;
ONELRASB ; EP - Break out variables
S STROBR=OBRSTR
S:$G(OBRLRAS)=""&($P(OBRSTR,"|",1)="OBR") OBRLRAS=$P($P(OBRSTR,"|",20),"^",6)
S X=$$GETACCCP^BLRUTIL3(OBRLRAS,.LRAA,.LRAD,.LRAN)
S STR=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
S LRDFN=$P(STR,"^")
S PROV=$P(STR,"^",8)
S LOGINP=$P(STR,"^",10)
S ORDLOC=$P(STR,"^",13)
S DFN=$P($G(^LR(LRDFN,0)),"^",3)
Q
BLR6249R ; IHS/MSC/MKK - LA7 MESSAGE QUEUE incoming messages only Report ; [ February 29, 2012 8:00 AM ]
+1 ;;5.2;LAB SERVICE;**1031**;Nov 1, 1997
+2 ;
EEP ; Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
EP ; EP
PEP ; EP
+1 NEW CNT,IEN,IEN2,IEN3,STR
+2 NEW BLRVERN,HD1,HEADER,LINES,MAXLINES,PG,QFLG
+3 NEW INSTR,LRAA,LRAD,LRAN,LRAS,ENTRYDTT,MSGNUM,STATUS,UID
+4 NEW LRANYAA,LRLL,LRPROF,REFLABIN
+5 ;
+6 DO INITVARS
+7 ;
+8 FOR
SET IEN=$ORDER(^LAHM(62.49,IEN))
IF IEN<1!(QFLG="Q")
QUIT
Begin DoDot:1
+9 ; Only Incoming messages
IF $PIECE($GET(^LAHM(62.49,IEN,0)),"^",2)'="I"
QUIT
+10 ; Only Non-Purgeable messages
IF $PIECE($GET(^LAHM(62.49,IEN,0)),"^",3)="X"
QUIT
+11 ;
+12 DO PRNTLINE
End DoDot:1
+13 ;
+14 IF CNT>0
WRITE !,?4,"Number of Non-Purgeable, Incoming messages = ",CNT,!
+15 ;
+16 DO ^%ZISC
+17 ;
+18 IF CNT<1
Begin DoDot:1
+19 WRITE $JUSTIFY("",20),$CHAR(13)
+20 WRITE !,?9,"No Messages in 62.49",!
End DoDot:1
+21 ;
+22 DO PRESSKEY^BLRGMENU(4)
+23 QUIT
+24 ;
INITVARS ; EP - Initialization
+1 SET BLRVERN=$$TRIM^XLFSTR($PIECE($TEXT(+1),";"),"R"," ")
+2 ;
+3 SET REFLABIN=$$GET1^DIQ(9009029,DUZ(2),3001)
+4 ;
+5 SET HEADER(1)="LA7 MESSAGE QUEUE (#62.49) File"
+6 SET HEADER(2)=REFLABIN_" Incoming Messages"
+7 SET HEADER(3)=$$CJ^XLFSTR("Non-Purgeable Statuses Only",IOM)
+8 SET HEADER(4)=" "
+9 ;
+10 DO HEADONE(.HD1)
+11 ;
+12 SET HEADER(5)="Msg #"
+13 SET $EXTRACT(HEADER(5),9)="STS"
+14 SET $EXTRACT(HEADER(5),14)="UID"
+15 SET $EXTRACT(HEADER(5),26)="Accession"
+16 SET $EXTRACT(HEADER(5),46)="Entry Date/Time"
+17 SET $EXTRACT(HEADER(5),67)="Instrument"
+18 ;
+19 SET IEN=.9999999
SET (CNT,INCNT,OUTCNT)=0
+20 SET (PG,WOT)=0
+21 ;
+22 SET QFLG="N"
+23 ;
+24 DO ^%ZIS
+25 USE IO
+26 SET MAXLINES=IOSL-4
+27 SET LINES=MAXLINES+10
+28 QUIT
+29 ;
HEADONE(HD1) ; EP -- Asks if user wants only 1 header line
+1 DO HEADERDT^BLRGMENU
+2 ;
+3 DO ^XBFMK
+4 SET DIR("A")="One Header Line ONLY"
+5 SET DIR("B")="NO"
+6 SET DIR(0)="YO"
+7 DO ^DIR
+8 SET HD1=$SELECT(+$GET(Y)=1:"YES",1:"NO")
+9 DO ^XBFMK
+10 DO HEADERDT^BLRGMENU
+11 QUIT
+12 ;
PRNTLINE ; EP - Print a line of data
+1 DO BREAKOUT
+2 ;
+3 ; Only messages for Reference Lab
IF INSTR'=REFLABIN
QUIT
+4 ;
+5 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,HD1)
IF QFLG="Q"
QUIT
+6 ;
+7 WRITE MSGNUM
+8 WRITE ?9,STATUS
+9 WRITE ?13,UID
+10 WRITE ?25,LRAS
+11 WRITE ?45,ENTRYDTT
+12 WRITE ?66,$EXTRACT(INSTR,1,14)
+13 WRITE !
+14 SET LINES=LINES+1
+15 SET CNT=CNT+1
+16 ;
+17 QUIT
+18 ;
BREAKOUT ; EP - "Break Out" variables
+1 NEW IEN2,STR,X
+2 ;
+3 SET STR=$GET(^LAHM(62.49,IEN,0))
+4 ;
+5 SET MSGNUM=$PIECE(STR,"^",1)
+6 SET STATUS=$PIECE(STR,"^",3)
+7 SET X=$$UP^XLFSTR($$FMTE^XLFDT($PIECE(STR,"^",5),"5MPZ"))
+8 SET INSTR=$PIECE($PIECE(STR,"^",6),"-")
+9 SET ENTRYDTT=$PIECE(X," ")_$$RJ^XLFSTR($PIECE(X," ",2,3),9)
+10 ;
+11 SET UID=0
SET IEN2=.9999999
+12 FOR
SET IEN2=$ORDER(^LAHM(62.49,IEN,150,IEN2))
IF IEN2<1!(UID)
QUIT
Begin DoDot:1
+13 IF $GET(^LAHM(62.49,IEN,150,IEN2,0))'["OBR"
QUIT
+14 ;
+15 SET UID=$TRANSLATE($$LJ^XLFSTR(+$REVERSE(+$REVERSE($PIECE($GET(^LAHM(62.49,IEN,150,IEN2,0)),"|",3))),10)," ","0")
End DoDot:1
+16 ;
+17 IF UID<1
SET (UID,LRAS)=""
QUIT
+18 ;
+19 SET LRAA=+$ORDER(^LRO(68,"C",UID,0))
+20 SET LRAD=+$ORDER(^LRO(68,"C",UID,LRAA,0))
+21 SET LRAN=+$ORDER(^LRO(68,"C",UID,LRAA,LRAD,0))
+22 ;
+23 SET LRAS=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
+24 ;
+25 QUIT
+26 ;
ONELRASR ; EP - Report on 1 Accession: INCOMING and OUTGOING messages
+1 NEW BLRVERN,HD1,HEADER,LINES,MAXLINES,PG,QFLG
+2 NEW CNT,DAYSAGO2,ENTRYDT,CNTINCOM,HEADER,INDEXDT,INSTALLN,INSTLLDT
+3 NEW INSTR,LABPATCH,LRAS,LRODT,MAX,OBRCNT,OBRSTR,OBRTXN,STATUS,STR,TXN,TXNCNT,TYPE
+4 ;
+5 IF $$ONELRASI()="Q"
QUIT
+6 ;
+7 FOR
SET INDEXDT=$ORDER(^LAHM(62.49,"AD",INDEXDT))
IF INDEXDT=""!(CNT>MAX)
QUIT
Begin DoDot:1
+8 FOR
SET TXN=$ORDER(^LAHM(62.49,"AD",INDEXDT,TXN))
IF TXN=""!(TXN'?.N)!(CNT>MAX)
QUIT
Begin DoDot:2
+9 DO TXNVARS
+10 FOR
SET OBRTXN=$ORDER(^LAHM(62.49,TXN,150,OBRTXN))
IF OBRTXN<1!(CNT>MAX)!($LENGTH(OBRLRAS)>0)
QUIT
Begin DoDot:3
+11 DO ONELRASL
End DoDot:3
End DoDot:2
End DoDot:1
+12 ;
+13 IF INDEXDT=""!(CNT>MAX)
WRITE !!,?4,"Number of Transactions:",TXNCNT,!
+14 IF OBRCNT>0&((INDEXDT="")!(CNT>MAX))
WRITE ?9,"Number of TXNs with OBR Segments:",OBRCNT,!!
+15 QUIT
+16 ;
ONELRASI() ; EP - Initialization of variables
+1 SET BLRVERN=$$TRIM^XLFSTR($PIECE($TEXT(+1),";"),"R"," ")
+2 ;
+3 WRITE !!
+4 DO ^LRWU4
+5 SET LRAS=$GET(^LRO(68,+LRAA,1,+LRAD,1,+LRAN,.2))
+6 ;
+7 IF $LENGTH(LRAS)<1
Begin DoDot:1
+8 WRITE !!,?4,"Accession Does not Exist.. Routine Ends."
+9 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT 0
+10 ;
+11 SET HEADER(1)="LA7 Message Queue (#62.49)"
+12 SET HEADER(2)="Accession "_LRAS_" Transactions"
+13 SET HEADER(3)=" "
+14 SET HEADER(4)="Txn"
+15 SET $EXTRACT(HEADER(4),10)="EntryDt"
+16 SET $EXTRACT(HEADER(4),20)="Instrument"
+17 SET $EXTRACT(HEADER(4),35)="Type"
+18 SET $EXTRACT(HEADER(4),40)="STS"
+19 SET $EXTRACT(HEADER(4),45)="PID"
+20 SET $EXTRACT(HEADER(4),55)="DFN"
+21 SET $EXTRACT(HEADER(4),65)="LogP"
+22 SET $EXTRACT(HEADER(4),75)="OrdL"
+23 ;
+24 SET MAXLINES=IOSL-4
SET LINES=MAXLINES+10
SET (NOPG,QFLG)="N"
+25 SET INDEXDT=.9999999
+26 SET TXN=0
+27 KILL INSTR,OBRLRAS
+28 SET (CNT,CNTINCOM,OBRCNT,TXN,TXNCNT)=0
+29 SET MAX=9999
+30 QUIT 1
+31 ;
TXNVARS ; EP - Setup variables at TXN level
+1 SET TXNCNT=TXNCNT+1
+2 SET STR=$GET(^LAHM(62.49,TXN,0))
+3 SET TYPE=$PIECE(STR,"^",2)
+4 SET STATUS=$PIECE(STR,"^",3)
+5 SET ENTRYDT=$PIECE(STR,"^",5)
+6 SET INSTR=$PIECE($PIECE(STR,"^",6),"-",1)
+7 SET CNTINCOM=1+CNTINCOM
+8 SET PID=$PIECE($GET(^LAHM(62.49,TXN,150,2,0)),"|",4)
+9 SET OBRLRAS=""
+10 SET OBRTXN=0
+11 QUIT
+12 ;
ONELRASL ; EP - Write a line of data
+1 SET OBRSTR=$GET(^LAHM(62.49,TXN,150,OBRTXN,0))
+2 IF $PIECE(OBRSTR,"|",1)'="OBR"
QUIT
+3 ;
+4 SET OBRCNT=1+$GET(OBRCNT)
+5 SET OBRLRAS=$PIECE($PIECE(OBRSTR,"|",17),"^",6)
+6 IF $LENGTH(OBRLRAS)<1
SET OBRLRAS=$PIECE($PIECE(OBRSTR,"|",20),"^",6)
+7 IF OBRLRAS'=LRAS
QUIT
+8 ;
+9 DO ONELRASB
+10 ;
+11 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,NOPG)
IF QFLG="Q"
QUIT
+12 ;
+13 WRITE TXN
+14 WRITE ?9,$PIECE(ENTRYDT,".")
+15 WRITE ?19,$EXTRACT(INSTR,1,13)
+16 WRITE ?35,TYPE
+17 WRITE ?40,$EXTRACT(STATUS,1)
+18 WRITE ?44,PID
+19 WRITE ?54,DFN
+20 WRITE ?64,LOGINP
+21 WRITE ?74,ORDLOC
+22 WRITE !
+23 SET CNT=CNT+1
+24 QUIT
+25 ;
ONELRASB ; EP - Break out variables
+1 SET STROBR=OBRSTR
+2 IF $GET(OBRLRAS)=""&($PIECE(OBRSTR,"|",1)="OBR")
SET OBRLRAS=$PIECE($PIECE(OBRSTR,"|",20),"^",6)
+3 SET X=$$GETACCCP^BLRUTIL3(OBRLRAS,.LRAA,.LRAD,.LRAN)
+4 SET STR=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
+5 SET LRDFN=$PIECE(STR,"^")
+6 SET PROV=$PIECE(STR,"^",8)
+7 SET LOGINP=$PIECE(STR,"^",10)
+8 SET ORDLOC=$PIECE(STR,"^",13)
+9 SET DFN=$PIECE($GET(^LR(LRDFN,0)),"^",3)
+10 QUIT
