TIURD2 ; SLC/JER - Reassignment following signature ;11/01/03
 ;;1.0;TEXT INTEGRATION UTILITIES;**61,100,109,113,112**;Jun 20, 1997
RETRACT(TIUDA,TIUDAD,COPYSTAT,NEWDAD,SKIPADD) ; Retract document
 N TIUOD0,TIUOD12,TIUOD13,TIUOD14,TIUOD15,TIUOD16,TIUOD17,TIUI,TIUPAT
 N TIUDPRM,TIUCOPY,TIUVSUPP,DUOUT,DIROUT,DTOUT,DA,DR,DFN,TIU,TIULMETH
 N TIUTYP,TIUVMETH,TIUPATNM,TIUNREC,DFN,TIUNDAD,TIUTNM,ONRTRCT
 S TIUOD0=$G(^TIU(8925,+TIUDA,0)),TIUOD12=$G(^(12)),TIUOD13=$G(^(13))
 S TIUOD14=$G(^TIU(8925,+TIUDA,14)),TIUOD15=$G(^(15)),TIUOD16=$G(^(16))
 S TIUOD17=$G(^TIU(8925,+TIUDA,17))
 S TIUTYP=+TIUOD0,^TMP("TIURTRCT",$J,TIUDA,0)=TIUOD0,COPYSTAT=$G(COPYSTAT,5)
 I $S(+COPYSTAT=14:1,+COPYSTAT=15:1,1:0) D STATUS(TIUDA) G RTADD
 I +$P(TIUOD0,U,5)'>5 D:+$G(NEWDAD) LINKADD(TIUDA,NEWDAD) G RETRAX
 I +COPYSTAT'<7,+$G(NEWDAD) D LINKADD(TIUDA,NEWDAD) G RETRAX
 D FULL^VALM1
 ; --- Initialize document parameters ---
 D DOCPRM^TIULC1(TIUTYP,.TIUDPRM,TIUDA)
 S TIUTNM=$$PNAME^TIULC1(+TIUTYP)
 ; --- Identify the patient ---
 S DFN=+$P(TIUOD0,U,2)
 I +DFN'>0 D  G RETRAX
 . W !,$C(7),"No patient selected..."
 . I $$READ^TIUU("EA","Press RETURN to continue...") W !
 S TIUPATNM=$$PTNAME^TIULC1(DFN)
 ; --- Get visit info ---
 D GETTIU^TIULD(.TIU,TIUDA)
 I '$D(TIU("VSTR")) W !,$C(7),"Patient & Visit required." H 2 G RETRAX
 I $D(TIU) D
 . N TIUNEW,TIUITEM,DA,DR,DIE
 . S DA=$$GETREC^TIUSRVP(DFN,.TIU,TIUTYP,.TIUNEW) Q:+DA'>0
 . I '+$G(TIUNEW) D  Q
 . . W !!,$C(7),"A ",TIUTNM," already exists for this visit."
 . . W !,"You may not use the reassign function to overwrite an existing ",!,$$UPPER^TIULS($$STATUS^TIULC(DA))," ",TIUTNM,".",!
 . . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
 . D REMVSIT(TIUDA,TIUOD0)
 . D COPY0(DA,TIUOD0,.TIU,$G(TIUDAD),COPYSTAT),COPY12(DA,TIUOD12,.TIU)
 . D COPY13(DA,TIUOD13,.TIU,COPYSTAT),COPY14(DA,TIUOD14,.TIU)
 . D COPYSGNR(TIUDA,DA,COPYSTAT)
 . I COPYSTAT>5 D COPY15(DA,TIUOD15)
 . I COPYSTAT>6,$L(TIUOD16) S ^TIU(8925,+DA,16)=TIUOD16
 . I +$$REQCOSIG^TIULP(+TIUTYP,TIUDA,+$P(TIUOD12,U,4)),(COPYSTAT<6) D
 . . N DIE,DR S DIE=8925
 . . S DR="1506////1" D ^DIE
 . D COPY17^TIURC1(DA,TIUOD17),COPYTEXT^TIURC1(TIUDA,DA)
 . I $D(^TIU(8925,DA,"TEMP")) D MERGTEXT^TIUEDI1(DA,.TIU) K ^TIU(8925,+DA,"TEMP")
 . S DR=".05///"_$$UPPER^TIULS($$STATUS^TIULC(DA))_";.1////^S X=$$LINECNT^TIULC(DA);1406////"_TIUDA
 . S DIE=8925 D ^DIE
 . D AUDIT^TIUEDI1(DA,0,$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEXT"")"))
 . S ^TMP("TIURTRCT",$J,"NEW",DA)=""
 . S:'+$G(TIUDAD) TIUNDAD=DA
 . S TIUNREC=$G(TIUNREC)_$S(+$G(TIUNREC):",",1:"")_DA
 . D STATUS(TIUDA)
 S ONRTRCT=$$ONRTRCT^TIULC1(+$G(^TIU(8925,TIUDA,0)))
 I ONRTRCT]"" X ONRTRCT
 ; If SKIPADD is TRUE, bypass retraction of addenda...
 I +$G(SKIPADD) G RETRAX
