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

TIURD3.m

Go to the documentation of this file. 
  1. TIURD3 ; SLC/JER - Reassign actions ;01-Aug-2011 12:06;MGH
  1.  ;;1.0;TEXT INTEGRATION UTILITIES;**61,124,113,112,1001,1005,1006,1009**;Jun 20, 1997;Build 22
  1.  ;IHS/ITSC/LJF 02/27/2003 added code to update visit pointer in V note when changed here
  1.  ; deleted inpatient data if changed to outpatient visit
  1.  ;07/22/2004 bypass PCE coding on reassign
  1.  ;IHS/ITSC/LJF 01/07/2005 found another place to bypass PCE coding PATCH 1001
  1.  ;
  1.  ;IHS/MSC/MGH  08/03/2006 Changed code for reference date on reassign
  1.  ;IHS/MSC/MGH 10/22/2008 Changed the code back to entered date
  1. REASSIGO ; Reassign an original Document
  1.  N TIU,TIUASK,TIUDPRM
  1.  W !!,"Please choose the correct PATIENT and CARE EPISODE:",!
  1.  ; --- Get a patient ---
  1.  S DFN=+$$PATIENT^TIULA
  1.  ; --- If no pt. selected, QUIT ---
  1.  I +$G(DFN)'>0 D  Q
  1.  . S TIUOUT=1
  1.  . W !!,"No PATIENT Selected: Aborting Transaction, No Harm Done...",!
  1.  . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
  1.  ; --- If document is a Surgical Report, redirect processing ---
  1.  I +$$ISA^TIULX(TIUTYPE,+$$CLASS^TIUSROI("SURGICAL REPORTS")) D REASSOP^TIUSROI(DFN,TIUDA) Q
  1.  ; --- If moving to another pt keep retracted original ---
  1.  I +$G(DFN)'=$P(TIUD0(0),U,2),(+$P(TIUD0(0),U,5)>5) D
  1.  . W !!,"Moving signed document to another Patient...A RETRACTED copy will be retained.",!
  1.  . S TIUODA=TIUDA,TIUDA=+$$RETRACT^TIURD2(TIUDA)
  1.  I TIUDA'>0 D  Q
  1.  . S TIUOUT=1
  1.  . W !!,"Creation of a new Copy of the RETRACTED record failed...Contact IRM.",!
  1.  . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
  1.  ; --- Get Document Parameters for TIUTYPE
  1.  D DOCPRM^TIULC1(TIUTYPE,.TIUDPRM)
  1.  ; --- Get associated visit ---
  1.  S TIULMETH=$$GETLMETH^TIUEDI1(TIUTYPE)
  1.  I '$L(TIULMETH) D  Q
  1.  . S TIUOUT=1
  1.  . W !!,$C(7),"No Visit Linkage Method defined for "
  1.  . W $$PNAME^TIULC1(TIUTYPE),".",!,"Please contact IRM...",!
  1.  . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
  1.  X TIULMETH
  1.  I '$D(TIU) D  Q
  1.  . S TIUOUT=1
  1.  . W !!,$C(7),"Patient & Visit required: Aborting Transaction...No Harm Done.",!
  1.  . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
  1.  ; --- Validate Selection ---
  1.  S TIUVMETH=$$GETVMETH^TIUEDI1(TIUTYPE)
  1.  I '$L(TIUVMETH) D  Q
  1.  . S TIUOUT=1
  1.  . W !!,$C(7),"No Validation Method defined for "
  1.  . W $$PNAME^TIULC1(TIUTYPE),".",!,"Please contact IRM...",!
  1.  . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
  1.  X TIUVMETH
  1.  I +$G(TIUASK)'>0 D  Q
  1.  . S TIUOUT=1
  1.  . W !!,$C(7),"Okay, No Harm Done.",!
  1.  . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
  1.  ; --- If same Pt & Visit, abort transaction ---
  1.  I +$G(TIU("VISIT"))=$P(TIUD0(0),U,3) D  Q:+$G(TIUOUT)
  1.  . I +$G(TIUADD0),+$P($G(TIUDPRM(0)),U,10) Q
  1.  . S TIUOUT=1
  1.  . W !!,$C(7),$C(7),$C(7),"This ",$$PNAME^TIULC1(TIUTYPE)," is already associated with the selected visit...",!
  1.  . W !,"No action taken.",!
  1.  . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
  1.  ; --- If valid Pt and Visit, Reassign the document ---
  1.  I $L($G(TIU("VSTR"))) D
  1.  . N DA,DR,DIE,TIUORIG,TIUOLD0
  1.  . S TIUORIG=+$O(^TIU(8925,"APTLD",DFN,TIUTYPE,$G(TIU("VSTR")),0))
  1.  . S TIUOLD0=$G(^TIU(8925,+TIUORIG,0))
  1.  . ; If record exists and >1 documents/visit NOT allowed, offer
  1.  . ; chance to attach record as addendum
  1.  . I +TIUORIG,(+$P(TIUDPRM(0),U,10)'>0),(+$P(TIUOLD0,U,5)'>13) D  Q
  1.  . . N TIUATT
  1.  . . I TIUORIG=TIUDA D  Q
  1.  . . . W !,$C(7),$C(7),$C(7),"This ",$$PNAME^TIULC1(TIUTYPE)," is already associated with the selected visit...",!
  1.  . . . W !,"No action taken.",!
  1.  . . . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
  1.  . . W !!,$C(7),$C(7),$C(7),"This patient already has a "
  1.  . . W $$UP^XLFSTR($$PNAME^TIULC1(TIUTYPE))," for the selected care"
  1.  . . W !,"episode. Do you wish to make the current record an ADDENDUM of that ",!,$$UP^XLFSTR($$PNAME^TIULC1(TIUTYPE)),"?",!
  1.  . . S TIUATT=$$READ^TIUU("YOA","   ...OK? ","YES")
  1.  . . I +TIUATT'>0 D  Q
  1.  . . . W !!,"All right. No harm done.",!
  1.  . . . S TIUOUT=1
  1.  . . . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
  1.  . . D DELIRT^TIUDIRT($S(+$G(TIUODA):+TIUODA,1:+TIUDA))
  1.  . . D ATTACH^TIURD2(+TIUORIG,TIUDA),SEND^TIUALRT(TIUDA) S TIUCHNG=1
  1.  . ; --- Roll back old IRT data ---
  1.  . D DELIRT^TIUDIRT($S(+$G(TIUODA):+TIUODA,1:+TIUDA))
  1.  . ; --- Set up the ^DIE Call ---
  1.  . S DR=$G(DR)_".02////"_DFN_";.03////"_$S(+$P($G(TIU("VISIT")),U):$P($G(TIU("VISIT")),U),1:"@")_";.07////"_$P($G(TIU("EDT")),U)_";.08////"_$S(+$G(TIU("LDT")):$P($G(TIU("LDT")),U),1:"@")_";.13////"_$P($G(TIU("VSTR")),";",3)
  1.  . ;IHS/ITSC/LJF 02/27/2003 add reference date to update, delete inpt data if needed
  1.  . ;S DR=DR_";1205////"_$P($G(TIU("LOC")),U)_";1401////"_$S($L($G(TIU("AD#"))):+$G(TIU("AD#")),1:"@")_";1402////"_$P($G(TIU("TS")),U)_";1211////"_$P($G(TIU("VLOC")),U)_";1212////"_$P($G(TIU("INST")),U)
  1.  . S DR=DR_";1205////"_$S(+$G(TIU("LOC")):$P($G(TIU("LOC")),U),1:"@")
  1.  . S DR=DR_";1401////"_$S(+$G(TIU("AD#")):$G(TIU("AD#")),1:"@")
  1.  . S DR=DR_";1402////"_$S(+$G(TIU("TS")):$P($G(TIU("TS")),U),1:"@")
  1.  . S DR=DR_";1211////"_$S(+$G(TIU("VLOC")):$P($G(TIU("VLOC")),U),1:"@")
  1.  . ;IHS/ITSC/LJF 02/27/2003 end of mods
  1.  . S:+$$ISDS^TIULX(TIUTYPE) DR=DR_";1301////^S X="_$$REFDTO^TIURD2(TIUDA,.TIU)
  1.  . ; --- Don't ask author or cosigner for documents that have been signed ---
  1.  . S:+$P($G(^TIU(8925,+TIUDA,0)),U,5)'>5 DR=DR_";1202;1204////^S X=$P(^TIU(8925,DA,12),U,2);I '+$P($G(^TIU(8925,+TIUDA,12)),U,8) S Y=0;1208"
  1.  . ; --- Call ^DIE to affect the Reassignment ---
  1.  . S DA=TIUDA,DIE=8925 D ^DIE
  1.  . ; --- Post-reassignment Steps ---
  1.  . ; 1. Package Reassign Action:
  1.  . D PKGACT(TIUDA,.TIUD0,.TIUD12,.TIUD13,.TIUD14,.TIUOUT)
  1.  . Q:+$G(TIUOUT)
  1.  . W !!,$G(TIUNAME)," Reassigned.",!
  1.  . ; 2. Attach document to new Visit
  1.  . D QUE^TIUPXAP1
  1.  . D VNOTFIX^BTIUU1(TIUDA)        ;IHS/ITSC/LJF 02/27/2003 update V Note
  1.  . ; 3. Update Addenda to Document
  1.  . D UPDTADD^TIURD2(TIUDA)
  1.  . ; 4. Update IRT Record
  1.  . D UPDTIRT^TIUDIRT(.TIU,+TIUDA)
  1.  . ; 5. Send Signature Alerts
  1.  . D SEND^TIUALRT(TIUDA)
  1.  . ; 6. Audit Reassignment
  1.  . S TIUD0(1)=$G(^TIU(8925,+TIUDA,0)),TIUD12(1)=$G(^(12))
  1.  . D AUDREASS^TIURB1(TIUDA,.TIUD0,.TIUD12)
  1.  . ; 7. If document was retracted, register audit trail for it
  1.  . I +$G(TIUODA) D AUDREASS^TIURB1(TIUODA,.TIUD0,.TIUD12)
  1.  . ;I +$P($G(TIUD0(0)),U,3) D WKLD(.TIUD0,.TIUD12)   ;IHS/ITSC/LJF 7/22/2004
  1.  . ;Finally, collect workload for target visit as appropriate
  1.  . I (+$P(^TIU(8925,+TIUDA,0),U,5)>6),+$P(^TIU(8925,+TIUDA,0),U,11) D
  1.  . . Q   ;IHS/ITSC/LJF 7/22/2004  bypass PCE coding
  1.  . . I $P(+$G(TIU("EDT")),".")'>DT D  Q:'+TIUASK
  1.  . . . W !!,"You may now edit the encounter data for the DESTINATION Visit...",!
  1.  . . . W !,"Patient: ",$G(TIU("PNM")),!,"  Visit: ",$P($G(TIU("EDT")),U,2)," to ",$P($G(TIU("VLOC")),U,2)
  1.  . . . W ! S TIUASK=+$$READ^TIUU("Y","Do you wish to do this now","NO")
  1.  . . ;If no workload process using TIU's interview
  1.  . . ;else, process using PCE's interview
  1.  . . I '$$CHKVST^TIUPXAP2(+TIUDA) D  I 1
  1.  . . . N TIUCONT,TIUPRMT
  1.  . . . Q:$D(XWBOS)
  1.  . . . I $P(+$P(^TIU(8925,+TIUDA,0),U,7),".")>DT D  Q
  1.  . . . . W !!
  1.  . . . . D QUE^TIUPXAP1
  1.  . . . . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
  1.  . . . ;W !!
  1.  . . . ;need workload? if yes enter
  1.  . . . I $$CHKWKL^TIUPXAP2(+TIUDA,.TIUDPRM) D CREDIT^TIUVSIT(TIUDA)
  1.  . . E  D
  1.  . . . ;need workload? if yes enter
  1.  . . . I $$CHKWKL^TIUPXAP2(+TIUDA,.TIUDPRM) D EDTENC^TIUPXAP2(TIUDA)
  1.  . S TIUCHNG=1 S:+$G(TIUODA) TIUCHNG=TIUCHNG_U_TIUDA
  1.  . W ! I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
  1.  Q
  1.  ;
  1. WKLD(TIUD0,TIUD12) ; Allow user to clean up workload for visit from which document was removed
  1.  N TIUVSIT,TIUWHAT,TIUERR,TIUDFN,TIUEDT,TIUHL
  1.  I $S($P(TIUD0(0),U,13)="H":1,$P(TIUD0(0),U,13)="E":1,1:0) Q
  1.  S TIUHL=$P(TIUD12(0),U,11)
  1.  I $P($G(^SC(+TIUHL,0)),U,3)'="C" Q
  1.  S TIUDFN=$P(TIUD0(0),U,2),TIUEDT=$P(TIUD0(0),U,7),TIUVSIT=$P(TIUD0(0),U,3)
  1.  W !,"You may now clean up the encounter data for the ORIGINAL Visit...",!
  1.  W !,"Patient: ",$$PTNAME^TIULC1(TIUDFN),!,"  Visit: ",$$DATE^TIULS(TIUEDT,"AMTH DD, CCYY@HR:MIN")," to ",$$VLOC^TIURD2(TIUHL)
  1.  W ! I '+$$READ^TIUU("Y","Do you wish to do this now","NO") Q
  1.  I $G(VALMAR)'="^TMP(""TIUR"",$J)" W !!,"Editing Encounter Data...",!
  1.  S TIUWHAT=$S($$CHKAPPT^TIUPXAP2(TIUVSIT,TIUDFN,TIUEDT,TIUHL):"INTV",1:"ADDEDIT")
  1.  S TIUERR=$$INTV^PXAPI(TIUWHAT,"TIU","TEXT INTEGRATION UTILITIES",.TIUVSIT,$S(+$G(TIUVSIT):"",1:TIUHL),TIUDFN,$S(+$G(TIUVSIT):"",1:TIUEDT))
  1.  ;
  1.  ;If an error is returned prompt to continue otherwise if a Visit
  1.  ;IEN is returned and one is not already defined update the document
  1.  ;I +TIUERR<0 D  I 1
  1.  ;. W ! I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
  1.  ;E  I +$G(TIUVSIT),(+$G(TIUVSIT)'=$P($G(^TIU(8925,+TIUDA,0)),U,3)) D
  1.  ;.
  1.  Q
  1. PKGACT(TIUDA,TIUD0,TIUD12,TIUD13,TIUD14,TIUOUT) ; Get/Execute Package Reassign Action
  1.  N TIUREASX,TIUPOP
  1.  S TIUREASX=$$REASSIGN^TIULC1(+$G(^TIU(8925,+TIUDA,0)))
  1.  I TIUREASX]"" D  Q:+$G(TIUPOP)
  1.  . X TIUREASX
  1.  . I +$G(TIUPOP) D  Q
  1.  . . S TIUOUT=1
  1.  . . D WHOABACK(TIUDA,TIUD0(0),TIUD12(0),TIUD13(0),TIUD14(0))
  1.  . . W !!,$C(7),"Can't Reassign this document...",!
  1.  . . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
  1.  . ; --- If original was retracted, call package Delete Action to roll-back ---
  1.  . I +$G(TIUODA) D
  1.  . . N TIUDA,TIUDELX
  1.  . . S TIUDA=TIUODA
  1.  . . S TIUDELX=$$DELETE^TIULC1(+$G(^TIU(8925,+TIUDA,0)))
  1.  . . I TIUDELX]"" X TIUDELX
  1.  Q
  1.  ;
  1. WHOABACK(DA,TIUD0,TIUD12,TIUD13,TIUD14) ; Undo Reassign when fails
  1.  N DIE,DR S DIE=8925
  1.  S DR=".02////"_$P(TIUD0,U,2)_";.03////"_$P(TIUD0,U,3)_";.07////"_$P(TIUD0,U,7)_";.08////"_$P(TIUD0,U,8)_";.13////"_$P(TIUD0,U,13)
  1.  S DR=DR_";1205////"_$P(TIUD12,U,5)_";1401////"_$P(TIUD14,U)_";1402////"_$P(TIUD14,U,2)_";1211////"_$P(TIUD12,U,11)_";1212////"_$P(TIUD12,U,12)
  1.  D ^DIE
  1.  I +$P($G(^TIU(8925,+DA,0)),U,5)'>5 D
  1.  . S DR="1202////"_$P(TIUD12,U,2)_";1305////"_$P(TIUD13,U,5)_";1306////"_$P(TIUD13,U,6)_";1208////"_$P(TIUD12,U,8)_";1209////"_$P(TIUD12,U,9)
  1.  . S DIE=8925 D ^DIE
  1.  Q