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 Apr 09, 2024@22:05:05 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
