source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMV2.m@ 1621

Last change on this file since 1621 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.5 KB
Line 
1DGPMV2 ;ALB/MRL/MIR - PATIENT MOVEMENT PROCESSOR; 21 APR 1989
2 ;;5.3;Registration;**40**;Aug 13, 1993
3 I '$D(DGPMVI) W !!,*7,"INPATIENT ARRAY NOT DEFINED...MODULE ENTERED INCORRECTLY" Q
4 K DGPME S DGPMMD="",DEF="NOW",DGPM1X=0 D S I "^1^4^5^"'[("^"_DGPMT_"^") D PTF^DGPMV21 I $D(DGPME) G Q
5 I DGPMT=3!(DGPMT=5) K DGPME G OLD:DGPMDCD S DGPML="",DGPM1X=1 G NEW
6 D NOW^%DTC,@("S"_DGPMT)
7 S DGPML=$S($D(^UTILITY("DGPMVN",$J,1)):$P(^(1),"^",2),1:"") K C,D,I,J,N
8 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=""
9 I $S(DGPMT=2:1,DGPMT=6:1,1:0),DGPMDCD,(DGPMDCD<%) S DEF=""
10SEL I $D(DGPME),(DGPME="***") D Q Q ;if no PTF, quit all the way out, don't reprompt
11 K DGPME I DGPMMD S Y=DGPMMD X ^DD("DD") S DEF=Y
12NEW 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
13 I 'DGX S DGONE=0
14 I DGPML D ^DGPMV20
15 I $D(^UTILITY("DGPMVN",$J,7)) W !?22,"Enter '?' to see more choices"
16SEL2 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
17 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
18 I X="",DGPMMD]"" S Y=DGPMMD G CONT
19 ;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
20 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
21 I X=+X,(X<10000),'$D(^UTILITY("DGPMVN",$J,+X)) D E G SEL
22 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
23 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
24CONT 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)
25 K %DT D ^DGPMV21,SCHDADM^DGPMV22:DGPMT=1&DGPMN,^DGPMV3:DGPMY I $D(DGPME) W:DGPME'="***" !,DGPME G SEL
26Q 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
27E 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
28 ;
29SHOW W !,"CHOOSE FROM" S %DT="RSE" W ! F I=0:0 S I=$O(^UTILITY("DGPMVN",$J,I)) Q:'I D WR^DGPMV20
30 W ! D HELP^%DTC K I,I1,N,D,C,%DT Q
31 ;
32S S DGPMAN=$S('DGPMVI(1):0,$D(^DGPM(+DGPMVI(13),0)):^(0),1:0),DGPMCA=$S(DGPMAN:DGPMVI(13),1:"") Q
33S1 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
34 Q
35S2 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
36 Q
37S4 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
38 Q
39S6 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
40 Q
41OLD ;for previous entries (discharges and check-outs) skip select
42 S DGPMY=+DGPMDCD,DGPMDA=+DGPMVI(17),DGPMN=0 K %DT D ^DGPMV21 I $D(DGPME) W:DGPME'="***" !,DGPME D Q Q
43 I DGPMY D ^DGPMV3 I $D(DGPME) W !,DGPME G OLD
44 D Q Q
Note: See TracBrowser for help on using the repository browser.