BLRAG05D ; IHS/MSC/SAT - SUPPORT FOR LABORATORY ACCESSION GUI RPCS ; 18-Jul-2016 15:43 ; MKK
;;5.2;IHS LABORATORY;**1031,1037,1039**;NOV 01, 1997;Build 38
;
;
LROE2 ;
I $D(^LRO(69,LRODT,1,DA,1)),$P(^(1),U,4)="C" S LRNONE=2,LRCHK=LRCHK+1
K LRSN
S (LRSN,LRSN(DA))=+DA
I '$D(^LRO(69,LRODT,1,LRSN,0)) Q
; S M9=$G(M9)+1,LRZX=^LRO(69,LRODT,1,LRSN,0),LRDFN=+LRZX,LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,PNM,?30,SSN S LRWRDS=LRWRD
;----- BEGIN IHS MODIFICATIONS LR*5.2*1027
S M9=$G(M9)+1
S LRZX=^LRO(69,LRODT,1,LRSN,0)
S LRDFN=+LRZX
S LRDPF=$P(^LR(LRDFN,0),U,2) S DFN=$P(^(0),U,3)
D PT^LRX
;W !,PNM,?30,HRCN
S LRWRDS=$G(LRWRD) ;ZSAT: where is this set up?
;----- END IHS MODIFICATIONS LR*5.2*1027
;W ?45,"Requesting location: ",$P(LRZX,U,7) S Y=$P(LRZX,U,5) D DD^LRX W !,"Date/Time Ordered: ",Y,?45,"By: ",$S($D(^VA(200,+$P(LRZX,U,2),0)):$P(^(0),U),1:"")
;S LRSVSN=LRSN D ORDER^LROS S LRSN=LRSVSN
Q
;
YN ;
Q
;
TASK ;
S IOP=$P($G(^LAB(69.9,1,3.5,+DUZ(2),0)),U,3)
D ^%ZIS
S LRLABLIO=ION_";"_IOST_";"_IOM_";"_IOSL
D ^%ZISC
;D CLOSE^%ZISUTL("LRLABEL")
I $D(LRLABLIO),$D(LRLBL) D
.S ZTRTN="ENT^LRLABLD",ZTDTH=$H,ZTDESC="LAB LABELS",ZTIO=LRLABLIO,ZTSAVE("LRLBL(")=""
.D ^%ZTLOAD
K LRLBL
D ^%ZISC
D STOP^LRCAPV K LRCOM,LRSPCDSC,LRCCOM,LRTCOM
Q
;
;
END K DIR,DIRUT,GOT
D ^LRORDK,LROEND^LRORDK,STOP^LRCAPV
Q
;
;
GOT(ORD,ODT) ;See if all tests have been canceled
N I,SN,ODT
S (GOT,ODT,SN)=0
F S ODT=$O(^LRO(69,"C",ORD,ODT)) Q:ODT<1 D
. S SN=0 F S SN=$O(^LRO(69,"C",ORD,ODT,SN)) Q:SN<1!(GOT) D
. . Q:'$D(^LRO(69,ODT,1,SN,0))
. . S I=0 F S I=$O(^LRO(69,ODT,1,SN,2,I)) Q:I<1 I $D(^(I,0)),'$P(^(0),"^",11) S GOT=1 Q
Q GOT
;
;
UNL69 ;
L -^LRO(69,"C",+$G(LRORD))
TCOMMIT
Q
UNL69ERR ;
L -^LRO(69,"C",+$G(LRORD))
TROLLBACK
Q
;
P15 ;from LRVER,LRVR,LRGV (P15^LROE1)
N COMB
;S E=0 F S E=$O(^LRO(69,LRODT,1,LRSN,2,E)) Q:'E W !,$P(^LAB(60,+^(E,0),0),"^")
;store estimated date/time of collection
;D TIME^LROE Q:LRCDT<1 S LRUN=$P(LRCDT,"^",2),LRTIM=+LRCDT,LRNT=LRTIM S $P(^LRO(69,LRODT,1,LRSN,0),U,8)=LRTIM
S LRCDT=$G(BLRCDT)_"^"
S LRUN=$P(LRCDT,"^",2),LRTIM=+LRCDT,LRNT=LRTIM
S $P(^LRO(69,LRODT,1,LRSN,0),U,8)=LRTIM
S:$P($G(^LRO(69,LRODT,1,LRSN,1)),U,1)="" $P(^LRO(69,LRODT,1,LRSN,1),U,1)=LRTIM
S:($P($G(^LRO(69,LRODT,1,LRSN,1)),U,3)="")&$G(BLRCUSR) $P(^LRO(69,LRODT,1,LRSN,1),U,3)=BLRCUSR
I '$D(LRCDT) S (LRCDT,LRTIM,LRNT)=$P(^LRO(69,LRODT,1,LRSN,0),U,8),LRUN=""
;if lab collect and a collection node, set REPORT ROUTING LOCATION and ORDERING LOCATION, then call P15A for more collection storage
;I $P(^LRO(69,LRODT,1,LRSN,0),U,4)="LC",$D(^(1)) S LRLLOC=$P(^(0),U,7),LROLLOC=$P(^(0),U,9),LRNT=$S($D(LRNT):LRNT,$D(LRTIM):LRTIM,$D(LRCDT):+LRCDT,1:"") D P15A Q
I $P(^LRO(69,LRODT,1,LRSN,0),U,4)'="",$D(^(1)) S LRLLOC=$P(^(0),U,7),LROLLOC=$P(^(0),U,9),LRNT=$S($D(LRNT):LRNT,$D(LRTIM):LRTIM,$D(LRCDT):+LRCDT,1:"") D P15A Q
S COMB=$P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7)
;store collection node
S ^LRO(69,LRODT,1,LRSN,1)=LRTIM_"^"_LRUN_"^"_BLRCUSR_"^"_LRSTATUS_"^^^"_COMB_"^"_DUZ(2)
S:LRSTATUS="C" ^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
Q
;
P15A ;from LROE1, LRPHEXPT (P15^LRPHITEM)
N LRORIFN,LRX712,LRUIDA
N BLRSETUP
;
Q:'$D(^LRO(69,LRODT,1,LRSN,1)) Q:$L($P(^LRO(69,LRODT,1,LRSN,1),U,4)) S J1=^(1),LRX712=^(0)
S LRDFN=+LRX712 K LRDPF
D
. N LRRB
. D PT^LRX
S LROLLOC=$P(LRX712,U,9)
S LRTREA=+$G(VAIN(3))
S LRORIFN=$P(LRX712,U,11)
S LRNT=$$NOW^XLFDT
;
;S ^LRO(69,LRODT,1,LRSN,1)=$P(J1,U,1,2)_"^"_DUZ_"^"_$P(J1,U,4)_"^^"_$P(J1,U,6)_"^"_$P(J1,U,7)
S:$P($G(^LRO(69,LRODT,1,LRSN,1)),U,3)="" $P(^LRO(69,LRODT,1,LRSN,1),U,3)=BLRCUSR
;
S $P(^LRO(69,LRODT,1,LRSN,3),U)=LRNT,^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
S (LRAA,LRAD,LRAN,LRTN)=0
F S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:LRTN<1 D
. I '$D(^LRO(69,LRODT,1,LRSN,2,LRTN,0)) Q
. S X=^LRO(69,LRODT,1,LRSN,2,LRTN,0),LRAA=+$P(X,U,4),LRAD=+$P(X,U,3),LRAN=+$P(X,U,5),LRORIFN=$P(X,U,7)
. S:'$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,1) $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,1)=$G(BLRCDT),$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)=9999999-$G(BLRCDT)
. S BLRSETUP=$$SETUP^BLRAGUT1()
. S:$G(MSCRLCLA)="" MSCRLCLA=$G(BLRRLCLA)
. D P15A^LRPHITEM
. S BLRRLCLA=MSCRLCLA
. I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) D
. . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)=LRNT
. . S ^LRO(68,LRAA,1,LRAD,1,"E",LRNT,LRAN)=""
;
I +$G(LRDPF)=2 D
. N CONTROL
. S CONTROL=$S($L(LRORIFN):"SC",1:"SN")
. D NEW^LR7OB1(LRODT,LRSN,CONTROL,,,6)
;
N LRX
S LRX=""
F S LRX=$O(LRUIDA(LRX)) Q:LRX="" D EN^LA7ADL(LRX)
Q
;
Q15 ; (^LROE2)
Q:'$D(^LRO(69,LRODT,1,LRSN,0))
;store collection data if not collected
I $D(^LRO(69,LRODT,1,LRSN,1)),$P(^LRO(69,LRODT,1,LRSN,1),"^",4)="U" D
.I $G(BLRUNC)'=1 S BLRRET="BLRAG05: This specimen has already been marked as UNCOLLECTED." S BLREF=1 Q ;ZSAT: 5) Continue if uncollected is OK?
.I $G(BLRUNC)=1 S ^LRO(69,LRODT,1,LRSN,1)=LRTIM_"^^"_BLRCUSR,DA=LRSN,DA(1)=LRODT,DIE="^LRO(69,"_DA(1)_",1,",DR=16 D ^DIE
Q:BLREF
;store patient confirmation data
D:(BLRPTCM'="")&(BLRPTCU'="") PTCS(LRODT,LRSN,BLRPTCU,$$NOW^XLFDT(),BLRPTCM)
S DA=DT,LRDFN=+^LRO(69,LRODT,1,LRSN,0),LRDPF=+$P(^LR(LRDFN,0),U,2)
;
;if no collection node, go make one
;IF '$D(^LRO(69,LRODT,1,LRSN,1)) S LRSTATUS="C",DA=LRODT I '$D(LRSND) D P15 Q:LRCDT<1
;updates to collection node
;I $D(LRSND),$P(^LRO(69,LRODT,1,LRSN,0),U,4)="",$D(^(1)) S LRLLOC=$P(^(0),U,7),LROLLOC=$P(^(0),U,9),LRNT=$S($D(LRNT):LRNT,$D(LRTIM):LRTIM,$D(LRCDT):+LRCDT,1:"") D P15A G PH
;I $D(LRSND) N COMB S COMB=$P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7) S ^LRO(69,LRODT,1,LRSN,1)=LRTIM_"^"_LRUN_"^"_BLRCUSR_"^"_LRSTATUS_"^^^"_COMB_"^"_DUZ(2) S:LRSTATUS="C" ^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
;
PH G Q16:LRORD Q
Q16 S J=0 D CHECK^LROW2 I J S BLRRET="BLRAG05: The ORDER NUMBER (LRDFN) is in use, contact the site manager. This order has been CANCELED, you will need to re-order." S BLREF=1 Q
Q16A ;I $D(LRLONG),$D(LRSND) S LRSN=LRSND,^TMP("LROE",$J,"LRORD")=LRORD_U_LRODT_U_LRTIM_U_PNM_U_SSN
I $D(LRLONG),$D(LRSND) S LRSN=LRSND,^TMP("LROE",$J,"LRORD")=LRORD_U_LRODT_U_LRTIM_U_PNM_U_HRCN ;IHS/ANMC/CLS 08/18/96
K DR S LRTSTS=0
N MSCLRSN
S LRSN=0 F S LRSN=$O(LRSN(LRSN)) Q:'LRSN S MSCLRSN=LRSN D Q17 S LRSN=MSCLRSN
;I $D(LRLONG),$D(LRSND) S LRSN=LRSND D LROE^LRFAST S X=^TMP("LROE",$J,"LRORD"),LRORD=+X,LRODT=$P(X,"^",2),LRTIM=$P(X,"^",3),LRLONG="",PNM=$P(X,"^",4),SSN=$P(X,"^",5)
I 0,$D(LRLONG),$D(LRSND) S LRSN=LRSND D LROE^LRFAST S X=^TMP("LROE",$J,"LRORD"),LRORD=+X,LRODT=$P(X,"^",2),LRTIM=$P(X,"^",3),LRLONG="",PNM=$P(X,"^",4),SSN=$P(X,"^",5),HRCN=$P(X,"^",5) ;IHS/ANMC/CLS 08/18/96
Q
Q17 ;S I=$O(^LRO(69,LRODT,1,LRSN,6,0)),J=$O(^(1)) S:'$D(IOM) IOM=80 K LRSPCDSC S:J LRSPCDSC=^(J,0) S:I DA=LRSN,DA(1)=LRODT,DR=6,DIC="^LRO(69,"_LRODT_",1," D EN^DIQ:I D LRSPEC^LROE1
S I=$O(^LRO(69,LRODT,1,LRSN,6,0)),J=$O(^LRO(69,LRODT,1,LRSN,6,1)) S:'$D(IOM) IOM=80 K LRSPCDSC S:J LRSPCDSC=^LRO(69,LRODT,1,LRSN,6,J,0) S:I DA=LRSN,DA(1)=LRODT,DR=6,DIC="^LRO(69,"_LRODT_",1," D:$D(^LRO(69,LRODT,1,LRSN,0)) LRSPEC^LROE1
D OLD K ^TMP("LR",$J,"TMP")
;store collected status, institution, and xref
S $P(^LRO(69,LRODT,1,LRSN,1),U,4)="C",$P(^LRO(69,LRODT,1,LRSN,1),U,8)=DUZ(2),^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
Q
;
OLD ;to allow unchanged routines to still work, from LROE1, LRPHSET1 (OLD^LRORDST)
N LRNT
D DT^LRORDST,NOW^%DTC
S LRNT=%
I $P(LRPARAM,U,4),'$D(LRNOLABL),'$D(LRTJ),0 D ^BLRAG05A ;ZSAT
S LRQUIET=1
D ^BLRAG05B
;
;if no collection node, go make one
IF '$D(^LRO(69,LRODT,1,LRSN,1)) S LRSTATUS="C",DA=LRODT D P15 Q:LRCDT<1
;updates to collection node
I $D(LRSND),$P(^LRO(69,LRODT,1,LRSN,0),U,4)'="",$D(^(1)) S LRLLOC=$P(^(0),U,7),LROLLOC=$P(^(0),U,9),LRNT=$S($D(LRNT):LRNT,$D(LRTIM):LRTIM,$D(LRCDT):+LRCDT,1:"") D P15A Q
I $D(LRSND) N COMB S COMB=$P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7) S ^LRO(69,LRODT,1,LRSN,1)=LRTIM_"^"_LRUN_"^"_BLRCUSR_"^"_LRSTATUS_"^^^"_COMB_"^"_DUZ(2) S:LRSTATUS="C" ^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
Q
;
;----- BEGIN IHS MODIFICATIONS LR*5.2*1021
BLRRL ;EP - cmi/anch/maw 8/4/2004 added to check for shipping manifest and print
;cmi/anch/maw REF LAB
;cmi/anch/maw 9/28/2004 changed to write only when a shipping manifest
K BLRINS,BLRDXS ;cmi/7/1/2010 reference lab ledi variables
K BLRASFLG ;P1034
Q:$G(BLRGUI)
Q:'$G(^BLRSITE(DUZ(2),"RL")) ;reference lab not set up
Q:$P($G(^BLRSITE(DUZ(2),"RL")),U,22)
;I $D(^TMP("BLRRL",$J)) D
I $G(LRORD),$O(^BLRRLO("B",LRORD,0)) D ;p1034
. N OI
. S OI=$O(^BLRRLO("B",LRORD,0))
. Q:'$D(^BLRRLO(OI,3,0)) ;not accessioned yet
. ;W !,"Printing Shipping Manifests for Reference Lab..." ;1036 moved to BLRRLEVN
. ;D PRT^BLRSHPM
. D SHIPMAN^BLRRLEVN(LRORD,0,0) ;ihs/cmi/maw 12/17/2014 p1034 store and forward changes
K BLRINS,BLRASFLG,BLRDXS ; ihs/cmi/maw p1037
Q ; IHS/MSC/MKK - LR*5.2*1039
;----- END IHS MODIFICATIONS cmi/anch/maw end REF LAB LR*5.2*1021
;
PTCS(BLRDT,BLRSPN,BLRUSER,BLRDTCF,BLRMETH) ;
; BLRDT = (required) order date in external format - pointer to LAB ORDER ENTRY file 69
; BLRSPN = (required) specimen number - pointer to specimen multiple in LAB ORDER ENTRY file 69
; BLRUSER = (required) user that did confirmation - pointer to NEW PERSON file 200
; BLRDTCF = (optional) Date/Time of user confirmation in external format - defaults to 'today'
; BLRMETH = (optional) method of confirmation - free text
;
;if confirmation date is null, default to NOW
I $G(BLRDTCF)="" S BLRDTCF=$$HTFM^XLFDT($H)
E D
.;convert external date to FM format
.S X=BLRDTCF,%DT="XT" D ^%DT S BLRDTCF=Y
.;default to 'NOW' if invalid date passed in
.S:$$FR^XLFDT($G(BLRDTCF)) BLRDTCF=$$HTFM^XLFDT($H)
K BLRM
S BLRM=""
S FDA(69.01,BLRSPN_","_+BLRDT_",",21400)=BLRUSER
S FDA(69.01,BLRSPN_","_+BLRDT_",",21401)=BLRDTCF
S FDA(69.01,BLRSPN_","_+BLRDT_",",21402)=BLRMETH
D FILE^DIE("","FDA","BLRM")
I $D(BLRM("DIERR")) D ERR^BLRAGUT("BLRAG01: "_BLRM("DIERR",1,"TEXT",1)) L -^LRO(69,BLRDT,1,BLRSPN) TROLLBACK Q
Q
;
ERROR ; EP
; D ENTRYAUD^BLRUTIL("ERROR^BLRAG05D 0.0") ; Store Error data
; NEW ERRORMSG
; S ERRORMSG="$"_"Z"_"E=""ERROR^BLRAG05D""" ; BYPASS SAC Checker
; S @ERRORMSG D ^%ZTER
;
; D ERR("RPMS Error")
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
NEW ERRSCFL,ERRCODE,LASTGLOR
S ERRCODE=$$EC^%ZOSV ; Error Code
S ERRLGLO=$$LGR^%ZOSV ; Last Global accessed
D FORCEIT^BLRUTIL7("ERROR^BLRAG05D")
D ERR("RPMS Error: "_ERRCODE)
; ----- END IHS/MSC/MKK - LR*5.2*1039
Q
;
ERR(BLRERR) ;Error processing
; BLRERR = Error text OR error code
; BLRAGI = pointer into return global array
;
D UNL69ERR^BLRAG05D
I +BLRERR S BLRERR=BLRERR+134234112 ;vbObjectError
S BLRAGI=BLRAGI+1
S ^TMP("BLRAG",$J,BLRAGI)=2_U_BLRERR_$C(30)
S BLRAGI=BLRAGI+1
S ^TMP("BLRAG",$J,BLRAGI)=$C(31)
Q
BLRAG05D ; IHS/MSC/SAT - SUPPORT FOR LABORATORY ACCESSION GUI RPCS ; 18-Jul-2016 15:43 ; MKK
+1 ;;5.2;IHS LABORATORY;**1031,1037,1039**;NOV 01, 1997;Build 38
+2 ;
+3 ;
LROE2 ;
+1 IF $DATA(^LRO(69,LRODT,1,DA,1))
IF $PIECE(^(1),U,4)="C"
SET LRNONE=2
SET LRCHK=LRCHK+1
+2 KILL LRSN
+3 SET (LRSN,LRSN(DA))=+DA
+4 IF '$DATA(^LRO(69,LRODT,1,LRSN,0))
QUIT
+5 ; S M9=$G(M9)+1,LRZX=^LRO(69,LRODT,1,LRSN,0),LRDFN=+LRZX,LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,PNM,?30,SSN S LRWRDS=LRWRD
+6 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1027
+7 SET M9=$GET(M9)+1
+8 SET LRZX=^LRO(69,LRODT,1,LRSN,0)
+9 SET LRDFN=+LRZX
+10 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+11 DO PT^LRX
+12 ;W !,PNM,?30,HRCN
+13 ;ZSAT: where is this set up?
SET LRWRDS=$GET(LRWRD)
+14 ;----- END IHS MODIFICATIONS LR*5.2*1027
+15 ;W ?45,"Requesting location: ",$P(LRZX,U,7) S Y=$P(LRZX,U,5) D DD^LRX W !,"Date/Time Ordered: ",Y,?45,"By: ",$S($D(^VA(200,+$P(LRZX,U,2),0)):$P(^(0),U),1:"")
+16 ;S LRSVSN=LRSN D ORDER^LROS S LRSN=LRSVSN
+17 QUIT
+18 ;
YN ;
+1 QUIT
+2 ;
TASK ;
+1 SET IOP=$PIECE($GET(^LAB(69.9,1,3.5,+DUZ(2),0)),U,3)
+2 DO ^%ZIS
+3 SET LRLABLIO=ION_";"_IOST_";"_IOM_";"_IOSL
+4 DO ^%ZISC
+5 ;D CLOSE^%ZISUTL("LRLABEL")
+6 IF $DATA(LRLABLIO)
IF $DATA(LRLBL)
Begin DoDot:1
+7 SET ZTRTN="ENT^LRLABLD"
SET ZTDTH=$HOROLOG
SET ZTDESC="LAB LABELS"
SET ZTIO=LRLABLIO
SET ZTSAVE("LRLBL(")=""
+8 DO ^%ZTLOAD
End DoDot:1
+9 KILL LRLBL
+10 DO ^%ZISC
+11 DO STOP^LRCAPV
KILL LRCOM,LRSPCDSC,LRCCOM,LRTCOM
+12 QUIT
+13 ;
+14 ;
END KILL DIR,DIRUT,GOT
+1 DO ^LRORDK
DO LROEND^LRORDK
DO STOP^LRCAPV
+2 QUIT
+3 ;
+4 ;
GOT(ORD,ODT) ;See if all tests have been canceled
+1 NEW I,SN,ODT
+2 SET (GOT,ODT,SN)=0
+3 FOR
SET ODT=$ORDER(^LRO(69,"C",ORD,ODT))
IF ODT<1
QUIT
Begin DoDot:1
+4 SET SN=0
FOR
SET SN=$ORDER(^LRO(69,"C",ORD,ODT,SN))
IF SN<1!(GOT)
QUIT
Begin DoDot:2
+5 IF '$DATA(^LRO(69,ODT,1,SN,0))
QUIT
+6 SET I=0
FOR
SET I=$ORDER(^LRO(69,ODT,1,SN,2,I))
IF I<1
QUIT
IF $DATA(^(I,0))
IF '$PIECE(^(0),"^",11)
SET GOT=1
QUIT
End DoDot:2
End DoDot:1
+7 QUIT GOT
+8 ;
+9 ;
UNL69 ;
+1 LOCK -^LRO(69,"C",+$GET(LRORD))
+2 TCOMMIT
+3 QUIT
UNL69ERR ;
+1 LOCK -^LRO(69,"C",+$GET(LRORD))
+2 TROLLBACK
+3 QUIT
+4 ;
P15 ;from LRVER,LRVR,LRGV (P15^LROE1)
+1 NEW COMB
+2 ;S E=0 F S E=$O(^LRO(69,LRODT,1,LRSN,2,E)) Q:'E W !,$P(^LAB(60,+^(E,0),0),"^")
+3 ;store estimated date/time of collection
+4 ;D TIME^LROE Q:LRCDT<1 S LRUN=$P(LRCDT,"^",2),LRTIM=+LRCDT,LRNT=LRTIM S $P(^LRO(69,LRODT,1,LRSN,0),U,8)=LRTIM
+5 SET LRCDT=$GET(BLRCDT)_"^"
+6 SET LRUN=$PIECE(LRCDT,"^",2)
SET LRTIM=+LRCDT
SET LRNT=LRTIM
+7 SET $PIECE(^LRO(69,LRODT,1,LRSN,0),U,8)=LRTIM
+8 IF $PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),U,1)=""
SET $PIECE(^LRO(69,LRODT,1,LRSN,1),U,1)=LRTIM
+9 IF ($PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),U,3)="")&$GET(BLRCUSR)
SET $PIECE(^LRO(69,LRODT,1,LRSN,1),U,3)=BLRCUSR
+10 IF '$DATA(LRCDT)
SET (LRCDT,LRTIM,LRNT)=$PIECE(^LRO(69,LRODT,1,LRSN,0),U,8)
SET LRUN=""
+11 ;if lab collect and a collection node, set REPORT ROUTING LOCATION and ORDERING LOCATION, then call P15A for more collection storage
+12 ;I $P(^LRO(69,LRODT,1,LRSN,0),U,4)="LC",$D(^(1)) S LRLLOC=$P(^(0),U,7),LROLLOC=$P(^(0),U,9),LRNT=$S($D(LRNT):LRNT,$D(LRTIM):LRTIM,$D(LRCDT):+LRCDT,1:"") D P15A Q
+13 IF $PIECE(^LRO(69,LRODT,1,LRSN,0),U,4)'=""
IF $DATA(^(1))
SET LRLLOC=$PIECE(^(0),U,7)
SET LROLLOC=$PIECE(^(0),U,9)
SET LRNT=$SELECT($DATA(LRNT):LRNT,$DATA(LRTIM):LRTIM,$DATA(LRCDT):+LRCDT,1:"")
DO P15A
QUIT
+14 SET COMB=$PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),"^",7)
+15 ;store collection node
+16 SET ^LRO(69,LRODT,1,LRSN,1)=LRTIM_"^"_LRUN_"^"_BLRCUSR_"^"_LRSTATUS_"^^^"_COMB_"^"_DUZ(2)
+17 IF LRSTATUS="C"
SET ^LRO(69,"AA",+$GET(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
+18 QUIT
+19 ;
P15A ;from LROE1, LRPHEXPT (P15^LRPHITEM)
+1 NEW LRORIFN,LRX712,LRUIDA
+2 NEW BLRSETUP
+3 ;
+4 IF '$DATA(^LRO(69,LRODT,1,LRSN,1))
QUIT
IF $LENGTH($PIECE(^LRO(69,LRODT,1,LRSN,1),U,4))
QUIT
SET J1=^(1)
SET LRX712=^(0)
+5 SET LRDFN=+LRX712
KILL LRDPF
+6 Begin DoDot:1
+7 NEW LRRB
+8 DO PT^LRX
End DoDot:1
+9 SET LROLLOC=$PIECE(LRX712,U,9)
+10 SET LRTREA=+$GET(VAIN(3))
+11 SET LRORIFN=$PIECE(LRX712,U,11)
+12 SET LRNT=$$NOW^XLFDT
+13 ;
+14 ;S ^LRO(69,LRODT,1,LRSN,1)=$P(J1,U,1,2)_"^"_DUZ_"^"_$P(J1,U,4)_"^^"_$P(J1,U,6)_"^"_$P(J1,U,7)
+15 IF $PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),U,3)=""
SET $PIECE(^LRO(69,LRODT,1,LRSN,1),U,3)=BLRCUSR
+16 ;
+17 SET $PIECE(^LRO(69,LRODT,1,LRSN,3),U)=LRNT
SET ^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
+18 SET (LRAA,LRAD,LRAN,LRTN)=0
+19 FOR
SET LRTN=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTN))
IF LRTN<1
QUIT
Begin DoDot:1
+20 IF '$DATA(^LRO(69,LRODT,1,LRSN,2,LRTN,0))
QUIT
+21 SET X=^LRO(69,LRODT,1,LRSN,2,LRTN,0)
SET LRAA=+$PIECE(X,U,4)
SET LRAD=+$PIECE(X,U,3)
SET LRAN=+$PIECE(X,U,5)
SET LRORIFN=$PIECE(X,U,7)
+22 IF '$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,1)
SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,1)=$GET(BLRCDT)
SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)=9999999-$GET(BLRCDT)
+23 SET BLRSETUP=$$SETUP^BLRAGUT1()
+24 IF $GET(MSCRLCLA)=""
SET MSCRLCLA=$GET(BLRRLCLA)
+25 DO P15A^LRPHITEM
+26 SET BLRRLCLA=MSCRLCLA
+27 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
Begin DoDot:2
+28 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)=LRNT
+29 SET ^LRO(68,LRAA,1,LRAD,1,"E",LRNT,LRAN)=""
End DoDot:2
End DoDot:1
+30 ;
+31 IF +$GET(LRDPF)=2
Begin DoDot:1
+32 NEW CONTROL
+33 SET CONTROL=$SELECT($LENGTH(LRORIFN):"SC",1:"SN")
+34 DO NEW^LR7OB1(LRODT,LRSN,CONTROL,,,6)
End DoDot:1
+35 ;
+36 NEW LRX
+37 SET LRX=""
+38 FOR
SET LRX=$ORDER(LRUIDA(LRX))
IF LRX=""
QUIT
DO EN^LA7ADL(LRX)
+39 QUIT
+40 ;
Q15 ; (^LROE2)
+1 IF '$DATA(^LRO(69,LRODT,1,LRSN,0))
QUIT
+2 ;store collection data if not collected
+3 IF $DATA(^LRO(69,LRODT,1,LRSN,1))
IF $PIECE(^LRO(69,LRODT,1,LRSN,1),"^",4)="U"
Begin DoDot:1
+4 ;ZSAT: 5) Continue if uncollected is OK?
IF $GET(BLRUNC)'=1
SET BLRRET="BLRAG05: This specimen has already been marked as UNCOLLECTED."
SET BLREF=1
QUIT
+5 IF $GET(BLRUNC)=1
SET ^LRO(69,LRODT,1,LRSN,1)=LRTIM_"^^"_BLRCUSR
SET DA=LRSN
SET DA(1)=LRODT
SET DIE="^LRO(69,"_DA(1)_",1,"
SET DR=16
DO ^DIE
End DoDot:1
+6 IF BLREF
QUIT
+7 ;store patient confirmation data
+8 IF (BLRPTCM'="")&(BLRPTCU'="")
DO PTCS(LRODT,LRSN,BLRPTCU,$$NOW^XLFDT(),BLRPTCM)
+9 SET DA=DT
SET LRDFN=+^LRO(69,LRODT,1,LRSN,0)
SET LRDPF=+$PIECE(^LR(LRDFN,0),U,2)
+10 ;
+11 ;if no collection node, go make one
+12 ;IF '$D(^LRO(69,LRODT,1,LRSN,1)) S LRSTATUS="C",DA=LRODT I '$D(LRSND) D P15 Q:LRCDT<1
+13 ;updates to collection node
+14 ;I $D(LRSND),$P(^LRO(69,LRODT,1,LRSN,0),U,4)="",$D(^(1)) S LRLLOC=$P(^(0),U,7),LROLLOC=$P(^(0),U,9),LRNT=$S($D(LRNT):LRNT,$D(LRTIM):LRTIM,$D(LRCDT):+LRCDT,1:"") D P15A G PH
+15 ;I $D(LRSND) N COMB S COMB=$P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7) S ^LRO(69,LRODT,1,LRSN,1)=LRTIM_"^"_LRUN_"^"_BLRCUSR_"^"_LRSTATUS_"^^^"_COMB_"^"_DUZ(2) S:LRSTATUS="C" ^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
+16 ;
PH IF LRORD
GOTO Q16
QUIT
Q16 SET J=0
DO CHECK^LROW2
IF J
SET BLRRET="BLRAG05: The ORDER NUMBER (LRDFN) is in use, contact the site manager. This order has been CANCELED, you will need to re-order."
SET BLREF=1
QUIT
Q16A ;I $D(LRLONG),$D(LRSND) S LRSN=LRSND,^TMP("LROE",$J,"LRORD")=LRORD_U_LRODT_U_LRTIM_U_PNM_U_SSN
+1 ;IHS/ANMC/CLS 08/18/96
IF $DATA(LRLONG)
IF $DATA(LRSND)
SET LRSN=LRSND
SET ^TMP("LROE",$JOB,"LRORD")=LRORD_U_LRODT_U_LRTIM_U_PNM_U_HRCN
+2 KILL DR
SET LRTSTS=0
+3 NEW MSCLRSN
+4 SET LRSN=0
FOR
SET LRSN=$ORDER(LRSN(LRSN))
IF 'LRSN
QUIT
SET MSCLRSN=LRSN
DO Q17
SET LRSN=MSCLRSN
+5 ;I $D(LRLONG),$D(LRSND) S LRSN=LRSND D LROE^LRFAST S X=^TMP("LROE",$J,"LRORD"),LRORD=+X,LRODT=$P(X,"^",2),LRTIM=$P(X,"^",3),LRLONG="",PNM=$P(X,"^",4),SSN=$P(X,"^",5)
+6 ;IHS/ANMC/CLS 08/18/96
IF 0
IF $DATA(LRLONG)
IF $DATA(LRSND)
SET LRSN=LRSND
DO LROE^LRFAST
SET X=^TMP("LROE",$JOB,"LRORD")
SET LRORD=+X
SET LRODT=$PIECE(X,"^",2)
SET LRTIM=$PIECE(X,"^",3)
SET LRLONG=""
SET PNM=$PIECE(X,"^",4)
SET SSN=$PIECE(X,"^",5)
SET HRCN=$PIECE(X,"^",5)
+7 QUIT
Q17 ;S I=$O(^LRO(69,LRODT,1,LRSN,6,0)),J=$O(^(1)) S:'$D(IOM) IOM=80 K LRSPCDSC S:J LRSPCDSC=^(J,0) S:I DA=LRSN,DA(1)=LRODT,DR=6,DIC="^LRO(69,"_LRODT_",1," D EN^DIQ:I D LRSPEC^LROE1
+1 SET I=$ORDER(^LRO(69,LRODT,1,LRSN,6,0))
SET J=$ORDER(^LRO(69,LRODT,1,LRSN,6,1))
IF '$DATA(IOM)
SET IOM=80
KILL LRSPCDSC
IF J
SET LRSPCDSC=^LRO(69,LRODT,1,LRSN,6,J,0)
IF I
SET DA=LRSN
SET DA(1)=LRODT
SET DR=6
SET DIC="^LRO(69,"_LRODT_",1,"
IF $DATA(^LRO(69,LRODT,1,LRSN,0))
DO LRSPEC^LROE1
+2 DO OLD
KILL ^TMP("LR",$JOB,"TMP")
+3 ;store collected status, institution, and xref
+4 SET $PIECE(^LRO(69,LRODT,1,LRSN,1),U,4)="C"
SET $PIECE(^LRO(69,LRODT,1,LRSN,1),U,8)=DUZ(2)
SET ^LRO(69,"AA",+$GET(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
+5 QUIT
+6 ;
OLD ;to allow unchanged routines to still work, from LROE1, LRPHSET1 (OLD^LRORDST)
+1 NEW LRNT
+2 DO DT^LRORDST
DO NOW^%DTC
+3 SET LRNT=%
+4 ;ZSAT
IF $PIECE(LRPARAM,U,4)
IF '$DATA(LRNOLABL)
IF '$DATA(LRTJ)
IF 0
DO ^BLRAG05A
+5 SET LRQUIET=1
+6 DO ^BLRAG05B
+7 ;
+8 ;if no collection node, go make one
+9 IF '$DATA(^LRO(69,LRODT,1,LRSN,1))
SET LRSTATUS="C"
SET DA=LRODT
DO P15
IF LRCDT<1
QUIT
+10 ;updates to collection node
+11 IF $DATA(LRSND)
IF $PIECE(^LRO(69,LRODT,1,LRSN,0),U,4)'=""
IF $DATA(^(1))
SET LRLLOC=$PIECE(^(0),U,7)
SET LROLLOC=$PIECE(^(0),U,9)
SET LRNT=$SELECT($DATA(LRNT):LRNT,$DATA(LRTIM):LRTIM,$DATA(LRCDT):+LRCDT,1:"")
DO P15A
QUIT
+12 IF $DATA(LRSND)
NEW COMB
SET COMB=$PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),"^",7)
SET ^LRO(69,LRODT,1,LRSN,1)=LRTIM_"^"_LRUN_"^"_BLRCUSR_"^"_LRSTATUS_"^^^"_COMB_"^"_DUZ(2)
IF LRSTATUS="C"
SET ^LRO(69,"AA",+$GET(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
+13 QUIT
+14 ;
+15 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1021
BLRRL ;EP - cmi/anch/maw 8/4/2004 added to check for shipping manifest and print
+1 ;cmi/anch/maw REF LAB
+2 ;cmi/anch/maw 9/28/2004 changed to write only when a shipping manifest
+3 ;cmi/7/1/2010 reference lab ledi variables
KILL BLRINS,BLRDXS
+4 ;P1034
KILL BLRASFLG
+5 IF $GET(BLRGUI)
QUIT
+6 ;reference lab not set up
IF '$GET(^BLRSITE(DUZ(2),"RL"))
QUIT
+7 IF $PIECE($GET(^BLRSITE(DUZ(2),"RL")),U,22)
QUIT
+8 ;I $D(^TMP("BLRRL",$J)) D
+9 ;p1034
IF $GET(LRORD)
IF $ORDER(^BLRRLO("B",LRORD,0))
Begin DoDot:1
+10 NEW OI
+11 SET OI=$ORDER(^BLRRLO("B",LRORD,0))
+12 ;not accessioned yet
IF '$DATA(^BLRRLO(OI,3,0))
QUIT
+13 ;W !,"Printing Shipping Manifests for Reference Lab..." ;1036 moved to BLRRLEVN
+14 ;D PRT^BLRSHPM
+15 ;ihs/cmi/maw 12/17/2014 p1034 store and forward changes
DO SHIPMAN^BLRRLEVN(LRORD,0,0)
End DoDot:1
+16 ; ihs/cmi/maw p1037
KILL BLRINS,BLRASFLG,BLRDXS
+17 ; IHS/MSC/MKK - LR*5.2*1039
QUIT
+18 ;----- END IHS MODIFICATIONS cmi/anch/maw end REF LAB LR*5.2*1021
+19 ;
PTCS(BLRDT,BLRSPN,BLRUSER,BLRDTCF,BLRMETH) ;
+1 ; BLRDT = (required) order date in external format - pointer to LAB ORDER ENTRY file 69
+2 ; BLRSPN = (required) specimen number - pointer to specimen multiple in LAB ORDER ENTRY file 69
+3 ; BLRUSER = (required) user that did confirmation - pointer to NEW PERSON file 200
+4 ; BLRDTCF = (optional) Date/Time of user confirmation in external format - defaults to 'today'
+5 ; BLRMETH = (optional) method of confirmation - free text
+6 ;
+7 ;if confirmation date is null, default to NOW
+8 IF $GET(BLRDTCF)=""
SET BLRDTCF=$$HTFM^XLFDT($HOROLOG)
+9 IF '$TEST
Begin DoDot:1
+10 ;convert external date to FM format
+11 SET X=BLRDTCF
SET %DT="XT"
DO ^%DT
SET BLRDTCF=Y
+12 ;default to 'NOW' if invalid date passed in
+13 IF $$FR^XLFDT($GET(BLRDTCF))
SET BLRDTCF=$$HTFM^XLFDT($HOROLOG)
End DoDot:1
+14 KILL BLRM
+15 SET BLRM=""
+16 SET FDA(69.01,BLRSPN_","_+BLRDT_",",21400)=BLRUSER
+17 SET FDA(69.01,BLRSPN_","_+BLRDT_",",21401)=BLRDTCF
+18 SET FDA(69.01,BLRSPN_","_+BLRDT_",",21402)=BLRMETH
+19 DO FILE^DIE("","FDA","BLRM")
+20 IF $DATA(BLRM("DIERR"))
DO ERR^BLRAGUT("BLRAG01: "_BLRM("DIERR",1,"TEXT",1))
LOCK -^LRO(69,BLRDT,1,BLRSPN)
TROLLBACK
QUIT
+21 QUIT
+22 ;
ERROR ; EP
+1 ; D ENTRYAUD^BLRUTIL("ERROR^BLRAG05D 0.0") ; Store Error data
+2 ; NEW ERRORMSG
+3 ; S ERRORMSG="$"_"Z"_"E=""ERROR^BLRAG05D""" ; BYPASS SAC Checker
+4 ; S @ERRORMSG D ^%ZTER
+5 ;
+6 ; D ERR("RPMS Error")
+7 ;
+8 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
+9 NEW ERRSCFL,ERRCODE,LASTGLOR
+10 ; Error Code
SET ERRCODE=$$EC^%ZOSV
+11 ; Last Global accessed
SET ERRLGLO=$$LGR^%ZOSV
+12 DO FORCEIT^BLRUTIL7("ERROR^BLRAG05D")
+13 DO ERR("RPMS Error: "_ERRCODE)
+14 ; ----- END IHS/MSC/MKK - LR*5.2*1039
+15 QUIT
+16 ;
ERR(BLRERR) ;Error processing
+1 ; BLRERR = Error text OR error code
+2 ; BLRAGI = pointer into return global array
+3 ;
+4 DO UNL69ERR^BLRAG05D
+5 ;vbObjectError
IF +BLRERR
SET BLRERR=BLRERR+134234112
+6 SET BLRAGI=BLRAGI+1
+7 SET ^TMP("BLRAG",$JOB,BLRAGI)=2_U_BLRERR_$CHAR(30)
+8 SET BLRAGI=BLRAGI+1
+9 SET ^TMP("BLRAG",$JOB,BLRAGI)=$CHAR(31)
+10 QUIT
