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

DGPMV31.m

Go to the documentation of this file. 
  1. DGPMV31 ;ALB/MIR - CONTINUE ADMIT PROCESS ; 12 SEP 89 @12
  1.  ;;5.3;Registration;**43,114,418,1015**;Aug 13, 1993;Build 21
  1.  ;IHS/ANMC/LJF  3/08/2001 bypassed setting entry in PTF file
  1.  ;                        delete service & provider if timed out
  1.  ;              7/26/2001 Added check for DGQUIET to write statements
  1.  ;
  1.  I '$P(DGPMA,"^",6)!(DGPMN&DGPMOUT) D KILL G DQ
  1.  S Y=DGPMDA_"^1" I 'DGPMOUT S:DGPMN DIE("NO^")="" D SPEC^DGPMV36 I '$D(^DGPM("APHY",DGPMDA)) D KILL G DQ
  1.  ;
  1.  ;IHS/ANMC/LJF 3/08/2001 added code to check for timing out of admit
  1.  ; must have required fields from service entry (providers & service)
  1.  NEW X,Y,BDGSAV
  1.  S X=$O(^DGPM("APHY",DGPMDA,0)) I 'X D KILL G DQ
  1.  S Y=$G(^DGPM(X,0))                    ;service node
  1.  I ('$P(Y,U,9))!('$P(Y,U,19))!('$P($G(^DGPM(X,"IHS")),U,2)) D  D DQ
  1.  . S BDGSAV=DGPMDA S DGPMDA=X D KILL   ;delete service transfer
  1.  . S DGPMDA=BDGSAV D KILL              ;delete admission
  1.  ;IHS/ANMC/LJF 3/08/2001 end of changes
  1.  ;
  1.  I $D(DGPMSVC) S DGPMDER=0 ;FOR DISPO^DGPMV - from disposition
  1.  I DGPMN,$D(^DGS(41.1,+DGPMSA,0)) S DA=DGPMSA,DR="17////"_DGPMDA,DIE="^DGS(41.1," D ^DIE
  1.  I DGPMN D ^DGPMVBUL,CK^DGBLRV
  1.  I 'DGPMN,($P(DGPMP,"^",6,7)'=$P(DGPMA,"^",6,7)),DGPMABL S DGPMND=DGPMA D AB^DGPMV32
  1.  D SA
  1. UP I $P(DGPMA,"^",21)&$S(+DGPMA'=+DGPMP:1,$P(DGPMA,"^",6,7)'=$P(DGPMP,"^",6,7):1,1:0) D ASIH
  1.  G:'$P(DGPMA,"^",6) PTF S X=$O(^DGWAIT("C",DFN,0)),Y=$O(^(+X,0)) G PTF:('X!'Y)
  1.  W !!,"This patient has the following waiting list entries on file:"
  1.  F I=0:0 S I=$O(^DGWAIT("C",DFN,I)) Q:'I  D
  1.  . F J=0:0 S J=$O(^DGWAIT("C",DFN,I,J)) Q:'J  D
  1.  . . S X=$G(^DGWAIT(I,"P",J,0)) I X']"" Q
  1.  . . W !?5,"TO: ",$S($D(^DG(40.8,+^DGWAIT(I,0),0)):$E($P(^(0),"^",1),1,20),1:"")
  1.  . . W ?32,"APPLIED: ",$$FMTE^XLFDT($P(X,"^",2)),?63,"BEDSECTION: ",$P(X,"^",5)
  1.  W !!,"Please delete from the waiting list if necessary.",!
  1. PTF S PTF=$P(DGPMA,"^",16)
  1.  I $$IHS^BDGF G DQ  ;IHS/ANMC/LJF 3/08/2001
  1.  N DGELA
  1.  S DGELA=+$P($G(^DGPT(+PTF,101)),U,8)
  1.  S DR="",DIE="^DGPT(" S:$S('$D(^DGPT(+PTF,0)):0,$P(^(0),"^",2)'=+DGPMA:1,1:0) DR=DR_"2////"_+DGPMA_";" S DR=DR_"20;20.1////^S X=$$ELIG^DGUTL3(DFN,2,DGELA)",DA=PTF I $D(^DGPT(+DA,0)) K DQ,DG D ^DIE G DQ
  1.  ;
  1.  G DQ:'DGPMN S Y=+DGPMA D CREATE^DGPTFCR
  1.  S PTF=Y
  1.  S DIE="^DGPM(",DA=DGPMDA,DR=".16////"_+Y K DQ,DG D ^DIE
  1.  ;
  1.  ;-- update admitting elig
  1.  S DR="",DIE="^DGPT("
  1.  S DR=DR_"20.1////^S X=$$ELIG^DGUTL3(DFN,2,DGELA)",DA=PTF
  1.  D ^DIE
  1.  ;
  1.  D ADM^DGPMVODS
  1. DQ ;I DGPMA'=DGPMP W !,"Patient Admi",$S($P(DGPMP,"^",4)']"":"tted",1:"ssion Updated"),!              ;IHS/ANMC/LJF 7/26/2001
  1.  I DGPMA'=DGPMP,'$D(DGQUIET) W !,"Patient Admi",$S($P(DGPMP,"^",4)']"":"tted",1:"ssion Updated"),!  ;IHS/ANMC/LJF 7/26/2001
  1.  Q
  1. DICS S DGER=0 I DGPMTYP=40 S DGER=1 Q  ;no TO ASIH!
  1.  I $P(^DGPM(DA,0),"^",18)=40 S DGER=1 Q  ;don't let them change from TO ASIH!
  1.  Q:DGPMTYP'=18
  1.  S DGX1=9999999.9999999-+^DGPM(DA,0)
  1.  F DGX=1:1:2 S DGX1=$O(^DGPM("ATID1",DFN,DGX1)) Q:'DGX1  S DGY=$O(^(DGX1,0)) I $D(^DGPM(+DGY,0)) G:($P(^(0),"^",18)=40) DICSQ S DGY=$P(^(0),"^",6) I $D(^DIC(42,+DGY,0)),("^NH^D^"[("^"_$P(^(0),"^",3)_"^"))!($P(^(0),"^",17)=1) G DICSQ ;p-418
  1.  S DGER=1 Q
  1. DICSQ S DGER=0 Q
  1. ASIH ;update corresponding transfer and NHCU/DOM discharge episodes
  1.  W !,"Updating corresponding NHCU/DOM movements"
  1.  S DIE="^DGPM(",DA=$P(DGPMA,"^",21),DR=".01///"_+DGPMA_";.06////"_$P(DGPMA,"^",6)_";.07////"_$P(DGPMA,"^",7)
  1.  I $D(^DGPM(+DA,0)) S ^UTILITY("DGPM",$J,2,DA,"P")=$S($D(^UTILITY("DGPM",$J,2,DA,"P")):^("P"),1:^DGPM(DA,0)) K DQ,DG D ^DIE S ^UTILITY("DGPM",$J,2,DA,"A")=^DGPM(DA,0)
  1.  Q:+DGPMP=+DGPMA  S DGX=$S($D(^DGPM(+$P(DGPMA,"^",21),0)):^(0),1:0),DGX2=$S('$D(^DGPM(+$P(DGX,"^",14),0)):0,$D(^DGPM(+$P(^(0),"^",17),0)):+^(0),1:0),X1=+DGPMP,X2=30 Q:'X1!'DGX2  D C^%DTC Q:X'=+DGX2
  1.  K DGX2 S X1=+DGPMA,X2=30 D C^%DTC S DA=$S($D(^DGPM(+$P(DGX,"^",14),0)):$P(^(0),"^",17),1:"")
  1.  S DIE="^DGPM(",DR=".01///"_X I $D(^DGPM(+DA,0)) S ^UTILITY("DGPM",$J,3,DA,"P")=$S($D(^UTILITY("DGPM",$J,3,DA,"P")):^("P"),1:^DGPM(DA,0)) K DQ,DG D ^DIE S ^UTILITY("DGPM",$J,3,DA,"A")=^DGPM(DA,0)
  1.  Q
  1. KILL ;S DIK="^DGPM(",DA=DGPMDA W !,"Incomplete admission...Deleted" D ^DIK K DIK S DGPMA="" Q              ;IHS/ANMC/LJF 7/26/2001
  1.  S DIK="^DGPM(",DA=DGPMDA W:'$D(DGQUIET) !,"Incomplete admission...Deleted" D ^DIK K DIK S DGPMA="" Q  ;IHS/ANMC/LJF 7/26/2001
  1.  ;
  1. SA Q:'$D(^DGS(41.1,"B",DFN))  S DGCT=0
  1.  F DGI=0:0 S DGI=$O(^DGS(41.1,"B",DFN,DGI)) Q:'DGI  S J=$S($D(^DGS(41.1,DGI,0)):^(0),1:0),Y=$P(J,"^",2) I Y X ^DD("DD") I '$P(J,"^",13),'$P(J,"^",17) S DGCT=DGCT+1 D WR
  1.  K DGCT,DGI,J,Y Q
  1.  ;
  1. WR I DGCT=1 W !,"This patient has the following scheduled admissions on file:"
  1.  W !?5,Y,?25,$S($P(J,"^",10)="W":"WARD: "_$S($D(^DIC(42,+$P(J,"^",8),0)):$P(^(0),"^",1),1:""),$P(J,"^",10)="T":"FACILITY TREATING SPECIALTY: "_$S($D(^DIC(45.7,+$P(J,"^",9),0)):$P(^(0),"^",1),1:""),1:"")
  1.  Q