- 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 Jan 18, 2025@03:46:18 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)