- 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 Feb 18, 2025@23:54:46 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 ;