- 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 Feb 19, 2025@00:07:43 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