source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTTS3.m@ 1416

Last change on this file since 1416 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.5 KB
Line 
1DGPTTS3 ;ALB/MJK - Physical Mvt ; 11/30/06 8:46am
2 ;;5.3;Registration;**26,61,549,729**;Aug 13, 1993;Build 59
3 ;
4EN ; -- entry used to update PTF rec
5 ; input: PTF := PTF#
6 ; DFN := pt#
7 ; DGPMCA := adm mvt #
8 ; DGDT := d/c date
9 ;
10 S DGPTIFN=PTF
11 D FDT^DGPTUTL G ENQ:$S(DGDT:DGDT,1:DT)<Y
12 I '$D(ZTQUEUED),'$G(DGQUIET) W !,"Now updating ward MPCR information..."
13 S (DGBEG,DGSTART,DGLAST)=Y-.0000001
14 S X=Y I $E(X,6,7)="00" S X1=X,X2=-1 D C^%DTC
15 S DGPFYDT=$P(X,".")_".2359" ; last date/time in previous FY
16 D KILL
17 N DGRT S DGRT="^DGPM(""APCA"",DFN,DGPMCA)"
18 ;
19 ; -- build ward table
20 S DGDATA="",DGADM0=$S($D(^DGPM(DGPMCA,0)):^(0),1:"")
21 I DGADM0,DGADM0'>DGSTART S DGT=DGPFYDT D ^DGINPW I +DG1 S $P(DGXFR0,U,4)=+DG1 D TABLE
22 I DGADM0,DGADM0>DGSTART S $P(DGXFR0,U,4)=$P(DGADM0,U,6),DGBEG=+DGADM0 D TABLE
23 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
24 G ENQ:DGDATA=""
25 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
26 ;
27ENQ I $D(DGSACNT),DGSACNT>25 D FLCHK
28 S L=DGPTIFN
29 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
30 Q
31 ;
32TABLE ; -- setup 535 node data
33 ; DGDATA := 1:ward cdr ^ 2:ward specialty ^ 3:leave days ^ 4:pass days ^ ^ 6:ward ^ ^ ^ ^ 10:mvt date/time
34 ;
35 S DGWD=+$P(DGXFR0,U,4)
36 G TABLEQ:'$D(^DIC(42,DGWD,0)) S DGSP=+$P(^(0),U,12)
37 G TABLEQ:'$D(^DIC(42.4,DGSP,0)) S DGCDR=$P(^(0),U,6)
38 ; -- create MPCR mvt if ward mpcr changes
39 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
40 I DGDATA="",DGCDR]"" S DGDATA=DGCDR_"^"_DGSP_"^^^^"_DGWD
41TABLEQ Q
42 ;
43CREATE ; -- create MPCR mvt
44 L +^DGPT(DGPTIFN,535) S Y=^DGPT(DGPTIFN,535,0),I=$P(Y,U,3)
45L S I=I+1 G L:$D(^DGPT(DGPTIFN,535,I))
46 S $P(^DGPT(DGPTIFN,535,0),U,3,4)=I_U_($P(Y,U,4)+1)
47 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)
48 K DA S DA=I,DA(1)=DGPTIFN,DIK="^DGPT("_DGPTIFN_",535," D IX1^DIK
49CREATEQ S DGSACNT=I
50 K DA,I,DIK Q
51 ;
52KILL ; -- clean out ward mvts
53 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
54 S:'$D(^DGPT(DGPTIFN,535,0)) ^(0)="^45.0535^"
55 K DIK,DGWI,DA Q
56 ;
57T ; -- test tag
58 S DIC(0)="AEMQZ",DIC=45,DIC("S")="I $P(^(0),U,11)=1" D ^DIC K DIC Q:Y<0
59PTF S PTF=+Y,DGDT=$S($D(^DGPT(L,70)):+^(70),1:0),DFN=+Y(0) D PM^DGPTUTL,EN:DGPMCA
60 Q
61 ;
62DAYS ; -- calc leave and pass days from DGBEG to DGEND
63 ; -- if last 501 date is after last 535 date then
64 ; calc from last 535 mvt d/t to last 501 mvt d/t
65 ;
66 ; 535 501 501 535
67 ; |------------|------|----------|
68 ; <<<<<<<<<<< total >>>>>>>>>>
69 ; <<<<<<< diff >>>>>>+<< pass >>
70 ;
71 S (PASS,LEAVE,DGDIFP,DGDIFL)=0 D MVT
72 I DGMDT>DGBEG S DGE=DGEND,DGEND=DGMDT D DAYS0 S DGDIFL=LEAVE,DGDIFP=PASS,DGEND=DGE
73 ; -- calc from last 535 mvt d/t to new 535 mvt d/t
74 S (PASS,LEAVE)=0 D DAYS0
75 ; -- substract 'diff' from 'total'
76 S PASS=PASS-DGDIFP,LEAVE=LEAVE-DGDIFL
77 K DGDIFL,DGDIFP,DGE Q
78 ;
79DAYS0 ;
80 N DGMVT
81 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
82 K DGMVTDT Q
83 ;
84DAYS1 S I=DGMVTDT,X2=$S(I<DGBEG:DGBEG,1:I),X1=$S(Y>DGBEG&(Y'>DGEND):Y,Y>DGEND!('Y):DGEND,1:X2)
85 I X1>X2 D ^%DTC S:C=1 PASS=PASS+X S:C=2 LEAVE=LEAVE+X
86 K C,X,Y,X1,X2,I
87 Q
88 ;
89NEXT ; -- find next x-ref date
90 N DGMVT
91 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
92NEXTQ Q
93 ;
94MVT ; -- find last 501 mvt d/t since the last 535 mvt d/t
95 ; and before the new 535 mvt d/t
96 S DGMDT=""
97 F M=DGLAST:0 S M=$O(^DGPT(DGPTIFN,"M","AM",M)) Q:'M!(M>DGEND) S DGMDT=M
98 K M Q
99 ;
100FLCHK ; -- check if more than 25 535s, then re-set x-mit flags
101 I '$D(DGSACNT) G FLQ
102 I DGSACNT<25 G FLQ
103 S DGF1=0
104 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
105 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
106FLQ K DGI,DGF1,DGWI,DGSAFTF,DGSACNT,DR,DA,DIE
107 Q
108 ;
Note: See TracBrowser for help on using the repository browser.