LRVRPOC ;DALOI/JMC - POINT OF CARE VERIFICATION ; 4 May 2004
 ;;5.2;LAB SERVICE;**290**;Sep 27, 1994
 ;
 ; 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