LRVRPOCU ;VA/DALOI/JMC - POINT OF CARE UTILITY PROGRAM ; May 10, 2004 12:06
;;5.2;LAB SERVICE;**1031**;NOV 1, 1997
;
;;VA LR Patch(s): 290
;
; 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
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.
;
N LRDATE,LRCLIEN,LRCOUNT,LRENC,LREXACT,LRP,LRX,LRY
S (LRDATE,LRENC,LREXACT,LRY)=0
S LRP(1)=(LRCDT\1)_";"_(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)
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 possbile 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
LRVRPOCU ;VA/DALOI/JMC - POINT OF CARE UTILITY PROGRAM ; May 10, 2004 12:06
+1 ;;5.2;LAB SERVICE;**1031**;NOV 1, 1997
+2 ;
+3 ;;VA LR Patch(s): 290
+4 ;
+5 ; Reference to DUZ^XUP supported by DBIA #4129
+6 ; Reference to DIVSET^XUSRB2 supported by DBIA #4055
+7 ;
+8 QUIT
+9 ;
+10 ;
INIT ; Initialize user
+1 ;
+2 NEW I,LR60,LR61,LR62,LR64,LR0070,LRNLT,LRX,LRY
+3 SET (LRCNT,LREND,LRSTORE)=0
SET (DIQUIET,LRNOECHO,LRQUIET)=1
SET LAMSG=""
+4 KILL LRDUZ,LRERR,LRIEN,LRORDNLT
+5 DO KVAR^VADPT
+6 SET LRX=$$FIND1^DIC(200,"","OX","LRLAB,POC","B","")
+7 IF LRX<1
Begin DoDot:1
+8 SET LREND=1
+9 SET LAMSG="Unable to identify user 'LRLAB,POC' in NEW PERSON file"
End DoDot:1
QUIT
+10 DO DUZ^XUP(LRX)
+11 ;
+12 DO EN^LRPARAM
+13 IF $GET(LREND)
SET LAMSG="LRPARAM Error for Load/Work List "_$PIECE(LRLL(0),"^")
QUIT
+14 SET $PIECE(LRPARAM,U,3)=""
SET $PIECE(LRPARAM,U,4)=""
+15 ;lab verification keys
SET LRLABKY="1^^^1"
+16 ;
+17 ; Get list of test and setup variables
+18 ; Order type POC
SET (LRORDR,LRLWC)="P"
+19 SET LRTYPE=+$PIECE($GET(^LRO(68.2,LRLL,0)),U,3)
+20 ;
+21 SET LRPROF=$ORDER(^LRO(68.2,LRLL,10,0))
+22 IF 'LRPROF
Begin DoDot:1
+23 SET LREND=1
+24 SET LAMSG="No Profile for Load/Work List "_$PIECE(LRLL(0),"^")
End DoDot:1
QUIT
+25 ;
+26 SET LRPROF(0)=^LRO(68.2,LRLL,10,LRPROF,0)
+27 SET (LRDAA,LRAA)=$PIECE(LRPROF(0),U,2)
+28 IF $SELECT('$GET(LRDAA):1,'$DATA(^LRO(68,LRDAA,0))#2:1,1:0)
Begin DoDot:1
+29 SET LREND=1
+30 SET LAMSG="No Default accession area for Load/Work List "_$PIECE(LRLL(0),"^")
End DoDot:1
QUIT
+31 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
+32 ;
+33 IF $$GET1^DIQ(68,LRDAA_",",.4)=""
Begin DoDot:1
+34 SET LREND=1
+35 SET LAMSG="No Numeric Identifier for Accession Area "_$$GET1^DIQ(68,LRDAA_",",.01)
End DoDot:1
QUIT
+36 ;
+37 SET LRX=$GET(^LRO(68,LRAA,0))
+38 SET LRLD=$SELECT($PIECE(LRX,U,19)'="":$PIECE(LRX,U,19),1:"CP")
+39 ;
+40 SET LRDFWKLD=+$GET(^LRO(68.2,LRLL,"SUF"))
+41 DO WKLD(LRDFWKLD)
+42 IF LRCDEF=""
Begin DoDot:1
+43 SET LREND=1
+44 SET LAMSG="No Default Suffix for Load/Work List "_$PIECE(LRLL(0),"^")
End DoDot:1
QUIT
+45 ;
+46 ; Explode the test list
+47 KILL ^TMP("LR",$JOB)
+48 DO EXPLODE^LRGP2
+49 IF '$ORDER(^TMP("LR",$JOB,"VTO",0))
Begin DoDot:1
+50 SET LREND=1
+51 SET LAMSG="No Test defined for Load/Work List "_$PIECE(LRLL(0),"^")
End DoDot:1
QUIT
+52 ;
+53 ; Build array of order NLT codes and corresponding file #60 tests.
+54 SET I=0
+55 FOR
SET I=$ORDER(^LRO(68.2,LRLL,10,LRPROF,1,I))
IF 'I
QUIT
Begin DoDot:1
+56 SET LRY=$GET(^LRO(68.2,LRLL,10,LRPROF,1,I,0))
SET (LR0070,LR62)=""
+57 SET LR60=+LRY
SET LR61=$PIECE(LRY,"^",2)
SET LR64=+$GET(^LAB(60,LR60,64))
+58 IF LR64
Begin DoDot:2
+59 SET LRNLT=$PIECE($GET(^LAM(LR64,0)),"^",2)
+60 IF LR61
Begin DoDot:3
+61 SET LR0070=$$GET1^DIQ(61,LR61_",","LEDI HL7:HL7 ABBR")
+62 SET LR62=$PIECE(LRY,"^",5)
+63 IF 'LR62
SET LR62=$$GET1^DIQ(61,LR61_",",4.1,"I")
End DoDot:3
+64 IF LRNLT'=""
IF LR0070'=""
SET LRORDNLT(LRNLT,LR0070)=LR60_"^"_LR61_"^"_LR62_"^"_$PIECE(LRY,"^",4)
End DoDot:2
End DoDot:1
+65 ;
+66 KILL LRIEN,LRERR
+67 SET LRDPF="2^DPT("
SET (LRERR,VAERR)=0
SET (LRLBLBP,LREAL,LRASSN,VA200,COMB)=""
+68 ;Routine urgency
SET LROUTINE=$$GET1^DIQ(69.9,"1,",301,"I","ANS","ERR")
+69 IF 'LROUTINE
SET LROUTINE=9
+70 SET LRALERT=LROUTINE
+71 ;
+72 IF $$GET1^DIQ(68.2,LRLL_",",.03,"I")'=2
Begin DoDot:1
+73 SET LREND=1
+74 SET LAMSG="Load/Work List "_$PIECE(LRLL(0),"^")_" not set to POC type."
End DoDot:1
QUIT
+75 ;
+76 ; Determine division to set user LRLAB,POC.
+77 SET LRDIV=$ORDER(^LRO(68,LRDAA,3,0))
+78 IF LRDIV<1
Begin DoDot:1
+79 SET LREND=1
+80 SET LAMSG="No associated division for accession area "_$$GET1^DIQ(68,LRDAA_",",.01)
End DoDot:1
QUIT
+81 IF LRDIV'=DUZ(2)
Begin DoDot:1
+82 SET LRY=0
+83 DO DIVSET^XUSRB2(.LRY,"`"_LRDIV)
+84 IF LRY
QUIT
+85 SET LREND=1
SET LAMSG="Unable to set user 'LRLAB,POC' to division "_$$GET1^DIQ(4,LRDIV_",",.01)
End DoDot:1
IF LREND
QUIT
+86 ;
+87 ; Set CPRS nature of order to 'AUTO'.
+88 SET LRNATURE=$PIECE($$NEW1^LROR6(9),"^",4,6)
+89 ;
+90 SET LRVBY=2
+91 QUIT
+92 ;
+93 ;
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 NEW LRDATE,LRCLIEN,LRCOUNT,LRENC,LREXACT,LRP,LRX,LRY
+10 SET (LRDATE,LRENC,LREXACT,LRY)=0
+11 SET LRP(1)=(LRCDT\1)_";"_(LRCDT\1)
+12 SET LRP(3)="R;I;NT"
+13 SET LRP(4)=DFN
+14 SET LRP("FLDS")="2;12"
+15 SET LRP("SORT")="P"
+16 SET LRCOUNT=$$SDAPI^SDAMA301(.LRP)
+17 IF LRCOUNT>0
Begin DoDot:1
+18 IF 'LROLLOC
DO FINDAPPT
QUIT
+19 IF LROLLOC
IF 'LRPRAC
DO CHKAPPT
End DoDot:1
+20 ;
+21 IF LRCOUNT'=0
KILL ^TMP($JOB,"SDAMA301")
+22 ;
+23 ; If no provider then try provider from outpatient encounter.
+24 IF 'LRPRAC
IF LROLLOC
IF LRENC
DO OENC(LRENC)
+25 QUIT
+26 ;
+27 ;
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 QUIT
+10 ;
+11 ;
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 possbile 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
