DGCOMPACT ;ALB/BPA,CMC - Routine for COMPACT Act processing the DG;12/18/2023@9:26am
;;5.3;Registration;**1104**;Aug 13, 1993;Build 59
; *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,DFN,DGSTDT
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)
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 %,DA,DEF,PXNWSTDT,STDT
W !!,"ADMITTED FOR ACUTE SUICIDAL CRISIS" S %=2 D YN^DICN I %=-1 G GO
I (%=2),($G(PTF)'="") D RETRACT^PXCOMPACTEOC(DFN,PTF)
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") D
. S PXNWSTDT=$$GETSTDT^PXCOMPACT(DFN)
DT ;
I %=1 D
. 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGCOMPACT 3963 printed Sep 23, 2025@20:17:32 Page 2
DGCOMPACT ;ALB/BPA,CMC - Routine for COMPACT Act processing the DG;12/18/2023@9:26am
+1 ;;5.3;Registration;**1104**;Aug 13, 1993;Build 59
+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,DFN,DGSTDT
+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 KILL ^UTILITY($JOB,"PXCOMPACT"),DGSTDT,ADMTYP
+5 QUIT
+6 ;
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 %,DA,DEF,PXNWSTDT,STDT
+1 WRITE !!,"ADMITTED FOR ACUTE SUICIDAL CRISIS"
SET %=2
DO YN^DICN
IF %=-1
GOTO GO
+2 IF (%=2)
IF ($GET(PTF)'="")
DO RETRACT^PXCOMPACTEOC(DFN,PTF)
+3 IF %=1
Begin DoDot:1
+4 WRITE !," THIS ADMISSION WILL BEGIN THE COMPACT ACT BENEFIT. ARE YOU SURE"
SET %=2
DO YN^DICN
IF %'=1
GOTO GO
End DoDot:1
+5 IF ($$ASC^PXCOMPACT(DFN)="Y")
IF ($$GETIPDT^PXCOMPACT(DFN)'="")
IF ($$GETBENTYP^PXCOMPACT(DFN)="O")
Begin DoDot:1
+6 SET PXNWSTDT=$$GETSTDT^PXCOMPACT(DFN)
End DoDot:1
DT ;
+1 IF %=1
Begin DoDot:1
+2 WRITE !," ACUTE SUICIDAL CRISIS START DATE?: NOW//"
READ STDT:30
+3 IF $GET(STDT)=""
SET STDT="NOW"
+4 DO DT^DILF("",STDT,.PXNWSTDT)
IF PXNWSTDT=-1
WRITE $CHAR(7),"??",!," Invalid Date!"
SET %=1
GOTO DT
+5 SET ^UTILITY($JOB,"PXCOMPACT")=DFN_"^"_PXNWSTDT_"^F"
End DoDot:1
+6 QUIT
