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

TIURD.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ; Call to $$TIUREAS^MDAPI covered by IA# 3378
  1.  ; $$TIUREAS^MDAPI went out with MD 1.0, which was not mandated, so
  1.  ;checks are made for its existence before it is called.
  1. REASSIGN ; Reassign selected Documents
  1.  N TIUCHNG,TIULST,TIUI,RSTRCTD,TIUDAARY
  1.  I '$D(VALMY) D EN^VALM2(XQORNOD(0))
  1.  S TIUI=0
  1.  F  S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0  D  Q:$D(DIROUT)
  1.  . N TIUDA,DFN,TIU,TIUDATA,TIUVIEW
  1.  . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI))
  1.  . S TIUDA=+$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA)
  1.  . W !!,"Processing Item #",TIUI,"..."
  1.  . I $$CANTSURG(TIUDA) H 1 Q  ;not permitted for surgery reports
  1.  . I RSTRCTD D  Q
  1.  . . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message
  1.  . . I $$READ^TIUU("EA","RETURN to continue...") ; pause
  1.  . I +$$HASIMG^TIURB2(TIUDA) D IMGNOTE^TIURB2 Q
  1.  . S TIUVIEW=$$CANDO^TIULP(TIUDA,"VIEW")
  1.  . I '+TIUVIEW D  Q
  1.  . . W !!,$C(7),$C(7),$C(7),$P(TIUVIEW,U,2),!
  1.  . . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
  1.  . S TIUDAARY(TIUI)=TIUDA
  1.  . S TIUCHNG=0
  1.  . D EN^VALM("TIU REASSIGN")
  1.  . I +$G(TIUCHNG) D
  1.  . . S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI
  1.  ; -- Rebuild list: --
  1.  S TIUCHNG("RBLD")=1
  1.  D UPRBLD^TIURL(.TIUCHNG) K VALMY
  1.  S VALMBCK="R"
  1.  D VMSG^TIURS1($G(TIULST),.TIUDAARY,"reassigned")
  1.  Q
  1.  ;
  1. REASSIG1 ; Single record reassign
  1.  N TIUAUTH,TIURSSG,TIUNAME,DA,DR,DIE,TIUTYPE,TIUEDIT,TIUADD,TIUPROMO,TIUY
  1.  N TIUD0,TIUD12,TIUD13,TIUD14,TIUODA,TIUOUT K ^TMP("TIURTRCT",$J)
  1.  D FULL^VALM1
  1.  I $$CANTSURG(TIUDA) H 3 Q  ;not permitted for surgery reports
  1.  L +^TIU(8925,+TIUDA):1
  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
  1.  ; Authorized? NO: echo why not & quit
  1.  I +$$HASIMG^TIURB2(TIUDA) D IMGNOTE^TIURB2 Q
  1.  I +$$ISADDNDM^TIULC1(TIUDA) D  I 1
  1.  . N TIUDAD
  1.  . S TIUDAD=+$P(^TIU(8925,TIUDA,0),U,6)
  1.  . I +$$DADORKID^TIUGBR(TIUDAD) D
  1.  . . S TIURSSG="0^You must first detach the ORIGINAL interdisciplinary entry."
  1.  E  I $$DADORKID^TIUGBR(TIUDA) D  I 1
  1.  . S TIURSSG="0^You must first detach interdisciplinary entries."
  1.  I '$D(TIURSSG) S TIURSSG=$$CANDO^TIULP(+TIUDA,"REASSIGN")
  1.  I +$G(TIURSSG)'>0 D  G REASS1X
  1.  . W !!,$C(7),$C(7),$C(7),$P(TIURSSG,U,2),!
  1.  . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
  1.  S TIUD0(0)=$G(^TIU(8925,+TIUDA,0)),TIUD12(0)=$G(^(12))
  1.  S TIUD13(0)=$G(^TIU(8925,+TIUDA,13)),TIUD14(0)=$G(^(14))
  1.  S TIUTYPE=$P(TIUD0(0),U)
  1.  S TIUNAME=$$PNAME^TIULC1(+TIUTYPE)
  1.  S TIUAUTH=$P(TIUD12(0),U,2)
  1.  W !,$C(7)
  1.  S TIUY=$$READ^TIUU("YO","Are you sure you want to REASSIGN this "_TIUNAME,"NO","^D REAS1^TIUDIRH")
  1.  I +TIUY'>0 S TIUOUT=1 G REASS1X
  1.  I +$P(TIUD0(0),U,5)>5 D  G:+$G(TIUOUT) REASS1X
  1.  . W !!,$C(7),$C(7),"The status of this document is: ",$$UP^XLFSTR($$STATUS^TIULC(TIUDA))
  1.  . I +$$GETSIG^TIURD2'>0 S TIUOUT=1
  1.  . W !
  1.  ; Addendum? YES: Ask intended action is move, swap with original, or
  1.  ; replace original
  1.  S TIUADD=$$ISADDNDM^TIULC1(+TIUDA)
  1.  I +TIUADD D  G REASS1X
  1.  . D REASSIGA
  1.  D REASSIGO^TIURD3
  1. REASS1X L -^TIU(8925,+TIUDA):1
  1.  I +$G(TIUOUT),+$G(TIUODA),+$G(TIUDA),$D(TIUD0(0)) D RECOVER^TIURD4(TIUODA,TIUDA,.TIUD0) S TIUDA=TIUODA
  1.  ; Remove additional signers who haven't signed from retracted original
  1.  I '+$G(TIUOUT),+$G(TIUODA) D
  1.  . I +$O(^TIU(8925.7,"B",+$G(TIUODA),0)) D DELSGNRS^TIURD4(TIUODA,1)
  1.  . D ALERTDEL^TIUALRT(TIUODA)
  1.  I '+$G(TIUOUT),+$G(TIUODA),+$$ISA^TIULX(+$G(TIUD0(0)),+$$CLASS^TIUCP) D
  1.  . N TIUCPY,TIUNVSTR
  1.  . Q:'$L($T(TIUREAS^MDAPI))
  1.  . S TIUNVSTR=$P(TIUD12(1),U,11)_";"_$P(TIUD0(1),U,7)
  1.  . S TIUNVSTR=TIUNVSTR_";"_$P(TIUD0(1),U,13)
  1.  . 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)
  1.  D SEND^TIUALRT(TIUDA)
  1.  S VALMBCK=$S(+$G(TIUCHNG):"Q",1:"R") K ^TMP("TIURTRCT",$J)
  1.  Q
  1.  ;
  1. REASSIGO ; Reassign an original Document
  1.  G REASSIGO^TIURD3
  1.  ;
  1. REASSIGA ;Reassign an Addendum to an original DS
  1.  N TIUACT,TIUSET S TIUCHNG=0
  1.  W !,"Please choose the appropriate action for this Addendum:"
  1.  S TIUSET="M:move addendum to a different document"
  1.  S TIUSET=TIUSET_";P:promote addendum as document for another visit"
  1.  S TIUSET=TIUSET_";R:replace parent document with this addendum"
  1.  S TIUSET=TIUSET_";S:swap this addendum with its parent document"
  1.  S TIUACT=$$READ^TIUU("S^"_TIUSET,"Select Reassign Action","move")
  1.  I $P(TIUACT,U)="M" D MOVEADD^TIURD1(TIUDA) Q
  1.  I $P(TIUACT,U)="P" D PROMOTE^TIURD1(TIUDA) Q
  1.  I $P(TIUACT,U)="R" D REPLACE^TIURD1(TIUDA) Q
  1.  I $P(TIUACT,U)="S" D SWAPADD^TIURD1(TIUDA)
  1.  Q
  1.  ;
  1. CLAPPLNK ; Re-link selected Documents to different Client Records
  1.  N TIUCHNG,TIULST,TIUDA,DFN,TIU,TIUDATA,TIUEDIT,TIUI,TIUY,Y,DIROUT,TIUPOP
  1.  N TIUDAARY
  1.  I '$D(VALMY) D EN^VALM2(XQORNOD(0))
  1.  S TIUI=0 D FULL^VALM1
  1.  F  S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0  D  Q:$D(DIROUT)
  1.  . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI))
  1.  . S TIUDA=+$P(TIUDATA,U,2),TIUDAARY(TIUI)=TIUDA
  1.  . S TIUCHNG=0
  1.  . W !!,"Processing Item #",TIUI,"..."
  1.  . D CLAPPLN1(TIUDA)
  1.  . I +$G(TIUCHNG)=1 D
  1.  . . S TIULST=$G(TIULST)_$S($G(TIULST)]"":", ",1:"")_TIUI
  1.  S TIUCHNG("REFRESH")=1
  1.  D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY
  1.  S VALMBCK="R"
  1.  D VMSG^TIURS1($G(TIULST),.TIUDAARY,"re-linked")
  1.  Q
  1.  ;
  1. CLAPPLN1(TIUDA) ; Re-link a single record to the client application
  1.  N TIUREASX,CANLNK,ACTION,ISPRF,OLDLINK
  1.  I '$D(^TIU(8925,TIUDA,0)) D  Q
  1.  . W !!,$C(7),"Document no longer exists.",!
  1.  . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
  1.  I $$CANTSURG(TIUDA) H 3 Q  ;not permitted for surgery reports
  1.  S ISPRF=$$ISPRFDOC^TIUPRF(TIUDA) ;Patient Record Flag
  1.  I ISPRF S ACTION="LINK TO FLAG",OLDLINK=$$GETLINK^DGPFAPI1(TIUDA)
  1.  I 'ISPRF S ACTION="LINK WITH REQUEST",OLDLINK=$P($G(^TIU(8925,TIUDA,14)),U,5)
  1.  I +$$ISADDNDM^TIULC1(TIUDA) D  Q
  1.  . W !!,$C(7),"Links for ADDENDA can't be independently changed.",!
  1.  . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
  1.  S TIUREASX=$$REASSIGN^TIULC1(+$G(^TIU(8925,TIUDA,0)))
  1.  I TIUREASX']"" D  Q
  1.  . W !!,$C(7),"No PACKAGE REASSIGNMENT ACTION Defined.",!
  1.  . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
  1.  I $$DADORKID^TIUGBR(TIUDA) D  Q  ;**100**
  1.  . S CANLNK="0^You must first detach interdisciplinary entries"
  1.  . W !!,$C(7),$C(7),"You must first detach interdisciplinary entries",!
  1.  . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
  1.  S CANLNK=$$CANDO^TIULP(+TIUDA,ACTION)
  1.  I +CANLNK'>0 D  Q
  1.  . W !!,$C(7),$C(7),$P(CANLNK,U,2),!
  1.  . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
  1.  X TIUREASX
  1.  I ISPRF,OLDLINK'=$$GETLINK^DGPFAPI1(TIUDA) S TIUCHNG=1
  1.  I 'ISPRF,$P($G(^TIU(8925,TIUDA,14)),U,5)'=OLDLINK S TIUCHNG=1
  1.  Q
  1.  ;
  1. CANTSURG(TIUDA) ; If TIUDA is surg docmt, write can't do this action and
  1.  ;return 1 for can't do it P184
  1.  N TIUY,CANT,TIUPDA,TIUDA2 S CANT=0,TIUPDA=0,TIUDA2=0
  1.  ; VMP/RJT - *233 - Do not allow action on addenda of Surgical documents 
  1.  D
  1.  . I +$$ISADDNDM^TIULC1(TIUDA) S TIUDA2=+$P($G(^TIU(8925,TIUDA,0)),U,6) Q
  1.  . S TIUDA2=TIUDA
  1.  D ISSURG^TIUSROI(.TIUY,+$G(^TIU(8925,TIUDA2,0)))
  1.  I '+TIUY Q CANT
  1.  S CANT=1 W !,"This action is no longer permitted for SURGICAL REPORTS"
  1.  Q CANT