LRVRPOCU ;DALOI/JMC - POINT OF CARE UTILITY PROGRAM ;05/11/10 16:38
;;5.2;LAB SERVICE;**290,350**;Sep 27, 1994;Build 230
;
; Reference to DUZ^XUP supported by DBIA #4129
; Reference to DIVSET^XUSRB2 supported by DBIA #4055
;
Q
;
;
INIT ; Initialize user
;
N I,LR60,LR61,LR62,LR64,LR0070,LRNLT,LRX,LRY
;
; 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")
. S LREND=1
;
;
; 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)
. S LREND=1
;
S (LRCNT,LREND,LRSTORE)=0,(DIQUIET,LRNOECHO,LRQUIET)=1,LAMSG=""
K LRDUZ,LRERR,LRIEN,LRORDNLT
D KVAR^VADPT
S LRX=$$FIND1^DIC(200,"","OX","LRLAB,POC","B","")
I LRX<1 D Q
. S LREND=1
. S LAMSG="Unable to identify user 'LRLAB,POC' in NEW PERSON file"
D DUZ^XUP(LRX)
;
D EN^LRPARAM
I $G(LREND) S LAMSG="LRPARAM Error for Load/Work List "_$P(LRLL(0),"^") Q
S $P(LRPARAM,U,3)="",$P(LRPARAM,U,4)=""
S LRLABKY="1^^^1" ;lab verification keys
;
; Get list of test and setup variables
S (LRORDR,LRLWC)="P" ; Order type POC
S LRTYPE=+$P($G(^LRO(68.2,LRLL,0)),U,3)
;
S LRPROF=$O(^LRO(68.2,LRLL,10,0))
I 'LRPROF D Q
. S LREND=1
. S LAMSG="No Profile for Load/Work List "_$P(LRLL(0),"^")
;
S LRPROF(0)=^LRO(68.2,LRLL,10,LRPROF,0)
S (LRDAA,LRAA)=$P(LRPROF(0),U,2)
I $S('$G(LRDAA):1,'$D(^LRO(68,LRDAA,0))#2:1,1:0) D Q
. S LREND=1
. S LAMSG="No Default accession area for Load/Work List "_$P(LRLL(0),"^")
I $P(^LRO(68,LRAA,0),U,2)'="CH" S LREND=1,LAMSG="No CH accession area for Load/Work List "_$P(LRLL(0),"^") Q
;
I $$GET1^DIQ(68,LRDAA_",",.4)="" D Q
. S LREND=1
. S LAMSG="No Numeric Identifier for Accession Area "_$$GET1^DIQ(68,LRDAA_",",.01)
;
S LRX=$G(^LRO(68,LRAA,0))
S LRLD=$S($P(LRX,U,19)'="":$P(LRX,U,19),1:"CP")
;
S LRDFWKLD=+$G(^LRO(68.2,LRLL,"SUF"))
D WKLD(LRDFWKLD)
I LRCDEF="" D Q
. S LREND=1
. S LAMSG="No Default Suffix for Load/Work List "_$P(LRLL(0),"^")
;
; Explode the test list
K ^TMP("LR",$J)
D EXPLODE^LRGP2
I '$O(^TMP("LR",$J,"VTO",0)) D Q
. S LREND=1
. S LAMSG="No Test defined for Load/Work List "_$P(LRLL(0),"^")
;
; Build array of order NLT codes and corresponding file #60 tests.
S I=0
F S I=$O(^LRO(68.2,LRLL,10,LRPROF,1,I)) Q:'I D
. S LRY=$G(^LRO(68.2,LRLL,10,LRPROF,1,I,0)),(LR0070,LR62)=""
. S LR60=+LRY,LR61=$P(LRY,"^",2),LR64=+$G(^LAB(60,LR60,64))
. I LR64 D
. . S LRNLT=$P($G(^LAM(LR64,0)),"^",2)
. . I LR61 D
. . . S LR0070=$$GET1^DIQ(61,LR61_",","LEDI HL7:HL7 ABBR")
. . . S LR62=$P(LRY,"^",5)
. . . I 'LR62 S LR62=$$GET1^DIQ(61,LR61_",",4.1,"I")
. . I LRNLT'="",LR0070'="" S LRORDNLT(LRNLT,LR0070)=LR60_"^"_LR61_"^"_LR62_"^"_$P(LRY,"^",4)
;
K LRIEN,LRERR
S LRDPF="2^DPT(",(LRERR,VAERR)=0,(LRLBLBP,LREAL,LRASSN,VA200,COMB)=""
S LROUTINE=$$GET1^DIQ(69.9,"1,",301,"I","ANS","ERR") ;Routine urgency
S:'LROUTINE LROUTINE=9
S LRALERT=LROUTINE
;
I $$GET1^DIQ(68.2,LRLL_",",.03,"I")'=2 D Q
. S LREND=1
. S LAMSG="Load/Work List "_$P(LRLL(0),"^")_" not set to POC type."
;
; Determine division to set user LRLAB,POC.
S LRDIV=$O(^LRO(68,LRDAA,3,0))
I LRDIV<1 D Q
. S LREND=1
. S LAMSG="No associated division for accession area "_$$GET1^DIQ(68,LRDAA_",",.01)
I LRDIV'=DUZ(2) D Q:LREND
. S LRY=0
. D DIVSET^XUSRB2(.LRY,"`"_LRDIV)
. I LRY Q
. S LREND=1,LAMSG="Unable to set user 'LRLAB,POC' to division "_$$GET1^DIQ(4,LRDIV_",",.01)
;
; Set CPRS nature of order to 'AUTO'.
S LRNATURE=$P($$NEW1^LROR6(9),"^",4,6)
;
S LRVBY=2
Q
;
;
WKLD(LRP) ; Setup LRCDEF* variables for workload
; Call with LRP = ien of WKLD suffix in file #64.2
S LRCDEF0=$G(^LAB(64.2,LRP,0)),LRCDEF0(1)=$P(LRCDEF0,"^",19)
S LRCDEF=$P($P(LRCDEF0,"^",2),".",2)
;
Q
;
;
SPALERT ; Send Processing Alert Message
;
N LAMSG,LRTIME,LRX
S LRX=0,LRTIME=$$HTE^XLFDT($H,"1M")
F S LRX=$O(LRSTORE(LRX)) Q:'LRX D
. I '$D(^LAHM(62.48,LRX,20,"B",1)) Q ; New result alerts not defined
. S LAMSG=$P(LRSTORE(LRX),"^")_" Patient(s) processed for POC: "_$$GET1^DIQ(62.48,LRX_",",.01)_" on "_LRTIME
. D XQA^LA7UXQA(1,LRX,"","",LAMSG,"",1)
Q
;
;
CLEAN ;Clean-up point
D KVAR^VADPT
K AGE,COMB,CONTROL,DFN,DOB,DTS,H8,I5
K LRACC,LRACD,LRAD,LRAN,LRAOD
K LRASSN,LRCAPLOC,LRCDT,LRCDEF,LRCDEF0,LRCDEF0X,LRCODEN,LRCOM
K LRDATA,LRERR,LRNOCODE,LROLDIV
K LRPRAC,LRRB
K LRSB,LRSN,LRSQ,LRSSCX,LRSSN,LRSUB,LRSXN,LRST,LRSUB,LRSUM
K LRSXN,LRT,LRTN,LRTREA,LRTS,LRTSORU,LRTST,LRTT,LRUID
K LRUNQ,LRWRD,PNM,S5,SEGID,SEX,SSN
K LRIDT,LRIN,LRIX,LRBLBP,LRM,LRNLT,LRNOW,LRNT,LRNX,LRODT
K LROLLOC,LRORD,LRODTIM,LRORU3,LROT,OCXAP
K T1,VA,VADMVT,VAINDT,VAL,XP,Z
Q
;
;
VASD ; Check for clinic appointment at same time as specimen
; else for clinic appointment before specimen date/time on same date.
;
; If unable to find an appointment before the specimen date/time then
; look for first appointment after specimen date/time.
;
; If ordering division in message then only check those clinic locations
; that are in the same division.
;
; If collection date/time within 6 hours of start of day
; then start look back 6 hours previous to collection date/time
; Example: if 3 am then start 9pm previous day.
;
N LRDATE,LRCLIEN,LRCOUNT,LRENC,LREXACT,LRP,LRX,LRY
S (LRDATE,LRENC,LREXACT,LRY)=0
S LRX=LRCDT#1
I LRX>.06 S LRP(1)=(LRCDT\1)_";"_(LRCDT\1)
E S LRP(1)=$$FMADD^XLFDT(LRCDT,0,-6,0,0)_";"_(LRCDT\1)
S LRP(3)="R;I;NT"
S LRP(4)=DFN
S LRP("FLDS")="2;12"
S LRP("SORT")="P"
S LRCOUNT=$$SDAPI^SDAMA301(.LRP)
I LRCOUNT>0 D
. I 'LROLLOC D FINDAPPT Q
. I LROLLOC,'LRPRAC D CHKAPPT
;
I LRCOUNT'=0 K ^TMP($J,"SDAMA301")
;
; If no provider then try provider from outpatient encounter.
I 'LRPRAC,LROLLOC,LRENC D OENC(LRENC)
Q
;
;
FINDAPPT ; Find an appointment for the collection date/time
F S LRDATE=$O(^TMP($J,"SDAMA301",DFN,LRDATE)) Q:LRDATE="" D Q:LREXACT
. S LRX=$G(^TMP($J,"SDAMA301",DFN,LRDATE))
. S LRCLIEN=$P($P(LRX,"^",2),";")
. I LROLDIV,LROLDIV'=$$GET1^DIQ(44,LRCLIEN_",",3,"I") Q
. I LRDATE=LRCDT S LROLLOC=LRCLIEN,LRENC=$P(LRX,"^",12),LREXACT=1 Q
. I 'LRY,LRDATE<LRCDT S LRY=LRX,LROLLOC=LRCLIEN,LRENC=$P(LRX,"^",12) Q
. I 'LRY,LRDATE>LRCDT S LRY=LRX,LROLLOC=LRCLIEN,LRENC=$P(LRX,"^",12) Q
. I LRDATE>LRY,LRDATE<LRCDT S LRY=LRX,LROLLOC=LRCLIEN,LRENC=$P(LRX,"^",12)
;
I 'LROLDIV S LROLDIV=$$GET1^DIQ(44,LRCLIEN_",",3,"I")
Q
;
;
CHKAPPT ; Check for an appointment that matches the ordering location
; to find the provider on the encounter when no provider sent.
F S LRDATE=$O(^TMP($J,"SDAMA301",DFN,LRDATE)) Q:LRDATE="" D Q:LRENC
. S LRX=$G(^TMP($J,"SDAMA301",DFN,LRDATE))
. S LRCLIEN=$P($P(LRX,"^",2),";")
. I LROLLOC=LRCLIEN S LRENC=$P(LRX,"^",12) Q
Q
;
;
OENC(LRENC) ; Lookup provider on encounter
; Use primary provider if possible otherwise use first provider listed.
;
N LRI,LRPRVLST,LRERR
D GETPRV^SDOE(LRENC,"LRPRVLST","LRERR")
I $G(LRPRVLST)<1 Q
S LRI=0
F S LRI=$O(LRPRVLST(LRI)) Q:'LRI D Q:LRPRAC
. I $P(LRPRVLST(LRI),"^",4)="P" S LRPRAC=+LRPRVLST(LRI) Q
I 'LRPRAC S LRI=$O(LRPRVLST(0)),LRPRAC=+LRPRVLST(LRI)
Q
;
;
SENDACK ; Send HL7 ACKnowledgment message
;
N LA
S LA(62.48)=LA76248,LA(62.49)=LA76249
S LA("ACK")=$S(+LRERR:"AE",1:"AA")
S LA("MSG")=$S($G(LRUID)'="":LRUID_"^",1:"")
S LA("MSG")=LA("MSG")_$P(LRERR,"^",2)
D ACK^LA7POC(.LA)
Q
;
;
GETDFN(LAPID) ; Find patient in PATIENT (#2) file based on patient id
; Call with LAPID = patient id to lookup
;
; Returns DFN = ien of patient in PATIENT (#2) file
; 0^error encountered
;
I DUZ("AG")="V" D
. S DFN=$$FIND1^DIC(2,"","X",LAPID,"SSN","","")
;
Q DFN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRVRPOCU 7993 printed Apr 09, 2024@21:06:54 Page 2
LRVRPOCU ;DALOI/JMC - POINT OF CARE UTILITY PROGRAM ;05/11/10 16:38
+1 ;;5.2;LAB SERVICE;**290,350**;Sep 27, 1994;Build 230
+2 ;
+3 ; Reference to DUZ^XUP supported by DBIA #4129
+4 ; Reference to DIVSET^XUSRB2 supported by DBIA #4055
+5 ;
+6 QUIT
+7 ;
+8 ;
INIT ; Initialize user
+1 ;
+2 NEW I,LR60,LR61,LR62,LR64,LR0070,LRNLT,LRX,LRY
+3 ;
+4 ; If rollover has not completed then requeue task 1 hour in future and send alert.
+5 IF $GET(^LAB(69.9,1,"RO"))'=+$HOROLOG
Begin DoDot:1
+6 SET ZTREQ=$$HADD^XLFDT($HOROLOG,0,1,0,0)
+7 SET LAMSG="POC: Lab Rollover has not completed as of "_$$HTE^XLFDT($HOROLOG,"1M")
+8 SET LREND=1
End DoDot:1
QUIT
+9 ;
+10 ;
+11 ; Must be POC Load/Work List
+12 IF $$GET1^DIQ(68.2,LRLL,.03,"I")'=2
Begin DoDot:1
+13 SET LAMSG="POC: Unable to process POC results using non-POC worklist "_$$GET1^DIQ(68.2,LRLL,.01)
+14 SET LREND=1
End DoDot:1
QUIT
+15 ;
+16 SET (LRCNT,LREND,LRSTORE)=0
SET (DIQUIET,LRNOECHO,LRQUIET)=1
SET LAMSG=""
+17 KILL LRDUZ,LRERR,LRIEN,LRORDNLT
+18 DO KVAR^VADPT
+19 SET LRX=$$FIND1^DIC(200,"","OX","LRLAB,POC","B","")
+20 IF LRX<1
Begin DoDot:1
+21 SET LREND=1
+22 SET LAMSG="Unable to identify user 'LRLAB,POC' in NEW PERSON file"
End DoDot:1
QUIT
+23 DO DUZ^XUP(LRX)
+24 ;
+25 DO EN^LRPARAM
+26 IF $GET(LREND)
SET LAMSG="LRPARAM Error for Load/Work List "_$PIECE(LRLL(0),"^")
QUIT
+27 SET $PIECE(LRPARAM,U,3)=""
SET $PIECE(LRPARAM,U,4)=""
+28 ;lab verification keys
SET LRLABKY="1^^^1"
+29 ;
+30 ; Get list of test and setup variables
+31 ; Order type POC
SET (LRORDR,LRLWC)="P"
+32 SET LRTYPE=+$PIECE($GET(^LRO(68.2,LRLL,0)),U,3)
+33 ;
+34 SET LRPROF=$ORDER(^LRO(68.2,LRLL,10,0))
+35 IF 'LRPROF
Begin DoDot:1
+36 SET LREND=1
+37 SET LAMSG="No Profile for Load/Work List "_$PIECE(LRLL(0),"^")
End DoDot:1
QUIT
+38 ;
+39 SET LRPROF(0)=^LRO(68.2,LRLL,10,LRPROF,0)
+40 SET (LRDAA,LRAA)=$PIECE(LRPROF(0),U,2)
+41 IF $SELECT('$GET(LRDAA):1,'$DATA(^LRO(68,LRDAA,0))#2:1,1:0)
Begin DoDot:1
+42 SET LREND=1
+43 SET LAMSG="No Default accession area for Load/Work List "_$PIECE(LRLL(0),"^")
End DoDot:1
QUIT
+44 IF $PIECE(^LRO(68,LRAA,0),U,2)'="CH"
SET LREND=1
SET LAMSG="No CH accession area for Load/Work List "_$PIECE(LRLL(0),"^")
QUIT
+45 ;
+46 IF $$GET1^DIQ(68,LRDAA_",",.4)=""
Begin DoDot:1
+47 SET LREND=1
+48 SET LAMSG="No Numeric Identifier for Accession Area "_$$GET1^DIQ(68,LRDAA_",",.01)
End DoDot:1
QUIT
+49 ;
+50 SET LRX=$GET(^LRO(68,LRAA,0))
+51 SET LRLD=$SELECT($PIECE(LRX,U,19)'="":$PIECE(LRX,U,19),1:"CP")
+52 ;
+53 SET LRDFWKLD=+$GET(^LRO(68.2,LRLL,"SUF"))
+54 DO WKLD(LRDFWKLD)
+55 IF LRCDEF=""
Begin DoDot:1
+56 SET LREND=1
+57 SET LAMSG="No Default Suffix for Load/Work List "_$PIECE(LRLL(0),"^")
End DoDot:1
QUIT
+58 ;
+59 ; Explode the test list
+60 KILL ^TMP("LR",$JOB)
+61 DO EXPLODE^LRGP2
+62 IF '$ORDER(^TMP("LR",$JOB,"VTO",0))
Begin DoDot:1
+63 SET LREND=1
+64 SET LAMSG="No Test defined for Load/Work List "_$PIECE(LRLL(0),"^")
End DoDot:1
QUIT
+65 ;
+66 ; Build array of order NLT codes and corresponding file #60 tests.
+67 SET I=0
+68 FOR
SET I=$ORDER(^LRO(68.2,LRLL,10,LRPROF,1,I))
if 'I
QUIT
Begin DoDot:1
+69 SET LRY=$GET(^LRO(68.2,LRLL,10,LRPROF,1,I,0))
SET (LR0070,LR62)=""
+70 SET LR60=+LRY
SET LR61=$PIECE(LRY,"^",2)
SET LR64=+$GET(^LAB(60,LR60,64))
+71 IF LR64
Begin DoDot:2
+72 SET LRNLT=$PIECE($GET(^LAM(LR64,0)),"^",2)
+73 IF LR61
Begin DoDot:3
+74 SET LR0070=$$GET1^DIQ(61,LR61_",","LEDI HL7:HL7 ABBR")
+75 SET LR62=$PIECE(LRY,"^",5)
+76 IF 'LR62
SET LR62=$$GET1^DIQ(61,LR61_",",4.1,"I")
End DoDot:3
+77 IF LRNLT'=""
IF LR0070'=""
SET LRORDNLT(LRNLT,LR0070)=LR60_"^"_LR61_"^"_LR62_"^"_$PIECE(LRY,"^",4)
End DoDot:2
End DoDot:1
+78 ;
+79 KILL LRIEN,LRERR
+80 SET LRDPF="2^DPT("
SET (LRERR,VAERR)=0
SET (LRLBLBP,LREAL,LRASSN,VA200,COMB)=""
+81 ;Routine urgency
SET LROUTINE=$$GET1^DIQ(69.9,"1,",301,"I","ANS","ERR")
+82 if 'LROUTINE
SET LROUTINE=9
+83 SET LRALERT=LROUTINE
+84 ;
+85 IF $$GET1^DIQ(68.2,LRLL_",",.03,"I")'=2
Begin DoDot:1
+86 SET LREND=1
+87 SET LAMSG="Load/Work List "_$PIECE(LRLL(0),"^")_" not set to POC type."
End DoDot:1
QUIT
+88 ;
+89 ; Determine division to set user LRLAB,POC.
+90 SET LRDIV=$ORDER(^LRO(68,LRDAA,3,0))
+91 IF LRDIV<1
Begin DoDot:1
+92 SET LREND=1
+93 SET LAMSG="No associated division for accession area "_$$GET1^DIQ(68,LRDAA_",",.01)
End DoDot:1
QUIT
+94 IF LRDIV'=DUZ(2)
Begin DoDot:1
+95 SET LRY=0
+96 DO DIVSET^XUSRB2(.LRY,"`"_LRDIV)
+97 IF LRY
QUIT
+98 SET LREND=1
SET LAMSG="Unable to set user 'LRLAB,POC' to division "_$$GET1^DIQ(4,LRDIV_",",.01)
End DoDot:1
if LREND
QUIT
+99 ;
+100 ; Set CPRS nature of order to 'AUTO'.
+101 SET LRNATURE=$PIECE($$NEW1^LROR6(9),"^",4,6)
+102 ;
+103 SET LRVBY=2
+104 QUIT
+105 ;
+106 ;
WKLD(LRP) ; Setup LRCDEF* variables for workload
+1 ; Call with LRP = ien of WKLD suffix in file #64.2
+2 SET LRCDEF0=$GET(^LAB(64.2,LRP,0))
SET LRCDEF0(1)=$PIECE(LRCDEF0,"^",19)
+3 SET LRCDEF=$PIECE($PIECE(LRCDEF0,"^",2),".",2)
+4 ;
+5 QUIT
+6 ;
+7 ;
SPALERT ; Send Processing Alert Message
+1 ;
+2 NEW LAMSG,LRTIME,LRX
+3 SET LRX=0
SET LRTIME=$$HTE^XLFDT($HOROLOG,"1M")
+4 FOR
SET LRX=$ORDER(LRSTORE(LRX))
if 'LRX
QUIT
Begin DoDot:1
+5 ; New result alerts not defined
IF '$DATA(^LAHM(62.48,LRX,20,"B",1))
QUIT
+6 SET LAMSG=$PIECE(LRSTORE(LRX),"^")_" Patient(s) processed for POC: "_$$GET1^DIQ(62.48,LRX_",",.01)_" on "_LRTIME
+7 DO XQA^LA7UXQA(1,LRX,"","",LAMSG,"",1)
End DoDot:1
+8 QUIT
+9 ;
+10 ;
CLEAN ;Clean-up point
+1 DO KVAR^VADPT
+2 KILL AGE,COMB,CONTROL,DFN,DOB,DTS,H8,I5
+3 KILL LRACC,LRACD,LRAD,LRAN,LRAOD
+4 KILL LRASSN,LRCAPLOC,LRCDT,LRCDEF,LRCDEF0,LRCDEF0X,LRCODEN,LRCOM
+5 KILL LRDATA,LRERR,LRNOCODE,LROLDIV
+6 KILL LRPRAC,LRRB
+7 KILL LRSB,LRSN,LRSQ,LRSSCX,LRSSN,LRSUB,LRSXN,LRST,LRSUB,LRSUM
+8 KILL LRSXN,LRT,LRTN,LRTREA,LRTS,LRTSORU,LRTST,LRTT,LRUID
+9 KILL LRUNQ,LRWRD,PNM,S5,SEGID,SEX,SSN
+10 KILL LRIDT,LRIN,LRIX,LRBLBP,LRM,LRNLT,LRNOW,LRNT,LRNX,LRODT
+11 KILL LROLLOC,LRORD,LRODTIM,LRORU3,LROT,OCXAP
+12 KILL T1,VA,VADMVT,VAINDT,VAL,XP,Z
+13 QUIT
+14 ;
+15 ;
VASD ; Check for clinic appointment at same time as specimen
+1 ; else for clinic appointment before specimen date/time on same date.
+2 ;
+3 ; If unable to find an appointment before the specimen date/time then
+4 ; look for first appointment after specimen date/time.
+5 ;
+6 ; If ordering division in message then only check those clinic locations
+7 ; that are in the same division.
+8 ;
+9 ; If collection date/time within 6 hours of start of day
+10 ; then start look back 6 hours previous to collection date/time
+11 ; Example: if 3 am then start 9pm previous day.
+12 ;
+13 NEW LRDATE,LRCLIEN,LRCOUNT,LRENC,LREXACT,LRP,LRX,LRY
+14 SET (LRDATE,LRENC,LREXACT,LRY)=0
+15 SET LRX=LRCDT#1
+16 IF LRX>.06
SET LRP(1)=(LRCDT\1)_";"_(LRCDT\1)
+17 IF '$TEST
SET LRP(1)=$$FMADD^XLFDT(LRCDT,0,-6,0,0)_";"_(LRCDT\1)
+18 SET LRP(3)="R;I;NT"
+19 SET LRP(4)=DFN
+20 SET LRP("FLDS")="2;12"
+21 SET LRP("SORT")="P"
+22 SET LRCOUNT=$$SDAPI^SDAMA301(.LRP)
+23 IF LRCOUNT>0
Begin DoDot:1
+24 IF 'LROLLOC
DO FINDAPPT
QUIT
+25 IF LROLLOC
IF 'LRPRAC
DO CHKAPPT
End DoDot:1
+26 ;
+27 IF LRCOUNT'=0
KILL ^TMP($JOB,"SDAMA301")
+28 ;
+29 ; If no provider then try provider from outpatient encounter.
+30 IF 'LRPRAC
IF LROLLOC
IF LRENC
DO OENC(LRENC)
+31 QUIT
+32 ;
+33 ;
FINDAPPT ; Find an appointment for the collection date/time
+1 FOR
SET LRDATE=$ORDER(^TMP($JOB,"SDAMA301",DFN,LRDATE))
if LRDATE=""
QUIT
Begin DoDot:1
+2 SET LRX=$GET(^TMP($JOB,"SDAMA301",DFN,LRDATE))
+3 SET LRCLIEN=$PIECE($PIECE(LRX,"^",2),";")
+4 IF LROLDIV
IF LROLDIV'=$$GET1^DIQ(44,LRCLIEN_",",3,"I")
QUIT
+5 IF LRDATE=LRCDT
SET LROLLOC=LRCLIEN
SET LRENC=$PIECE(LRX,"^",12)
SET LREXACT=1
QUIT
+6 IF 'LRY
IF LRDATE<LRCDT
SET LRY=LRX
SET LROLLOC=LRCLIEN
SET LRENC=$PIECE(LRX,"^",12)
QUIT
+7 IF 'LRY
IF LRDATE>LRCDT
SET LRY=LRX
SET LROLLOC=LRCLIEN
SET LRENC=$PIECE(LRX,"^",12)
QUIT
+8 IF LRDATE>LRY
IF LRDATE<LRCDT
SET LRY=LRX
SET LROLLOC=LRCLIEN
SET LRENC=$PIECE(LRX,"^",12)
End DoDot:1
if LREXACT
QUIT
+9 ;
+10 IF 'LROLDIV
SET LROLDIV=$$GET1^DIQ(44,LRCLIEN_",",3,"I")
+11 QUIT
+12 ;
+13 ;
CHKAPPT ; Check for an appointment that matches the ordering location
+1 ; to find the provider on the encounter when no provider sent.
+2 FOR
SET LRDATE=$ORDER(^TMP($JOB,"SDAMA301",DFN,LRDATE))
if LRDATE=""
QUIT
Begin DoDot:1
+3 SET LRX=$GET(^TMP($JOB,"SDAMA301",DFN,LRDATE))
+4 SET LRCLIEN=$PIECE($PIECE(LRX,"^",2),";")
+5 IF LROLLOC=LRCLIEN
SET LRENC=$PIECE(LRX,"^",12)
QUIT
End DoDot:1
if LRENC
QUIT
+6 QUIT
+7 ;
+8 ;
OENC(LRENC) ; Lookup provider on encounter
+1 ; Use primary provider if possible otherwise use first provider listed.
+2 ;
+3 NEW LRI,LRPRVLST,LRERR
+4 DO GETPRV^SDOE(LRENC,"LRPRVLST","LRERR")
+5 IF $GET(LRPRVLST)<1
QUIT
+6 SET LRI=0
+7 FOR
SET LRI=$ORDER(LRPRVLST(LRI))
if 'LRI
QUIT
Begin DoDot:1
+8 IF $PIECE(LRPRVLST(LRI),"^",4)="P"
SET LRPRAC=+LRPRVLST(LRI)
QUIT
End DoDot:1
if LRPRAC
QUIT
+9 IF 'LRPRAC
SET LRI=$ORDER(LRPRVLST(0))
SET LRPRAC=+LRPRVLST(LRI)
+10 QUIT
+11 ;
+12 ;
SENDACK ; Send HL7 ACKnowledgment message
+1 ;
+2 NEW LA
+3 SET LA(62.48)=LA76248
SET LA(62.49)=LA76249
+4 SET LA("ACK")=$SELECT(+LRERR:"AE",1:"AA")
+5 SET LA("MSG")=$SELECT($GET(LRUID)'="":LRUID_"^",1:"")
+6 SET LA("MSG")=LA("MSG")_$PIECE(LRERR,"^",2)
+7 DO ACK^LA7POC(.LA)
+8 QUIT
+9 ;
+10 ;
GETDFN(LAPID) ; Find patient in PATIENT (#2) file based on patient id
+1 ; Call with LAPID = patient id to lookup
+2 ;
+3 ; Returns DFN = ien of patient in PATIENT (#2) file
+4 ; 0^error encountered
+5 ;
+6 IF DUZ("AG")="V"
Begin DoDot:1
+7 SET DFN=$$FIND1^DIC(2,"","X",LAPID,"SSN","","")
End DoDot:1
+8 ;
+9 QUIT DFN
