TIUSRV1 ; SLC/JER - More silent server functions ; 07/31/2002 12:22
;;1.0;TEXT INTEGRATION UTILITIES;**61,100,112**;Jun 20, 1997
REASSIGN(TIUDA,REASSIGN,TIUL) ; Reassign Hx
N TIUI,DR,DIC,DIQ,TIUREASS S TIUI=0
I +$P(^TIU(8925,TIUDA,0),U,5)'=15,(+$G(REASSIGN)=0) Q
S TIUL=TIUL+1 D BLANK^TIUSRV(TIUL) S TIUL=TIUL+1
D SET^TIUSRV(TIUL,2," Reassignment History ",$G(IORVON),$G(IORVOFF))
I '+$O(^TIU(8925.5,"AR",+TIUDA,0)) D
. N TIUI
. D SET^TIUSRV(TIUL,26,"Document Never Reassigned.")
. F TIUI=(TIUL+1):1:16 S @VALMAR@(TIUI,0)=" "
F S TIUI=$O(^TIU(8925.5,"AR",TIUDA,TIUI)) Q:+TIUI'>0 D
. N DA S DA=0
. F S DA=$O(^TIU(8925.5,"AR",TIUDA,TIUI,DA)) Q:+DA'>0 D
. . S DR="1.01:1.12",DIC="^TIU(8925.5,",DIQ="TIUREASS"
. . D EN^DIQ1 Q:$D(TIUREASS)'>9!($G(TIUREASS(8925.5,DA,1.01))']"")
. . S TIUCNT=+$G(TIUCNT)+1 I TIUCNT>1 S TIUL=TIUL+1 D BLANK^TIUSRV(TIUL)
. . S TIUL=TIUL+1
. . D SET^TIUSRV(TIUL,2," Reassign Date: "_$G(TIUREASS(8925.5,DA,1.01)))
. . D SET^TIUSRV(TIUL,44," Reassigned By: "_$G(TIUREASS(8925.5,DA,1.02)))
. . S TIUL=TIUL+1
. . D SET^TIUSRV(TIUL,2," Patient: "_$G(TIUREASS(8925.5,DA,1.03)))
. . D SET^TIUSRV(TIUL,44," ---> "_$G(TIUREASS(8925.5,DA,1.04)))
. . S TIUL=TIUL+1
. . D SET^TIUSRV(TIUL,2,"Visit Date/time: "_$G(TIUREASS(8925.5,DA,1.05)))
. . D SET^TIUSRV(TIUL,44," ---> "_$G(TIUREASS(8925.5,DA,1.06)))
. . S TIUL=TIUL+1
. . D SET^TIUSRV(TIUL,2," Hosp Location: "_$G(TIUREASS(8925.5,DA,1.07)))
. . D SET^TIUSRV(TIUL,44," ---> "_$G(TIUREASS(8925.5,DA,1.08)))
. . S TIUL=TIUL+1
. . D SET^TIUSRV(TIUL,2," Visit Type: "_$$UP^XLFSTR($G(TIUREASS(8925.5,DA,1.09))))
. . D SET^TIUSRV(TIUL,44," ---> "_$$UP^XLFSTR($G(TIUREASS(8925.5,DA,1.1))))
Q
IDLINK(TIUDA,TIUL) ; Show Attach/Detach Hx
N TIUI S TIUI=0
Q:'$$IDHX(TIUDA)
S TIUL=TIUL+1 D BLANK^TIUSRV(TIUL) S TIUL=TIUL+1
D SET^TIUSRV(TIUL,1," Interdisciplinary Linkage History ",$G(IORVON),$G(IORVOFF))
S TIUL=TIUL+1 D BLANK^TIUSRV(TIUL) S TIUL=TIUL+1
D SET^TIUSRV(TIUL,0,"Date/Time "_$S(+$G(^TIU(8925,+TIUDA,21)):"ID Parent",1:"Entry # ")_" Title Action By") S TIUL=TIUL+1
D SET^TIUSRV(TIUL,0,"---------------- ---------- ------------------------ -------- -------------")
; First, get events for ID Parents
F S TIUI=$O(^TIU(8925.5,"AID",TIUDA,TIUI)) Q:+TIUI'>0 D
. N TIUD0,TIUD3,TIUY,EVDT,ENTDA,ENTTL,ACTION,DOER
. Q:'$L($G(^TIU(8925.5,TIUI,3)))
. S TIUD0=$G(^TIU(8925.5,TIUI,0)),TIUD3=$G(^(3))
. S ENTDA=+TIUD0
. S ACTION=$P(TIUD3,U),ACTION=$S(ACTION="d":"detached",1:"attached")
. S EVDT=$$DATE^TIULS($P(TIUD3,U,2),"MM/DD/CCYY HR:MIN")
. S ENTTL=$$PNAME^TIULC1(+$G(^TIU(8925,ENTDA,0)))
. S DOER=$$NAME^TIULS($$PERSNAME^TIULC1(+$P(TIUD3,U,3)),"LAST,FI")
. S TIUY="" S TIUY=$$SETSTR^VALM1(EVDT,TIUY,1,16)
. S TIUY=$$SETSTR^VALM1(ENTDA,TIUY,19,10)
. S TIUY=$$SETSTR^VALM1(ENTTL,TIUY,31,24)
. S TIUY=$$SETSTR^VALM1(ACTION,TIUY,57,8)
. S TIUY=$$SETSTR^VALM1(DOER,TIUY,67,14)
. S TIUL=TIUL+1 D SET^TIUSRV(TIUL,0,TIUY)
; Next, get hx for ID Entries
F S TIUI=$O(^TIU(8925.5,"B",TIUDA,TIUI)) Q:+TIUI'>0 D
. N TIUD0,TIUD3,TIUY,EVDT,ENTDA,IDDAD,IDTTL,ACTION,DOER
. Q:'$L($G(^TIU(8925.5,TIUI,3)))
. S TIUD0=$G(^TIU(8925.5,TIUI,0)),TIUD3=$G(^(3))
. S ENTDA=+TIUD0,IDDAD=$P(TIUD3,U,5)
. S ACTION=$P(TIUD3,U),ACTION=$S(ACTION="d":"detached",1:"attached")
. S EVDT=$$DATE^TIULS($P(TIUD3,U,2),"MM/DD/CCYY HR:MIN")
. S IDTTL=$$PNAME^TIULC1(+$G(^TIU(8925,IDDAD,0)))
. S DOER=$$NAME^TIULS($$PERSNAME^TIULC1(+$P(TIUD3,U,3)),"LAST,FI")
. S TIUY="" S TIUY=$$SETSTR^VALM1(EVDT,TIUY,1,16)
. S TIUY=$$SETSTR^VALM1(IDDAD,TIUY,19,10)
. S TIUY=$$SETSTR^VALM1(IDTTL,TIUY,31,24)
. S TIUY=$$SETSTR^VALM1(ACTION,TIUY,57,8)
. S TIUY=$$SETSTR^VALM1(DOER,TIUY,67,14)
. S TIUL=TIUL+1 D SET^TIUSRV(TIUL,0,TIUY)
Q
IDHX(TIUDA) ; Boolean fn to evaluate whether ID history exists
N TIUI,TIUY S TIUY=0
S TIUI=0
F S TIUI=$O(^TIU(8925.5,"B",TIUDA,TIUI)) Q:+TIUI'>0 D Q:+TIUY
. S:$L($G(^TIU(8925.5,TIUI,3))) TIUY=1
S TIUI=0
F S TIUI=$O(^TIU(8925.5,"AID",TIUDA,TIUI)) Q:+TIUI'>0 D Q:+TIUY
. S:$L($G(^TIU(8925.5,TIUI,3))) TIUY=1
IDHXX Q TIUY
TIUSRV1 ; SLC/JER - More silent server functions ; 07/31/2002 12:22
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**61,100,112**;Jun 20, 1997
REASSIGN(TIUDA,REASSIGN,TIUL) ; Reassign Hx
+1 NEW TIUI,DR,DIC,DIQ,TIUREASS
SET TIUI=0
+2 IF +$PIECE(^TIU(8925,TIUDA,0),U,5)'=15
IF (+$GET(REASSIGN)=0)
QUIT
+3 SET TIUL=TIUL+1
DO BLANK^TIUSRV(TIUL)
SET TIUL=TIUL+1
+4 DO SET^TIUSRV(TIUL,2," Reassignment History ",$GET(IORVON),$GET(IORVOFF))
+5 IF '+$ORDER(^TIU(8925.5,"AR",+TIUDA,0))
Begin DoDot:1
+6 NEW TIUI
+7 DO SET^TIUSRV(TIUL,26,"Document Never Reassigned.")
+8 FOR TIUI=(TIUL+1):1:16
SET @VALMAR@(TIUI,0)=" "
End DoDot:1
+9 FOR
SET TIUI=$ORDER(^TIU(8925.5,"AR",TIUDA,TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:1
+10 NEW DA
SET DA=0
+11 FOR
SET DA=$ORDER(^TIU(8925.5,"AR",TIUDA,TIUI,DA))
IF +DA'>0
QUIT
Begin DoDot:2
+12 SET DR="1.01:1.12"
SET DIC="^TIU(8925.5,"
SET DIQ="TIUREASS"
+13 DO EN^DIQ1
IF $DATA(TIUREASS)'>9!($GET(TIUREASS(8925.5,DA,1.01))']"")
QUIT
+14 SET TIUCNT=+$GET(TIUCNT)+1
IF TIUCNT>1
SET TIUL=TIUL+1
DO BLANK^TIUSRV(TIUL)
+15 SET TIUL=TIUL+1
+16 DO SET^TIUSRV(TIUL,2," Reassign Date: "_$GET(TIUREASS(8925.5,DA,1.01)))
+17 DO SET^TIUSRV(TIUL,44," Reassigned By: "_$GET(TIUREASS(8925.5,DA,1.02)))
+18 SET TIUL=TIUL+1
+19 DO SET^TIUSRV(TIUL,2," Patient: "_$GET(TIUREASS(8925.5,DA,1.03)))
+20 DO SET^TIUSRV(TIUL,44," ---> "_$GET(TIUREASS(8925.5,DA,1.04)))
+21 SET TIUL=TIUL+1
+22 DO SET^TIUSRV(TIUL,2,"Visit Date/time: "_$GET(TIUREASS(8925.5,DA,1.05)))
+23 DO SET^TIUSRV(TIUL,44," ---> "_$GET(TIUREASS(8925.5,DA,1.06)))
+24 SET TIUL=TIUL+1
+25 DO SET^TIUSRV(TIUL,2," Hosp Location: "_$GET(TIUREASS(8925.5,DA,1.07)))
+26 DO SET^TIUSRV(TIUL,44," ---> "_$GET(TIUREASS(8925.5,DA,1.08)))
+27 SET TIUL=TIUL+1
+28 DO SET^TIUSRV(TIUL,2," Visit Type: "_$$UP^XLFSTR($GET(TIUREASS(8925.5,DA,1.09))))
+29 DO SET^TIUSRV(TIUL,44," ---> "_$$UP^XLFSTR($GET(TIUREASS(8925.5,DA,1.1))))
End DoDot:2
End DoDot:1
+30 QUIT
IDLINK(TIUDA,TIUL) ; Show Attach/Detach Hx
+1 NEW TIUI
SET TIUI=0
+2 IF '$$IDHX(TIUDA)
QUIT
+3 SET TIUL=TIUL+1
DO BLANK^TIUSRV(TIUL)
SET TIUL=TIUL+1
+4 DO SET^TIUSRV(TIUL,1," Interdisciplinary Linkage History ",$GET(IORVON),$GET(IORVOFF))
+5 SET TIUL=TIUL+1
DO BLANK^TIUSRV(TIUL)
SET TIUL=TIUL+1
+6 DO SET^TIUSRV(TIUL,0,"Date/Time "_$SELECT(+$GET(^TIU(8925,+TIUDA,21)):"ID Parent",1:"Entry # ")_" Title Action By")
SET TIUL=TIUL+1
+7 DO SET^TIUSRV(TIUL,0,"---------------- ---------- ------------------------ -------- -------------")
+8 ; First, get events for ID Parents
+9 FOR
SET TIUI=$ORDER(^TIU(8925.5,"AID",TIUDA,TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:1
+10 NEW TIUD0,TIUD3,TIUY,EVDT,ENTDA,ENTTL,ACTION,DOER
+11 IF '$LENGTH($GET(^TIU(8925.5,TIUI,3)))
QUIT
+12 SET TIUD0=$GET(^TIU(8925.5,TIUI,0))
SET TIUD3=$GET(^(3))
+13 SET ENTDA=+TIUD0
+14 SET ACTION=$PIECE(TIUD3,U)
SET ACTION=$SELECT(ACTION="d":"detached",1:"attached")
+15 SET EVDT=$$DATE^TIULS($PIECE(TIUD3,U,2),"MM/DD/CCYY HR:MIN")
+16 SET ENTTL=$$PNAME^TIULC1(+$GET(^TIU(8925,ENTDA,0)))
+17 SET DOER=$$NAME^TIULS($$PERSNAME^TIULC1(+$PIECE(TIUD3,U,3)),"LAST,FI")
+18 SET TIUY=""
SET TIUY=$$SETSTR^VALM1(EVDT,TIUY,1,16)
+19 SET TIUY=$$SETSTR^VALM1(ENTDA,TIUY,19,10)
+20 SET TIUY=$$SETSTR^VALM1(ENTTL,TIUY,31,24)
+21 SET TIUY=$$SETSTR^VALM1(ACTION,TIUY,57,8)
+22 SET TIUY=$$SETSTR^VALM1(DOER,TIUY,67,14)
+23 SET TIUL=TIUL+1
DO SET^TIUSRV(TIUL,0,TIUY)
End DoDot:1
+24 ; Next, get hx for ID Entries
+25 FOR
SET TIUI=$ORDER(^TIU(8925.5,"B",TIUDA,TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:1
+26 NEW TIUD0,TIUD3,TIUY,EVDT,ENTDA,IDDAD,IDTTL,ACTION,DOER
+27 IF '$LENGTH($GET(^TIU(8925.5,TIUI,3)))
QUIT
+28 SET TIUD0=$GET(^TIU(8925.5,TIUI,0))
SET TIUD3=$GET(^(3))
+29 SET ENTDA=+TIUD0
SET IDDAD=$PIECE(TIUD3,U,5)
+30 SET ACTION=$PIECE(TIUD3,U)
SET ACTION=$SELECT(ACTION="d":"detached",1:"attached")
+31 SET EVDT=$$DATE^TIULS($PIECE(TIUD3,U,2),"MM/DD/CCYY HR:MIN")
+32 SET IDTTL=$$PNAME^TIULC1(+$GET(^TIU(8925,IDDAD,0)))
+33 SET DOER=$$NAME^TIULS($$PERSNAME^TIULC1(+$PIECE(TIUD3,U,3)),"LAST,FI")
+34 SET TIUY=""
SET TIUY=$$SETSTR^VALM1(EVDT,TIUY,1,16)
+35 SET TIUY=$$SETSTR^VALM1(IDDAD,TIUY,19,10)
+36 SET TIUY=$$SETSTR^VALM1(IDTTL,TIUY,31,24)
+37 SET TIUY=$$SETSTR^VALM1(ACTION,TIUY,57,8)
+38 SET TIUY=$$SETSTR^VALM1(DOER,TIUY,67,14)
+39 SET TIUL=TIUL+1
DO SET^TIUSRV(TIUL,0,TIUY)
End DoDot:1
+40 QUIT
IDHX(TIUDA) ; Boolean fn to evaluate whether ID history exists
+1 NEW TIUI,TIUY
SET TIUY=0
+2 SET TIUI=0
+3 FOR
SET TIUI=$ORDER(^TIU(8925.5,"B",TIUDA,TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:1
+4 IF $LENGTH($GET(^TIU(8925.5,TIUI,3)))
SET TIUY=1
End DoDot:1
IF +TIUY
QUIT
+5 SET TIUI=0
+6 FOR
SET TIUI=$ORDER(^TIU(8925.5,"AID",TIUDA,TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:1
+7 IF $LENGTH($GET(^TIU(8925.5,TIUI,3)))
SET TIUY=1
End DoDot:1
IF +TIUY
QUIT
IDHXX QUIT TIUY
