DGPMV36 ;ALB/MIR - TREATING SPECIALTY TRANSFER, CONTINUED ; 8/6/04 10:17am
;;5.3;Registration;**1104,1117**;Aug 13, 1993;Build 32
; Reference to NEWEOC^PXCOMPACT, $$ASC^PXCOMPACT, $$GETEOCSEQ^PXCOMPACT, and $$GETSTDT^PXCOMPACT in ICR #7327
;
I '$P(DGPMA,"^",9) S DGPMA="",DIK="^DGPM(",DA=DGPMDA D ^DIK K DIK W !,"Incomplete Treating Specialty Transfer...Deleted"
Q
;
DICS ; -- check that it is a PROVIDER/SPECIALTY change
S DGER=DGPMTYP'=20
Q
;
ONLY ; -- determine if there is only one 'specialty xfr' type mvt
N C,I S C=0
F I=0:0 S I=$O(^DG(405.1,"AT",6,I)) Q:'I I $D(^DG(405.1,I,0)),$P(^(0),"^",4) S C=C+1,DGPMSPI=I I C>1 K DGPMSPI Q
Q
;
SPEC ; -- entry point to add/edit specialty mvt when adding/editing
; a physical mvt
;
; Input: Y = ifn of mvt file ^ auto add specialty entry(1)
; Output: Y = ifn of spec mvt
;
; Variable: DGPMPHY = physical mvt IFN ; DGPMPHY0 = 0th node
; DGPMSP = specialty mvt IFN
;
Q:'$D(^DGPM(+Y,0))
N DGPMT,DGPMN S DGPMPHY=+Y,DGPMPHY0=^DGPM(+Y,0),DGPMT=6,DGPMN=0
S DGPMSP=$S($D(^DGPM("APHY",DGPMPHY)):$O(^(DGPMPHY,0)),1:"")
I 'DGPMSP S Y=+$P(Y,"^",2) D ASK:'Y G SPECQ:'Y D NEW
D EDIT:DGPMSP
;Only call if doing a transfer
I DGPMUC'="ADMISSION",$G(PTF)'="",$$ELIG^DGCOMPACTELIG(DFN,"DGPMV36")'="NOT ELIGIBLE" D COMPACT
SPECQ S Y=DGPMSP K DGPMPHY,DGPMPHY0,DGPMSP Q
;
ASK ; -- ask user if they want to make a special mvt also
W ! S DIR(0)="YA",DIR("A")="Do you wish to associate a 'facility treating specialty' transfer? "
S DIR("?",1)="If you would like to associate a facility specialty"
S DIR("?",2)="transfer with this physical movement then answer 'Yes'."
S DIR("?")="Otherwise, answer with a 'No'."
D ^DIR K DIR
Q
;
COMPACT ; -- ask user if the treatment for the movement was for Acute Suicidal Crisis
N %,CDATA,CMPMSG,DGVAL,ERROR,FIRSTMOVE,FLIP,MOVEDT,MOVESEQ,MVMTVAL,PTFPOINT,PXEOCNUM,PXEOCSEQ,PXIENS,SEQCHK,STARTDT,X,Y
W !,"Was Treatment for Acute Suicidal Crisis" S %=$S($$ASC^PXCOMPACT(DFN)="Y":1,1:2) D YN^DICN I %=-1 W !,"Answer must be 'Yes' or 'No'" G COMPACT
S PXEOCNUM=$$GETEOC^PXCOMPACT(DFN),CDATA=""
; get EOC sequence number
S PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
S PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
I (%=2),$$ASC^PXCOMPACT(DFN)="Y" D Q
. ;before marking an episode as an error, determine if this movement is the last one in the multiple
. I $$CHKMVMT^DGCOMPACT(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 COMPACT Act benefit. Are you sure" S %=2 D YN^DICN I %'=1 G COMPACT
. . ;set PTF 101 to a No
. . D SETPTFFLG^DGCOMPACT(PTF,0)
. . ;set 501 to No
. . I DGPMY'="" D
. . . S MOVESEQ=$O(^DGPT(PTF,"M","AM",DGPMY,"")) I MOVESEQ="" Q
. . . D SETPTFMVMT^DGCOMPACT(PTF,"N",MOVESEQ)
. . D REVERT^DGCOMPACT(DFN,PTF)
. . ;I $$GETBENTYP^PXCOMPACT(DFN)="I" D REVERT^DGCOMPACT(DFN,PTF)
. I $$CHKMVMT^DGCOMPACT(DFN,PTF)>1 D
. . ;Remove movement from multiple in EOC file
. . S PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
. . S PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
. . 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
. . I DGPMY'="" D
. . . S MOVESEQ=$O(^DGPT(PTF,"M","AM",DGPMY,"")) I MOVESEQ="" Q
. . . D SETPTFMVMT^DGCOMPACT(PTF,"N",MOVESEQ)
. . ;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 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 yes AND there's a current inpatient episode, add the movement to the episode and set the 501 to Yes
I ($$ASC^PXCOMPACT(DFN)="Y"),($$GETBENTYP^PXCOMPACT(DFN)="I") D Q
. S (CMPMSG,CDATA(818.41))=""
. ;Set the movement multiple
. 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")
. ;set 501 to Yes
. I DGPMY'="" D
. . S MOVESEQ=$O(^DGPT(PTF,"M","AM",DGPMY,"")) I MOVESEQ="" Q
. . D SETPTFMVMT^DGCOMPACT(PTF,"Y",MOVESEQ)
. S ^UTILITY($J,"PXCOMPACT-TRANS")=""
I %=1 D
. W !,"THIS MOVEMENT WILL BEGIN THE COMPACT ACT BENEFIT. ARE YOU SURE" S %=2 D YN^DICN I %'=1 G COMPACT
. S DGVAL=$S(%=1:1,1:0),MVMTVAL=$S(%=1:"Y",1:"N"),STARTDT="",ERROR="",FLIP=""
. ;get start date of last valid episode
. S STARTDT=$$GETSTDT^PXCOMPACT(DFN)
. ;handle scenario where current episode is Outpatient
. I $$ASC^PXCOMPACT(DFN)="Y",$P(^PXCOMP(818,PXEOCNUM,0),"^",3)="O",$$CHKMVMT^DGCOMPACT(DFN,PTF)="" D
. . ;first check if date belongs to a different sequence (that possibly errored)
. . S PXEOCSEQ=$O(^PXCOMP(818,PXEOCNUM,10,"B",$P(DGPMY,"."),""))
. . I PXEOCSEQ'="",$P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",6)="E" S ERROR=1
. . ;same day processing, flip episode to Inpatient
. . I $P(DGPMY,".")=STARTDT,'ERROR D
. . . S $P(^PXCOMP(818,PXEOCNUM,0),"^",3)="I"
. . . S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)=$$FMADD^XLFDT($P(DGPMY,"."),29)
. . . S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",5)=""
. . . S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",7)="A"
. . . D VISIT^PXCOMPACT(PTF,"I",PXEOCNUM,DFN)
. . . S FLIP=1
. . ;non-same day processing, end OP episode and create new IP episode using the date provided
. . I $P(DGPMY,".")'=STARTDT,'ERROR D
. . . D SETENDDT^PXCOMPACT(DFN,$P(DGPMY,"."),"PR")
. . . D NEWEOC^PXCOMPACT(DFN,PTF,"I",$P(DGPMY,"."))
. . . S FLIP=1
. ;reopen episode of care if the transfer date is on the same date as an Entered in Error episode
. I PXEOCNUM'="",$D(^PXCOMP(818,PXEOCNUM,10,"B",$P(DGPMY,"."))),'FLIP D
. . D SETENDDT^PXCOMPACT(DFN,$P(DGPMY,"."),"PR")
. . S PXEOCSEQ=$O(^PXCOMP(818,PXEOCNUM,10,"B",$P(DGPMY,"."),"")) I PXEOCSEQ="" Q
. . D REOPNEOC^PXCOMPACT(PXEOCNUM,PXEOCSEQ,""),VISIT^PXCOMPACT(PTF,"I",PXEOCNUM,DFN)
. ;Reopen episode of care if the PTF is already associated with an episode and not currently in a crisis
. I PXEOCNUM'="",PXEOCSEQ'="",$D(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,"B",PTF)),$$ASC^PXCOMPACT(DFN)="N" D
. . D REOPNEOC^PXCOMPACT(PXEOCNUM,PXEOCSEQ,STARTDT)
. ;otherwise start a new episode
. I $$ASC^PXCOMPACT(DFN)="N" D NEWEOC^PXCOMPACT(DFN,PTF,"I",$P(DGPMY,"."))
. D SETPTFFLG^DGCOMPACT(PTF,DGVAL)
. S PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
. S PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
. S (CMPMSG,CDATA(818.41))=""
. ;Set the movement multiple
. 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")
. S ^UTILITY($J,"PXCOMPACT-TRANS")=""
. ;set 501 to Yes
. I DGPMY'="" D
. . S MOVESEQ=$O(^DGPT(PTF,"M","AM",DGPMY,"")) I MOVESEQ="" Q
. . D SETPTFMVMT^DGCOMPACT(PTF,"Y",MOVESEQ)
Q
;
NEW ; -- add a specialty mvt
S X=DGPMPHY0,Y=+X_U_DGPMT_U_$P(X,U,3),$P(Y,U,14)=$P(X,U,14),$P(Y,U,24)=DGPMPHY
S X=+X,DGPM0ND=Y D NEW^DGPMV3
S DGPMSP=$S(+Y>0:+Y,1:"") S DGPMN=(+Y>0)
I DGPMSP,$P(DGPMPHY0,"^",2)=1,$P(DGPMPHY0,"^",10)]"" S DR="99///"_$P(DGPMPHY0,"^",10),DA=DGPMSP,DIE="^DGPM(" D ^DIE
K DIE,DIC,DA,DR,DGPM0ND
Q
EDIT ; -- edit specialty mvt
N DGPMX,DGPMP
I DGPMN S (DGPMP,^UTILITY("DGPM",$J,6,DGPMSP,"P"))="",DIE("NO^")=""
I 'DGPMN S (DGPMP,^UTILITY("DGPM",$J,6,DGPMSP,"P"))=^DGPM(DGPMSP,0)
S Y=DGPMSP D PRIOR
S DGPMN=(+DGPMP=+DGPMPHY0) ;set to 1 no dt/time change to bypass x-refs
S DGPMX=+DGPMPHY0,DA=DGPMSP,DIE="^DGPM(",DR="[DGPM SPECIALTY TRANSFER]"
K DQ,DG D ^DIE
S ^UTILITY("DGPM",$J,6,DGPMSP,"A")=$S($D(^DGPM(DGPMSP,0)):^(0),1:"")
S Y=DGPMSP D AFTER
Q
;
PRIOR ; -- set special 'prior' nodes for event driver
I DGPMN S (^UTILITY("DGPM",$J,6,Y,"DXP"),^("PTFP"))=""
I 'DGPMN S X=$P($S($D(^DGPM(Y,"DX",0)):^(0),1:""),"^",3,4),X=X_$S($D(^(1,0)):$E(^(0),1,245-$L(X)),1:""),^UTILITY("DGPM",$J,6,Y,"DXP")=X,^UTILITY("DGPM",$J,6,Y,"PTFP")=$S($D(^DGPM(Y,"PTF")):^("PTF"),1:"")
Q
;
AFTER ; -- set special 'after' nodes for event driver
S X=$P($S($D(^DGPM(Y,"DX",0)):^(0),1:""),"^",3,4),X=X_$S($D(^(1,0)):$E(^(0),1,245-$L(X)),1:""),^UTILITY("DGPM",$J,6,Y,"DXA")=X,^UTILITY("DGPM",$J,6,Y,"PTFA")=$S($D(^DGPM(Y,"PTF")):^("PTF"),1:"")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMV36 9216 printed Jan 29, 2026@15:48:50 Page 2
DGPMV36 ;ALB/MIR - TREATING SPECIALTY TRANSFER, CONTINUED ; 8/6/04 10:17am
+1 ;;5.3;Registration;**1104,1117**;Aug 13, 1993;Build 32
+2 ; Reference to NEWEOC^PXCOMPACT, $$ASC^PXCOMPACT, $$GETEOCSEQ^PXCOMPACT, and $$GETSTDT^PXCOMPACT in ICR #7327
+3 ;
+4 IF '$PIECE(DGPMA,"^",9)
SET DGPMA=""
SET DIK="^DGPM("
SET DA=DGPMDA
DO ^DIK
KILL DIK
WRITE !,"Incomplete Treating Specialty Transfer...Deleted"
+5 QUIT
+6 ;
DICS ; -- check that it is a PROVIDER/SPECIALTY change
+1 SET DGER=DGPMTYP'=20
+2 QUIT
+3 ;
ONLY ; -- determine if there is only one 'specialty xfr' type mvt
+1 NEW C,I
SET C=0
+2 FOR I=0:0
SET I=$ORDER(^DG(405.1,"AT",6,I))
if 'I
QUIT
IF $DATA(^DG(405.1,I,0))
IF $PIECE(^(0),"^",4)
SET C=C+1
SET DGPMSPI=I
IF C>1
KILL DGPMSPI
QUIT
+3 QUIT
+4 ;
SPEC ; -- entry point to add/edit specialty mvt when adding/editing
+1 ; a physical mvt
+2 ;
+3 ; Input: Y = ifn of mvt file ^ auto add specialty entry(1)
+4 ; Output: Y = ifn of spec mvt
+5 ;
+6 ; Variable: DGPMPHY = physical mvt IFN ; DGPMPHY0 = 0th node
+7 ; DGPMSP = specialty mvt IFN
+8 ;
+9 if '$DATA(^DGPM(+Y,0))
QUIT
+10 NEW DGPMT,DGPMN
SET DGPMPHY=+Y
SET DGPMPHY0=^DGPM(+Y,0)
SET DGPMT=6
SET DGPMN=0
+11 SET DGPMSP=$SELECT($DATA(^DGPM("APHY",DGPMPHY)):$ORDER(^(DGPMPHY,0)),1:"")
+12 IF 'DGPMSP
SET Y=+$PIECE(Y,"^",2)
if 'Y
DO ASK
if 'Y
GOTO SPECQ
DO NEW
+13 if DGPMSP
DO EDIT
+14 ;Only call if doing a transfer
+15 IF DGPMUC'="ADMISSION"
IF $GET(PTF)'=""
IF $$ELIG^DGCOMPACTELIG(DFN,"DGPMV36")'="NOT ELIGIBLE"
DO COMPACT
SPECQ SET Y=DGPMSP
KILL DGPMPHY,DGPMPHY0,DGPMSP
QUIT
+1 ;
ASK ; -- ask user if they want to make a special mvt also
+1 WRITE !
SET DIR(0)="YA"
SET DIR("A")="Do you wish to associate a 'facility treating specialty' transfer? "
+2 SET DIR("?",1)="If you would like to associate a facility specialty"
+3 SET DIR("?",2)="transfer with this physical movement then answer 'Yes'."
+4 SET DIR("?")="Otherwise, answer with a 'No'."
+5 DO ^DIR
KILL DIR
+6 QUIT
+7 ;
COMPACT ; -- ask user if the treatment for the movement was for Acute Suicidal Crisis
+1 NEW %,CDATA,CMPMSG,DGVAL,ERROR,FIRSTMOVE,FLIP,MOVEDT,MOVESEQ,MVMTVAL,PTFPOINT,PXEOCNUM,PXEOCSEQ,PXIENS,SEQCHK,STARTDT,X,Y
+2 WRITE !,"Was Treatment for Acute Suicidal Crisis"
SET %=$SELECT($$ASC^PXCOMPACT(DFN)="Y":1,1:2)
DO YN^DICN
IF %=-1
WRITE !,"Answer must be 'Yes' or 'No'"
GOTO COMPACT
+3 SET PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
SET CDATA=""
+4 ; get EOC sequence number
+5 SET PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
+6 SET PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
+7 IF (%=2)
IF $$ASC^PXCOMPACT(DFN)="Y"
Begin DoDot:1
+8 ;before marking an episode as an error, determine if this movement is the last one in the multiple
+9 IF $$CHKMVMT^DGCOMPACT(DFN,PTF)=1
IF $DATA(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,PTFPOINT,1,"B",DGPMDA))
Begin DoDot:2
+10 IF $$GETBENTYP^PXCOMPACT(DFN)="I"
WRITE !,"This action will end COMPACT Act benefit. Are you sure"
SET %=2
DO YN^DICN
IF %'=1
GOTO COMPACT
+11 ;set PTF 101 to a No
+12 DO SETPTFFLG^DGCOMPACT(PTF,0)
+13 ;set 501 to No
+14 IF DGPMY'=""
Begin DoDot:3
+15 SET MOVESEQ=$ORDER(^DGPT(PTF,"M","AM",DGPMY,""))
IF MOVESEQ=""
QUIT
+16 DO SETPTFMVMT^DGCOMPACT(PTF,"N",MOVESEQ)
End DoDot:3
+17 DO REVERT^DGCOMPACT(DFN,PTF)
+18 ;I $$GETBENTYP^PXCOMPACT(DFN)="I" D REVERT^DGCOMPACT(DFN,PTF)
End DoDot:2
+19 IF $$CHKMVMT^DGCOMPACT(DFN,PTF)>1
Begin DoDot:2
+20 ;Remove movement from multiple in EOC file
+21 SET PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
+22 SET PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
+23 SET PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
+24 SET DA(3)=PXEOCNUM
SET DA(2)=PXEOCSEQ
SET DA(1)=PTFPOINT
SET DA=$$GETMVMT^DGCOMPACT(DFN,PTF,DGPMDA)
+25 SET DIK="^PXCOMP(818,"_DA(3)_",10,"_DA(2)_",40,"_DA(1)_",1,"
+26 DO ^DIK
+27 KILL DA,DIK
+28 IF DGPMY'=""
Begin DoDot:3
+29 SET MOVESEQ=$ORDER(^DGPT(PTF,"M","AM",DGPMY,""))
IF MOVESEQ=""
QUIT
+30 DO SETPTFMVMT^DGCOMPACT(PTF,"N",MOVESEQ)
End DoDot:3
+31 ;reset start date (potentially) to earliest movement date
+32 SET FIRSTMOVE=$ORDER(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,PTFPOINT,1,"B",""))
IF FIRSTMOVE=""
QUIT
+33 SET MOVEDT=$PIECE($PIECE($GET(^DGPM(FIRSTMOVE,0)),"^"),".")
SET STARTDT=$$GETSTDT^PXCOMPACT(DFN)
+34 IF MOVEDT'=STARTDT
Begin DoDot:3
+35 ;check if there is a prior OP episode whose end date matches this episode's start date
+36 SET SEQCHK="B"
+37 FOR
SET SEQCHK=$ORDER(^PXCOMP(818,PXEOCNUM,10,SEQCHK),-1)
if SEQCHK=0
QUIT
Begin DoDot:4
+38 IF SEQCHK=PXEOCSEQ
QUIT
+39 IF $PIECE(^PXCOMP(818,PXEOCNUM,10,SEQCHK,0),"^",2)=STARTDT
Begin DoDot:5
+40 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
+41 IF $$GETBENTYP^PXCOMPACT(DFN)="O"
Begin DoDot:4
+42 ;update start date ONLY
+43 SET PXIENS=PXEOCSEQ_","_PXEOCNUM_","
+44 IF $GET(MOVEDT)'=""
SET CDATA(818.01,PXIENS,.01)=MOVEDT
+45 DO FILE^DIE("","CDATA")
End DoDot:4
QUIT
+46 DO SETSTDT^PXCOMPACT(DFN,MOVEDT)
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+47 ;if yes AND there's a current inpatient episode, add the movement to the episode and set the 501 to Yes
+48 IF ($$ASC^PXCOMPACT(DFN)="Y")
IF ($$GETBENTYP^PXCOMPACT(DFN)="I")
Begin DoDot:1
+49 SET (CMPMSG,CDATA(818.41))=""
+50 ;Set the movement multiple
+51 SET PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
+52 SET PXIENS="?+1,"_PTFPOINT_","_PXEOCSEQ_","_PXEOCNUM_","
+53 IF $GET(DGPMDA)'=""
Begin DoDot:2
+54 SET CDATA(818.41,PXIENS,.01)=DGPMDA
+55 DO UPDATE^DIE("","CDATA","","CMPMSG")
End DoDot:2
+56 ;set 501 to Yes
+57 IF DGPMY'=""
Begin DoDot:2
+58 SET MOVESEQ=$ORDER(^DGPT(PTF,"M","AM",DGPMY,""))
IF MOVESEQ=""
QUIT
+59 DO SETPTFMVMT^DGCOMPACT(PTF,"Y",MOVESEQ)
End DoDot:2
+60 SET ^UTILITY($JOB,"PXCOMPACT-TRANS")=""
End DoDot:1
QUIT
+61 IF %=1
Begin DoDot:1
+62 WRITE !,"THIS MOVEMENT WILL BEGIN THE COMPACT ACT BENEFIT. ARE YOU SURE"
SET %=2
DO YN^DICN
IF %'=1
GOTO COMPACT
+63 SET DGVAL=$SELECT(%=1:1,1:0)
SET MVMTVAL=$SELECT(%=1:"Y",1:"N")
SET STARTDT=""
SET ERROR=""
SET FLIP=""
+64 ;get start date of last valid episode
+65 SET STARTDT=$$GETSTDT^PXCOMPACT(DFN)
+66 ;handle scenario where current episode is Outpatient
+67 IF $$ASC^PXCOMPACT(DFN)="Y"
IF $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",3)="O"
IF $$CHKMVMT^DGCOMPACT(DFN,PTF)=""
Begin DoDot:2
+68 ;first check if date belongs to a different sequence (that possibly errored)
+69 SET PXEOCSEQ=$ORDER(^PXCOMP(818,PXEOCNUM,10,"B",$PIECE(DGPMY,"."),""))
+70 IF PXEOCSEQ'=""
IF $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",6)="E"
SET ERROR=1
+71 ;same day processing, flip episode to Inpatient
+72 IF $PIECE(DGPMY,".")=STARTDT
IF 'ERROR
Begin DoDot:3
+73 SET $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",3)="I"
+74 SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)=$$FMADD^XLFDT($PIECE(DGPMY,"."),29)
+75 SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",5)=""
+76 SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",7)="A"
+77 DO VISIT^PXCOMPACT(PTF,"I",PXEOCNUM,DFN)
+78 SET FLIP=1
End DoDot:3
+79 ;non-same day processing, end OP episode and create new IP episode using the date provided
+80 IF $PIECE(DGPMY,".")'=STARTDT
IF 'ERROR
Begin DoDot:3
+81 DO SETENDDT^PXCOMPACT(DFN,$PIECE(DGPMY,"."),"PR")
+82 DO NEWEOC^PXCOMPACT(DFN,PTF,"I",$PIECE(DGPMY,"."))
+83 SET FLIP=1
End DoDot:3
End DoDot:2
+84 ;reopen episode of care if the transfer date is on the same date as an Entered in Error episode
+85 IF PXEOCNUM'=""
IF $DATA(^PXCOMP(818,PXEOCNUM,10,"B",$PIECE(DGPMY,".")))
IF 'FLIP
Begin DoDot:2
+86 DO SETENDDT^PXCOMPACT(DFN,$PIECE(DGPMY,"."),"PR")
+87 SET PXEOCSEQ=$ORDER(^PXCOMP(818,PXEOCNUM,10,"B",$PIECE(DGPMY,"."),""))
IF PXEOCSEQ=""
QUIT
+88 DO REOPNEOC^PXCOMPACT(PXEOCNUM,PXEOCSEQ,"")
DO VISIT^PXCOMPACT(PTF,"I",PXEOCNUM,DFN)
End DoDot:2
+89 ;Reopen episode of care if the PTF is already associated with an episode and not currently in a crisis
+90 IF PXEOCNUM'=""
IF PXEOCSEQ'=""
IF $DATA(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,"B",PTF))
IF $$ASC^PXCOMPACT(DFN)="N"
Begin DoDot:2
+91 DO REOPNEOC^PXCOMPACT(PXEOCNUM,PXEOCSEQ,STARTDT)
End DoDot:2
+92 ;otherwise start a new episode
+93 IF $$ASC^PXCOMPACT(DFN)="N"
DO NEWEOC^PXCOMPACT(DFN,PTF,"I",$PIECE(DGPMY,"."))
+94 DO SETPTFFLG^DGCOMPACT(PTF,DGVAL)
+95 SET PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
+96 SET PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
+97 SET (CMPMSG,CDATA(818.41))=""
+98 ;Set the movement multiple
+99 SET PTFPOINT=$$GETPOINTRSEQ^PXCOMPACT(DFN,PTF,"I")
+100 SET PXIENS="?+1,"_PTFPOINT_","_PXEOCSEQ_","_PXEOCNUM_","
+101 IF $GET(DGPMDA)'=""
Begin DoDot:2
+102 SET CDATA(818.41,PXIENS,.01)=DGPMDA
+103 DO UPDATE^DIE("","CDATA","","CMPMSG")
End DoDot:2
+104 SET ^UTILITY($JOB,"PXCOMPACT-TRANS")=""
+105 ;set 501 to Yes
+106 IF DGPMY'=""
Begin DoDot:2
+107 SET MOVESEQ=$ORDER(^DGPT(PTF,"M","AM",DGPMY,""))
IF MOVESEQ=""
QUIT
+108 DO SETPTFMVMT^DGCOMPACT(PTF,"Y",MOVESEQ)
End DoDot:2
End DoDot:1
+109 QUIT
+110 ;
NEW ; -- add a specialty mvt
+1 SET X=DGPMPHY0
SET Y=+X_U_DGPMT_U_$PIECE(X,U,3)
SET $PIECE(Y,U,14)=$PIECE(X,U,14)
SET $PIECE(Y,U,24)=DGPMPHY
+2 SET X=+X
SET DGPM0ND=Y
DO NEW^DGPMV3
+3 SET DGPMSP=$SELECT(+Y>0:+Y,1:"")
SET DGPMN=(+Y>0)
+4 IF DGPMSP
IF $PIECE(DGPMPHY0,"^",2)=1
IF $PIECE(DGPMPHY0,"^",10)]""
SET DR="99///"_$PIECE(DGPMPHY0,"^",10)
SET DA=DGPMSP
SET DIE="^DGPM("
DO ^DIE
+5 KILL DIE,DIC,DA,DR,DGPM0ND
+6 QUIT
EDIT ; -- edit specialty mvt
+1 NEW DGPMX,DGPMP
+2 IF DGPMN
SET (DGPMP,^UTILITY("DGPM",$JOB,6,DGPMSP,"P"))=""
SET DIE("NO^")=""
+3 IF 'DGPMN
SET (DGPMP,^UTILITY("DGPM",$JOB,6,DGPMSP,"P"))=^DGPM(DGPMSP,0)
+4 SET Y=DGPMSP
DO PRIOR
+5 ;set to 1 no dt/time change to bypass x-refs
SET DGPMN=(+DGPMP=+DGPMPHY0)
+6 SET DGPMX=+DGPMPHY0
SET DA=DGPMSP
SET DIE="^DGPM("
SET DR="[DGPM SPECIALTY TRANSFER]"
+7 KILL DQ,DG
DO ^DIE
+8 SET ^UTILITY("DGPM",$JOB,6,DGPMSP,"A")=$SELECT($DATA(^DGPM(DGPMSP,0)):^(0),1:"")
+9 SET Y=DGPMSP
DO AFTER
+10 QUIT
+11 ;
PRIOR ; -- set special 'prior' nodes for event driver
+1 IF DGPMN
SET (^UTILITY("DGPM",$JOB,6,Y,"DXP"),^("PTFP"))=""
+2 IF 'DGPMN
SET X=$PIECE($SELECT($DATA(^DGPM(Y,"DX",0)):^(0),1:""),"^",3,4)
SET X=X_$SELECT($DATA(^(1,0)):$EXTRACT(^(0),1,245-$LENGTH(X)),1:"")
SET ^UTILITY("DGPM",$JOB,6,Y,"DXP")=X
SET ^UTILITY("DGPM",$JOB,6,Y,"PTFP")=$SELECT($DATA(^DGPM(Y,"PTF")):^("PTF"),1:"")
+3 QUIT
+4 ;
AFTER ; -- set special 'after' nodes for event driver
+1 SET X=$PIECE($SELECT($DATA(^DGPM(Y,"DX",0)):^(0),1:""),"^",3,4)
SET X=X_$SELECT($DATA(^(1,0)):$EXTRACT(^(0),1,245-$LENGTH(X)),1:"")
SET ^UTILITY("DGPM",$JOB,6,Y,"DXA")=X
SET ^UTILITY("DGPM",$JOB,6,Y,"PTFA")=$SELECT($DATA(^DGPM(Y,"PTF")):^("PTF"),1:"")
+2 QUIT
