TIURD ; SLC/JER - Reassign actions ;4/25/05
;;1.0;TEXT INTEGRATION UTILITIES;**4,58,61,100,109,173,184,233**;Jun 20, 1997;Build 3
;
; Call to $$TIUREAS^MDAPI covered by IA# 3378
; $$TIUREAS^MDAPI went out with MD 1.0, which was not mandated, so
;checks are made for its existence before it is called.
REASSIGN ; Reassign selected Documents
N TIUCHNG,TIULST,TIUI,RSTRCTD,TIUDAARY
I '$D(VALMY) D EN^VALM2(XQORNOD(0))
S TIUI=0
F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT)
. N TIUDA,DFN,TIU,TIUDATA,TIUVIEW
. S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI))
. S TIUDA=+$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA)
. W !!,"Processing Item #",TIUI,"..."
. I $$CANTSURG(TIUDA) H 1 Q ;not permitted for surgery reports
. I RSTRCTD D Q
. . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message
. . I $$READ^TIUU("EA","RETURN to continue...") ; pause
. I +$$HASIMG^TIURB2(TIUDA) D IMGNOTE^TIURB2 Q
. S TIUVIEW=$$CANDO^TIULP(TIUDA,"VIEW")
. I '+TIUVIEW D Q
. . W !!,$C(7),$C(7),$C(7),$P(TIUVIEW,U,2),!
. . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
. S TIUDAARY(TIUI)=TIUDA
. S TIUCHNG=0
. D EN^VALM("TIU REASSIGN")
. I +$G(TIUCHNG) D
. . S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI
; -- Rebuild list: --
S TIUCHNG("RBLD")=1
D UPRBLD^TIURL(.TIUCHNG) K VALMY
S VALMBCK="R"
D VMSG^TIURS1($G(TIULST),.TIUDAARY,"reassigned")
Q
;
REASSIG1 ; Single record reassign
N TIUAUTH,TIURSSG,TIUNAME,DA,DR,DIE,TIUTYPE,TIUEDIT,TIUADD,TIUPROMO,TIUY
N TIUD0,TIUD12,TIUD13,TIUD14,TIUODA,TIUOUT K ^TMP("TIURTRCT",$J)
D FULL^VALM1
I $$CANTSURG(TIUDA) H 3 Q ;not permitted for surgery reports
L +^TIU(8925,+TIUDA):1
E W !?5,$C(7),$C(7),$C(7),"Another user is editing this entry." S TIUY=$$READ^TIUU("EA","Press RETURN to continue...") Q
; Authorized? NO: echo why not & quit
I +$$HASIMG^TIURB2(TIUDA) D IMGNOTE^TIURB2 Q
I +$$ISADDNDM^TIULC1(TIUDA) D I 1
. N TIUDAD
. S TIUDAD=+$P(^TIU(8925,TIUDA,0),U,6)
. I +$$DADORKID^TIUGBR(TIUDAD) D
. . S TIURSSG="0^You must first detach the ORIGINAL interdisciplinary entry."
E I $$DADORKID^TIUGBR(TIUDA) D I 1
. S TIURSSG="0^You must first detach interdisciplinary entries."
I '$D(TIURSSG) S TIURSSG=$$CANDO^TIULP(+TIUDA,"REASSIGN")
I +$G(TIURSSG)'>0 D G REASS1X
. W !!,$C(7),$C(7),$C(7),$P(TIURSSG,U,2),!
. I $$READ^TIUU("EA","Press RETURN to continue...") W ""
S TIUD0(0)=$G(^TIU(8925,+TIUDA,0)),TIUD12(0)=$G(^(12))
S TIUD13(0)=$G(^TIU(8925,+TIUDA,13)),TIUD14(0)=$G(^(14))
S TIUTYPE=$P(TIUD0(0),U)
S TIUNAME=$$PNAME^TIULC1(+TIUTYPE)
S TIUAUTH=$P(TIUD12(0),U,2)
W !,$C(7)
S TIUY=$$READ^TIUU("YO","Are you sure you want to REASSIGN this "_TIUNAME,"NO","^D REAS1^TIUDIRH")
I +TIUY'>0 S TIUOUT=1 G REASS1X
I +$P(TIUD0(0),U,5)>5 D G:+$G(TIUOUT) REASS1X
. W !!,$C(7),$C(7),"The status of this document is: ",$$UP^XLFSTR($$STATUS^TIULC(TIUDA))
. I +$$GETSIG^TIURD2'>0 S TIUOUT=1
. W !
; Addendum? YES: Ask intended action is move, swap with original, or
; replace original
S TIUADD=$$ISADDNDM^TIULC1(+TIUDA)
I +TIUADD D G REASS1X
. D REASSIGA
D REASSIGO^TIURD3
REASS1X L -^TIU(8925,+TIUDA):1
I +$G(TIUOUT),+$G(TIUODA),+$G(TIUDA),$D(TIUD0(0)) D RECOVER^TIURD4(TIUODA,TIUDA,.TIUD0) S TIUDA=TIUODA
; Remove additional signers who haven't signed from retracted original
I '+$G(TIUOUT),+$G(TIUODA) D
. I +$O(^TIU(8925.7,"B",+$G(TIUODA),0)) D DELSGNRS^TIURD4(TIUODA,1)
. D ALERTDEL^TIUALRT(TIUODA)
I '+$G(TIUOUT),+$G(TIUODA),+$$ISA^TIULX(+$G(TIUD0(0)),+$$CLASS^TIUCP) D
. N TIUCPY,TIUNVSTR
. Q:'$L($T(TIUREAS^MDAPI))
. S TIUNVSTR=$P(TIUD12(1),U,11)_";"_$P(TIUD0(1),U,7)
. S TIUNVSTR=TIUNVSTR_";"_$P(TIUD0(1),U,13)
. S TIUCPY=$$TIUREAS^MDAPI(+$P(TIUD0(0),U,2),+$P(TIUD14(0),U,5),+TIUODA,+$P(TIUD0(1),U,2),+$P($G(^TIU(8925,TIUDA,14)),U,5),TIUNVSTR,TIUDA)
D SEND^TIUALRT(TIUDA)
S VALMBCK=$S(+$G(TIUCHNG):"Q",1:"R") K ^TMP("TIURTRCT",$J)
Q
;
REASSIGO ; Reassign an original Document
G REASSIGO^TIURD3
;
REASSIGA ;Reassign an Addendum to an original DS
N TIUACT,TIUSET S TIUCHNG=0
W !,"Please choose the appropriate action for this Addendum:"
S TIUSET="M:move addendum to a different document"
S TIUSET=TIUSET_";P:promote addendum as document for another visit"
S TIUSET=TIUSET_";R:replace parent document with this addendum"
S TIUSET=TIUSET_";S:swap this addendum with its parent document"
S TIUACT=$$READ^TIUU("S^"_TIUSET,"Select Reassign Action","move")
I $P(TIUACT,U)="M" D MOVEADD^TIURD1(TIUDA) Q
I $P(TIUACT,U)="P" D PROMOTE^TIURD1(TIUDA) Q
I $P(TIUACT,U)="R" D REPLACE^TIURD1(TIUDA) Q
I $P(TIUACT,U)="S" D SWAPADD^TIURD1(TIUDA)
Q
;
CLAPPLNK ; Re-link selected Documents to different Client Records
N TIUCHNG,TIULST,TIUDA,DFN,TIU,TIUDATA,TIUEDIT,TIUI,TIUY,Y,DIROUT,TIUPOP
N TIUDAARY
I '$D(VALMY) D EN^VALM2(XQORNOD(0))
S TIUI=0 D FULL^VALM1
F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT)
. S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI))
. S TIUDA=+$P(TIUDATA,U,2),TIUDAARY(TIUI)=TIUDA
. S TIUCHNG=0
. W !!,"Processing Item #",TIUI,"..."
. D CLAPPLN1(TIUDA)
. I +$G(TIUCHNG)=1 D
. . S TIULST=$G(TIULST)_$S($G(TIULST)]"":", ",1:"")_TIUI
S TIUCHNG("REFRESH")=1
D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY
S VALMBCK="R"
D VMSG^TIURS1($G(TIULST),.TIUDAARY,"re-linked")
Q
;
CLAPPLN1(TIUDA) ; Re-link a single record to the client application
N TIUREASX,CANLNK,ACTION,ISPRF,OLDLINK
I '$D(^TIU(8925,TIUDA,0)) D Q
. W !!,$C(7),"Document no longer exists.",!
. I $$READ^TIUU("EA","Press RETURN to continue...") W ""
I $$CANTSURG(TIUDA) H 3 Q ;not permitted for surgery reports
S ISPRF=$$ISPRFDOC^TIUPRF(TIUDA) ;Patient Record Flag
I ISPRF S ACTION="LINK TO FLAG",OLDLINK=$$GETLINK^DGPFAPI1(TIUDA)
I 'ISPRF S ACTION="LINK WITH REQUEST",OLDLINK=$P($G(^TIU(8925,TIUDA,14)),U,5)
I +$$ISADDNDM^TIULC1(TIUDA) D Q
. W !!,$C(7),"Links for ADDENDA can't be independently changed.",!
. I $$READ^TIUU("EA","Press RETURN to continue...") W ""
S TIUREASX=$$REASSIGN^TIULC1(+$G(^TIU(8925,TIUDA,0)))
I TIUREASX']"" D Q
. W !!,$C(7),"No PACKAGE REASSIGNMENT ACTION Defined.",!
. I $$READ^TIUU("EA","Press RETURN to continue...") W ""
I $$DADORKID^TIUGBR(TIUDA) D Q ;**100**
. S CANLNK="0^You must first detach interdisciplinary entries"
. W !!,$C(7),$C(7),"You must first detach interdisciplinary entries",!
. I $$READ^TIUU("EA","Press RETURN to continue...") W ""
S CANLNK=$$CANDO^TIULP(+TIUDA,ACTION)
I +CANLNK'>0 D Q
. W !!,$C(7),$C(7),$P(CANLNK,U,2),!
. I $$READ^TIUU("EA","Press RETURN to continue...") W ""
X TIUREASX
I ISPRF,OLDLINK'=$$GETLINK^DGPFAPI1(TIUDA) S TIUCHNG=1
I 'ISPRF,$P($G(^TIU(8925,TIUDA,14)),U,5)'=OLDLINK S TIUCHNG=1
Q
;
CANTSURG(TIUDA) ; If TIUDA is surg docmt, write can't do this action and
;return 1 for can't do it P184
N TIUY,CANT,TIUPDA,TIUDA2 S CANT=0,TIUPDA=0,TIUDA2=0
; VMP/RJT - *233 - Do not allow action on addenda of Surgical documents
D
. I +$$ISADDNDM^TIULC1(TIUDA) S TIUDA2=+$P($G(^TIU(8925,TIUDA,0)),U,6) Q
. S TIUDA2=TIUDA
D ISSURG^TIUSROI(.TIUY,+$G(^TIU(8925,TIUDA2,0)))
I '+TIUY Q CANT
S CANT=1 W !,"This action is no longer permitted for SURGICAL REPORTS"
Q CANT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIURD 7241 printed Dec 13, 2024@02:45:07 Page 2
TIURD ; SLC/JER - Reassign actions ;4/25/05
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**4,58,61,100,109,173,184,233**;Jun 20, 1997;Build 3
+2 ;
+3 ; Call to $$TIUREAS^MDAPI covered by IA# 3378
+4 ; $$TIUREAS^MDAPI went out with MD 1.0, which was not mandated, so
+5 ;checks are made for its existence before it is called.
REASSIGN ; Reassign selected Documents
+1 NEW TIUCHNG,TIULST,TIUI,RSTRCTD,TIUDAARY
+2 IF '$DATA(VALMY)
DO EN^VALM2(XQORNOD(0))
+3 SET TIUI=0
+4 FOR
SET TIUI=$ORDER(VALMY(TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+5 NEW TIUDA,DFN,TIU,TIUDATA,TIUVIEW
+6 SET TIUDATA=$GET(^TMP("TIURIDX",$JOB,TIUI))
+7 SET TIUDA=+$PIECE(TIUDATA,U,2)
SET RSTRCTD=$$DOCRES^TIULRR(TIUDA)
+8 WRITE !!,"Processing Item #",TIUI,"..."
+9 ;not permitted for surgery reports
IF $$CANTSURG(TIUDA)
HANG 1
QUIT
+10 IF RSTRCTD
Begin DoDot:2
+11 ; Echo denial message
WRITE !!,$CHAR(7),"Ok, no harm done...",!
+12 ; pause
IF $$READ^TIUU("EA","RETURN to continue...")
End DoDot:2
QUIT
+13 IF +$$HASIMG^TIURB2(TIUDA)
DO IMGNOTE^TIURB2
QUIT
+14 SET TIUVIEW=$$CANDO^TIULP(TIUDA,"VIEW")
+15 IF '+TIUVIEW
Begin DoDot:2
+16 WRITE !!,$CHAR(7),$CHAR(7),$CHAR(7),$PIECE(TIUVIEW,U,2),!
+17 IF $$READ^TIUU("EA","Press RETURN to continue...")
WRITE ""
End DoDot:2
QUIT
+18 SET TIUDAARY(TIUI)=TIUDA
+19 SET TIUCHNG=0
+20 DO EN^VALM("TIU REASSIGN")
+21 IF +$GET(TIUCHNG)
Begin DoDot:2
+22 SET TIULST=$GET(TIULST)_$SELECT($GET(TIULST)]"":",",1:"")_TIUI
End DoDot:2
End DoDot:1
if $DATA(DIROUT)
QUIT
+23 ; -- Rebuild list: --
+24 SET TIUCHNG("RBLD")=1
+25 DO UPRBLD^TIURL(.TIUCHNG)
KILL VALMY
+26 SET VALMBCK="R"
+27 DO VMSG^TIURS1($GET(TIULST),.TIUDAARY,"reassigned")
+28 QUIT
+29 ;
REASSIG1 ; Single record reassign
+1 NEW TIUAUTH,TIURSSG,TIUNAME,DA,DR,DIE,TIUTYPE,TIUEDIT,TIUADD,TIUPROMO,TIUY
+2 NEW TIUD0,TIUD12,TIUD13,TIUD14,TIUODA,TIUOUT
KILL ^TMP("TIURTRCT",$JOB)
+3 DO FULL^VALM1
+4 ;not permitted for surgery reports
IF $$CANTSURG(TIUDA)
HANG 3
QUIT
+5 LOCK +^TIU(8925,+TIUDA):1
+6 IF '$TEST
WRITE !?5,$CHAR(7),$CHAR(7),$CHAR(7),"Another user is editing this entry."
SET TIUY=$$READ^TIUU("EA","Press RETURN to continue...")
QUIT
+7 ; Authorized? NO: echo why not & quit
+8 IF +$$HASIMG^TIURB2(TIUDA)
DO IMGNOTE^TIURB2
QUIT
+9 IF +$$ISADDNDM^TIULC1(TIUDA)
Begin DoDot:1
+10 NEW TIUDAD
+11 SET TIUDAD=+$PIECE(^TIU(8925,TIUDA,0),U,6)
+12 IF +$$DADORKID^TIUGBR(TIUDAD)
Begin DoDot:2
+13 SET TIURSSG="0^You must first detach the ORIGINAL interdisciplinary entry."
End DoDot:2
End DoDot:1
IF 1
+14 IF '$TEST
IF $$DADORKID^TIUGBR(TIUDA)
Begin DoDot:1
+15 SET TIURSSG="0^You must first detach interdisciplinary entries."
End DoDot:1
IF 1
+16 IF '$DATA(TIURSSG)
SET TIURSSG=$$CANDO^TIULP(+TIUDA,"REASSIGN")
+17 IF +$GET(TIURSSG)'>0
Begin DoDot:1
+18 WRITE !!,$CHAR(7),$CHAR(7),$CHAR(7),$PIECE(TIURSSG,U,2),!
+19 IF $$READ^TIUU("EA","Press RETURN to continue...")
WRITE ""
End DoDot:1
GOTO REASS1X
+20 SET TIUD0(0)=$GET(^TIU(8925,+TIUDA,0))
SET TIUD12(0)=$GET(^(12))
+21 SET TIUD13(0)=$GET(^TIU(8925,+TIUDA,13))
SET TIUD14(0)=$GET(^(14))
+22 SET TIUTYPE=$PIECE(TIUD0(0),U)
+23 SET TIUNAME=$$PNAME^TIULC1(+TIUTYPE)
+24 SET TIUAUTH=$PIECE(TIUD12(0),U,2)
+25 WRITE !,$CHAR(7)
+26 SET TIUY=$$READ^TIUU("YO","Are you sure you want to REASSIGN this "_TIUNAME,"NO","^D REAS1^TIUDIRH")
+27 IF +TIUY'>0
SET TIUOUT=1
GOTO REASS1X
+28 IF +$PIECE(TIUD0(0),U,5)>5
Begin DoDot:1
+29 WRITE !!,$CHAR(7),$CHAR(7),"The status of this document is: ",$$UP^XLFSTR($$STATUS^TIULC(TIUDA))
+30 IF +$$GETSIG^TIURD2'>0
SET TIUOUT=1
+31 WRITE !
End DoDot:1
if +$GET(TIUOUT)
GOTO REASS1X
+32 ; Addendum? YES: Ask intended action is move, swap with original, or
+33 ; replace original
+34 SET TIUADD=$$ISADDNDM^TIULC1(+TIUDA)
+35 IF +TIUADD
Begin DoDot:1
+36 DO REASSIGA
End DoDot:1
GOTO REASS1X
+37 DO REASSIGO^TIURD3
REASS1X LOCK -^TIU(8925,+TIUDA):1
+1 IF +$GET(TIUOUT)
IF +$GET(TIUODA)
IF +$GET(TIUDA)
IF $DATA(TIUD0(0))
DO RECOVER^TIURD4(TIUODA,TIUDA,.TIUD0)
SET TIUDA=TIUODA
+2 ; Remove additional signers who haven't signed from retracted original
+3 IF '+$GET(TIUOUT)
IF +$GET(TIUODA)
Begin DoDot:1
+4 IF +$ORDER(^TIU(8925.7,"B",+$GET(TIUODA),0))
DO DELSGNRS^TIURD4(TIUODA,1)
+5 DO ALERTDEL^TIUALRT(TIUODA)
End DoDot:1
+6 IF '+$GET(TIUOUT)
IF +$GET(TIUODA)
IF +$$ISA^TIULX(+$GET(TIUD0(0)),+$$CLASS^TIUCP)
Begin DoDot:1
+7 NEW TIUCPY,TIUNVSTR
+8 if '$LENGTH($TEXT(TIUREAS^MDAPI))
QUIT
+9 SET TIUNVSTR=$PIECE(TIUD12(1),U,11)_";"_$PIECE(TIUD0(1),U,7)
+10 SET TIUNVSTR=TIUNVSTR_";"_$PIECE(TIUD0(1),U,13)
+11 SET TIUCPY=$$TIUREAS^MDAPI(+$PIECE(TIUD0(0),U,2),+$PIECE(TIUD14(0),U,5),+TIUODA,+$PIECE(TIUD0(1),U,2),+$PIECE($GET(^TIU(8925,TIUDA,14)),U,5),TIUNVSTR,TIUDA)
End DoDot:1
+12 DO SEND^TIUALRT(TIUDA)
+13 SET VALMBCK=$SELECT(+$GET(TIUCHNG):"Q",1:"R")
KILL ^TMP("TIURTRCT",$JOB)
+14 QUIT
+15 ;
REASSIGO ; Reassign an original Document
+1 GOTO REASSIGO^TIURD3
+2 ;
REASSIGA ;Reassign an Addendum to an original DS
+1 NEW TIUACT,TIUSET
SET TIUCHNG=0
+2 WRITE !,"Please choose the appropriate action for this Addendum:"
+3 SET TIUSET="M:move addendum to a different document"
+4 SET TIUSET=TIUSET_";P:promote addendum as document for another visit"
+5 SET TIUSET=TIUSET_";R:replace parent document with this addendum"
+6 SET TIUSET=TIUSET_";S:swap this addendum with its parent document"
+7 SET TIUACT=$$READ^TIUU("S^"_TIUSET,"Select Reassign Action","move")
+8 IF $PIECE(TIUACT,U)="M"
DO MOVEADD^TIURD1(TIUDA)
QUIT
+9 IF $PIECE(TIUACT,U)="P"
DO PROMOTE^TIURD1(TIUDA)
QUIT
+10 IF $PIECE(TIUACT,U)="R"
DO REPLACE^TIURD1(TIUDA)
QUIT
+11 IF $PIECE(TIUACT,U)="S"
DO SWAPADD^TIURD1(TIUDA)
+12 QUIT
+13 ;
CLAPPLNK ; Re-link selected Documents to different Client Records
+1 NEW TIUCHNG,TIULST,TIUDA,DFN,TIU,TIUDATA,TIUEDIT,TIUI,TIUY,Y,DIROUT,TIUPOP
+2 NEW TIUDAARY
+3 IF '$DATA(VALMY)
DO EN^VALM2(XQORNOD(0))
+4 SET TIUI=0
DO FULL^VALM1
+5 FOR
SET TIUI=$ORDER(VALMY(TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+6 SET TIUDATA=$GET(^TMP("TIURIDX",$JOB,TIUI))
+7 SET TIUDA=+$PIECE(TIUDATA,U,2)
SET TIUDAARY(TIUI)=TIUDA
+8 SET TIUCHNG=0
+9 WRITE !!,"Processing Item #",TIUI,"..."
+10 DO CLAPPLN1(TIUDA)
+11 IF +$GET(TIUCHNG)=1
Begin DoDot:2
+12 SET TIULST=$GET(TIULST)_$SELECT($GET(TIULST)]"":", ",1:"")_TIUI
End DoDot:2
End DoDot:1
if $DATA(DIROUT)
QUIT
+13 SET TIUCHNG("REFRESH")=1
+14 DO UPRBLD^TIURL(.TIUCHNG,.VALMY)
KILL VALMY
+15 SET VALMBCK="R"
+16 DO VMSG^TIURS1($GET(TIULST),.TIUDAARY,"re-linked")
+17 QUIT
+18 ;
CLAPPLN1(TIUDA) ; Re-link a single record to the client application
+1 NEW TIUREASX,CANLNK,ACTION,ISPRF,OLDLINK
+2 IF '$DATA(^TIU(8925,TIUDA,0))
Begin DoDot:1
+3 WRITE !!,$CHAR(7),"Document no longer exists.",!
+4 IF $$READ^TIUU("EA","Press RETURN to continue...")
WRITE ""
End DoDot:1
QUIT
+5 ;not permitted for surgery reports
IF $$CANTSURG(TIUDA)
HANG 3
QUIT
+6 ;Patient Record Flag
SET ISPRF=$$ISPRFDOC^TIUPRF(TIUDA)
+7 IF ISPRF
SET ACTION="LINK TO FLAG"
SET OLDLINK=$$GETLINK^DGPFAPI1(TIUDA)
+8 IF 'ISPRF
SET ACTION="LINK WITH REQUEST"
SET OLDLINK=$PIECE($GET(^TIU(8925,TIUDA,14)),U,5)
+9 IF +$$ISADDNDM^TIULC1(TIUDA)
Begin DoDot:1
+10 WRITE !!,$CHAR(7),"Links for ADDENDA can't be independently changed.",!
+11 IF $$READ^TIUU("EA","Press RETURN to continue...")
WRITE ""
End DoDot:1
QUIT
+12 SET TIUREASX=$$REASSIGN^TIULC1(+$GET(^TIU(8925,TIUDA,0)))
+13 IF TIUREASX']""
Begin DoDot:1
+14 WRITE !!,$CHAR(7),"No PACKAGE REASSIGNMENT ACTION Defined.",!
+15 IF $$READ^TIUU("EA","Press RETURN to continue...")
WRITE ""
End DoDot:1
QUIT
+16 ;**100**
IF $$DADORKID^TIUGBR(TIUDA)
Begin DoDot:1
+17 SET CANLNK="0^You must first detach interdisciplinary entries"
+18 WRITE !!,$CHAR(7),$CHAR(7),"You must first detach interdisciplinary entries",!
+19 IF $$READ^TIUU("EA","Press RETURN to continue...")
WRITE ""
End DoDot:1
QUIT
+20 SET CANLNK=$$CANDO^TIULP(+TIUDA,ACTION)
+21 IF +CANLNK'>0
Begin DoDot:1
+22 WRITE !!,$CHAR(7),$CHAR(7),$PIECE(CANLNK,U,2),!
+23 IF $$READ^TIUU("EA","Press RETURN to continue...")
WRITE ""
End DoDot:1
QUIT
+24 XECUTE TIUREASX
+25 IF ISPRF
IF OLDLINK'=$$GETLINK^DGPFAPI1(TIUDA)
SET TIUCHNG=1
+26 IF 'ISPRF
IF $PIECE($GET(^TIU(8925,TIUDA,14)),U,5)'=OLDLINK
SET TIUCHNG=1
+27 QUIT
+28 ;
CANTSURG(TIUDA) ; If TIUDA is surg docmt, write can't do this action and
+1 ;return 1 for can't do it P184
+2 NEW TIUY,CANT,TIUPDA,TIUDA2
SET CANT=0
SET TIUPDA=0
SET TIUDA2=0
+3 ; VMP/RJT - *233 - Do not allow action on addenda of Surgical documents
+4 Begin DoDot:1
+5 IF +$$ISADDNDM^TIULC1(TIUDA)
SET TIUDA2=+$PIECE($GET(^TIU(8925,TIUDA,0)),U,6)
QUIT
+6 SET TIUDA2=TIUDA
End DoDot:1
+7 DO ISSURG^TIUSROI(.TIUY,+$GET(^TIU(8925,TIUDA2,0)))
+8 IF '+TIUY
QUIT CANT
+9 SET CANT=1
WRITE !,"This action is no longer permitted for SURGICAL REPORTS"
+10 QUIT CANT
