BLRAAORR ;IHS/OIT/MKK - IHS LAB ASK-AT-ORDER REPORTS ; JUL 06, 2011 3:15 PM
;;5.2;IHS LABORATORY;**1030**;NOV 01, 1997
;
Q
;
DATAREPT ; EP - Report on Data Global
NEW ANSWER,CANCEL,CNT,EHDT,HDT,LRAS,LRODT,LRSP,P60,ORD,LRORDN
NEW BLRVERN,BLRVERN2,HEADER,HD1,LINES,LINEWRAP,MAXLINES,PG,QFLG,WRAPLINE
;
D DATARPTI
;
F S LRODT=$O(^BLRAAOQD(LRODT)) Q:LRODT<1!(QFLG="Q") D
. F S LRSP=$O(^BLRAAOQD(LRODT,LRSP)) Q:LRSP<1!(QFLG="Q") D
.. F S P60=$O(^BLRAAOQD(LRODT,LRSP,P60)) Q:P60<1!(QFLG="Q") D
... F S ORD=$O(^BLRAAOQD(LRODT,LRSP,P60,ORD)) Q:ORD<1!(QFLG="Q") D
.... D DATARPTL
.. W !
.. S LINES=LINES+1
;
D:CNT<1 EMPTYDB("No Data in Lab Ask-At-Order Data file.")
;
D PRESSKEY^BLRGMENU(4)
Q
;
DATARPTI ; EP - Initialize variables
S BLRVERN=$P($P($T(+1),";")," ")
S BLRVERN2="DATAREPT"
;
S HEADER(1)="Lab Ask At Order Questions"
S HEADER(2)="Non Accessioned Responses"
S HEADER(3)=" "
;
S HEADER(4)="Order #"
S $E(HEADER(4),10)="Test IEN"
S $E(HEADER(4),20)="Question"
S $E(HEADER(4),51)="Answer"
S $E(HEADER(4),65)="Date/Time Answrd"
;
S MAXLINES=20,LINES=MAXLINES+10,PG=0,(HD1,QFLG)="NO"
;
S (CNT,LRODT,LRSP,P60,ORD)=0
Q
;
DATARPTL ; EP - Write a line of data
I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HD1) Q:QFLG="Q"
;
D DATARPTB(29)
;
W LRORDN ; File 69: Order Number
W ?8,CANCEL
W ?9,P60 ; File 60: IEN
W ?19,LINEWRAP(1) ; Question - Line 1
W ?50,ANSWER
W ?64,EHDT ; Date/Time Question Answered
W !
S LINES=LINES+1
S CNT=CNT+1
;
D MULTLINE(19)
;
Q
;
DATARPTB(MAXCOL) ; EP - Breakout Variables from global
NEW GLOSTR,STR,TSTORD
NEW LRAA,LRAD,LRAN,STR,TST,TEST
;
K LRORDN,LINEWRAP,ANSWER,EHDT,HDT
;
S LRAS=""
S TST=0
F S TST=$O(^LRO(69,LRODT,1,LRSP,2,TST)) Q:TST!($L(LRAS)) D
. S STR=$G(^LRO(69,LRODT,1,LRSP,2,TST,0))
. Q:+$G(STR)'=P60
. ;
. S LRAD=$P(STR,"^",4),LRAA=$P(STR,"^",3),LRAN=$P(STR,"^",5)
. S LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
;
S LRORDN=$G(^LRO(69,LRODT,1,LRSP,.1))
;
S GLOSTR=$G(^BLRAAOQD(LRODT,LRSP,P60,ORD))
S ANSWER=$P(GLOSTR,"^",2)
S HDT=$P(GLOSTR,"^",3)
S EHDT=$$HTE^XLFDT(HDT,"5MZ")
;
S STR(1)=$P(GLOSTR,"^",1)
I $L($G(STR(1)))<MAXCOL S LINEWRAP(1)=STR(1) Q
;
; Question too long; have to create multiple lines
D WRAP(.STR,MAXCOL,.LINEWRAP)
;
S CANCEL=""
; Determine if Test has been cancelled
S TSTORD=.9999999
F S TSTORD=$O(^LRO(69,LRODT,1,LRSP,2,TSTORD)) Q:TSTORD<1 D
. Q:+$G(^LRO(69,LRODT,1,LRSP,2,TSTORD,0))'=P60
. ;
. S:+$P($G(^LRO(69,LRODT,1,LRSP,2,TSTORD,0)),"^",11)>0 CANCEL="*"
;
Q
;
DATARPTA ; EP - Report on Data Global - Accession Number, not Test IEN
NEW ANSWER,CANCEL,CNT,EHDT,HDT,LRODT,LRAS,LRSP,P60,ORD,LRORDN
NEW BLRVERN,BLRVERN2,HEADER,HD1,LINES,LINEWRAP,MAXLINES,PG,QFLG,WRAPLINE
;
D DATRPTAI
;
F S LRODT=$O(^BLRAAOQD(LRODT)) Q:LRODT<1!(QFLG="Q") D
. F S LRSP=$O(^BLRAAOQD(LRODT,LRSP)) Q:LRSP<1!(QFLG="Q") D
.. F S P60=$O(^BLRAAOQD(LRODT,LRSP,P60)) Q:P60<1!(QFLG="Q") D
... F S ORD=$O(^BLRAAOQD(LRODT,LRSP,P60,ORD)) Q:ORD<1!(QFLG="Q") D
.... D DATRPTAL
.. W !
.. S LINES=LINES+1
;
D:CNT<1 EMPTYDB("No Data in Lab Ask-At-Order Data file.")
;
D PRESSKEY^BLRGMENU(4)
Q
;
DATRPTAI ; EP - Initialize variables
S BLRVERN=$P($P($T(+1),";")," ")
S BLRVERN2="DATAREPT"
;
S HEADER(1)="Lab Ask At Order Questions"
S HEADER(2)="Non Accessioned Responses"
S HEADER(3)=" "
;
S HEADER(4)="Order #"
S $E(HEADER(4),10)="Accession Number"
S $E(HEADER(4),30)="Question"
S $E(HEADER(4),51)="Answer"
S $E(HEADER(4),65)="Date/Time Answrd"
;
S MAXLINES=20,LINES=MAXLINES+10,PG=0,(HD1,QFLG)="NO"
;
S (CNT,LRODT,LRSP,P60,ORD)=0
Q
;
DATRPTAL ; EP - Write a line of data
I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HD1) Q:QFLG="Q"
;
D DATARPTB(19)
;
W LRORDN ; File 69: Order Number
W ?8,CANCEL
W ?9,LRAS ; Accession Number
W ?29,LINEWRAP(1) ; Question - Line 1
W ?50,ANSWER
W ?64,EHDT ; Date/Time Question Answered
W !
S LINES=LINES+1
S CNT=CNT+1
;
D MULTLINE(29)
;
Q
;
EMPTYDB(MSG) ; EP - Empty DB Message
K HEADER(3),HEADER(4)
D HEADERDT^BLRGMENU
W !!,?9,MSG,!
Q
;
; Cloned from LR7OSAP1. Wrap Text in array ROOT to PUTIT array
WRAP(ROOT,FMT,PUTIT) ; EP - Wrap text
I '$L($G(ROOT(1))) Q
N CCNT,GCNT,INC,LRI,LRINDX,LRTX,SP,X
S:'$G(FMT) FMT=79
S LRINDX=0,LRI=0,GCNT=0
F S LRI=$O(ROOT(LRI)) Q:LRI'>0 D
. S X=$S($L($G(ROOT(LRI))):ROOT(LRI),$L($G(ROOT(LRI,0))):ROOT(LRI,0),1:""),LRINDX=LRINDX+1
. S X=$$FMT^LR7OSAP1(FMT,.LRINDX,X)
S LRI=0
F S LRI=$O(LRTX(LRI)) Q:'LRI D LN^LR7OSAP S PUTIT(GCNT)=$$S^LR7OS(1,CCNT,LRTX(LRI))
Q
;
MULTLINE(TAB) ; EP - Answer too long for one line; print rest of lines.
S WRAPLINE=1
F S WRAPLINE=$O(LINEWRAP(WRAPLINE)) Q:WRAPLINE<1 D
. W ?TAB,LINEWRAP(WRAPLINE),!
. S LINES=LINES+1
;
Q
;
ERRSREPT ; EP - Report on Errors Global
NEW ANSWER,CNT,EHDT,ERRSMSG,HDT,LRDFN,LRIDT,LRODT,LRSP,P60,ORD,LRORDN
NEW BLRVERN,BLRVERN2,HEADER,HD1,LINES,LINEWRAP,MAXLINES,PG,QFLG,WRAPLINE
;
D ERSSRPTI
;
F S LRDFN=$O(^BLRAAORE(LRDFN)) Q:LRDFN<1!(QFLG="Q") D
. F S LRIDT=$O(^BLRAAORE(LRDFN,LRIDT)) Q:LRIDT<1!(QFLG="Q") D
.. F S LRODT=$O(^BLRAAORE(LRDFN,LRIDT,LRODT)) Q:LRODT<1!(QFLG="Q") D
... F S LRSP=$O(^BLRAAORE(LRDFN,LRIDT,LRODT,LRSP)) Q:LRSP<1!(QFLG="Q") D
.... F S P60=$O(^BLRAAORE(LRDFN,LRIDT,LRODT,LRSP,P60)) Q:P60<1!(QFLG="Q") D
..... F S ORD=$O(^BLRAAORE(LRDFN,LRIDT,LRODT,LRSP,P60,ORD)) Q:ORD<1!(QFLG="Q") D
...... D ERSSRPTL
;
D:CNT<1 EMPTYDB("No Data in Errors Database.")
;
D PRESSKEY^BLRGMENU(4)
Q
;
S BLRVERN=$P($P($T(+1),";")," ")
S BLRVERN2="DATAREPT"
;
S HEADER(1)="Lab Ask At Order Questions"
S HEADER(2)="Transactions With Errors"
S HEADER(3)=" "
;
S HEADER(4)="LRDFN"
S $E(HEADER(4),10)="LRIDT"
S $E(HEADER(4),27)="LRODT"
S $E(HEADER(4),37)="LRSP"
S $E(HEADER(4),43)="Test IEN"
S $E(HEADER(4),53)="Ord"
S $E(HEADER(4),58)="Error Message"
;
S MAXLINES=22,LINES=MAXLINES+10,PG=0,(HD1,QFLG)="NO"
;
S (CNT,LRDFN,LRIDT,LRODT,LRSP,P60,ORD)=0
Q
;
I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HD1) Q:QFLG="Q"
;
S ERRMSG=$G(^BLRAAORE(LRDFN,LRIDT,LRODT,LRSP,P60,ORD,"DIERR",1))
;
W LRDFN
W ?9,LRIDT
W ?26,LRODT
W ?36,LRSP
W ?42,P60
W ?52,ORD
W ?57,$E(ERRMSG,1,23)
W !
S LINES=LINES+1
S CNT=CNT+1
;
Q
;
ORDNREPT(LRORD) ; EP -- Report on Lab Data File Ask at Order questions given Lab Order Number
NEW LINE,LINEWRAP,LRAA,LRAD,LRAN,LRAS,LRIDT,LRODT,LRSP,PTR,STR,TST
NEW HD1,HEADER,LINES,MAXLINES,PG,QFLG
;
D ORDNRPTI
;
S LRODT=.9999999
F S LRODT=$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1!(QFLG="Q") D
. S LRSP=.9999999
. F S LRSP=$O(^LRO(69,"C",LRORD,LRODT,LRSP)) Q:LRSP<1!(QFLG="Q") D
.. S TST=.999999
.. F S TST=$O(^LRO(69,LRODT,1,LRSP,2,TST)) Q:TST<1!(QFLG="Q") D
... S STR=$G(^LRO(69,LRODT,1,LRSP,2,TST,0))
... S LRAD=+$P(STR,"^",3),LRAA=+$P(STR,"^",4),LRAN=+$P(STR,"^",5)
... S LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
... Q:$L(LRAS)<1
... ;
... S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
... S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
... ;
... Q:LRDFN<1!(LRIDT<1)
... ;
... S LINE=0
... F S LINE=$O(^LR(LRDFN,"CH",LRIDT,1,LINE)) Q:LINE<1!(QFLG="Q") D
.... S STR=$$TRIM^XLFSTR($G(^LR(LRDFN,"CH",LRIDT,1,LINE,0)),"LR"," ")
.... I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HD1) Q:QFLG="Q"
.... I $L(STR)<60 D Q
..... W LRAS,?19,STR,!
..... S LINES=LINES+1
.... W LRAS,?19,$E(STR,1,59),!
.... W ?19,$E(STR,60,$L(STR)),!
.... S LINES=LINES+2
Q
;
ORDNRPTI ; EP
S BLRVERN=$P($P($T(+1),";")," ")
S BLRVERN2="DATAREPT"
;
S HEADER(1)="Lab Ask At Order Questions"
S HEADER(2)="Lab Data Comments"
S HEADER(3)=" "
;
S HEADER(4)="Accession #"
S $E(HEADER(4),20)="Comments"
;
S MAXLINES=22,LINES=MAXLINES+10,PG=0,(HD1,QFLG)="NO"
;
S (CNT,LRODT,LRSP,P60,ORD)=0
Q
;
SHOWACCS(LRORD) ;EP - Given an Order Number, show it's Accession Number(s)
NEW CNT,BLRVERN,BLRVERN2,LRAA,LRAD,LRAN,LRAS,LINE,LINEWRAP,LRIDT,LRODT,LRSP
NEW ORD,P60,PTR,STR,TST
NEW HD1,HEADER,LINES,MAXLINES,PG,QFLG
;
D ORDNRPTI
;
S CNT=0,LRODT=.9999999
F S LRODT=$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1!(QFLG="Q") D
. S LRSP=.9999999
. F S LRSP=$O(^LRO(69,"C",LRORD,LRODT,LRSP)) Q:LRSP<1!(QFLG="Q") D
.. S TST=.999999
.. F S TST=$O(^LRO(69,LRODT,1,LRSP,2,TST)) Q:TST<1!(QFLG="Q") D
... S STR=$G(^LRO(69,LRODT,1,LRSP,2,TST,0))
... S LRAD=+$P(STR,"^",3),LRAA=+$P(STR,"^",4),LRAN=+$P(STR,"^",5)
... S LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
... Q:$L(LRAS)<1
... ;
... W LRORD
... W ?9,LRAS
... W ?29,LRAA
... W ?34,LRAD
... W ?44,LRAN
... W !
... S CNT=CNT+1
;
Q:CNT>0
;
W !!,"No Accessions found for Order Number:",LRORD,!!
Q
BLRAAORR ;IHS/OIT/MKK - IHS LAB ASK-AT-ORDER REPORTS ; JUL 06, 2011 3:15 PM
+1 ;;5.2;IHS LABORATORY;**1030**;NOV 01, 1997
+2 ;
+3 QUIT
+4 ;
DATAREPT ; EP - Report on Data Global
+1 NEW ANSWER,CANCEL,CNT,EHDT,HDT,LRAS,LRODT,LRSP,P60,ORD,LRORDN
+2 NEW BLRVERN,BLRVERN2,HEADER,HD1,LINES,LINEWRAP,MAXLINES,PG,QFLG,WRAPLINE
+3 ;
+4 DO DATARPTI
+5 ;
+6 FOR
SET LRODT=$ORDER(^BLRAAOQD(LRODT))
IF LRODT<1!(QFLG="Q")
QUIT
Begin DoDot:1
+7 FOR
SET LRSP=$ORDER(^BLRAAOQD(LRODT,LRSP))
IF LRSP<1!(QFLG="Q")
QUIT
Begin DoDot:2
+8 FOR
SET P60=$ORDER(^BLRAAOQD(LRODT,LRSP,P60))
IF P60<1!(QFLG="Q")
QUIT
Begin DoDot:3
+9 FOR
SET ORD=$ORDER(^BLRAAOQD(LRODT,LRSP,P60,ORD))
IF ORD<1!(QFLG="Q")
QUIT
Begin DoDot:4
+10 DO DATARPTL
End DoDot:4
End DoDot:3
+11 WRITE !
+12 SET LINES=LINES+1
End DoDot:2
End DoDot:1
+13 ;
+14 IF CNT<1
DO EMPTYDB("No Data in Lab Ask-At-Order Data file.")
+15 ;
+16 DO PRESSKEY^BLRGMENU(4)
+17 QUIT
+18 ;
DATARPTI ; EP - Initialize variables
+1 SET BLRVERN=$PIECE($PIECE($TEXT(+1),";")," ")
+2 SET BLRVERN2="DATAREPT"
+3 ;
+4 SET HEADER(1)="Lab Ask At Order Questions"
+5 SET HEADER(2)="Non Accessioned Responses"
+6 SET HEADER(3)=" "
+7 ;
+8 SET HEADER(4)="Order #"
+9 SET $EXTRACT(HEADER(4),10)="Test IEN"
+10 SET $EXTRACT(HEADER(4),20)="Question"
+11 SET $EXTRACT(HEADER(4),51)="Answer"
+12 SET $EXTRACT(HEADER(4),65)="Date/Time Answrd"
+13 ;
+14 SET MAXLINES=20
SET LINES=MAXLINES+10
SET PG=0
SET (HD1,QFLG)="NO"
+15 ;
+16 SET (CNT,LRODT,LRSP,P60,ORD)=0
+17 QUIT
+18 ;
DATARPTL ; EP - Write a line of data
+1 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,HD1)
IF QFLG="Q"
QUIT
+2 ;
+3 DO DATARPTB(29)
+4 ;
+5 ; File 69: Order Number
WRITE LRORDN
+6 WRITE ?8,CANCEL
+7 ; File 60: IEN
WRITE ?9,P60
+8 ; Question - Line 1
WRITE ?19,LINEWRAP(1)
+9 WRITE ?50,ANSWER
+10 ; Date/Time Question Answered
WRITE ?64,EHDT
+11 WRITE !
+12 SET LINES=LINES+1
+13 SET CNT=CNT+1
+14 ;
+15 DO MULTLINE(19)
+16 ;
+17 QUIT
+18 ;
DATARPTB(MAXCOL) ; EP - Breakout Variables from global
+1 NEW GLOSTR,STR,TSTORD
+2 NEW LRAA,LRAD,LRAN,STR,TST,TEST
+3 ;
+4 KILL LRORDN,LINEWRAP,ANSWER,EHDT,HDT
+5 ;
+6 SET LRAS=""
+7 SET TST=0
+8 FOR
SET TST=$ORDER(^LRO(69,LRODT,1,LRSP,2,TST))
IF TST!($LENGTH(LRAS))
QUIT
Begin DoDot:1
+9 SET STR=$GET(^LRO(69,LRODT,1,LRSP,2,TST,0))
+10 IF +$GET(STR)'=P60
QUIT
+11 ;
+12 SET LRAD=$PIECE(STR,"^",4)
SET LRAA=$PIECE(STR,"^",3)
SET LRAN=$PIECE(STR,"^",5)
+13 SET LRAS=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
End DoDot:1
+14 ;
+15 SET LRORDN=$GET(^LRO(69,LRODT,1,LRSP,.1))
+16 ;
+17 SET GLOSTR=$GET(^BLRAAOQD(LRODT,LRSP,P60,ORD))
+18 SET ANSWER=$PIECE(GLOSTR,"^",2)
+19 SET HDT=$PIECE(GLOSTR,"^",3)
+20 SET EHDT=$$HTE^XLFDT(HDT,"5MZ")
+21 ;
+22 SET STR(1)=$PIECE(GLOSTR,"^",1)
+23 IF $LENGTH($GET(STR(1)))<MAXCOL
SET LINEWRAP(1)=STR(1)
QUIT
+24 ;
+25 ; Question too long; have to create multiple lines
+26 DO WRAP(.STR,MAXCOL,.LINEWRAP)
+27 ;
+28 SET CANCEL=""
+29 ; Determine if Test has been cancelled
+30 SET TSTORD=.9999999
+31 FOR
SET TSTORD=$ORDER(^LRO(69,LRODT,1,LRSP,2,TSTORD))
IF TSTORD<1
QUIT
Begin DoDot:1
+32 IF +$GET(^LRO(69,LRODT,1,LRSP,2,TSTORD,0))'=P60
QUIT
+33 ;
+34 IF +$PIECE($GET(^LRO(69,LRODT,1,LRSP,2,TSTORD,0)),"^",11)>0
SET CANCEL="*"
End DoDot:1
+35 ;
+36 QUIT
+37 ;
DATARPTA ; EP - Report on Data Global - Accession Number, not Test IEN
+1 NEW ANSWER,CANCEL,CNT,EHDT,HDT,LRODT,LRAS,LRSP,P60,ORD,LRORDN
+2 NEW BLRVERN,BLRVERN2,HEADER,HD1,LINES,LINEWRAP,MAXLINES,PG,QFLG,WRAPLINE
+3 ;
+4 DO DATRPTAI
+5 ;
+6 FOR
SET LRODT=$ORDER(^BLRAAOQD(LRODT))
IF LRODT<1!(QFLG="Q")
QUIT
Begin DoDot:1
+7 FOR
SET LRSP=$ORDER(^BLRAAOQD(LRODT,LRSP))
IF LRSP<1!(QFLG="Q")
QUIT
Begin DoDot:2
+8 FOR
SET P60=$ORDER(^BLRAAOQD(LRODT,LRSP,P60))
IF P60<1!(QFLG="Q")
QUIT
Begin DoDot:3
+9 FOR
SET ORD=$ORDER(^BLRAAOQD(LRODT,LRSP,P60,ORD))
IF ORD<1!(QFLG="Q")
QUIT
Begin DoDot:4
+10 DO DATRPTAL
End DoDot:4
End DoDot:3
+11 WRITE !
+12 SET LINES=LINES+1
End DoDot:2
End DoDot:1
+13 ;
+14 IF CNT<1
DO EMPTYDB("No Data in Lab Ask-At-Order Data file.")
+15 ;
+16 DO PRESSKEY^BLRGMENU(4)
+17 QUIT
+18 ;
DATRPTAI ; EP - Initialize variables
+1 SET BLRVERN=$PIECE($PIECE($TEXT(+1),";")," ")
+2 SET BLRVERN2="DATAREPT"
+3 ;
+4 SET HEADER(1)="Lab Ask At Order Questions"
+5 SET HEADER(2)="Non Accessioned Responses"
+6 SET HEADER(3)=" "
+7 ;
+8 SET HEADER(4)="Order #"
+9 SET $EXTRACT(HEADER(4),10)="Accession Number"
+10 SET $EXTRACT(HEADER(4),30)="Question"
+11 SET $EXTRACT(HEADER(4),51)="Answer"
+12 SET $EXTRACT(HEADER(4),65)="Date/Time Answrd"
+13 ;
+14 SET MAXLINES=20
SET LINES=MAXLINES+10
SET PG=0
SET (HD1,QFLG)="NO"
+15 ;
+16 SET (CNT,LRODT,LRSP,P60,ORD)=0
+17 QUIT
+18 ;
DATRPTAL ; EP - Write a line of data
+1 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,HD1)
IF QFLG="Q"
QUIT
+2 ;
+3 DO DATARPTB(19)
+4 ;
+5 ; File 69: Order Number
WRITE LRORDN
+6 WRITE ?8,CANCEL
+7 ; Accession Number
WRITE ?9,LRAS
+8 ; Question - Line 1
WRITE ?29,LINEWRAP(1)
+9 WRITE ?50,ANSWER
+10 ; Date/Time Question Answered
WRITE ?64,EHDT
+11 WRITE !
+12 SET LINES=LINES+1
+13 SET CNT=CNT+1
+14 ;
+15 DO MULTLINE(29)
+16 ;
+17 QUIT
+18 ;
EMPTYDB(MSG) ; EP - Empty DB Message
+1 KILL HEADER(3),HEADER(4)
+2 DO HEADERDT^BLRGMENU
+3 WRITE !!,?9,MSG,!
+4 QUIT
+5 ;
+6 ; Cloned from LR7OSAP1. Wrap Text in array ROOT to PUTIT array
WRAP(ROOT,FMT,PUTIT) ; EP - Wrap text
+1 IF '$LENGTH($GET(ROOT(1)))
QUIT
+2 NEW CCNT,GCNT,INC,LRI,LRINDX,LRTX,SP,X
+3 IF '$GET(FMT)
SET FMT=79
+4 SET LRINDX=0
SET LRI=0
SET GCNT=0
+5 FOR
SET LRI=$ORDER(ROOT(LRI))
IF LRI'>0
QUIT
Begin DoDot:1
+6 SET X=$SELECT($LENGTH($GET(ROOT(LRI))):ROOT(LRI),$LENGTH($GET(ROOT(LRI,0))):ROOT(LRI,0),1:"")
SET LRINDX=LRINDX+1
+7 SET X=$$FMT^LR7OSAP1(FMT,.LRINDX,X)
End DoDot:1
+8 SET LRI=0
+9 FOR
SET LRI=$ORDER(LRTX(LRI))
IF 'LRI
QUIT
DO LN^LR7OSAP
SET PUTIT(GCNT)=$$S^LR7OS(1,CCNT,LRTX(LRI))
+10 QUIT
+11 ;
MULTLINE(TAB) ; EP - Answer too long for one line; print rest of lines.
+1 SET WRAPLINE=1
+2 FOR
SET WRAPLINE=$ORDER(LINEWRAP(WRAPLINE))
IF WRAPLINE<1
QUIT
Begin DoDot:1
+3 WRITE ?TAB,LINEWRAP(WRAPLINE),!
+4 SET LINES=LINES+1
End DoDot:1
+5 ;
+6 QUIT
+7 ;
ERRSREPT ; EP - Report on Errors Global
+1 NEW ANSWER,CNT,EHDT,ERRSMSG,HDT,LRDFN,LRIDT,LRODT,LRSP,P60,ORD,LRORDN
+2 NEW BLRVERN,BLRVERN2,HEADER,HD1,LINES,LINEWRAP,MAXLINES,PG,QFLG,WRAPLINE
+3 ;
+4 DO ERSSRPTI
+5 ;
+6 FOR
SET LRDFN=$ORDER(^BLRAAORE(LRDFN))
IF LRDFN<1!(QFLG="Q")
QUIT
Begin DoDot:1
+7 FOR
SET LRIDT=$ORDER(^BLRAAORE(LRDFN,LRIDT))
IF LRIDT<1!(QFLG="Q")
QUIT
Begin DoDot:2
+8 FOR
SET LRODT=$ORDER(^BLRAAORE(LRDFN,LRIDT,LRODT))
IF LRODT<1!(QFLG="Q")
QUIT
Begin DoDot:3
+9 FOR
SET LRSP=$ORDER(^BLRAAORE(LRDFN,LRIDT,LRODT,LRSP))
IF LRSP<1!(QFLG="Q")
QUIT
Begin DoDot:4
+10 FOR
SET P60=$ORDER(^BLRAAORE(LRDFN,LRIDT,LRODT,LRSP,P60))
IF P60<1!(QFLG="Q")
QUIT
Begin DoDot:5
+11 FOR
SET ORD=$ORDER(^BLRAAORE(LRDFN,LRIDT,LRODT,LRSP,P60,ORD))
IF ORD<1!(QFLG="Q")
QUIT
Begin DoDot:6
+12 DO ERSSRPTL
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 ;
+14 IF CNT<1
DO EMPTYDB("No Data in Errors Database.")
+15 ;
+16 DO PRESSKEY^BLRGMENU(4)
+17 QUIT
+18 ;
+1 SET BLRVERN=$PIECE($PIECE($TEXT(+1),";")," ")
+2 SET BLRVERN2="DATAREPT"
+3 ;
+4 SET HEADER(1)="Lab Ask At Order Questions"
+5 SET HEADER(2)="Transactions With Errors"
+6 SET HEADER(3)=" "
+7 ;
+8 SET HEADER(4)="LRDFN"
+9 SET $EXTRACT(HEADER(4),10)="LRIDT"
+10 SET $EXTRACT(HEADER(4),27)="LRODT"
+11 SET $EXTRACT(HEADER(4),37)="LRSP"
+12 SET $EXTRACT(HEADER(4),43)="Test IEN"
+13 SET $EXTRACT(HEADER(4),53)="Ord"
+14 SET $EXTRACT(HEADER(4),58)="Error Message"
+15 ;
+16 SET MAXLINES=22
SET LINES=MAXLINES+10
SET PG=0
SET (HD1,QFLG)="NO"
+17 ;
+18 SET (CNT,LRDFN,LRIDT,LRODT,LRSP,P60,ORD)=0
+19 QUIT
+20 ;
+1 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,HD1)
IF QFLG="Q"
QUIT
+2 ;
+3 SET ERRMSG=$GET(^BLRAAORE(LRDFN,LRIDT,LRODT,LRSP,P60,ORD,"DIERR",1))
+4 ;
+5 WRITE LRDFN
+6 WRITE ?9,LRIDT
+7 WRITE ?26,LRODT
+8 WRITE ?36,LRSP
+9 WRITE ?42,P60
+10 WRITE ?52,ORD
+11 WRITE ?57,$EXTRACT(ERRMSG,1,23)
+12 WRITE !
+13 SET LINES=LINES+1
+14 SET CNT=CNT+1
+15 ;
+16 QUIT
+17 ;
ORDNREPT(LRORD) ; EP -- Report on Lab Data File Ask at Order questions given Lab Order Number
+1 NEW LINE,LINEWRAP,LRAA,LRAD,LRAN,LRAS,LRIDT,LRODT,LRSP,PTR,STR,TST
+2 NEW HD1,HEADER,LINES,MAXLINES,PG,QFLG
+3 ;
+4 DO ORDNRPTI
+5 ;
+6 SET LRODT=.9999999
+7 FOR
SET LRODT=$ORDER(^LRO(69,"C",LRORD,LRODT))
IF LRODT<1!(QFLG="Q")
QUIT
Begin DoDot:1
+8 SET LRSP=.9999999
+9 FOR
SET LRSP=$ORDER(^LRO(69,"C",LRORD,LRODT,LRSP))
IF LRSP<1!(QFLG="Q")
QUIT
Begin DoDot:2
+10 SET TST=.999999
+11 FOR
SET TST=$ORDER(^LRO(69,LRODT,1,LRSP,2,TST))
IF TST<1!(QFLG="Q")
QUIT
Begin DoDot:3
+12 SET STR=$GET(^LRO(69,LRODT,1,LRSP,2,TST,0))
+13 SET LRAD=+$PIECE(STR,"^",3)
SET LRAA=+$PIECE(STR,"^",4)
SET LRAN=+$PIECE(STR,"^",5)
+14 SET LRAS=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
+15 IF $LENGTH(LRAS)<1
QUIT
+16 ;
+17 SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
+18 SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
+19 ;
+20 IF LRDFN<1!(LRIDT<1)
QUIT
+21 ;
+22 SET LINE=0
+23 FOR
SET LINE=$ORDER(^LR(LRDFN,"CH",LRIDT,1,LINE))
IF LINE<1!(QFLG="Q")
QUIT
Begin DoDot:4
+24 SET STR=$$TRIM^XLFSTR($GET(^LR(LRDFN,"CH",LRIDT,1,LINE,0)),"LR"," ")
+25 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,HD1)
IF QFLG="Q"
QUIT
+26 IF $LENGTH(STR)<60
Begin DoDot:5
+27 WRITE LRAS,?19,STR,!
+28 SET LINES=LINES+1
End DoDot:5
QUIT
+29 WRITE LRAS,?19,$EXTRACT(STR,1,59),!
+30 WRITE ?19,$EXTRACT(STR,60,$LENGTH(STR)),!
+31 SET LINES=LINES+2
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT
+33 ;
ORDNRPTI ; EP
+1 SET BLRVERN=$PIECE($PIECE($TEXT(+1),";")," ")
+2 SET BLRVERN2="DATAREPT"
+3 ;
+4 SET HEADER(1)="Lab Ask At Order Questions"
+5 SET HEADER(2)="Lab Data Comments"
+6 SET HEADER(3)=" "
+7 ;
+8 SET HEADER(4)="Accession #"
+9 SET $EXTRACT(HEADER(4),20)="Comments"
+10 ;
+11 SET MAXLINES=22
SET LINES=MAXLINES+10
SET PG=0
SET (HD1,QFLG)="NO"
+12 ;
+13 SET (CNT,LRODT,LRSP,P60,ORD)=0
+14 QUIT
+15 ;
SHOWACCS(LRORD) ;EP - Given an Order Number, show it's Accession Number(s)
+1 NEW CNT,BLRVERN,BLRVERN2,LRAA,LRAD,LRAN,LRAS,LINE,LINEWRAP,LRIDT,LRODT,LRSP
+2 NEW ORD,P60,PTR,STR,TST
+3 NEW HD1,HEADER,LINES,MAXLINES,PG,QFLG
+4 ;
+5 DO ORDNRPTI
+6 ;
+7 SET CNT=0
SET LRODT=.9999999
+8 FOR
SET LRODT=$ORDER(^LRO(69,"C",LRORD,LRODT))
IF LRODT<1!(QFLG="Q")
QUIT
Begin DoDot:1
+9 SET LRSP=.9999999
+10 FOR
SET LRSP=$ORDER(^LRO(69,"C",LRORD,LRODT,LRSP))
IF LRSP<1!(QFLG="Q")
QUIT
Begin DoDot:2
+11 SET TST=.999999
+12 FOR
SET TST=$ORDER(^LRO(69,LRODT,1,LRSP,2,TST))
IF TST<1!(QFLG="Q")
QUIT
Begin DoDot:3
+13 SET STR=$GET(^LRO(69,LRODT,1,LRSP,2,TST,0))
+14 SET LRAD=+$PIECE(STR,"^",3)
SET LRAA=+$PIECE(STR,"^",4)
SET LRAN=+$PIECE(STR,"^",5)
+15 SET LRAS=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
+16 IF $LENGTH(LRAS)<1
QUIT
+17 ;
+18 WRITE LRORD
+19 WRITE ?9,LRAS
+20 WRITE ?29,LRAA
+21 WRITE ?34,LRAD
+22 WRITE ?44,LRAN
+23 WRITE !
+24 SET CNT=CNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+25 ;
+26 IF CNT>0
QUIT
+27 ;
+28 WRITE !!,"No Accessions found for Order Number:",LRORD,!!
+29 QUIT
