PXCOMPACT ;ALB/BPA,CMC - Routine for COMPACT Act APIs;05/06/2024@12:01
;;1.0;PCE PATIENT CARE ENCOUNTER;**240**;Aug 12, 1996;Build 55
; *240* APIs for Episode of Care APIs (^PXCOMP(818))
; Reference to $$ELIG^DGCOMPACTELIG in ICR #7462
; Reference to SETPTFFLG^DGCOMPACT and SETPTFMVMT^DGCOMPACT in ICR #7463
; Reference to ^DGPM("ATID3") in ICR #17
;
Q
GETSTDT(DFN) ;
; Retrieve the start date from the zero level of the most current episode sequence
; DFN is the Patient ID
;
N PXEOCNUM,PXEOCSEQ,PXSTDT
S (PXEOCNUM,PXEOCSEQ,PXERRMSG,PXSTDT)=""
;D VALDFN(DFN,.PXERRMSG) I PXERRMSG'="" Q PXERRMSG
I $D(^PXCOMP(818,"B",DFN)) D
. S PXEOCNUM=$$GETEOC(DFN),PXEOCSEQ=$$GETEOCSEQ(DFN),PXSTDT=$P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",1)
Q PXSTDT
;
GETIPDT(DFN) ;
;Retrieve the IP benefit end date
;
N PXEOCNUM,PXEOCSEQ,IPENDDT
S (PXEOCNUM,PXEOCSEQ,IPENDDT)=""
I $D(^PXCOMP(818,"B",DFN)) D
. S PXEOCNUM=$$GETEOC(DFN),PXEOCSEQ=$$GETEOCSEQ(DFN),IPENDDT=$P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)
Q IPENDDT
;
GETEOC(DFN) ;
; Get the Episode of Care number assigned to the patient
N PXEOCNUM
I DFN="" S PXEOCNUM=""
E S PXEOCNUM=$O(^PXCOMP(818,"B",DFN,""))
Q PXEOCNUM
;
GETEOCSEQ(DFN) ;
; Get the current/last Episode of Care sequence
N PXEOCNUM,PXEOCSEQ
S PXEOCSEQ="",PXEOCNUM=$$GETEOC(DFN)
I $G(PXEOCNUM)'="",$D(^PXCOMP(818,PXEOCNUM,10,0)) S PXEOCSEQ=$O(^PXCOMP(818,PXEOCNUM,10,"B"),-1)
Q PXEOCSEQ
;
GETPOINTRSEQ(DFN,PXENC,PXTY) ;
; Get the pointer sequence from the episode of care
; DFN - Internal Patient ID *required
; PXENC - Internal Encounter ID (VISIT or PTF) *required
; PXTY - Inpatient or Outpatient
N PXEOCNUM,PXEOCSEQ,PXPONTRNUM
S PXPONTRNUM=""
I $G(PXTY)="" S PXTY=$$GETBENTYP(DFN)
S PXEOCNUM=$$GETEOC(DFN),PXEOCSEQ=$$GETEOCSEQ(DFN)
I PXEOCNUM'="",PXTY'="" D
. I PXTY="O" S PXPONTRNUM=$O(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,41,"B",PXENC,""))
. E S PXPONTRNUM=$O(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,"B",PXENC,""))
Q PXPONTRNUM
;
GETBENTYP(DFN) ;
N PXBENTYP,PXEOCNUM,PXEOCSEQ
S PXEOCNUM=$$GETEOC(DFN)
I PXEOCNUM'="" S PXBENTYP=$P(^PXCOMP(818,PXEOCNUM,0),"^",3)
; If there is no value in the benefit type field for a closed episode of care,
; look at the benefit end date history
I PXBENTYP="" D
. ; Default setting to outpatient
. S PXEOCSEQ=$$GETEOCSEQ(DFN),PXBENTYP="O"
. ; Look for the inpatient benefit end date and outpatient benefit end date to
. ; determine a closed episode of care benefit type
. I $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)'="",$P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",5)="" S PXBENTYP="I"
Q PXBENTYP
;
SETSTDT(DFN,PXNWSTDT) ;
; Set a new start date for the current / most recent episode of care
; DFN - Patient ID
; PXNWSTDT - New start date (VA format)
;
N CDATA,CMPMSG,PXBENTYP,PXEOCNUM,PXEOCSEQ,PXERRMSG,PXFNDOBI,PXFNDOBO,PXIENS
S (CDATA,CMPMSG,PXBENTYP,PXEOCNUM,PXEOCSEQ,PXERRMSG,PXFNDOBI,PXFNDOBO,PXIENS)=""
;
; Check to see if date is less than seven digits in length
I $L(PXNWSTDT)<7 S PXERRMSG="The start date value "_PXNWSTDT_" is less than seven digits in length." D COMPACTERR^PXCOMPACT1(PXERRMSG,DFN) Q
; Check to see if date is more than seven digits in length
I $L(PXNWSTDT)>7 S PXERRMSG="The start date value "_PXNWSTDT_" is greater than seven digits in length." D COMPACTERR^PXCOMPACT1(PXERRMSG,DFN) Q
; Check to see if the start date is prior to January 17th, 2023
I PXNWSTDT<3230117 S PXERRMSG="The start date "_PXNWSTDT_" is prior to January 17th, 2023." D COMPACTERR^PXCOMPACT1(PXERRMSG,DFN) Q
; Check to see if start date is in the future
I PXNWSTDT>DT S PXERRMSG="The start date "_PXNWSTDT_" is in the future." D COMPACTERR^PXCOMPACT1(PXERRMSG,DFN) Q
;
D VALDFN(DFN,.PXERRMSG) I PXERRMSG'="" Q
S PXEOCNUM=$$GETEOC(DFN),PXEOCSEQ=$$GETEOCSEQ(DFN),PXBENTYP=$$GETBENTYP(DFN)
I PXBENTYP="I" S PXFNDOBI=$$FMADD^XLFDT(PXNWSTDT,29)
I PXBENTYP="O" S PXFNDOBO=$$FMADD^XLFDT(PXNWSTDT,89)
S PXIENS=PXEOCSEQ_","_PXEOCNUM_","
;
I $G(PXNWSTDT)'="" S CDATA(818.01,PXIENS,.01)=PXNWSTDT
I $G(PXFNDOBI)'="" S CDATA(818.01,PXIENS,4)=PXFNDOBI
I $G(PXFNDOBO)'="" S CDATA(818.01,PXIENS,5)=PXFNDOBO
D FILE^DIE("","CDATA","CMPMSG")
I $D(CMPMSG("DIERR")) D FILEMANERR^PXCOMPACT1(DFN,.CDATA,.CMPMSG) Q
Q
;
SETENDDT(DFN,PXENDDT,PXENDSRC,PXAUTH,PXCOMM) ;
N PXEOCNUM,PXEOCSEQ,PXERRMSG,PXSTDT
S (PXEOCNUM,PXEOCSEQ,PXERRMSG,PXSTDT)=""
D VALDFN(DFN,.PXERRMSG) I PXERRMSG'="" Q
I $G(PXENDDT)="" Q
I $G(PXAUTH)'="" D VALUSR(PXAUTH,.PXERRMSG) I PXERRMSG'="" Q
;
S PXENDSRC=$S($G(PXENDSRC)="PA":"PA",$G(PXENDSRC)="PR":"PR",$G(PXENDSRC)="TE":"TE",1:"")
;
S PXEOCNUM=$$GETEOC(DFN),PXEOCSEQ=$$GETEOCSEQ(DFN)
S PXSTDT=$P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^")
I PXSTDT>PXENDDT Q
;
S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",2)=PXENDDT
S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",3)=PXENDSRC
I $P(^PXCOMP(818,PXEOCNUM,0),"^",3)="I" S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)=PXENDDT
I $P(^PXCOMP(818,PXEOCNUM,0),"^",3)="O" S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",5)=PXENDDT
I $G(PXAUTH)'="" S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,1),"^",1)=PXAUTH
I $G(PXCOMM)'="" S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,1),"^",2)=PXCOMM
; Set the ACUTE SUICIDAL CRISIS FLAG to zero and benefit type flag to NULL
S $P(^PXCOMP(818,PXEOCNUM,0),"^",2)=0,$P(^PXCOMP(818,PXEOCNUM,0),"^",3)=""
Q
;
NEWEOC(DFN,PXENC,PXTY,PXSTDT,PXSRC) ;
; API to input a new Episode of Care
;
N CDATA,CMPMSG,EPDATA,PXELIG,PXEOCNUM,PXEOCSEQ,PXERRMSG,PXFNDOBI,PXFNDOBO,PXIEN,PXIENEP,PXTYCHK
S (CDATA,CMPMSG,EPDATA,PXELIG,PXEOCNUM,PXEOCSEQ,PXERRMSG,PXFNDOBI,PXFNDOBO,PXIEN,PXIENEP,PXTYCHK)=""
I $G(DFN)="" S PXERRMSG="Patient ID (DFN) cannot be null" D COMPACTERR^PXCOMPACT1(PXERRMSG,DFN) Q
I '$D(^DPT(DFN)) S PXERRMSG="Patient is invalid, not in the patient file #2" D COMPACTERR^PXCOMPACT1(PXERRMSG,DFN) Q
S PXTYCHK=$S($G(PXTY)="I":1,$G(PXTY)="O":1,1:0)
I PXTYCHK=0 S PXERRMSG="Inpatient (I) or Outpatient (O) must be the designated type" D COMPACTERR^PXCOMPACT1(PXERRMSG,DFN) Q
I PXENC="" S PXERRMSG="The encounter value can not be null" D COMPACTERR^PXCOMPACT1(PXERRMSG,DFN) Q
I $D(^PXCOMP(818,"B",DFN)) D
. S PXEOCNUM=$$GETEOC(DFN)
. I $P(^PXCOMP(818,PXEOCNUM,0),"^",2)=1 S PXERRMSG="Patient has an open episode" D COMPACTERR^PXCOMPACT1(PXERRMSG,DFN)
I PXERRMSG'="" Q
; If the start date is not passed in, use the start date of the encounter
I $D(^DGPT(PXENC)),$G(PXSTDT)="",$G(PXTY)="I" S PXSTDT=$P($P(^DGPT(PXENC,0),"^",2),".")
I $D(^AUPNVSIT(PXENC)),$G(PXSTDT)="",$G(PXTY)="O" S PXSTDT=$P($P(^AUPNVSIT(PXENC,0),"^"),".")
I $G(PXSTDT)="" S PXSTDT=DT
S PXELIG=$$ELIG^DGCOMPACTELIG(DFN,"PXCOMPACT")
S PXELIG=$S(PXELIG="ELIGIBLE":"E",PXELIG="NOT ELIGIBLE":"N",1:"U")
I $G(PXSRC)="" S PXSRC=""
I PXTY="I" S PXFNDOBI=$$FMADD^XLFDT(PXSTDT,29)
I PXTY="O" S PXFNDOBO=$$FMADD^XLFDT(PXSTDT,90)
;Set top level of ^PXCOMP
I $G(PXEOCNUM)="" D
. N CDATA,CMPMSG,PXIEN
. S PXIEN="?+1,"
. S CDATA(818,PXIEN,.01)=DFN
. S CDATA(818,PXIEN,2)=1
. S CDATA(818,PXIEN,3)=PXTY
. D UPDATE^DIE("","CDATA","","CMPMSG")
. I $D(CMPMSG("DIERR")) D FILEMANERR^PXCOMPACT1(DFN,.CDATA,.CMPMSG) Q
E D
. S $P(^PXCOMP(818,PXEOCNUM,0),"^",2)=1
. S $P(^PXCOMP(818,PXEOCNUM,0),"^",3)=PXTY
;
I $D(CMPMSG("DIERR")) Q
I PXEOCNUM="" S PXEOCNUM=$$GETEOC(DFN)
;
;Set episode level (10)
S PXIENEP="?+1,"_PXEOCNUM_","
I $G(PXSTDT)'="" S EPDATA(818.01,PXIENEP,.01)=PXSTDT
I $G(PXFNDOBI)'="" S EPDATA(818.01,PXIENEP,4)=PXFNDOBI
I $G(PXFNDOBO)'="" S EPDATA(818.01,PXIENEP,5)=PXFNDOBO
I $G(PXSRC)'="" S EPDATA(818.01,PXIENEP,7)=PXSRC
I $G(PXELIG)'="" S EPDATA(818.01,PXIENEP,8)=PXELIG
D UPDATE^DIE("","EPDATA","","CMPMSG")
I $D(CMPMSG("DIERR")) D FILEMANERR^PXCOMPACT1(DFN,.EPDATA,.CMPMSG)
;
S (PXEOCNUM,PXEOCSEQ)=""
S PXEOCNUM=$$GETEOC(DFN),PXEOCSEQ=$$GETEOCSEQ(DFN)
I $G(PXELIG)'="" S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",8)=PXELIG
; CALL 40/41 API HERE
D VISIT(PXENC,PXTY,PXEOCNUM,DFN)
Q
;
CHGTYPSTAT(DFN,PXTY,PXCHNGDT) ;
N PXEOCNUM,PXEOCSEQ,PXFNDOBI,PXFNDOBO
S (PXFNDOBI,PXFNDOBO)=""
S PXEOCNUM=$$GETEOC(DFN),PXEOCSEQ=$$GETEOCSEQ(DFN)
I PXEOCNUM="" Q
;
I $$GETBENTYP(DFN)=PXTY Q
I $G(PXCHNGDT)="" S PXCHNGDT=DT
S $P(^PXCOMP(818,PXEOCNUM,0),"^",3)=PXTY
; Set the updated benefit end dates based on the type of change
I PXTY="O" S PXFNDOBI=PXCHNGDT,PXFNDOBO=$$FMADD^XLFDT(PXCHNGDT,90)
I PXTY="I" S PXFNDOBO=PXCHNGDT,PXFNDOBI=$$FMADD^XLFDT(PXCHNGDT,29)
S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)=PXFNDOBI
S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",5)=PXFNDOBO
S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",7)="A"
Q
;
VISIT(ENC,PXTY,PXEOCNUM,DFN) ;
;
N CDATA,CMPMSG,PXIENS,PXEOCSEQ
S (PXIENS)=""
S PXEOCSEQ=$$GETEOCSEQ(DFN)
I PXTY="I" D
. S (CMPMSG,CDATA(818.04))=""
. ;Set top level 40 node for PTF pointer
. S PXIENS="?+1,"_PXEOCSEQ_","_PXEOCNUM_","
. I $G(ENC)'="" D
. . S CDATA(818.04,PXIENS,.01)=ENC
. . D UPDATE^DIE("","CDATA","","CMPMSG")
. . I $D(CMPMSG("DIERR")) D FILEMANERR^PXCOMPACT1(DFN,.CDATA,.CMPMSG)
. . I $D(^DGPT(ENC,0)) D SETPTFFLG^DGCOMPACT(ENC,1)
I PXTY="O" D
. S (CMPMSG,CDATA(818.141))=""
. ;Set top level 41 node for VISIT pointer
. S PXIENS="?+1,"_PXEOCSEQ_","_PXEOCNUM_","
. I $G(ENC)'="" D
. . S CDATA(818.141,PXIENS,.01)=ENC
. . D UPDATE^DIE("","CDATA","","CMPMSG")
. . I $D(CMPMSG("DIERR")) D FILEMANERR^PXCOMPACT1(DFN,.CDATA,.CMPMSG)
. . D SETVSTFLG(DFN,ENC,1)
Q
;
SETVSTFLG(DFN,PXENC,PXVAL) ;
N PXEOCNUM,PXEOCSEQ,PXPOINTRSEQ
S PXEOCNUM=$$GETEOC(DFN),PXEOCSEQ=$$GETEOCSEQ(DFN),PXPOINTRSEQ=$$GETPOINTRSEQ(DFN,PXENC,"O")
I PXPOINTRSEQ'="" S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,41,PXPOINTRSEQ,0),"^",2)=PXVAL
Q
;
VALDFN(DFN,PXERRMSG) ;
N PXERRMSG
S PXERRMSG=""
I DFN="" S PXERRMSG="Patient required" D COMPACTERR^PXCOMPACT1(PXERRMSG,DFN) Q
I '$D(^DPT(DFN)) S PXERRMSG="Patient is invalid, not in the patient file #2" D COMPACTERR^PXCOMPACT1(PXERRMSG,DFN) Q
I '$D(^PXCOMP(818,"B",DFN)) S PXERRMSG="Patient is not in the COMPACT Act Episode of Care file #818" D COMPACTERR^PXCOMPACT1(PXERRMSG,DFN) Q
Q
;
VALUSR(PXAUTH,PXERRMSG) ;
N PXERRMSG
S PXERRMSG=""
I PXAUTH="" S PXERRMSG="User value can not be null" D COMPACTERR^PXCOMPACT1(PXERRMSG,DFN) Q
I '$D(^VA(200,PXAUTH,0)) S PXERRMSG="Invalid user "_PXAUTH_", not in the new person file #200" D COMPACTERR^PXCOMPACT1(PXERRMSG,DFN) Q
Q
;
ASC(DFN) ;
; Determine if patient is currently in an acute suicidal crisis
N PXEOCNUM,ASC
S PXEOCNUM="",PXEOCNUM=$$GETEOC(DFN),ASC="N"
I PXEOCNUM,$P(^PXCOMP(818,PXEOCNUM,0),"^",2)>0 S ASC="Y"
Q ASC
;
DISPLAY(DFN) ;
;before calling this tag, verify eligibility by calling ELIG^DGCOMPACTELIG(DFN)
;if ELIGIBLE or UNDETERMINED, call this tag
N DISPLAY,ELIGSEQ,ENDDT,EOCTYP,IPBENEND,OPBENEND,OPEXT,PXIEN,PXLASTSEQ,PXNUMOPX,PXSEQ,STARTDT
S (ENDDT,EOCTYP,IPBENEND,OPBENEND,OPEXT,PXIEN,PXLASTSEQ,PXNUMOPX,PXSEQ,STARTDT,ELIGSEQ,DISPLAY)=""
;get Compact Act sequence
I $D(^PXCOMP(818,"B",DFN)) S PXSEQ=$$GETEOC(DFN)
I PXSEQ'="" D
. ;find the latest sequence in the episode
. S PXLASTSEQ=$$GETEOCSEQ(DFN)
. ;get the start date and format it
. S STARTDT=$P(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,0),"^",1),STARTDT=$$FMTE^XLFDT(STARTDT)
. S EOCTYP=$P(^PXCOMP(818,PXSEQ,0),"^",3)
. ;check if the episode has ended. If so, only display Episode Start and End Date
. S ENDDT=$P($G(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,0)),"^",2)
. S IPBENEND=$P($G(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,0)),"^",4) I IPBENEND'="" S IPBENEND=$$FMTE^XLFDT(IPBENEND)
. S OPBENEND=$P($G(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,0)),"^",5) I OPBENEND'="" S OPBENEND=$$FMTE^XLFDT(OPBENEND)
. I ENDDT'="" D
. . S ENDDT=$$FMTE^XLFDT(ENDDT)
. . ;check for extensions
. . S OPEXT=$D(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,30))
. . I OPEXT=0 D
. . . S DISPLAY="COMPACT Act Start Date^"_STARTDT_"^End Date^"_ENDDT_"^IP Benefit End Date^"_IPBENEND_"^OP Benefit end date^"_OPBENEND
. . . ; if there's an extension, display extension start and episode end date
. . I OPEXT D
. . . S STARTDT=$P($G(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,30,1,0)),"^",1),STARTDT=$$FMTE^XLFDT(STARTDT)
. . . S DISPLAY="Extension Start Date^"_STARTDT_"^Episode End Date^"_ENDDT
. ;if not ended, display Episode Start Date and Remaining Days (if no extensions)
. E D
. . ;check for extensions
. . S OPEXT=$D(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,30))
. . I OPEXT=0 D
. . . S PXIEN=PXLASTSEQ_","_PXSEQ
. . . I EOCTYP="I",$P(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,0),"^",4)'="" D
. . . . S DISPLAY="COMPACT Act Start Date^"_STARTDT_"^Remaining Days^"_$$GET1^DIQ(818.01,PXIEN,42)_"^Inpatient Benefit End Date^"_IPBENEND
. . . E S DISPLAY="COMPACT Act Start Date^"_STARTDT_"^Remaining Days^"_$S(EOCTYP="O":$$GET1^DIQ(818.01,PXIEN,43),1:$$GET1^DIQ(818.01,PXIEN,42))
. . I OPEXT D
. . . S STARTDT=$P($G(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,30,1,0)),"^",1),STARTDT=$$FMTE^XLFDT(STARTDT)
. . . S PXNUMOPX=$P(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,30,0),"^",3),PXIEN=PXNUMOPX_","_PXLASTSEQ_","_PXSEQ
. . . S DISPLAY="Extension Start Date^"_STARTDT_"^Remaining Days^"_$S(EOCTYP="O":$$GET1^DIQ(818.01,PXIEN,43),1:$$GET1^DIQ(818.01,PXIEN,42))
Q DISPLAY
;
ADMIT(DFN,STARTDT,ADMIT,PTF) ;
;called from DGPM ADMIT input template
;first, close the episode of care IF it's outpatient
N EOCNUM,EOCSEQ,LTD,REOPNFLG
S (EOCNUM,EOCSEQ)="",REOPNFLG=0
S EOCNUM=$$GETEOC(DFN)
I EOCNUM="" D NEWEOC(DFN,PTF,"I",STARTDT,"V") I ADMIT="F" D SETPTFMVMT^DGCOMPACT(PTF,"Y")
;Processing complete, new episode of care created
I EOCNUM="" Q
S EOCSEQ=$$GETEOCSEQ(DFN) I EOCSEQ="" Q
;
;checking for scenario where patient is discharged but admitted same day
I $P(^PXCOMP(818,EOCNUM,0),"^",3)="O",$P(^PXCOMP(818,EOCNUM,0),"^",2)=1 D
. ; - get the last discharge date
. S LTD=+$O(^DGPM("ATID3",DFN,"")) S:LTD LTD=9999999.9999999-LTD\1
. ;Processing for patient that has been discharged/admitted the same day
. I DT=LTD D REOPNEOC(EOCNUM,EOCSEQ,"") S REOPNFLG=1
. I REOPNFLG=0 D SETENDDT(DFN,DT,"PR",DUZ,"admitting")
;if a current inpatient EOC exists do the following:
;link both PTF records to the episode
I $P(^PXCOMP(818,EOCNUM,0),"^",3)="I",$P(^PXCOMP(818,EOCNUM,0),"^",2)=1 D
. D VISIT(PTF,"I",EOCNUM,DFN)
. D SETPTFMVMT^DGCOMPACT(PTF,"Y")
;if no current EOC inpatient record
I $P(^PXCOMP(818,EOCNUM,0),"^",2)=0 D
. D NEWEOC(DFN,PTF,"I",STARTDT,"V")
. ;set movement for Full admit
. I ADMIT="F" D SETPTFMVMT^DGCOMPACT(PTF,"Y")
Q
;
REOPNEOC(PXEOCNUM,PXEOCSEQ,STARTDT) ;
N DFN,ELIG S (DFN,ELIG)=""
; Reopen an inpatient Episode of Care
S $P(^PXCOMP(818,PXEOCNUM,0),"^",2)=1 ;Reset the episode of care open/close flag
S $P(^PXCOMP(818,PXEOCNUM,0),"^",3)="I" ;Reset the Benefit Type
; Start date processing needs benefit type
S DFN=$P(^PXCOMP(818,PXEOCNUM,0),"^",1)
I $G(STARTDT)="" S STARTDT=$P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",1)
E D SETSTDT(DFN,STARTDT)
;
S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",2)="" ;Remove the end date
S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",3)="" ;Remove the end source
I $D(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,1)) K ^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,1)
S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)=$$FMADD^XLFDT(STARTDT,29) ;Reset the inpatient benefit end date
S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",5)="" ;Remove the outpatient benefit end date
S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",6)="" ;Remove the final status
S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",7)="" ;Remove the source
S ELIG=$$ELIG^DGCOMPACTELIG(DFN,"PXCOMPACT")
S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",8)=$S(ELIG="ELIGIBLE":"E",ELIG="NOT ELIGIBLE":"N",1:"U") ;Reset the patient eligibility
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXCOMPACT 15881 printed Dec 13, 2024@02:28:29 Page 2
PXCOMPACT ;ALB/BPA,CMC - Routine for COMPACT Act APIs;05/06/2024@12:01
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**240**;Aug 12, 1996;Build 55
+2 ; *240* APIs for Episode of Care APIs (^PXCOMP(818))
+3 ; Reference to $$ELIG^DGCOMPACTELIG in ICR #7462
+4 ; Reference to SETPTFFLG^DGCOMPACT and SETPTFMVMT^DGCOMPACT in ICR #7463
+5 ; Reference to ^DGPM("ATID3") in ICR #17
+6 ;
+7 QUIT
GETSTDT(DFN) ;
+1 ; Retrieve the start date from the zero level of the most current episode sequence
+2 ; DFN is the Patient ID
+3 ;
+4 NEW PXEOCNUM,PXEOCSEQ,PXSTDT
+5 SET (PXEOCNUM,PXEOCSEQ,PXERRMSG,PXSTDT)=""
+6 ;D VALDFN(DFN,.PXERRMSG) I PXERRMSG'="" Q PXERRMSG
+7 IF $DATA(^PXCOMP(818,"B",DFN))
Begin DoDot:1
+8 SET PXEOCNUM=$$GETEOC(DFN)
SET PXEOCSEQ=$$GETEOCSEQ(DFN)
SET PXSTDT=$PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",1)
End DoDot:1
+9 QUIT PXSTDT
+10 ;
GETIPDT(DFN) ;
+1 ;Retrieve the IP benefit end date
+2 ;
+3 NEW PXEOCNUM,PXEOCSEQ,IPENDDT
+4 SET (PXEOCNUM,PXEOCSEQ,IPENDDT)=""
+5 IF $DATA(^PXCOMP(818,"B",DFN))
Begin DoDot:1
+6 SET PXEOCNUM=$$GETEOC(DFN)
SET PXEOCSEQ=$$GETEOCSEQ(DFN)
SET IPENDDT=$PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)
End DoDot:1
+7 QUIT IPENDDT
+8 ;
GETEOC(DFN) ;
+1 ; Get the Episode of Care number assigned to the patient
+2 NEW PXEOCNUM
+3 IF DFN=""
SET PXEOCNUM=""
+4 IF '$TEST
SET PXEOCNUM=$ORDER(^PXCOMP(818,"B",DFN,""))
+5 QUIT PXEOCNUM
+6 ;
GETEOCSEQ(DFN) ;
+1 ; Get the current/last Episode of Care sequence
+2 NEW PXEOCNUM,PXEOCSEQ
+3 SET PXEOCSEQ=""
SET PXEOCNUM=$$GETEOC(DFN)
+4 IF $GET(PXEOCNUM)'=""
IF $DATA(^PXCOMP(818,PXEOCNUM,10,0))
SET PXEOCSEQ=$ORDER(^PXCOMP(818,PXEOCNUM,10,"B"),-1)
+5 QUIT PXEOCSEQ
+6 ;
GETPOINTRSEQ(DFN,PXENC,PXTY) ;
+1 ; Get the pointer sequence from the episode of care
+2 ; DFN - Internal Patient ID *required
+3 ; PXENC - Internal Encounter ID (VISIT or PTF) *required
+4 ; PXTY - Inpatient or Outpatient
+5 NEW PXEOCNUM,PXEOCSEQ,PXPONTRNUM
+6 SET PXPONTRNUM=""
+7 IF $GET(PXTY)=""
SET PXTY=$$GETBENTYP(DFN)
+8 SET PXEOCNUM=$$GETEOC(DFN)
SET PXEOCSEQ=$$GETEOCSEQ(DFN)
+9 IF PXEOCNUM'=""
IF PXTY'=""
Begin DoDot:1
+10 IF PXTY="O"
SET PXPONTRNUM=$ORDER(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,41,"B",PXENC,""))
+11 IF '$TEST
SET PXPONTRNUM=$ORDER(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,"B",PXENC,""))
End DoDot:1
+12 QUIT PXPONTRNUM
+13 ;
GETBENTYP(DFN) ;
+1 NEW PXBENTYP,PXEOCNUM,PXEOCSEQ
+2 SET PXEOCNUM=$$GETEOC(DFN)
+3 IF PXEOCNUM'=""
SET PXBENTYP=$PIECE(^PXCOMP(818,PXEOCNUM,0),"^",3)
+4 ; If there is no value in the benefit type field for a closed episode of care,
+5 ; look at the benefit end date history
+6 IF PXBENTYP=""
Begin DoDot:1
+7 ; Default setting to outpatient
+8 SET PXEOCSEQ=$$GETEOCSEQ(DFN)
SET PXBENTYP="O"
+9 ; Look for the inpatient benefit end date and outpatient benefit end date to
+10 ; determine a closed episode of care benefit type
+11 IF $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)'=""
IF $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",5)=""
SET PXBENTYP="I"
End DoDot:1
+12 QUIT PXBENTYP
+13 ;
SETSTDT(DFN,PXNWSTDT) ;
+1 ; Set a new start date for the current / most recent episode of care
+2 ; DFN - Patient ID
+3 ; PXNWSTDT - New start date (VA format)
+4 ;
+5 NEW CDATA,CMPMSG,PXBENTYP,PXEOCNUM,PXEOCSEQ,PXERRMSG,PXFNDOBI,PXFNDOBO,PXIENS
+6 SET (CDATA,CMPMSG,PXBENTYP,PXEOCNUM,PXEOCSEQ,PXERRMSG,PXFNDOBI,PXFNDOBO,PXIENS)=""
+7 ;
+8 ; Check to see if date is less than seven digits in length
+9 IF $LENGTH(PXNWSTDT)<7
SET PXERRMSG="The start date value "_PXNWSTDT_" is less than seven digits in length."
DO COMPACTERR^PXCOMPACT1(PXERRMSG,DFN)
QUIT
+10 ; Check to see if date is more than seven digits in length
+11 IF $LENGTH(PXNWSTDT)>7
SET PXERRMSG="The start date value "_PXNWSTDT_" is greater than seven digits in length."
DO COMPACTERR^PXCOMPACT1(PXERRMSG,DFN)
QUIT
+12 ; Check to see if the start date is prior to January 17th, 2023
+13 IF PXNWSTDT<3230117
SET PXERRMSG="The start date "_PXNWSTDT_" is prior to January 17th, 2023."
DO COMPACTERR^PXCOMPACT1(PXERRMSG,DFN)
QUIT
+14 ; Check to see if start date is in the future
+15 IF PXNWSTDT>DT
SET PXERRMSG="The start date "_PXNWSTDT_" is in the future."
DO COMPACTERR^PXCOMPACT1(PXERRMSG,DFN)
QUIT
+16 ;
+17 DO VALDFN(DFN,.PXERRMSG)
IF PXERRMSG'=""
QUIT
+18 SET PXEOCNUM=$$GETEOC(DFN)
SET PXEOCSEQ=$$GETEOCSEQ(DFN)
SET PXBENTYP=$$GETBENTYP(DFN)
+19 IF PXBENTYP="I"
SET PXFNDOBI=$$FMADD^XLFDT(PXNWSTDT,29)
+20 IF PXBENTYP="O"
SET PXFNDOBO=$$FMADD^XLFDT(PXNWSTDT,89)
+21 SET PXIENS=PXEOCSEQ_","_PXEOCNUM_","
+22 ;
+23 IF $GET(PXNWSTDT)'=""
SET CDATA(818.01,PXIENS,.01)=PXNWSTDT
+24 IF $GET(PXFNDOBI)'=""
SET CDATA(818.01,PXIENS,4)=PXFNDOBI
+25 IF $GET(PXFNDOBO)'=""
SET CDATA(818.01,PXIENS,5)=PXFNDOBO
+26 DO FILE^DIE("","CDATA","CMPMSG")
+27 IF $DATA(CMPMSG("DIERR"))
DO FILEMANERR^PXCOMPACT1(DFN,.CDATA,.CMPMSG)
QUIT
+28 QUIT
+29 ;
SETENDDT(DFN,PXENDDT,PXENDSRC,PXAUTH,PXCOMM) ;
+1 NEW PXEOCNUM,PXEOCSEQ,PXERRMSG,PXSTDT
+2 SET (PXEOCNUM,PXEOCSEQ,PXERRMSG,PXSTDT)=""
+3 DO VALDFN(DFN,.PXERRMSG)
IF PXERRMSG'=""
QUIT
+4 IF $GET(PXENDDT)=""
QUIT
+5 IF $GET(PXAUTH)'=""
DO VALUSR(PXAUTH,.PXERRMSG)
IF PXERRMSG'=""
QUIT
+6 ;
+7 SET PXENDSRC=$SELECT($GET(PXENDSRC)="PA":"PA",$GET(PXENDSRC)="PR":"PR",$GET(PXENDSRC)="TE":"TE",1:"")
+8 ;
+9 SET PXEOCNUM=$$GETEOC(DFN)
SET PXEOCSEQ=$$GETEOCSEQ(DFN)
+10 SET PXSTDT=$PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^")
+11 IF PXSTDT>PXENDDT
QUIT
+12 ;
+13 SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",2)=PXENDDT
+14 SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",3)=PXENDSRC
+15 IF $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",3)="I"
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)=PXENDDT
+16 IF $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",3)="O"
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",5)=PXENDDT
+17 IF $GET(PXAUTH)'=""
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,1),"^",1)=PXAUTH
+18 IF $GET(PXCOMM)'=""
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,1),"^",2)=PXCOMM
+19 ; Set the ACUTE SUICIDAL CRISIS FLAG to zero and benefit type flag to NULL
+20 SET $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",2)=0
SET $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",3)=""
+21 QUIT
+22 ;
NEWEOC(DFN,PXENC,PXTY,PXSTDT,PXSRC) ;
+1 ; API to input a new Episode of Care
+2 ;
+3 NEW CDATA,CMPMSG,EPDATA,PXELIG,PXEOCNUM,PXEOCSEQ,PXERRMSG,PXFNDOBI,PXFNDOBO,PXIEN,PXIENEP,PXTYCHK
+4 SET (CDATA,CMPMSG,EPDATA,PXELIG,PXEOCNUM,PXEOCSEQ,PXERRMSG,PXFNDOBI,PXFNDOBO,PXIEN,PXIENEP,PXTYCHK)=""
+5 IF $GET(DFN)=""
SET PXERRMSG="Patient ID (DFN) cannot be null"
DO COMPACTERR^PXCOMPACT1(PXERRMSG,DFN)
QUIT
+6 IF '$DATA(^DPT(DFN))
SET PXERRMSG="Patient is invalid, not in the patient file #2"
DO COMPACTERR^PXCOMPACT1(PXERRMSG,DFN)
QUIT
+7 SET PXTYCHK=$SELECT($GET(PXTY)="I":1,$GET(PXTY)="O":1,1:0)
+8 IF PXTYCHK=0
SET PXERRMSG="Inpatient (I) or Outpatient (O) must be the designated type"
DO COMPACTERR^PXCOMPACT1(PXERRMSG,DFN)
QUIT
+9 IF PXENC=""
SET PXERRMSG="The encounter value can not be null"
DO COMPACTERR^PXCOMPACT1(PXERRMSG,DFN)
QUIT
+10 IF $DATA(^PXCOMP(818,"B",DFN))
Begin DoDot:1
+11 SET PXEOCNUM=$$GETEOC(DFN)
+12 IF $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",2)=1
SET PXERRMSG="Patient has an open episode"
DO COMPACTERR^PXCOMPACT1(PXERRMSG,DFN)
End DoDot:1
+13 IF PXERRMSG'=""
QUIT
+14 ; If the start date is not passed in, use the start date of the encounter
+15 IF $DATA(^DGPT(PXENC))
IF $GET(PXSTDT)=""
IF $GET(PXTY)="I"
SET PXSTDT=$PIECE($PIECE(^DGPT(PXENC,0),"^",2),".")
+16 IF $DATA(^AUPNVSIT(PXENC))
IF $GET(PXSTDT)=""
IF $GET(PXTY)="O"
SET PXSTDT=$PIECE($PIECE(^AUPNVSIT(PXENC,0),"^"),".")
+17 IF $GET(PXSTDT)=""
SET PXSTDT=DT
+18 SET PXELIG=$$ELIG^DGCOMPACTELIG(DFN,"PXCOMPACT")
+19 SET PXELIG=$SELECT(PXELIG="ELIGIBLE":"E",PXELIG="NOT ELIGIBLE":"N",1:"U")
+20 IF $GET(PXSRC)=""
SET PXSRC=""
+21 IF PXTY="I"
SET PXFNDOBI=$$FMADD^XLFDT(PXSTDT,29)
+22 IF PXTY="O"
SET PXFNDOBO=$$FMADD^XLFDT(PXSTDT,90)
+23 ;Set top level of ^PXCOMP
+24 IF $GET(PXEOCNUM)=""
Begin DoDot:1
+25 NEW CDATA,CMPMSG,PXIEN
+26 SET PXIEN="?+1,"
+27 SET CDATA(818,PXIEN,.01)=DFN
+28 SET CDATA(818,PXIEN,2)=1
+29 SET CDATA(818,PXIEN,3)=PXTY
+30 DO UPDATE^DIE("","CDATA","","CMPMSG")
+31 IF $DATA(CMPMSG("DIERR"))
DO FILEMANERR^PXCOMPACT1(DFN,.CDATA,.CMPMSG)
QUIT
End DoDot:1
+32 IF '$TEST
Begin DoDot:1
+33 SET $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",2)=1
+34 SET $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",3)=PXTY
End DoDot:1
+35 ;
+36 IF $DATA(CMPMSG("DIERR"))
QUIT
+37 IF PXEOCNUM=""
SET PXEOCNUM=$$GETEOC(DFN)
+38 ;
+39 ;Set episode level (10)
+40 SET PXIENEP="?+1,"_PXEOCNUM_","
+41 IF $GET(PXSTDT)'=""
SET EPDATA(818.01,PXIENEP,.01)=PXSTDT
+42 IF $GET(PXFNDOBI)'=""
SET EPDATA(818.01,PXIENEP,4)=PXFNDOBI
+43 IF $GET(PXFNDOBO)'=""
SET EPDATA(818.01,PXIENEP,5)=PXFNDOBO
+44 IF $GET(PXSRC)'=""
SET EPDATA(818.01,PXIENEP,7)=PXSRC
+45 IF $GET(PXELIG)'=""
SET EPDATA(818.01,PXIENEP,8)=PXELIG
+46 DO UPDATE^DIE("","EPDATA","","CMPMSG")
+47 IF $DATA(CMPMSG("DIERR"))
DO FILEMANERR^PXCOMPACT1(DFN,.EPDATA,.CMPMSG)
+48 ;
+49 SET (PXEOCNUM,PXEOCSEQ)=""
+50 SET PXEOCNUM=$$GETEOC(DFN)
SET PXEOCSEQ=$$GETEOCSEQ(DFN)
+51 IF $GET(PXELIG)'=""
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",8)=PXELIG
+52 ; CALL 40/41 API HERE
+53 DO VISIT(PXENC,PXTY,PXEOCNUM,DFN)
+54 QUIT
+55 ;
CHGTYPSTAT(DFN,PXTY,PXCHNGDT) ;
+1 NEW PXEOCNUM,PXEOCSEQ,PXFNDOBI,PXFNDOBO
+2 SET (PXFNDOBI,PXFNDOBO)=""
+3 SET PXEOCNUM=$$GETEOC(DFN)
SET PXEOCSEQ=$$GETEOCSEQ(DFN)
+4 IF PXEOCNUM=""
QUIT
+5 ;
+6 IF $$GETBENTYP(DFN)=PXTY
QUIT
+7 IF $GET(PXCHNGDT)=""
SET PXCHNGDT=DT
+8 SET $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",3)=PXTY
+9 ; Set the updated benefit end dates based on the type of change
+10 IF PXTY="O"
SET PXFNDOBI=PXCHNGDT
SET PXFNDOBO=$$FMADD^XLFDT(PXCHNGDT,90)
+11 IF PXTY="I"
SET PXFNDOBO=PXCHNGDT
SET PXFNDOBI=$$FMADD^XLFDT(PXCHNGDT,29)
+12 SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)=PXFNDOBI
+13 SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",5)=PXFNDOBO
+14 SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",7)="A"
+15 QUIT
+16 ;
VISIT(ENC,PXTY,PXEOCNUM,DFN) ;
+1 ;
+2 NEW CDATA,CMPMSG,PXIENS,PXEOCSEQ
+3 SET (PXIENS)=""
+4 SET PXEOCSEQ=$$GETEOCSEQ(DFN)
+5 IF PXTY="I"
Begin DoDot:1
+6 SET (CMPMSG,CDATA(818.04))=""
+7 ;Set top level 40 node for PTF pointer
+8 SET PXIENS="?+1,"_PXEOCSEQ_","_PXEOCNUM_","
+9 IF $GET(ENC)'=""
Begin DoDot:2
+10 SET CDATA(818.04,PXIENS,.01)=ENC
+11 DO UPDATE^DIE("","CDATA","","CMPMSG")
+12 IF $DATA(CMPMSG("DIERR"))
DO FILEMANERR^PXCOMPACT1(DFN,.CDATA,.CMPMSG)
+13 IF $DATA(^DGPT(ENC,0))
DO SETPTFFLG^DGCOMPACT(ENC,1)
End DoDot:2
End DoDot:1
+14 IF PXTY="O"
Begin DoDot:1
+15 SET (CMPMSG,CDATA(818.141))=""
+16 ;Set top level 41 node for VISIT pointer
+17 SET PXIENS="?+1,"_PXEOCSEQ_","_PXEOCNUM_","
+18 IF $GET(ENC)'=""
Begin DoDot:2
+19 SET CDATA(818.141,PXIENS,.01)=ENC
+20 DO UPDATE^DIE("","CDATA","","CMPMSG")
+21 IF $DATA(CMPMSG("DIERR"))
DO FILEMANERR^PXCOMPACT1(DFN,.CDATA,.CMPMSG)
+22 DO SETVSTFLG(DFN,ENC,1)
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
SETVSTFLG(DFN,PXENC,PXVAL) ;
+1 NEW PXEOCNUM,PXEOCSEQ,PXPOINTRSEQ
+2 SET PXEOCNUM=$$GETEOC(DFN)
SET PXEOCSEQ=$$GETEOCSEQ(DFN)
SET PXPOINTRSEQ=$$GETPOINTRSEQ(DFN,PXENC,"O")
+3 IF PXPOINTRSEQ'=""
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,41,PXPOINTRSEQ,0),"^",2)=PXVAL
+4 QUIT
+5 ;
VALDFN(DFN,PXERRMSG) ;
+1 NEW PXERRMSG
+2 SET PXERRMSG=""
+3 IF DFN=""
SET PXERRMSG="Patient required"
DO COMPACTERR^PXCOMPACT1(PXERRMSG,DFN)
QUIT
+4 IF '$DATA(^DPT(DFN))
SET PXERRMSG="Patient is invalid, not in the patient file #2"
DO COMPACTERR^PXCOMPACT1(PXERRMSG,DFN)
QUIT
+5 IF '$DATA(^PXCOMP(818,"B",DFN))
SET PXERRMSG="Patient is not in the COMPACT Act Episode of Care file #818"
DO COMPACTERR^PXCOMPACT1(PXERRMSG,DFN)
QUIT
+6 QUIT
+7 ;
VALUSR(PXAUTH,PXERRMSG) ;
+1 NEW PXERRMSG
+2 SET PXERRMSG=""
+3 IF PXAUTH=""
SET PXERRMSG="User value can not be null"
DO COMPACTERR^PXCOMPACT1(PXERRMSG,DFN)
QUIT
+4 IF '$DATA(^VA(200,PXAUTH,0))
SET PXERRMSG="Invalid user "_PXAUTH_", not in the new person file #200"
DO COMPACTERR^PXCOMPACT1(PXERRMSG,DFN)
QUIT
+5 QUIT
+6 ;
ASC(DFN) ;
+1 ; Determine if patient is currently in an acute suicidal crisis
+2 NEW PXEOCNUM,ASC
+3 SET PXEOCNUM=""
SET PXEOCNUM=$$GETEOC(DFN)
SET ASC="N"
+4 IF PXEOCNUM
IF $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",2)>0
SET ASC="Y"
+5 QUIT ASC
+6 ;
DISPLAY(DFN) ;
+1 ;before calling this tag, verify eligibility by calling ELIG^DGCOMPACTELIG(DFN)
+2 ;if ELIGIBLE or UNDETERMINED, call this tag
+3 NEW DISPLAY,ELIGSEQ,ENDDT,EOCTYP,IPBENEND,OPBENEND,OPEXT,PXIEN,PXLASTSEQ,PXNUMOPX,PXSEQ,STARTDT
+4 SET (ENDDT,EOCTYP,IPBENEND,OPBENEND,OPEXT,PXIEN,PXLASTSEQ,PXNUMOPX,PXSEQ,STARTDT,ELIGSEQ,DISPLAY)=""
+5 ;get Compact Act sequence
+6 IF $DATA(^PXCOMP(818,"B",DFN))
SET PXSEQ=$$GETEOC(DFN)
+7 IF PXSEQ'=""
Begin DoDot:1
+8 ;find the latest sequence in the episode
+9 SET PXLASTSEQ=$$GETEOCSEQ(DFN)
+10 ;get the start date and format it
+11 SET STARTDT=$PIECE(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,0),"^",1)
SET STARTDT=$$FMTE^XLFDT(STARTDT)
+12 SET EOCTYP=$PIECE(^PXCOMP(818,PXSEQ,0),"^",3)
+13 ;check if the episode has ended. If so, only display Episode Start and End Date
+14 SET ENDDT=$PIECE($GET(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,0)),"^",2)
+15 SET IPBENEND=$PIECE($GET(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,0)),"^",4)
IF IPBENEND'=""
SET IPBENEND=$$FMTE^XLFDT(IPBENEND)
+16 SET OPBENEND=$PIECE($GET(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,0)),"^",5)
IF OPBENEND'=""
SET OPBENEND=$$FMTE^XLFDT(OPBENEND)
+17 IF ENDDT'=""
Begin DoDot:2
+18 SET ENDDT=$$FMTE^XLFDT(ENDDT)
+19 ;check for extensions
+20 SET OPEXT=$DATA(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,30))
+21 IF OPEXT=0
Begin DoDot:3
+22 SET DISPLAY="COMPACT Act Start Date^"_STARTDT_"^End Date^"_ENDDT_"^IP Benefit End Date^"_IPBENEND_"^OP Benefit end date^"_OPBENEND
+23 ; if there's an extension, display extension start and episode end date
End DoDot:3
+24 IF OPEXT
Begin DoDot:3
+25 SET STARTDT=$PIECE($GET(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,30,1,0)),"^",1)
SET STARTDT=$$FMTE^XLFDT(STARTDT)
+26 SET DISPLAY="Extension Start Date^"_STARTDT_"^Episode End Date^"_ENDDT
End DoDot:3
End DoDot:2
+27 ;if not ended, display Episode Start Date and Remaining Days (if no extensions)
+28 IF '$TEST
Begin DoDot:2
+29 ;check for extensions
+30 SET OPEXT=$DATA(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,30))
+31 IF OPEXT=0
Begin DoDot:3
+32 SET PXIEN=PXLASTSEQ_","_PXSEQ
+33 IF EOCTYP="I"
IF $PIECE(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,0),"^",4)'=""
Begin DoDot:4
+34 SET DISPLAY="COMPACT Act Start Date^"_STARTDT_"^Remaining Days^"_$$GET1^DIQ(818.01,PXIEN,42)_"^Inpatient Benefit End Date^"_IPBENEND
End DoDot:4
+35 IF '$TEST
SET DISPLAY="COMPACT Act Start Date^"_STARTDT_"^Remaining Days^"_$SELECT(EOCTYP="O":$$GET1^DIQ(818.01,PXIEN,43),1:$$GET1^DIQ(818.01,PXIEN,42))
End DoDot:3
+36 IF OPEXT
Begin DoDot:3
+37 SET STARTDT=$PIECE($GET(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,30,1,0)),"^",1)
SET STARTDT=$$FMTE^XLFDT(STARTDT)
+38 SET PXNUMOPX=$PIECE(^PXCOMP(818,PXSEQ,10,PXLASTSEQ,30,0),"^",3)
SET PXIEN=PXNUMOPX_","_PXLASTSEQ_","_PXSEQ
+39 SET DISPLAY="Extension Start Date^"_STARTDT_"^Remaining Days^"_$SELECT(EOCTYP="O":$$GET1^DIQ(818.01,PXIEN,43),1:$$GET1^DIQ(818.01,PXIEN,42))
End DoDot:3
End DoDot:2
End DoDot:1
+40 QUIT DISPLAY
+41 ;
ADMIT(DFN,STARTDT,ADMIT,PTF) ;
+1 ;called from DGPM ADMIT input template
+2 ;first, close the episode of care IF it's outpatient
+3 NEW EOCNUM,EOCSEQ,LTD,REOPNFLG
+4 SET (EOCNUM,EOCSEQ)=""
SET REOPNFLG=0
+5 SET EOCNUM=$$GETEOC(DFN)
+6 IF EOCNUM=""
DO NEWEOC(DFN,PTF,"I",STARTDT,"V")
IF ADMIT="F"
DO SETPTFMVMT^DGCOMPACT(PTF,"Y")
+7 ;Processing complete, new episode of care created
+8 IF EOCNUM=""
QUIT
+9 SET EOCSEQ=$$GETEOCSEQ(DFN)
IF EOCSEQ=""
QUIT
+10 ;
+11 ;checking for scenario where patient is discharged but admitted same day
+12 IF $PIECE(^PXCOMP(818,EOCNUM,0),"^",3)="O"
IF $PIECE(^PXCOMP(818,EOCNUM,0),"^",2)=1
Begin DoDot:1
+13 ; - get the last discharge date
+14 SET LTD=+$ORDER(^DGPM("ATID3",DFN,""))
if LTD
SET LTD=9999999.9999999-LTD\1
+15 ;Processing for patient that has been discharged/admitted the same day
+16 IF DT=LTD
DO REOPNEOC(EOCNUM,EOCSEQ,"")
SET REOPNFLG=1
+17 IF REOPNFLG=0
DO SETENDDT(DFN,DT,"PR",DUZ,"admitting")
End DoDot:1
+18 ;if a current inpatient EOC exists do the following:
+19 ;link both PTF records to the episode
+20 IF $PIECE(^PXCOMP(818,EOCNUM,0),"^",3)="I"
IF $PIECE(^PXCOMP(818,EOCNUM,0),"^",2)=1
Begin DoDot:1
+21 DO VISIT(PTF,"I",EOCNUM,DFN)
+22 DO SETPTFMVMT^DGCOMPACT(PTF,"Y")
End DoDot:1
+23 ;if no current EOC inpatient record
+24 IF $PIECE(^PXCOMP(818,EOCNUM,0),"^",2)=0
Begin DoDot:1
+25 DO NEWEOC(DFN,PTF,"I",STARTDT,"V")
+26 ;set movement for Full admit
+27 IF ADMIT="F"
DO SETPTFMVMT^DGCOMPACT(PTF,"Y")
End DoDot:1
+28 QUIT
+29 ;
REOPNEOC(PXEOCNUM,PXEOCSEQ,STARTDT) ;
+1 NEW DFN,ELIG
SET (DFN,ELIG)=""
+2 ; Reopen an inpatient Episode of Care
+3 ;Reset the episode of care open/close flag
SET $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",2)=1
+4 ;Reset the Benefit Type
SET $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",3)="I"
+5 ; Start date processing needs benefit type
+6 SET DFN=$PIECE(^PXCOMP(818,PXEOCNUM,0),"^",1)
+7 IF $GET(STARTDT)=""
SET STARTDT=$PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",1)
+8 IF '$TEST
DO SETSTDT(DFN,STARTDT)
+9 ;
+10 ;Remove the end date
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",2)=""
+11 ;Remove the end source
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",3)=""
+12 IF $DATA(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,1))
KILL ^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,1)
+13 ;Reset the inpatient benefit end date
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)=$$FMADD^XLFDT(STARTDT,29)
+14 ;Remove the outpatient benefit end date
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",5)=""
+15 ;Remove the final status
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",6)=""
+16 ;Remove the source
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",7)=""
+17 SET ELIG=$$ELIG^DGCOMPACTELIG(DFN,"PXCOMPACT")
+18 ;Reset the patient eligibility
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",8)=$SELECT(ELIG="ELIGIBLE":"E",ELIG="NOT ELIGIBLE":"N",1:"U")
+19 QUIT
+20 ;
