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

DGPMV22.m

Go to the documentation of this file.
  1. DGPMV22 ;ALB/MIR - SCHEDULED ADMISSION? ; 23 NOV 90
  1. ;;5.3;Registration;**40**;Aug 13, 1993
  1. SCHDADM ;is this a scheduled admission...DGPMSA=1 for yes, 0 for no
  1. ;must be within 7 days of actual scheduled admission entry
  1. S X1=DGPMY,X2=-7 D C^%DTC S DGPMSD=$P(X,".")-.1
  1. S X1=DGPMY,X2=7 D C^%DTC S DGPMED=$P(X,".")+.9
  1. S DGCT=0 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:"") I J,($P(J,"^",2)>DGPMSD),($P(J,"^",2)<DGPMED) I '$P(J,"^",13),'$P(J,"^",17) S DGCT=DGCT+1 D WR
  1. I 'DGCT S DGPMSA=0 G SCHDQ
  1. ;
  1. ASK W !,"Is this ",$S(DGCT=1:"the",1:"one of the")," scheduled admission",$S(DGCT>1:"s",1:"")," listed above" S %=1 D YN^DICN I %Y["?" W !?5,"Answer yes if this is a scheduled admission, otherwise no." G ASK
  1. S DGPMSA=$S(%<0:0,1:'(%-1)) I 'DGPMSA G SCHDQ
  1. I DGCT=1 S DGPMSA=^UTILITY("DGPMSA",$J,1) G SCHDQ
  1. WHICH W !,"Which scheduled admission is it? " R X:DTIME I '$T S DGPMER="" D SCHDQ K DGPMY Q
  1. I X["?" W !,"Choose a number 1-",DGCT G WHICH
  1. W ! I X["^"!'X!(X<1)!(X>DGCT) G ASK
  1. S DGPMSA=^UTILITY("DGPMSA",$J,X)
  1. SCHDQ K X,X1,X2,DGCT,DGPMED,DGPMSD,^UTILITY("DGPMSA",$J),DGI,J Q
  1. ;
  1. WR S Y=$P(J,"^",2) X ^DD("DD")
  1. I DGCT=1 W !!,"Scheduled admissions:"
  1. W !?2,DGCT,". ",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. S ^UTILITY("DGPMSA",$J,DGCT)=DGI
  1. Q
  1. ;
  1. ;
  1. PTF(DFN,DGPMDA,DGPME,DGPMCA) ;ptf check
  1. ;
  1. ; prevent editing of a movement if related to admission w/closed PTF
  1. ; (either same admission or ASIH-related admission)
  1. ;
  1. ; Input: DFN = ien of patient file
  1. ; DGPMDA = ien of patient movement file
  1. ; DGPME = error flag if ptf closed out <by reference>
  1. ; DGPMCA = ien of admission movement from pt mvmnt file
  1. ;
  1. ; Output: DGPME = "" if no error; otherwise error message
  1. ;
  1. I $S('+$G(DFN):1,'+$G(DGPMDA):1,'+$G(DGPMCA):1,1:0) Q
  1. ;
  1. N MVTYPE,NODE,TRANS,X
  1. S NODE=$G(^DGPM(DGPMDA,0)),TRANS=$P(NODE,U,2),TYPE=$P(NODE,U,18)
  1. ;
  1. ; check PTF of current admission for all movements
  1. D PTFC($P(NODE,"^",14),.DGPME) I $G(DGPME)]"" G PTFQ
  1. ;
  1. ; check related nhcu/dom admission if current admission = TO ASIH
  1. I TRANS=1 D:$P(NODE,"^",21) G PTFQ
  1. . S X=$G(^DGPM($P(NODE,"^",21),0))
  1. . D PTFC($P(X,"^",14),.DGPME)
  1. ;
  1. ; check related ASIH admission if nhcu/dom transfer movement
  1. I TRANS=2 D G PTFQ
  1. . I "^13^14^44^45^"'[("^"_TYPE_"^") Q ; not ASIH mvt...quit
  1. . I "^13^44^"[("^"_TYPE_"^") D PTFC($P(NODE,"^",15),.DGPME) Q ; to asih or resume asih xfr...check hospital PTF & quit
  1. . S X=$O(^DGPM("APMV",DFN,DGPMCA,(9999999.9999999-+NODE))),X=$O(^DGPM("APMV",DFN,DGPMCA,+X,0)) ; prior mvt ien
  1. . S X=$G(^DGPM(+X,0)) ; prior mvt node
  1. . I $P(X,"^",15) D PTFC($P(X,"^",15),.DGPME) ; if prior mvt associated with hospital admission, check hospital ptf
  1. ;
  1. ; check related nhcu/dom admission if asih discharge
  1. I TRANS=3,("^41^46^"[("^"_TYPE_"^")) D
  1. . S X=$G(^DGPM(+$P(NODE,"^",14),0)),X=$G(^DGPM(+$P(X,"^",21),0)) ; x=associated nhcu/dom transfer node
  1. . I X]"" D PTFC($P(X,"^",14),.DGPME)
  1. PTFQ Q
  1. ;
  1. ;
  1. PTFC(ADMIT,DGPME) ;check if ptf in close out file/ set error flag if true
  1. ;
  1. ; Input: ADMIT = ien of admission record
  1. ; DGPME = ptf closed flag <by reference>
  1. ; Output: DGPME = set if ptf closed out
  1. ;
  1. Q:'+$G(ADMIT)
  1. N PTF
  1. S PTF=$P($G(^DGPM(ADMIT,0)),"^",16)
  1. I PTF,$D(^DGP(45.84,+PTF)) S DGPME="Associated PTF (#"_PTF_") is not open. Cannot edit this movement."
  1. Q