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

DGPTTS3.m

Go to the documentation of this file.
  1. DGPTTS3 ;ALB/MJK - Physical Mvt ; 2/10/11 6:19pm
  1. ;;5.3;Registration;**26,61,549,729,787**;Aug 13, 1993;Build 1
  1. ;
  1. EN ; -- entry used to update PTF rec
  1. ; input: PTF := PTF#
  1. ; DFN := pt#
  1. ; DGPMCA := adm mvt #
  1. ; DGDT := d/c date
  1. ;
  1. S DGPTIFN=PTF
  1. D FDT^DGPTUTL G ENQ:$S(DGDT:DGDT,1:DT)<Y
  1. I '$D(ZTQUEUED),'$G(DGQUIET) W !,"Now updating ward MPCR information..."
  1. S (DGBEG,DGSTART,DGLAST)=Y-.0000001
  1. S X=Y I $E(X,6,7)="00" S X1=X,X2=-1 D C^%DTC
  1. S DGPFYDT=$P(X,".")_".2359" ; last date/time in previous FY
  1. D KILL
  1. N DGRT S DGRT="^DGPM(""APCA"",DFN,DGPMCA)"
  1. ;
  1. ; -- build ward table
  1. S DGDATA="",DGADM0=$S($D(^DGPM(DGPMCA,0)):^(0),1:"")
  1. I DGADM0,DGADM0'>DGSTART S DGT=DGPFYDT D ^DGINPW I +DG1 S $P(DGXFR0,U,4)=+DG1 D TABLE
  1. I DGADM0,DGADM0>DGSTART S $P(DGXFR0,U,4)=$P(DGADM0,U,6),DGBEG=+DGADM0 D TABLE
  1. F DGXDT=DGSTART:0 S DGXDT=$O(@DGRT@(DGXDT)) Q:'DGXDT F DGMVT=0:0 S DGMVT=$O(@DGRT@(DGXDT,DGMVT)) Q:'DGMVT I $D(^DGPM(DGMVT,0)) S X=^(0) I $P(X,U,2)=2 S DGXFR0=$P(X,U,18)_"^^^"_$P(X,U,6) D TABLE
  1. G ENQ:DGDATA=""
  1. S DGEND=$S(DGDT:DGDT,1:DT) D DAYS S DGXDT=($S(DGDT:DGDT,1:"")),$P(DGDATA,U,3,4)=LEAVE_U_PASS,$P(DGDATA,U,7)=1 D CREATE
  1. ;
  1. ENQ I $D(DGSACNT),DGSACNT>25 D FLCHK
  1. S L=DGPTIFN
  1. K DGRT,DGADM0,DG1,DGDATA,DGMDT,DGPTIFN,DGXFR0,DGXDT,DGM,X,DGM0,LEAVE,PASS,DGBEG,DGEND,DGSTART,DGWD,DGCDR,DGSP,DGADM0,DGPFYDT,DGT,DGA1,DGSAFTF,DGSACNT,DGWI,DGI
  1. Q
  1. ;
  1. TABLE ; -- setup 535 node data
  1. ; DGDATA := 1:ward cdr ^ 2:ward specialty ^ 3:leave days ^ 4:pass days ^ ^ 6:ward ^ ^ ^ ^ 10:mvt date/time
  1. ;
  1. S DGWD=+$P(DGXFR0,U,4)
  1. G TABLEQ:'$D(^DIC(42,DGWD,0)) S DGSP=+$P(^(0),U,12)
  1. G TABLEQ:'$D(^DIC(42.4,DGSP,0)) S DGCDR=$P(^(0),U,6)
  1. ; -- create MPCR mvt if ward mpcr changes
  1. I DGDATA]"",+DGDATA'=DGCDR S DGEND=DGXDT D DAYS S $P(DGDATA,U,3,4)=LEAVE_U_PASS D CREATE S DGDATA=DGCDR_"^"_DGSP_"^^^^"_DGWD,DGLAST=DGBEG,DGBEG=DGEND
  1. I DGDATA="",DGCDR]"" S DGDATA=DGCDR_"^"_DGSP_"^^^^"_DGWD
  1. TABLEQ Q
  1. ;
  1. CREATE ; -- create MPCR mvt
  1. F L +^DGPT(DGPTIFN,535):$G(DILOCKTM,3) Q:$T W !,"Another user is editing this record, trying again...",!
  1. S Y=^DGPT(DGPTIFN,535,0),I=$P(Y,U,3)
  1. L S I=I+1 G L:$D(^DGPT(DGPTIFN,535,I))
  1. S $P(^DGPT(DGPTIFN,535,0),U,3,4)=I_U_($P(Y,U,4)+1)
  1. S X=DGDATA,^DGPT(DGPTIFN,535,I,0)=I_U_$P(X,U,2)_U_$P(X,U,3)_U_$P(X,U,4)_"^^"_$P(X,U,6)_"^"_$P(X,U,7)_"^^^"_DGXDT L -^DGPT(DGPTIFN,535)
  1. K DA S DA=I,DA(1)=DGPTIFN,DIK="^DGPT("_DGPTIFN_",535," D IX1^DIK
  1. CREATEQ S DGSACNT=I
  1. K DA,I,DIK Q
  1. ;
  1. KILL ; -- clean out ward mvts
  1. F DGWI=0:0 S DGWI=$O(^DGPT(DGPTIFN,535,DGWI)) Q:'DGWI S:$P(^(DGWI,0),U,17)="n" DGSAFTF(DGWI)=^(0) K DA S DA(1)=DGPTIFN,DA=DGWI,DIK="^DGPT("_DGPTIFN_",535," D ^DIK K DA
  1. S:'$D(^DGPT(DGPTIFN,535,0)) ^(0)="^45.0535^"
  1. K DIK,DGWI,DA Q
  1. ;
  1. T ; -- test tag
  1. S DIC(0)="AEMQZ",DIC=45,DIC("S")="I $P(^(0),U,11)=1" D ^DIC K DIC Q:Y<0
  1. PTF S PTF=+Y,DGDT=$S($D(^DGPT(L,70)):+^(70),1:0),DFN=+Y(0) D PM^DGPTUTL,EN:DGPMCA
  1. Q
  1. ;
  1. DAYS ; -- calc leave and pass days from DGBEG to DGEND
  1. ; -- if last 501 date is after last 535 date then
  1. ; calc from last 535 mvt d/t to last 501 mvt d/t
  1. ;
  1. ; 535 501 501 535
  1. ; |------------|------|----------|
  1. ; <<<<<<<<<<< total >>>>>>>>>>
  1. ; <<<<<<< diff >>>>>>+<< pass >>
  1. ;
  1. S (PASS,LEAVE,DGDIFP,DGDIFL)=0 D MVT
  1. I DGMDT>DGBEG S DGE=DGEND,DGEND=DGMDT D DAYS0 S DGDIFL=LEAVE,DGDIFP=PASS,DGEND=DGE
  1. ; -- calc from last 535 mvt d/t to new 535 mvt d/t
  1. S (PASS,LEAVE)=0 D DAYS0
  1. ; -- substract 'diff' from 'total'
  1. S PASS=PASS-DGDIFP,LEAVE=LEAVE-DGDIFL
  1. K DGDIFL,DGDIFP,DGE Q
  1. ;
  1. DAYS0 ;
  1. N DGMVT
  1. F DGMVTDT=(DGBEG-.0000001):0 S DGMVTDT=$O(@DGRT@(DGMVTDT)) Q:'DGMVTDT F DGMVT=0:0 S DGMVT=$O(@DGRT@(DGMVTDT,DGMVT)) Q:'DGMVT I $D(^DGPM(DGMVT,0)),$P(^(0),U,2)=2 S C=$P(^(0),U,18) I C=1!(C=2)!(C=3) D NEXT,DAYS1
  1. K DGMVTDT Q
  1. ;
  1. DAYS1 S I=DGMVTDT,X2=$S(I<DGBEG:DGBEG,1:I),X1=$S(Y>DGBEG&(Y'>DGEND):Y,Y>DGEND!('Y):DGEND,1:X2)
  1. I X1>X2 D ^%DTC S:C=1 PASS=PASS+X S:C=2 LEAVE=LEAVE+X
  1. K C,X,Y,X1,X2,I
  1. Q
  1. ;
  1. NEXT ; -- find next x-ref date
  1. N DGMVT
  1. F Y=DGMVTDT:0 S Y=$O(@DGRT@(Y)) Q:'Y F DGMVT=0:0 S DGMVT=$O(@DGRT@(Y,DGMVT)) Q:'DGMVT I $D(^DGPM(DGMVT,0)),$P(^(0),U,2)=2 G NEXTQ
  1. NEXTQ Q
  1. ;
  1. MVT ; -- find last 501 mvt d/t since the last 535 mvt d/t
  1. ; and before the new 535 mvt d/t
  1. S DGMDT=""
  1. F M=DGLAST:0 S M=$O(^DGPT(DGPTIFN,"M","AM",M)) Q:'M!(M>DGEND) S DGMDT=M
  1. K M Q
  1. ;
  1. FLCHK ; -- check if more than 25 535s, then re-set x-mit flags
  1. I '$D(DGSACNT) G FLQ
  1. I DGSACNT<25 G FLQ
  1. S DGF1=0
  1. F DGWI=0:0 S DGWI=$O(DGSAFTF(DGWI)) Q:'DGWI!('$D(^DGPT(DGPTIFN,535,+DGWI,0))) F DGI=1,2,10,16 S:$P(^(0),U,DGI)'=$P(DGSAFTF(DGWI),U,DGI) DGF1=1
  1. I 'DGF1,'DGWI F DGWI=0:0 S DGWI=$O(DGSAFTF(DGWI)) Q:'DGWI S DA=DGWI,DA(1)=DGPTIFN,DIE="^DGPT("_DGPTIFN_",535,",DR="17///n" D ^DIE
  1. FLQ K DGI,DGF1,DGWI,DGSAFTF,DGSACNT,DR,DA,DIE
  1. Q
  1. ;