BLRMANP3 ; IHS/MSC/MKK - Multiple Accession Not Performed utility, part 3 ; 22-Apr-2016 15:12 ; MKK
;;5.2;IHS LABORATORY;**1039**;NOV 01, 1997;Build 38
;
EEP ; Ersatz EP
D EEP^BLRGMENU
Q
;
; The following cloned from BLRRLTDU
XTMPRPT ; EP - ^XTMP Issues node - Interactive Report
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D SETBLRVS("XTMPRPT")
S HEADER(1)="^XTMP Global"
;
I $D(^XTMP("BLRMANPU","UID"))<1 D Q
. D HEADERDT^BLRGMENU
. W !,?4,"^XTMP Global has no Data for 'Multiple Accession Not Performed' Errors."
. D PRESSKEY^BLRGMENU(9)
;
S HEADER(2)="Accession (UID)"
S HEADER(3)=$$CJ^XLFSTR("Could *NOT* Mark 'Not Performed' Report",80)
S HEADER(4)=" "
S HEADER(5)="UID"
S $E(HEADER(5),13)="Date/Time"
S $E(HEADER(5),29)="DUZ"
S $E(HEADER(5),36)="Error Message"
;
S MAXLINES=IOSL-4,LINES=MAXLINES+10
S (CNT,PG)=0
S QFLG="NO"
;
S UID=0,MSGL=5
F S UID=$O(^XTMP("BLRMANPU","UID",UID)) Q:UID<1!(QFLG="Q") D
. S MSGDUZ=0
. F S MSGDUZ=$O(^XTMP("BLRMANPU","UID",UID,"DUZ",MSGDUZ)) Q:MSGDUZ<1!(QFLG="Q") D
.. S NAMEDUZ=$$GET1^DIQ(200,MSGDUZ,"NAME")
.. S HDATE=""
.. F S HDATE=$O(^XTMP("BLRMANPU","UID",UID,"DUZ",MSGDUZ,HDATE)) Q:HDATE=""!(QFLG="Q") D
... S STR=$G(^XTMP("BLRMANPU","UID",UID,"DUZ",MSGDUZ,HDATE))
... I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,"NO") Q:QFLG="Q"
... W UID
... W ?12,$$HTE^XLFDT(HDATE,"2MZ")
... W ?28,MSGDUZ
... D LINEWRAP^BLRGMENU(35,$P(STR,"^"),45)
... W !
... S LINES=LINES+1
;
D PRESSKEY^BLRGMENU(9)
Q
;
XTMPKILL ; EP - Purge the ^XTMP("BLRMANPU") Node
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S HEADER(1)="^XTMP Global"
S HEADER(2)="Purge"
D HEADERDT^BLRGMENU
W ?9,"This option will purge the ^XTMP(""BLRMANPU"") global.",!!
W ?9,"That global contains any error messages created during the",!!
W ?14,"Mark Multiple Accessions as Not Performed",!!
W ?9,"process."
S TAB=$J("",5)
D ^XBFMK
S DIR(0)="YO"
S DIR("A")=TAB_"Are you Sure"
D ^DIR
Q:+Y<1 $$BADSTUFN^BLRUTIL7("No/Quit/Invalid Response.")
;
D ^XBFMK
S DIR(0)="YO"
S DIR("A")=TAB_"Second Chance: Are you Really sure"
D ^DIR
Q:+Y<1 $$BADSTUFN^BLRUTIL7("No/Quit/Invalid Response.")
;
D ^XBFMK
S DIR(0)="Y"
S DIR("A")=TAB_"FINAL CHANCE: Are you Absolutely sure"
D ^DIR
Q:+Y<1 $$BADSTUFN^BLRUTIL7("No/Quit/Invalid Response.")
;
W !!,TAB_TAB_"^XTMP(""BLRMANPU"") Global Purged."
K ^XTMP("BLRMANPU")
;
D PRESSKEY^BLRGMENU(4)
Q
;
DETAIL68 ; EP - Accession (#68) File Data Detail
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
Q:$$DETAILIN("ACDETAIL")="Q"
;
D NODEZERO,NODE3,ACCTESTS
;
I $O(^LRO(69,"C",ORDERNUM,0))<1 W !,?6,"**Order #:",ORDERNUM," is **NOT** in the Lab Order Entry (#69) File."
;
D PRESSKEY^BLRGMENU(4)
Q
;
DETAILIN(SUBRTN) ; EP - Initialize variables
NEW COL,COL2
D SETBLRVS($G(SUBRTN))
;
S HEADER(1)="Accession Detail"
;
D HEADERDT^BLRGMENU
;
D ^LRWU4
;
I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))<1 Q $$ENDERQ("Accession does not Exist.")
;
S LRSS=$P($G(^LRO(68,LRAA,0)),U,2)
S LRASIEN=LRAN_","_LRAD_","_LRAA
S ORDERNUM=$$GET1^DIQ(68.02,LRASIEN,14)
S LRAS=$$GET1^DIQ(68.02,LRASIEN,15)
S UID=$$GET1^DIQ(68.02,LRASIEN,16)
S DIV=$$GET1^DIQ(68.02,LRASIEN,26)
;
S HEADER(2)="Accession #:"_LRAS
S HEADER(3)=$$CENTER("LRAA:"_LRAA_" LRAD:"_LRAD_" LRAN:"_LRAN)
;
D ^%ZIS
I POP Q $$ENDERQ("Invalid %ZIS call.")
;
S MAXLINES=IOSL-4
S LINES=MAXLINES+10
S PG=0,RESULTDT="",QFLG="OK"
Q "OK"
;
NODEZERO() ; EP - Display Accession Node Zero
D HEADERDT^BLRGMENU
;
; D LINEMSG("Accession (#68) file Data","=",5)
;
S STR=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
;
W ?5,"Order #:",ORDERNUM
W:$O(^LRO(69,"C",ORDERNUM,0))<1 "**"
W ?23,"UID:",UID
W ?43,"Order Dt:"
S ORDERDT=$$GET1^DIQ(68.02,LRASIEN,3,"I")
W:ORDERDT $$FMTE^XLFDT(ORDERDT,"5DZ")
W !
;
S LRDFN=$$GET1^DIQ(68.02,LRASIEN,.01,"I")
W ?7,"LRDFN:",LRDFN
W ?23,"DFN:",$$GET1^DIQ(63,LRDFN,.03,"I")
W ?44,"PT NAME:",$$GET1^DIQ(63,LRDFN,.03)
W !
;
W ?4,"Provider:",$E($$GET1^DIQ(68.02,LRASIEN,6.5),1,36)
W ?42,"Rpt R Loc:",$$GET1^DIQ(68.02,LRASIEN,6)
W !
;
W ?5,"Ord Loc:",$E($$GET1^DIQ(68.02,LRASIEN,94),1,27)
W ?48,"Div:",$E(DIV,1,28)
W !
W ?4,"Log-In Person:",$E($$GET1^DIQ(68.02,LRASIEN,6.7),1,19)
W ?39,"File 200 IEN:",$$GET1^DIQ(68.02,LRASIEN,6.7,"I")
W !!
Q
;
NODE3 ; EP - Display Accession Node Three
S STR=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
;
W ?4,"Draw Time:"
S DRAWTIME=$$GET1^DIQ(68.02,LRASIEN,9,"I")
W $TR($$UP^XLFSTR($$FMTE^XLFDT(DRAWTIME,"5MPZ")),"@"," ")
W ?39,"Lab Arr Time:"
S LARRTIME=$$GET1^DIQ(68.02,LRASIEN,12,"I")
W $TR($$UP^XLFSTR($$FMTE^XLFDT(LARRTIME,"5MPZ")),"@"," ")
W !
;
W ?14,DRAWTIME,?52,LARRTIME,!
;
W ?4,"Result Dt:"
S RESULTDT=$$GET1^DIQ(68.02,LRASIEN,13,"I")
I RESULTDT D
. S TEMP=$$UP^XLFSTR($$FMTE^XLFDT(RESULTDT,"5MPZ"))
. W $P(TEMP," "),$$RJ^XLFSTR($P(TEMP," ",2,3),9)
W ?39,"Inverse Date:",$$GET1^DIQ(68.02,LRASIEN,13.5,"I")
W !
Q
;
ACCTESTS ; EP - Display the Tests
NEW TECH
;
S LRAT=.9999999
F S LRAT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRAT)) Q:LRAT<1 D
. S LRATIEN=LRAT_","_LRASIEN
. S TESTIEN=$P(STR,U)
. W !,?4,"Test:",$$GET1^DIQ(68.04,LRATIEN,.01)
. W ?40,"File 60 IEN:",$$GET1^DIQ(68.04,LRATIEN,.01,"I")
. W !
. S TECH=+$P(STR,U,4)
. W ?4,"Tech:",$$GET1^DIQ(68.04,LRATIEN,3)
. S DATETIME=$$GET1^DIQ(68.04,LRATIEN,4,"I")
. I DATETIME D
.. W ?44,"Comp Dt:"
.. S TEMP=$$UP^XLFSTR($$FMTE^XLFDT(DATETIME,"5MPZ"))
.. W $P(TEMP," "),$$RJ^XLFSTR($P(TEMP," ",2,3),9)
. W !
. S STR=$$GET1^DIQ(68.04,LRATIEN,5)
. I $L(STR) D
.. W ?8,"Disp:",$E(STR,1,67)
.. W !
;
W !
;
S LRASP=0
F S LRASP=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,LRASP)) Q:LRASP<1 D
. S LRASPIEN=LRASP_","_LRASIEN
. W ?5,"Specimen:",$E($$GET1^DIQ(68.05,LRASPIEN,.01),1,32)
. W ?40,"File 61 IEN:",$$GET1^DIQ(68.05,LRASPIEN,.01,"I")
. W !
. W ?4,"Coll Samp:",$E($$GET1^DIQ(68.05,LRASPIEN,1),1,32)
. W ?40,"File 62 IEN:",$$GET1^DIQ(68.05,LRASPIEN,1,"I")
. W !
Q
;
; ============================= UTILITIES =============================
;
VARSNEW ; EP - NEW put here to facilitate adding new routines.
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
Q
;
SETBLRVS(TWO) ; EP - Set the BLRVERN variables
K BLRVERN,BLRVERN2
S BLRVERN=$TR($P($T(+1),";")," ")
S:$L($G(TWO)) BLRVERN2=TWO
Q
ENDMESG ; EP -- Display the message
W !!,?5,MESSAGE," Routine Ends."
D PRESSKEY^BLRGMENU(10)
Q
;
ENDERQ(MESSAGE) ; EP - Function to state why routine ending. Quits with "Q"
D ENDMESG
Q "Q"
;
CENTER(STR) ; EP - Center a string using IOM
Q $$CJ^XLFSTR(STR,$G(IOM,80))
;
LINEMSG(MSG,FILLER,TAB) ; EP - Demarcation line, Version 2
S MSG="@"_$TR(MSG," ","@")_"@"
S MSG=$TR($$CJ^XLFSTR(MSG,(IOM-$S(+$G(TAB):TAB*2,1:0)))," @",FILLER_" ")
W ?($S(+$G(TAB):TAB-1,1:0)),MSG,!
Q
;
NAMEPRT(DFN,CONVERT) ;EP; return printable name
;CONVERT=1 means convert to mixed case letters
NEW VADM,X
D DEM^VADPT
S X=$P($P(VADM(1),",",2)," ")_" "_$P(VADM(1),",")
I $G(CONVERT) X ^DD("FUNC",14,1)
Q X
BLRMANP3 ; IHS/MSC/MKK - Multiple Accession Not Performed utility, part 3 ; 22-Apr-2016 15:12 ; MKK
+1 ;;5.2;IHS LABORATORY;**1039**;NOV 01, 1997;Build 38
+2 ;
EEP ; Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
+4 ; The following cloned from BLRRLTDU
XTMPRPT ; EP - ^XTMP Issues node - Interactive Report
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 DO SETBLRVS("XTMPRPT")
+4 SET HEADER(1)="^XTMP Global"
+5 ;
+6 IF $DATA(^XTMP("BLRMANPU","UID"))<1
Begin DoDot:1
+7 DO HEADERDT^BLRGMENU
+8 WRITE !,?4,"^XTMP Global has no Data for 'Multiple Accession Not Performed' Errors."
+9 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+10 ;
+11 SET HEADER(2)="Accession (UID)"
+12 SET HEADER(3)=$$CJ^XLFSTR("Could *NOT* Mark 'Not Performed' Report",80)
+13 SET HEADER(4)=" "
+14 SET HEADER(5)="UID"
+15 SET $EXTRACT(HEADER(5),13)="Date/Time"
+16 SET $EXTRACT(HEADER(5),29)="DUZ"
+17 SET $EXTRACT(HEADER(5),36)="Error Message"
+18 ;
+19 SET MAXLINES=IOSL-4
SET LINES=MAXLINES+10
+20 SET (CNT,PG)=0
+21 SET QFLG="NO"
+22 ;
+23 SET UID=0
SET MSGL=5
+24 FOR
SET UID=$ORDER(^XTMP("BLRMANPU","UID",UID))
IF UID<1!(QFLG="Q")
QUIT
Begin DoDot:1
+25 SET MSGDUZ=0
+26 FOR
SET MSGDUZ=$ORDER(^XTMP("BLRMANPU","UID",UID,"DUZ",MSGDUZ))
IF MSGDUZ<1!(QFLG="Q")
QUIT
Begin DoDot:2
+27 SET NAMEDUZ=$$GET1^DIQ(200,MSGDUZ,"NAME")
+28 SET HDATE=""
+29 FOR
SET HDATE=$ORDER(^XTMP("BLRMANPU","UID",UID,"DUZ",MSGDUZ,HDATE))
IF HDATE=""!(QFLG="Q")
QUIT
Begin DoDot:3
+30 SET STR=$GET(^XTMP("BLRMANPU","UID",UID,"DUZ",MSGDUZ,HDATE))
+31 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,"NO")
IF QFLG="Q"
QUIT
+32 WRITE UID
+33 WRITE ?12,$$HTE^XLFDT(HDATE,"2MZ")
+34 WRITE ?28,MSGDUZ
+35 DO LINEWRAP^BLRGMENU(35,$PIECE(STR,"^"),45)
+36 WRITE !
+37 SET LINES=LINES+1
End DoDot:3
End DoDot:2
End DoDot:1
+38 ;
+39 DO PRESSKEY^BLRGMENU(9)
+40 QUIT
+41 ;
XTMPKILL ; EP - Purge the ^XTMP("BLRMANPU") Node
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 SET HEADER(1)="^XTMP Global"
+4 SET HEADER(2)="Purge"
+5 DO HEADERDT^BLRGMENU
+6 WRITE ?9,"This option will purge the ^XTMP(""BLRMANPU"") global.",!!
+7 WRITE ?9,"That global contains any error messages created during the",!!
+8 WRITE ?14,"Mark Multiple Accessions as Not Performed",!!
+9 WRITE ?9,"process."
+10 SET TAB=$JUSTIFY("",5)
+11 DO ^XBFMK
+12 SET DIR(0)="YO"
+13 SET DIR("A")=TAB_"Are you Sure"
+14 DO ^DIR
+15 IF +Y<1
QUIT $$BADSTUFN^BLRUTIL7("No/Quit/Invalid Response.")
+16 ;
+17 DO ^XBFMK
+18 SET DIR(0)="YO"
+19 SET DIR("A")=TAB_"Second Chance: Are you Really sure"
+20 DO ^DIR
+21 IF +Y<1
QUIT $$BADSTUFN^BLRUTIL7("No/Quit/Invalid Response.")
+22 ;
+23 DO ^XBFMK
+24 SET DIR(0)="Y"
+25 SET DIR("A")=TAB_"FINAL CHANCE: Are you Absolutely sure"
+26 DO ^DIR
+27 IF +Y<1
QUIT $$BADSTUFN^BLRUTIL7("No/Quit/Invalid Response.")
+28 ;
+29 WRITE !!,TAB_TAB_"^XTMP(""BLRMANPU"") Global Purged."
+30 KILL ^XTMP("BLRMANPU")
+31 ;
+32 DO PRESSKEY^BLRGMENU(4)
+33 QUIT
+34 ;
DETAIL68 ; EP - Accession (#68) File Data Detail
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 IF $$DETAILIN("ACDETAIL")="Q"
QUIT
+4 ;
+5 DO NODEZERO
DO NODE3
DO ACCTESTS
+6 ;
+7 IF $ORDER(^LRO(69,"C",ORDERNUM,0))<1
WRITE !,?6,"**Order #:",ORDERNUM," is **NOT** in the Lab Order Entry (#69) File."
+8 ;
+9 DO PRESSKEY^BLRGMENU(4)
+10 QUIT
+11 ;
DETAILIN(SUBRTN) ; EP - Initialize variables
+1 NEW COL,COL2
+2 DO SETBLRVS($GET(SUBRTN))
+3 ;
+4 SET HEADER(1)="Accession Detail"
+5 ;
+6 DO HEADERDT^BLRGMENU
+7 ;
+8 DO ^LRWU4
+9 ;
+10 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))<1
QUIT $$ENDERQ("Accession does not Exist.")
+11 ;
+12 SET LRSS=$PIECE($GET(^LRO(68,LRAA,0)),U,2)
+13 SET LRASIEN=LRAN_","_LRAD_","_LRAA
+14 SET ORDERNUM=$$GET1^DIQ(68.02,LRASIEN,14)
+15 SET LRAS=$$GET1^DIQ(68.02,LRASIEN,15)
+16 SET UID=$$GET1^DIQ(68.02,LRASIEN,16)
+17 SET DIV=$$GET1^DIQ(68.02,LRASIEN,26)
+18 ;
+19 SET HEADER(2)="Accession #:"_LRAS
+20 SET HEADER(3)=$$CENTER("LRAA:"_LRAA_" LRAD:"_LRAD_" LRAN:"_LRAN)
+21 ;
+22 DO ^%ZIS
+23 IF POP
QUIT $$ENDERQ("Invalid %ZIS call.")
+24 ;
+25 SET MAXLINES=IOSL-4
+26 SET LINES=MAXLINES+10
+27 SET PG=0
SET RESULTDT=""
SET QFLG="OK"
+28 QUIT "OK"
+29 ;
NODEZERO() ; EP - Display Accession Node Zero
+1 DO HEADERDT^BLRGMENU
+2 ;
+3 ; D LINEMSG("Accession (#68) file Data","=",5)
+4 ;
+5 SET STR=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
+6 ;
+7 WRITE ?5,"Order #:",ORDERNUM
+8 IF $ORDER(^LRO(69,"C",ORDERNUM,0))<1
WRITE "**"
+9 WRITE ?23,"UID:",UID
+10 WRITE ?43,"Order Dt:"
+11 SET ORDERDT=$$GET1^DIQ(68.02,LRASIEN,3,"I")
+12 IF ORDERDT
WRITE $$FMTE^XLFDT(ORDERDT,"5DZ")
+13 WRITE !
+14 ;
+15 SET LRDFN=$$GET1^DIQ(68.02,LRASIEN,.01,"I")
+16 WRITE ?7,"LRDFN:",LRDFN
+17 WRITE ?23,"DFN:",$$GET1^DIQ(63,LRDFN,.03,"I")
+18 WRITE ?44,"PT NAME:",$$GET1^DIQ(63,LRDFN,.03)
+19 WRITE !
+20 ;
+21 WRITE ?4,"Provider:",$EXTRACT($$GET1^DIQ(68.02,LRASIEN,6.5),1,36)
+22 WRITE ?42,"Rpt R Loc:",$$GET1^DIQ(68.02,LRASIEN,6)
+23 WRITE !
+24 ;
+25 WRITE ?5,"Ord Loc:",$EXTRACT($$GET1^DIQ(68.02,LRASIEN,94),1,27)
+26 WRITE ?48,"Div:",$EXTRACT(DIV,1,28)
+27 WRITE !
+28 WRITE ?4,"Log-In Person:",$EXTRACT($$GET1^DIQ(68.02,LRASIEN,6.7),1,19)
+29 WRITE ?39,"File 200 IEN:",$$GET1^DIQ(68.02,LRASIEN,6.7,"I")
+30 WRITE !!
+31 QUIT
+32 ;
NODE3 ; EP - Display Accession Node Three
+1 SET STR=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
+2 ;
+3 WRITE ?4,"Draw Time:"
+4 SET DRAWTIME=$$GET1^DIQ(68.02,LRASIEN,9,"I")
+5 WRITE $TRANSLATE($$UP^XLFSTR($$FMTE^XLFDT(DRAWTIME,"5MPZ")),"@"," ")
+6 WRITE ?39,"Lab Arr Time:"
+7 SET LARRTIME=$$GET1^DIQ(68.02,LRASIEN,12,"I")
+8 WRITE $TRANSLATE($$UP^XLFSTR($$FMTE^XLFDT(LARRTIME,"5MPZ")),"@"," ")
+9 WRITE !
+10 ;
+11 WRITE ?14,DRAWTIME,?52,LARRTIME,!
+12 ;
+13 WRITE ?4,"Result Dt:"
+14 SET RESULTDT=$$GET1^DIQ(68.02,LRASIEN,13,"I")
+15 IF RESULTDT
Begin DoDot:1
+16 SET TEMP=$$UP^XLFSTR($$FMTE^XLFDT(RESULTDT,"5MPZ"))
+17 WRITE $PIECE(TEMP," "),$$RJ^XLFSTR($PIECE(TEMP," ",2,3),9)
End DoDot:1
+18 WRITE ?39,"Inverse Date:",$$GET1^DIQ(68.02,LRASIEN,13.5,"I")
+19 WRITE !
+20 QUIT
+21 ;
ACCTESTS ; EP - Display the Tests
+1 NEW TECH
+2 ;
+3 SET LRAT=.9999999
+4 FOR
SET LRAT=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRAT))
IF LRAT<1
QUIT
Begin DoDot:1
+5 SET LRATIEN=LRAT_","_LRASIEN
+6 SET TESTIEN=$PIECE(STR,U)
+7 WRITE !,?4,"Test:",$$GET1^DIQ(68.04,LRATIEN,.01)
+8 WRITE ?40,"File 60 IEN:",$$GET1^DIQ(68.04,LRATIEN,.01,"I")
+9 WRITE !
+10 SET TECH=+$PIECE(STR,U,4)
+11 WRITE ?4,"Tech:",$$GET1^DIQ(68.04,LRATIEN,3)
+12 SET DATETIME=$$GET1^DIQ(68.04,LRATIEN,4,"I")
+13 IF DATETIME
Begin DoDot:2
+14 WRITE ?44,"Comp Dt:"
+15 SET TEMP=$$UP^XLFSTR($$FMTE^XLFDT(DATETIME,"5MPZ"))
+16 WRITE $PIECE(TEMP," "),$$RJ^XLFSTR($PIECE(TEMP," ",2,3),9)
End DoDot:2
+17 WRITE !
+18 SET STR=$$GET1^DIQ(68.04,LRATIEN,5)
+19 IF $LENGTH(STR)
Begin DoDot:2
+20 WRITE ?8,"Disp:",$EXTRACT(STR,1,67)
+21 WRITE !
End DoDot:2
End DoDot:1
+22 ;
+23 WRITE !
+24 ;
+25 SET LRASP=0
+26 FOR
SET LRASP=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,5,LRASP))
IF LRASP<1
QUIT
Begin DoDot:1
+27 SET LRASPIEN=LRASP_","_LRASIEN
+28 WRITE ?5,"Specimen:",$EXTRACT($$GET1^DIQ(68.05,LRASPIEN,.01),1,32)
+29 WRITE ?40,"File 61 IEN:",$$GET1^DIQ(68.05,LRASPIEN,.01,"I")
+30 WRITE !
+31 WRITE ?4,"Coll Samp:",$EXTRACT($$GET1^DIQ(68.05,LRASPIEN,1),1,32)
+32 WRITE ?40,"File 62 IEN:",$$GET1^DIQ(68.05,LRASPIEN,1,"I")
+33 WRITE !
End DoDot:1
+34 QUIT
+35 ;
+36 ; ============================= UTILITIES =============================
+37 ;
VARSNEW ; EP - NEW put here to facilitate adding new routines.
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 QUIT
+3 ;
SETBLRVS(TWO) ; EP - Set the BLRVERN variables
+1 KILL BLRVERN,BLRVERN2
+2 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+3 IF $LENGTH($GET(TWO))
SET BLRVERN2=TWO
+4 QUIT
ENDMESG ; EP -- Display the message
+1 WRITE !!,?5,MESSAGE," Routine Ends."
+2 DO PRESSKEY^BLRGMENU(10)
+3 QUIT
+4 ;
ENDERQ(MESSAGE) ; EP - Function to state why routine ending. Quits with "Q"
+1 DO ENDMESG
+2 QUIT "Q"
+3 ;
CENTER(STR) ; EP - Center a string using IOM
+1 QUIT $$CJ^XLFSTR(STR,$GET(IOM,80))
+2 ;
LINEMSG(MSG,FILLER,TAB) ; EP - Demarcation line, Version 2
+1 SET MSG="@"_$TRANSLATE(MSG," ","@")_"@"
+2 SET MSG=$TRANSLATE($$CJ^XLFSTR(MSG,(IOM-$SELECT(+$GET(TAB):TAB*2,1:0)))," @",FILLER_" ")
+3 WRITE ?($SELECT(+$GET(TAB):TAB-1,1:0)),MSG,!
+4 QUIT
+5 ;
NAMEPRT(DFN,CONVERT) ;EP; return printable name
+1 ;CONVERT=1 means convert to mixed case letters
+2 NEW VADM,X
+3 DO DEM^VADPT
+4 SET X=$PIECE($PIECE(VADM(1),",",2)," ")_" "_$PIECE(VADM(1),",")
+5 IF $GET(CONVERT)
XECUTE ^DD("FUNC",14,1)
+6 QUIT X
