PXCOMPACTEVAL ;ALB/BPA,CMC - COMPACT Act evaluation / protocol entry routine;12/26/2023@10:58am
;;1.0;PCE PATIENT CARE ENCOUNTER;**240**;Aug 12, 1996;Build 55
; *240* COMPACT Act evaluation / protocol entry routine
; Reference to $$ELIG^DGCOMPACTELIG in ICR #7462
Q
;
EVAL ; load an TMP global with foreground $J value to simulate a pre-existing TMP global from protocol
N PURGEDT,XTMPSUB,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
S XTMPSUB="PXCMP"_$J_$$NOW^XLFDT
S PURGEDT=DT_".1159"
S XTMPSUB(0)=PURGEDT_U_DT_U_"COMPACT Act auto adjudication"
M ^XTMP(XTMPSUB,0)=^TMP("PXKCO",$J)
S ZTRTN="EVALQUE^PXCOMPACTEVAL"
S ZTDESC="COMPACT Act auto adjudication",ZTIO="",ZTDTH=$H
S ZTSAVE("XTMPSUB")=""
D ^%ZTLOAD
Q
;
EVALQUE ; RUNS IN BACKGROUND
N CPTBEFOR,CPTBEFORVAL,CPTCODE,CPTVAL,DFN,DXCOD1,DXCOD2,DXCOD3,DXCOD4,HFCHECK,HFBEFOR,HFBEFORVAL
N HFCODE,HFVAL,POVBEFOR,POVBEFORVAL,POVCODE,POVVAL,PXADMIN,PXCOD1,PXCOD2,PXEOCNUM,PXEOCSEQ,PXFOLLOW
N PXNEWEOC,PXOPNCLOSE,PXHFFOLLOW,PXHFINITIAL,PXHFNONACUTE,PXVCPTIEN,PXVHFIEN,PXVPOVIEN,PXSTDT,PXVSTIEN
N PXUPDATEVST,PXUPDTEOC
S (CPTBEFOR,CPTBEFORVAL,CPTCODE,CPTVAL,DFN,DXCOD1,DXCOD2,DXCOD3,DXCOD4,HFCHECK,HFBEFOR,HFBEFORVAL)=""
S (HFCODE,HFVAL,POVBEFOR,POVBEFORVAL,POVCODE,POVVAL,PXADMIN,PXCOD1,PXCOD2,PXVCPTIEN,PXVHFIEN,PXVPOVIEN)=""
S (PXSTDT,PXVSTIEN)=""
S (PXHFINITIAL,PXHFFOLLOW,PXHFNONACUTE)=0
S (PXFOLLOW,PXNEWEOC,PXOPNCLOSE,PXUPDATEVST,PXUPDTEOC)=0
;
; Set the VISIT IEN value
S PXVSTIEN=$O(^XTMP(XTMPSUB,0,""))
; Get the DFN and start date
I PXVSTIEN'="" D
. S DFN=$P(^XTMP(XTMPSUB,0,PXVSTIEN,"VST",PXVSTIEN,0,"AFTER"),"^",5)
. S PXSTDT=$P($P(^XTMP(XTMPSUB,0,PXVSTIEN,"VST",PXVSTIEN,0,"AFTER"),"^"),".")
;
I DFN="" K ^XTMP(XTMPSUB) Q
; Check for an open EoC
S PXOPNCLOSE=$$ASC^PXCOMPACT(DFN)
;
; Check for existing episode of care number and current episode of care sequence number
S PXEOCNUM=$$GETEOC^PXCOMPACT(DFN),PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
;
; Gather rules engine Health Factor code
S PXHFINITIAL=$O(^AUTTHF("B","VA-COMPACT ACT SUICIDE TX ENCOUNTER INITIAL",""))
S PXHFFOLLOW=$O(^AUTTHF("B","VA-COMPACT ACT SUICIDE TX ENCOUNTER FOLLOW UP",""))
S PXHFNONACUTE=$O(^AUTTHF("B","VA-COMPACT ACT SUICIDE RISK NONACUTE",""))
;
; Add calls here to validate DX codes for rules engine
S DXCOD1=$P($$CODEN^ICDEX("T14.91XA",80),"~",1)
S DXCOD2=$P($$CODEN^ICDEX("R45.851",80),"~",1)
S DXCOD3=$P($$CODEN^ICDEX("T14.91XD",80),"~",1) ;Added for follow up
S DXCOD4=$P($$CODEN^ICDEX("T14.91XS",80),"~",1) ;Added for follow up
; Add calls here to validate PX codes for rules engine
S PXCOD1=$P($$STATCHK^ICPTAPIU(90839,1),"^",2)
S PXCOD2=$P($$STATCHK^ICPTAPIU("T2034",1),"^",2)
;
; Set up the default start date to now if PXSTDT is not set
I PXSTDT="" S PXSTDT=DT
;
; Gather Procedure Codes
F S PXVCPTIEN=$O(^XTMP(XTMPSUB,0,PXVSTIEN,"CPT",PXVCPTIEN)) Q:PXVCPTIEN="" D
. I $D(^XTMP(XTMPSUB,0,PXVSTIEN,"CPT",PXVCPTIEN,0,"AFTER")) D
. . S CPTVAL=$P(^XTMP(XTMPSUB,0,PXVSTIEN,"CPT",PXVCPTIEN,0,"AFTER"),"^") I CPTVAL'="" S CPTCODE(CPTVAL)=""
. . S CPTBEFORVAL=$P(^XTMP(XTMPSUB,0,PXVSTIEN,"CPT",PXVCPTIEN,0,"BEFORE"),"^")
. ; Evaluate the before value to see if if differs from the after value
. I CPTBEFORVAL'="",CPTBEFORVAL'=$G(CPTVAL) S CPTBEFOR(CPTBEFORVAL)=PXVCPTIEN_"^"_CPTVAL,PXUPDATEVST=1
;
; Gather Diagnosis Codes
F S PXVPOVIEN=$O(^XTMP(XTMPSUB,0,PXVSTIEN,"POV",PXVPOVIEN)) Q:PXVPOVIEN="" D
. I $D(^XTMP(XTMPSUB,0,PXVSTIEN,"POV",PXVPOVIEN,0,"AFTER")) D
. . S POVVAL=$P(^XTMP(XTMPSUB,0,PXVSTIEN,"POV",PXVPOVIEN,0,"AFTER"),"^") I POVVAL'="" S POVCODE(POVVAL)=""
. . S POVBEFORVAL=$P(^XTMP(XTMPSUB,0,PXVSTIEN,"POV",PXVPOVIEN,0,"BEFORE"),"^")
. ; Evaluate the before value to see if if differs from the after value
. I POVBEFORVAL'="",POVBEFORVAL'=$G(POVVAL) S POVBEFOR(POVBEFORVAL)=PXVPOVIEN_"^"_POVVAL,PXUPDATEVST=1
;
; Gather Health Factor information
F S PXVHFIEN=$O(^XTMP(XTMPSUB,0,PXVSTIEN,"HF",PXVHFIEN)) Q:PXVHFIEN="" D
. I $D(^XTMP(XTMPSUB,0,PXVSTIEN,"HF",PXVHFIEN,0,"AFTER")) D
. . S HFVAL=$P(^XTMP(XTMPSUB,0,PXVSTIEN,"HF",PXVHFIEN,0,"AFTER"),"^") I HFVAL'="" S HFCODE(HFVAL)=""
. I $D(^XTMP(XTMPSUB,0,PXVSTIEN,"HF",PXVHFIEN,0,"BEFORE")),$P(^XTMP(XTMPSUB,0,PXVSTIEN,"HF",PXVHFIEN,0,"BEFORE"),"^")'=$G(HFVAL) D
. . S HFCHECK=$P(^XTMP(XTMPSUB,0,PXVSTIEN,"HF",PXVHFIEN,0,"BEFORE"),"^")
. . I PXHFINITIAL>0,(HFCHECK=PXHFINITIAL) S HFBEFOR(HFCHECK)=PXVHFIEN_"^"_HFVAL,PXUPDATEVST=1
. . I PXHFFOLLOW>0,(HFCHECK=PXHFFOLLOW) S HFBEFOR(HFCHECK)=PXVHFIEN_"^"_HFVAL,PXUPDATEVST=1
;
K ^XTMP(XTMPSUB)
; Check to see if the non acute health factor has been selected
I PXOPNCLOSE="Y",PXHFNONACUTE>0,$D(HFCODE(PXHFNONACUTE)) D
. D VISIT^PXCOMPACT(PXVSTIEN,"O",PXEOCNUM,DFN)
. D SETENDDT^PXCOMPACT(DFN,PXSTDT,"PR")
;
; Gather health factor and compare to see if it contains VA-COMPACT ACT SUICIDE TX ENCOUNTER INITIAL
; Current auto adjudication rules :
; Health Factor VA-COMPACT ACT SUICIDE TX ENCOUNTER INITIAL
; OR DX code T14.91XA
; OR Procedure code 90839 + DX code R45.851
; OR Procedure code T2034 <-- default code from CRD
;
I PXNEWEOC=0,PXOPNCLOSE="N" D
. I PXHFINITIAL>0,$D(HFCODE(PXHFINITIAL)) S PXNEWEOC=1 Q ;Health Factor VA-COMPACT ACT SUICIDE TX ENCOUNTER INITIAL
. I PXNEWEOC=0,$D(POVCODE(DXCOD1)) S PXNEWEOC=1 Q ;T14.91XA
. I PXNEWEOC=0,$D(POVCODE(DXCOD2)),$D(CPTCODE(PXCOD1)) S PXNEWEOC=1 Q ;R45.851 + 90839
. I PXNEWEOC=0,$D(CPTCODE(PXCOD2)) S PXNEWEOC=1 Q ;T2034
I PXNEWEOC=1 D
. ; Check administrative eligibility for COMPACT Act
. S PXADMIN=$$ELIG^DGCOMPACTELIG(DFN,"PXCOMPACTEVAL")
. I PXADMIN'="NOT ELIGIBLE" D NEWEOC^PXCOMPACT(DFN,PXVSTIEN,"O",PXSTDT,"A")
;
; If the follow up flag is not set and the episode of care is still open (not closed by non-acute health factor)
I PXFOLLOW=0,$$ASC^PXCOMPACT(DFN)="Y" D
. I PXHFINITIAL>0,$D(HFCODE(PXHFINITIAL)) S PXFOLLOW=1 Q ;Health Factor VA-COMPACT ACT SUICIDE TX ENCOUNTER INITIAL
. I PXFOLLOW=0,PXHFFOLLOW>0,$D(HFCODE(PXHFFOLLOW)) S PXFOLLOW=1 Q ;VA-COMPACT ACT SUICIDE TX ENCOUNTER FOLLOW UP
. I PXFOLLOW=0,$D(POVCODE(DXCOD3)) S PXFOLLOW=1 Q ;T14.91XD
. I PXFOLLOW=0,$D(POVCODE(DXCOD4)) S PXFOLLOW=1 Q ;T14.91XS
. I PXFOLLOW=0,$D(POVCODE(DXCOD1)) S PXFOLLOW=1 Q ;T14.91XA
. I PXFOLLOW=0,$D(POVCODE(DXCOD2)),$D(CPTCODE(PXCOD1)) S PXFOLLOW=1 Q ;R45.851 + 90839
. I PXFOLLOW=0,$D(CPTCODE(PXCOD2)) S PXFOLLOW=1 Q ;T2034
I PXFOLLOW=1 D
. ; Check administrative eligibility for COMPACT Act
. S PXADMIN=$$ELIG^DGCOMPACTELIG(DFN,"PXCOMPACTEVAL")
. I PXADMIN'="NOT ELIGIBLE" D VISIT^PXCOMPACT(PXVSTIEN,"O",PXEOCNUM,DFN)
;
; If there is an EoC entry, the new EoC logic did not trigger, the follow up EoC logic did not trigger
; and either a procedure code, diagnosis code or health factor has changed, check further
I $D(^PXCOMP(818,"B",DFN)),PXNEWEOC=0,PXFOLLOW=0,PXUPDATEVST=1 D
. S PXUPDTEOC=0
. I $D(CPTBEFOR(PXCOD1))!$D(CPTBEFOR(PXCOD2)) S PXUPDTEOC=1
. I $D(POVBEFOR(DXCOD1))!$D(POVBEFOR(DXCOD2))!$D(POVBEFOR(DXCOD3))!$D(POVBEFOR(DXCOD4)) S PXUPDTEOC=1
. I $D(HFBEFOR(PXHFINITIAL))!$D(HFBEFOR(PXHFFOLLOW)) S PXUPDTEOC=1
. I PXUPDTEOC=1 D CHNGEVAL(DFN,PXVSTIEN)
;
I $D(ZTQUEUED) S ZTREQ="@" ;SAC convention to keep taskman log clean.
K ZTQUEUED,ZTREQ
Q
;
CHNGEVAL(DFN,PXVSTIEN) ;
N PXEOCNUM,PXEOCSEQ,PXPONTRSEQ,PXVSTLST,PXVSTFLG
S (PXEOCNUM,PXEOCSEQ,PXPONTRSEQ,PXVSTLST,PXVSTFLG)=""
;
S PXEOCNUM=$$GETEOC^PXCOMPACT(DFN),PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
S PXPONTRSEQ=$$GETPOINTRSEQ^PXCOMPACT(DFN,PXVSTIEN,"O")
I PXPONTRSEQ="" Q ; This visit is not part of the current episode of care
;
; If it is the first sequence and there is no inpatient benefit end date, end the episode of care
; and mark the episode as entered in error (E)
I PXPONTRSEQ=1,$P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)="" D
. D SETENDDT^PXCOMPACT(DFN,DT,"PR")
. S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",6)="E"
. ; Loop through the visit pointers to set the treatment for flags to no
. S PXVSTLST=$P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,41,0),"^",3)
. F PXVSTFLG=1:1:PXVSTLST D
. . S PXVSTIEN=$P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,41,PXVSTFLG,0),"^")
. . ; Mark the visit treatment for flag(s) to NULL
. . I PXVSTIEN'="" D SETVSTFLG^PXCOMPACT(DFN,PXVSTIEN,"")
E D
. ; Mark the visit treatment for flag to NULL
. D SETVSTFLG^PXCOMPACT(DFN,PXVSTIEN,"")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXCOMPACTEVAL 8473 printed Nov 22, 2024@17:38:33 Page 2
PXCOMPACTEVAL ;ALB/BPA,CMC - COMPACT Act evaluation / protocol entry routine;12/26/2023@10:58am
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**240**;Aug 12, 1996;Build 55
+2 ; *240* COMPACT Act evaluation / protocol entry routine
+3 ; Reference to $$ELIG^DGCOMPACTELIG in ICR #7462
+4 QUIT
+5 ;
EVAL ; load an TMP global with foreground $J value to simulate a pre-existing TMP global from protocol
+1 NEW PURGEDT,XTMPSUB,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+2 SET XTMPSUB="PXCMP"_$JOB_$$NOW^XLFDT
+3 SET PURGEDT=DT_".1159"
+4 SET XTMPSUB(0)=PURGEDT_U_DT_U_"COMPACT Act auto adjudication"
+5 MERGE ^XTMP(XTMPSUB,0)=^TMP("PXKCO",$JOB)
+6 SET ZTRTN="EVALQUE^PXCOMPACTEVAL"
+7 SET ZTDESC="COMPACT Act auto adjudication"
SET ZTIO=""
SET ZTDTH=$HOROLOG
+8 SET ZTSAVE("XTMPSUB")=""
+9 DO ^%ZTLOAD
+10 QUIT
+11 ;
EVALQUE ; RUNS IN BACKGROUND
+1 NEW CPTBEFOR,CPTBEFORVAL,CPTCODE,CPTVAL,DFN,DXCOD1,DXCOD2,DXCOD3,DXCOD4,HFCHECK,HFBEFOR,HFBEFORVAL
+2 NEW HFCODE,HFVAL,POVBEFOR,POVBEFORVAL,POVCODE,POVVAL,PXADMIN,PXCOD1,PXCOD2,PXEOCNUM,PXEOCSEQ,PXFOLLOW
+3 NEW PXNEWEOC,PXOPNCLOSE,PXHFFOLLOW,PXHFINITIAL,PXHFNONACUTE,PXVCPTIEN,PXVHFIEN,PXVPOVIEN,PXSTDT,PXVSTIEN
+4 NEW PXUPDATEVST,PXUPDTEOC
+5 SET (CPTBEFOR,CPTBEFORVAL,CPTCODE,CPTVAL,DFN,DXCOD1,DXCOD2,DXCOD3,DXCOD4,HFCHECK,HFBEFOR,HFBEFORVAL)=""
+6 SET (HFCODE,HFVAL,POVBEFOR,POVBEFORVAL,POVCODE,POVVAL,PXADMIN,PXCOD1,PXCOD2,PXVCPTIEN,PXVHFIEN,PXVPOVIEN)=""
+7 SET (PXSTDT,PXVSTIEN)=""
+8 SET (PXHFINITIAL,PXHFFOLLOW,PXHFNONACUTE)=0
+9 SET (PXFOLLOW,PXNEWEOC,PXOPNCLOSE,PXUPDATEVST,PXUPDTEOC)=0
+10 ;
+11 ; Set the VISIT IEN value
+12 SET PXVSTIEN=$ORDER(^XTMP(XTMPSUB,0,""))
+13 ; Get the DFN and start date
+14 IF PXVSTIEN'=""
Begin DoDot:1
+15 SET DFN=$PIECE(^XTMP(XTMPSUB,0,PXVSTIEN,"VST",PXVSTIEN,0,"AFTER"),"^",5)
+16 SET PXSTDT=$PIECE($PIECE(^XTMP(XTMPSUB,0,PXVSTIEN,"VST",PXVSTIEN,0,"AFTER"),"^"),".")
End DoDot:1
+17 ;
+18 IF DFN=""
KILL ^XTMP(XTMPSUB)
QUIT
+19 ; Check for an open EoC
+20 SET PXOPNCLOSE=$$ASC^PXCOMPACT(DFN)
+21 ;
+22 ; Check for existing episode of care number and current episode of care sequence number
+23 SET PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
SET PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
+24 ;
+25 ; Gather rules engine Health Factor code
+26 SET PXHFINITIAL=$ORDER(^AUTTHF("B","VA-COMPACT ACT SUICIDE TX ENCOUNTER INITIAL",""))
+27 SET PXHFFOLLOW=$ORDER(^AUTTHF("B","VA-COMPACT ACT SUICIDE TX ENCOUNTER FOLLOW UP",""))
+28 SET PXHFNONACUTE=$ORDER(^AUTTHF("B","VA-COMPACT ACT SUICIDE RISK NONACUTE",""))
+29 ;
+30 ; Add calls here to validate DX codes for rules engine
+31 SET DXCOD1=$PIECE($$CODEN^ICDEX("T14.91XA",80),"~",1)
+32 SET DXCOD2=$PIECE($$CODEN^ICDEX("R45.851",80),"~",1)
+33 ;Added for follow up
SET DXCOD3=$PIECE($$CODEN^ICDEX("T14.91XD",80),"~",1)
+34 ;Added for follow up
SET DXCOD4=$PIECE($$CODEN^ICDEX("T14.91XS",80),"~",1)
+35 ; Add calls here to validate PX codes for rules engine
+36 SET PXCOD1=$PIECE($$STATCHK^ICPTAPIU(90839,1),"^",2)
+37 SET PXCOD2=$PIECE($$STATCHK^ICPTAPIU("T2034",1),"^",2)
+38 ;
+39 ; Set up the default start date to now if PXSTDT is not set
+40 IF PXSTDT=""
SET PXSTDT=DT
+41 ;
+42 ; Gather Procedure Codes
+43 FOR
SET PXVCPTIEN=$ORDER(^XTMP(XTMPSUB,0,PXVSTIEN,"CPT",PXVCPTIEN))
if PXVCPTIEN=""
QUIT
Begin DoDot:1
+44 IF $DATA(^XTMP(XTMPSUB,0,PXVSTIEN,"CPT",PXVCPTIEN,0,"AFTER"))
Begin DoDot:2
+45 SET CPTVAL=$PIECE(^XTMP(XTMPSUB,0,PXVSTIEN,"CPT",PXVCPTIEN,0,"AFTER"),"^")
IF CPTVAL'=""
SET CPTCODE(CPTVAL)=""
+46 SET CPTBEFORVAL=$PIECE(^XTMP(XTMPSUB,0,PXVSTIEN,"CPT",PXVCPTIEN,0,"BEFORE"),"^")
End DoDot:2
+47 ; Evaluate the before value to see if if differs from the after value
+48 IF CPTBEFORVAL'=""
IF CPTBEFORVAL'=$GET(CPTVAL)
SET CPTBEFOR(CPTBEFORVAL)=PXVCPTIEN_"^"_CPTVAL
SET PXUPDATEVST=1
End DoDot:1
+49 ;
+50 ; Gather Diagnosis Codes
+51 FOR
SET PXVPOVIEN=$ORDER(^XTMP(XTMPSUB,0,PXVSTIEN,"POV",PXVPOVIEN))
if PXVPOVIEN=""
QUIT
Begin DoDot:1
+52 IF $DATA(^XTMP(XTMPSUB,0,PXVSTIEN,"POV",PXVPOVIEN,0,"AFTER"))
Begin DoDot:2
+53 SET POVVAL=$PIECE(^XTMP(XTMPSUB,0,PXVSTIEN,"POV",PXVPOVIEN,0,"AFTER"),"^")
IF POVVAL'=""
SET POVCODE(POVVAL)=""
+54 SET POVBEFORVAL=$PIECE(^XTMP(XTMPSUB,0,PXVSTIEN,"POV",PXVPOVIEN,0,"BEFORE"),"^")
End DoDot:2
+55 ; Evaluate the before value to see if if differs from the after value
+56 IF POVBEFORVAL'=""
IF POVBEFORVAL'=$GET(POVVAL)
SET POVBEFOR(POVBEFORVAL)=PXVPOVIEN_"^"_POVVAL
SET PXUPDATEVST=1
End DoDot:1
+57 ;
+58 ; Gather Health Factor information
+59 FOR
SET PXVHFIEN=$ORDER(^XTMP(XTMPSUB,0,PXVSTIEN,"HF",PXVHFIEN))
if PXVHFIEN=""
QUIT
Begin DoDot:1
+60 IF $DATA(^XTMP(XTMPSUB,0,PXVSTIEN,"HF",PXVHFIEN,0,"AFTER"))
Begin DoDot:2
+61 SET HFVAL=$PIECE(^XTMP(XTMPSUB,0,PXVSTIEN,"HF",PXVHFIEN,0,"AFTER"),"^")
IF HFVAL'=""
SET HFCODE(HFVAL)=""
End DoDot:2
+62 IF $DATA(^XTMP(XTMPSUB,0,PXVSTIEN,"HF",PXVHFIEN,0,"BEFORE"))
IF $PIECE(^XTMP(XTMPSUB,0,PXVSTIEN,"HF",PXVHFIEN,0,"BEFORE"),"^")'=$GET(HFVAL)
Begin DoDot:2
+63 SET HFCHECK=$PIECE(^XTMP(XTMPSUB,0,PXVSTIEN,"HF",PXVHFIEN,0,"BEFORE"),"^")
+64 IF PXHFINITIAL>0
IF (HFCHECK=PXHFINITIAL)
SET HFBEFOR(HFCHECK)=PXVHFIEN_"^"_HFVAL
SET PXUPDATEVST=1
+65 IF PXHFFOLLOW>0
IF (HFCHECK=PXHFFOLLOW)
SET HFBEFOR(HFCHECK)=PXVHFIEN_"^"_HFVAL
SET PXUPDATEVST=1
End DoDot:2
End DoDot:1
+66 ;
+67 KILL ^XTMP(XTMPSUB)
+68 ; Check to see if the non acute health factor has been selected
+69 IF PXOPNCLOSE="Y"
IF PXHFNONACUTE>0
IF $DATA(HFCODE(PXHFNONACUTE))
Begin DoDot:1
+70 DO VISIT^PXCOMPACT(PXVSTIEN,"O",PXEOCNUM,DFN)
+71 DO SETENDDT^PXCOMPACT(DFN,PXSTDT,"PR")
End DoDot:1
+72 ;
+73 ; Gather health factor and compare to see if it contains VA-COMPACT ACT SUICIDE TX ENCOUNTER INITIAL
+74 ; Current auto adjudication rules :
+75 ; Health Factor VA-COMPACT ACT SUICIDE TX ENCOUNTER INITIAL
+76 ; OR DX code T14.91XA
+77 ; OR Procedure code 90839 + DX code R45.851
+78 ; OR Procedure code T2034 <-- default code from CRD
+79 ;
+80 IF PXNEWEOC=0
IF PXOPNCLOSE="N"
Begin DoDot:1
+81 ;Health Factor VA-COMPACT ACT SUICIDE TX ENCOUNTER INITIAL
IF PXHFINITIAL>0
IF $DATA(HFCODE(PXHFINITIAL))
SET PXNEWEOC=1
QUIT
+82 ;T14.91XA
IF PXNEWEOC=0
IF $DATA(POVCODE(DXCOD1))
SET PXNEWEOC=1
QUIT
+83 ;R45.851 + 90839
IF PXNEWEOC=0
IF $DATA(POVCODE(DXCOD2))
IF $DATA(CPTCODE(PXCOD1))
SET PXNEWEOC=1
QUIT
+84 ;T2034
IF PXNEWEOC=0
IF $DATA(CPTCODE(PXCOD2))
SET PXNEWEOC=1
QUIT
End DoDot:1
+85 IF PXNEWEOC=1
Begin DoDot:1
+86 ; Check administrative eligibility for COMPACT Act
+87 SET PXADMIN=$$ELIG^DGCOMPACTELIG(DFN,"PXCOMPACTEVAL")
+88 IF PXADMIN'="NOT ELIGIBLE"
DO NEWEOC^PXCOMPACT(DFN,PXVSTIEN,"O",PXSTDT,"A")
End DoDot:1
+89 ;
+90 ; If the follow up flag is not set and the episode of care is still open (not closed by non-acute health factor)
+91 IF PXFOLLOW=0
IF $$ASC^PXCOMPACT(DFN)="Y"
Begin DoDot:1
+92 ;Health Factor VA-COMPACT ACT SUICIDE TX ENCOUNTER INITIAL
IF PXHFINITIAL>0
IF $DATA(HFCODE(PXHFINITIAL))
SET PXFOLLOW=1
QUIT
+93 ;VA-COMPACT ACT SUICIDE TX ENCOUNTER FOLLOW UP
IF PXFOLLOW=0
IF PXHFFOLLOW>0
IF $DATA(HFCODE(PXHFFOLLOW))
SET PXFOLLOW=1
QUIT
+94 ;T14.91XD
IF PXFOLLOW=0
IF $DATA(POVCODE(DXCOD3))
SET PXFOLLOW=1
QUIT
+95 ;T14.91XS
IF PXFOLLOW=0
IF $DATA(POVCODE(DXCOD4))
SET PXFOLLOW=1
QUIT
+96 ;T14.91XA
IF PXFOLLOW=0
IF $DATA(POVCODE(DXCOD1))
SET PXFOLLOW=1
QUIT
+97 ;R45.851 + 90839
IF PXFOLLOW=0
IF $DATA(POVCODE(DXCOD2))
IF $DATA(CPTCODE(PXCOD1))
SET PXFOLLOW=1
QUIT
+98 ;T2034
IF PXFOLLOW=0
IF $DATA(CPTCODE(PXCOD2))
SET PXFOLLOW=1
QUIT
End DoDot:1
+99 IF PXFOLLOW=1
Begin DoDot:1
+100 ; Check administrative eligibility for COMPACT Act
+101 SET PXADMIN=$$ELIG^DGCOMPACTELIG(DFN,"PXCOMPACTEVAL")
+102 IF PXADMIN'="NOT ELIGIBLE"
DO VISIT^PXCOMPACT(PXVSTIEN,"O",PXEOCNUM,DFN)
End DoDot:1
+103 ;
+104 ; If there is an EoC entry, the new EoC logic did not trigger, the follow up EoC logic did not trigger
+105 ; and either a procedure code, diagnosis code or health factor has changed, check further
+106 IF $DATA(^PXCOMP(818,"B",DFN))
IF PXNEWEOC=0
IF PXFOLLOW=0
IF PXUPDATEVST=1
Begin DoDot:1
+107 SET PXUPDTEOC=0
+108 IF $DATA(CPTBEFOR(PXCOD1))!$DATA(CPTBEFOR(PXCOD2))
SET PXUPDTEOC=1
+109 IF $DATA(POVBEFOR(DXCOD1))!$DATA(POVBEFOR(DXCOD2))!$DATA(POVBEFOR(DXCOD3))!$DATA(POVBEFOR(DXCOD4))
SET PXUPDTEOC=1
+110 IF $DATA(HFBEFOR(PXHFINITIAL))!$DATA(HFBEFOR(PXHFFOLLOW))
SET PXUPDTEOC=1
+111 IF PXUPDTEOC=1
DO CHNGEVAL(DFN,PXVSTIEN)
End DoDot:1
+112 ;
+113 ;SAC convention to keep taskman log clean.
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+114 KILL ZTQUEUED,ZTREQ
+115 QUIT
+116 ;
CHNGEVAL(DFN,PXVSTIEN) ;
+1 NEW PXEOCNUM,PXEOCSEQ,PXPONTRSEQ,PXVSTLST,PXVSTFLG
+2 SET (PXEOCNUM,PXEOCSEQ,PXPONTRSEQ,PXVSTLST,PXVSTFLG)=""
+3 ;
+4 SET PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
SET PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
+5 SET PXPONTRSEQ=$$GETPOINTRSEQ^PXCOMPACT(DFN,PXVSTIEN,"O")
+6 ; This visit is not part of the current episode of care
IF PXPONTRSEQ=""
QUIT
+7 ;
+8 ; If it is the first sequence and there is no inpatient benefit end date, end the episode of care
+9 ; and mark the episode as entered in error (E)
+10 IF PXPONTRSEQ=1
IF $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)=""
Begin DoDot:1
+11 DO SETENDDT^PXCOMPACT(DFN,DT,"PR")
+12 SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",6)="E"
+13 ; Loop through the visit pointers to set the treatment for flags to no
+14 SET PXVSTLST=$PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,41,0),"^",3)
+15 FOR PXVSTFLG=1:1:PXVSTLST
Begin DoDot:2
+16 SET PXVSTIEN=$PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,41,PXVSTFLG,0),"^")
+17 ; Mark the visit treatment for flag(s) to NULL
+18 IF PXVSTIEN'=""
DO SETVSTFLG^PXCOMPACT(DFN,PXVSTIEN,"")
End DoDot:2
End DoDot:1
+19 IF '$TEST
Begin DoDot:1
+20 ; Mark the visit treatment for flag to NULL
+21 DO SETVSTFLG^PXCOMPACT(DFN,PXVSTIEN,"")
End DoDot:1
+22 QUIT
