- 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 Jan 18, 2025@03:50:45 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