DGCOMPACT ;ALB/BPA,CMC - Routine for COMPACT Act processing the DG;12/18/2023@9:26am
;;5.3;Registration;**1104,1117**;Aug 13, 1993;Build 32
; *1104* APIs for COMPACT Act processing
; Reference to VISIT^PXCOMPACT in ICR #7327
;
SETPTFFLG(DGENC,DGVAL) ;
; API to set TRT FOR ACUTE SUICIDAL CRISIS flag in PTF 101
; DGENC - Encounter ID (PTF IEN)
; DGVAL - Value to set into flag
; For YES: D SETPTFFLG^DGCOMPACT(DGENC,1)
; For NO: D SETPTFFLG^DGCOMPACT(DGENC,0)
; For NULL: D SETPTFFLG^DGCOMPACT(DGENC,"")
; Create a 70 level in the PTF file if it is not set
I $G(^DGPT(DGENC,70))="" S ^DGPT(DGENC,70)=""
S $P(^DGPT(DGENC,70),"^",33)=DGVAL
Q
;
SETPTFMVMT(DGENC,DGVAL,DGSEQ) ;
; API to set TREATMENT FOR SUICIDAL CRISIS flag in PTF 501
; DGENC - Encounter ID (PTF IEN)
; DGVAL - Value to set into flag
; DGSEQ - Movement sequence *not required
; For YES: D SETPTFMVMT^DGCOMPACT(DGENC,"Y",DGSEQ)
; For NO: D SETPTFMVMT^DGCOMPACT(DGENC,"N",DGSEQ)
; For NULL: D SETPTFMVMT^DGCOMPACT(DGENC,"",DGSEQ)
; When setting a sequence other than the first one, pass the sequence number
I $G(DGSEQ)'="" S $P(^DGPT(DGENC,"M",DGSEQ,0),"^",33)=DGVAL
; Whenever a new movement is created for a PTF, it becomes the 1 node of the subfile.
E S $P(^DGPT(DGENC,"M",1,0),"^",33)=DGVAL
Q
;
EDITADMIT(PTF) ;
N ADMTYP,CDATA,CMPMSG,DFN,DGSTDT,PXIENS
S DFN=$P(^UTILITY($J,"PXCOMPACT"),"^",1),DGSTDT=$P(^UTILITY($J,"PXCOMPACT"),"^",2),ADMTYP=$P(^UTILITY($J,"PXCOMPACT"),"^",3)
D ADMIT^PXCOMPACT(DFN,DGSTDT,ADMTYP,PTF)
S (CMPMSG,CDATA(818.41))=""
;Set the movement multiple
S PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
S PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
S PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
S PXIENS="?+1,"_PTFPOINT_","_PXEOCSEQ_","_PXEOCNUM_","
I $G(DGPMDA)'="" D
. S CDATA(818.41,PXIENS,.01)=DGPMDA
. D UPDATE^DIE("","CDATA","","CMPMSG")
K ^UTILITY($J,"PXCOMPACT"),DGSTDT,ADMTYP
Q
;
QUERY ;
;query the COMPACT ACT TRANSACTION LOG file and display contents
N COUNT,DATA,ICN,RECORD,REQ,REQUEST,RESP,RESPCODE,RESPDATE,ROUTINE,RSEQ,SEQ,SITE
I '$D(^DGCOMP(33.3,"B")) W !,"Data Not Available" Q
S ICN=""
F S ICN=$O(^DGCOMP(33.3,"B",ICN)) Q:ICN="" D
. S SEQ=""
. F S SEQ=$O(^DGCOMP(33.3,"B",ICN,SEQ)) Q:SEQ="" D
. . S RECORD=^DGCOMP(33.3,SEQ,0)
. . S ROUTINE=$P(RECORD,"^",2),REQUEST=$P(RECORD,"^",3),RESPCODE=$P(RECORD,"^",4),RESPDATE=$P(RECORD,"^",5)
. . S ROUTINE=$S($P(RECORD,"^",2)="":"NO ROUTINE",1:$P(RECORD,"^",2))
. . I $D(ROUTINE(ROUTINE,"ICN",ICN)) D Q
. . . S ROUTINE(ROUTINE,"ICN",ICN,$O(ROUTINE(ROUTINE,"ICN",ICN,""))+1)=REQUEST_"^"_RESPDATE_"^"_RESPCODE
. . . S ROUTINE(ROUTINE,"COUNT")=$G(ROUTINE(ROUTINE,"COUNT"))+1
. . S ROUTINE(ROUTINE,"ICN",ICN,1)=REQUEST_"^"_RESPDATE_"^"_RESPCODE,ROUTINE(ROUTINE,"COUNT")=$G(ROUTINE(ROUTINE,"COUNT"))+1
. . Q
. Q
;now display data in desired format
S SITE=$P($$SITE^VASITE,"^",1)
W !,"Site # ",SITE
S ROUTINE=""
F S ROUTINE=$O(ROUTINE(ROUTINE)) Q:ROUTINE="" D
. S COUNT=ROUTINE(ROUTINE,"COUNT")
. W !!,"Calling Routine: ",ROUTINE," Request Count: ",COUNT
. S ICN=""
. F S ICN=$O(ROUTINE(ROUTINE,"ICN",ICN)) Q:ICN="" D
. . W !,ICN
. . S RSEQ=""
. . F S RSEQ=$O(ROUTINE(ROUTINE,"ICN",ICN,RSEQ)) Q:RSEQ="" D
. . . S DATA=ROUTINE(ROUTINE,"ICN",ICN,RSEQ)
. . . S REQ=$$FMTE^XLFDT($P(DATA,"^",1)),RESP=$$FMTE^XLFDT($P(DATA,"^",2)),RESPCODE=$P(DATA,"^",3)
. . . W !," Request: ",$S($L(REQ)=18:REQ_":00",1:REQ)
. . . W !," Response: ",$S($L(RESP)=18:RESP_":00",1:RESP)," ",$TR(RESPCODE,"~","^"),!
Q
ADMIT(DFN,PTF) ;
GO N X,Y,%,CDATA,DA,DEF,ERROR,FIRSTMOVE,MOVEDT,PTFPOINT,PXIENS,PXNWSTDT,SEQCHK,STARTDT,STDT
W !!,"ADMITTED FOR ACUTE SUICIDAL CRISIS" S %=$S($$ASC^PXCOMPACT(DFN)="Y":1,1:2) D YN^DICN I %=-1 G GO
S PXEOCNUM=$$GETEOC^PXCOMPACT(DFN),PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN),PTFPOINT="",ERROR="",CDATA=""
I PTF'="" S PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
I (%=2),$$ASC^PXCOMPACT(DFN)="Y" D Q
. ;if this is the last movement in the multiple, need the 'are you sure' prompt
. I PTFPOINT="" Q
. I $$CHKMVMT(DFN,PTF)=1,$D(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,PTFPOINT,1,"B",DGPMDA)) D
. . I $$GETBENTYP^PXCOMPACT(DFN)="I" W !,"This action will end the episode. Are you sure" S %=2 D YN^DICN I %'=1 G GO
. . ;Remove movement from multiple in EOC file
. . S PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
. . S DA(3)=PXEOCNUM,DA(2)=PXEOCSEQ,DA(1)=PTFPOINT,DA=$$GETMVMT^DGCOMPACT(DFN,PTF,DGPMDA)
. . S DIK="^PXCOMP(818,"_DA(3)_",10,"_DA(2)_",40,"_DA(1)_",1,"
. . D ^DIK
. . K DA,DIK
. . ;set PTF 101 to a No
. . D SETPTFFLG(PTF,0)
. . ;set PTF 501 to a No
. . D SETPTFMVMT(PTF,"N",1)
. . I $$GETBENTYP^PXCOMPACT(DFN)="I" D REVERT(DFN,PTF) Q
. . ;Otherwise remove 40 node associating the episode with the PTF and movement (edit admission to No after patient is discharged)
. . N DA,DIK
. . S DA(2)=PXEOCNUM,DA(1)=PXEOCSEQ,DA=PTFPOINT,DIK="^PXCOMP(818,"_DA(2)_",10,"_DA(1)_",40,"
. . D ^DIK
. . K DA,DIK
. I $$CHKMVMT(DFN,PTF)>1 D
. . ;Remove movement from multiple in EOC file
. . S PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
. . S DA(3)=PXEOCNUM,DA(2)=PXEOCSEQ,DA(1)=PTFPOINT,DA=$$GETMVMT^DGCOMPACT(DFN,PTF,DGPMDA)
. . S DIK="^PXCOMP(818,"_DA(3)_",10,"_DA(2)_",40,"_DA(1)_",1,"
. . D ^DIK
. . K DA,DIK
. . ;set PTF 501 to a No
. . D SETPTFMVMT(PTF,"N",1)
. . ;reset start date (potentially) to earliest movement date
. . S FIRSTMOVE=$O(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,PTFPOINT,1,"B","")) I FIRSTMOVE="" Q
. . S MOVEDT=$P($P($G(^DGPM(FIRSTMOVE,0)),"^"),"."),STARTDT=$$GETSTDT^PXCOMPACT(DFN)
. . I MOVEDT'=STARTDT D
. . . ;check if there is a prior OP episode whose end date matches this episode's start date
. . . S SEQCHK="B"
. . . F S SEQCHK=$O(^PXCOMP(818,PXEOCNUM,10,SEQCHK),-1) Q:SEQCHK=0 D
. . . . I (SEQCHK=PXEOCSEQ)!($P(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",6)="E") Q
. . . . I $P(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",2)=STARTDT D
. . . . . S $P(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",2)=MOVEDT,$P(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",5)=MOVEDT
. . . I $$GETBENTYP^PXCOMPACT(DFN)="O" D Q
. . . . ;update start date ONLY
. . . . S PXIENS=PXEOCSEQ_","_PXEOCNUM_","
. . . . I $G(MOVEDT)'="" S CDATA(818.01,PXIENS,.01)=MOVEDT
. . . . D FILE^DIE("","CDATA")
. . . D SETSTDT^PXCOMPACT(DFN,MOVEDT)
;if admission is edited to a Yes after discharge, add movement to episode multiple and update 101
I (%=1),$G(PTF)'="",($$ASC^PXCOMPACT(DFN)="Y"),($$GETBENTYP^PXCOMPACT(DFN)="O"),($P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)'="") D I ERROR="" Q
. ;if latest sequence is error, quit
. I $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",6)="E" S ERROR=1 Q
. D VISIT^PXCOMPACT(PTF,"I",PXEOCNUM,DFN)
. S PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
. ;Set the movement multiple
. S PXIENS="?+1,"_PTFPOINT_","_PXEOCSEQ_","_PXEOCNUM_","
. I $G(DGPMDA)'="" D
. . S CDATA(818.41,PXIENS,.01)=DGPMDA
. . D UPDATE^DIE("","CDATA","","CMPMSG")
. D SETPTFMVMT(PTF,"Y",1)
;if admission is edited to a Yes AFTER a transfer is a Yes, add movement to episode multiple and update start date to admission date
I (%=1),($$ASC^PXCOMPACT(DFN)="Y"),($$GETBENTYP^PXCOMPACT(DFN)="I") D Q
. ;in the event there's no PTF associated (if PTF was removed while patient was discharged and then discharge was deleted)
. I PTFPOINT="" D VISIT^PXCOMPACT(PTF,"I",PXEOCNUM,DFN)
. S PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
. ;Set the movement multiple
. S PXIENS="?+1,"_PTFPOINT_","_PXEOCSEQ_","_PXEOCNUM_","
. I $G(DGPMDA)'="" D
. . S CDATA(818.41,PXIENS,.01)=DGPMDA
. . D UPDATE^DIE("","CDATA","","CMPMSG")
. ;now update start date
. D SETSTDT^PXCOMPACT(DFN,$P(^DGPM(DGPMDA,0),"."))
. ;set PTF 501 to Yes
. D SETPTFMVMT(PTF,"Y",1)
;otherwise, start the Inpatient episode
I %=1 D
. W !," THIS ADMISSION WILL BEGIN THE COMPACT ACT BENEFIT. ARE YOU SURE" S %=2 D YN^DICN I %'=1 G GO
I ($$ASC^PXCOMPACT(DFN)="Y"),($$GETIPDT^PXCOMPACT(DFN)'=""),($$GETBENTYP^PXCOMPACT(DFN)="O"),$$CHKMVMT(DFN,PTF)="" D
. S PXNWSTDT=$$GETSTDT^PXCOMPACT(DFN)
DT ;
I %=1 D
. I ($$ASC^PXCOMPACT(DFN)="Y"),($$GETBENTYP^PXCOMPACT(DFN)="I") Q
. W !," ACUTE SUICIDAL CRISIS START DATE?: NOW//" R STDT:30
. I $G(STDT)="" S STDT="NOW"
. D DT^DILF("",STDT,.PXNWSTDT) I PXNWSTDT=-1 W $C(7),"??",!," Invalid Date!" S %=1 G DT
. S ^UTILITY($J,"PXCOMPACT")=DFN_"^"_PXNWSTDT_"^F"
Q
;
CHKMVMT(DFN,PTF) ;
N COUNT,PTFPOINT,PXEOCNUM,PXEOCSEQ
I PTF="" Q ""
S PXEOCNUM=$$GETEOC^PXCOMPACT(DFN) I PXEOCNUM="" Q ""
S PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN) I PXEOCSEQ="" Q ""
S PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I") I PTFPOINT="" Q ""
S COUNT=$P($G(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,PTFPOINT,1,0)),"^",4)
Q COUNT
;
GETMVMT(DFN,PTF,DGPMDA) ;
N MOVE,PTFPOINT,PXEOCNUM,PXEOCSEQ
S PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
S PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
S PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
S MOVE=$O(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,PTFPOINT,1,"B",DGPMDA,""))
Q MOVE
;
REVERT(DFN,PTF,DGPMT) ;
; get EOC number
N X,Y,DA,DIK,ELIG,FLAG,FOUND,PTFPOINT,PXEOCNUM,PXEOCSEQ,PXSTARTDT,SEQCHK,STARTDT,VISIT
S PXEOCNUM=$$GETEOC^PXCOMPACT(DFN),FLAG=""
; get EOC sequence number
S PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
;before marking an episode as Entered in Error, determine if it's associated to the PTF
S PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
I PTFPOINT="" Q
;check if episode is currently Outpatient. if so, just remove 40 node associating episode with PTF and movement
;don't want to change dates
I $$GETBENTYP^PXCOMPACT(DFN)="O" D Q
. D DELPTF
;check if there are any VISITs. if so, check the date to see if it's the same as the episode start date
I $D(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,41)) D I FLAG Q
. S PXSTARTDT=$$GETSTDT^PXCOMPACT(DFN)
. S VISIT=""
. F S VISIT=$O(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,41,"B",VISIT)) Q:(VISIT="")!(FLAG) D
. . I $P($P($G(^AUPNVSIT(VISIT,0)),"^",1),".")=PXSTARTDT S FLAG=1
. I FLAG="" Q
. S $P(^PXCOMP(818,PXEOCNUM,0),"^",2)=1 ;Reset the episode of care open/close flag
. S $P(^PXCOMP(818,PXEOCNUM,0),"^",3)="O" ;Reset the Benefit Type
. S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",5)=$$FMADD^XLFDT(PXSTARTDT,90) ; Reset outpatient benefit end date
. S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)="" ;Set inpatient benefit end date to null
. ;Remove 40 node associating the episode with the PTF and movement
. D DELPTF
;Same day scenario - check if there is a prior episode. if so, check if it was an Outpatient and was closed due to this admission
S PXSTARTDT=$$GETSTDT^PXCOMPACT(DFN)
S SEQCHK="B",FOUND=""
F S SEQCHK=$O(^PXCOMP(818,PXEOCNUM,10,SEQCHK),-1) Q:(SEQCHK=0)!(FOUND) D
. I $P(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",6)="E" Q
. I $P(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",2)'=PXSTARTDT Q
. ;update fields for prior episode
. S $P(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",2)="" ;Remove the end date
. S $P(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",3)="" ;Remove the end source
. S STARTDT=$P(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",1) ;Get start date for processing
. S $P(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",5)=$$FMADD^XLFDT(STARTDT,90) ; Reset outpatient benefit end date
. I $D(^PXCOMP(818,PXEOCNUM,10,SEQCHK,1)) K ^PXCOMP(818,PXEOCNUM,10,SEQCHK,1)
. S ELIG=$$ELIG^DGCOMPACTELIG(DFN,"PXCOMPACT")
. S $P(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",8)=$S(ELIG="ELIGIBLE":"E",ELIG="NOT ELIGIBLE":"N",1:"U") ;Reset the patient eligibility
. D SETENDDT^PXCOMPACT(DFN,DT,"")
. ;mark episode as Entered in Error
. ; 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)=""
. S FOUND=1
. ;Remove 40 node associating the episode with the PTF and movement
. D DELPTF
. S $P(^PXCOMP(818,PXEOCNUM,0),"^",2)=1,$P(^PXCOMP(818,PXEOCNUM,0),"^",3)="O" ;Reset the Benefit Type
I FOUND Q
;Remove 40 node associating the episode with the PTF and movement
D DELPTF
; otherwise, it's a stand alone episode that needs to be marked as Entered in Error
; Set the EPISODE FINAL STATUS to Entered in Error (E) and EPISODE SOURCE to NULL
D SETENDDT^PXCOMPACT(DFN,DT,"")
S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",6)="E",$P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",7)=""
Q
DELPTF ;
;repeatable function to remove 40 node associating episode with the PTF and movement
N DA,DIK
S DA(2)=PXEOCNUM,DA(1)=PXEOCSEQ,DA=PTFPOINT,DIK="^PXCOMP(818,"_DA(2)_",10,"_DA(1)_",40,"
D ^DIK
K DA,DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGCOMPACT 12765 printed Jan 29, 2026@15:40:07 Page 2
DGCOMPACT ;ALB/BPA,CMC - Routine for COMPACT Act processing the DG;12/18/2023@9:26am
+1 ;;5.3;Registration;**1104,1117**;Aug 13, 1993;Build 32
+2 ; *1104* APIs for COMPACT Act processing
+3 ; Reference to VISIT^PXCOMPACT in ICR #7327
+4 ;
SETPTFFLG(DGENC,DGVAL) ;
+1 ; API to set TRT FOR ACUTE SUICIDAL CRISIS flag in PTF 101
+2 ; DGENC - Encounter ID (PTF IEN)
+3 ; DGVAL - Value to set into flag
+4 ; For YES: D SETPTFFLG^DGCOMPACT(DGENC,1)
+5 ; For NO: D SETPTFFLG^DGCOMPACT(DGENC,0)
+6 ; For NULL: D SETPTFFLG^DGCOMPACT(DGENC,"")
+7 ; Create a 70 level in the PTF file if it is not set
+8 IF $GET(^DGPT(DGENC,70))=""
SET ^DGPT(DGENC,70)=""
+9 SET $PIECE(^DGPT(DGENC,70),"^",33)=DGVAL
+10 QUIT
+11 ;
SETPTFMVMT(DGENC,DGVAL,DGSEQ) ;
+1 ; API to set TREATMENT FOR SUICIDAL CRISIS flag in PTF 501
+2 ; DGENC - Encounter ID (PTF IEN)
+3 ; DGVAL - Value to set into flag
+4 ; DGSEQ - Movement sequence *not required
+5 ; For YES: D SETPTFMVMT^DGCOMPACT(DGENC,"Y",DGSEQ)
+6 ; For NO: D SETPTFMVMT^DGCOMPACT(DGENC,"N",DGSEQ)
+7 ; For NULL: D SETPTFMVMT^DGCOMPACT(DGENC,"",DGSEQ)
+8 ; When setting a sequence other than the first one, pass the sequence number
+9 IF $GET(DGSEQ)'=""
SET $PIECE(^DGPT(DGENC,"M",DGSEQ,0),"^",33)=DGVAL
+10 ; Whenever a new movement is created for a PTF, it becomes the 1 node of the subfile.
+11 IF '$TEST
SET $PIECE(^DGPT(DGENC,"M",1,0),"^",33)=DGVAL
+12 QUIT
+13 ;
EDITADMIT(PTF) ;
+1 NEW ADMTYP,CDATA,CMPMSG,DFN,DGSTDT,PXIENS
+2 SET DFN=$PIECE(^UTILITY($JOB,"PXCOMPACT"),"^",1)
SET DGSTDT=$PIECE(^UTILITY($JOB,"PXCOMPACT"),"^",2)
SET ADMTYP=$PIECE(^UTILITY($JOB,"PXCOMPACT"),"^",3)
+3 DO ADMIT^PXCOMPACT(DFN,DGSTDT,ADMTYP,PTF)
+4 SET (CMPMSG,CDATA(818.41))=""
+5 ;Set the movement multiple
+6 SET PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
+7 SET PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
+8 SET PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
+9 SET PXIENS="?+1,"_PTFPOINT_","_PXEOCSEQ_","_PXEOCNUM_","
+10 IF $GET(DGPMDA)'=""
Begin DoDot:1
+11 SET CDATA(818.41,PXIENS,.01)=DGPMDA
+12 DO UPDATE^DIE("","CDATA","","CMPMSG")
End DoDot:1
+13 KILL ^UTILITY($JOB,"PXCOMPACT"),DGSTDT,ADMTYP
+14 QUIT
+15 ;
QUERY ;
+1 ;query the COMPACT ACT TRANSACTION LOG file and display contents
+2 NEW COUNT,DATA,ICN,RECORD,REQ,REQUEST,RESP,RESPCODE,RESPDATE,ROUTINE,RSEQ,SEQ,SITE
+3 IF '$DATA(^DGCOMP(33.3,"B"))
WRITE !,"Data Not Available"
QUIT
+4 SET ICN=""
+5 FOR
SET ICN=$ORDER(^DGCOMP(33.3,"B",ICN))
if ICN=""
QUIT
Begin DoDot:1
+6 SET SEQ=""
+7 FOR
SET SEQ=$ORDER(^DGCOMP(33.3,"B",ICN,SEQ))
if SEQ=""
QUIT
Begin DoDot:2
+8 SET RECORD=^DGCOMP(33.3,SEQ,0)
+9 SET ROUTINE=$PIECE(RECORD,"^",2)
SET REQUEST=$PIECE(RECORD,"^",3)
SET RESPCODE=$PIECE(RECORD,"^",4)
SET RESPDATE=$PIECE(RECORD,"^",5)
+10 SET ROUTINE=$SELECT($PIECE(RECORD,"^",2)="":"NO ROUTINE",1:$PIECE(RECORD,"^",2))
+11 IF $DATA(ROUTINE(ROUTINE,"ICN",ICN))
Begin DoDot:3
+12 SET ROUTINE(ROUTINE,"ICN",ICN,$ORDER(ROUTINE(ROUTINE,"ICN",ICN,""))+1)=REQUEST_"^"_RESPDATE_"^"_RESPCODE
+13 SET ROUTINE(ROUTINE,"COUNT")=$GET(ROUTINE(ROUTINE,"COUNT"))+1
End DoDot:3
QUIT
+14 SET ROUTINE(ROUTINE,"ICN",ICN,1)=REQUEST_"^"_RESPDATE_"^"_RESPCODE
SET ROUTINE(ROUTINE,"COUNT")=$GET(ROUTINE(ROUTINE,"COUNT"))+1
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 ;now display data in desired format
+18 SET SITE=$PIECE($$SITE^VASITE,"^",1)
+19 WRITE !,"Site # ",SITE
+20 SET ROUTINE=""
+21 FOR
SET ROUTINE=$ORDER(ROUTINE(ROUTINE))
if ROUTINE=""
QUIT
Begin DoDot:1
+22 SET COUNT=ROUTINE(ROUTINE,"COUNT")
+23 WRITE !!,"Calling Routine: ",ROUTINE," Request Count: ",COUNT
+24 SET ICN=""
+25 FOR
SET ICN=$ORDER(ROUTINE(ROUTINE,"ICN",ICN))
if ICN=""
QUIT
Begin DoDot:2
+26 WRITE !,ICN
+27 SET RSEQ=""
+28 FOR
SET RSEQ=$ORDER(ROUTINE(ROUTINE,"ICN",ICN,RSEQ))
if RSEQ=""
QUIT
Begin DoDot:3
+29 SET DATA=ROUTINE(ROUTINE,"ICN",ICN,RSEQ)
+30 SET REQ=$$FMTE^XLFDT($PIECE(DATA,"^",1))
SET RESP=$$FMTE^XLFDT($PIECE(DATA,"^",2))
SET RESPCODE=$PIECE(DATA,"^",3)
+31 WRITE !," Request: ",$SELECT($LENGTH(REQ)=18:REQ_":00",1:REQ)
+32 WRITE !," Response: ",$SELECT($LENGTH(RESP)=18:RESP_":00",1:RESP)," ",$TRANSLATE(RESPCODE,"~","^"),!
End DoDot:3
End DoDot:2
End DoDot:1
+33 QUIT
ADMIT(DFN,PTF) ;
GO NEW X,Y,%,CDATA,DA,DEF,ERROR,FIRSTMOVE,MOVEDT,PTFPOINT,PXIENS,PXNWSTDT,SEQCHK,STARTDT,STDT
+1 WRITE !!,"ADMITTED FOR ACUTE SUICIDAL CRISIS"
SET %=$SELECT($$ASC^PXCOMPACT(DFN)="Y":1,1:2)
DO YN^DICN
IF %=-1
GOTO GO
+2 SET PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
SET PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
SET PTFPOINT=""
SET ERROR=""
SET CDATA=""
+3 IF PTF'=""
SET PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
+4 IF (%=2)
IF $$ASC^PXCOMPACT(DFN)="Y"
Begin DoDot:1
+5 ;if this is the last movement in the multiple, need the 'are you sure' prompt
+6 IF PTFPOINT=""
QUIT
+7 IF $$CHKMVMT(DFN,PTF)=1
IF $DATA(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,PTFPOINT,1,"B",DGPMDA))
Begin DoDot:2
+8 IF $$GETBENTYP^PXCOMPACT(DFN)="I"
WRITE !,"This action will end the episode. Are you sure"
SET %=2
DO YN^DICN
IF %'=1
GOTO GO
+9 ;Remove movement from multiple in EOC file
+10 SET PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
+11 SET DA(3)=PXEOCNUM
SET DA(2)=PXEOCSEQ
SET DA(1)=PTFPOINT
SET DA=$$GETMVMT^DGCOMPACT(DFN,PTF,DGPMDA)
+12 SET DIK="^PXCOMP(818,"_DA(3)_",10,"_DA(2)_",40,"_DA(1)_",1,"
+13 DO ^DIK
+14 KILL DA,DIK
+15 ;set PTF 101 to a No
+16 DO SETPTFFLG(PTF,0)
+17 ;set PTF 501 to a No
+18 DO SETPTFMVMT(PTF,"N",1)
+19 IF $$GETBENTYP^PXCOMPACT(DFN)="I"
DO REVERT(DFN,PTF)
QUIT
+20 ;Otherwise remove 40 node associating the episode with the PTF and movement (edit admission to No after patient is discharged)
+21 NEW DA,DIK
+22 SET DA(2)=PXEOCNUM
SET DA(1)=PXEOCSEQ
SET DA=PTFPOINT
SET DIK="^PXCOMP(818,"_DA(2)_",10,"_DA(1)_",40,"
+23 DO ^DIK
+24 KILL DA,DIK
End DoDot:2
+25 IF $$CHKMVMT(DFN,PTF)>1
Begin DoDot:2
+26 ;Remove movement from multiple in EOC file
+27 SET PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
+28 SET DA(3)=PXEOCNUM
SET DA(2)=PXEOCSEQ
SET DA(1)=PTFPOINT
SET DA=$$GETMVMT^DGCOMPACT(DFN,PTF,DGPMDA)
+29 SET DIK="^PXCOMP(818,"_DA(3)_",10,"_DA(2)_",40,"_DA(1)_",1,"
+30 DO ^DIK
+31 KILL DA,DIK
+32 ;set PTF 501 to a No
+33 DO SETPTFMVMT(PTF,"N",1)
+34 ;reset start date (potentially) to earliest movement date
+35 SET FIRSTMOVE=$ORDER(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,PTFPOINT,1,"B",""))
IF FIRSTMOVE=""
QUIT
+36 SET MOVEDT=$PIECE($PIECE($GET(^DGPM(FIRSTMOVE,0)),"^"),".")
SET STARTDT=$$GETSTDT^PXCOMPACT(DFN)
+37 IF MOVEDT'=STARTDT
Begin DoDot:3
+38 ;check if there is a prior OP episode whose end date matches this episode's start date
+39 SET SEQCHK="B"
+40 FOR
SET SEQCHK=$ORDER(^PXCOMP(818,PXEOCNUM,10,SEQCHK),-1)
if SEQCHK=0
QUIT
Begin DoDot:4
+41 IF (SEQCHK=PXEOCSEQ)!($PIECE(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",6)="E")
QUIT
+42 IF $PIECE(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",2)=STARTDT
Begin DoDot:5
+43 SET $PIECE(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",2)=MOVEDT
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",5)=MOVEDT
End DoDot:5
End DoDot:4
+44 IF $$GETBENTYP^PXCOMPACT(DFN)="O"
Begin DoDot:4
+45 ;update start date ONLY
+46 SET PXIENS=PXEOCSEQ_","_PXEOCNUM_","
+47 IF $GET(MOVEDT)'=""
SET CDATA(818.01,PXIENS,.01)=MOVEDT
+48 DO FILE^DIE("","CDATA")
End DoDot:4
QUIT
+49 DO SETSTDT^PXCOMPACT(DFN,MOVEDT)
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+50 ;if admission is edited to a Yes after discharge, add movement to episode multiple and update 101
+51 IF (%=1)
IF $GET(PTF)'=""
IF ($$ASC^PXCOMPACT(DFN)="Y")
IF ($$GETBENTYP^PXCOMPACT(DFN)="O")
IF ($PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)'="")
Begin DoDot:1
+52 ;if latest sequence is error, quit
+53 IF $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",6)="E"
SET ERROR=1
QUIT
+54 DO VISIT^PXCOMPACT(PTF,"I",PXEOCNUM,DFN)
+55 SET PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
+56 ;Set the movement multiple
+57 SET PXIENS="?+1,"_PTFPOINT_","_PXEOCSEQ_","_PXEOCNUM_","
+58 IF $GET(DGPMDA)'=""
Begin DoDot:2
+59 SET CDATA(818.41,PXIENS,.01)=DGPMDA
+60 DO UPDATE^DIE("","CDATA","","CMPMSG")
End DoDot:2
+61 DO SETPTFMVMT(PTF,"Y",1)
End DoDot:1
IF ERROR=""
QUIT
+62 ;if admission is edited to a Yes AFTER a transfer is a Yes, add movement to episode multiple and update start date to admission date
+63 IF (%=1)
IF ($$ASC^PXCOMPACT(DFN)="Y")
IF ($$GETBENTYP^PXCOMPACT(DFN)="I")
Begin DoDot:1
+64 ;in the event there's no PTF associated (if PTF was removed while patient was discharged and then discharge was deleted)
+65 IF PTFPOINT=""
DO VISIT^PXCOMPACT(PTF,"I",PXEOCNUM,DFN)
+66 SET PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
+67 ;Set the movement multiple
+68 SET PXIENS="?+1,"_PTFPOINT_","_PXEOCSEQ_","_PXEOCNUM_","
+69 IF $GET(DGPMDA)'=""
Begin DoDot:2
+70 SET CDATA(818.41,PXIENS,.01)=DGPMDA
+71 DO UPDATE^DIE("","CDATA","","CMPMSG")
End DoDot:2
+72 ;now update start date
+73 DO SETSTDT^PXCOMPACT(DFN,$PIECE(^DGPM(DGPMDA,0),"."))
+74 ;set PTF 501 to Yes
+75 DO SETPTFMVMT(PTF,"Y",1)
End DoDot:1
QUIT
+76 ;otherwise, start the Inpatient episode
+77 IF %=1
Begin DoDot:1
+78 WRITE !," THIS ADMISSION WILL BEGIN THE COMPACT ACT BENEFIT. ARE YOU SURE"
SET %=2
DO YN^DICN
IF %'=1
GOTO GO
End DoDot:1
+79 IF ($$ASC^PXCOMPACT(DFN)="Y")
IF ($$GETIPDT^PXCOMPACT(DFN)'="")
IF ($$GETBENTYP^PXCOMPACT(DFN)="O")
IF $$CHKMVMT(DFN,PTF)=""
Begin DoDot:1
+80 SET PXNWSTDT=$$GETSTDT^PXCOMPACT(DFN)
End DoDot:1
DT ;
+1 IF %=1
Begin DoDot:1
+2 IF ($$ASC^PXCOMPACT(DFN)="Y")
IF ($$GETBENTYP^PXCOMPACT(DFN)="I")
QUIT
+3 WRITE !," ACUTE SUICIDAL CRISIS START DATE?: NOW//"
READ STDT:30
+4 IF $GET(STDT)=""
SET STDT="NOW"
+5 DO DT^DILF("",STDT,.PXNWSTDT)
IF PXNWSTDT=-1
WRITE $CHAR(7),"??",!," Invalid Date!"
SET %=1
GOTO DT
+6 SET ^UTILITY($JOB,"PXCOMPACT")=DFN_"^"_PXNWSTDT_"^F"
End DoDot:1
+7 QUIT
+8 ;
CHKMVMT(DFN,PTF) ;
+1 NEW COUNT,PTFPOINT,PXEOCNUM,PXEOCSEQ
+2 IF PTF=""
QUIT ""
+3 SET PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
IF PXEOCNUM=""
QUIT ""
+4 SET PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
IF PXEOCSEQ=""
QUIT ""
+5 SET PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
IF PTFPOINT=""
QUIT ""
+6 SET COUNT=$PIECE($GET(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,PTFPOINT,1,0)),"^",4)
+7 QUIT COUNT
+8 ;
GETMVMT(DFN,PTF,DGPMDA) ;
+1 NEW MOVE,PTFPOINT,PXEOCNUM,PXEOCSEQ
+2 SET PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
+3 SET PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
+4 SET PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
+5 SET MOVE=$ORDER(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,PTFPOINT,1,"B",DGPMDA,""))
+6 QUIT MOVE
+7 ;
REVERT(DFN,PTF,DGPMT) ;
+1 ; get EOC number
+2 NEW X,Y,DA,DIK,ELIG,FLAG,FOUND,PTFPOINT,PXEOCNUM,PXEOCSEQ,PXSTARTDT,SEQCHK,STARTDT,VISIT
+3 SET PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
SET FLAG=""
+4 ; get EOC sequence number
+5 SET PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
+6 ;before marking an episode as Entered in Error, determine if it's associated to the PTF
+7 SET PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
+8 IF PTFPOINT=""
QUIT
+9 ;check if episode is currently Outpatient. if so, just remove 40 node associating episode with PTF and movement
+10 ;don't want to change dates
+11 IF $$GETBENTYP^PXCOMPACT(DFN)="O"
Begin DoDot:1
+12 DO DELPTF
End DoDot:1
QUIT
+13 ;check if there are any VISITs. if so, check the date to see if it's the same as the episode start date
+14 IF $DATA(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,41))
Begin DoDot:1
+15 SET PXSTARTDT=$$GETSTDT^PXCOMPACT(DFN)
+16 SET VISIT=""
+17 FOR
SET VISIT=$ORDER(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,41,"B",VISIT))
if (VISIT="")!(FLAG)
QUIT
Begin DoDot:2
+18 IF $PIECE($PIECE($GET(^AUPNVSIT(VISIT,0)),"^",1),".")=PXSTARTDT
SET FLAG=1
End DoDot:2
+19 IF FLAG=""
QUIT
+20 ;Reset the episode of care open/close flag
SET $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",2)=1
+21 ;Reset the Benefit Type
SET $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",3)="O"
+22 ; Reset outpatient benefit end date
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",5)=$$FMADD^XLFDT(PXSTARTDT,90)
+23 ;Set inpatient benefit end date to null
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)=""
+24 ;Remove 40 node associating the episode with the PTF and movement
+25 DO DELPTF
End DoDot:1
IF FLAG
QUIT
+26 ;Same day scenario - check if there is a prior episode. if so, check if it was an Outpatient and was closed due to this admission
+27 SET PXSTARTDT=$$GETSTDT^PXCOMPACT(DFN)
+28 SET SEQCHK="B"
SET FOUND=""
+29 FOR
SET SEQCHK=$ORDER(^PXCOMP(818,PXEOCNUM,10,SEQCHK),-1)
if (SEQCHK=0)!(FOUND)
QUIT
Begin DoDot:1
+30 IF $PIECE(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",6)="E"
QUIT
+31 IF $PIECE(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",2)'=PXSTARTDT
QUIT
+32 ;update fields for prior episode
+33 ;Remove the end date
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",2)=""
+34 ;Remove the end source
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",3)=""
+35 ;Get start date for processing
SET STARTDT=$PIECE(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",1)
+36 ; Reset outpatient benefit end date
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",5)=$$FMADD^XLFDT(STARTDT,90)
+37 IF $DATA(^PXCOMP(818,PXEOCNUM,10,SEQCHK,1))
KILL ^PXCOMP(818,PXEOCNUM,10,SEQCHK,1)
+38 SET ELIG=$$ELIG^DGCOMPACTELIG(DFN,"PXCOMPACT")
+39 ;Reset the patient eligibility
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",8)=$SELECT(ELIG="ELIGIBLE":"E",ELIG="NOT ELIGIBLE":"N",1:"U")
+40 DO SETENDDT^PXCOMPACT(DFN,DT,"")
+41 ;mark episode as Entered in Error
+42 ; Set the EPISODE FINAL STATUS to Entered in Error (E) and EPISODE SOURCE to NULL
+43 SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",6)="E"
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",7)=""
+44 SET FOUND=1
+45 ;Remove 40 node associating the episode with the PTF and movement
+46 DO DELPTF
+47 ;Reset the Benefit Type
SET $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",2)=1
SET $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",3)="O"
End DoDot:1
+48 IF FOUND
QUIT
+49 ;Remove 40 node associating the episode with the PTF and movement
+50 DO DELPTF
+51 ; otherwise, it's a stand alone episode that needs to be marked as Entered in Error
+52 ; Set the EPISODE FINAL STATUS to Entered in Error (E) and EPISODE SOURCE to NULL
+53 DO SETENDDT^PXCOMPACT(DFN,DT,"")
+54 SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",6)="E"
SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",7)=""
+55 QUIT
DELPTF ;
+1 ;repeatable function to remove 40 node associating episode with the PTF and movement
+2 NEW DA,DIK
+3 SET DA(2)=PXEOCNUM
SET DA(1)=PXEOCSEQ
SET DA=PTFPOINT
SET DIK="^PXCOMP(818,"_DA(2)_",10,"_DA(1)_",40,"
+4 DO ^DIK
+5 KILL DA,DIK
+6 QUIT
