LRCAPPH1 ;DALOI/SED/RKS/KLL - PROCESS PHLEBOTOMY WORKLOAD DATA CONT ;07/30/04
;;5.2;LAB SERVICE;**1002,1031**;NOV 1, 1997
;
;;VA LR Patche(s): 127,136,138,158,263,264,274,291,359,308
;
; Reference to ^SC( Supported by DBIA #1482
; Reference to $$CODM^ICPTCOD Supported by DBIA #1995-A
; Reference to $$CPT^ICPTCOD Supported by DBIA #1995-A
; Reference to $$DATA2PCE^PXAPI Supported by DBIA #1889-A
; Reference to $$DELVFILE^PXAPI Supported by DBIA #1889-B
; Reference to ENCEVENT^PXKENC Supported by DBIA #1889-F
; Reference to $$NOW^XLFDT Supported by Reference #10103
; Reference to $$GET^XUA4A72 Supported by Reference #1625
EN3 ;LREDT = PATIENT ENCOUNTER DATE
N LREDT,LRNOP,LRBEID
K ^TMP("LRPXAPI",$J),LRXTST,LRVSITN,LRXCPT
NP ;Not perform entry
S:$D(^LRO(69,"AA",LRCEX,LROA)) ^(LROA)=""
S LREDT=$P($G(^LRO(69,LRCDT,1,LRSN,1)),U)
N LRDUZ
Q:+LREDT'>0!('$D(^LR(+NODE,0))#2)
S:$G(LRDBUG) LREDT=$$NOW^XLFDT
S EDATE=$P(LREDT,".")
S:'$P(LREDT,".",2) $P(LREDT,".",2)="1201"
S LOC=+$P(NODE,U,9),LRNINS=$P(NODE(1),U,8),LRPRO=+$P(NODE,U,6) ;CHECK
S LRDUZ=+$P(NODE,U,2)
S LRNINS=$S($P($G(^SC(LOC,0)),U,4):$P(^(0),U,4),$G(LRNINS):LRNINS,1:LRINS)
S LRPRO=$S($$GET^XUA4A72(LRPRO,EDATE)>0:LRPRO,1:LRDPRAC)
I $S('$G(LOC):1,"CMZ"'[$P($G(^SC(LOC,0)),U,3):1,1:0) Q
I $S('DFN:1,'LOC:1,1:0) S:$D(^LRO(69,"AA",LRCEX,LROA)) ^(LROA)=1 S LRNOP=1 Q
I 'LRNINS S:$D(^LRO(69,"AA",LRCEX,LROA)) ^(LROA)=2 S LRNOP=2 Q
I 'LRPRO S:$D(^LRO(69,"AA",LRCEX,LROA)) ^(LROA)=3 S LRNOP=3 Q
Q:$G(LRNP)
EN5 ;GET THE CPT CODES FOR THE TESTS
I LRCDT,LRSN,$D(^LRO(69,LRCDT,1,LRSN,2,0)) D
. S (LRTST,LRCNT,LRXAA)=0 K LRXTST S LRXTST=""
. F S LRTST=$O(^LRO(69,LRCDT,1,LRSN,2,LRTST)) Q:+LRTST'>0 D
. . Q:'($D(^LRO(69,LRCDT,1,LRSN,2,LRTST,0))#2) S LREN5=^(0)
. . Q:$S($P(LREN5,U,12):1,$P(LREN5,U,11):1,1:0) ;Don't send cancel/already sent codes
. . S LRTSTP=+$P(LREN5,U),LRAA=+$P(LREN5,U,4) Q:$S('LRTSTP:1,'LRAA:1,1:0)
. . ;Turn off old style PCE reporting for CH subscripts.
. . ;Data passed via Billing Aware API
. . I $P($G(^LRO(68,LRAA,0)),U,2)="CH" Q
. . S LRBEID=$P(^LRO(69,LRCDT,1,LRSN,2,LRTST,.3),U)
. . I '$G(LRDBUG),$P($G(^LRO(68,LRAA,0)),U,2)'="MI" S $P(^LRO(69,LRCDT,1,LRSN,2,LRTST,0),U,12)=1
. . I 'LRXAA S LRXAA=LRAA D LOC
. . Q:'$G(LRDSSID)
. . I LRXAA'=LRAA,$D(^TMP("LRPXAPI",$J,"PROCEDURE")) D SEND K ^TMP("LRPXAPI",$J) S LRXAA=LRAA D LOC Q:'$G(LRDSSID) D EN6 Q
. . D EN6
I $D(^TMP("LRPXAPI",$J,"PROCEDURE")),'$G(^LRO(69,"AA",LRCEX,LROA)) D SEND
END Q:$G(LRDBUG)
END0 K ^TMP("LRPXAPI",$J),LRINA,LRREL,LRNLT,CPT,LRPRO,LRICPT,EDATE,LRTST
K I,LOC,LRI,LRCNT,LRSTP,LRNINS,LROK,LRAA,LRXAA,LRDSSID,LREN5,LRXTST
K LRNLTN,LRIDT,LRXTSTU,LRXCPT
Q
EN6 ;Called from LRCAPPNP
;Turn off old style PCE reporting for CH subscripts.
;Data passed via Billing Aware API
I $G(LRAA),$P($G(^LRO(68,LRAA,0)),U,2)="CH" Q
S:'$D(^LRO(69,LRCDT,1,LRSN,"PCE")) ^("PCE")=""
N LRFLG
S LRNLT=+$P($G(^LAB(60,LRTSTP,64)),U),LRICPT=0
Q:+LRNLT'>0
Q:'$D(^LAM("AD",LRNLT,"CPT")) S LRNLTN=$P(^LAM(LRNLT,0),U,2)
Q:'LRNLTN
F S LRICPT=$O(^LAM("AD",LRNLT,"CPT",LRICPT)) Q:+LRICPT'>0 S CPT=+$P($G(^LAM(LRNLT,4,LRICPT,0)),U) I CPT,$P(^(0),U,2)="CPT" D
. ;CPT must be active in file #64 before edit can continue against #81
. S LRFLG=1
. S LRREL=$P(^LAM(LRNLT,4,LRICPT,0),U,3),LRINA=$P(^(0),U,4)
. I LRREL&(LRINA="") S LRFLG=0
. I LRFLG,EDATE>(LRREL-1)&((EDATE<LRINA)!(LRINA="")) S LRFLG=0
. Q:'$G(CPT)!(LRFLG)
. I '$P($$CPT^ICPTCOD(CPT,$P(LREDT,"."),,),U,7) S:$D(^LRO(69,"AA",LRCEX,LROA)) ^(LROA)=4 Q
. S LRREL=$P(^LAM(LRNLT,4,LRICPT,0),U,3),LRINA=$P(^(0),U,4)
. D:LRREL&(LRINA="") SET Q
. D:EDATE>(LRREL-1)&((EDATE<LRINA)!(LRINA="")) SET
Q
LOC ;Called from LRCAPPNP
I '$G(LRAA) S LRNOP=4 Q
S LRDSSLOC=$S($G(^LRO(68,+LRAA,.8)):+^(.8),1:LRDLOC)
I 'LRDSSLOC S:$D(^LRO(69,"AA",LRCEX,LROA)) ^(LROA)=4 S LRNOP=4 Q
S LRDSSID=+$P($G(^SC(LRDSSLOC,0)),U,7)
I 'LRDSSID S:$D(^LRO(69,"AA",LRCEX,LROA)) ^(LROA)=5 S LRNOP=5
Q
SET ;SET IF VALID PROCEDURE
I $G(LRNP),'$D(LRNPX(CPT))#2 Q
I '$D(^TMP("LRMOD",$J,CPT)) S ^(CPT)="" D
. N X
. S X=$$CODM^ICPTCOD(CPT,"^TMP(""LRMOD"",$J,CPT)",,)
;LRCNT=CPT POSITION IN TABLE LRXCPT
;LRCCT=LOCATION POSITION IN TABLE LRXCPT
I $G(LRXCPT(CPT)) S LRCNT=LRXCPT(CPT)
I '$G(LRXCPT(CPT)) S (LRCNT,LRCCT)=$G(LRCCT)+1,LRXCPT(CPT)=LRCCT
;S LRCNT=LRXCPT(CPT)
I '$G(LRNP) S LRXCPT(CPT,"P",LRCNT)=1+$G(LRXCPT(CPT,"P",LRCNT))
I $G(LRNP) D
. S LRXCPT(CPT,"P",LRCNT)=($G(LRNPX(CPT))-1)
. S LRNPX(CPT)=(LRNPX(CPT)-1)
S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"ENC PROVIDER")=LRPRO
S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"PROCEDURE")=CPT
I $G(LRNP) D
. Q:$G(LRXCPT(CPT,"P",LRCNT))>0
. S LRXCPT(CPT,"P",LRCNT)=1
. S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"DELETE")=1
S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"QTY")=$S($G(LRXCPT(CPT,"P",LRCNT)):LRXCPT(CPT,"P",LRCNT),1:1)
Q:$G(LRNP)
I $G(LRXCPT(CPT,"P",LRCNT))>1,$D(^TMP("LRMOD",$J,CPT,59))>0 D
. S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"MODIFIERS",59)=""
;If Manual CPT coding always set modifier to 59 to force PCE to add CPT code.
I $G(LRES) S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"MODIFIERS",59)=""
I $G(LRAA) D
.S MOD=$$GMOD^LRBEBA2(LRAA,CPT)
.I MOD'="" S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"MODIFIERS",MOD)="" K MOD
S LRXTST(LRTST)=LRNLTN_U_LRTSTP
I $G(LRAA),$P($G(^LRO(68,LRAA,0)),U,2)="MI" D
. Q:('$D(^TMP("LRPXAPI",$J,"PROCEDURE")))
. ;Get PCE data via Billing Aware API for Microbiology
. D MICRO1^LRBEBA3(LRCDT,LRSN,LRTST,LRCNT)
. I '$D(^TMP("LRPXAPI",$J,"PROCEDURE")) S ^LRO(69,"AA",LRCEX,LROA)=9
Q
SEND ;BUILD ENCOUNTER INFO Called from LRCAPPNP
I '$G(LRESCPT) Q:$G(^LRO(69,"AA",$G(LRCEX),$G(LROA)))
N LRENCDT ; Check for incorrect time
S LRENCDT=$J(LREDT,7,4),LRENCDT(1)=$P(LRENCDT,".",2)
S:'LRENCDT(1) LRENCDT(1)=1201
I $E(LRENCDT(1),3,4)>59 S LRENCDT(1)=$E(LRENCDT(1),1,2)_59
I $E(LRENCDT(1),1,2)>23 S LRENCDT(1)=23_$E(LRENCDT(1),3,4)
S $P(LRENCDT,".",2)=LRENCDT(1)
S ^TMP("LRPXAPI",$J,"ENCOUNTER",1,"DSS ID")=LRDSSID
S ^TMP("LRPXAPI",$J,"ENCOUNTER",1,"ENC D/T")=LRENCDT
S ^TMP("LRPXAPI",$J,"ENCOUNTER",1,"HOS LOC")=LRDSSLOC
S:LRNINS ^TMP("LRPXAPI",$J,"ENCOUNTER",1,"INSTITUTION")=LRNINS
S ^TMP("LRPXAPI",$J,"ENCOUNTER",1,"PATIENT")=DFN
S ^TMP("LRPXAPI",$J,"ENCOUNTER",1,"SERVICE CATEGORY")="X"
S ^TMP("LRPXAPI",$J,"ENCOUNTER",1,"ENCOUNTER TYPE")="A"
PCE ;SEND DATA TO PCE
N LRLNOW,LRAAX
K LRVSITN S (LROK,LRVSITN)=""
I $G(LRAA) S LRAAX=$P($G(^LRO(68,LRAA,0)),U,2)
I ($G(LRAAX)="CH") S LROK=1,LRVSITN=$G(LRBEVSIT)
I ($G(LRAAX)="MI") D
. Q:('$D(^TMP("LRPXAPI",$J,"PROCEDURE")))
. ;Get PCE data via Billing Aware API for Microbiology
. D MICRO2^LRBEBA3(LRCDT,LRSN)
. S LROK=$$DATA2PCE^PXAPI("^TMP(""LRPXAPI"",$J)",LRPKG,"LAB DATA",.LRVSITN,$G(LRDUZ))
. K ^TMP("LRBEDX",$J)
I (";AU;BB;CY;EM;SP;"[(";"_$G(LRSS)_";"))!(";AU;BB;CY;EM;SP;"[(";"_$G(LRAAX)_";")) D
.S LROK=$$DATA2PCE^PXAPI("^TMP(""LRPXAPI"",$J)",LRPKG,"LAB DATA",.LRVSITN,$G(LRDUZ))
I $G(^XTMP("LRPCELOG",0)) D ;Used to log/debug contents of ^TMP("LRPXAPI")
. F S LRLNOW=$$NOW^XLFDT Q:'$D(^XTMP("LRPCELOG",1,LRLNOW)) H 1
. S ^XTMP("LRPCELOG",1,LRLNOW,0)=U_$G(LRBEID)_U_$G(LRVSITN)
. M ^XTMP("LRPCELOG",1,LRLNOW)=^TMP("LRPXAPI",$J)
W:$G(LRDBUG) !,"LROK = ",LROK,!,$G(LRVSITN)
Q:$G(LRESCPT)
I '$G(LRNP),$D(^LRO(69,LRCDT,1,LRSN,"PCE")) S:LRVSITN ^("PCE")=$E(^("PCE")_$S(LROK>0:LRVSITN,1:LROK)_";",1,30) D
. I LROK<1,$D(^LRO(69,"AA",LRCEX,LROA)) S ^(LROA)=LROK
EN7 N LRFND,LRPCE
Q:'$G(LRNP)!(LROK<1)!('LRVSITN)
S LRPCE=$G(^LRO(69,LRCDT,1,LRSN,"PCE"))
I '$F(LRPCE,LRVSITN_"-CPT CANC") D
. S LRFND=$F(LRPCE,LRVSITN) Q:'LRFND
. I LRFND S LRPCE=$E(LRPCE,1,(LRFND-1))_"-CPT CANC"_$E(LRPCE,LRFND,$L(LRPCE))
. S ^LRO(69,LRCDT,1,LRSN,"PCE")=$E(LRPCE,1,30)
CHK ;Determine if any CPT code remain on the encounter, then delete encounter if false
K ^TMP("PXKENC",$J)
D ENCEVENT^PXKENC(LRVSITN,1)
I $O(^TMP("PXKENC",$J,LRVSITN,"CPT",0)) K ^TMP("PXKENC",$J) Q
; S LROK=$$DELVFILE^PXAPI("ALL",$G(LRVSITN),LRPKG,"LAB DATA",0,0,0)
S:$$MODEXIST^BLRUTIL4("PX") LROK=$$DELVFILE^PXAPI("ALL",$G(LRVSITN),LRPKG,"LAB DATA",0,0,0) ; IHS/MSC/MKK - LR*5.2*1031
S:'$$MODEXIST^BLRUTIL4("PX") LROK=0 ; IHS/MSC/MKK - LR*5.2*1031
K ^TMP("PXKENC",$J) Q:LROK<1
N LRSN
S LRSN=0
F S LRSN=$O(^LRO(69,"C",LRCE,LRCDT,LRSN)) Q:LRSN<1 D DELCAN
Q
DELCAN ;Mark PCE Encounter number as '-CPT CANC-ENC DEL'
;LRVSITN = Encounter IEN
S LRPCE=$G(^LRO(69,LRCDT,1,LRSN,"PCE")) Q:'$L(LRPCE) D
. Q:'$G(LRVSITN)
. I $F(LRPCE,LRVSITN_"-CPT CANC-ENC DEL;") Q
. S LRFND=$F($G(LRPCE),LRVSITN_"-CPT CANC") I LRFND D Q
. . S LRPCE=$E(LRPCE,1,(LRFND-1))_"-ENC DEL"_$E(LRPCE,LRFND,$L(LRPCE))
. . S ^LRO(69,LRCDT,1,LRSN,"PCE")=$E(LRPCE,1,30)
. S LRFND=$F($G(LRPCE),LRVSITN) I LRFND D
. . S LRPCE=$E(LRPCE,1,(LRFND-1))_"-CPT CANC-ENC DEL"_$E(LRPCE,LRFND,$L(LRPCE))
. . S ^LRO(69,LRCDT,1,LRSN,"PCE")=$E(LRPCE,1,30)
Q
TEST ;
S:'$G(LRDPRAC) LRDPRAC=DUZ
S LRDLOC=+$G(^LAB(69.9,1,.8))
S:'$G(LRPKG) LRPKG=26 S:'$G(LRDBUG) LRDBUG=1 S LRVSIT=2
S:'$G(LRCDT) LRCDT=DT S:'$G(LRSN) LRSN=1 S NODE=^LRO(69,LRCDT,1,LRSN,0)
S NODE(1)=^LRO(69,LRCDT,1,LRSN,1)
S DFN=$P(^LR(+NODE,0),U,3)
D EN3
Q
LRCAPPH1 ;DALOI/SED/RKS/KLL - PROCESS PHLEBOTOMY WORKLOAD DATA CONT ;07/30/04
+1 ;;5.2;LAB SERVICE;**1002,1031**;NOV 1, 1997
+2 ;
+3 ;;VA LR Patche(s): 127,136,138,158,263,264,274,291,359,308
+4 ;
+5 ; Reference to ^SC( Supported by DBIA #1482
+6 ; Reference to $$CODM^ICPTCOD Supported by DBIA #1995-A
+7 ; Reference to $$CPT^ICPTCOD Supported by DBIA #1995-A
+8 ; Reference to $$DATA2PCE^PXAPI Supported by DBIA #1889-A
+9 ; Reference to $$DELVFILE^PXAPI Supported by DBIA #1889-B
+10 ; Reference to ENCEVENT^PXKENC Supported by DBIA #1889-F
+11 ; Reference to $$NOW^XLFDT Supported by Reference #10103
+12 ; Reference to $$GET^XUA4A72 Supported by Reference #1625
EN3 ;LREDT = PATIENT ENCOUNTER DATE
+1 NEW LREDT,LRNOP,LRBEID
+2 KILL ^TMP("LRPXAPI",$JOB),LRXTST,LRVSITN,LRXCPT
NP ;Not perform entry
+1 IF $DATA(^LRO(69,"AA",LRCEX,LROA))
SET ^(LROA)=""
+2 SET LREDT=$PIECE($GET(^LRO(69,LRCDT,1,LRSN,1)),U)
+3 NEW LRDUZ
+4 IF +LREDT'>0!('$DATA(^LR(+NODE,0))#2)
QUIT
+5 IF $GET(LRDBUG)
SET LREDT=$$NOW^XLFDT
+6 SET EDATE=$PIECE(LREDT,".")
+7 IF '$PIECE(LREDT,".",2)
SET $PIECE(LREDT,".",2)="1201"
+8 ;CHECK
SET LOC=+$PIECE(NODE,U,9)
SET LRNINS=$PIECE(NODE(1),U,8)
SET LRPRO=+$PIECE(NODE,U,6)
+9 SET LRDUZ=+$PIECE(NODE,U,2)
+10 SET LRNINS=$SELECT($PIECE($GET(^SC(LOC,0)),U,4):$PIECE(^(0),U,4),$GET(LRNINS):LRNINS,1:LRINS)
+11 SET LRPRO=$SELECT($$GET^XUA4A72(LRPRO,EDATE)>0:LRPRO,1:LRDPRAC)
+12 IF $SELECT('$GET(LOC):1,"CMZ"'[$PIECE($GET(^SC(LOC,0)),U,3):1,1:0)
QUIT
+13 IF $SELECT('DFN:1,'LOC:1,1:0)
IF $DATA(^LRO(69,"AA",LRCEX,LROA))
SET ^(LROA)=1
SET LRNOP=1
QUIT
+14 IF 'LRNINS
IF $DATA(^LRO(69,"AA",LRCEX,LROA))
SET ^(LROA)=2
SET LRNOP=2
QUIT
+15 IF 'LRPRO
IF $DATA(^LRO(69,"AA",LRCEX,LROA))
SET ^(LROA)=3
SET LRNOP=3
QUIT
+16 IF $GET(LRNP)
QUIT
EN5 ;GET THE CPT CODES FOR THE TESTS
+1 IF LRCDT
IF LRSN
IF $DATA(^LRO(69,LRCDT,1,LRSN,2,0))
Begin DoDot:1
+2 SET (LRTST,LRCNT,LRXAA)=0
KILL LRXTST
SET LRXTST=""
+3 FOR
SET LRTST=$ORDER(^LRO(69,LRCDT,1,LRSN,2,LRTST))
IF +LRTST'>0
QUIT
Begin DoDot:2
+4 IF '($DATA(^LRO(69,LRCDT,1,LRSN,2,LRTST,0))#2)
QUIT
SET LREN5=^(0)
+5 ;Don't send cancel/already sent codes
IF $SELECT($PIECE(LREN5,U,12)
QUIT
+6 SET LRTSTP=+$PIECE(LREN5,U)
SET LRAA=+$PIECE(LREN5,U,4)
IF $SELECT('LRTSTP
QUIT
+7 ;Turn off old style PCE reporting for CH subscripts.
+8 ;Data passed via Billing Aware API
+9 IF $PIECE($GET(^LRO(68,LRAA,0)),U,2)="CH"
QUIT
+10 SET LRBEID=$PIECE(^LRO(69,LRCDT,1,LRSN,2,LRTST,.3),U)
+11 IF '$GET(LRDBUG)
IF $PIECE($GET(^LRO(68,LRAA,0)),U,2)'="MI"
SET $PIECE(^LRO(69,LRCDT,1,LRSN,2,LRTST,0),U,12)=1
+12 IF 'LRXAA
SET LRXAA=LRAA
DO LOC
+13 IF '$GET(LRDSSID)
QUIT
+14 IF LRXAA'=LRAA
IF $DATA(^TMP("LRPXAPI",$JOB,"PROCEDURE"))
DO SEND
KILL ^TMP("LRPXAPI",$JOB)
SET LRXAA=LRAA
DO LOC
IF '$GET(LRDSSID)
QUIT
DO EN6
QUIT
+15 DO EN6
End DoDot:2
End DoDot:1
+16 IF $DATA(^TMP("LRPXAPI",$JOB,"PROCEDURE"))
IF '$GET(^LRO(69,"AA",LRCEX,LROA))
DO SEND
END IF $GET(LRDBUG)
QUIT
END0 KILL ^TMP("LRPXAPI",$JOB),LRINA,LRREL,LRNLT,CPT,LRPRO,LRICPT,EDATE,LRTST
+1 KILL I,LOC,LRI,LRCNT,LRSTP,LRNINS,LROK,LRAA,LRXAA,LRDSSID,LREN5,LRXTST
+2 KILL LRNLTN,LRIDT,LRXTSTU,LRXCPT
+3 QUIT
EN6 ;Called from LRCAPPNP
+1 ;Turn off old style PCE reporting for CH subscripts.
+2 ;Data passed via Billing Aware API
+3 IF $GET(LRAA)
IF $PIECE($GET(^LRO(68,LRAA,0)),U,2)="CH"
QUIT
+4 IF '$DATA(^LRO(69,LRCDT,1,LRSN,"PCE"))
SET ^("PCE")=""
+5 NEW LRFLG
+6 SET LRNLT=+$PIECE($GET(^LAB(60,LRTSTP,64)),U)
SET LRICPT=0
+7 IF +LRNLT'>0
QUIT
+8 IF '$DATA(^LAM("AD",LRNLT,"CPT"))
QUIT
SET LRNLTN=$PIECE(^LAM(LRNLT,0),U,2)
+9 IF 'LRNLTN
QUIT
+10 FOR
SET LRICPT=$ORDER(^LAM("AD",LRNLT,"CPT",LRICPT))
IF +LRICPT'>0
QUIT
SET CPT=+$PIECE($GET(^LAM(LRNLT,4,LRICPT,0)),U)
IF CPT
IF $PIECE(^(0),U,2)="CPT"
Begin DoDot:1
+11 ;CPT must be active in file #64 before edit can continue against #81
+12 SET LRFLG=1
+13 SET LRREL=$PIECE(^LAM(LRNLT,4,LRICPT,0),U,3)
SET LRINA=$PIECE(^(0),U,4)
+14 IF LRREL&(LRINA="")
SET LRFLG=0
+15 IF LRFLG
IF EDATE>(LRREL-1)&((EDATE<LRINA)!(LRINA=""))
SET LRFLG=0
+16 IF '$GET(CPT)!(LRFLG)
QUIT
+17 IF '$PIECE($$CPT^ICPTCOD(CPT,$PIECE(LREDT,"."),,),U,7)
IF $DATA(^LRO(69,"AA",LRCEX,LROA))
SET ^(LROA)=4
QUIT
+18 SET LRREL=$PIECE(^LAM(LRNLT,4,LRICPT,0),U,3)
SET LRINA=$PIECE(^(0),U,4)
+19 IF LRREL&(LRINA="")
DO SET
QUIT
+20 IF EDATE>(LRREL-1)&((EDATE<LRINA)!(LRINA=""))
DO SET
End DoDot:1
+21 QUIT
LOC ;Called from LRCAPPNP
+1 IF '$GET(LRAA)
SET LRNOP=4
QUIT
+2 SET LRDSSLOC=$SELECT($GET(^LRO(68,+LRAA,.8)):+^(.8),1:LRDLOC)
+3 IF 'LRDSSLOC
IF $DATA(^LRO(69,"AA",LRCEX,LROA))
SET ^(LROA)=4
SET LRNOP=4
QUIT
+4 SET LRDSSID=+$PIECE($GET(^SC(LRDSSLOC,0)),U,7)
+5 IF 'LRDSSID
IF $DATA(^LRO(69,"AA",LRCEX,LROA))
SET ^(LROA)=5
SET LRNOP=5
+6 QUIT
SET ;SET IF VALID PROCEDURE
+1 IF $GET(LRNP)
IF '$DATA(LRNPX(CPT))#2
QUIT
+2 IF '$DATA(^TMP("LRMOD",$JOB,CPT))
SET ^(CPT)=""
Begin DoDot:1
+3 NEW X
+4 SET X=$$CODM^ICPTCOD(CPT,"^TMP(""LRMOD"",$J,CPT)",,)
End DoDot:1
+5 ;LRCNT=CPT POSITION IN TABLE LRXCPT
+6 ;LRCCT=LOCATION POSITION IN TABLE LRXCPT
+7 IF $GET(LRXCPT(CPT))
SET LRCNT=LRXCPT(CPT)
+8 IF '$GET(LRXCPT(CPT))
SET (LRCNT,LRCCT)=$GET(LRCCT)+1
SET LRXCPT(CPT)=LRCCT
+9 ;S LRCNT=LRXCPT(CPT)
+10 IF '$GET(LRNP)
SET LRXCPT(CPT,"P",LRCNT)=1+$GET(LRXCPT(CPT,"P",LRCNT))
+11 IF $GET(LRNP)
Begin DoDot:1
+12 SET LRXCPT(CPT,"P",LRCNT)=($GET(LRNPX(CPT))-1)
+13 SET LRNPX(CPT)=(LRNPX(CPT)-1)
End DoDot:1
+14 SET ^TMP("LRPXAPI",$JOB,"PROCEDURE",LRCNT,"ENC PROVIDER")=LRPRO
+15 SET ^TMP("LRPXAPI",$JOB,"PROCEDURE",LRCNT,"PROCEDURE")=CPT
+16 IF $GET(LRNP)
Begin DoDot:1
+17 IF $GET(LRXCPT(CPT,"P",LRCNT))>0
QUIT
+18 SET LRXCPT(CPT,"P",LRCNT)=1
+19 SET ^TMP("LRPXAPI",$JOB,"PROCEDURE",LRCNT,"DELETE")=1
End DoDot:1
+20 SET ^TMP("LRPXAPI",$JOB,"PROCEDURE",LRCNT,"QTY")=$SELECT($GET(LRXCPT(CPT,"P",LRCNT)):LRXCPT(CPT,"P",LRCNT),1:1)
+21 IF $GET(LRNP)
QUIT
+22 IF $GET(LRXCPT(CPT,"P",LRCNT))>1
IF $DATA(^TMP("LRMOD",$JOB,CPT,59))>0
Begin DoDot:1
+23 SET ^TMP("LRPXAPI",$JOB,"PROCEDURE",LRCNT,"MODIFIERS",59)=""
End DoDot:1
+24 ;If Manual CPT coding always set modifier to 59 to force PCE to add CPT code.
+25 IF $GET(LRES)
SET ^TMP("LRPXAPI",$JOB,"PROCEDURE",LRCNT,"MODIFIERS",59)=""
+26 IF $GET(LRAA)
Begin DoDot:1
+27 SET MOD=$$GMOD^LRBEBA2(LRAA,CPT)
+28 IF MOD'=""
SET ^TMP("LRPXAPI",$JOB,"PROCEDURE",LRCNT,"MODIFIERS",MOD)=""
KILL MOD
End DoDot:1
+29 SET LRXTST(LRTST)=LRNLTN_U_LRTSTP
+30 IF $GET(LRAA)
IF $PIECE($GET(^LRO(68,LRAA,0)),U,2)="MI"
Begin DoDot:1
+31 IF ('$DATA(^TMP("LRPXAPI",$JOB,"PROCEDURE")))
QUIT
+32 ;Get PCE data via Billing Aware API for Microbiology
+33 DO MICRO1^LRBEBA3(LRCDT,LRSN,LRTST,LRCNT)
+34 IF '$DATA(^TMP("LRPXAPI",$JOB,"PROCEDURE"))
SET ^LRO(69,"AA",LRCEX,LROA)=9
End DoDot:1
+35 QUIT
SEND ;BUILD ENCOUNTER INFO Called from LRCAPPNP
+1 IF '$GET(LRESCPT)
IF $GET(^LRO(69,"AA",$GET(LRCEX),$GET(LROA)))
QUIT
+2 ; Check for incorrect time
NEW LRENCDT
+3 SET LRENCDT=$JUSTIFY(LREDT,7,4)
SET LRENCDT(1)=$PIECE(LRENCDT,".",2)
+4 IF 'LRENCDT(1)
SET LRENCDT(1)=1201
+5 IF $EXTRACT(LRENCDT(1),3,4)>59
SET LRENCDT(1)=$EXTRACT(LRENCDT(1),1,2)_59
+6 IF $EXTRACT(LRENCDT(1),1,2)>23
SET LRENCDT(1)=23_$EXTRACT(LRENCDT(1),3,4)
+7 SET $PIECE(LRENCDT,".",2)=LRENCDT(1)
+8 SET ^TMP("LRPXAPI",$JOB,"ENCOUNTER",1,"DSS ID")=LRDSSID
+9 SET ^TMP("LRPXAPI",$JOB,"ENCOUNTER",1,"ENC D/T")=LRENCDT
+10 SET ^TMP("LRPXAPI",$JOB,"ENCOUNTER",1,"HOS LOC")=LRDSSLOC
+11 IF LRNINS
SET ^TMP("LRPXAPI",$JOB,"ENCOUNTER",1,"INSTITUTION")=LRNINS
+12 SET ^TMP("LRPXAPI",$JOB,"ENCOUNTER",1,"PATIENT")=DFN
+13 SET ^TMP("LRPXAPI",$JOB,"ENCOUNTER",1,"SERVICE CATEGORY")="X"
+14 SET ^TMP("LRPXAPI",$JOB,"ENCOUNTER",1,"ENCOUNTER TYPE")="A"
PCE ;SEND DATA TO PCE
+1 NEW LRLNOW,LRAAX
+2 KILL LRVSITN
SET (LROK,LRVSITN)=""
+3 IF $GET(LRAA)
SET LRAAX=$PIECE($GET(^LRO(68,LRAA,0)),U,2)
+4 IF ($GET(LRAAX)="CH")
SET LROK=1
SET LRVSITN=$GET(LRBEVSIT)
+5 IF ($GET(LRAAX)="MI")
Begin DoDot:1
+6 IF ('$DATA(^TMP("LRPXAPI",$JOB,"PROCEDURE")))
QUIT
+7 ;Get PCE data via Billing Aware API for Microbiology
+8 DO MICRO2^LRBEBA3(LRCDT,LRSN)
+9 SET LROK=$$DATA2PCE^PXAPI("^TMP(""LRPXAPI"",$J)",LRPKG,"LAB DATA",.LRVSITN,$GET(LRDUZ))
+10 KILL ^TMP("LRBEDX",$JOB)
End DoDot:1
+11 IF (";AU;BB;CY;EM;SP;"[(";"_$GET(LRSS)_";"))!(";AU;BB;CY;EM;SP;"[(";"_$GET(LRAAX)_";"))
Begin DoDot:1
+12 SET LROK=$$DATA2PCE^PXAPI("^TMP(""LRPXAPI"",$J)",LRPKG,"LAB DATA",.LRVSITN,$GET(LRDUZ))
End DoDot:1
+13 ;Used to log/debug contents of ^TMP("LRPXAPI")
IF $GET(^XTMP("LRPCELOG",0))
Begin DoDot:1
+14 FOR
SET LRLNOW=$$NOW^XLFDT
IF '$DATA(^XTMP("LRPCELOG",1,LRLNOW))
QUIT
HANG 1
+15 SET ^XTMP("LRPCELOG",1,LRLNOW,0)=U_$GET(LRBEID)_U_$GET(LRVSITN)
+16 MERGE ^XTMP("LRPCELOG",1,LRLNOW)=^TMP("LRPXAPI",$JOB)
End DoDot:1
+17 IF $GET(LRDBUG)
WRITE !,"LROK = ",LROK,!,$GET(LRVSITN)
+18 IF $GET(LRESCPT)
QUIT
+19 IF '$GET(LRNP)
IF $DATA(^LRO(69,LRCDT,1,LRSN,"PCE"))
IF LRVSITN
SET ^("PCE")=$EXTRACT(^("PCE")_$SELECT(LROK>0:LRVSITN,1:LROK)_";",1,30)
Begin DoDot:1
+20 IF LROK<1
IF $DATA(^LRO(69,"AA",LRCEX,LROA))
SET ^(LROA)=LROK
End DoDot:1
EN7 NEW LRFND,LRPCE
+1 IF '$GET(LRNP)!(LROK<1)!('LRVSITN)
QUIT
+2 SET LRPCE=$GET(^LRO(69,LRCDT,1,LRSN,"PCE"))
+3 IF '$FIND(LRPCE,LRVSITN_"-CPT CANC")
Begin DoDot:1
+4 SET LRFND=$FIND(LRPCE,LRVSITN)
IF 'LRFND
QUIT
+5 IF LRFND
SET LRPCE=$EXTRACT(LRPCE,1,(LRFND-1))_"-CPT CANC"_$EXTRACT(LRPCE,LRFND,$LENGTH(LRPCE))
+6 SET ^LRO(69,LRCDT,1,LRSN,"PCE")=$EXTRACT(LRPCE,1,30)
End DoDot:1
CHK ;Determine if any CPT code remain on the encounter, then delete encounter if false
+1 KILL ^TMP("PXKENC",$JOB)
+2 DO ENCEVENT^PXKENC(LRVSITN,1)
+3 IF $ORDER(^TMP("PXKENC",$JOB,LRVSITN,"CPT",0))
KILL ^TMP("PXKENC",$JOB)
QUIT
+4 ; S LROK=$$DELVFILE^PXAPI("ALL",$G(LRVSITN),LRPKG,"LAB DATA",0,0,0)
+5 ; IHS/MSC/MKK - LR*5.2*1031
IF $$MODEXIST^BLRUTIL4("PX")
SET LROK=$$DELVFILE^PXAPI("ALL",$GET(LRVSITN),LRPKG,"LAB DATA",0,0,0)
+6 ; IHS/MSC/MKK - LR*5.2*1031
IF '$$MODEXIST^BLRUTIL4("PX")
SET LROK=0
+7 KILL ^TMP("PXKENC",$JOB)
IF LROK<1
QUIT
+8 NEW LRSN
+9 SET LRSN=0
+10 FOR
SET LRSN=$ORDER(^LRO(69,"C",LRCE,LRCDT,LRSN))
IF LRSN<1
QUIT
DO DELCAN
+11 QUIT
DELCAN ;Mark PCE Encounter number as '-CPT CANC-ENC DEL'
+1 ;LRVSITN = Encounter IEN
+2 SET LRPCE=$GET(^LRO(69,LRCDT,1,LRSN,"PCE"))
IF '$LENGTH(LRPCE)
QUIT
Begin DoDot:1
+3 IF '$GET(LRVSITN)
QUIT
+4 IF $FIND(LRPCE,LRVSITN_"-CPT CANC-ENC DEL;")
QUIT
+5 SET LRFND=$FIND($GET(LRPCE),LRVSITN_"-CPT CANC")
IF LRFND
Begin DoDot:2
+6 SET LRPCE=$EXTRACT(LRPCE,1,(LRFND-1))_"-ENC DEL"_$EXTRACT(LRPCE,LRFND,$LENGTH(LRPCE))
+7 SET ^LRO(69,LRCDT,1,LRSN,"PCE")=$EXTRACT(LRPCE,1,30)
End DoDot:2
QUIT
+8 SET LRFND=$FIND($GET(LRPCE),LRVSITN)
IF LRFND
Begin DoDot:2
+9 SET LRPCE=$EXTRACT(LRPCE,1,(LRFND-1))_"-CPT CANC-ENC DEL"_$EXTRACT(LRPCE,LRFND,$LENGTH(LRPCE))
+10 SET ^LRO(69,LRCDT,1,LRSN,"PCE")=$EXTRACT(LRPCE,1,30)
End DoDot:2
End DoDot:1
+11 QUIT
TEST ;
+1 IF '$GET(LRDPRAC)
SET LRDPRAC=DUZ
+2 SET LRDLOC=+$GET(^LAB(69.9,1,.8))
+3 IF '$GET(LRPKG)
SET LRPKG=26
IF '$GET(LRDBUG)
SET LRDBUG=1
SET LRVSIT=2
+4 IF '$GET(LRCDT)
SET LRCDT=DT
IF '$GET(LRSN)
SET LRSN=1
SET NODE=^LRO(69,LRCDT,1,LRSN,0)
+5 SET NODE(1)=^LRO(69,LRCDT,1,LRSN,1)
+6 SET DFN=$PIECE(^LR(+NODE,0),U,3)
+7 DO EN3
+8 QUIT
