source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURC1.m@ 794

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1TIURC1 ; SLC/JER - Additional Review screen actions ;4/13/05
2 ;;1.0;TEXT INTEGRATION UTILITIES;**100,113,184**;Jun 20, 1997
3COPY ; Copy
4 N DA,DIE,DR,TIU,TIUCHNG,TIUDATA,TIUI,TIUY,Y,DIROUT
5 N TIUVIEW,TIULST,TIUNREC,TIUDAARY,OLDNREC
6 I '$D(VALMY) D EN^VALM2(XQORNOD(0))
7 S TIUI=0
8 F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT)
9 . N TIU,RSTRCTD
10 . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI))
11 . S TIUDA=+$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA)
12 . I RSTRCTD D Q
13 . . W !!,$C(7),"Ok, no harm done...",!
14 . . I $$READ^TIUU("EA","RETURN to continue...") ; pause
15 . S TIUVIEW=$$CANDO^TIULP(TIUDA,"VIEW")
16 . I +TIUVIEW'>0 D Q
17 . . W !!,$C(7),$P(TIUVIEW,U,2),!
18 . . I $$READ^TIUU("EA","RETURN to continue...") ; pause
19 . S OLDNREC=$G(TIUNREC)
20 . ; -- Single docmt copy. Does COPY1.
21 . ; Generates list TIUNREC of new recs for feedback
22 . D EN^VALM("TIU COPY DOCUMENT")
23 . K ^TMP("TIUVIEW",$J)
24 . I $G(TIUNREC)'=OLDNREC D
25 . . S TIUDAARY(TIUI)=TIUDA
26 . . S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI
27 I +$G(TIUNREC) D
28 . N TIUI,TIUNDA,TIUITEM
29 . F TIUI=1:1:$L($G(TIUNREC),",") D
30 . . S TIUNDA=$P(TIUNREC,",",TIUI),TIUITEM=+$G(^TMP("TIUR",$J,0))
31 . . D ADDELMNT^TIUR2(TIUNDA,+TIUITEM,1)
32 S TIUCHNG("REFRESH")=1
33 D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY
34 S VALMBCK="R"
35 D VMSG^TIURS1($G(TIULST),.TIUDAARY,"copied")
36 Q
37COPY1 ; Copy a document
38 N TIUOD0,TIUOD12,TIUD13,TIUOD14,TIUOD17,TIUI,TIUPAT,TIUTNM,TIUTYP
39 N TIUDPRM,TIUPOP,TIUCOPY,TIUVSUPP,DUOUT,DIROUT,DTOUT,TIUASK
40 S TIUPOP=0
41 I +$$ISADDNDM^TIULC1(TIUDA) D Q
42 . W !,$C(7),"ADDENDA may not be copied."
43 . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
44 S TIUCOPY=$$CANDO^TIULP(TIUDA,"COPY RECORD")
45 I +TIUCOPY'>0 D Q
46 . W !!,$C(7),$P(TIUCOPY,U,2),!
47 . I $$READ^TIUU("EA","RETURN to continue...") ; pause
48 S TIUOD0=$G(^TIU(8925,+TIUDA,0)),TIUOD12=$G(^(12)),TIUD13=$G(^(13))
49 S TIUOD14=$G(^TIU(8925,+TIUDA,14)),TIUOD17=$G(^TIU(8925,+TIUDA,17))
50 S TIUTYP=+TIUOD0
51 D FULL^VALM1
52 I $$CHKTITLE(+TIUTYP) D Q:$G(TIUOUT)=1
53 . N TIUDOC0,TIUDCLS
54 . S TIUDOC0=$G(^TIU(8925.1,TIUTYP,0))
55 . W !
56 . I $P(TIUDOC0,U,7)=13 D
57 . . W !,$C(7),$P(TIUDOC0,U,3)," is an inactive title."
58 . W !,"You must now select a new, active title BEFORE the note is copied:",!
59 . S TIUDCLS=+$$CLINDOC^TIULC1(+TIUTYP,TIUDA),TIUTYP=0
60 . D DOCSPICK^TIULA2(.TIUTYP,TIUDCLS,"1A","","","+$$CANPICK^TIULP(+Y),+$$CANENTR^TIULP(+Y)")
61 . I TIUTYP'>0 S TIUOUT=1
62 . E D
63 . . S TIUTYP=$P($G(TIUTYP(1)),U,2)
64 . . I $$CHKTITLE(+TIUTYP) S TIUOUT=1
65 D DOCPRM^TIULC1(TIUTYP,.TIUDPRM,TIUDA)
66 S TIUTNM=$$PNAME^TIULC1(+TIUTYP)
67 S TIUTYP(1)="1^"_+TIUTYP_U_TIUTNM_U
68 W !!,"Please Choose One or More Patients for whom the document should be copied:",!
69 F D Q:+TIUPOP
70 . D PATIENT^ORU1(.TIUPAT,1)
71 . I +TIUPAT'>0 D Q
72 . . W !,$C(7),"No patient(s) selected..."
73 . . I $$READ^TIUU("EA","Press RETURN to continue...") W !
74 . . S TIUCHNG=0,TIUPOP=1
75 . S TIUI=0 F S TIUI=$O(TIUPAT(TIUI)) Q:+TIUI'>0 D
76 . . N DA,DR,DFN,TIU,TIULMETH,TIUVMETH,TIUPATNM
77 . . S DFN=+TIUPAT(TIUI),TIUPATNM=$P(TIUPAT(TIUI),U,2)
78 . . S TIUVSUPP=+$$SUPPVSIT^TIULC1(TIUTYP)
79 . . I TIUVSUPP'>0 D I 1
80 . . . S TIULMETH=$$GETLMETH^TIUEDI1(TIUTYP)
81 . . . I '$L(TIULMETH) D S TIUOUT=1 Q
82 . . . . W !,$C(7),"No Visit Linkage Method defined for "
83 . . . . W $$PNAME^TIULC1(TIUTYP),".",!,"Please contact IRM..."
84 . . . . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
85 . . . W !!,"For Patient ",TIUPATNM
86 . . . X TIULMETH
87 . . E D EVENT^TIUSRVP1(.TIU,DFN)
88 . . I '$D(TIU("VSTR")) W !,$C(7),"Patient & Visit required." H 2 Q
89 . . S TIUVMETH=$$GETVMETH^TIUEDI1(TIUTYP)
90 . . I '$L(TIUVMETH) D S TIUOUT=1 Q
91 . . . W !,$C(7),"No Validation Method defined for "
92 . . . W $$PNAME^TIULC1(TIUTYP),".",!,"Please contact IRM..."
93 . . X TIUVMETH
94 . . I $D(TIU),+$G(TIUASK) D
95 . . . N TIUNEW,TIUITEM,DA,DR,DIE
96 . . . S DA=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.TIUNEW,.TIUDPRM) Q:+DA'>0
97 . . . I '+$G(TIUNEW) D Q
98 . . . . W !!,$C(7),"A ",$P(TIUTYP(1),U,3)," already exists for this visit."
99 . . . . W !,"You may not use the copy function to overwrite an existing ",!,$$UPPER^TIULS($$STATUS^TIULC(DA))," ",$P(TIUTYP(1),U,3),".",!
100 . . . . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
101 . . . D COPY0(DA,TIUOD0,.TIU),COPY12(DA,TIUOD0,TIUOD12,.TIU),COPY13(DA,TIUD13)
102 . . . D COPY14(DA,TIUOD14,.TIU),COPY17(DA,TIUOD17),COPYTEXT(TIUDA,DA)
103 . . . I $D(^TIU(8925,DA,"TEMP")) D MERGTEXT^TIUEDI1(DA,.TIU) K ^TIU(8925,+DA,"TEMP")
104 . . . S DR=".05///"_$$UPPER^TIULS($$STATUS^TIULC(DA)),DIE=8925 D ^DIE
105 . . . I +$D(^TIU(8925,+DA,"TEXT"))>9!(+$O(^TIU(8925,"DAD",+DA,0))>0) D
106 . . . . N TIUDA,TIUCPYNG S TIUDA=+DA,TIUCPYNG=1 D EDIT1^TIURA
107 . . . I '$G(DA) Q ;Docmt deleted in TIURA
108 . . . S TIUCHNG=1,TIUNREC=$G(TIUNREC)_$S(+$G(TIUNREC):",",1:"")_DA
109 . S TIUPOP='+$$AGAIN
110 Q
111CHKTITLE(TIUTYP) ; Title Status
112 N TIUBAD S TIUBAD=0
113 I +$$CANPICK^TIULP(+TIUTYP)'>0 S TIUBAD=1 I 1
114 E I +$$CANENTR^TIULP(+TIUTYP)'>0 S TIUBAD=1
115 Q TIUBAD
116AGAIN() ; Ask again?
117 N TIUY W !
118 S TIUY=$$READ^TIUU("Y","Copy this note again","No")
119 Q TIUY
120COPY0(DA,TIUD0,TIU) ; Copy 0-node
121 N DR,DIE S DIE=8925
122 S DR=".02////"_DFN_";.03////"_$P($G(TIU("VISIT")),U)_";.04////"_$P(TIUD0,U,4)_";.07////"_$P($G(TIU("EDT")),U)_";.08////"_$P($G(TIU("LDT")),U)_";.09////"_$P(TIUD0,U,9)
123 I $P($G(TIUDPRM(0)),U,16),'$P($G(^TIU(8925,+DA,0)),U,11),$$WORKOK^TIUPXAP1(+DA) S DR=DR_";.11////1" ;set flag to collect workload
124 D ^DIE
125 Q
126COPY12(DA,TIUD0,TIUD12,TIU) ; Copy 12-node
127 N DR,DIE S DIE=8925
128 S DR="1201////"_$$NOW^TIULC_";1202////"_+$G(DUZ)_";1203////"_$P(TIUD12,U,3)_";1204////"_$G(DUZ)_";1205////"_$P($G(TIU("LOC")),U)
129 S DR=DR_";1206////"_$P(TIUD12,U,6)_";1207////"_$P(TIUD12,U,7)_";1209////"_$P(TIUD12,U,9)
130 I +$$REQCOSIG^TIULP(+TIUD0,DA,+$G(DUZ)) S DR=DR_";1208////"_$P(TIUD12,U,8)
131 S DR=DR_";1210////"_$P(TIUD12,U,10)_";1211////"_+$G(TIU("VLOC"))_";1212////"_$P($G(TIU("INST")),U)
132 D ^DIE
133 Q
134COPY13(DA,TIUD13,TIU) ; Copy 13-node
135 N DR,DIE S DIE=8925
136 S DR="1301////"_$$NOW^TIULC_";1302////"_$G(DUZ)_";1303////O;1307////"_$P(TIUD13,U,7)
137 D ^DIE
138 Q
139COPY14(DA,TIUD14,TIU) ; Copy 14-node
140 N DR,DIE S DIE=8925
141 S DR="1401////"_$P($G(TIU("AD#")),U)_";1402////"_$P($G(TIU("TS")),U)_";1403////"_$P(TIUD14,U,3)_";1404////"_$P(TIUD14,U,4)
142 D ^DIE
143 Q
144COPY17(DA,TIUD17) ; Copy Subject
145 N DR,DIE S DIE=8925
146 I $G(TIUD17)']"" Q
147 S DR="1701////^S X=$G(TIUD17)" D ^DIE
148 Q
149COPYTEXT(TIUDA,DA) ; Copy text
150 N TIUC,TIUI,TIUJ,TIULINE
151 I +$O(^TIU(8925,+TIUDA,"TEXT",0)) M ^TIU(8925,+DA,"TEMP")=^TIU(8925,+TIUDA,"TEXT")
152 S (TIUC,TIULINE)=0,TIUJ=+$P($G(^TIU(8925,+DA,"TEMP",0)),U,3)
153 F S TIUC=$O(^TIU(8925,"DAD",TIUDA,TIUC)) Q:+TIUC'>0 D
154 . I +$$ISADDNDM^TIULC1(TIUC) Q
155 . S TIUI=0 F S TIUI=$O(^TIU(8925,+TIUC,"TEXT",TIUI)) Q:+TIUI'>0 D
156 . . S TIUJ=+$G(TIUJ)+1
157 . . S ^TIU(8925,+DA,"TEMP",TIUJ,0)=$G(^TIU(8925,+TIUC,"TEXT",TIUI,0))
158 . . S ^TIU(8925,+DA,"TEMP",0)="^^"_TIUJ_"^"_TIUJ_"^"_DT_"^^"
159 Q
Note: See TracBrowser for help on using the repository browser.