Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: TIUSRV1

TIUSRV1.m

Go to the documentation of this file. 
  1. TIUSRV1 ; SLC/JER - More silent server functions ; 07/31/2002 12:22
  1.  ;;1.0;TEXT INTEGRATION UTILITIES;**61,100,112**;Jun 20, 1997
  1. REASSIGN(TIUDA,REASSIGN,TIUL) ; Reassign Hx
  1.  N TIUI,DR,DIC,DIQ,TIUREASS S TIUI=0
  1.  I +$P(^TIU(8925,TIUDA,0),U,5)'=15,(+$G(REASSIGN)=0) Q
  1.  S TIUL=TIUL+1 D BLANK^TIUSRV(TIUL) S TIUL=TIUL+1
  1.  D SET^TIUSRV(TIUL,2," Reassignment History ",$G(IORVON),$G(IORVOFF))
  1.  I '+$O(^TIU(8925.5,"AR",+TIUDA,0)) D
  1.  . N TIUI
  1.  . D SET^TIUSRV(TIUL,26,"Document Never Reassigned.")
  1.  . F TIUI=(TIUL+1):1:16 S @VALMAR@(TIUI,0)=" "
  1.  F  S TIUI=$O(^TIU(8925.5,"AR",TIUDA,TIUI)) Q:+TIUI'>0  D
  1.  . N DA S DA=0
  1.  . F  S DA=$O(^TIU(8925.5,"AR",TIUDA,TIUI,DA)) Q:+DA'>0  D
  1.  . . S DR="1.01:1.12",DIC="^TIU(8925.5,",DIQ="TIUREASS"
  1.  . . D EN^DIQ1 Q:$D(TIUREASS)'>9!($G(TIUREASS(8925.5,DA,1.01))']"")
  1.  . . S TIUCNT=+$G(TIUCNT)+1 I TIUCNT>1 S TIUL=TIUL+1 D BLANK^TIUSRV(TIUL)
  1.  . . S TIUL=TIUL+1
  1.  . . D SET^TIUSRV(TIUL,2,"  Reassign Date: "_$G(TIUREASS(8925.5,DA,1.01)))
  1.  . . D SET^TIUSRV(TIUL,44," Reassigned By: "_$G(TIUREASS(8925.5,DA,1.02)))
  1.  . . S TIUL=TIUL+1
  1.  . . D SET^TIUSRV(TIUL,2,"        Patient: "_$G(TIUREASS(8925.5,DA,1.03)))
  1.  . . D SET^TIUSRV(TIUL,44," --->           "_$G(TIUREASS(8925.5,DA,1.04)))
  1.  . . S TIUL=TIUL+1
  1.  . . D SET^TIUSRV(TIUL,2,"Visit Date/time: "_$G(TIUREASS(8925.5,DA,1.05)))
  1.  . . D SET^TIUSRV(TIUL,44," --->           "_$G(TIUREASS(8925.5,DA,1.06)))
  1.  . . S TIUL=TIUL+1
  1.  . . D SET^TIUSRV(TIUL,2,"  Hosp Location: "_$G(TIUREASS(8925.5,DA,1.07)))
  1.  . . D SET^TIUSRV(TIUL,44," --->           "_$G(TIUREASS(8925.5,DA,1.08)))
  1.  . . S TIUL=TIUL+1
  1.  . . D SET^TIUSRV(TIUL,2,"     Visit Type: "_$$UP^XLFSTR($G(TIUREASS(8925.5,DA,1.09))))
  1.  . . D SET^TIUSRV(TIUL,44," --->           "_$$UP^XLFSTR($G(TIUREASS(8925.5,DA,1.1))))
  1.  Q
  1.  N TIUI S TIUI=0
  1.  Q:'$$IDHX(TIUDA)
  1.  S TIUL=TIUL+1 D BLANK^TIUSRV(TIUL) S TIUL=TIUL+1
  1.  D SET^TIUSRV(TIUL,1," Interdisciplinary Linkage History ",$G(IORVON),$G(IORVOFF))
  1.  S TIUL=TIUL+1 D BLANK^TIUSRV(TIUL) S TIUL=TIUL+1
  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
  1.  D SET^TIUSRV(TIUL,0,"----------------  ----------  ------------------------  --------  -------------")
  1.  ; First, get events for ID Parents
  1.  F  S TIUI=$O(^TIU(8925.5,"AID",TIUDA,TIUI)) Q:+TIUI'>0  D
  1.  . N TIUD0,TIUD3,TIUY,EVDT,ENTDA,ENTTL,ACTION,DOER
  1.  . Q:'$L($G(^TIU(8925.5,TIUI,3)))
  1.  . S TIUD0=$G(^TIU(8925.5,TIUI,0)),TIUD3=$G(^(3))
  1.  . S ENTDA=+TIUD0
  1.  . S ACTION=$P(TIUD3,U),ACTION=$S(ACTION="d":"detached",1:"attached")
  1.  . S EVDT=$$DATE^TIULS($P(TIUD3,U,2),"MM/DD/CCYY HR:MIN")
  1.  . S ENTTL=$$PNAME^TIULC1(+$G(^TIU(8925,ENTDA,0)))
  1.  . S DOER=$$NAME^TIULS($$PERSNAME^TIULC1(+$P(TIUD3,U,3)),"LAST,FI")
  1.  . S TIUY="" S TIUY=$$SETSTR^VALM1(EVDT,TIUY,1,16)
  1.  . S TIUY=$$SETSTR^VALM1(ENTDA,TIUY,19,10)
  1.  . S TIUY=$$SETSTR^VALM1(ENTTL,TIUY,31,24)
  1.  . S TIUY=$$SETSTR^VALM1(ACTION,TIUY,57,8)
  1.  . S TIUY=$$SETSTR^VALM1(DOER,TIUY,67,14)
  1.  . S TIUL=TIUL+1 D SET^TIUSRV(TIUL,0,TIUY)
  1.  ; Next, get hx for ID Entries
  1.  F  S TIUI=$O(^TIU(8925.5,"B",TIUDA,TIUI)) Q:+TIUI'>0  D
  1.  . N TIUD0,TIUD3,TIUY,EVDT,ENTDA,IDDAD,IDTTL,ACTION,DOER
  1.  . Q:'$L($G(^TIU(8925.5,TIUI,3)))
  1.  . S TIUD0=$G(^TIU(8925.5,TIUI,0)),TIUD3=$G(^(3))
  1.  . S ENTDA=+TIUD0,IDDAD=$P(TIUD3,U,5)
  1.  . S ACTION=$P(TIUD3,U),ACTION=$S(ACTION="d":"detached",1:"attached")
  1.  . S EVDT=$$DATE^TIULS($P(TIUD3,U,2),"MM/DD/CCYY HR:MIN")
  1.  . S IDTTL=$$PNAME^TIULC1(+$G(^TIU(8925,IDDAD,0)))
  1.  . S DOER=$$NAME^TIULS($$PERSNAME^TIULC1(+$P(TIUD3,U,3)),"LAST,FI")
  1.  . S TIUY="" S TIUY=$$SETSTR^VALM1(EVDT,TIUY,1,16)
  1.  . S TIUY=$$SETSTR^VALM1(IDDAD,TIUY,19,10)
  1.  . S TIUY=$$SETSTR^VALM1(IDTTL,TIUY,31,24)
  1.  . S TIUY=$$SETSTR^VALM1(ACTION,TIUY,57,8)
  1.  . S TIUY=$$SETSTR^VALM1(DOER,TIUY,67,14)
  1.  . S TIUL=TIUL+1 D SET^TIUSRV(TIUL,0,TIUY)
  1.  Q
  1. IDHX(TIUDA) ; Boolean fn to evaluate whether ID history exists
  1.  N TIUI,TIUY S TIUY=0
  1.  S TIUI=0
  1.  F  S TIUI=$O(^TIU(8925.5,"B",TIUDA,TIUI)) Q:+TIUI'>0  D  Q:+TIUY
  1.  . S:$L($G(^TIU(8925.5,TIUI,3))) TIUY=1
  1.  S TIUI=0
  1.  F  S TIUI=$O(^TIU(8925.5,"AID",TIUDA,TIUI)) Q:+TIUI'>0  D  Q:+TIUY
  1.  . S:$L($G(^TIU(8925.5,TIUI,3))) TIUY=1
  1. IDHXX Q TIUY