- DGPMV2 ;ALB/MRL/MIR - PATIENT MOVEMENT PROCESSOR; 21 APR 1989
- ;;5.3;Registration;**40**;Aug 13, 1993;Build 2
- 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
- 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)
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMV2 3678 printed Jan 18, 2025@03:50:49 Page 2
- DGPMV2 ;ALB/MRL/MIR - PATIENT MOVEMENT PROCESSOR; 21 APR 1989
- +1 ;;5.3;Registration;**40**;Aug 13, 1993;Build 2
- +2 IF '$DATA(DGPMVI)
- WRITE !!,*7,"INPATIENT ARRAY NOT DEFINED...MODULE ENTERED INCORRECTLY"
- QUIT
- +3 KILL DGPME
- SET DGPMMD=""
- SET DEF="NOW"
- SET DGPM1X=0
- DO S
- IF "^1^4^5^"'[("^"_DGPMT_"^")
- DO PTF^DGPMV21
- IF $DATA(DGPME)
- GOTO Q
- +4 IF DGPMT=3!(DGPMT=5)
- KILL DGPME
- if DGPMDCD
- GOTO OLD
- SET DGPML=""
- SET DGPM1X=1
- GOTO NEW
- +5 DO NOW^%DTC
- DO @("S"_DGPMT)
- +6 SET DGPML=$SELECT($DATA(^UTILITY("DGPMVN",$JOB,1)):$PIECE(^(1),"^",2),1:"")
- KILL C,D,I,J,N
- +7 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=""
- +8 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 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