DGPMV300.m

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 ---DGPMV300   1343     printed  Apr 09, 2024@22:06:26                                                                                                                                                                                                    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