source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRV1.m@ 1704

Last change on this file since 1704 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.0 KB
Line 
1TIUSRV1 ; SLC/JER - More silent server functions ; 07/31/2002 12:22
2 ;;1.0;TEXT INTEGRATION UTILITIES;**61,100,112**;Jun 20, 1997
3REASSIGN(TIUDA,REASSIGN,TIUL) ; Reassign Hx
4 N TIUI,DR,DIC,DIQ,TIUREASS S TIUI=0
5 I +$P(^TIU(8925,TIUDA,0),U,5)'=15,(+$G(REASSIGN)=0) Q
6 S TIUL=TIUL+1 D BLANK^TIUSRV(TIUL) S TIUL=TIUL+1
7 D SET^TIUSRV(TIUL,2," Reassignment History ",$G(IORVON),$G(IORVOFF))
8 I '+$O(^TIU(8925.5,"AR",+TIUDA,0)) D
9 . N TIUI
10 . D SET^TIUSRV(TIUL,26,"Document Never Reassigned.")
11 . F TIUI=(TIUL+1):1:16 S @VALMAR@(TIUI,0)=" "
12 F S TIUI=$O(^TIU(8925.5,"AR",TIUDA,TIUI)) Q:+TIUI'>0 D
13 . N DA S DA=0
14 . F S DA=$O(^TIU(8925.5,"AR",TIUDA,TIUI,DA)) Q:+DA'>0 D
15 . . S DR="1.01:1.12",DIC="^TIU(8925.5,",DIQ="TIUREASS"
16 . . D EN^DIQ1 Q:$D(TIUREASS)'>9!($G(TIUREASS(8925.5,DA,1.01))']"")
17 . . S TIUCNT=+$G(TIUCNT)+1 I TIUCNT>1 S TIUL=TIUL+1 D BLANK^TIUSRV(TIUL)
18 . . S TIUL=TIUL+1
19 . . D SET^TIUSRV(TIUL,2," Reassign Date: "_$G(TIUREASS(8925.5,DA,1.01)))
20 . . D SET^TIUSRV(TIUL,44," Reassigned By: "_$G(TIUREASS(8925.5,DA,1.02)))
21 . . S TIUL=TIUL+1
22 . . D SET^TIUSRV(TIUL,2," Patient: "_$G(TIUREASS(8925.5,DA,1.03)))
23 . . D SET^TIUSRV(TIUL,44," ---> "_$G(TIUREASS(8925.5,DA,1.04)))
24 . . S TIUL=TIUL+1
25 . . D SET^TIUSRV(TIUL,2,"Visit Date/time: "_$G(TIUREASS(8925.5,DA,1.05)))
26 . . D SET^TIUSRV(TIUL,44," ---> "_$G(TIUREASS(8925.5,DA,1.06)))
27 . . S TIUL=TIUL+1
28 . . D SET^TIUSRV(TIUL,2," Hosp Location: "_$G(TIUREASS(8925.5,DA,1.07)))
29 . . D SET^TIUSRV(TIUL,44," ---> "_$G(TIUREASS(8925.5,DA,1.08)))
30 . . S TIUL=TIUL+1
31 . . D SET^TIUSRV(TIUL,2," Visit Type: "_$$UP^XLFSTR($G(TIUREASS(8925.5,DA,1.09))))
32 . . D SET^TIUSRV(TIUL,44," ---> "_$$UP^XLFSTR($G(TIUREASS(8925.5,DA,1.1))))
33 Q
34IDLINK(TIUDA,TIUL) ; Show Attach/Detach Hx
35 N TIUI S TIUI=0
36 Q:'$$IDHX(TIUDA)
37 S TIUL=TIUL+1 D BLANK^TIUSRV(TIUL) S TIUL=TIUL+1
38 D SET^TIUSRV(TIUL,1," Interdisciplinary Linkage History ",$G(IORVON),$G(IORVOFF))
39 S TIUL=TIUL+1 D BLANK^TIUSRV(TIUL) S TIUL=TIUL+1
40 D SET^TIUSRV(TIUL,0,"Date/Time "_$S(+$G(^TIU(8925,+TIUDA,21)):"ID Parent",1:"Entry # ")_" Title Action By") S TIUL=TIUL+1
41 D SET^TIUSRV(TIUL,0,"---------------- ---------- ------------------------ -------- -------------")
42 ; First, get events for ID Parents
43 F S TIUI=$O(^TIU(8925.5,"AID",TIUDA,TIUI)) Q:+TIUI'>0 D
44 . N TIUD0,TIUD3,TIUY,EVDT,ENTDA,ENTTL,ACTION,DOER
45 . Q:'$L($G(^TIU(8925.5,TIUI,3)))
46 . S TIUD0=$G(^TIU(8925.5,TIUI,0)),TIUD3=$G(^(3))
47 . S ENTDA=+TIUD0
48 . S ACTION=$P(TIUD3,U),ACTION=$S(ACTION="d":"detached",1:"attached")
49 . S EVDT=$$DATE^TIULS($P(TIUD3,U,2),"MM/DD/CCYY HR:MIN")
50 . S ENTTL=$$PNAME^TIULC1(+$G(^TIU(8925,ENTDA,0)))
51 . S DOER=$$NAME^TIULS($$PERSNAME^TIULC1(+$P(TIUD3,U,3)),"LAST,FI")
52 . S TIUY="" S TIUY=$$SETSTR^VALM1(EVDT,TIUY,1,16)
53 . S TIUY=$$SETSTR^VALM1(ENTDA,TIUY,19,10)
54 . S TIUY=$$SETSTR^VALM1(ENTTL,TIUY,31,24)
55 . S TIUY=$$SETSTR^VALM1(ACTION,TIUY,57,8)
56 . S TIUY=$$SETSTR^VALM1(DOER,TIUY,67,14)
57 . S TIUL=TIUL+1 D SET^TIUSRV(TIUL,0,TIUY)
58 ; Next, get hx for ID Entries
59 F S TIUI=$O(^TIU(8925.5,"B",TIUDA,TIUI)) Q:+TIUI'>0 D
60 . N TIUD0,TIUD3,TIUY,EVDT,ENTDA,IDDAD,IDTTL,ACTION,DOER
61 . Q:'$L($G(^TIU(8925.5,TIUI,3)))
62 . S TIUD0=$G(^TIU(8925.5,TIUI,0)),TIUD3=$G(^(3))
63 . S ENTDA=+TIUD0,IDDAD=$P(TIUD3,U,5)
64 . S ACTION=$P(TIUD3,U),ACTION=$S(ACTION="d":"detached",1:"attached")
65 . S EVDT=$$DATE^TIULS($P(TIUD3,U,2),"MM/DD/CCYY HR:MIN")
66 . S IDTTL=$$PNAME^TIULC1(+$G(^TIU(8925,IDDAD,0)))
67 . S DOER=$$NAME^TIULS($$PERSNAME^TIULC1(+$P(TIUD3,U,3)),"LAST,FI")
68 . S TIUY="" S TIUY=$$SETSTR^VALM1(EVDT,TIUY,1,16)
69 . S TIUY=$$SETSTR^VALM1(IDDAD,TIUY,19,10)
70 . S TIUY=$$SETSTR^VALM1(IDTTL,TIUY,31,24)
71 . S TIUY=$$SETSTR^VALM1(ACTION,TIUY,57,8)
72 . S TIUY=$$SETSTR^VALM1(DOER,TIUY,67,14)
73 . S TIUL=TIUL+1 D SET^TIUSRV(TIUL,0,TIUY)
74 Q
75IDHX(TIUDA) ; Boolean fn to evaluate whether ID history exists
76 N TIUI,TIUY S TIUY=0
77 S TIUI=0
78 F S TIUI=$O(^TIU(8925.5,"B",TIUDA,TIUI)) Q:+TIUI'>0 D Q:+TIUY
79 . S:$L($G(^TIU(8925.5,TIUI,3))) TIUY=1
80 S TIUI=0
81 F S TIUI=$O(^TIU(8925.5,"AID",TIUDA,TIUI)) Q:+TIUI'>0 D Q:+TIUY
82 . S:$L($G(^TIU(8925.5,TIUI,3))) TIUY=1
83IDHXX Q TIUY
Note: See TracBrowser for help on using the repository browser.