DGPMUTL.m

DGPMUTL ;ALB/MJK - SELECT PATIENT MOVEMENT FOR PATIENT ; 3/24/90 1PM ;

 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

 ;

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

DGPMUTL   ;ALB/MJK - SELECT PATIENT MOVEMENT FOR PATIENT ; 3/24/90 1PM ;

 +1       ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

 +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