RTADD ; Retract all addenda
 N TIUDADD S TIUDADD=0
 F  S TIUDADD=$O(^TIU(8925,"DAD",TIUDA,TIUDADD)) Q:+TIUDADD'>0  D
 . I '$$ISADDNDM^TIULC1(TIUDADD) Q
 . D ADDENDEL^TIUALRT(TIUDADD)
 . S TIUNREC=$G(TIUNREC)_$S(+$G(TIUNREC):",",1:"")_$$RETRACT(TIUDADD,TIUDA,$G(COPYSTAT),$G(TIUNDAD))
RETRAX Q +$G(TIUNREC)
REMVSIT(DA,TIUOD0) ; Remove VISIT from Retracted Doc
 N DIE,DR,SVCAT,TIUPOP S TIUPOP=0
 S SVCAT=$P(TIUOD0,U,13)
 I +$$ISADDNDM^TIULC1(DA) D  Q:+TIUPOP
 . I +$P($G(^TIU(8925,+$P(TIUOD0,U,6),0)),U,3)>0 S TIUPOP=1 Q
 . S:SVCAT="" SVCAT=$P($G(^TIU(8925,+$P(TIUOD0,U,6),0)),U,13)
 I SVCAT="H" Q
 W !,"Removing RETRACTED ",TIUTNM," from original Visit..."
 S DIE=8925,DR=".03///@" D ^DIE
 Q
LINKADD(DA,TIUDAD) ; Link addendum (DA) to TIUDAD
 N DR,DIE
 S DIE=8925,DR=".06////^S X=TIUDAD" D ^DIE
 Q
COPY0(DA,TIUD0,TIU,TIUDAD,STATUS) ; Copy root node
 N DR,DIE S DIE=8925,STATUS=$G(STATUS,5)
 S DR=".02////"_DFN_";.03////"_$P(TIUD0,U,3)_";.04////"_$P(TIUD0,U,4)_";.05////"_STATUS_";.06////"_$P(TIUD0,U,6)_";.07////"_$P(TIUD0,U,7)_";.08////"_$P(TIUD0,U,8)_";.09////"_$P(TIUD0,U,9)_";.12////"_$P(TIUD0,U,12)_";.13////"_$P(TIUD0,U,13)
 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
 D ^DIE
 Q
COPY12(DA,TIUD12,TIU) ; Copy 12-node
 N DR,DIE S DIE=8925
 S DR="1201////"_+$$NOW^XLFDT_";1202////"_+$P(TIUD12,U,2)_";1203////"_$P(TIUD12,U,3)_";1204////"_$P(TIUD12,U,4)_";1205////"_$P(TIUD12,U,5)
 S DR=DR_";1206////"_$P(TIUD12,U,6)_";1207////"_$P(TIUD12,U,7)_";1208////"_$P(TIUD12,U,8)_";1209////"_$P(TIUD12,U,9)
 S DR=DR_";1210////"_$P(TIUD12,U,10)_";1211////"_$P(TIUD12,U,11)_";1212////"_$P(TIUD12,U,12)
 D ^DIE
 Q
COPY13(DA,TIUD13,TIU,STATUS) ; Copy 13-node
 N DR,DIE,TIUDT,TIURDT S DIE=8925,TIUDT=$P(TIUD13,U)
 S TIURDT=$S(+$$ISDS^TIULX(+$G(^TIU(8925,DA,0))):+$$REFDATE^TIULC1(.TIU,TIUDT),1:TIUDT)
 S:'TIURDT TIURDT=TIUDT
 S DR="1301////"_TIURDT_";1302////"_$P(TIUD13,U,2)_";1303////O"
 S DR=DR_";1304////"_$S(STATUS<4:"@",1:TIUDT)
 S DR=DR_";1305////"_$S(STATUS<5:"@",1:TIUDT)
 S DR=DR_";1306////"_$S(STATUS<5:"@",+$P(TIUD13,U,6):$P(TIUD13,U,6),1:DUZ)
 S DR=DR_";1307////"_$P(TIUD13,U,7)
 D ^DIE
 Q
