PXCOMPACTEOC ;ALB/BPA,CMC - Supporting routine for editing COMPACT EPISODE OF CARE file ;02/05/2024@13:25
;;1.0;PCE PATIENT CARE ENCOUNTER;**240**;Aug 12, 1996;Build 55
; Reference to SETPTFFLG^DGCOMPACT and SETPTFMVMT^DGCOMPACT in ICR #7463
;
Q
;
EDIT ;
N DIR,DIC,DFN,ENDSRC,PXEOCNUM,PXIEN,PXSEQ,STARTDATE,ENDDATE,Y
W ! S DIC="^PXCOMP(818,",DIC(0)="AEQMZ" D ^DIC
Q:Y=-1
S PXEOCNUM=+Y,DFN=$P(Y,"^",2)
S PXSEQ="B",PXSEQ=$O(^PXCOMP(818,PXEOCNUM,10,PXSEQ),-1)
S PXIEN=PXSEQ_","_PXEOCNUM_","
; Get external formats for display
S STARTDATE=$$GET1^DIQ(818.01,PXIEN,.01),ENDDATE=$$GET1^DIQ(818.01,PXIEN,2)
W !!,"Episode Start Date: ",STARTDATE
W !,"Episode End Date: ",ENDDATE
N DIR
S DIR("A")="Do you wish to edit the Episode Start Date"
S DIR("B")="YES",DIR(0)="Y"
W ! D ^DIR
Q:Y="^"
I Y D SDTEDIT(DFN,PXEOCNUM,PXSEQ)
K DIR
S DIR("A")="Do you wish to edit the Episode End Date"
S DIR("B")="YES",DIR(0)="Y"
W ! D ^DIR
Q:Y="^"
I Y D EDTEDIT(DFN,PXEOCNUM,PXSEQ,PXIEN)
;
; Display Source of Crisis End data here, since changing the end date could have changed this field
; Get external format for display
S ENDSRC=$$GET1^DIQ(818.01,PXIEN,3)
W !!,"Source of Crisis End: ",ENDSRC
K DIR
S DIR("A")="Do you wish to edit the Source of Crisis End"
S DIR("B")="YES",DIR(0)="Y"
W ! D ^DIR
Q:Y="^"
I Y D SRCEDIT(PXEOCNUM,PXSEQ)
K DIC,DIR
Q
SDTEDIT(DFN,PXEOCNUM,PXSEQ) ;
N DIR,FMENDDATE,X,Y
S1 S FMENDDATE=$P(^PXCOMP(818,PXEOCNUM,10,PXSEQ,0),"^",2) I FMENDDATE="" S FMENDDATE=DT
S DIR("A")="Enter new Episode Start Date"
S DIR(0)="DO^3230117:"_FMENDDATE_":EX"
S DIR("?")="Date must be no earlier than Jan 17, 2023 and no later than "_$$FMTE^XLFDT(FMENDDATE) W ! D ^DIR
I (Y="")!(Y="^") Q
I (Y>DT) W !,"Start date cannot be in the future." G S1
; if validation passes, update the Episode Start Date
D SETSTDT^PXCOMPACT(DFN,Y)
W !,"Episode Start Date updated!"
Q
;
EDTEDIT(DFN,PXEOCNUM,PXSEQ,PXIEN) ;
N DIR,FMSTDATE,X,Y
S FMSTDATE=$P(^PXCOMP(818,PXEOCNUM,10,PXSEQ,0),"^",1)
S DIR("A")="Enter new Episode End Date"
S DIR(0)="DO^"_FMSTDATE_":"_DT_":EX"
S DIR("?")="End date must be no earlier than "_$$FMTE^XLFDT(FMSTDATE)_" and no later than today's date"
W ! D ^DIR
I (Y="")!(Y="^") Q
; if validation passes, update the Episode End Date
D SETENDDT^PXCOMPACT(DFN,Y,"PR")
W !,"Episode End Date updated!"
Q
SRCEDIT(PXEOCNUM,PXSEQ) ;
N DIR,X,Y
S DIR("A")="Enter new Source of Crisis End"
S DIR(0)="SO^PR:PROVIDER;PA:PATIENT"
S DIR("?")="Enter PR for Provider or PA for Patient"
W ! D ^DIR
I (Y="")!(Y="^") Q
; if validation passes, update the Source of Crisis End
S $P(^PXCOMP(818,PXEOCNUM,10,PXSEQ,0),"^",3)=$$UP^XLFSTR(Y)
W !,"Source of Crisis End updated!"
Q
;
N DIC,DIR,DFN,Y
W ! S DIC="^PXCOMP(818,",DIC(0)="AEQMZ" D ^DIC
Q:Y=-1
S DFN=$P(Y,"^",2)
;
K DIR
S DIR("A")="Do you wish to retract the current inpatient episode of care"
S DIR("B")="YES",DIR(0)="Y"
W ! D ^DIR
I (Y=0)!(Y="^") G RETRACTMENU
K DIR,Y
S DIR("A")="Retracting will remove the COMPACT Act benefit for this inpatient stay. Are you sure"
S DIR("B")="YES",DIR(0)="Y"
W ! D ^DIR
I (Y="^")!(Y=0) G RETRACTMENU
I Y D RETRACT(DFN,"",1)
W !,"COMPACT Act Episode of Care retracted"
Q
;
RETRACT(DFN,PXENC,MENU) ;
; Call in DG input templates: D RETRACT^PXCOMPACTEOC(DFN,PTF)
;
; Only allow retraction for the most current episode of care open or closed
; DFN - Internal Patient ID (required)
; PXENC - PTF internal ID (NOT required) {Used for inpatient processing}
; MENU - Used to differentiate between a RETRACTMENU call and a call from elsewhere
;
N DA,PXEOCNUM,PXEOCSEQ,PXPTF,PXPTFSEQ,PXVST,PXVSTSEQ
S (PXEOCNUM,PXEOCSEQ,PXPTF,PXPTFSEQ,PXVST,PXVSTSEQ)=""
I $G(PXENC)="" S PXENC=""
I $G(MENU)="" S MENU=""
I DFN="" W !,"Internal Patient ID can not be null." Q
I '$D(^PXCOMP(818,"B",DFN)) W !,"Patient "_DFN_" not in the COMPACT Act episode of care file." Q
S PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
I PXEOCNUM'="" D
. S PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN) I PXEOCSEQ="" W !,"Patient does not have an episode in the COMPACT Episode of Care file." Q
. I MENU'=1,$P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)="" Q
. I MENU=1,$P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)="" W !,"This is not an inpatient episode of care, cannot be retracted from this menu." G RETRACTMENU
. ; For inpatient processing, check for PTF before retraction. If the PTF passed in is not part of the Episode
. ; of Care, do not retract the Episode.
. I PXENC'="",'$D(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,"B",PXENC)) Q
. ; Set the EPISODE FINAL STATUS to Entered in Error (E) and EPISODE SOURCE to NULL
. S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",6)="E",$P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",7)=""
. I $$ASC^PXCOMPACT(DFN)="Y" D SETENDDT^PXCOMPACT(DFN,DT,"")
. ; Loop through 40 and 41 levels
. S PXPTFSEQ=0,PXPTF=""
. F S PXPTFSEQ=$O(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,PXPTFSEQ)) Q:(PXPTFSEQ="B")!(PXPTFSEQ="") D
. . S PXPTF=$P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,PXPTFSEQ,0),"^",1) D
. . . I $D(^DGPT(PXPTF)) D SETPTFFLG^DGCOMPACT(PXPTF,"")
. . . N PTFMVTSEQ S PTFMVTSEQ=0
. . . I $D(^DGPT(PXPTF,"M")) D
. . . . F S PTFMVTSEQ=$O(^DGPT(PXPTF,"M",PTFMVTSEQ)) Q:(PTFMVTSEQ["A")!(PTFMVTSEQ="") D SETPTFMVMT^DGCOMPACT(PXPTF,"",PTFMVTSEQ)
. S PXVSTSEQ=0,PXVST=""
. F S PXVSTSEQ=$O(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,41,PXVSTSEQ)) Q:(PXVSTSEQ="B")!(PXVSTSEQ="") D
. . S PXVST=$P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,41,PXVSTSEQ,0),"^",1) D SETVSTFLG^PXCOMPACT(DFN,PXVST,"")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXCOMPACTEOC 5665 printed Dec 13, 2024@02:28:32 Page 2
PXCOMPACTEOC ;ALB/BPA,CMC - Supporting routine for editing COMPACT EPISODE OF CARE file ;02/05/2024@13:25
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**240**;Aug 12, 1996;Build 55
+2 ; Reference to SETPTFFLG^DGCOMPACT and SETPTFMVMT^DGCOMPACT in ICR #7463
+3 ;
+4 QUIT
+5 ;
EDIT ;
+1 NEW DIR,DIC,DFN,ENDSRC,PXEOCNUM,PXIEN,PXSEQ,STARTDATE,ENDDATE,Y
+2 WRITE !
SET DIC="^PXCOMP(818,"
SET DIC(0)="AEQMZ"
DO ^DIC
+3 if Y=-1
QUIT
+4 SET PXEOCNUM=+Y
SET DFN=$PIECE(Y,"^",2)
+5 SET PXSEQ="B"
SET PXSEQ=$ORDER(^PXCOMP(818,PXEOCNUM,10,PXSEQ),-1)
+6 SET PXIEN=PXSEQ_","_PXEOCNUM_","
+7 ; Get external formats for display
+8 SET STARTDATE=$$GET1^DIQ(818.01,PXIEN,.01)
SET ENDDATE=$$GET1^DIQ(818.01,PXIEN,2)
+9 WRITE !!,"Episode Start Date: ",STARTDATE
+10 WRITE !,"Episode End Date: ",ENDDATE
+11 NEW DIR
+12 SET DIR("A")="Do you wish to edit the Episode Start Date"
+13 SET DIR("B")="YES"
SET DIR(0)="Y"
+14 WRITE !
DO ^DIR
+15 if Y="^"
QUIT
+16 IF Y
DO SDTEDIT(DFN,PXEOCNUM,PXSEQ)
+17 KILL DIR
+18 SET DIR("A")="Do you wish to edit the Episode End Date"
+19 SET DIR("B")="YES"
SET DIR(0)="Y"
+20 WRITE !
DO ^DIR
+21 if Y="^"
QUIT
+22 IF Y
DO EDTEDIT(DFN,PXEOCNUM,PXSEQ,PXIEN)
+23 ;
+24 ; Display Source of Crisis End data here, since changing the end date could have changed this field
+25 ; Get external format for display
+26 SET ENDSRC=$$GET1^DIQ(818.01,PXIEN,3)
+27 WRITE !!,"Source of Crisis End: ",ENDSRC
+28 KILL DIR
+29 SET DIR("A")="Do you wish to edit the Source of Crisis End"
+30 SET DIR("B")="YES"
SET DIR(0)="Y"
+31 WRITE !
DO ^DIR
+32 if Y="^"
QUIT
+33 IF Y
DO SRCEDIT(PXEOCNUM,PXSEQ)
+34 KILL DIC,DIR
+35 QUIT
SDTEDIT(DFN,PXEOCNUM,PXSEQ) ;
+1 NEW DIR,FMENDDATE,X,Y
S1 SET FMENDDATE=$PIECE(^PXCOMP(818,PXEOCNUM,10,PXSEQ,0),"^",2)
IF FMENDDATE=""
SET FMENDDATE=DT
+1 SET DIR("A")="Enter new Episode Start Date"
+2 SET DIR(0)="DO^3230117:"_FMENDDATE_":EX"
+3 SET DIR("?")="Date must be no earlier than Jan 17, 2023 and no later than "_$$FMTE^XLFDT(FMENDDATE)
WRITE !
DO ^DIR
+4 IF (Y="")!(Y="^")
QUIT
+5 IF (Y>DT)
WRITE !,"Start date cannot be in the future."
GOTO S1
+6 ; if validation passes, update the Episode Start Date
+7 DO SETSTDT^PXCOMPACT(DFN,Y)
+8 WRITE !,"Episode Start Date updated!"
+9 QUIT
+10 ;
EDTEDIT(DFN,PXEOCNUM,PXSEQ,PXIEN) ;
+1 NEW DIR,FMSTDATE,X,Y
+2 SET FMSTDATE=$PIECE(^PXCOMP(818,PXEOCNUM,10,PXSEQ,0),"^",1)
+3 SET DIR("A")="Enter new Episode End Date"
+4 SET DIR(0)="DO^"_FMSTDATE_":"_DT_":EX"
+5 SET DIR("?")="End date must be no earlier than "_$$FMTE^XLFDT(FMSTDATE)_" and no later than today's date"
+6 WRITE !
DO ^DIR
+7 IF (Y="")!(Y="^")
QUIT
+8 ; if validation passes, update the Episode End Date
+9 DO SETENDDT^PXCOMPACT(DFN,Y,"PR")
+10 WRITE !,"Episode End Date updated!"
+11 QUIT
SRCEDIT(PXEOCNUM,PXSEQ) ;
+1 NEW DIR,X,Y
+2 SET DIR("A")="Enter new Source of Crisis End"
+3 SET DIR(0)="SO^PR:PROVIDER;PA:PATIENT"
+4 SET DIR("?")="Enter PR for Provider or PA for Patient"
+5 WRITE !
DO ^DIR
+6 IF (Y="")!(Y="^")
QUIT
+7 ; if validation passes, update the Source of Crisis End
+8 SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXSEQ,0),"^",3)=$$UP^XLFSTR(Y)
+9 WRITE !,"Source of Crisis End updated!"
+10 QUIT
+11 ;
+1 NEW DIC,DIR,DFN,Y
+2 WRITE !
SET DIC="^PXCOMP(818,"
SET DIC(0)="AEQMZ"
DO ^DIC
+3 if Y=-1
QUIT
+4 SET DFN=$PIECE(Y,"^",2)
+5 ;
+6 KILL DIR
+7 SET DIR("A")="Do you wish to retract the current inpatient episode of care"
+8 SET DIR("B")="YES"
SET DIR(0)="Y"
+9 WRITE !
DO ^DIR
+10 IF (Y=0)!(Y="^")
GOTO RETRACTMENU
+11 KILL DIR,Y
+12 SET DIR("A")="Retracting will remove the COMPACT Act benefit for this inpatient stay. Are you sure"
+13 SET DIR("B")="YES"
SET DIR(0)="Y"
+14 WRITE !
DO ^DIR
+15 IF (Y="^")!(Y=0)
GOTO RETRACTMENU
+16 IF Y
DO RETRACT(DFN,"",1)
+17 WRITE !,"COMPACT Act Episode of Care retracted"
+18 QUIT
+19 ;
RETRACT(DFN,PXENC,MENU) ;
+1 ; Call in DG input templates: D RETRACT^PXCOMPACTEOC(DFN,PTF)
+2 ;
+3 ; Only allow retraction for the most current episode of care open or closed
+4 ; DFN - Internal Patient ID (required)
+5 ; PXENC - PTF internal ID (NOT required) {Used for inpatient processing}
+6 ; MENU - Used to differentiate between a RETRACTMENU call and a call from elsewhere
+7 ;
+8 NEW DA,PXEOCNUM,PXEOCSEQ,PXPTF,PXPTFSEQ,PXVST,PXVSTSEQ
+9 SET (PXEOCNUM,PXEOCSEQ,PXPTF,PXPTFSEQ,PXVST,PXVSTSEQ)=""
+10 IF $GET(PXENC)=""
SET PXENC=""
+11 IF $GET(MENU)=""
SET MENU=""
+12 IF DFN=""
WRITE !,"Internal Patient ID can not be null."
QUIT
+13 IF '$DATA(^PXCOMP(818,"B",DFN))
WRITE !,"Patient "_DFN_" not in the COMPACT Act episode of care file."
QUIT
+14 SET PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
+15 IF PXEOCNUM'=""
Begin DoDot:1
+16 SET PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
IF PXEOCSEQ=""
WRITE !,"Patient does not have an episode in the COMPACT Episode of Care file."
QUIT
+17 IF MENU'=1
IF $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)=""
QUIT
+18 IF MENU=1
IF $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)=""
WRITE !,"This is not an inpatient episode of care, cannot be retracted from this menu."
GOTO RETRACTMENU
+19 ; For inpatient processing, check for PTF before retraction. If the PTF passed in is not part of the Episode
+20 ; of Care, do not retract the Episode.
+21 IF PXENC'=""
IF '$DATA(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,"B",PXENC))
QUIT
+22 ; Set the EPISODE FINAL STATUS to Entered in Error (E) and EPISODE SOURCE to NULL
+23 SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",6)="E"
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",7)=""
+24 IF $$ASC^PXCOMPACT(DFN)="Y"
DO SETENDDT^PXCOMPACT(DFN,DT,"")
+25 ; Loop through 40 and 41 levels
+26 SET PXPTFSEQ=0
SET PXPTF=""
+27 FOR
SET PXPTFSEQ=$ORDER(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,PXPTFSEQ))
if (PXPTFSEQ="B")!(PXPTFSEQ="")
QUIT
Begin DoDot:2
+28 SET PXPTF=$PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,PXPTFSEQ,0),"^",1)
Begin DoDot:3
+29 IF $DATA(^DGPT(PXPTF))
DO SETPTFFLG^DGCOMPACT(PXPTF,"")
+30 NEW PTFMVTSEQ
SET PTFMVTSEQ=0
+31 IF $DATA(^DGPT(PXPTF,"M"))
Begin DoDot:4
+32 FOR
SET PTFMVTSEQ=$ORDER(^DGPT(PXPTF,"M",PTFMVTSEQ))
if (PTFMVTSEQ["A")!(PTFMVTSEQ="")
QUIT
DO SETPTFMVMT^DGCOMPACT(PXPTF,"",PTFMVTSEQ)
End DoDot:4
End DoDot:3
End DoDot:2
+33 SET PXVSTSEQ=0
SET PXVST=""
+34 FOR
SET PXVSTSEQ=$ORDER(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,41,PXVSTSEQ))
if (PXVSTSEQ="B")!(PXVSTSEQ="")
QUIT
Begin DoDot:2
+35 SET PXVST=$PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,41,PXVSTSEQ,0),"^",1)
DO SETVSTFLG^PXCOMPACT(DFN,PXVST,"")
End DoDot:2
End DoDot:1
+36 QUIT
