BLRUTIL5 ;IHS/ITSC/TPF - MISC IHS LAB UTILITIES (Cont) ; 22-Oct-2013 09:22 ; MKK
;;5.2;IHS LABORATORY;**1033**;NOV 01, 1997
;
; Following subroutines pulled from BLRUTIL routine because BLRUTIL was becoming too large.
;
; Original code follows:
;
;THE FOLLOWING IS A FIX FOR PATCH 10 THAT LEFT PARENTS
;WITH 'STATUS FLAG' NOT SET PROPERLY
PAT10FIX(BORDDATE,EORDDATE) ; EP
;^BLRTXLOG("AOT",3010227.085637,1,9999044,6150)=""
N BLR
S BLR="^BLRPAR"
I $$KILLOK^ZIBGCHAR($P(BLR,U,2)) W !,$$ERR^ZIBGCHAR($$KILLOK^ZIBGCHAR($P(BLR,U,2)))_" "_BLR
K @BLR
S U="^"
S ORDDATE=BORDDATE-1
F S ORDDATE=$O(^BLRTXLOG("AOT",ORDDATE)) Q:ORDDATE=""!(ORDDATE>EORDDATE) D
.S PANEL=""
.F S PANEL=$O(^BLRTXLOG("AOT",ORDDATE,PANEL)) Q:PANEL="" D
..S TESTPTR=""
..F S TESTPTR=$O(^BLRTXLOG("AOT",ORDDATE,PANEL,TESTPTR)) Q:TESTPTR="" D
...S SEQNUM=""
...F S SEQNUM=$O(^BLRTXLOG("AOT",ORDDATE,PANEL,TESTPTR,SEQNUM)) Q:SEQNUM="" D
....;
....S LOGREC0=$G(^BLRTXLOG(SEQNUM,0))
....S LOGREC1=$G(^BLRTXLOG(SEQNUM,1))
....S NOPARENT=$P(LOGREC1,U)
....W !,LOGREC1
....I 'NOPARENT W !,"PARENT: ",SEQNUM S ^BLRPAR(SEQNUM)="" Q
....W !,"CHILD: ",SEQNUM
....S STATUS=$P(LOGREC0,U,2)
....S CPTCODE=$P(LOGREC1,U,11)
....S ^BLRPAR(NOPARENT,SEQNUM)=""
....;
Q
;
;FIND BAD CH or mi ZERO NODES
FIXCH S U="^",COUNT=0
S LRDFN=0,TARDATE=6959869.8 ;1/29 AT 12:00
F S LRDFN=$O(^LR(LRDFN)) Q:'LRDFN D
.S LRIDT=0
.F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:(LRIDT="") D
..;W !,9999999-LRIDT
..;NOTE: NOTE P^7 should be p10 when doing ch
..Q:($P(^LR(LRDFN,"CH",LRIDT,0),U,5)'=""&($P(^LR(LRDFN,"CH",LRIDT,0),U,10)'=""))
..S COUNT=COUNT+1
..;W !,"^LR("_LRDFN_",""CH"","_LRIDT_",0)="_$G(^LR(LRDFN,"CH",LRIDT,0))
..S LRNODE="^LR("_LRDFN_",""CH"","_LRIDT_",0)"
..S LRUID=$G(^LR(LRDFN,"CH",LRIDT,"ORU"))
..I 'LRUID W !,"MISSING ""ORU"" NODE IN FILE 63"_"^LR("_LRDFN_",""CH"","_LRIDT_",0)" Q
..S LRPROV=$P(^LR(LRDFN,"CH",LRIDT,0),U,10) ;FOR CH SUBSCRIPT ONLY
..S LRSPEC=$P(^LR(LRDFN,"CH",LRIDT,0),U,5)
..;
..S FLAG=0
..D GETMISS(LRUID,.FLAG) ;GO TO LRO(68 AND FIND MISSING DATA
..I FLAG W !,"PROBLEM WITH UID ",LRUID," ""C"" X-REF IN LRO(68" Q
..W !!,"^LR("_LRDFN_",""CH"","_LRIDT_",0)="_$G(^LR(LRDFN,"CH",LRIDT,0))
..W !,"FOUND ACCESSION: ",ACCESSN," AT ",NODE
..W !,"FILE 63 PROV ENTRY IS: ",LRPROV," SHOULD BE: ",GPROV
..W !,"FILE 63 SPEC ENTRY IS: ",LRSPEC," SHOULD BE: ",GSPEC
..W !,"FIX MADE TO LR NODE: ",LRNODE
..;UNCOMMENT FOLLOWING LINES TO DO FIX
..;I LRPROV="" S $P(@LRNODE,U,10)=GPROV ;FOR CH
..;I LRSPEC="" S $P(@LRNODE,U,5)=GSPEC
Q
;
GETMISS(UID,FLAG) ; EP
S ACCAREA=$O(^LRO(68,"C",UID,"")) I ACCAREA="" S FLAG=1 Q
S ACCDAT=$O(^LRO(68,"C",UID,ACCAREA,"")) I ACCAREA="" S FLAG=1 Q
S ACCNUM=$O(^LRO(68,"C",UID,ACCAREA,ACCDAT,"")) I ACCAREA="" S FLAG=1 Q
;
S GPROV=$P($G(^LRO(68,ACCAREA,1,ACCDAT,1,ACCNUM,0)),U,8) ;GOOD PROV ENTRY
S GSPEC=$P($G(^LRO(68,ACCAREA,1,ACCDAT,1,ACCNUM,5,1,0)),U) ;GOOD SPEC ENTRY
S ACCESSN=$P($G(^LRO(68,ACCAREA,1,ACCDAT,1,ACCNUM,.2)),U) ;ACCESSION
S NODE="LRO(68,"_ACCAREA_",1,"_ACCDAT_",1,"_ACCNUM_",0)" ;ACCESSION NODE
Q
;
FIXMI ; EP
S U="^",COUNT=0
S LRDFN=0,TARDATE=6959869.8 ;1/29 AT 12:00
S TARDATE=0
F S LRDFN=$O(^LR(LRDFN)) Q:'LRDFN D
.S LRIDT=0
.F S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:(LRIDT="") D
..;W !,9999999-LRIDT
..;Q:($P(^LR(LRDFN,"MI",LRIDT,0),U,5)'=""&($P(^LR(LRDFN,"MI",LRIDT,0),U,7)'="")&
..Q:$P(^LR(LRDFN,"MI",LRIDT,0),U,11)'=0&($P(^LR(LRDFN,"MI",LRIDT,0),U,7)'="")
..S COUNT=COUNT+1
..;W !,"^LR("_LRDFN_",""MI"","_LRIDT_",0)="_$G(^LR(LRDFN,"MI",LRIDT,0))
..S LRNODE="^LR("_LRDFN_",""MI"","_LRIDT_",0)"
..S LRPROV=$P(^LR(LRDFN,"MI",LRIDT,0),U,7) ;FOR MI SUBSCRIPT ONLY
..S LRSPEC=$P(^LR(LRDFN,"MI",LRIDT,0),U,5)
..S LRCOL=$P(^LR(LRDFN,"MI",LRIDT,0),U,11)
..;
..S ACCESSN=$P(^LR(LRDFN,"MI",LRIDT,0),U,6)
..S ACCNUM=$P(ACCESSN," ",3)
..S ACCYR=$P(ACCESSN," ",2)
..S ACCDT="3"_ACCYR_"0000"
..S ACCAREA=5
..;
..W !!,LRNODE_"="_@LRNODE
..S NODE="^LRO(68,"_ACCAREA_",1,"_ACCDT_",1,"_ACCNUM_",0)"
..;W !,"MATCHES TO: ",NODE_"="_@NODE
..;
..W !,"FOUND ACCESSION: ",ACCESSN," AT ",NODE
..S GPROV=$P(@NODE,U,8)
..S GSPEC=$P($G(^LRO(68,ACCAREA,1,ACCDT,1,ACCNUM,5,1,0)),U)
..W !,"FILE 63 PROV ENTRY IS: ",LRPROV," SHOULD BE: ",GPROV
..W !,"FILE 63 SPEC ENTRY IS: ",LRSPEC," SHOULD BE: ",GSPEC
..W !,"FIX MADE TO LR NODE: ",LRNODE
..W !,"TESTS FOUND:"
..D GETTESTS
..;B "S+"
..I CNT=1 D
...S $P(@LRNODE,U,11)=GCOLSAMP
...S $P(^LRO(68,ACCAREA,1,ACCDT,1,ACCNUM,5,1,0),U,2)=GCOLSAMP
..;I LRPROV="" S $P(@LRNODE,U,7)=GPROV ;FOR MI
..;I LRSPEC="" S $P(@LRNODE,U,5)=GSPEC
Q
;
GETTESTS ; EP
S LRTST=0
F S LRTST=$O(^LRO(68,ACCAREA,1,ACCDT,1,ACCNUM,4,LRTST)) Q:'LRTST D
.S TSTNAME=$P($G(^LAB(60,LRTST,0)),U)
.W !?5,LRTST_":"_$P($G(^LAB(60,LRTST,0)),U)
.W !,"COLLECTION SAMPLES FOUND FOR TEST ",LRTST
.D COLSAMP
.W !,"COLLECTION SAMPLES FOUND ",CNT
Q
;
COLSAMP ;^LAB(60,1,3,1,0)=3^SUPERBILL^LAVENDER^
S GCOLSAMP=0
S COLSAMP=0
F CNT=0:1 S COLSAMP=$O(^LAB(60,LRTST,3,COLSAMP)) Q:'COLSAMP D
.S COLIEN=$P($G(^LAB(60,LRTST,3,COLSAMP,0)),U)
.W !?5,"COLLECTION SAMPLE: ",COLIEN,":",$P($G(^LAB(62,COLIEN,0)),U)
I CNT=1 S GCOLSAMP=$P($G(^LAB(60,LRTST,3,1,0)),U)
W CNT
Q
;
; =========================================================================================
; Following code moved here from BLRUTIL3
; =========================================================================================
;
INSTLRPT ; EP -- Report of ^BLRINSTL global
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D INSTLRPI
;
F S CP=$O(^BLRINSTL("LAB PATCH",CP),-1) Q:CP<1!(QFLG="Q") D
. F S CNT=$O(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT)) Q:CNT<1!(QFLG="Q") D
.. D INSTLRPL
Q
;
INSTLRPI ; EP -- Initialize variables
S BLRVERN=$P($P($T(+1),";")," ")
;
S HEADER(1)="IHS LAB Patches Report"
;
S FRSTPTCH=$O(^BLRINSTL("LAB PATCH",0))
S FIRST=$O(^BLRINSTL("LAB PATCH",FRSTPTCH,"INSTALLED BY",0))
S FIRSTDT=$P($G(^BLRINSTL("LAB PATCH",FRSTPTCH,"INSTALLED BY",FIRST,"DATE/TIME")),"@")
;
S LASTPTCH=$O(^BLRINSTL("LAB PATCH","A"),-1)
S LAST=$O(^BLRINSTL("LAB PATCH",LASTPTCH,"INSTALLED BY","A"),-1)
S LASTDT=$P($G(^BLRINSTL("LAB PATCH",LASTPTCH,"INSTALLED BY",LAST,"DATE/TIME")),"@")
;
S HEADER(2)="Patches Installed From "_FIRSTDT_" thru "_LASTDT
S HEADER(3)=" "
S $E(HEADER(4),5)="Patch"
S $E(HEADER(4),15)="Who"
S $E(HEADER(4),45)="When"
;
S MAXLINES=20,LINES=MAXLINES+10,PG=0,(HD1,QFLG)="NO"
S CNT=0
S CP="A"
Q
;
INSTLRPL ; EP -- Line of Data
I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HD1) Q:QFLG="Q"
;
W ?4,CP
W ?14,$G(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT))
W ?44,$TR($P($G(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT,"DATE/TIME")),":",1,2),"@"," ")
W !
S LINES=LINES+1
Q
;
ESIGINFO ; EP -- Rework of BLRUTIL ESIGINFO subroutine.
NEW DOCDUZ,DOCIEN,ESIGDSTR,REVIEWDV,TAB
NEW REVSTS
;
; If E-SIG not turned on, Quit
I '$$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",+$G(DUZ(2))) Q
;
S DOCIEN=$O(^VA(200,"B",LRDOC,"")) ; LRDOC = Ordering Provider
;
; If no IEN, Quit. Usually happens when LRDOC="Unknown"
Q:$G(DOCIEN)=""
;
I '($D(^BLRALAB(9009027.1,DOCIEN,0))#2) W ?56,"NOT E-SIG PARTICIPATING" Q
I $P(^BLRALAB(9009027.1,DOCIEN,0),U,7)'="A" W ?53,"INACTIVE E-SIG PARTICIPANT" Q
;
;LRSS doesn't exist when doing option 'BLRTASK CUM', so set it.
S:$G(LRSS)="" LRSS=$P($G(^LRO(68,LRAA,0)),"^",2)
;
S ESIGDSTR=$G(^LR(LRDFN,LRSS,LRIDT,9009027)) ; E-SIG string Data
;
Q:$P(ESIGDSTR,U,2)="" ; NO Signing Physician
Q:$P(^BLRALAB(9009027.1,$P(ESIGDSTR,U,2),0),U,7)'="A" ; NOT Active
;
; REVIEW status Data Values
S REVIEWDV=$$UP^XLFSTR($P($G(^DD(63.04,.9009025,0)),U,3))
S REVSTS=$P($P(REVIEWDV,$P(ESIGDSTR,U)_":",2),";")
;
; Make sure E-SIG STATUS is flush right
S TAB=IOM-(16+$L(REVSTS))
W ?TAB,"E-SIG STATUS: ",REVSTS
;
Q:'$P(ESIGDSTR,U,5) ; NO Signed Date
;
Q:REVSTS["NOT REV" ; NOT Reviewed
;
W !?5,"SIGNING PHYSICIAN: "
W $P($G(^VA(200,$P(ESIGDSTR,U,2),0)),U)
W !?5,"DATE/TIME RESULT SIGNED: "
W $TR($$FMTE^XLFDT($P(ESIGDSTR,U,5),"2MZ"),"@"," ")
;
Q
;
NOCOLLDT ; EP - "Quick & Dirty" Routine to determine if Accession file has no DRAW DATE but an Accession Number
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),";")," ")
K ^TMP("BLRUTIL4",$J,"NOCOLLDT")
;
W !!,?4,"Compilation Begins"
S LRAA=.9999999,(BADCNT,CNT)=0
F S LRAA=$O(^LRO(68,LRAA)) Q:LRAA<1 D
. S LRAD=0
. F S LRAD=$O(^LRO(68,LRAA,1,LRAD)) Q:LRAD<1 D
.. S LRAN=0
.. F S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN)) Q:LRAN<1 D
... Q:+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))<1 ; No Zero Node Data, skip
... ;
... S UID=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
... Q:UID<1 ; No UID, skip
... ;
... S CNT=CNT+1
... W:(CNT#100)=0 "." W:$X>74 !,?4
... ;
... Q:+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) ; Draw Date Exists
... ;
... W:($L(UID)+$X)>74 !,?3
... W " >",UID,"< "
... W:$X>74 !,?4
... S ^TMP("BLRUTIL4",$J,"NOCOLLDT",LRAA,LRAD,LRAN)=UID
... S BADCNT=BADCNT+1
;
S WOTCOL=$X
W:WOTCOL<(IOM-17) "Compilation Ends"
W:WOTCOL>(IOM-18) !,?4,"Compilation Ends"
;
W !!,?4,"Number of Accessions Analyzed = ",CNT,!
W:BADCNT<1 !,?9,"All Accessions have Draw Dates",!
W:BADCNT !,?9,"# of Accessions with No Draw Date = ",BADCNT,!
;
D PRESSKEY^BLRGMENU(9)
;
D:BADCNT NOCOLRPT
;
K ^TMP("BLRUTIL4",$J,"NOCOLLDT")
Q
;
NOCOLRPT ; EP - Report on ^TMP("BLRUTIL4",$J,"NOCOLLDT"
S HEADER(1)="Accessions With No Draw Date"
S HEADER(2)=" "
S HEADER(3)="LRAA"
S $E(HEADER(3),6)="LRAD"
S $E(HEADER(3),15)="LRAN"
S $E(HEADER(3),25)="UID"
S $E(HEADER(3),40)="ARRIVAL TIME"
S $E(HEADER(3),55)="LRDFN"
S $E(HEADER(3),65)="INVERSE DATE"
;
D HEADERDT^BLRGMENU
;
S LRAA=0
F S LRAA=$O(^TMP("BLRUTIL4",$J,"NOCOLLDT",LRAA)) Q:LRAA<1 D
. S LRAD=0
. F S LRAD=$O(^TMP("BLRUTIL4",$J,"NOCOLLDT",LRAA,LRAD)) Q:LRAD<1 D
.. S LRAN=0
.. F S LRAN=$O(^TMP("BLRUTIL4",$J,"NOCOLLDT",LRAA,LRAD,LRAN)) Q:LRAN<1 D
... S UID=+$G(^TMP("BLRUTIL4",$J,"NOCOLLDT",LRAA,LRAD,LRAN))
... S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),STR3=$G(^(3))
... S LABARRT=$P(STR3,"^",3)
... S LRIDT=$P(STR3,"^",5)
... ;
... W LRAA
... W ?5,LRAD
... W ?14,LRAN
... W ?24,UID
... W ?39,LABARRT
... W ?54,LRDFN
... W ?64,LRIDT
... W !
;
D PRESSKEY^BLRGMENU(9)
Q
BLRUTIL5 ;IHS/ITSC/TPF - MISC IHS LAB UTILITIES (Cont) ; 22-Oct-2013 09:22 ; MKK
+1 ;;5.2;IHS LABORATORY;**1033**;NOV 01, 1997
+2 ;
+3 ; Following subroutines pulled from BLRUTIL routine because BLRUTIL was becoming too large.
+4 ;
+5 ; Original code follows:
+6 ;
+7 ;THE FOLLOWING IS A FIX FOR PATCH 10 THAT LEFT PARENTS
+8 ;WITH 'STATUS FLAG' NOT SET PROPERLY
PAT10FIX(BORDDATE,EORDDATE) ; EP
+1 ;^BLRTXLOG("AOT",3010227.085637,1,9999044,6150)=""
+2 NEW BLR
+3 SET BLR="^BLRPAR"
+4 IF $$KILLOK^ZIBGCHAR($PIECE(BLR,U,2))
WRITE !,$$ERR^ZIBGCHAR($$KILLOK^ZIBGCHAR($PIECE(BLR,U,2)))_" "_BLR
+5 KILL @BLR
+6 SET U="^"
+7 SET ORDDATE=BORDDATE-1
+8 FOR
SET ORDDATE=$ORDER(^BLRTXLOG("AOT",ORDDATE))
IF ORDDATE=""!(ORDDATE>EORDDATE)
QUIT
Begin DoDot:1
+9 SET PANEL=""
+10 FOR
SET PANEL=$ORDER(^BLRTXLOG("AOT",ORDDATE,PANEL))
IF PANEL=""
QUIT
Begin DoDot:2
+11 SET TESTPTR=""
+12 FOR
SET TESTPTR=$ORDER(^BLRTXLOG("AOT",ORDDATE,PANEL,TESTPTR))
IF TESTPTR=""
QUIT
Begin DoDot:3
+13 SET SEQNUM=""
+14 FOR
SET SEQNUM=$ORDER(^BLRTXLOG("AOT",ORDDATE,PANEL,TESTPTR,SEQNUM))
IF SEQNUM=""
QUIT
Begin DoDot:4
+15 ;
+16 SET LOGREC0=$GET(^BLRTXLOG(SEQNUM,0))
+17 SET LOGREC1=$GET(^BLRTXLOG(SEQNUM,1))
+18 SET NOPARENT=$PIECE(LOGREC1,U)
+19 WRITE !,LOGREC1
+20 IF 'NOPARENT
WRITE !,"PARENT: ",SEQNUM
SET ^BLRPAR(SEQNUM)=""
QUIT
+21 WRITE !,"CHILD: ",SEQNUM
+22 SET STATUS=$PIECE(LOGREC0,U,2)
+23 SET CPTCODE=$PIECE(LOGREC1,U,11)
+24 SET ^BLRPAR(NOPARENT,SEQNUM)=""
+25 ;
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
+28 ;FIND BAD CH or mi ZERO NODES
FIXCH SET U="^"
SET COUNT=0
+1 ;1/29 AT 12:00
SET LRDFN=0
SET TARDATE=6959869.8
+2 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
IF 'LRDFN
QUIT
Begin DoDot:1
+3 SET LRIDT=0
+4 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
IF (LRIDT="")
QUIT
Begin DoDot:2
+5 ;W !,9999999-LRIDT
+6 ;NOTE: NOTE P^7 should be p10 when doing ch
+7 IF ($PIECE(^LR(LRDFN,"CH",LRIDT,0),U,5)'=""&($PIECE(^LR(LRDFN,"CH",LRIDT,0),U,10)'=""))
QUIT
+8 SET COUNT=COUNT+1
+9 ;W !,"^LR("_LRDFN_",""CH"","_LRIDT_",0)="_$G(^LR(LRDFN,"CH",LRIDT,0))
+10 SET LRNODE="^LR("_LRDFN_",""CH"","_LRIDT_",0)"
+11 SET LRUID=$GET(^LR(LRDFN,"CH",LRIDT,"ORU"))
+12 IF 'LRUID
WRITE !,"MISSING ""ORU"" NODE IN FILE 63"_"^LR("_LRDFN_",""CH"","_LRIDT_",0)"
QUIT
+13 ;FOR CH SUBSCRIPT ONLY
SET LRPROV=$PIECE(^LR(LRDFN,"CH",LRIDT,0),U,10)
+14 SET LRSPEC=$PIECE(^LR(LRDFN,"CH",LRIDT,0),U,5)
+15 ;
+16 SET FLAG=0
+17 ;GO TO LRO(68 AND FIND MISSING DATA
DO GETMISS(LRUID,.FLAG)
+18 IF FLAG
WRITE !,"PROBLEM WITH UID ",LRUID," ""C"" X-REF IN LRO(68"
QUIT
+19 WRITE !!,"^LR("_LRDFN_",""CH"","_LRIDT_",0)="_$GET(^LR(LRDFN,"CH",LRIDT,0))
+20 WRITE !,"FOUND ACCESSION: ",ACCESSN," AT ",NODE
+21 WRITE !,"FILE 63 PROV ENTRY IS: ",LRPROV," SHOULD BE: ",GPROV
+22 WRITE !,"FILE 63 SPEC ENTRY IS: ",LRSPEC," SHOULD BE: ",GSPEC
+23 WRITE !,"FIX MADE TO LR NODE: ",LRNODE
+24 ;UNCOMMENT FOLLOWING LINES TO DO FIX
+25 ;I LRPROV="" S $P(@LRNODE,U,10)=GPROV ;FOR CH
+26 ;I LRSPEC="" S $P(@LRNODE,U,5)=GSPEC
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
GETMISS(UID,FLAG) ; EP
+1 SET ACCAREA=$ORDER(^LRO(68,"C",UID,""))
IF ACCAREA=""
SET FLAG=1
QUIT
+2 SET ACCDAT=$ORDER(^LRO(68,"C",UID,ACCAREA,""))
IF ACCAREA=""
SET FLAG=1
QUIT
+3 SET ACCNUM=$ORDER(^LRO(68,"C",UID,ACCAREA,ACCDAT,""))
IF ACCAREA=""
SET FLAG=1
QUIT
+4 ;
+5 ;GOOD PROV ENTRY
SET GPROV=$PIECE($GET(^LRO(68,ACCAREA,1,ACCDAT,1,ACCNUM,0)),U,8)
+6 ;GOOD SPEC ENTRY
SET GSPEC=$PIECE($GET(^LRO(68,ACCAREA,1,ACCDAT,1,ACCNUM,5,1,0)),U)
+7 ;ACCESSION
SET ACCESSN=$PIECE($GET(^LRO(68,ACCAREA,1,ACCDAT,1,ACCNUM,.2)),U)
+8 ;ACCESSION NODE
SET NODE="LRO(68,"_ACCAREA_",1,"_ACCDAT_",1,"_ACCNUM_",0)"
+9 QUIT
+10 ;
FIXMI ; EP
+1 SET U="^"
SET COUNT=0
+2 ;1/29 AT 12:00
SET LRDFN=0
SET TARDATE=6959869.8
+3 SET TARDATE=0
+4 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
IF 'LRDFN
QUIT
Begin DoDot:1
+5 SET LRIDT=0
+6 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"MI",LRIDT))
IF (LRIDT="")
QUIT
Begin DoDot:2
+7 ;W !,9999999-LRIDT
+8 ;Q:($P(^LR(LRDFN,"MI",LRIDT,0),U,5)'=""&($P(^LR(LRDFN,"MI",LRIDT,0),U,7)'="")&
+9 IF $PIECE(^LR(LRDFN,"MI",LRIDT,0),U,11)'=0&($PIECE(^LR(LRDFN,"MI",LRIDT,0),U,7)'="")
QUIT
+10 SET COUNT=COUNT+1
+11 ;W !,"^LR("_LRDFN_",""MI"","_LRIDT_",0)="_$G(^LR(LRDFN,"MI",LRIDT,0))
+12 SET LRNODE="^LR("_LRDFN_",""MI"","_LRIDT_",0)"
+13 ;FOR MI SUBSCRIPT ONLY
SET LRPROV=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,7)
+14 SET LRSPEC=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,5)
+15 SET LRCOL=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,11)
+16 ;
+17 SET ACCESSN=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,6)
+18 SET ACCNUM=$PIECE(ACCESSN," ",3)
+19 SET ACCYR=$PIECE(ACCESSN," ",2)
+20 SET ACCDT="3"_ACCYR_"0000"
+21 SET ACCAREA=5
+22 ;
+23 WRITE !!,LRNODE_"="_@LRNODE
+24 SET NODE="^LRO(68,"_ACCAREA_",1,"_ACCDT_",1,"_ACCNUM_",0)"
+25 ;W !,"MATCHES TO: ",NODE_"="_@NODE
+26 ;
+27 WRITE !,"FOUND ACCESSION: ",ACCESSN," AT ",NODE
+28 SET GPROV=$PIECE(@NODE,U,8)
+29 SET GSPEC=$PIECE($GET(^LRO(68,ACCAREA,1,ACCDT,1,ACCNUM,5,1,0)),U)
+30 WRITE !,"FILE 63 PROV ENTRY IS: ",LRPROV," SHOULD BE: ",GPROV
+31 WRITE !,"FILE 63 SPEC ENTRY IS: ",LRSPEC," SHOULD BE: ",GSPEC
+32 WRITE !,"FIX MADE TO LR NODE: ",LRNODE
+33 WRITE !,"TESTS FOUND:"
+34 DO GETTESTS
+35 ;B "S+"
+36 IF CNT=1
Begin DoDot:3
+37 SET $PIECE(@LRNODE,U,11)=GCOLSAMP
+38 SET $PIECE(^LRO(68,ACCAREA,1,ACCDT,1,ACCNUM,5,1,0),U,2)=GCOLSAMP
End DoDot:3
+39 ;I LRPROV="" S $P(@LRNODE,U,7)=GPROV ;FOR MI
+40 ;I LRSPEC="" S $P(@LRNODE,U,5)=GSPEC
End DoDot:2
End DoDot:1
+41 QUIT
+42 ;
GETTESTS ; EP
+1 SET LRTST=0
+2 FOR
SET LRTST=$ORDER(^LRO(68,ACCAREA,1,ACCDT,1,ACCNUM,4,LRTST))
IF 'LRTST
QUIT
Begin DoDot:1
+3 SET TSTNAME=$PIECE($GET(^LAB(60,LRTST,0)),U)
+4 WRITE !?5,LRTST_":"_$PIECE($GET(^LAB(60,LRTST,0)),U)
+5 WRITE !,"COLLECTION SAMPLES FOUND FOR TEST ",LRTST
+6 DO COLSAMP
+7 WRITE !,"COLLECTION SAMPLES FOUND ",CNT
End DoDot:1
+8 QUIT
+9 ;
COLSAMP ;^LAB(60,1,3,1,0)=3^SUPERBILL^LAVENDER^
+1 SET GCOLSAMP=0
+2 SET COLSAMP=0
+3 FOR CNT=0:1
SET COLSAMP=$ORDER(^LAB(60,LRTST,3,COLSAMP))
IF 'COLSAMP
QUIT
Begin DoDot:1
+4 SET COLIEN=$PIECE($GET(^LAB(60,LRTST,3,COLSAMP,0)),U)
+5 WRITE !?5,"COLLECTION SAMPLE: ",COLIEN,":",$PIECE($GET(^LAB(62,COLIEN,0)),U)
End DoDot:1
+6 IF CNT=1
SET GCOLSAMP=$PIECE($GET(^LAB(60,LRTST,3,1,0)),U)
+7 WRITE CNT
+8 QUIT
+9 ;
+10 ; =========================================================================================
+11 ; Following code moved here from BLRUTIL3
+12 ; =========================================================================================
+13 ;
INSTLRPT ; EP -- Report of ^BLRINSTL global
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 DO INSTLRPI
+4 ;
+5 FOR
SET CP=$ORDER(^BLRINSTL("LAB PATCH",CP),-1)
IF CP<1!(QFLG="Q")
QUIT
Begin DoDot:1
+6 FOR
SET CNT=$ORDER(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT))
IF CNT<1!(QFLG="Q")
QUIT
Begin DoDot:2
+7 DO INSTLRPL
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
INSTLRPI ; EP -- Initialize variables
+1 SET BLRVERN=$PIECE($PIECE($TEXT(+1),";")," ")
+2 ;
+3 SET HEADER(1)="IHS LAB Patches Report"
+4 ;
+5 SET FRSTPTCH=$ORDER(^BLRINSTL("LAB PATCH",0))
+6 SET FIRST=$ORDER(^BLRINSTL("LAB PATCH",FRSTPTCH,"INSTALLED BY",0))
+7 SET FIRSTDT=$PIECE($GET(^BLRINSTL("LAB PATCH",FRSTPTCH,"INSTALLED BY",FIRST,"DATE/TIME")),"@")
+8 ;
+9 SET LASTPTCH=$ORDER(^BLRINSTL("LAB PATCH","A"),-1)
+10 SET LAST=$ORDER(^BLRINSTL("LAB PATCH",LASTPTCH,"INSTALLED BY","A"),-1)
+11 SET LASTDT=$PIECE($GET(^BLRINSTL("LAB PATCH",LASTPTCH,"INSTALLED BY",LAST,"DATE/TIME")),"@")
+12 ;
+13 SET HEADER(2)="Patches Installed From "_FIRSTDT_" thru "_LASTDT
+14 SET HEADER(3)=" "
+15 SET $EXTRACT(HEADER(4),5)="Patch"
+16 SET $EXTRACT(HEADER(4),15)="Who"
+17 SET $EXTRACT(HEADER(4),45)="When"
+18 ;
+19 SET MAXLINES=20
SET LINES=MAXLINES+10
SET PG=0
SET (HD1,QFLG)="NO"
+20 SET CNT=0
+21 SET CP="A"
+22 QUIT
+23 ;
INSTLRPL ; EP -- Line of Data
+1 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,HD1)
IF QFLG="Q"
QUIT
+2 ;
+3 WRITE ?4,CP
+4 WRITE ?14,$GET(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT))
+5 WRITE ?44,$TRANSLATE($PIECE($GET(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT,"DATE/TIME")),":",1,2),"@"," ")
+6 WRITE !
+7 SET LINES=LINES+1
+8 QUIT
+9 ;
ESIGINFO ; EP -- Rework of BLRUTIL ESIGINFO subroutine.
+1 NEW DOCDUZ,DOCIEN,ESIGDSTR,REVIEWDV,TAB
+2 NEW REVSTS
+3 ;
+4 ; If E-SIG not turned on, Quit
+5 IF '$$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",+$GET(DUZ(2)))
QUIT
+6 ;
+7 ; LRDOC = Ordering Provider
SET DOCIEN=$ORDER(^VA(200,"B",LRDOC,""))
+8 ;
+9 ; If no IEN, Quit. Usually happens when LRDOC="Unknown"
+10 IF $GET(DOCIEN)=""
QUIT
+11 ;
+12 IF '($DATA(^BLRALAB(9009027.1,DOCIEN,0))#2)
WRITE ?56,"NOT E-SIG PARTICIPATING"
QUIT
+13 IF $PIECE(^BLRALAB(9009027.1,DOCIEN,0),U,7)'="A"
WRITE ?53,"INACTIVE E-SIG PARTICIPANT"
QUIT
+14 ;
+15 ;LRSS doesn't exist when doing option 'BLRTASK CUM', so set it.
+16 IF $GET(LRSS)=""
SET LRSS=$PIECE($GET(^LRO(68,LRAA,0)),"^",2)
+17 ;
+18 ; E-SIG string Data
SET ESIGDSTR=$GET(^LR(LRDFN,LRSS,LRIDT,9009027))
+19 ;
+20 ; NO Signing Physician
IF $PIECE(ESIGDSTR,U,2)=""
QUIT
+21 ; NOT Active
IF $PIECE(^BLRALAB(9009027.1,$PIECE(ESIGDSTR,U,2),0),U,7)'="A"
QUIT
+22 ;
+23 ; REVIEW status Data Values
+24 SET REVIEWDV=$$UP^XLFSTR($PIECE($GET(^DD(63.04,.9009025,0)),U,3))
+25 SET REVSTS=$PIECE($PIECE(REVIEWDV,$PIECE(ESIGDSTR,U)_":",2),";")
+26 ;
+27 ; Make sure E-SIG STATUS is flush right
+28 SET TAB=IOM-(16+$LENGTH(REVSTS))
+29 WRITE ?TAB,"E-SIG STATUS: ",REVSTS
+30 ;
+31 ; NO Signed Date
IF '$PIECE(ESIGDSTR,U,5)
QUIT
+32 ;
+33 ; NOT Reviewed
IF REVSTS["NOT REV"
QUIT
+34 ;
+35 WRITE !?5,"SIGNING PHYSICIAN: "
+36 WRITE $PIECE($GET(^VA(200,$PIECE(ESIGDSTR,U,2),0)),U)
+37 WRITE !?5,"DATE/TIME RESULT SIGNED: "
+38 WRITE $TRANSLATE($$FMTE^XLFDT($PIECE(ESIGDSTR,U,5),"2MZ"),"@"," ")
+39 ;
+40 QUIT
+41 ;
NOCOLLDT ; EP - "Quick & Dirty" Routine to determine if Accession file has no DRAW DATE but an Accession Number
+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 KILL ^TMP("BLRUTIL4",$JOB,"NOCOLLDT")
+5 ;
+6 WRITE !!,?4,"Compilation Begins"
+7 SET LRAA=.9999999
SET (BADCNT,CNT)=0
+8 FOR
SET LRAA=$ORDER(^LRO(68,LRAA))
IF LRAA<1
QUIT
Begin DoDot:1
+9 SET LRAD=0
+10 FOR
SET LRAD=$ORDER(^LRO(68,LRAA,1,LRAD))
IF LRAD<1
QUIT
Begin DoDot:2
+11 SET LRAN=0
+12 FOR
SET LRAN=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN))
IF LRAN<1
QUIT
Begin DoDot:3
+13 ; No Zero Node Data, skip
IF +$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))<1
QUIT
+14 ;
+15 SET UID=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+16 ; No UID, skip
IF UID<1
QUIT
+17 ;
+18 SET CNT=CNT+1
+19 IF (CNT#100)=0
WRITE "."
IF $X>74
WRITE !,?4
+20 ;
+21 ; Draw Date Exists
IF +$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
QUIT
+22 ;
+23 IF ($LENGTH(UID)+$X)>74
WRITE !,?3
+24 WRITE " >",UID,"< "
+25 IF $X>74
WRITE !,?4
+26 SET ^TMP("BLRUTIL4",$JOB,"NOCOLLDT",LRAA,LRAD,LRAN)=UID
+27 SET BADCNT=BADCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+28 ;
+29 SET WOTCOL=$X
+30 IF WOTCOL<(IOM-17)
WRITE "Compilation Ends"
+31 IF WOTCOL>(IOM-18)
WRITE !,?4,"Compilation Ends"
+32 ;
+33 WRITE !!,?4,"Number of Accessions Analyzed = ",CNT,!
+34 IF BADCNT<1
WRITE !,?9,"All Accessions have Draw Dates",!
+35 IF BADCNT
WRITE !,?9,"# of Accessions with No Draw Date = ",BADCNT,!
+36 ;
+37 DO PRESSKEY^BLRGMENU(9)
+38 ;
+39 IF BADCNT
DO NOCOLRPT
+40 ;
+41 KILL ^TMP("BLRUTIL4",$JOB,"NOCOLLDT")
+42 QUIT
+43 ;
NOCOLRPT ; EP - Report on ^TMP("BLRUTIL4",$J,"NOCOLLDT"
+1 SET HEADER(1)="Accessions With No Draw Date"
+2 SET HEADER(2)=" "
+3 SET HEADER(3)="LRAA"
+4 SET $EXTRACT(HEADER(3),6)="LRAD"
+5 SET $EXTRACT(HEADER(3),15)="LRAN"
+6 SET $EXTRACT(HEADER(3),25)="UID"
+7 SET $EXTRACT(HEADER(3),40)="ARRIVAL TIME"
+8 SET $EXTRACT(HEADER(3),55)="LRDFN"
+9 SET $EXTRACT(HEADER(3),65)="INVERSE DATE"
+10 ;
+11 DO HEADERDT^BLRGMENU
+12 ;
+13 SET LRAA=0
+14 FOR
SET LRAA=$ORDER(^TMP("BLRUTIL4",$JOB,"NOCOLLDT",LRAA))
IF LRAA<1
QUIT
Begin DoDot:1
+15 SET LRAD=0
+16 FOR
SET LRAD=$ORDER(^TMP("BLRUTIL4",$JOB,"NOCOLLDT",LRAA,LRAD))
IF LRAD<1
QUIT
Begin DoDot:2
+17 SET LRAN=0
+18 FOR
SET LRAN=$ORDER(^TMP("BLRUTIL4",$JOB,"NOCOLLDT",LRAA,LRAD,LRAN))
IF LRAN<1
QUIT
Begin DoDot:3
+19 SET UID=+$GET(^TMP("BLRUTIL4",$JOB,"NOCOLLDT",LRAA,LRAD,LRAN))
+20 SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
SET STR3=$GET(^(3))
+21 SET LABARRT=$PIECE(STR3,"^",3)
+22 SET LRIDT=$PIECE(STR3,"^",5)
+23 ;
+24 WRITE LRAA
+25 WRITE ?5,LRAD
+26 WRITE ?14,LRAN
+27 WRITE ?24,UID
+28 WRITE ?39,LABARRT
+29 WRITE ?54,LRDFN
+30 WRITE ?64,LRIDT
+31 WRITE !
End DoDot:3
End DoDot:2
End DoDot:1
+32 ;
+33 DO PRESSKEY^BLRGMENU(9)
+34 QUIT
