Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPMV36

DGPMV36.m

Go to the documentation of this file.
  1. DGPMV36 ;ALB/MIR - TREATING SPECIALTY TRANSFER, CONTINUED ; 8/6/04 10:17am
  1. ;;5.3;Registration;**1104**;Aug 13, 1993;Build 59
  1. ; Reference to NEWEOC^PXCOMPACT, $$ASC^PXCOMPACT, $$GETEOCSEQ^PXCOMPACT, and $$GETSTDT^PXCOMPACT in ICR #7327
  1. ;
  1. I '$P(DGPMA,"^",9) S DGPMA="",DIK="^DGPM(",DA=DGPMDA D ^DIK K DIK W !,"Incomplete Treating Specialty Transfer...Deleted"
  1. Q
  1. ;
  1. DICS ; -- check that it is a PROVIDER/SPECIALTY change
  1. S DGER=DGPMTYP'=20
  1. Q
  1. ;
  1. ONLY ; -- determine if there is only one 'specialty xfr' type mvt
  1. N C,I S C=0
  1. 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
  1. Q
  1. ;
  1. SPEC ; -- entry point to add/edit specialty mvt when adding/editing
  1. ; a physical mvt
  1. ;
  1. ; Input: Y = ifn of mvt file ^ auto add specialty entry(1)
  1. ; Output: Y = ifn of spec mvt
  1. ;
  1. ; Variable: DGPMPHY = physical mvt IFN ; DGPMPHY0 = 0th node
  1. ; DGPMSP = specialty mvt IFN
  1. ;
  1. Q:'$D(^DGPM(+Y,0))
  1. N DGPMT,DGPMN S DGPMPHY=+Y,DGPMPHY0=^DGPM(+Y,0),DGPMT=6,DGPMN=0
  1. S DGPMSP=$S($D(^DGPM("APHY",DGPMPHY)):$O(^(DGPMPHY,0)),1:"")
  1. I 'DGPMSP S Y=+$P(Y,"^",2) D ASK:'Y G SPECQ:'Y D NEW
  1. D EDIT:DGPMSP
  1. ;Only call if doing a transfer
  1. I DGPMUC'="ADMISSION",$G(PTF)'="",$$ELIG^DGCOMPACTELIG(DFN,"DGPMV36")'="NOT ELIGIBLE" D COMPACT
  1. SPECQ S Y=DGPMSP K DGPMPHY,DGPMPHY0,DGPMSP Q
  1. ;
  1. ASK ; -- ask user if they want to make a special mvt also
  1. W ! S DIR(0)="YA",DIR("A")="Do you wish to associate a 'facility treating specialty' transfer? "
  1. S DIR("?",1)="If you would like to associate a facility specialty"
  1. S DIR("?",2)="transfer with this physical movement then answer 'Yes'."
  1. S DIR("?")="Otherwise, answer with a 'No'."
  1. D ^DIR K DIR
  1. Q
  1. ;
  1. COMPACT ; -- ask user if the treatment for the movement was for Acute Suicidal Crisis
  1. N %,DGVAL,MVMTVAL,PXEOCNUM,PXEOCSEQ,STARTDT
  1. W !,"Was Treatment for Acute Suicidal Crisis" S %=2 D YN^DICN I %=-1 W !,"Answer must be 'Yes' or 'No'" G COMPACT
  1. I %=1 W !,"THIS ADMISSION WILL BEGIN THE COMPACT ACT BENEFIT. ARE YOU SURE" S %=2 D YN^DICN I %'=1 G COMPACT
  1. S DGVAL=$S(%=1:1,1:0),MVMTVAL=$S(%=1:"Y",1:"N")
  1. I %=1 D
  1. . S PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
  1. . S PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
  1. . S STARTDT=$$GETSTDT^PXCOMPACT(DFN)
  1. . ;handle scenario where current episode is Outpatient
  1. . I $$ASC^PXCOMPACT(DFN)="Y",$P(^PXCOMP(818,PXEOCNUM,0),"^",3)="O" D
  1. . . ;same day processing, flip episode to Inpatient
  1. . . I $P(DGPMY,".")=STARTDT D
  1. . . . S $P(^PXCOMP(818,PXEOCNUM,0),"^",3)="I"
  1. . . . S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",4)=$$FMADD^XLFDT($P(DGPMY,"."),29)
  1. . . . S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",5)=""
  1. . . . S $P(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,0),"^",7)="A"
  1. . . . D VISIT^PXCOMPACT(PTF,"I",PXEOCNUM,DFN)
  1. . . ;non-same day processing, end OP episode and create new IP episode using the date provided
  1. . . I $P(DGPMY,".")'=STARTDT D
  1. . . . D SETENDDT^PXCOMPACT(DFN,$P(DGPMY,"."),"PR")
  1. . . . D NEWEOC^PXCOMPACT(DFN,PTF,"I",$P(DGPMY,"."))
  1. . ;Reopen episode of care if the PTF is already associated with an episode and not currently in a crisis
  1. . I PXEOCNUM'="",PXEOCSEQ'="",$D(^PXCOMP(818,PXEOCNUM,10,PXEOCSEQ,40,"B",PTF)),$$ASC^PXCOMPACT(DFN)="N" D
  1. . . D REOPNEOC^PXCOMPACT(PXEOCNUM,PXEOCSEQ,STARTDT)
  1. . ;otherwise start a new episode
  1. . I $$ASC^PXCOMPACT(DFN)="N" D NEWEOC^PXCOMPACT(DFN,PTF,"I",$P(DGPMY,"."))
  1. . D SETPTFFLG^DGCOMPACT(PTF,DGVAL)
  1. . S ^UTILITY($J,"PXCOMPACT-TRANS")=""
  1. Q
  1. ;
  1. NEW ; -- add a specialty mvt
  1. 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
  1. S X=+X,DGPM0ND=Y D NEW^DGPMV3
  1. S DGPMSP=$S(+Y>0:+Y,1:"") S DGPMN=(+Y>0)
  1. I DGPMSP,$P(DGPMPHY0,"^",2)=1,$P(DGPMPHY0,"^",10)]"" S DR="99///"_$P(DGPMPHY0,"^",10),DA=DGPMSP,DIE="^DGPM(" D ^DIE
  1. K DIE,DIC,DA,DR,DGPM0ND
  1. Q
  1. EDIT ; -- edit specialty mvt
  1. N DGPMX,DGPMP
  1. I DGPMN S (DGPMP,^UTILITY("DGPM",$J,6,DGPMSP,"P"))="",DIE("NO^")=""
  1. I 'DGPMN S (DGPMP,^UTILITY("DGPM",$J,6,DGPMSP,"P"))=^DGPM(DGPMSP,0)
  1. S Y=DGPMSP D PRIOR
  1. S DGPMN=(+DGPMP=+DGPMPHY0) ;set to 1 no dt/time change to bypass x-refs
  1. S DGPMX=+DGPMPHY0,DA=DGPMSP,DIE="^DGPM(",DR="[DGPM SPECIALTY TRANSFER]"
  1. K DQ,DG D ^DIE
  1. S ^UTILITY("DGPM",$J,6,DGPMSP,"A")=$S($D(^DGPM(DGPMSP,0)):^(0),1:"")
  1. S Y=DGPMSP D AFTER
  1. Q
  1. ;
  1. PRIOR ; -- set special 'prior' nodes for event driver
  1. I DGPMN S (^UTILITY("DGPM",$J,6,Y,"DXP"),^("PTFP"))=""
  1. 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:"")
  1. Q
  1. ;
  1. AFTER ; -- set special 'after' nodes for event driver
  1. 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:"")
  1. Q