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

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

initial load of WorldVistAEHR

File size: 1.3 KB
RevLine 
[613]1DGPMV300 ;ALB/MIR - EDITS FOR DATE/TIME ;12 NOV 89 @8
2 ;;5.3;Registration;;Aug 13, 1993
3EDITS ;date/time edits needed for both new and existing entries
4 S DGI=$O(^DGPM("APMV",DFN,DGPMCA,0)),DGJ=$S($D(^DGPM(+$O(^(DGI,0)),0)):^(0),1:""),DGI=$S($D(^DGPM(+DGJ,0)):^(0),1:""),DGK=$P(DGI,"^",18)
5 I DGK=1 S X1=+DGI,X2=4 D C^%DTC I DGPMY>X S DGPME="Must be less than 96 hours" Q
6 I DGK=2 S X1=+DGI,X2=4 D C^%DTC I DGPMY'>X S DGPME="Must be more than 96 hours" Q
7 ;discharge or transfer must be within 30 days of going to ASIH
8 S K=0 I DGK=13!(DGK=43) S K=DGJ
9 I DGK=44!(DGK=45) F I=0:0 S I=$O(^DGPM("APMV",DFN,DGPMCA,I)) Q:'I S J=$O(^(I,0)) I $D(^DGPM(+J,0)),("^13^43^"[("^"_$P(^(0),"^",18)_"^")) S K=^(0) Q
10 I K S X1=+K,X2=30 D C^%DTC I DGPMY>X S DGPME="Must be within 30 days of original transfer to ASIH" Q
11 K DGI,DGJ,DGK,I,J,K Q
12 ;
13ASIHADM ;Check to make an ASIH admit remains within 30 days of it's discharge if appropriate
14 I $S('$D(^DGPM(+$P(DGPMAN,"^",21),0)):1,$P(^(0),"^",18)=13:0,1:1) Q
15 S DGX=$S($D(^DGPM(+$P(DGPMAN,"^",17),0)):^(0),1:"") I 'DGX Q
16 S X1=+DGPMP,X2=30 D C^%DTC S DGX1=X
17 S X1=DGPMY,X2=30 D C^%DTC S DGX2=X
18 I DGX1>DGX,(DGX2'>DGX) S DGPME="Must remain more than 30 days from time of return from ASIH."
19 I DGX1<DGX,(DGX2'<DGX) S DGPME="Must remain within 30 days of return from ASIH."
20 K DGX,DGX1,DGX2 Q
Note: See TracBrowser for help on using the repository browser.