BLRLAHGU ; IHS/MSC/MKK - LOAD/WORK List in the ^LAH Global ; 22-Oct-2013 09:22 ; MKK
;;5.2;IHS LABORATORY;**1033**;NOV 1, 1997
;
EEP ; Ersatz EP
D EEP^BLRGMENU
Q
;
PEP ; EP
ACCFILEL ; EP
; NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S LRLL=0
;
D SETLBRVS("ACCFILEL")
;
D B^LRU
Q:+$G(LRSDT)<1!(+$G(LRLDT)<1)
;
Q:$$GETAUTOI()="Q"
;
Q
S NOGO=0
F Q:NOGO D
. D GETUID(LRSDT,LRLDT)
Q
;
GETUID(LRSDT,LRLDT) ; EP
; The following code reads the ^LAH global for the LOAD/WORK LIST "tied" to
; the selected AUTO INSTRUMENT and creates the necessary string to setup
; the D ^DIR call to "select from a list"
;
NEW BELOW,CNT,DIRZERO,DRAWDATE,ENTRY,IENSTR,LRUID,LUIDINDX,NUMCOL,STR
;
S DIRZERO="SO^"
S (CNT,ENTRY)=0
F S ENTRY=$O(^LAH(LRLL,1,ENTRY)) Q:ENTRY<1 D
. S LRUID=+$G(^LAH(LRLL,1,ENTRY,.3))
. Q:LRUID<1
. ;
. 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 DRAWDATE=$P($$GET1^DIQ(68.02,IENSTR,"DRAW TIME","I"),".")
. Q:DRAWDATE<LRSDT!(DRAWDATE>LRLDT) ; Skip if not in date range
. ;
. 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_ENTRY_U_LRAA_U_LRAD_U_LRAN
S CNT=CNT+1
S DIRZERO=DIRZERO_(CNT)_":AL"
;
I $D(LUIDINDX)<1 D Q
. W !!,?4,"No Entries for Date Range ",$$FMTE^XLFDT(LRSDT,"5DZ")," thru ",$$FMTE^XLFDT(LRLDT,"5DZ")
. 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
;
D HEADERDT^BLRGMENU
;
D ^DIR
I +Y<1!(+$G(DIRUT)) D Q
. W !,?4,"No/Invalid Entry. Routine Ends."
. D PRESSKEY^BLRGMENU(9)
. S LREND=1
;
S STR=$G(LUIDINDX(+$G(Y)))
S LRUID=+STR
S LRIFN=+$P(STR,U,2),LRAA=$P(STR,U,3),LRAD=$P(STR,U,4),LRAN=$P(STR,U,5)
Q
;
ONGO(NOGO) ; EP - Continue?
D ^XBFMK
S DIR(0)="YO"
S DIR("A")="Continue"
S DIR("B")="NO"
D ^DIR
S:+Y<1 NOGO=1
Q
;
REPORT ; EP - Report on UIDs for a Specific LOAD/WORK LIST
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D SETLBRVS("REPORT")
Q:$$GETAUTOI()="Q"
Q:$$REPORTI()="Q"
;
F S ENTRY=$O(^LAH(LRLL,1,ENTRY),-1) Q:ENTRY<1!(QFLG="Q") D REPORTL
;
D PRESSKEY^BLRGMENU(9)
Q
;
REPORTI() ; EP - Initialization of variables
K HEADER
S HEADER(1)=LRAUTON_" AUTO INSTRUMENT"
S HEADER(2)=$$CJ^XLFSTR(LRLLNAME_" ^LAH Entries",IOM)
S HEADER(3)=" "
S $E(HEADER(4),5)="Entry"
S $E(HEADER(4),15)="UID"
S $E(HEADER(4),28)="Accession"
S $E(HEADER(4),48)="Order #"
S $E(HEADER(4),58)="Order Date"
S $E(HEADER(4),70)="Draw Date"
;
S (CNT,PG)=0,ENTRY="A"
S MAXLINES=20,LINES=MAXLINES+10
S QFLG="NO"
Q "OK"
;
REPORTL ; EP - Line of data
Q:$$REPORTB()="Q"
;
I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,"NO") Q:QFLG="Q"
;
W ?5,ENTRY
W ?14,LRUID
W ?27,LRAS
W ?47,ORDERNUM
W ?57,DATEORD
W ?69,DRAWDATE
W !
S LINES=LINES+1
S CNT=CNT+1
Q
;
REPORTB() ; EP - Breakout data
S LRUID=+$G(^LAH(LRLL,1,ENTRY,.3))
Q:LRUID<1 "Q"
;
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) "Q"
;
S IENSTR=LRAN_","_LRAD_","_LRAA_","
;
S ORDERNUM=$$GET1^DIQ(68.02,IENSTR,"ORDER #")
S LRAS=$$GET1^DIQ(68.02,IENSTR,"ACCESSION")
S DATEORD=$$FMTE^XLFDT($$GET1^DIQ(68.02,IENSTR,"DATE ORDERED","I"),"5DZ")
S DRAWDATE=$$FMTE^XLFDT($$GET1^DIQ(68.02,IENSTR,"DRAW TIME","I"),"5DZ")
Q "OK"
;
SETLBRVS(TWO) ; EP - Set the BLRVERN & BLRVERN2 variables
S BLRVERN=$TR($P($T(+1),";")," ")
S:$L($G(TWO)) BLRVERN2=TWO
Q
;
GETAUTOI() ; EP - Get the AUTO INSTRUMENT
S HEADER(1)="AUTO INSTRUMENT"
D HEADERDT^BLRGMENU
;
D ^XBFMK
S DIR(0)="PO^62.4:E"
D ^DIR
I +Y<1!(+$G(DIRUT)) D Q "Q"
. W !,?4,"No/Invalid Entry. Routine Ends."
. D PRESSKEY^BLRGMENU(9)
;
S LRAUTO=+Y,LRAUTON=$P(Y,U,2)
I $$GETLWRKL()="Q" Q "Q"
Q "OK"
;
S LRLL=+$$GET1^DIQ(62.4,LRAUTO,"LOAD/WORK LIST","I")
S LRLLNAME=$$GET1^DIQ(62.4,LRAUTO,"LOAD/WORK LIST")
I LRLL<1 D Q "Q"
. W !,?4,"No LOAD/WORK LIST associated with ",LRAUTON,". Routine Ends."
. D PRESSKEY^BLRGMENU(9)
;
K HEADER(1)
S HEADER(1)=LRAUTON_" AUTO INSTRUMENT"
S HEADER(2)=$$CJ^XLFSTR(LRLLNAME_" ^LAH Entries",IOM)
;
Q "OK"
;
GETLWRKL() ; EP - Get the LOAD/WORK list
S HEADER(1)="LOAD/WORK LIST"
D HEADERDT^BLRGMENU
;
; Get LOAD/WORK list IEN
D ^XBFMK
S DIR(0)="PO^68.2:E"
D ^DIR
I +Y<1!(+$G(DIRUT)) D Q "Q"
. W !,?4,"No/Invalid Entry. Routine Ends."
. D PRESSKEY^BLRGMENU(9)
;
S LRLL=+Y,LRLLNAME=$P(Y,U,2)
S HEADER(2)=LRLLNAME_" ^LAH Entries"
;
Q "OK"
BLRLAHGU ; IHS/MSC/MKK - LOAD/WORK List in the ^LAH Global ; 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
ACCFILEL ; EP
+1 ; NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 SET LRLL=0
+4 ;
+5 DO SETLBRVS("ACCFILEL")
+6 ;
+7 DO B^LRU
+8 IF +$GET(LRSDT)<1!(+$GET(LRLDT)<1)
QUIT
+9 ;
+10 IF $$GETAUTOI()="Q"
QUIT
+11 ;
+12 QUIT
+13 SET NOGO=0
+14 FOR
IF NOGO
QUIT
Begin DoDot:1
+15 DO GETUID(LRSDT,LRLDT)
End DoDot:1
+16 QUIT
+17 ;
GETUID(LRSDT,LRLDT) ; EP
+1 ; The following code reads the ^LAH global for the LOAD/WORK LIST "tied" to
+2 ; the selected AUTO INSTRUMENT and creates the necessary string to setup
+3 ; the D ^DIR call to "select from a list"
+4 ;
+5 NEW BELOW,CNT,DIRZERO,DRAWDATE,ENTRY,IENSTR,LRUID,LUIDINDX,NUMCOL,STR
+6 ;
+7 SET DIRZERO="SO^"
+8 SET (CNT,ENTRY)=0
+9 FOR
SET ENTRY=$ORDER(^LAH(LRLL,1,ENTRY))
IF ENTRY<1
QUIT
Begin DoDot:1
+10 SET LRUID=+$GET(^LAH(LRLL,1,ENTRY,.3))
+11 IF LRUID<1
QUIT
+12 ;
+13 SET X=$QUERY(^LRO(68,"C",LRUID,0))
SET LRAA=+$QSUBSCRIPT(X,4)
SET LRAD=+$QSUBSCRIPT(X,5)
SET LRAN=+$QSUBSCRIPT(X,6)
+14 ; If no Accession, skip
IF LRAA<1!(LRAD<1)!(LRAN<1)
QUIT
+15 ;
+16 SET IENSTR=LRAN_","_LRAD_","_LRAA_","
+17 SET DRAWDATE=$PIECE($$GET1^DIQ(68.02,IENSTR,"DRAW TIME","I"),".")
+18 ; Skip if not in date range
IF DRAWDATE<LRSDT!(DRAWDATE>LRLDT)
QUIT
+19 ;
+20 SET LRAS=$$GET1^DIQ(68.02,IENSTR,"ACCESSION")
+21 SET CNT=CNT+1
+22 SET DIRZERO=DIRZERO_CNT_":"_LRUID_";"
+23 SET DIRZERO(CNT)=$$LJ^XLFSTR($JUSTIFY(CNT,2)_") "_$$LJ^XLFSTR(LRUID,11)_LRAS,27)
+24 SET LUIDINDX(CNT)=LRUID_U_ENTRY_U_LRAA_U_LRAD_U_LRAN
End DoDot:1
+25 SET CNT=CNT+1
+26 SET DIRZERO=DIRZERO_(CNT)_":AL"
+27 ;
+28 IF $DATA(LUIDINDX)<1
Begin DoDot:1
+29 WRITE !!,?4,"No Entries for Date Range ",$$FMTE^XLFDT(LRSDT,"5DZ")," thru ",$$FMTE^XLFDT(LRLDT,"5DZ")
+30 DO PRESSKEY^BLRGMENU(9)
+31 SET LREND=1
End DoDot:1
QUIT
+32 ;
+33 SET NUMCOL=3
+34 KILL LRUID
+35 DO ^XBFMK
+36 SET DIR(0)=DIRZERO
+37 SET DIR("L",1)=" UID Accession UID Accession UID Accession"
+38 SET DIR("L",2)=" ---------- ----------- ---------- ----------- ---------- ----------"
+39 SET BELOW=3
+40 SET CNT=0
+41 FOR
SET CNT=$ORDER(DIRZERO(CNT))
IF CNT<1
QUIT
Begin DoDot:1
+42 IF (CNT#NUMCOL)=1
SET DIR("L",BELOW)=""
+43 SET DIR("L",BELOW)=$GET(DIR("L",BELOW))_$SELECT((CNT#NUMCOL)=0:$$TRIM^XLFSTR(DIRZERO(CNT),"R"," "),1:DIRZERO(CNT))
+44 IF (CNT#NUMCOL)=0
SET BELOW=BELOW+1
End DoDot:1
+45 ;
+46 SET DIR("L")=""
+47 ; Change default prompt
SET DIR("A")="Select number"
+48 ;
+49 DO HEADERDT^BLRGMENU
+50 ;
+51 DO ^DIR
+52 IF +Y<1!(+$GET(DIRUT))
Begin DoDot:1
+53 WRITE !,?4,"No/Invalid Entry. Routine Ends."
+54 DO PRESSKEY^BLRGMENU(9)
+55 SET LREND=1
End DoDot:1
QUIT
+56 ;
+57 SET STR=$GET(LUIDINDX(+$GET(Y)))
+58 SET LRUID=+STR
+59 SET LRIFN=+$PIECE(STR,U,2)
SET LRAA=$PIECE(STR,U,3)
SET LRAD=$PIECE(STR,U,4)
SET LRAN=$PIECE(STR,U,5)
+60 QUIT
+61 ;
ONGO(NOGO) ; EP - Continue?
+1 DO ^XBFMK
+2 SET DIR(0)="YO"
+3 SET DIR("A")="Continue"
+4 SET DIR("B")="NO"
+5 DO ^DIR
+6 IF +Y<1
SET NOGO=1
+7 QUIT
+8 ;
REPORT ; EP - Report on UIDs for a Specific LOAD/WORK LIST
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 DO SETLBRVS("REPORT")
+4 IF $$GETAUTOI()="Q"
QUIT
+5 IF $$REPORTI()="Q"
QUIT
+6 ;
+7 FOR
SET ENTRY=$ORDER(^LAH(LRLL,1,ENTRY),-1)
IF ENTRY<1!(QFLG="Q")
QUIT
DO REPORTL
+8 ;
+9 DO PRESSKEY^BLRGMENU(9)
+10 QUIT
+11 ;
REPORTI() ; EP - Initialization of variables
+1 KILL HEADER
+2 SET HEADER(1)=LRAUTON_" AUTO INSTRUMENT"
+3 SET HEADER(2)=$$CJ^XLFSTR(LRLLNAME_" ^LAH Entries",IOM)
+4 SET HEADER(3)=" "
+5 SET $EXTRACT(HEADER(4),5)="Entry"
+6 SET $EXTRACT(HEADER(4),15)="UID"
+7 SET $EXTRACT(HEADER(4),28)="Accession"
+8 SET $EXTRACT(HEADER(4),48)="Order #"
+9 SET $EXTRACT(HEADER(4),58)="Order Date"
+10 SET $EXTRACT(HEADER(4),70)="Draw Date"
+11 ;
+12 SET (CNT,PG)=0
SET ENTRY="A"
+13 SET MAXLINES=20
SET LINES=MAXLINES+10
+14 SET QFLG="NO"
+15 QUIT "OK"
+16 ;
REPORTL ; EP - Line of data
+1 IF $$REPORTB()="Q"
QUIT
+2 ;
+3 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,"NO")
IF QFLG="Q"
QUIT
+4 ;
+5 WRITE ?5,ENTRY
+6 WRITE ?14,LRUID
+7 WRITE ?27,LRAS
+8 WRITE ?47,ORDERNUM
+9 WRITE ?57,DATEORD
+10 WRITE ?69,DRAWDATE
+11 WRITE !
+12 SET LINES=LINES+1
+13 SET CNT=CNT+1
+14 QUIT
+15 ;
REPORTB() ; EP - Breakout data
+1 SET LRUID=+$GET(^LAH(LRLL,1,ENTRY,.3))
+2 IF LRUID<1
QUIT "Q"
+3 ;
+4 SET X=$QUERY(^LRO(68,"C",LRUID,0))
SET LRAA=+$QSUBSCRIPT(X,4)
SET LRAD=+$QSUBSCRIPT(X,5)
SET LRAN=+$QSUBSCRIPT(X,6)
+5 ;
+6 IF LRAA<1!(LRAD<1)!(LRAN<1)
QUIT "Q"
+7 ;
+8 SET IENSTR=LRAN_","_LRAD_","_LRAA_","
+9 ;
+10 SET ORDERNUM=$$GET1^DIQ(68.02,IENSTR,"ORDER #")
+11 SET LRAS=$$GET1^DIQ(68.02,IENSTR,"ACCESSION")
+12 SET DATEORD=$$FMTE^XLFDT($$GET1^DIQ(68.02,IENSTR,"DATE ORDERED","I"),"5DZ")
+13 SET DRAWDATE=$$FMTE^XLFDT($$GET1^DIQ(68.02,IENSTR,"DRAW TIME","I"),"5DZ")
+14 QUIT "OK"
+15 ;
SETLBRVS(TWO) ; EP - Set the BLRVERN & BLRVERN2 variables
+1 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+2 IF $LENGTH($GET(TWO))
SET BLRVERN2=TWO
+3 QUIT
+4 ;
GETAUTOI() ; EP - Get the AUTO INSTRUMENT
+1 SET HEADER(1)="AUTO INSTRUMENT"
+2 DO HEADERDT^BLRGMENU
+3 ;
+4 DO ^XBFMK
+5 SET DIR(0)="PO^62.4:E"
+6 DO ^DIR
+7 IF +Y<1!(+$GET(DIRUT))
Begin DoDot:1
+8 WRITE !,?4,"No/Invalid Entry. Routine Ends."
+9 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT "Q"
+10 ;
+11 SET LRAUTO=+Y
SET LRAUTON=$PIECE(Y,U,2)
+12 IF $$GETLWRKL()="Q"
QUIT "Q"
+13 QUIT "OK"
+14 ;
+15 SET LRLL=+$$GET1^DIQ(62.4,LRAUTO,"LOAD/WORK LIST","I")
+16 SET LRLLNAME=$$GET1^DIQ(62.4,LRAUTO,"LOAD/WORK LIST")
+17 IF LRLL<1
Begin DoDot:1
+18 WRITE !,?4,"No LOAD/WORK LIST associated with ",LRAUTON,". Routine Ends."
+19 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT "Q"
+20 ;
+21 KILL HEADER(1)
+22 SET HEADER(1)=LRAUTON_" AUTO INSTRUMENT"
+23 SET HEADER(2)=$$CJ^XLFSTR(LRLLNAME_" ^LAH Entries",IOM)
+24 ;
+25 QUIT "OK"
+26 ;
GETLWRKL() ; EP - Get the LOAD/WORK list
+1 SET HEADER(1)="LOAD/WORK LIST"
+2 DO HEADERDT^BLRGMENU
+3 ;
+4 ; Get LOAD/WORK list IEN
+5 DO ^XBFMK
+6 SET DIR(0)="PO^68.2:E"
+7 DO ^DIR
+8 IF +Y<1!(+$GET(DIRUT))
Begin DoDot:1
+9 WRITE !,?4,"No/Invalid Entry. Routine Ends."
+10 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT "Q"
+11 ;
+12 SET LRLL=+Y
SET LRLLNAME=$PIECE(Y,U,2)
+13 SET HEADER(2)=LRLLNAME_" ^LAH Entries"
+14 ;
+15 QUIT "OK"
