DGPMV2.m

DGPMV2 ;ALB/MRL/MIR - PATIENT MOVEMENT PROCESSOR; [ 09/13/2001  3:57 PM ]

 ;;5.3;Registration;**40,1015**;Aug 13, 1993;Build 21

 ;IHS/ANMC/LJF  3/02/2001 added check for lockout parameter

 ;              3/08/2001 removed call to PTF file

 ;

 I '$D(DGPMVI) W !!,*7,"INPATIENT ARRAY NOT DEFINED...MODULE ENTERED INCORRECTLY" Q

 ;K DGPME S DGPMMD="",DEF="NOW",DGPM1X=0 D S I "^1^4^5^"'[("^"_DGPMT_"^") D PTF^DGPMV21 I $D(DGPME) G Q  ;IHS/ANMC/LJF 3/08/2001

 ;ihs/cmi/maw 02/08/2012 patch 1014 add PTF back in to see what happens next line

 K DGPME S DGPMMD="",DEF="NOW",DGPM1X=0 D S  ; I "^1^4^5^"'[("^"_DGPMT_"^") D PTF^DGPMV21 I $D(DGPME) G Q  ;IHS/ANMC/LJF 3/08/2001

 I DGPMT=3!(DGPMT=5) K DGPME G OLD:DGPMDCD S DGPML="",DGPM1X=1 G NEW

 D NOW^%DTC,@("S"_DGPMT)

 S DGPML=$S($D(^UTILITY("DGPMVN",$J,1)):$P(^(1),"^",2),1:"") K C,D,I,J,N

 S:$S('DGPMDCD:1,DGPMDCD>%:1,DGPM2X:1,1:0)&$S(DGPMT=1:1,DGPMT=4:1,1:0) DGPMMD=DGPML I $S('DGPMDCD:0,DGPMT=3:1,DGPMT=5:1,DGPMDCD'>%:1,1:0)&$S(DGPMT=1:0,DGPMT=4:0,1:1) S DGPMMD=DGPML,DEF=""

 I $S(DGPMT=2:1,DGPMT=6:1,1:0),DGPMDCD,(DGPMDCD<%) S DEF=""

SEL I $D(DGPME),(DGPME="***") D Q Q  ;if no PTF, quit all the way out, don't reprompt

 K DGPME I DGPMMD S Y=DGPMMD X ^DD("DD") S DEF=Y

NEW S DGX=$S(DGPMT=5:7,DGPMT=6:20,1:0) I DGX S DGONE=1 I $O(^DG(405.1,"AM",DGX,+$O(^DG(405.1,"AM",DGX,0)))) S DGONE=0

 I 'DGX S DGONE=0

 I DGPML D ^DGPMV20

 I $D(^UTILITY("DGPMVN",$J,7)) W !?22,"Enter '?' to see more choices"

SEL2 S DGPMN=0 W !! W:'DGPM1X "Select " W DGPMUC," DATE:  ",DEF W $S(DEF]"":"// ",1:"") R X:DTIME G Q:'$T!(X["^") I X["?" D SHOW G SEL2

 D UP^DGHELP I $S($E(X,1,3)="NOV":0,$E(X)="N":1,X=""&(DEF="NOW"):1,1:0) D NOW^%DTC S DGPMN=1,(DGZ,Y)=% X ^DD("DD") W "  (",Y,")" S Y=DGZ G CONT:(DEF="NOW")!(DGPMT=2)!(DGPMT=6) D E G SEL

 I X="",DGPMMD]"" S Y=DGPMMD G CONT

 ;I X=" ",$D(^DISV(DUZ,"DGPMADM",DFN)) S DGX=^(DFN) I $D(^UTILITY("DGPMVD",$J,+DGX)) S (Y,DGY)=^(DGX) X ^DD("DD") W "  (",Y,")" K DGX,DGY G CONT

 I X?1N.N,$D(^UTILITY("DGPMVN",$J,+X)) S (Y,DGZ)=$P(^(+X),"^",2) X ^DD("DD") W "  (",Y,")" S Y=DGZ G CONT

 I X=+X,(X<10000),'$D(^UTILITY("DGPMVN",$J,+X)) D E G SEL

 S %DT="SEXT",%DT(0)="-NOW" D ^%DT I $S('Y:1,$D(^UTILITY("DGPMVD",$J,+Y)):0,Y'?7N1".".N:1,1:0) D E G SEL

 I '$D(^UTILITY("DGPMVD",$J,+Y)) S DGPMN=1 I $S(DGPMMD']"":0,DGPMT=2:0,DGPMT=6:0,1:1)!($P(Y,".",2)']"") D E G SEL

CONT S DGPMY=+Y,DGPMDA=$S($D(^UTILITY("DGPMVD",$J,+Y)):+^(Y),1:"") I DGPMT=1!(DGPMT=4) S DGPMCA=+DGPMDA,DGPMAN=$S($D(^DGPM(DGPMCA,0)):^(0),1:DGPMY)

 ;

 ;IHS/ANMC/LJF 3/02/2001 added lines below to check lockout parameter

 I DGPMY,$$LOCKED^BDGPAR(BDGDIV,+DGPMY) D  G Q

 . W !!?10,"*** CAN'T EDIT A MOVEMENT OLDER THAN LOCK OUT DATE. ***"

 . W !?18,"*** CONTACT APPLICATION COORDINATOR ***" D PAUSE^BDGF

 ;IHS/ANMC/LJF 3/02/2001 end of new code

 ;

 K %DT D ^DGPMV21,SCHDADM^DGPMV22:DGPMT=1&DGPMN,^DGPMV3:DGPMY I $D(DGPME) W:DGPME'="***" !,DGPME G SEL

Q K %,D,DEF,DGPM1X,DGPMAN,DGPMCA,DGPME,DGPML,DGPMMD,DGPMN,DGONE,DGPMSA,I,J,I1,N,PTF,X,Y,^UTILITY("DGPMVD",$J),^UTILITY("DGPMVN",$J) Q

E W !?8,*7,"NOT A VALID SELECTION...CHOOSE BY DATE/TIME OR NUMBER." W:DGPMN !?8,"NEW MOVEMENT ENTRIES MUST INCLUDE A DATE AND TIME." Q

 ;

SHOW W !,"CHOOSE FROM" S %DT="RSE" W ! F I=0:0 S I=$O(^UTILITY("DGPMVN",$J,I)) Q:'I  D WR^DGPMV20

 W ! D HELP^%DTC K I,I1,N,D,C,%DT Q

 ;

S S DGPMAN=$S('DGPMVI(1):0,$D(^DGPM(+DGPMVI(13),0)):^(0),1:0),DGPMCA=$S(DGPMAN:DGPMVI(13),1:"") Q

S1 S C=0 F I=0:0 S I=$O(^DGPM("ATID1",DFN,I)) Q:'I  S N=$O(^(I,0)) I $D(^DGPM(+N,0)) S D=^(0),C=C+1,^UTILITY("DGPMVN",$J,C)=N_"^"_D,^UTILITY("DGPMVD",$J,+D)=N

 Q

S2 S C=0 F I=0:0 S I=$O(^DGPM("APMV",DFN,DGPMCA,I)) Q:'I  S N=$O(^(+I,0)) I $D(^DGPM(+N,0)),($P(^(0),"^",2)=2) S D=^(0),C=C+1,^UTILITY("DGPMVN",$J,C)=N_"^"_D,^UTILITY("DGPMVD",$J,+D)=N

 Q

S4 S C=0 F I=0:0 S I=$O(^DGPM("ATID4",DFN,I)) Q:'I  S N=$O(^(I,0)) I $D(^DGPM(+N,0)) S D=^(0),C=C+1,^UTILITY("DGPMVN",$J,C)=N_"^"_D,^UTILITY("DGPMVD",$J,+D)=N

 Q

S6 S C=0 F I=0:0 S I=$O(^DGPM("ATS",DFN,DGPMCA,I)) Q:'I  S J=$O(^(+I,0)),N=$O(^(+J,0)) I $D(^DGPM(+N,0)) S C=C+1,D=^(0),^UTILITY("DGPMVN",$J,C)=N_"^"_D,^UTILITY("DGPMVD",$J,+D)=N

 Q

OLD ;for previous entries (discharges and check-outs) skip select

 S DGPMY=+DGPMDCD,DGPMDA=+DGPMVI(17),DGPMN=0 K %DT D ^DGPMV21 I $D(DGPME) W:DGPME'="***" !,DGPME D Q Q

 I DGPMY D ^DGPMV3 I $D(DGPME) W !,DGPME G OLD

 D Q Q

DGPMV2    ;ALB/MRL/MIR - PATIENT MOVEMENT PROCESSOR; [ 09/13/2001  3:57 PM ]

 +1       ;;5.3;Registration;**40,1015**;Aug 13, 1993;Build 21

 +2       ;IHS/ANMC/LJF  3/02/2001 added check for lockout parameter

 +3       ;              3/08/2001 removed call to PTF file

 +4       ;

 +5        IF '$DATA(DGPMVI)

               WRITE !!,*7,"INPATIENT ARRAY NOT DEFINED...MODULE ENTERED INCORRECTLY"

               QUIT 

 +6       ;K DGPME S DGPMMD="",DEF="NOW",DGPM1X=0 D S I "^1^4^5^"'[("^"_DGPMT_"^") D PTF^DGPMV21 I $D(DGPME) G Q  ;IHS/ANMC/LJF 3/08/2001

 +7       ;ihs/cmi/maw 02/08/2012 patch 1014 add PTF back in to see what happens next line

 +8       ; I "^1^4^5^"'[("^"_DGPMT_"^") D PTF^DGPMV21 I $D(DGPME) G Q  ;IHS/ANMC/LJF 3/08/2001

           KILL DGPME

           SET DGPMMD=""

           SET DEF="NOW"

           SET DGPM1X=0

           DO S

 +9        IF DGPMT=3!(DGPMT=5)

               KILL DGPME

               IF DGPMDCD

                   GOTO OLD

               SET DGPML=""

               SET DGPM1X=1

               GOTO NEW

 +10       DO NOW^%DTC

           DO @("S"_DGPMT)

 +11       SET DGPML=$SELECT($DATA(^UTILITY("DGPMVN",$JOB,1)):$PIECE(^(1),"^",2),1:"")

           KILL C,D,I,J,N

 +12       IF $SELECT('DGPMDCD

               SET DGPMMD=DGPML

           IF $SELECT('DGPMDCD:0,DGPMT=3:1,DGPMT=5:1,DGPMDCD'>%:1,1:0)&$SELECT(DGPMT=1:0,DGPMT=4:0,1:1)

               SET DGPMMD=DGPML

               SET DEF=""

 +13       IF $SELECT(DGPMT=2:1,DGPMT=6:1,1:0)

               IF DGPMDCD

                   IF (DGPMDCD<%)

                       SET DEF=""

SEL       ;if no PTF, quit all the way out, don't reprompt

           IF $DATA(DGPME)

               IF (DGPME="***")

                   DO Q

                   QUIT 

 +1        KILL DGPME

           IF DGPMMD

               SET Y=DGPMMD

               XECUTE ^DD("DD")

               SET DEF=Y

NEW        SET DGX=$SELECT(DGPMT=5:7,DGPMT=6:20,1:0)

           IF DGX

               SET DGONE=1

               IF $ORDER(^DG(405.1,"AM",DGX,+$ORDER(^DG(405.1,"AM",DGX,0))))

                   SET DGONE=0

 +1        IF 'DGX

               SET DGONE=0

 +2        IF DGPML

               DO ^DGPMV20

 +3        IF $DATA(^UTILITY("DGPMVN",$JOB,7))

               WRITE !?22,"Enter '?' to see more choices"

SEL2       SET DGPMN=0

           WRITE !!

           IF 'DGPM1X

               WRITE "Select "

           WRITE DGPMUC," DATE:  ",DEF

           WRITE $SELECT(DEF]"":"// ",1:"")

           READ X:DTIME

           IF '$TEST!(X["^")

               GOTO Q

           IF X["?"

               DO SHOW

               GOTO SEL2

 +1        DO UP^DGHELP

           IF $SELECT($EXTRACT(X,1,3)="NOV":0,$EXTRACT(X)="N":1,X=""&(DEF="NOW"):1,1:0)

               DO NOW^%DTC

               SET DGPMN=1

               SET (DGZ,Y)=%

               XECUTE ^DD("DD")

               WRITE "  (",Y,")"

               SET Y=DGZ

               IF (DEF="NOW")!(DGPMT=2)!(DGPMT=6)

                   GOTO CONT

               DO E

               GOTO SEL

 +2        IF X=""

               IF DGPMMD]""

                   SET Y=DGPMMD

                   GOTO CONT

 +3       ;I X=" ",$D(^DISV(DUZ,"DGPMADM",DFN)) S DGX=^(DFN) I $D(^UTILITY("DGPMVD",$J,+DGX)) S (Y,DGY)=^(DGX) X ^DD("DD") W "  (",Y,")" K DGX,DGY G CONT

 +4        IF X?1N.N

               IF $DATA(^UTILITY("DGPMVN",$JOB,+X))

                   SET (Y,DGZ)=$PIECE(^(+X),"^",2)

                   XECUTE ^DD("DD")

                   WRITE "  (",Y,")"

                   SET Y=DGZ

                   GOTO CONT

 +5        IF X=+X

               IF (X<10000)

                   IF '$DATA(^UTILITY("DGPMVN",$JOB,+X))

                       DO E

                       GOTO SEL

 +6        SET %DT="SEXT"

           SET %DT(0)="-NOW"

           DO ^%DT

           IF $SELECT('Y:1,$DATA(^UTILITY("DGPMVD",$JOB,+Y)):0,Y'?7N1".".N:1,1:0)

               DO E

               GOTO SEL

 +7        IF '$DATA(^UTILITY("DGPMVD",$JOB,+Y))

               SET DGPMN=1

               IF $SELECT(DGPMMD']"":0,DGPMT=2:0,DGPMT=6:0,1:1)!($PIECE(Y,".",2)']"")

                   DO E

                   GOTO SEL

CONT       SET DGPMY=+Y

           SET DGPMDA=$SELECT($DATA(^UTILITY("DGPMVD",$JOB,+Y)):+^(Y),1:"")

           IF DGPMT=1!(DGPMT=4)

               SET DGPMCA=+DGPMDA

               SET DGPMAN=$SELECT($DATA(^DGPM(DGPMCA,0)):^(0),1:DGPMY)

 +1       ;

 +2       ;IHS/ANMC/LJF 3/02/2001 added lines below to check lockout parameter

 +3        IF DGPMY

               IF $$LOCKED^BDGPAR(BDGDIV,+DGPMY)

                   Begin DoDot:1

 +4                    WRITE !!?10,"*** CAN'T EDIT A MOVEMENT OLDER THAN LOCK OUT DATE. ***"

 +5                    WRITE !?18,"*** CONTACT APPLICATION COORDINATOR ***"

                       DO PAUSE^BDGF

                   End DoDot:1

                   GOTO Q

 +6       ;IHS/ANMC/LJF 3/02/2001 end of new code

 +7       ;

 +8        KILL %DT

           DO ^DGPMV21

           IF DGPMT=1&DGPMN

               DO SCHDADM^DGPMV22

           IF DGPMY

               DO ^DGPMV3

           IF $DATA(DGPME)

               IF DGPME'="***"

                   WRITE !,DGPME

               GOTO SEL

Q          KILL %,D,DEF,DGPM1X,DGPMAN,DGPMCA,DGPME,DGPML,DGPMMD,DGPMN,DGONE,DGPMSA,I,J,I1,N,PTF,X,Y,^UTILITY("DGPMVD",$JOB),^UTILITY("DGPMVN",$JOB)

           QUIT 

E          WRITE !?8,*7,"NOT A VALID SELECTION...CHOOSE BY DATE/TIME OR NUMBER."

           IF DGPMN

               WRITE !?8,"NEW MOVEMENT ENTRIES MUST INCLUDE A DATE AND TIME."

           QUIT 

 +1       ;

SHOW       WRITE !,"CHOOSE FROM"

           SET %DT="RSE"

           WRITE !

           FOR I=0:0

               SET I=$ORDER(^UTILITY("DGPMVN",$JOB,I))

               IF 'I

                   QUIT 

               DO WR^DGPMV20

 +1        WRITE !

           DO HELP^%DTC

           KILL I,I1,N,D,C,%DT

           QUIT 

 +2       ;

S          SET DGPMAN=$SELECT('DGPMVI(1):0,$DATA(^DGPM(+DGPMVI(13),0)):^(0),1:0)

           SET DGPMCA=$SELECT(DGPMAN:DGPMVI(13),1:"")

           QUIT 

S1         SET C=0

           FOR I=0:0

               SET I=$ORDER(^DGPM("ATID1",DFN,I))

               IF 'I

                   QUIT 

               SET N=$ORDER(^(I,0))

               IF $DATA(^DGPM(+N,0))

                   SET D=^(0)

                   SET C=C+1

                   SET ^UTILITY("DGPMVN",$JOB,C)=N_"^"_D

                   SET ^UTILITY("DGPMVD",$JOB,+D)=N

 +1        QUIT 

S2         SET C=0

           FOR I=0:0

               SET I=$ORDER(^DGPM("APMV",DFN,DGPMCA,I))

               IF 'I

                   QUIT 

               SET N=$ORDER(^(+I,0))

               IF $DATA(^DGPM(+N,0))

                   IF ($PIECE(^(0),"^",2)=2)

                       SET D=^(0)

                       SET C=C+1

                       SET ^UTILITY("DGPMVN",$JOB,C)=N_"^"_D

                       SET ^UTILITY("DGPMVD",$JOB,+D)=N

 +1        QUIT 

S4         SET C=0

           FOR I=0:0

               SET I=$ORDER(^DGPM("ATID4",DFN,I))

               IF 'I

                   QUIT 

               SET N=$ORDER(^(I,0))

               IF $DATA(^DGPM(+N,0))

                   SET D=^(0)

                   SET C=C+1

                   SET ^UTILITY("DGPMVN",$JOB,C)=N_"^"_D

                   SET ^UTILITY("DGPMVD",$JOB,+D)=N

 +1        QUIT 

S6         SET C=0

           FOR I=0:0

               SET I=$ORDER(^DGPM("ATS",DFN,DGPMCA,I))

               IF 'I

                   QUIT 

               SET J=$ORDER(^(+I,0))

               SET N=$ORDER(^(+J,0))

               IF $DATA(^DGPM(+N,0))

                   SET C=C+1

                   SET D=^(0)

                   SET ^UTILITY("DGPMVN",$JOB,C)=N_"^"_D

                   SET ^UTILITY("DGPMVD",$JOB,+D)=N

 +1        QUIT 

OLD       ;for previous entries (discharges and check-outs) skip select

 +1        SET DGPMY=+DGPMDCD

           SET DGPMDA=+DGPMVI(17)

           SET DGPMN=0

           KILL %DT

           DO ^DGPMV21

           IF $DATA(DGPME)

               IF DGPME'="***"

                   WRITE !,DGPME

               DO Q

               QUIT 

 +2        IF DGPMY

               DO ^DGPMV3

               IF $DATA(DGPME)

                   WRITE !,DGPME

                   GOTO OLD

 +3        DO Q

           QUIT