- DGPMV36 ;ALB/MIR - TREATING SPECIALTY TRANSFER, CONTINUED ; 8/6/04 10:17am
- ;;5.3;Registration;**1104**;Aug 13, 1993;Build 59
- ; 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 %,DGVAL,MVMTVAL,PXEOCNUM,PXEOCSEQ,STARTDT
- W !,"Was Treatment for Acute Suicidal Crisis" S %=2 D YN^DICN I %=-1 W !,"Answer must be 'Yes' or 'No'" G COMPACT
- I %=1 W !,"THIS ADMISSION 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")
- I %=1 D
- . S PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
- . S PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
- . S STARTDT=$$GETSTDT^PXCOMPACT(DFN)
- . ;handle scenario where current episode is Outpatient
- . I $$ASC^PXCOMPACT(DFN)="Y",$P(^PXCOMP(818,PXEOCNUM,0),"^",3)="O" D
- . . ;same day processing, flip episode to Inpatient
- . . I $P(DGPMY,".")=STARTDT 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)
- . . ;non-same day processing, end OP episode and create new IP episode using the date provided
- . . I $P(DGPMY,".")'=STARTDT D
- . . . D SETENDDT^PXCOMPACT(DFN,$P(DGPMY,"."),"PR")
- . . . D NEWEOC^PXCOMPACT(DFN,PTF,"I",$P(DGPMY,"."))
- . ;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 ^UTILITY($J,"PXCOMPACT-TRANS")=""
- 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 4916 printed Feb 19, 2025@00:16:25 Page 2
- DGPMV36 ;ALB/MIR - TREATING SPECIALTY TRANSFER, CONTINUED ; 8/6/04 10:17am
- +1 ;;5.3;Registration;**1104**;Aug 13, 1993;Build 59
- +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 %,DGVAL,MVMTVAL,PXEOCNUM,PXEOCSEQ,STARTDT
- +2 WRITE !,"Was Treatment for Acute Suicidal Crisis"
- SET %=2
- DO YN^DICN
- IF %=-1
- WRITE !,"Answer must be 'Yes' or 'No'"
- GOTO COMPACT
- +3 IF %=1
- WRITE !,"THIS ADMISSION WILL BEGIN THE COMPACT ACT BENEFIT. ARE YOU SURE"
- SET %=2
- DO YN^DICN
- IF %'=1
- GOTO COMPACT
- +4 SET DGVAL=$SELECT(%=1:1,1:0)
- SET MVMTVAL=$SELECT(%=1:"Y",1:"N")
- +5 IF %=1
- Begin DoDot:1
- +6 SET PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
- +7 SET PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
- +8 SET STARTDT=$$GETSTDT^PXCOMPACT(DFN)
- +9 ;handle scenario where current episode is Outpatient
- +10 IF $$ASC^PXCOMPACT(DFN)="Y"
- IF $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",3)="O"
- Begin DoDot:2
- +11 ;same day processing, flip episode to Inpatient
- +12 IF $PIECE(DGPMY,".")=STARTDT
- Begin DoDot:3
- +13 SET $PIECE(^PXCOMP(818,PXEOCNUM,0),"^",3)="I"
- +14 SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)=$$FMADD^XLFDT($PIECE(DGPMY,"."),29)
- +15 SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",5)=""
- +16 SET $PIECE(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",7)="A"
- +17 DO VISIT^PXCOMPACT(PTF,"I",PXEOCNUM,DFN)
- End DoDot:3
- +18 ;non-same day processing, end OP episode and create new IP episode using the date provided
- +19 IF $PIECE(DGPMY,".")'=STARTDT
- Begin DoDot:3
- +20 DO SETENDDT^PXCOMPACT(DFN,$PIECE(DGPMY,"."),"PR")
- +21 DO NEWEOC^PXCOMPACT(DFN,PTF,"I",$PIECE(DGPMY,"."))
- End DoDot:3
- End DoDot:2
- +22 ;Reopen episode of care if the PTF is already associated with an episode and not currently in a crisis
- +23 IF PXEOCNUM'=""
- IF PXEOCSEQ'=""
- IF $DATA(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,"B",PTF))
- IF $$ASC^PXCOMPACT(DFN)="N"
- Begin DoDot:2
- +24 DO REOPNEOC^PXCOMPACT(PXEOCNUM,PXEOCSEQ,STARTDT)
- End DoDot:2
- +25 ;otherwise start a new episode
- +26 IF $$ASC^PXCOMPACT(DFN)="N"
- DO NEWEOC^PXCOMPACT(DFN,PTF,"I",$PIECE(DGPMY,"."))
- +27 DO SETPTFFLG^DGCOMPACT(PTF,DGVAL)
- +28 SET ^UTILITY($JOB,"PXCOMPACT-TRANS")=""
- End DoDot:1
- +29 QUIT
- +30 ;
- 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