DGPMV300 ;ALB/MIR - EDITS FOR DATE/TIME ;12 NOV 89 @8
;;5.3;Registration;;Aug 13, 1993
EDITS ;date/time edits needed for both new and existing entries
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)
I DGK=1 S X1=+DGI,X2=4 D C^%DTC I DGPMY>X S DGPME="Must be less than 96 hours" Q
I DGK=2 S X1=+DGI,X2=4 D C^%DTC I DGPMY'>X S DGPME="Must be more than 96 hours" Q
;discharge or transfer must be within 30 days of going to ASIH
S K=0 I DGK=13!(DGK=43) S K=DGJ
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
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
K DGI,DGJ,DGK,I,J,K Q
;
ASIHADM ;Check to make an ASIH admit remains within 30 days of it's discharge if appropriate
I $S('$D(^DGPM(+$P(DGPMAN,"^",21),0)):1,$P(^(0),"^",18)=13:0,1:1) Q
S DGX=$S($D(^DGPM(+$P(DGPMAN,"^",17),0)):^(0),1:"") I 'DGX Q
S X1=+DGPMP,X2=30 D C^%DTC S DGX1=X
S X1=DGPMY,X2=30 D C^%DTC S DGX2=X
I DGX1>DGX,(DGX2'>DGX) S DGPME="Must remain more than 30 days from time of return from ASIH."
I DGX1<DGX,(DGX2'<DGX) S DGPME="Must remain within 30 days of return from ASIH."
K DGX,DGX1,DGX2 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMV300 1343 printed Nov 22, 2024@18:00:15 Page 2
DGPMV300 ;ALB/MIR - EDITS FOR DATE/TIME ;12 NOV 89 @8
+1 ;;5.3;Registration;;Aug 13, 1993
EDITS ;date/time edits needed for both new and existing entries
+1 SET DGI=$ORDER(^DGPM("APMV",DFN,DGPMCA,0))
SET DGJ=$SELECT($DATA(^DGPM(+$ORDER(^(DGI,0)),0)):^(0),1:"")
SET DGI=$SELECT($DATA(^DGPM(+DGJ,0)):^(0),1:"")
SET DGK=$PIECE(DGI,"^",18)
+2 IF DGK=1
SET X1=+DGI
SET X2=4
DO C^%DTC
IF DGPMY>X
SET DGPME="Must be less than 96 hours"
QUIT
+3 IF DGK=2
SET X1=+DGI
SET X2=4
DO C^%DTC
IF DGPMY'>X
SET DGPME="Must be more than 96 hours"
QUIT
+4 ;discharge or transfer must be within 30 days of going to ASIH
+5 SET K=0
IF DGK=13!(DGK=43)
SET K=DGJ
+6 IF DGK=44!(DGK=45)
FOR I=0:0
SET I=$ORDER(^DGPM("APMV",DFN,DGPMCA,I))
if 'I
QUIT
SET J=$ORDER(^(I,0))
IF $DATA(^DGPM(+J,0))
IF ("^13^43^"[("^"_$PIECE(^(0),"^",18)_"^"))
SET K=^(0)
QUIT
+7 IF K
SET X1=+K
SET X2=30
DO C^%DTC
IF DGPMY>X
SET DGPME="Must be within 30 days of original transfer to ASIH"
QUIT
+8 KILL DGI,DGJ,DGK,I,J,K
QUIT
+9 ;
ASIHADM ;Check to make an ASIH admit remains within 30 days of it's discharge if appropriate
+1 IF $SELECT('$DATA(^DGPM(+$PIECE(DGPMAN,"^",21),0)):1,$PIECE(^(0),"^",18)=13:0,1:1)
QUIT
+2 SET DGX=$SELECT($DATA(^DGPM(+$PIECE(DGPMAN,"^",17),0)):^(0),1:"")
IF 'DGX
QUIT
+3 SET X1=+DGPMP
SET X2=30
DO C^%DTC
SET DGX1=X
+4 SET X1=DGPMY
SET X2=30
DO C^%DTC
SET DGX2=X
+5 IF DGX1>DGX
IF (DGX2'>DGX)
SET DGPME="Must remain more than 30 days from time of return from ASIH."
+6 IF DGX1<DGX
IF (DGX2'<DGX)
SET DGPME="Must remain within 30 days of return from ASIH."
+7 KILL DGX,DGX1,DGX2
QUIT
