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