LRVRPOC ;VA/DALOI/JMC - POINT OF CARE VERIFICATION ; 4 May 2004
;;5.2;LAB SERVICE;**1031**;NOV 1, 1997
;
;;VA LR Patch(s): 290
;
; Reference to DIVSET^XUSRB2 supported by DBIA #4055
; Reference to ADM^VADPT2 supported by DBIA #325
;
EN ; Entry Point Call with LRLL=Load/Worklist IEN
;
N DIQUIET
;
S LRLL=+$G(LRLL)
;
; See if already running
L +^LAH("Z",LRLL):10
E D END Q
;
I '$D(^LRO(68.2,LRLL,0))#2 D END Q
S LRLL(0)=^LRO(68.2,LRLL,0)
;
; Must be POC Load/Work List
I $$GET1^DIQ(68.2,LRLL,.03,"I")'=2 D Q
. S LAMSG="POC: Unable to process POC results using non-POC worklist "_$$GET1^DIQ(68.2,LRLL,.01)
. D XQA^LA7UXQA(2,0,0,0,LAMSG,"")
. D END
;
;
; If rollover has not completed
; then requeue task 1 hour in future and send alert.
I $G(^LAB(69.9,1,"RO"))'=+$H D Q
. S ZTREQ=$$HADD^XLFDT($H,0,1,0,0)
. S LAMSG="POC: Lab Rollover has not completed as of "_$$HTE^XLFDT($H,"1M")
. D XQA^LA7UXQA(2,0,0,0,LAMSG,"")
. D END
;
D INIT^LRVRPOCU
I LREND D Q
. D XQA^LA7UXQA(2,0,0,0,"POC: "_LAMSG,"")
. D END
;
S LAIEN=0
F S LAIEN=$O(^LAH(LRLL,1,LAIEN)) Q:LAIEN<1 D
. I $$S^%ZTLOAD S ZTSTOP=1 Q ; Task has been requested to stop
. K LRERR
. S LASSN=$P($G(^LAH(LRLL,1,LAIEN,.1,"PID","SSN")),"^")
. ; Interface message number in ^LAHM(62.49
. S LA76249=+$P($G(^LAH(LRLL,1,LAIEN,0)),U,13)
. ; File #62.48 configuration link
. S LA76248=""
. I LA76249 S LA76248=$$GET1^DIQ(62.49,LA76249_",",.5,"I")
. D LOOK,NEXT,ZAPALL^LRVR3(LRLL,LAIEN)
D END
Q
;
;
NEXT ; Clean up between entries
D CLEAN^LRVRPOCU
Q
;
;
END ; Clean up and quit
; Release lock
L -^LAH("Z",LRLL)
;
D SPALERT^LRVRPOCU,KVAR^VADPT,KILL^XUSCLEAN
K ^TMP("LR",$J)
I $D(ZTQUEUED),'$P($G(ZTREQ),"^") S ZTREQ="@"
Q
;
;
LOOK ; Check for data
K LRDFN,LRERR
S LRODT=DT,(LREND,LRERR)=0
S DFN=$$FIND1^DIC(2,"","X",LASSN,"SSN","","")
I 'DFN D Q
. S LRERR=$$CREATE^LA7LOG(101,1)
. D SENDACK^LRVRPOCU
S LADFN=DFN
I '$D(^LAH(LRLL,1,LAIEN,0))#2 D Q
. S LRERR=$$CREATE^LA7LOG(105,1)
. D SENDACK^LRVRPOCU
S LRCDT=$P($G(^LAH(LRLL,1,LAIEN,.1,"OBR","ORCDT")),"^")
I LRCDT'?7N.E D Q
. S LRERR=$$CREATE^LA7LOG(104,1)
. D SENDACK^LRVRPOCU
S LRDFN=$$FNLRDFN(LADFN)
I $S(LREND:1,LRDFN<1:1,1:0) Q
S LRSSN=$S($G(^LAH(LRLL,1,LAIEN,.1,"PID","SSN")):^("SSN"),1:"???")
I LRSSN'=$G(SSN(2)) D Q
. S LRERR=$$CREATE^LA7LOG(106,1)
. D SENDACK^LRVRPOCU
S LRTJ=""
D DATA(LRLL,LAIEN)
Q
;
;
FNLRDFN(DFN) ;Lookup/set LRDFN and define patient variables
D KVAR^VADPT
K ANS,ERR,LRDPF,PNM,X
I $S(+DFN'=DFN:1,'$G(DFN):1,'$D(^DPT(DFN,0))#2:1,1:0) D Q 0
. S LREND=1,LRERR=$$CREATE^LA7LOG(108,1)
. D SENDACK^LRVRPOCU
S LRDFN=$$GET1^DIQ(2,DFN_",",63,"I","ANS","ERR")
S PNM="Unknown"
I LRDFN<1 S LRDFN=$$NEWPT(DFN)
I LRDFN>0 D Q LRDFN
. D DEM^LRX
. I $G(LREND) S LRDFN=0 Q
. S VAINDT=LRCDT D ADM^VADPT2
. S VAIP("D")=$S(VADMVT:LRCDT,1:LRCDT\1) D IN5PT^LRX
. D DPT(SSN(2))
. I LRERR S LREND=1,LRDFN=0
Q 0
;
;
NEWPT(DFN) ;Set ^LR( root for patient
S LRDPF="2^DPT(",X="^"_$P(LRDPF,"^",2)_DFN_",""LR"")"
S LRDFN=$O(^LR("A"),-1) I 'LRDFN S LRDFN=1
L +^LR(0):99
D E2^LRDPA
L -^LR(0)
I $G(LRDFN)<1 S LREND=1,LRDFN=0
Q LRDFN
;
;
DPT(LRASSN) ;
N LRX,X,Y,DIC
S (LRERR,LRDFN)=""
S DFN=$$FIND1^DIC(2,"","X",LRASSN,"SSN","","")
I 'DFN D Q
. N LASSN
. S LASSN=LRASSN,LRERR=$$CREATE^LA7LOG(101,1)
. D SENDACK^LRVRPOCU
S LRDFN=$$GET1^DIQ(2,DFN_",",63,"I","ANS","ERR")
I 'LRDFN D END^LRDPA Q:'$G(LRDFN)
S LRX=$G(^LAH(LRLL,1,LAIEN,.1,"PID","LRDFN"))
I LRX,LRX'=LRDFN D Q
. S LRERR=$$CREATE^LA7LOG(103,1)
. D SENDACK^LRVRPOCU
;
S LRX=$G(^LAH(LRLL,1,LAIEN,.1,"PID","DFN"))
I LRX,LRX'=DFN D Q
. S LRERR=$$CREATE^LA7LOG(102,1)
. D SENDACK^LRVRPOCU
;
; Determine ordering provider
N LRX,LRY,X,Y
S LRPRAC=""
S LRX=$G(^LAH(LRLL,1,LAIEN,.1,"OBR","ORDP"))
I '$P(LRX,"^",2),$P(LRX,"^")'="" D Q:LRERR
. S LRERR=$$CREATE^LA7LOG(119,1)
. D SENDACK^LRVRPOCU
; Check if a valid provider
I $P(LRX,"^",2) D Q:LRERR
. I $$PROVIDER^XUSER(+LRX) S LRPRAC=+LRX Q
. S LRERR=$$CREATE^LA7LOG(119,1)
. D SENDACK^LRVRPOCU
;
; If no ordering provider in message then check for inpatient provider.
I 'LRPRAC D
. I $G(VAIP(7)) S LRPRAC=+VAIP(7) Q
. I $G(VAIP(18)) S LRPRAC=+VAIP(18) Q
;
; Use VADPT for inpatients - clinic enrollment for outpatient
; Check if ordering location/division from message
S X=$G(^LAH(LRLL,1,LAIEN,.1,"OBR","EOL"))
S LROLLOC=+X,LROLDIV=$P(X,"^",3)
;
; Check for inpatient location if no location
I 'LROLLOC,$G(VAIP(5)) D
. S LROLLOC=$$GET1^DIQ(42,+VAIP(5)_",",44,"I")
. I 'LROLDIV S LROLDIV=$$GET1^DIQ(44,LROLLOC_",",3,"I")
;
; Check for outpatient appointments if no location
I 'LROLLOC!('LRPRAC) D VASD^LRVRPOCU
;
; If no location then log error.
I 'LROLLOC D Q
. S LRERR=$$CREATE^LA7LOG(107,1)
. D SENDACK^LRVRPOCU
;
; If no in/outpatient provider then check for primary care provider
I 'LRPRAC S LRPRAC=+$$OUTPTPR^SDUTL3(DFN,LRCDT)
;
; If no provider - none in message, no primary care and no provider on
; outpatient encounter then log error.
I 'LRPRAC D Q
. S LRERR=$$CREATE^LA7LOG(110,1)
. D SENDACK^LRVRPOCU
;
; If division in message does not match location's division then reject.
; Check if division not a VAMC and parent is a VAMC and division
; matches parent - deal with multiple medical centers within an
; integrated system.
I LROLDIV D Q:LRERR
. N DIV,OK,LRX
. S DIV=$$GET1^DIQ(44,LROLLOC_",",3,"I")
. I LROLDIV=DIV Q
. S X=$$NNT^XUAF4(DIV),OK=0
. I $P(X,"^",3)'="VAMC" D Q:OK
. . S Y=$P($$PRNT^XUAF4($P(X,"^")),"^"),X=$$NNT^XUAF4(Y)
. . I $P(X,"^",3)="VAMC",$P(Y,"^")=LROLDIV S OK=1
. S LRX=$$NNT^XUAF4(LROLDIV)
. S LRERR=$$CREATE^LA7LOG(112,1)
. D SENDACK^LRVRPOCU
;
; Get location abbreviation
S LRLLOC=$$GET1^DIQ(44,LROLLOC_",",1,"I")
I LRLLOC="" S LRLLOC="NO ABRV "_LROLLOC
Q
;
;
DATA(LRLL,LAIEN) ;Extract results into LROT(
;
K LR642,LRDATA,LRERR,LRSPECX,LRCNT,LROSPEC,LROT,LRSAMP,LRSB,LRSPEC,LRTRAY,LRCUP,LRSQ,LRTS,LRX,LRY,LRZ
S LRSQ=LAIEN,LRDATA=1,(LR642,LRCNT,LRERR)=0,(LRDAA,LRSAMP,LRSPEC)=""
S LRLL(0)=^LRO(68.2,LRLL,0)
S LROSPEC=$P($G(^LAH(LRLL,1,LAIEN,.1,"OBR","ORDSPEC")),"^")
I LROSPEC="" D Q
. S LRERR=$$CREATE^LA7LOG(114,1)
. D SENDACK^LRVRPOCU
S LRX=$G(^LAH(LRLL,1,LAIEN,.1,"OBR","ORDNLT"))
;
; Change division to ordering division
S LRDUZ(2)=$S(LROLDIV:LROLDIV,1:LRDIV)
I LRDUZ(2)'=DUZ(2) D Q:LRERR
. N LA7X,LRY
. S LRY=0
. D DIVSET^XUSRB2(.LRY,"`"_LRDUZ(2))
. I LRY Q
. S LA7X="Unable to set user 'LRLAB,POC' to division "_$$GET1^DIQ(4,LRDUZ(2)_",",.01)
. S LRERR=$$CREATE^LA7LOG(37,1)
;
; Ordering based on NLT codes from loadlist profile and OBR segment
F I=1:1:$L(LRX,"^") S LRY=$P(LRX,"^",I) Q:LRY="" D Q:LRERR
. I '$D(LRORDNLT(LRY,LROSPEC)) S LRERR=$$CREATE^LA7LOG(120,1) Q
. S LRZ=LRORDNLT(LRY,LROSPEC)
. S LRTST=$P(LRZ,"^"),LRSPEC=$P(LRZ,"^",2),LRSAMP=$P(LRZ,"^",3)
. I '$D(^TMP("LR",$J,"VTO",LRTST)) S LRERR=$$CREATE^LA7LOG(118,1) Q
. I 'LRSPEC S LRERR=$$CREATE^LA7LOG(114,1) Q
. I 'LRSAMP S LRERR=$$CREATE^LA7LOG(115,1) Q
. S LRCNT=LRCNT+1,LROT(LRSAMP,LRSPEC,LRCNT)=LRTST
. I $P(LRZ,"^",4) S LR642=$P(LRZ,"^",4)
. I 'LRDAA,LROLDIV,$D(^LAB(60,LRTST,8,LROLDIV,0)) S LRDAA=$P(^(0),U,2)
I LRERR D SENDACK^LRVRPOCU Q
I LRDAA<1 S LRDAA=$P(^LRO(68.2,LRLL,10,LRPROF,0),"^",2)
;
; Check for results to process
I '$O(LROT(0)) D Q
. S LRERR=$$CREATE^LA7LOG(113,1)
. D SENDACK^LRVRPOCU
;
; Setup workload suffix
I LR642<1 S LR642=LRDFWKLD
D WKLD^LRVRPOCU(LR642)
;
; Check if results have datanames/tests on this profile.
F S LRDATA=$O(^LAH(LRLL,1,LAIEN,LRDATA)) Q:LRDATA<1 D Q:LRERR
. I $P($G(^LAH(LRLL,1,LAIEN,LRDATA)),U)="" Q
. S LRDATA(LRDATA)=^LAH(LRLL,1,LAIEN,LRDATA)
. I $P(LRDATA(LRDATA),"^",4)<1 S LRERR=$$CREATE^LA7LOG(111,1) Q
. S LRTST=+$G(LRVTS(LRDATA))
. I 'LRTST S LRERR=$$CREATE^LA7LOG(116,1) Q
. I '$D(^TMP("LR",$J,"VTO",LRTST)) S LRERR=$$CREATE^LA7LOG(118,1) Q
I LRERR D SENDACK^LRVRPOCU Q
;
K LRCOM
S LRNT=$$NOW^XLFDT,LRORDTIM=""
;
; Setup the order in LRO(69
S LRNOLABL="" ; Suppress label printing
D
. N LRSPEC,LRSAMP,ZTQUEUED
. S ZTQUEUED=1
. D ORDER^LROW2,^LRORDST
;
; Setup LRO(68
D
. N LRSPEC,LRSAMP
. D ^LRWLST
I '$G(LRAA) D Q
. S LRERR=$$CREATE^LA7LOG(109,1)
. D SENDACK^LRVRPOCU
;
S LRMETH="POC DEVICE"
I LA76248 S LRMETH=$E($$GET1^DIQ(62.48,LA76248_",",.01),1,10)
I LRMETH="" S LRMETH=$E($P(LRLL(0),U),1,5)_"(POC)"
;
; Store POC specimen id in file #63 as ordering site UID.
S X=$G(^LAH(LRLL,1,LAIEN,.1,"OBR","FID"))
I $P(X,"^")'="" D
. N FDA,LA7DIE
. S FDA(1,63.04,LRIDT_","_LRDFN_",",.342)=$P(X,"^")
. I $P(X,"^",2) S FDA(1,63.04,LRIDT_","_LRDFN_",",.32)=$P(X,"^",2)
. D FILE^DIE("","FDA(1)","LA7DIE(1)")
;
; Store ^LR( data [results]
S LRVF=0,LRALERT=LROUTINE,LRUSI="POC.5"
M LRSB=LRDATA
D TEST^LRVR1
S LRSB=0
F S LRSB=$O(LRSB(LRSB)) Q:LRSB<1 D Q:LRERR
. I '$G(^TMP("LR",$J,"TMP",LRSB,"P")) S LRERR=$$CREATE^LA7LOG(117,1) Q
. S LRX=$$TMPSB^LRVER1(LRSB),LRY=$P(LRSB(LRSB),U,3)
. F I=1:1:$L(LRX,"!") I $P(LRY,"!",I)="" S $P(LRY,"!",I)=$P(LRX,"!",I)
. S $P(LRSB(LRSB),U,3)=LRY
. S LRTS=$G(^TMP("LR",$J,"TMP",LRSB))
. D V25^LRVER5
. S LRX=LRNGS,LRY=$P(LRSB(LRSB),U,5)
. F I=1:1:$L(LRX,U) I $P(LRY,"!",I)="" S $P(LRY,"!",I)=$P(LRX,U,I)
. S $P(LRSB(LRSB),U,5)=LRY
. I $P(LRSB(LRSB),U,9)="" S $P(LRSB(LRSB),U,9)=$S($G(LRDUZ(2)):LRDUZ(2),1:$G(DUZ(2)))
. S ^LR(LRDFN,"CH",LRIDT,LRSB)=LRSB(LRSB)
;
I LRERR D SENDACK^LRVRPOCU Q
;
; Call to set data and comments
I $O(LRSB(0)) D
. D LRSBCOM^LRVR4,A3^LRVR3
. S LRSTORE=LRSTORE+1
. I $G(LA76248) S LRSTORE(LA76248)=$G(LRSTORE(LA76248))+1
;
; Send application ack back to POC interface
D SENDACK^LRVRPOCU
Q
LRVRPOC ;VA/DALOI/JMC - POINT OF CARE VERIFICATION ; 4 May 2004
+1 ;;5.2;LAB SERVICE;**1031**;NOV 1, 1997
+2 ;
+3 ;;VA LR Patch(s): 290
+4 ;
+5 ; Reference to DIVSET^XUSRB2 supported by DBIA #4055
+6 ; Reference to ADM^VADPT2 supported by DBIA #325
+7 ;
EN ; Entry Point Call with LRLL=Load/Worklist IEN
+1 ;
+2 NEW DIQUIET
+3 ;
+4 SET LRLL=+$GET(LRLL)
+5 ;
+6 ; See if already running
+7 LOCK +^LAH("Z",LRLL):10
+8 IF '$TEST
DO END
QUIT
+9 ;
+10 IF '$DATA(^LRO(68.2,LRLL,0))#2
DO END
QUIT
+11 SET LRLL(0)=^LRO(68.2,LRLL,0)
+12 ;
+13 ; Must be POC Load/Work List
+14 IF $$GET1^DIQ(68.2,LRLL,.03,"I")'=2
Begin DoDot:1
+15 SET LAMSG="POC: Unable to process POC results using non-POC worklist "_$$GET1^DIQ(68.2,LRLL,.01)
+16 DO XQA^LA7UXQA(2,0,0,0,LAMSG,"")
+17 DO END
End DoDot:1
QUIT
+18 ;
+19 ;
+20 ; If rollover has not completed
+21 ; then requeue task 1 hour in future and send alert.
+22 IF $GET(^LAB(69.9,1,"RO"))'=+$HOROLOG
Begin DoDot:1
+23 SET ZTREQ=$$HADD^XLFDT($HOROLOG,0,1,0,0)
+24 SET LAMSG="POC: Lab Rollover has not completed as of "_$$HTE^XLFDT($HOROLOG,"1M")
+25 DO XQA^LA7UXQA(2,0,0,0,LAMSG,"")
+26 DO END
End DoDot:1
QUIT
+27 ;
+28 DO INIT^LRVRPOCU
+29 IF LREND
Begin DoDot:1
+30 DO XQA^LA7UXQA(2,0,0,0,"POC: "_LAMSG,"")
+31 DO END
End DoDot:1
QUIT
+32 ;
+33 SET LAIEN=0
+34 FOR
SET LAIEN=$ORDER(^LAH(LRLL,1,LAIEN))
IF LAIEN<1
QUIT
Begin DoDot:1
+35 ; Task has been requested to stop
IF $$S^%ZTLOAD
SET ZTSTOP=1
QUIT
+36 KILL LRERR
+37 SET LASSN=$PIECE($GET(^LAH(LRLL,1,LAIEN,.1,"PID","SSN")),"^")
+38 ; Interface message number in ^LAHM(62.49
+39 SET LA76249=+$PIECE($GET(^LAH(LRLL,1,LAIEN,0)),U,13)
+40 ; File #62.48 configuration link
+41 SET LA76248=""
+42 IF LA76249
SET LA76248=$$GET1^DIQ(62.49,LA76249_",",.5,"I")
+43 DO LOOK
DO NEXT
DO ZAPALL^LRVR3(LRLL,LAIEN)
End DoDot:1
+44 DO END
+45 QUIT
+46 ;
+47 ;
NEXT ; Clean up between entries
+1 DO CLEAN^LRVRPOCU
+2 QUIT
+3 ;
+4 ;
END ; Clean up and quit
+1 ; Release lock
+2 LOCK -^LAH("Z",LRLL)
+3 ;
+4 DO SPALERT^LRVRPOCU
DO KVAR^VADPT
DO KILL^XUSCLEAN
+5 KILL ^TMP("LR",$JOB)
+6 IF $DATA(ZTQUEUED)
IF '$PIECE($GET(ZTREQ),"^")
SET ZTREQ="@"
+7 QUIT
+8 ;
+9 ;
LOOK ; Check for data
+1 KILL LRDFN,LRERR
+2 SET LRODT=DT
SET (LREND,LRERR)=0
+3 SET DFN=$$FIND1^DIC(2,"","X",LASSN,"SSN","","")
+4 IF 'DFN
Begin DoDot:1
+5 SET LRERR=$$CREATE^LA7LOG(101,1)
+6 DO SENDACK^LRVRPOCU
End DoDot:1
QUIT
+7 SET LADFN=DFN
+8 IF '$DATA(^LAH(LRLL,1,LAIEN,0))#2
Begin DoDot:1
+9 SET LRERR=$$CREATE^LA7LOG(105,1)
+10 DO SENDACK^LRVRPOCU
End DoDot:1
QUIT
+11 SET LRCDT=$PIECE($GET(^LAH(LRLL,1,LAIEN,.1,"OBR","ORCDT")),"^")
+12 IF LRCDT'?7N.E
Begin DoDot:1
+13 SET LRERR=$$CREATE^LA7LOG(104,1)
+14 DO SENDACK^LRVRPOCU
End DoDot:1
QUIT
+15 SET LRDFN=$$FNLRDFN(LADFN)
+16 IF $SELECT(LREND:1,LRDFN<1:1,1:0)
QUIT
+17 SET LRSSN=$SELECT($GET(^LAH(LRLL,1,LAIEN,.1,"PID","SSN")):^("SSN"),1:"???")
+18 IF LRSSN'=$GET(SSN(2))
Begin DoDot:1
+19 SET LRERR=$$CREATE^LA7LOG(106,1)
+20 DO SENDACK^LRVRPOCU
End DoDot:1
QUIT
+21 SET LRTJ=""
+22 DO DATA(LRLL,LAIEN)
+23 QUIT
+24 ;
+25 ;
FNLRDFN(DFN) ;Lookup/set LRDFN and define patient variables
+1 DO KVAR^VADPT
+2 KILL ANS,ERR,LRDPF,PNM,X
+3 IF $SELECT(+DFN'=DFN:1,'$GET(DFN):1,'$DATA(^DPT(DFN,0))#2:1,1:0)
Begin DoDot:1
+4 SET LREND=1
SET LRERR=$$CREATE^LA7LOG(108,1)
+5 DO SENDACK^LRVRPOCU
End DoDot:1
QUIT 0
+6 SET LRDFN=$$GET1^DIQ(2,DFN_",",63,"I","ANS","ERR")
+7 SET PNM="Unknown"
+8 IF LRDFN<1
SET LRDFN=$$NEWPT(DFN)
+9 IF LRDFN>0
Begin DoDot:1
+10 DO DEM^LRX
+11 IF $GET(LREND)
SET LRDFN=0
QUIT
+12 SET VAINDT=LRCDT
DO ADM^VADPT2
+13 SET VAIP("D")=$SELECT(VADMVT:LRCDT,1:LRCDT\1)
DO IN5PT^LRX
+14 DO DPT(SSN(2))
+15 IF LRERR
SET LREND=1
SET LRDFN=0
End DoDot:1
QUIT LRDFN
+16 QUIT 0
+17 ;
+18 ;
NEWPT(DFN) ;Set ^LR( root for patient
+1 SET LRDPF="2^DPT("
SET X="^"_$PIECE(LRDPF,"^",2)_DFN_",""LR"")"
+2 SET LRDFN=$ORDER(^LR("A"),-1)
IF 'LRDFN
SET LRDFN=1
+3 LOCK +^LR(0):99
+4 DO E2^LRDPA
+5 LOCK -^LR(0)
+6 IF $GET(LRDFN)<1
SET LREND=1
SET LRDFN=0
+7 QUIT LRDFN
+8 ;
+9 ;
DPT(LRASSN) ;
+1 NEW LRX,X,Y,DIC
+2 SET (LRERR,LRDFN)=""
+3 SET DFN=$$FIND1^DIC(2,"","X",LRASSN,"SSN","","")
+4 IF 'DFN
Begin DoDot:1
+5 NEW LASSN
+6 SET LASSN=LRASSN
SET LRERR=$$CREATE^LA7LOG(101,1)
+7 DO SENDACK^LRVRPOCU
End DoDot:1
QUIT
+8 SET LRDFN=$$GET1^DIQ(2,DFN_",",63,"I","ANS","ERR")
+9 IF 'LRDFN
DO END^LRDPA
IF '$GET(LRDFN)
QUIT
+10 SET LRX=$GET(^LAH(LRLL,1,LAIEN,.1,"PID","LRDFN"))
+11 IF LRX
IF LRX'=LRDFN
Begin DoDot:1
+12 SET LRERR=$$CREATE^LA7LOG(103,1)
+13 DO SENDACK^LRVRPOCU
End DoDot:1
QUIT
+14 ;
+15 SET LRX=$GET(^LAH(LRLL,1,LAIEN,.1,"PID","DFN"))
+16 IF LRX
IF LRX'=DFN
Begin DoDot:1
+17 SET LRERR=$$CREATE^LA7LOG(102,1)
+18 DO SENDACK^LRVRPOCU
End DoDot:1
QUIT
+19 ;
+20 ; Determine ordering provider
+21 NEW LRX,LRY,X,Y
+22 SET LRPRAC=""
+23 SET LRX=$GET(^LAH(LRLL,1,LAIEN,.1,"OBR","ORDP"))
+24 IF '$PIECE(LRX,"^",2)
IF $PIECE(LRX,"^")'=""
Begin DoDot:1
+25 SET LRERR=$$CREATE^LA7LOG(119,1)
+26 DO SENDACK^LRVRPOCU
End DoDot:1
IF LRERR
QUIT
+27 ; Check if a valid provider
+28 IF $PIECE(LRX,"^",2)
Begin DoDot:1
+29 IF $$PROVIDER^XUSER(+LRX)
SET LRPRAC=+LRX
QUIT
+30 SET LRERR=$$CREATE^LA7LOG(119,1)
+31 DO SENDACK^LRVRPOCU
End DoDot:1
IF LRERR
QUIT
+32 ;
+33 ; If no ordering provider in message then check for inpatient provider.
+34 IF 'LRPRAC
Begin DoDot:1
+35 IF $GET(VAIP(7))
SET LRPRAC=+VAIP(7)
QUIT
+36 IF $GET(VAIP(18))
SET LRPRAC=+VAIP(18)
QUIT
End DoDot:1
+37 ;
+38 ; Use VADPT for inpatients - clinic enrollment for outpatient
+39 ; Check if ordering location/division from message
+40 SET X=$GET(^LAH(LRLL,1,LAIEN,.1,"OBR","EOL"))
+41 SET LROLLOC=+X
SET LROLDIV=$PIECE(X,"^",3)
+42 ;
+43 ; Check for inpatient location if no location
+44 IF 'LROLLOC
IF $GET(VAIP(5))
Begin DoDot:1
+45 SET LROLLOC=$$GET1^DIQ(42,+VAIP(5)_",",44,"I")
+46 IF 'LROLDIV
SET LROLDIV=$$GET1^DIQ(44,LROLLOC_",",3,"I")
End DoDot:1
+47 ;
+48 ; Check for outpatient appointments if no location
+49 IF 'LROLLOC!('LRPRAC)
DO VASD^LRVRPOCU
+50 ;
+51 ; If no location then log error.
+52 IF 'LROLLOC
Begin DoDot:1
+53 SET LRERR=$$CREATE^LA7LOG(107,1)
+54 DO SENDACK^LRVRPOCU
End DoDot:1
QUIT
+55 ;
+56 ; If no in/outpatient provider then check for primary care provider
+57 IF 'LRPRAC
SET LRPRAC=+$$OUTPTPR^SDUTL3(DFN,LRCDT)
+58 ;
+59 ; If no provider - none in message, no primary care and no provider on
+60 ; outpatient encounter then log error.
+61 IF 'LRPRAC
Begin DoDot:1
+62 SET LRERR=$$CREATE^LA7LOG(110,1)
+63 DO SENDACK^LRVRPOCU
End DoDot:1
QUIT
+64 ;
+65 ; If division in message does not match location's division then reject.
+66 ; Check if division not a VAMC and parent is a VAMC and division
+67 ; matches parent - deal with multiple medical centers within an
+68 ; integrated system.
+69 IF LROLDIV
Begin DoDot:1
+70 NEW DIV,OK,LRX
+71 SET DIV=$$GET1^DIQ(44,LROLLOC_",",3,"I")
+72 IF LROLDIV=DIV
QUIT
+73 SET X=$$NNT^XUAF4(DIV)
SET OK=0
+74 IF $PIECE(X,"^",3)'="VAMC"
Begin DoDot:2
+75 SET Y=$PIECE($$PRNT^XUAF4($PIECE(X,"^")),"^")
SET X=$$NNT^XUAF4(Y)
+76 IF $PIECE(X,"^",3)="VAMC"
IF $PIECE(Y,"^")=LROLDIV
SET OK=1
End DoDot:2
IF OK
QUIT
+77 SET LRX=$$NNT^XUAF4(LROLDIV)
+78 SET LRERR=$$CREATE^LA7LOG(112,1)
+79 DO SENDACK^LRVRPOCU
End DoDot:1
IF LRERR
QUIT
+80 ;
+81 ; Get location abbreviation
+82 SET LRLLOC=$$GET1^DIQ(44,LROLLOC_",",1,"I")
+83 IF LRLLOC=""
SET LRLLOC="NO ABRV "_LROLLOC
+84 QUIT
+85 ;
+86 ;
DATA(LRLL,LAIEN) ;Extract results into LROT(
+1 ;
+2 KILL LR642,LRDATA,LRERR,LRSPECX,LRCNT,LROSPEC,LROT,LRSAMP,LRSB,LRSPEC,LRTRAY,LRCUP,LRSQ,LRTS,LRX,LRY,LRZ
+3 SET LRSQ=LAIEN
SET LRDATA=1
SET (LR642,LRCNT,LRERR)=0
SET (LRDAA,LRSAMP,LRSPEC)=""
+4 SET LRLL(0)=^LRO(68.2,LRLL,0)
+5 SET LROSPEC=$PIECE($GET(^LAH(LRLL,1,LAIEN,.1,"OBR","ORDSPEC")),"^")
+6 IF LROSPEC=""
Begin DoDot:1
+7 SET LRERR=$$CREATE^LA7LOG(114,1)
+8 DO SENDACK^LRVRPOCU
End DoDot:1
QUIT
+9 SET LRX=$GET(^LAH(LRLL,1,LAIEN,.1,"OBR","ORDNLT"))
+10 ;
+11 ; Change division to ordering division
+12 SET LRDUZ(2)=$SELECT(LROLDIV:LROLDIV,1:LRDIV)
+13 IF LRDUZ(2)'=DUZ(2)
Begin DoDot:1
+14 NEW LA7X,LRY
+15 SET LRY=0
+16 DO DIVSET^XUSRB2(.LRY,"`"_LRDUZ(2))
+17 IF LRY
QUIT
+18 SET LA7X="Unable to set user 'LRLAB,POC' to division "_$$GET1^DIQ(4,LRDUZ(2)_",",.01)
+19 SET LRERR=$$CREATE^LA7LOG(37,1)
End DoDot:1
IF LRERR
QUIT
+20 ;
+21 ; Ordering based on NLT codes from loadlist profile and OBR segment
+22 FOR I=1:1:$LENGTH(LRX,"^")
SET LRY=$PIECE(LRX,"^",I)
IF LRY=""
QUIT
Begin DoDot:1
+23 IF '$DATA(LRORDNLT(LRY,LROSPEC))
SET LRERR=$$CREATE^LA7LOG(120,1)
QUIT
+24 SET LRZ=LRORDNLT(LRY,LROSPEC)
+25 SET LRTST=$PIECE(LRZ,"^")
SET LRSPEC=$PIECE(LRZ,"^",2)
SET LRSAMP=$PIECE(LRZ,"^",3)
+26 IF '$DATA(^TMP("LR",$JOB,"VTO",LRTST))
SET LRERR=$$CREATE^LA7LOG(118,1)
QUIT
+27 IF 'LRSPEC
SET LRERR=$$CREATE^LA7LOG(114,1)
QUIT
+28 IF 'LRSAMP
SET LRERR=$$CREATE^LA7LOG(115,1)
QUIT
+29 SET LRCNT=LRCNT+1
SET LROT(LRSAMP,LRSPEC,LRCNT)=LRTST
+30 IF $PIECE(LRZ,"^",4)
SET LR642=$PIECE(LRZ,"^",4)
+31 IF 'LRDAA
IF LROLDIV
IF $DATA(^LAB(60,LRTST,8,LROLDIV,0))
SET LRDAA=$PIECE(^(0),U,2)
End DoDot:1
IF LRERR
QUIT
+32 IF LRERR
DO SENDACK^LRVRPOCU
QUIT
+33 IF LRDAA<1
SET LRDAA=$PIECE(^LRO(68.2,LRLL,10,LRPROF,0),"^",2)
+34 ;
+35 ; Check for results to process
+36 IF '$ORDER(LROT(0))
Begin DoDot:1
+37 SET LRERR=$$CREATE^LA7LOG(113,1)
+38 DO SENDACK^LRVRPOCU
End DoDot:1
QUIT
+39 ;
+40 ; Setup workload suffix
+41 IF LR642<1
SET LR642=LRDFWKLD
+42 DO WKLD^LRVRPOCU(LR642)
+43 ;
+44 ; Check if results have datanames/tests on this profile.
+45 FOR
SET LRDATA=$ORDER(^LAH(LRLL,1,LAIEN,LRDATA))
IF LRDATA<1
QUIT
Begin DoDot:1
+46 IF $PIECE($GET(^LAH(LRLL,1,LAIEN,LRDATA)),U)=""
QUIT
+47 SET LRDATA(LRDATA)=^LAH(LRLL,1,LAIEN,LRDATA)
+48 IF $PIECE(LRDATA(LRDATA),"^",4)<1
SET LRERR=$$CREATE^LA7LOG(111,1)
QUIT
+49 SET LRTST=+$GET(LRVTS(LRDATA))
+50 IF 'LRTST
SET LRERR=$$CREATE^LA7LOG(116,1)
QUIT
+51 IF '$DATA(^TMP("LR",$JOB,"VTO",LRTST))
SET LRERR=$$CREATE^LA7LOG(118,1)
QUIT
End DoDot:1
IF LRERR
QUIT
+52 IF LRERR
DO SENDACK^LRVRPOCU
QUIT
+53 ;
+54 KILL LRCOM
+55 SET LRNT=$$NOW^XLFDT
SET LRORDTIM=""
+56 ;
+57 ; Setup the order in LRO(69
+58 ; Suppress label printing
SET LRNOLABL=""
+59 Begin DoDot:1
+60 NEW LRSPEC,LRSAMP,ZTQUEUED
+61 SET ZTQUEUED=1
+62 DO ORDER^LROW2
DO ^LRORDST
End DoDot:1
+63 ;
+64 ; Setup LRO(68
+65 Begin DoDot:1
+66 NEW LRSPEC,LRSAMP
+67 DO ^LRWLST
End DoDot:1
+68 IF '$GET(LRAA)
Begin DoDot:1
+69 SET LRERR=$$CREATE^LA7LOG(109,1)
+70 DO SENDACK^LRVRPOCU
End DoDot:1
QUIT
+71 ;
+72 SET LRMETH="POC DEVICE"
+73 IF LA76248
SET LRMETH=$EXTRACT($$GET1^DIQ(62.48,LA76248_",",.01),1,10)
+74 IF LRMETH=""
SET LRMETH=$EXTRACT($PIECE(LRLL(0),U),1,5)_"(POC)"
+75 ;
+76 ; Store POC specimen id in file #63 as ordering site UID.
+77 SET X=$GET(^LAH(LRLL,1,LAIEN,.1,"OBR","FID"))
+78 IF $PIECE(X,"^")'=""
Begin DoDot:1
+79 NEW FDA,LA7DIE
+80 SET FDA(1,63.04,LRIDT_","_LRDFN_",",.342)=$PIECE(X,"^")
+81 IF $PIECE(X,"^",2)
SET FDA(1,63.04,LRIDT_","_LRDFN_",",.32)=$PIECE(X,"^",2)
+82 DO FILE^DIE("","FDA(1)","LA7DIE(1)")
End DoDot:1
+83 ;
+84 ; Store ^LR( data [results]
+85 SET LRVF=0
SET LRALERT=LROUTINE
SET LRUSI="POC.5"
+86 MERGE LRSB=LRDATA
+87 DO TEST^LRVR1
+88 SET LRSB=0
+89 FOR
SET LRSB=$ORDER(LRSB(LRSB))
IF LRSB<1
QUIT
Begin DoDot:1
+90 IF '$GET(^TMP("LR",$JOB,"TMP",LRSB,"P"))
SET LRERR=$$CREATE^LA7LOG(117,1)
QUIT
+91 SET LRX=$$TMPSB^LRVER1(LRSB)
SET LRY=$PIECE(LRSB(LRSB),U,3)
+92 FOR I=1:1:$LENGTH(LRX,"!")
IF $PIECE(LRY,"!",I)=""
SET $PIECE(LRY,"!",I)=$PIECE(LRX,"!",I)
+93 SET $PIECE(LRSB(LRSB),U,3)=LRY
+94 SET LRTS=$GET(^TMP("LR",$JOB,"TMP",LRSB))
+95 DO V25^LRVER5
+96 SET LRX=LRNGS
SET LRY=$PIECE(LRSB(LRSB),U,5)
+97 FOR I=1:1:$LENGTH(LRX,U)
IF $PIECE(LRY,"!",I)=""
SET $PIECE(LRY,"!",I)=$PIECE(LRX,U,I)
+98 SET $PIECE(LRSB(LRSB),U,5)=LRY
+99 IF $PIECE(LRSB(LRSB),U,9)=""
SET $PIECE(LRSB(LRSB),U,9)=$SELECT($GET(LRDUZ(2)):LRDUZ(2),1:$GET(DUZ(2)))
+100 SET ^LR(LRDFN,"CH",LRIDT,LRSB)=LRSB(LRSB)
End DoDot:1
IF LRERR
QUIT
+101 ;
+102 IF LRERR
DO SENDACK^LRVRPOCU
QUIT
+103 ;
+104 ; Call to set data and comments
+105 IF $ORDER(LRSB(0))
Begin DoDot:1
+106 DO LRSBCOM^LRVR4
DO A3^LRVR3
+107 SET LRSTORE=LRSTORE+1
+108 IF $GET(LA76248)
SET LRSTORE(LA76248)=$GET(LRSTORE(LA76248))+1
End DoDot:1
+109 ;
+110 ; Send application ack back to POC interface
+111 DO SENDACK^LRVRPOCU
+112 QUIT
