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

TIURD2.m

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