- LRCAPPH1 ;DALOI/SED/RKS/KLL - PROCESS PHLEBOTOMY WORKLOAD DATA CONT ;07/30/04
- ;;5.2;LAB SERVICE;**127,136,138,158,263,264,274,291,359,308**;Sep 27, 1994
- ; 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)
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPPH1 9022 printed Feb 18, 2025@23:39:03 Page 2
- LRCAPPH1 ;DALOI/SED/RKS/KLL - PROCESS PHLEBOTOMY WORKLOAD DATA CONT ;07/30/04
- +1 ;;5.2;LAB SERVICE;**127,136,138,158,263,264,274,291,359,308**;Sep 27, 1994
- +2 ; Reference to ^SC( Supported by DBIA #1482
- +3 ; Reference to $$CODM^ICPTCOD Supported by DBIA #1995-A
- +4 ; Reference to $$CPT^ICPTCOD Supported by DBIA #1995-A
- +5 ; Reference to $$DATA2PCE^PXAPI Supported by DBIA #1889-A
- +6 ; Reference to $$DELVFILE^PXAPI Supported by DBIA #1889-B
- +7 ; Reference to ENCEVENT^PXKENC Supported by DBIA #1889-F
- +8 ; Reference to $$NOW^XLFDT Supported by Reference #10103
- +9 ; 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 SET LROK=$$DELVFILE^PXAPI("ALL",$GET(LRVSITN),LRPKG,"LAB DATA",0,0,0)
- +5 KILL ^TMP("PXKENC",$JOB)
- if LROK<1
- QUIT
- +6 NEW LRSN
- +7 SET LRSN=0
- +8 FOR
- SET LRSN=$ORDER(^LRO(69,"C",LRCE,LRCDT,LRSN))
- if LRSN<1
- QUIT
- DO DELCAN
- +9 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