COPY14(DA,TIUD14,TIU) ; Copy 14-node
 N DR,DIE S DIE=8925
 S DR="1401////"_$P(TIUD14,U)_";1402////"_$P(TIUD14,U,2)
 S DR=DR_";1403////"_$P(TIUD14,U,3)_";1404////"_$P(TIUD14,U,4)
 S DR=DR_";1405////^S X=$P(TIUD14,U,5)"
 D ^DIE
 Q
COPYSGNR(TIUDA,TIUCDA,COPYSTAT) ; Copy Add'nal Signers
 N TIUSDA S TIUSDA=0
 F  S TIUSDA=$O(^TIU(8925.7,"B",TIUDA,TIUSDA)) Q:+TIUSDA'>0  D
 . N TIUSD0,DA,DR,DIC,DIE,DLAYGO
 . S TIUSD0=$G(^TIU(8925.7,TIUSDA,0))
 . S (DIC,DLAYGO)=8925.7,DIC(0)="LX",X=""""_"`"_TIUCDA_"""" D ^DIC Q:+Y'>0
 . S DA=+Y,DIE=DIC,DR=".02////^S X=0;.03////^S X=$P(TIUSD0,U,3)"
 . I COPYSTAT>5 D
 . . S DR=DR_";.04////^S X=$P(TIUSD0,U,4);.05////^S X=$P(TIUSD0,U,5)"
 . . S DR=DR_";.06////^S X=$P(TIUSD0,U,6);.07////^S X=$P(TIUSD0,U,7)"
 . . S DR=DR_";.08////^S X=$P(TIUSD0,U,8)"
 . D ^DIE
 Q
COPY15(DA,TIUD15) ; Copy 15-node
 N DR,DIE S DIE=8925
 S DR="1501////"_$P(TIUD15,U)_";1502////"_$P(TIUD15,U,2)_";1503////^S X=$P(TIUD15,U,3);1504////^S X=$P(TIUD15,U,4)"
 S DR=DR_";1505////"_$P(TIUD15,U,5)_";1506////"_$P(TIUD15,U,6)_";1507////"_$P(TIUD15,U,7)_";1508////"_$P(TIUD15,U,8)
 S DR=DR_";1509////^S X=$P(TIUD15,U,9);1510////^S X=$P(TIUD15,U,10);1511////"_$P(TIUD15,U,11)_";1512////"_$P(TIUD15,U,12)
 S DR=DR_";1513////"_$P(TIUD15,U,13)
 D ^DIE
 Q
STATUS(DA) ; Set original's status to "RETRACTED"
 N DIE,DR,DIC
 S DIE=8925,DR=".05///RETRACTED" D ^DIE
 D ALERTDEL^TIUALRT(DA),DELIRT^TIUDIRT(DA)
 Q
ATTACH(TIUDA,TIUDADD) ; Attach TIUDADD as addendum to TIUDA
 N DR,DIE,DA,TIUD0,TIUD12,TIUD14,TIUDADA
 S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^(12)),TIUD14=$G(^(14))
 S DIE="^TIU(8925,",DA=TIUDADD
 S DR=".01////81;.02////^S X=$P(TIUD0,U,2);.03////^S X=$P(TIUD0,U,3);.04////^S X=$$DOCCLASS^TIULC1(81)"
 S DR=DR_";.06////^S X=TIUDA;.07////^S X=$P(TIUD0,U,7);.08////^S X=$P(TIUD0,U,8)"
 D ^DIE
 S DR="1205////^S X=$P(TIUD12,U,5);1211////^S X=$P(TIUD12,U,11);1212////^S X=$P(TIUD12,U,12)"
 D ^DIE
 S DR="1301////^S X="_$$REFDTA(TIUDA,TIUDADD,TIUD0)
 S DR=DR_";1401////^S X=$P(TIUD14,U);1402////^S X=$P(TIUD14,U,2)"
 D ^DIE
 ; If TIUDADD has addenda, re-attach them as addenda to TIUDA
 S TIUDADA=0
 F  S TIUDADA=$O(^TIU(8925,"DAD",TIUDADD,TIUDADA)) Q:+TIUDADA'>0  D
 . Q:'+$$ISADDNDM^TIULC1(TIUDADA)
 . D ATTACH(TIUDA,TIUDADA),SEND^TIUALRT(TIUDADA) W "."
 W !!,"Done." S TIUCHNG=1
 Q
