Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRVRPOC

LRVRPOC.m

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