- LRVRPOCU ;DALOI/JMC - POINT OF CARE UTILITY PROGRAM; Oct 23, 2023@17:30
- ;;5.2;LAB SERVICE;**290,350,568**;Sep 27, 1994;Build 3
- ;
- ;Reference to DUZ^XUP in ICR #4129
- ;Reference to DIVSET^XUSRB2 in ICR #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.
- ;LR*5.2*568: LRSYSDIV is set in EN^LRVRPOC.
- S LRDIV=$S(LRSYSDIV:LRSYSDIV,1:$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 8044 printed Mar 13, 2025@21:27:26 Page 2
- LRVRPOCU ;DALOI/JMC - POINT OF CARE UTILITY PROGRAM; Oct 23, 2023@17:30
- +1 ;;5.2;LAB SERVICE;**290,350,568**;Sep 27, 1994;Build 3
- +2 ;
- +3 ;Reference to DUZ^XUP in ICR #4129
- +4 ;Reference to DIVSET^XUSRB2 in ICR #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 ;LR*5.2*568: LRSYSDIV is set in EN^LRVRPOC.
- +91 SET LRDIV=$SELECT(LRSYSDIV:LRSYSDIV,1:$ORDER(^LRO(68,LRDAA,3,0)))
- +92 IF LRDIV<1
- Begin DoDot:1
- +93 SET LREND=1
- +94 SET LAMSG="No associated division for accession area "_$$GET1^DIQ(68,LRDAA_",",.01)
- End DoDot:1
- QUIT
- +95 IF LRDIV'=DUZ(2)
- Begin DoDot:1
- +96 SET LRY=0
- +97 DO DIVSET^XUSRB2(.LRY,"`"_LRDIV)
- +98 IF LRY
- QUIT
- +99 SET LREND=1
- SET LAMSG="Unable to set user 'LRLAB,POC' to division "_$$GET1^DIQ(4,LRDIV_",",.01)
- End DoDot:1
- if LREND
- QUIT
- +100 ;
- +101 ; Set CPRS nature of order to 'AUTO'.
- +102 SET LRNATURE=$PIECE($$NEW1^LROR6(9),"^",4,6)
- +103 ;
- +104 SET LRVBY=2
- +105 QUIT
- +106 ;
- +107 ;
- 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
