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

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

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1DGOIL2 ;ALB/AAS - CALCULATE LOS BY TRANSFER ; 28-SEPT-90
2 ;;5.3;Registration;**93,498**;Aug 13, 1993
3 ;
4 ;INPUT - Admission ifn in DGPMIFN - call EN^
5 ;
6 ;OUTPUT - x(t)=net los^auth absence days^pass days^unauth days^asih days^gross los^trf date^ward
7 ; x3=sum of x(t's)
8 ;
9EN N T,I S (LOP,LOA,LOUA,LOAS)=0
10 S (X,X3)="0^0^0^0^0^0^0"
11 I $S('$D(DGPMIFN):1,'$D(^DGPM(+DGPMIFN,0)):1,$P(^(0),"^",2)'=1:1,1:0) G END
12 S B=^DGPM(DGPMIFN,0),DFN=$P(B,"^",3),A=+B
13 I $P(B,"^",22) S:$L(A)=7 A=A_"." S A=A_"000000",A=$E(A,1,14)_$P(B,"^",22)
14ASIH S DGASIH="" I $P(B,"^",18)=40,$P(B,"^",21),$P(^DGPM($P(B,"^",21),0),"^",14) S ADM=^DGPM($P(^DGPM($P(B,"^",21),0),"^",14),0),DIS=$P(ADM,"^",17) I DIS]"",$D(^DGPM(DIS,0)),+^(0)>DT S DGASIH="+" ;currently asih flag
15 D MAX
16 ;
17 S (I,DGT)=1
18ADM F DGT=DGT:1 S A1=A,DGPMIFN1=$O(^DGPM("APCA",DFN,DGPMIFN,A,0)) Q:'DGPMIFN1!('A)!('I) D TRANS
19 Q:$D(DGPMIFN(1))
20 S $P(X3,"^",9)=DGASIH
21 S $P(X3,"^",10)=$S($P($G(^DGPM(DGPMIFN,"DIR")),"^",1)'=0:"!",1:"")
22 G END
23 ;
24EN1 ; - entry to find los for one transfer
25 ; - input DGPMIFN1 = transfer
26 ; - output in X(t) if '$d(DGT) t=1
27 ;
28 I $S('$D(DGPMIFN1):1,'$D(^DGPM(DGPMIFN1,0)):1,$P(^(0),"^",2)>2:1,1:0) S DGOUT=1 G EN1Q
29 S DGPMIFN=$P(^DGPM(DGPMIFN1,0),"^",14) I $S('DGPMIFN:1,'$D(^DGPM(DGPMIFN,0)):1,1:0) S DGOUT=1 G EN1Q
30 S B=^DGPM(DGPMIFN,0)
31 S DGT=1 D MAX
32TRANS S (DGOUT,LOP,LOA,LOUA,LOAS)=0
33 S X(DGT)="0^0^0^0^0^0^0^0^"
34 S B(DGT)=^DGPM(DGPMIFN1,0)
35 S DGWRD=+$P(B(DGT),"^",6) I +DGWRD,$D(^DIC(42,+DGWRD,0)) S DGWRD=$P(^(0),"^")
36 E S DGWRD=""
37 ;
38 S DGDONE=0
39 F I=A:0 S I=$O(^DGPM("APCA",DFN,DGPMIFN,I)) Q:'I S:$E(I,1,$L(D))'=D A=I S DGS=$O(^(I,0)) I $D(^DGPM(+DGS,0)) S Z=DGS,DGS=^(0) I "^1^2^3^4^25^26^13^14^43^44^45^"[("^"_$P(DGS,"^",18)_"^") S X2=+DGS,DGS=("^"_$P(DGS,"^",18)_"^") D ABS Q:'I!DGOUT
40 I 'DGDONE,'I S A1=A,A=D ;end of movements, a1=start of last trf, a=dschrg or now
41 D TRFTOT
42 I $D(DGS),"^13^"[DGS D ^DGOIL3
43EN1Q K DGWRD
44 Q
45 ;
46ABS ; - if patient was on absence, find return.
47 ; - DGS = mvt type at start of absence
48 ; - DGE = mvt type at end of absence
49 ;
50 I "^43^"[DGS S DGOF=$S($P(^DGPM(Z,0),"^",5):$S($D(^DIC(4,$P(^DGPM(Z,0),"^",5),0)):$P(^(0),"^"),1:"UNK"),1:"UNK")
51 I "^4^13^43^"[DGS S DGOUT=1 Q ;start new transfers
52 ;
53 I "^14^"[DGS S:$D(DGOF) DGOFF=1 S X1=A,X2=A1 D ^%DTC S LOAS=LOAS+X,DGOUT=1 Q
54 ;
55TF S X1=0 F I=I:0 S I=$O(^DGPM("APCA",DFN,DGPMIFN,I)) Q:'I S DGE=$O(^(I,0)) I $D(^DGPM(+DGE,0)) S DGE=^(0) I "^4^13^14^22^23^24^25^26^43^"[("^"_$P(DGE,"^",18)_"^") S (X1,DGET)=+DGE,DGE="^"_$P(DGE,"^",18)_"^" Q
56 ;
57 I 'X1 S (A,X1)=D D ^%DTC S DGOUT=1 D NORET Q ;if no return from absence use discharge or now
58 D ^%DTC
59 ;
60 ;if 22 or 26 add time in unauth
61 I "^22^26^"[DGE S LOUA=LOUA+X,A=A1
62 ;
63 ;if 23 add time in pass
64 I "^23^"[DGE S LOP=LOP+X,A=A1
65 ;
66 ;if 24 or 25 add time in auth
67 I "^24^25^"[DGE S LOA=LOA+X,A=A1
68 ;
69 I "^14^"[DGE S LOAS=LOAS+X,DGOUT=1
70 ;
71 ;if 25 or 26 sets tranf to and looks for next return
72 I "^25^26"[DGE S DGS=DGE,X2=DGET G TF
73 ;
74 I "^14^44^"[DGE S DGOUT=1 Q ;I wonder if this is really necessary?
75 Q
76 ;
77TOT ; -- total los from transfer x(t) into x3
78 F JJ=1:1:6 S $P(X3,"^",JJ)=$P(X3,"^",JJ)+($P(X(DGT),"^",JJ))
79 F JJ=7:1:8 S $P(X3,"^",JJ)=$P(X(DGT),"^",JJ)
80 Q
81 ;
82TRFTOT ; los for transfer, set x(t)
83 S X1=A,X2=A1 D ^%DTC
84 S X(DGT)=(X-(LOA+LOUA))_"^"_LOA_"^"_LOP_"^"_LOUA_"^"_$S($D(DGPMIFN(1)):X,1:LOAS)_"^"_X_"^"_A1_"^"_$S($D(DGOFF):DGOF,1:DGWRD),DGOUT=1 K:$D(DGOFF) DGOFF,DGOF
85 D TOT
86 Q
87 ;
88NORET ; -- If discharge while absent find absence up to discharge
89 S DGDONE=1
90 I "^1^"[DGS S LOP=LOP+X
91 I "^2^26^"[DGS S LOA=LOA+X
92 I "^3^25^"[DGS S LOUA=LOUA+X
93 I "^14^43^44^45^"[DGS S LOAS=LOAS+X
94 Q
95END K A,A1,B,D,DGDONE,DGE,DGET,DGMAX,DGOUT,DGPMIFN,DGPMIFN1,DGS,DGT,DGWRD,I,JJ,LOA,LOAS,LOP,LOUA,T,X1,X2
96 Q
97MAX D NOW^%DTC S D=$S($D(^DGPM(+$P(B,"^",17),0)):+^(0),1:0) S D=$S('D:%,D>%:%,1:D) S X1=D,X2=A D ^%DTC S DGMAX=$S(X:X,1:1)
98 Q
Note: See TracBrowser for help on using the repository browser.