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

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

initial load of FOIAVistA 6/30/08 version
File size: 4.8 KB
Line 
1DGUTL2 ;ALB/MJK/AAS - CALCULATE PASS DAYS UTILITY ; 8/5/02 5:48pm
2 ;;5.3;Registration;**259,468**;Aug 13, 1993
3 ;
4 ;
5CALC ; -- calculate days
6 ; input: DGBDT := begin date
7 ; DGEDT := end date
8 ; DGADM := adm date
9 ; DGPMCA:= corresponding. admission.
10 ; DGMVTP:= type movements to count - see below
11 ; output: DGREC := #days count asih
12 ;
13 Q:'$D(DGMVTP)
14 S DGREC=0,DGXFRS="^UTILITY($J,""DGXFRS"")"
15 F DGI=DGADM:0 S DGI=$O(^DGPM("APCA",DFN,DGPMCA,DGI)) Q:'DGI!(DGI>DGEDT) I $D(^DGPM(+$O(^(DGI,0)),0)),$P(^(0),U,2)=2 S @DGXFRS@(DGI)=+$P(^(0),U,18)
16 F DGI=0:0 S DGI=$O(@DGXFRS@(DGI)) Q:'DGI I DGMVTP[(U_@DGXFRS@(DGI)_U) S DGA=$O(@DGXFRS@(DGI)) I $S('DGA:1,1:DGA'<DGBDT) S X2=$S(DGI<DGBDT:DGBDT,1:DGI),X1=$S('DGA:DGEDT,DGA<DGEDT:DGA,1:DGEDT) D ^%DTC S DGREC=DGREC+X Q:'DGA
17CALCQ K @DGXFRS,DGXFRS,DGI Q
18 ;
19ASIH ;calculate asih days
20 S DGMVTP="^13^43^44^45^" G CALC
21 ;
22PL ;calculate total PASS and UA, AA leave days
23 S DGMVTP="^1^2^3^25^26^" G CALC
24 ;
25PLASIH ;calculate pass, leave and asih days
26 S DGMVTP="^1^2^3^25^26^13^43^44^45^" G CALC
27 ;
28APLD(DGPMCA,DGARR,DGBDT,DGEDT,DGMTYP) ;Return ASIH, pass & leave days and dates
29 ;Input: DGPMCA=corresponding admission (pointer to file #405).
30 ;Input: DGARR=output array name.
31 ;Input: DGBDT=billing begin date.
32 ;Input: DGEDT=billing end date.
33 ;Input: DGMTYP=movement types (optional) where:
34 ; 'A' = ASIH movements
35 ; 'P' = pass and leave movements
36 ; 'B' = both (default)
37 ;
38 ;Output: '-1' as an extrinisic value if input parameters are invalid.
39 ; 1 as an extrinisic value if input parameters are valid.
40 ; Total ASIH,PASS & LEAVE days returned as array (DGARR).
41 ;
42 ;Output: DGARR array where:
43 ; DGARR(0)=Total days^Begin date^End date.
44 ; DGARR(Movement_Ien Pointer to 405)=Movement_start_date^Movement_end_date^
45 ; Total_days^Movement_type(Pointer to 405.2)^(used only to denote a return
46 ; movement set as "RTN")^Return_Movement_type^Return_Movement_Ien.
47 ;
48 ;validate input
49 N DFN,DGMOV,DGMVTP,SOL,EOL,DGM0,TDGI,TDGM,DGI,DGM,X1,X2,DGCT,DGDIS,X
50 N DGPL,DGRC,MDT,RTN,NDGM,PROCESS,RTN,XSOL,XSOL,XDGMOV,ISOL,RCNT,DGRTMV,DGIB K DGARR
51 S DGPMCA=$G(DGPMCA),DGMTYP=$G(DGMTYP),(DGBDT)=($G(DGBDT)\1),DGEDT=($G(DGEDT)\1)
52 I DGBDT<1!(DGEDT<1)!(DGPMCA="")!'$D(^DGPM(DGPMCA,0))!(DGBDT>DGEDT) Q -1
53 I DGEDT>DT Q -1 ; no future billing dates.
54 ;initialize variables
55 S DGMVTP=$S(DGMTYP="A":"^13^43^44^45^",DGMTYP="P":"^1^2^3^25^26^",1:"^1^2^3^25^26^13^43^44^45^")
56 S DGRTMV=$S(DGMTYP="A":"^14^",DGMTYP="P":"^22^23^24^",1:"^14^22^23^24^")
57 S DGPL="^1^2^3^25^26^13^43^44^45^"
58 S DGCT=0,DGI=0,DGMOV="^TMP(""DGMOV"",$J)" K ^TMP("DGMOV",$J)
59 S DGM0=^DGPM(+DGPMCA,0),DFN=$P(DGM0,U,3) Q:$P(DGM0,U,2)'=1 -1
60 S DGDIS=$P($G(^DGPM(+$P(DGM0,U,17),0)),U) I DGDIS>1 D
61 .I DGEDT>DGDIS S DGEDT=DGDIS
62 .S DGMVTP=DGMVTP_$P(^DGPM($P(DGM0,U,17),0),U,18)_"^"
63 I DGDIS,DGBDT'<DGDIS Q -1 ; date range starts after discharge
64 S DGRC=0,DGI=DGBDT F S DGI=$O(^DGPM("APCA",DFN,DGPMCA,DGI)) Q:'DGI!(DGI\1>DGEDT) D
65 .S DGM=$O(^DGPM("APCA",DFN,DGPMCA,DGI,0)),DGM0=$G(^DGPM(DGM,0)),MDT=DGM0\1
66 .Q:MDT>DGEDT I $P(DGM0,U,2)=2!($P(DGM0,U,2)=3) S @DGMOV@(DGI,DGM)=DGM0 S DGRC=DGRC+1
67 ;Examine movements movements for selected movement option.
68 I DGRC=0 S (SOL,DGM0)=DGBDT,EOL=DGEDT,DGIB=0 D IBCHK G ENDREC ; interm billcheck
69 N DGRTNCHK,DG,DGK,DGB S (RTN,DGI,RCNT)=0 F DG=1:1 S DGI=$O(@DGMOV@(DGI)) Q:'DGI S RCNT=RCNT+1 D
70 .S DGIB=0,NDGM="",EOL=0,DGM=$O(@DGMOV@(DGI,0)),NDGM=DGI,NDGM=$O(@DGMOV@(NDGM))
71 .S DGM0=@DGMOV@(DGI,DGM),SOL=$P(DGM0,U,1)
72 .S PROCESS=$S(DGMVTP'[(U_$P(DGM0,U,18)_U):0,$P(DGM0,U,2)=3:1,1:1)
73 .S PROCESS=$S(DGRTMV[(U_$P(DGM0,U,18)_U)&(RCNT=1):1,1:PROCESS)
74 .Q:'PROCESS
75 .S DGK="",DGB=""
76 .F S DGK=$O(DGRTNCHK(DGK)) Q:DGK="" I DGRTNCHK(DGK)[(DGI_DGM) S DGB=1 Q
77 .Q:DGB
78 .S TDGI=DGI F S TDGI=$O(@DGMOV@(TDGI)) Q:'TDGI!(EOL) D
79 ..S TDGM=$O(@DGMOV@(TDGI,0)) I DGRTMV[(U_$P(@DGMOV@(TDGI,TDGM),U,18)_U) D
80 ...S RTN=U_"RTN"_U_($P((@DGMOV@(TDGI,TDGM)),U,18))_U_TDGM,EOL=1
81 ...S DGRTNCHK(DG)=TDGI_TDGM
82 .S EOL=$S('NDGM:DGEDT,NDGM>DGEDT:DGEDT,1:NDGM) D
83 ..S SOL=$S(SOL<DGBDT:DGBDT,$P(DGM0,U,2)=3&(RCNT=1):DGBDT,1:SOL)
84 ..I RCNT=1 D IBCHK I DGRTMV[(U_$P(DGM0,U,18)_U) D
85 ...S RTN=U_"RTN"_U_($P(DGM0,U,18))_U_DGM
86 ..I RCNT=1,$P(DGM0,U,2)=3,DGIB=0 Q
87 ..S X2=SOL,X1=EOL D ^%DTC I RTN=0,(EOL\1)'=(DGDIS\1),(SOL\1)'=(DGDIS\1),EOL'=NDGM S X=X+1
88 ..I X=0 S RTN=0 Q
89 ..S DGARR(DGM)=SOL_U_EOL_U_X_U_$P(DGM0,U,18)
90 ..S:RTN'=0 DGARR(DGM)=DGARR(DGM)_RTN,RTN=0
91 ..S DGCT=DGCT+X ;Grand total
92ENDREC S DGARR(0)=DGCT_U_DGBDT_U_DGEDT K ^TMP("DGMOV",$J)
93 Q 1
94IBCHK S ISOL=DGM0\1 S ISOL=$O(^DGPM("APCA",DFN,DGPMCA,ISOL),-1) I ISOL D
95 .S XDGMOV="" S XDGMOV=$O(^DGPM("APCA",DFN,DGPMCA,ISOL,XDGMOV)) Q:XDGMOV="" D
96 ..I DGMVTP[(U_$P(^DGPM(XDGMOV,0),U,18)_U) S DGIB=1 I DGRC S EOL=$S($P(DGM0,U,2)=3&(RCNT=1):EOL,1:SOL),SOL=DGBDT ;interim billing ch
97 ..I DGRC=0,DGIB=1 S X2=SOL,X1=EOL D ^%DTC S DGCT=X,DGCT=DGCT+1
98 Q
Note: See TracBrowser for help on using the repository browser.