REFDTO(TIUDA,TIU) ; Compute reference date
 N TIUY,TIUD12,TIUD13
 S TIUD12=$G(^TIU(8925,+TIUDA,12)),TIUD13=$G(^(13))
 S TIUY=+TIU("LDT")
 I TIUY>0 G REFDTOX
 I +$P(TIUD13,U,7) S TIUY=+$P(TIUD13,U,7) G REFDTOX
 S TIUY=+$P(TIUD12,U)
REFDTOX Q TIUY
REFDTA(TIUDA,TIUDADD,TIUD0) ; Compute reference date for addenda
 N TIUY,TIUDAD12,TIUDAD13
 S TIUDAD12=$G(^TIU(8925,+TIUDADD,12)),TIUDAD13=$G(^(13))
 S TIUY=+TIUDAD13
 I +$$ISDS^TIULX(+TIUD0)'>0 G REFDTAX
 I +$P(TIUDAD13,U) S TIUY=+$P(TIUDAD13,U) G REFDTAX
 I +$P(TIUDAD13,U,7) S TIUY=+$P(TIUDAD13,U,7) G REFDTAX
 S TIUY=+$P(TIUDAD12,U)
REFDTAX Q TIUY
UPDTADD(TIUDA) ; Addenda for reassigned original are updated
 I $$HASADDEN^TIULC1(+TIUDA) D
 . N DA
 . W !!,$C(7),"Addenda for this Document will now be updated..."
 . S DA=0 F  S DA=$O(^TIU(8925,"DAD",+TIUDA,DA)) Q:+DA'>0  D
 . . N DR,DIE,TIUD0,TIUD12,TIUD14
 . . I '+$$ISADDNDM^TIULC1(+DA) Q
 . . S TIUD0(0)=$G(^TIU(8925,+DA,0)),TIUD12(0)=$G(^(12))
 . . S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^(12)),TIUD14=$G(^(14))
 . . S DR=".02////"_$P(TIUD0,U,2)_";.03////"_$S($P(TIUD0,U,3)="":"@",1:$P(TIUD0,U,3))_";.04////"_$P(TIUD0,U,4)_";.07////"_$P(TIUD0,U,7)_";.08////"_$S(+$P(TIUD0,U,8):$P(TIUD0,U,8),1:"@")_";.13////"_$P(TIUD0,U,13)
 . . S DR=DR_";1401////"_$P(TIUD14,U)_";1402////"_$P(TIUD14,U,2)
 . . S DIE=8925 D ^DIE
 . . S DR="1205////"_$P(TIUD12,U,5)_";1211////"_$P(TIUD12,U,11)_";1212////"_$P(TIUD12,U,12)
 . . D ^DIE
 . . S DR="1301////^S X="_$$REFDTA^TIURD2(TIUDA,DA,TIUD0)
 . . D ^DIE W "."
 . . ; Remove and resend alerts
 . . D SEND^TIUALRT(DA)
 . . S TIUD0(1)=$G(^TIU(8925,+DA,0)),TIUD12(1)=$G(^(12))
 . . D AUDREASS^TIURB1(DA,.TIUD0,.TIUD12)
 . . ; If the addendum was retracted, post its audit trail info as well
 . . I +$P($G(^TIU(8925,DA,14)),U,6) D
 . . . D AUDREASS^TIURB1(+$P(^TIU(8925,DA,14),U,6),.TIUD0,.TIUD12)
 Q
VLOC(LOCDA)     ; Resolve location pointer
 Q $P($G(^SC(LOCDA,0)),U)
GETSIG() ; Challenge user for Electronic Signature, when appropriate
 N X,X1,X2,TIUY S TIUY=0
 D SIG^XUSESIG
 I X1']"" D  G GETSIGX
 . W !!,$C(7),$C(7),"You MUST Enter your CORRECT Electronic Signature to Complete this Task...",!
 . W:$$READ^TIUU("EA","Press RETURN to continue...") ""
 S TIUY=1
GETSIGX Q +$G(TIUY)