DGPMUTL ;ALB/MJK - SELECT PATIENT MOVEMENT FOR PATIENT ; 3/24/90 1PM ;
;;5.3;Registration;;Aug 13, 1993
;
EN ; -- sets DIC and DIC(0) before calling DFN (*** FOR MAS USE ONLY ***)
; input: DFN
; All desired DIC variables except DIC and DIC(0)
; output: Y, X, DTOUT, DUOUT as defined by FM documentation for ^DIC
;
S DIC="^DGPM(",DIC(0)="QES" D DFN
Q
;
DFN ; -- select mvt for DFN patient (*** FOR MAS USE ONLY ***)
; input: DFN
; All desired DIC variables
; output: Y, X, DTOUT, DUOUT as defined by FM documentation for ^DIC
;
S Y=-1,X="" G DFNQ:'$D(^DPT(DFN,0)) S X=^(0)
W !,$S($D(DIC("A")):DIC("A"),1:"Select Movement for "_$P(X,"^")_": ") I $D(DIC("B")) W DIC("B")_"// "
R X:DTIME I '$T S DTOUT="",Y=-1,X="" G DFNQ
I X="",$D(DIC("B")) S X=DIC("B")
I "^"[X S Y=-1 S:X="^" DUOUT="" G DFNQ
I $E(X)["?" D DIC G DFN
I X'=" ",$E(X)'="`" S %DT="ETP" D ^%DT K %DT G DFNQ:$D(DTOUT),DFN:+Y<0 S X=Y
D DIC G DFNQ:$D(DTOUT),DFN:+Y<0
DFNQ K D Q
;
DIC ;
F %="A","M","N" S:DIC(0)[% DIC(0)=$P(DIC(0),%)_$P(DIC(0),%,2)
S D="ADFN"_DFN D IX^DIC
Q
;
WARD ; -- determine ward at discharge
; o called by WARD AT DISCHARGE(c) field in pt mvt file
; input: D0 := d/c ifn of pat. mvt. file
;output: X := ward name
;
S X="" N IDT,MVT,CA,DFN,M
G WARDQ:'$D(^DGPM(D0,0)) S M=^(0) G WARDQ:$P(M,U,2)'=3
S CA=+$P(M,U,14),DFN=+$P(M,U,3)
F IDT=0:0 S IDT=$O(^DGPM("APMV",DFN,CA,IDT)) Q:'IDT F MVT=0:0 S MVT=$O(^DGPM("APMV",DFN,CA,IDT,MVT)) Q:'MVT I $D(^DGPM(MVT,0)) S M=^(0) I "^13^43^44^45^"'[(U_$P(M,U,18)_U),$D(^DIC(42,+$P(M,U,6),0)) S X=$P(^(0),U) G WARDQ
WARDQ Q
;
PTF(DGPTF) ; -- determine ward at discharge
; o called by WARD AT DISCHARGE(c) field in PTF file
; input: DGPTF := ifn of ptf file
;output: X := ward name
;
N D0
S D0=+$P($G(^DGPM(+$O(^DGPM("APTF",DGPTF,0)),0)),U,17)
D WARD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMUTL 1915 printed Apr 09, 2024@21:54:56 Page 2
DGPMUTL ;ALB/MJK - SELECT PATIENT MOVEMENT FOR PATIENT ; 3/24/90 1PM ;
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
EN ; -- sets DIC and DIC(0) before calling DFN (*** FOR MAS USE ONLY ***)
+1 ; input: DFN
+2 ; All desired DIC variables except DIC and DIC(0)
+3 ; output: Y, X, DTOUT, DUOUT as defined by FM documentation for ^DIC
+4 ;
+5 SET DIC="^DGPM("
SET DIC(0)="QES"
DO DFN
+6 QUIT
+7 ;
DFN ; -- select mvt for DFN patient (*** FOR MAS USE ONLY ***)
+1 ; input: DFN
+2 ; All desired DIC variables
+3 ; output: Y, X, DTOUT, DUOUT as defined by FM documentation for ^DIC
+4 ;
+5 SET Y=-1
SET X=""
if '$DATA(^DPT(DFN,0))
GOTO DFNQ
SET X=^(0)
+6 WRITE !,$SELECT($DATA(DIC("A")):DIC("A"),1:"Select Movement for "_$PIECE(X,"^")_": ")
IF $DATA(DIC("B"))
WRITE DIC("B")_"// "
+7 READ X:DTIME
IF '$TEST
SET DTOUT=""
SET Y=-1
SET X=""
GOTO DFNQ
+8 IF X=""
IF $DATA(DIC("B"))
SET X=DIC("B")
+9 IF "^"[X
SET Y=-1
if X="^"
SET DUOUT=""
GOTO DFNQ
+10 IF $EXTRACT(X)["?"
DO DIC
GOTO DFN
+11 IF X'=" "
IF $EXTRACT(X)'="`"
SET %DT="ETP"
DO ^%DT
KILL %DT
if $DATA(DTOUT)
GOTO DFNQ
if +Y<0
GOTO DFN
SET X=Y
+12 DO DIC
if $DATA(DTOUT)
GOTO DFNQ
if +Y<0
GOTO DFN
DFNQ KILL D
QUIT
+1 ;
DIC ;
+1 FOR %="A","M","N"
if DIC(0)[%
SET DIC(0)=$PIECE(DIC(0),%)_$PIECE(DIC(0),%,2)
+2 SET D="ADFN"_DFN
DO IX^DIC
+3 QUIT
+4 ;
WARD ; -- determine ward at discharge
+1 ; o called by WARD AT DISCHARGE(c) field in pt mvt file
+2 ; input: D0 := d/c ifn of pat. mvt. file
+3 ;output: X := ward name
+4 ;
+5 SET X=""
NEW IDT,MVT,CA,DFN,M
+6 if '$DATA(^DGPM(D0,0))
GOTO WARDQ
SET M=^(0)
if $PIECE(M,U,2)'=3
GOTO WARDQ
+7 SET CA=+$PIECE(M,U,14)
SET DFN=+$PIECE(M,U,3)
+8 FOR IDT=0:0
SET IDT=$ORDER(^DGPM("APMV",DFN,CA,IDT))
if 'IDT
QUIT
FOR MVT=0:0
SET MVT=$ORDER(^DGPM("APMV",DFN,CA,IDT,MVT))
if 'MVT
QUIT
IF $DATA(^DGPM(MVT,0))
SET M=^(0)
IF "^13^43^44^45^"'[(U_$PIECE(M,U,18)_U)
IF $DATA(^DIC(42,+$PIECE(M,U,6),0))
SET X=$PIECE(^(0),U)
GOTO WARDQ
WARDQ QUIT
+1 ;
PTF(DGPTF) ; -- determine ward at discharge
+1 ; o called by WARD AT DISCHARGE(c) field in PTF file
+2 ; input: DGPTF := ifn of ptf file
+3 ;output: X := ward name
+4 ;
+5 NEW D0
+6 SET D0=+$PIECE($GET(^DGPM(+$ORDER(^DGPM("APTF",DGPTF,0)),0)),U,17)
+7 DO WARD
+8 QUIT
