TIUMOVE ; SLC/JER - Patient movement look-up ;10/26/95 21:17
;;1.0;TEXT INTEGRATION UTILITIES;**3**;Jun 20, 1997
;IHS/ITSC/LJF 02/26/2003 display transfer facility based on ADT version
;
MAIN(TIUY,DFN,TIUSSN,TIUMDT,TIULDT,TIUMTYP,TIUDFLT,TIUMODE,TIULOC) ;
; Call with: .TIUY - (by ref) array in which demographic, movement,
; & visit data are returned
; [DFN] - patient file entry number
; [TIUSSN] - patient SSN
; [TIUMDT] - movement date
; [TIULDT] - upper bound of date range
; [TIUMTYP] - MAS Movement event type
; [TIUDFLT] - Default movement (e.g., "LAST")
; [TIUMODE] - mode flag 0 ==> Silent
; 1 ==> Interactive (default)
AGN ; Loop for handling repeated attempts
N TIUI,TIUII,TIUER,TIUOK,TIUOUT,TIUX,TIUMTSTR,TIUMLST,TIUCNT,X
S TIUMTYP=$S(+$G(TIUMTYP):+$G(TIUMTYP),1:1)
S TIUMODE=$S($G(TIUMODE)]"":$G(TIUMODE),1:1)
S TIUMDT=$S(+$G(TIUMDT):+$G(TIUMDT),1:2400101)
S TIULDT=$S(+$G(TIULDT):+$G(TIULDT),1:+$$NOW^TIULC)
S TIUMTSTR="ADMISSION^TRANSFER^DISCHARGE^CHECK-IN^CHECK-OUT^SPECIALTY CHANGE"
I +$G(DFN)'>0,($G(TIUSSN)]"") S DFN=+$$PATIENT^TIULA($G(TIUSSN))
I +$G(DFN)'>0 S TIUOUT=1 Q
I '$D(^DGPM("ATID"_TIUMTYP,DFN)),+TIUMODE W !,"No ",$P(TIUMTSTR,U,TIUMTYP),"S on file.",! Q
I +TIUMTYP=1,(TIUMODE=0),(TIUDFLT="CURRENT"),+$G(^DPT(DFN,.105)) S TIUX=+$G(^DPT(DFN,.105)) G VADPT
D TGET(.TIUMLST,DFN,TIUMDT,TIULDT,TIUMTYP,.TIUCNT,TIUMODE)
; If call is silent, and multiple movements in result, then quit
I '+TIUMODE,$S(+TIUCNT=1:1,TIUDFLT="LAST":1,1:0) S TIUX=$G(TIUMLST(1))
I '+TIUMODE,(+TIUCNT>1),(+$G(TIUX)'>0) Q
I '+TIUMODE,(+TIUCNT=0) Q
I +TIUMODE D I +TIUER Q:+$G(TIUOUT) G AGN
. I +TIUCNT'>0 W !,"No ",$P(TIUMTSTR,U,TIUMTYP),"S within search parameters.",! Q
. W !,"The following ",$P(TIUMTSTR,U,TIUMTYP)
. W $S(+TIUCNT>1:"(S) are",1:" is")," available:"
. S (TIUER,TIUOK,TIUI)=0
. F S TIUI=$O(TIUMLST(TIUI)) Q:+TIUI'>0!+TIUER!+TIUOK D
. . S TIUII=TIUI,TIUX=$P(TIUMLST(TIUI),"^",2,20)
. . D WRITE I '(TIUI#5) D BREAK
. Q:$D(TIUOUT)
. I +TIUER S TIUOUT=1 Q
. I TIUII#5 D BREAK Q:$D(TIUOUT)
. I +TIUER S TIUOUT=1 Q
. S TIUX=$G(TIUMLST(+TIUOK)),^DISV(DUZ,"DGPMEX",DFN)=+TIUX
. W " ",$$DATE^TIULS(+$P(TIUX,U,2),"AMTH DD CCYY@HR:MIN")
VADPT D PATVADPT^TIULV(.TIUY,DFN,+TIUX)
Q
TGET(Y,DFN,MDT,LDT,MTYPE,C,MODE) ; Get list of movements
N I,N,D S MDT=$G(MDT,9999999.9999999),MTYPE=$G(MTYPE,1),LDT=$G(LDT,0)
I MDT'=9999999.9999999 S MDT=9999999.9999999-$$IDATE^TIULC(MDT)
I LDT'=0 S LDT=9999999.9999999-$$IDATE^TIULC(LDT)
S C=0,I=LDT F S I=$O(^DGPM("ATID"_MTYPE,DFN,I)) Q:+I'>0!(+I>MDT) D
. S N=$O(^DGPM("ATID"_MTYPE,DFN,I,0)) Q:'$D(^DGPM(+N,0))
. S D=^(0),C=C+1,Y(C)=N_"^"_D
. I +$G(MODE) S Y("TIUMVD",+D)=N,Y("TIUMVDA",N)=C
Q
BREAK ; Handle prompting
W !,"CHOOSE 1-",TIUII W:$D(TIUMLST(TIUII+1)) !,"<RETURN> TO CONTINUE",!,"OR '^' TO QUIT" W ": " R X:DTIME
I $S('$T!(X["^"):1,X=""&'$D(TIUMLST(TIUII+1)):1,1:0) S TIUER=1 Q
I X="" Q
I X=" ",$D(^DISV(DUZ,"DGPMEX",DFN)) S TIUX=^(DFN) I $D(TIUMLST("TIUMVDA",+TIUX)) S TIUOK=+$G(TIUMLST("TIUMVDA",+TIUX)) Q
I X'=+X!'$D(TIUMLST(+X)) W !!,$C(7),"INVALID RESPONSE",! G BREAK
S TIUOK=X
Q
WRITE W !,$J(TIUI,4),"> ",$$DATE^TIULS(+TIUX,"AMTH DD, CCYY@HR:MIN"),?30,$S('$D(^DG(405.1,+$P(TIUX,"^",4),0)):"",$P(^(0),"^",7)]"":$P(^(0),"^",7),1:$E($P(^(0),"^",1),1,20))
;
;IHS/ITSC/LJF 02/27/2003 IHS transfer facility pointer is different from VA & different in each IHS version of ADT
;W ?55,"TO: ",$S($D(^DIC(42,+$P(TIUX,"^",6),0)):$E($P(^(0),"^",1),1,18),1:"") I $P(TIUX,"^",18)=9 W !?23,"FROM: ",$S($D(^DIC(4,+$P(TIUX,"^",5),0)):$P(^(0),"^",1),1:"") ;IHS/ITSC/LJF 02/26/2003
W ?55,"TO: ",$S($D(^DIC(42,+$P(TIUX,"^",6),0)):$E($P(^(0),"^",1),1,18),1:"")
I $P(TIUX,"^",18)=9 W !?23,"FROM: " NEW Y,C S Y=+$P(TIUX,U,5),C=$P(^DD(405,.05,0),U,2) D Y^DIQ W Y
;IHS/ITSC/LJF 02/27/2003 end of mods
;
Q
TIUMOVE ; SLC/JER - Patient movement look-up ;10/26/95 21:17
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**3**;Jun 20, 1997
+2 ;IHS/ITSC/LJF 02/26/2003 display transfer facility based on ADT version
+3 ;
MAIN(TIUY,DFN,TIUSSN,TIUMDT,TIULDT,TIUMTYP,TIUDFLT,TIUMODE,TIULOC) ;
+1 ; Call with: .TIUY - (by ref) array in which demographic, movement,
+2 ; & visit data are returned
+3 ; [DFN] - patient file entry number
+4 ; [TIUSSN] - patient SSN
+5 ; [TIUMDT] - movement date
+6 ; [TIULDT] - upper bound of date range
+7 ; [TIUMTYP] - MAS Movement event type
+8 ; [TIUDFLT] - Default movement (e.g., "LAST")
+9 ; [TIUMODE] - mode flag 0 ==> Silent
+10 ; 1 ==> Interactive (default)
AGN ; Loop for handling repeated attempts
+1 NEW TIUI,TIUII,TIUER,TIUOK,TIUOUT,TIUX,TIUMTSTR,TIUMLST,TIUCNT,X
+2 SET TIUMTYP=$SELECT(+$GET(TIUMTYP):+$GET(TIUMTYP),1:1)
+3 SET TIUMODE=$SELECT($GET(TIUMODE)]"":$GET(TIUMODE),1:1)
+4 SET TIUMDT=$SELECT(+$GET(TIUMDT):+$GET(TIUMDT),1:2400101)
+5 SET TIULDT=$SELECT(+$GET(TIULDT):+$GET(TIULDT),1:+$$NOW^TIULC)
+6 SET TIUMTSTR="ADMISSION^TRANSFER^DISCHARGE^CHECK-IN^CHECK-OUT^SPECIALTY CHANGE"
+7 IF +$GET(DFN)'>0
IF ($GET(TIUSSN)]"")
SET DFN=+$$PATIENT^TIULA($GET(TIUSSN))
+8 IF +$GET(DFN)'>0
SET TIUOUT=1
QUIT
+9 IF '$DATA(^DGPM("ATID"_TIUMTYP,DFN))
IF +TIUMODE
WRITE !,"No ",$PIECE(TIUMTSTR,U,TIUMTYP),"S on file.",!
QUIT
+10 IF +TIUMTYP=1
IF (TIUMODE=0)
IF (TIUDFLT="CURRENT")
IF +$GET(^DPT(DFN,.105))
SET TIUX=+$GET(^DPT(DFN,.105))
GOTO VADPT
+11 DO TGET(.TIUMLST,DFN,TIUMDT,TIULDT,TIUMTYP,.TIUCNT,TIUMODE)
+12 ; If call is silent, and multiple movements in result, then quit
+13 IF '+TIUMODE
IF $SELECT(+TIUCNT=1:1,TIUDFLT="LAST":1,1:0)
SET TIUX=$GET(TIUMLST(1))
+14 IF '+TIUMODE
IF (+TIUCNT>1)
IF (+$GET(TIUX)'>0)
QUIT
+15 IF '+TIUMODE
IF (+TIUCNT=0)
QUIT
+16 IF +TIUMODE
Begin DoDot:1
+17 IF +TIUCNT'>0
WRITE !,"No ",$PIECE(TIUMTSTR,U,TIUMTYP),"S within search parameters.",!
QUIT
+18 WRITE !,"The following ",$PIECE(TIUMTSTR,U,TIUMTYP)
+19 WRITE $SELECT(+TIUCNT>1:"(S) are",1:" is")," available:"
+20 SET (TIUER,TIUOK,TIUI)=0
+21 FOR
SET TIUI=$ORDER(TIUMLST(TIUI))
IF +TIUI'>0!+TIUER!+TIUOK
QUIT
Begin DoDot:2
+22 SET TIUII=TIUI
SET TIUX=$PIECE(TIUMLST(TIUI),"^",2,20)
+23 DO WRITE
IF '(TIUI#5)
DO BREAK
End DoDot:2
+24 IF $DATA(TIUOUT)
QUIT
+25 IF +TIUER
SET TIUOUT=1
QUIT
+26 IF TIUII#5
DO BREAK
IF $DATA(TIUOUT)
QUIT
+27 IF +TIUER
SET TIUOUT=1
QUIT
+28 SET TIUX=$GET(TIUMLST(+TIUOK))
SET ^DISV(DUZ,"DGPMEX",DFN)=+TIUX
+29 WRITE " ",$$DATE^TIULS(+$PIECE(TIUX,U,2),"AMTH DD CCYY@HR:MIN")
End DoDot:1
IF +TIUER
IF +$GET(TIUOUT)
QUIT
GOTO AGN
VADPT DO PATVADPT^TIULV(.TIUY,DFN,+TIUX)
+1 QUIT
TGET(Y,DFN,MDT,LDT,MTYPE,C,MODE) ; Get list of movements
+1 NEW I,N,D
SET MDT=$GET(MDT,9999999.9999999)
SET MTYPE=$GET(MTYPE,1)
SET LDT=$GET(LDT,0)
+2 IF MDT'=9999999.9999999
SET MDT=9999999.9999999-$$IDATE^TIULC(MDT)
+3 IF LDT'=0
SET LDT=9999999.9999999-$$IDATE^TIULC(LDT)
+4 SET C=0
SET I=LDT
FOR
SET I=$ORDER(^DGPM("ATID"_MTYPE,DFN,I))
IF +I'>0!(+I>MDT)
QUIT
Begin DoDot:1
+5 SET N=$ORDER(^DGPM("ATID"_MTYPE,DFN,I,0))
IF '$DATA(^DGPM(+N,0))
QUIT
+6 SET D=^(0)
SET C=C+1
SET Y(C)=N_"^"_D
+7 IF +$GET(MODE)
SET Y("TIUMVD",+D)=N
SET Y("TIUMVDA",N)=C
End DoDot:1
+8 QUIT
BREAK ; Handle prompting
+1 WRITE !,"CHOOSE 1-",TIUII
IF $DATA(TIUMLST(TIUII+1))
WRITE !,"<RETURN> TO CONTINUE",!,"OR '^' TO QUIT"
WRITE ": "
READ X:DTIME
+2 IF $SELECT('$TEST!(X["^"):1,X=""&'$DATA(TIUMLST(TIUII+1)):1,1:0)
SET TIUER=1
QUIT
+3 IF X=""
QUIT
+4 IF X=" "
IF $DATA(^DISV(DUZ,"DGPMEX",DFN))
SET TIUX=^(DFN)
IF $DATA(TIUMLST("TIUMVDA",+TIUX))
SET TIUOK=+$GET(TIUMLST("TIUMVDA",+TIUX))
QUIT
+5 IF X'=+X!'$DATA(TIUMLST(+X))
WRITE !!,$CHAR(7),"INVALID RESPONSE",!
GOTO BREAK
+6 SET TIUOK=X
+7 QUIT
WRITE WRITE !,$JUSTIFY(TIUI,4),"> ",$$DATE^TIULS(+TIUX,"AMTH DD, CCYY@HR:MIN"),?30,$SELECT('$DATA(^DG(405.1,+$PIECE(TIUX,"^",4),0)):"",$PIECE(^(0),"^",7)]"":$PIECE(^(0),"^",7),1:$EXTRACT($PIECE(^(0),"^",1),1,20))
+1 ;
+2 ;IHS/ITSC/LJF 02/27/2003 IHS transfer facility pointer is different from VA & different in each IHS version of ADT
+3 ;W ?55,"TO: ",$S($D(^DIC(42,+$P(TIUX,"^",6),0)):$E($P(^(0),"^",1),1,18),1:"") I $P(TIUX,"^",18)=9 W !?23,"FROM: ",$S($D(^DIC(4,+$P(TIUX,"^",5),0)):$P(^(0),"^",1),1:"") ;IHS/ITSC/LJF 02/26/2003
+4 WRITE ?55,"TO: ",$SELECT($DATA(^DIC(42,+$PIECE(TIUX,"^",6),0)):$EXTRACT($PIECE(^(0),"^",1),1,18),1:"")
+5 IF $PIECE(TIUX,"^",18)=9
WRITE !?23,"FROM: "
NEW Y,C
SET Y=+$PIECE(TIUX,U,5)
SET C=$PIECE(^DD(405,.05,0),U,2)
DO Y^DIQ
WRITE Y
+6 ;IHS/ITSC/LJF 02/27/2003 end of mods
+7 ;
+8 QUIT
