TIURS1 ; SLC/JER - Additional /es/ actions ; 11/21/12 4:18pm
;;1.0;TEXT INTEGRATION UTILITIES;**7,36,58,100,109,142,156,184,233,261,274**;Jun 20, 1997;Build 6
ELSIG ; Sign rec
N TIULST,TIUSLST,TIURJCT,TIUES,TIUI,X,X1,Y,TIUDAARY,TIUCHNG
I '$D(TIUPRM0) D SETPARM^TIULE
I $P(TIUPRM0,U,2)'>0 W !,"Electronic signature not yet enabled." H 3 G ELSIGX
I '$D(VALMY) D EN^VALM2(XQORNOD(0))
S TIUI=0 I $D(VALMY)>9 D CLEAR^VALM1
F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D
. N TIU0,TIU12,TIUSTAT,TIUEVNT,TIUTYPE,TIUPOP,TIU15,TIUDPRM
. N ASK,SIGNER,COSIGNER,XTRASGNR,TIUDATA,TIUDA,RSTRCTD
. S (ASK,TIUPOP)=0
. S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI))
. S TIUDA=$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA)
. I RSTRCTD D Q
. . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message
. . I $$READ^TIUU("EA","RETURN to continue...") ; pause
. S TIU0=$G(^TIU(8925,+TIUDA,0)),TIU12=$G(^(12)),TIU15=$G(^(15))
. S SIGNER=$S(+$P(TIU12,U,4):$P(TIU12,U,4),1:$P(TIU12,U,2))
. S COSIGNER=$P(TIU12,U,8)
. I (DUZ'=SIGNER),(DUZ'=COSIGNER) S XTRASGNR=+$O(^TIU(8925.7,"AE",+TIUDA,+DUZ,0))
. S TIUSTAT=+$P(TIU0,U,5)
. S TIUTYPE=$$PNAME^TIULC1(+TIU0)
. S TIUEVNT=$S(TIUSTAT'>5:"SIGNATURE",+$G(XTRASGNR):"SIGNATURE",1:"COSIGNATURE")
. D DOCPRM^TIULC1(+TIU0,.TIUDPRM,TIUDA)
. S ASK=$$CANDO^TIULP(TIUDA,TIUEVNT)
. I +ASK>0 D
. . L +^TIU(8925,+TIUDA):1
. . E S ASK="0^ Another user is editing this entry."
. I +ASK'>0,$P(ASK,U,2)]"" D I 1
. . D FULL^VALM1
. . W !!,"Item #",TIUI,": ",$P(ASK,U,2),! K VALMY(TIUI)
. . W !,"Removed from signature list.",!
. . I $$READ^TIUU("FOA","Press RETURN to continue...")
. E D
. . ;If document is a clinical procedures title AND (P184) this is not an additional signature, check if clinical
. . ;procedure fields are required. If the fields are required, prompt for
. . ;them and don't permit the user to sign unless the fields are defined.
. . I '$G(XTRASGNR),+$$ISA^TIULX(+TIU0,+$$CLASS^TIUCP),$$REQCPF^TIULP(+$P($G(^TIU(8925,+TIUDA,14)),U,5)) D Q:+TIUPOP
. . . N TIUCPFLD
. . . W !!,"Item #",TIUI,": ",TIUTYPE," for "
. . . W $$PTNAME^TIULC1($P(TIU0,U,2))," will need Procedure Summary Code and Date/Time Performed..."
. . . I $G(^TIU(8925,+TIUDA,702)),$P(^(702),U)]"",$P(^(702),U,2)]"" S TIUCPFLD=1 Q
. . . S TIUCPFLD=$$ASKCPF^TIURS(TIUDA)
. . . I +TIUCPFLD'>0 D
. . . . S TIUPOP=1
. . . . W !!,"Item #",TIUI,": MUST have a Procedure Summary Code and Date/Time Performed",!,"before you may sign."
. . . . W !!,"Removed from signature list.",!
. . . . I $$READ^TIUU("FOA","Press RETURN to continue...")
. . ; VMP/RJT - *233
. . I $S(+$$REQCOSIG^TIULP(+TIU0,+TIUDA,DUZ):1,+$P(TIU15,U,6):1,1:0),(+$P(TIU12,U,8)'>0),'+$G(XTRASGNR) D Q:+TIUPOP
. . . N COSIGNER
. . . W !!,"Item #",TIUI,": ",TIUTYPE," for "
. . . W $$PTNAME^TIULC1($P(TIU0,U,2))," will need cosignature..."
. . . S COSIGNER=$$ASKCSNR^TIURS(TIUDA,DUZ)
. . . I +COSIGNER'>0 D
. . . . S TIUPOP=1
. . . . W !!,"Item #",TIUI,": MUST have a cosigner, before you may sign."
. . . . W !!,"Removed from signature list.",!
. . . . I $$READ^TIUU("FOA","Press RETURN to continue...")
. . ; TIU*1.0*274 DJH Do not allow notes without any text to be signed
. . I $$EMPTYDOC^TIULF(+TIUDA) D Q
. . . W !!,"Item #",TIUI,": This note contains no text and cannot be signed."
. . . W !!,"Removed from signature list.",!
. . . I $$READ^TIUU("FOA","Press RETURN to continue...")
. . N TIU,TIUY
. . D EN^VALM("TIU SIGN/COSIGN")
I $D(TIUSLST)'>9 D G ELSIGX
. S VALMSG="** Signature List Empty...Nothing signed. **"
I $D(TIUSLST)>9 D
. N TIUIO
. S TIUES=$$ASKSIG^TIULA1
. I '+TIUES S VALMSG="** Nothing Signed. **" D FIXLSTNW^TIULM Q
. D FULL^VALM1
. D MULTIPRN(.TIUSLST,.TIUIO)
. S TIUI=0 F S TIUI=$O(TIUSLST(TIUI)) Q:+TIUI'>0 D
. . N TIUPY,XTRASGNR
. . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI)),TIUDA=$P(TIUDATA,U,2)
. . S TIUDAARY(TIUI)=TIUDA
. . S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI
. . S XTRASGNR=+$P(TIUSLST(TIUI),U,3)
. . I +$G(XTRASGNR) D ADDSIG^TIURS1(TIUDA,XTRASGNR)
. . I '+$G(XTRASGNR) D ES^TIURS(TIUDA,TIUES)
. . I +TIUSLST(TIUI),(TIUIO]"") D RPC^TIUPD(.TIUPY,TIUDA,TIUIO,$P(TIUSLST(TIUI),U,2))
. D FULL^VALM1
ELSIGX I $G(TIUCHNG("ADDM"))!$G(TIUCHNG("DELETE")) S TIUCHNG("RBLD")=1
E S TIUCHNG("UPDATE")=1
M TIUVALMY=VALMY D UPRBLD^TIURL(.TIUCHNG,.TIUVALMY) K VALMY,TIUVALMY
S VALMBCK="R"
D VMSG($G(TIULST),.TIUDAARY,"signed")
Q
VMSG(TIULST,TIUDAARY,ACTION) ; Set VALMSG for messagebar, bold changed items
N TIUI,LINENO,ACTFIRST
S ACTFIRST=$S(ACTION="Encounter Data Edited":1,ACTION="Signers identified/edited":1,ACTION="Title changed":1,1:0)
I TIULST']"" D Q
. I ACTFIRST S VALMSG="** No changes made. **" Q
. S VALMSG="** Nothing "_ACTION_". **"
I ACTION="copied" S ACTION="copied; See end of list"
S TIULST=$$NEWLST(TIULST,.TIUDAARY)
I TIULST]"" D
. I ACTFIRST D Q
. . S VALMSG="** "_ACTION_" for item"_$S($L(TIULST,",")>1:"s ",$L(TIULST,"-")>1:"s ",1:" ")_TIULST_". **"
. S VALMSG="** Item"_$S($L(TIULST,",")>1:"s ",$L(TIULST,"-")>1:"s ",1:" ")_TIULST_" "_ACTION_". **"
I TIULST']"" D
. I ACTFIRST D Q
. . S VALMSG="** "_ACTION_"; item(s) no longer in list. **"
. S VALMSG="** Item"_$S($L(TIULST,",")>1:"s ",$L(TIULST,"-")>1:"s ",1:" ")_TIULST_" "_ACTION_", no longer in list. **"
. ;S VALMSG="** Item(s) "_ACTION_", no longer in list. **"
Q:$G(^TMP("TIUR",$J,"RTN"))="TIUROR"
F TIUI=1:1 S LINENO=$P(TIULST,", ",TIUI) Q:'LINENO D
. D CNTRL^VALM10(LINENO,1,$G(VALM("RM")),IOINHI,IOINORM)
Q
NEWLST(TIULST,TIUDAARY) ; Return TIULST with updated item numbers
N TIUI,TIULNO,TIUDA,TIUNLNO,TIUNLST
S TIUNLST=""
F TIUI=1:1 S TIULNO=$P(TIULST,",",TIUI) Q:'TIULNO D
. S TIUDA=TIUDAARY(TIULNO),TIUNLNO=$O(^TMP("TIUR",$J,"IEN",TIUDA,0))
. I TIUNLNO S TIUNLST=$G(TIUNLST)_$S($G(TIUNLST)]"":", ",1:"")_TIUNLNO
Q TIUNLST
;
MULTIPRN(TIUSLST,TIUIO) ; ask device
N TIUI,TIUASK,TIUION,TIUPOK,IO,TIUPLIST,TIUSCRN S (TIUI,TIUPOK)=0
F S TIUI=$O(TIUSLST(TIUI)) Q:TIUI'>0!+TIUPOK S:+TIUSLST(TIUI) TIUPOK=1
I '+TIUPOK S TIUIO="" Q
S TIUPLIST=$$LIST(.TIUSLST)
W !!,"Please specify the device for printing item"
W $S(TIUPLIST[",":"s",TIUPLIST["-":"s",1:""),": ",TIUPLIST,!!
S TIUSCRN="I $L($G(^%ZIS(1,+Y,""TYPE""))),("";HFS;MT;BAR;VTRM;RES;CHAN;IMPC;""'[("";""_^(""TYPE"")_"";""))"
S TIUION=$$DEVICE^TIUDEV(.TIUIO,"LAST","N",TIUSCRN,"Q")
I '$L(TIUION) S TIUIO=""
D ^%ZISC
Q
LIST(LIST) ; build print list
N TIUY,TIUI S TIUI=0
F S TIUI=$O(LIST(TIUI)) Q:+TIUI'>0 D
. S:+LIST(TIUI) TIUY=$G(TIUY)_$S($G(TIUY)]"":", ",1:"")_TIUI
Q $G(TIUY)
;
ADDSIG(TIUDA,DA) ; Apply extra signatures to a document
N DIE,DR
S DIE=8925.7
S DR=".04////"_$$NOW^TIULC_";.05////"_DUZ_";.06///^S X=$$SIGNAME^TIULS("_DUZ_");.07///^S X=$$SIGTITL^TIULS("_DUZ_");.08////E"
D ^DIE
D SEND^TIUALRT(TIUDA)
Q
CNVPOST ; Change Titles/Convert Postings
N TIUI,TIULST,Y,TIUVIEW,TIUCHNG,TIUDAARY,DIROUT
I $G(TIUGLINK) W !,"Please finish attaching the interdisciplinary note before changing title.",! H 3 Q
I '$D(VALMY) D EN^VALM2(XQORNOD(0))
S TIUI=0
I +$O(VALMY(0)) D FULL^VALM1
F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT)
. N TIU,TIUDA,DFN,TIUDATA,VALMY,XQORM,TIUVIEW,RSTRCTD
. S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI))
. S TIUDA=+$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA)
. I RSTRCTD D Q
. . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message
. . I $$READ^TIUU("EA","RETURN to continue...") ; pause
. S TIUVIEW=$$CANDO^TIULP(TIUDA,"VIEW")
. I +TIUVIEW'>0 D Q ; Exclude records user can't view
. . W !!,$C(7),$P(TIUVIEW,U,2),! ; Echo denial message
. . I $$READ^TIUU("EA","RETURN to continue...") ; pause
. S TIUCHNG=0
. D EN^VALM("TIU CHANGE TITLE")
. S TIUDAARY(TIUI)=TIUDA
. I +$G(TIUCHNG) S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI
; -- Update list: --
S TIUCHNG("UPDATE")=1 M TIUVALMY=VALMY
D UPRBLD^TIURL(.TIUCHNG,.TIUVALMY) K VALMY,TIUVALMY
S VALMBCK="R"
D VMSG($G(TIULST),.TIUDAARY,"Title changed")
Q
CNVPOST1 ; Convert Single Posting to another title
N TIUD0,DIE,DR,TIUTITL,CHKSUM,TIUCHTTL,TIUCLSS,TIUCON,TIUQUIT
N DA,X,Y
N TIUCHNGD ;261
; Added TIUCON for **142
S TIUD0=$G(^TIU(8925,TIUDA,0)),TIUCHNG=0
; Added TIUNOCS for **142
D FULL^VALM1
I +TIUD0=81 S TIUCHTTL="0^You may not change the TITLE of an ADDENDUM."
I '$D(TIUCHTTL) S TIUCHTTL=$$CANDO^TIULP(TIUDA,"CHANGE TITLE")
I +TIUCHTTL,$$DADORKID^TIUGBR(TIUDA) S TIUCHTTL="0^Interdisciplinary entries must be detached before changing titles." ;**100
I +TIUCHTTL'>0 D Q
. W !!,$C(7),$P(TIUCHTTL,U,2),! ; Echo denial
. I $$READ^TIUU("EA","RETURN to continue...") ; pause
L +^TIU(8925,TIUDA,0):1
E D Q
. W !!?5,$C(7),"Another user is editing this entry.",! ; Echo denial
. I $$READ^TIUU("EA","RETURN to continue...") ; pause
S TIUTITL=$$ASKTITLE^TIULA3(+$$CLINDOC^TIULC1(+TIUD0,TIUDA),+TIUD0)
S TIUCLSS=$$CLASS^TIUCNSLT()
S TIUCON=+$$ISA^TIULX(TIUTITL,TIUCLSS)
I TIUCON=1,+TIUD0'=TIUTITL D CHANGE^TIUCNSLT(TIUDA,"",.TIUNOCS)
I $G(TIUNOCS)=-1 D G POST1Q
. I $$READ^TIUU("EA","Press RETURN to continue...") ; **142
;*184->
D CONSCT^TIUCNSLT(TIUDA,+TIUD0,TIUTITL)
D PRFCT^TIUPRF1(+TIUD0,TIUTITL,TIUDA)
;<-*184
I $G(TIUQUIT)=1 G POST1Q
D WTRMARK^TIURB3(TIUDA,TIUTITL,.TIUCHNGD) I $G(TIUQUIT)=1 G POST1Q ;261
I 'TIUCHNGD D TLDIE(TIUDA,TIUTITL)
I +$G(^TIU(8925,+TIUDA,0))'=+TIUD0 S TIUCHNG=1
S CHKSUM=+$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")")
D AUDIT^TIUEDI1(TIUDA,CHKSUM,CHKSUM)
POST1Q ;clean up, linetag put in with *171
L -^TIU(8925,TIUDA,0)
K TIUNOCS
Q
;
TLDIE(DA,TIUTITL) ; Change title of DA to TIUTITL
N DIE,DR S DIE=8925
S DR=".01////^S X="_TIUTITL_";.04////^S X="_$$DOCCLASS^TIULC1(TIUTITL)
D ^DIE
Q
TIURS1 ; SLC/JER - Additional /es/ actions ; 11/21/12 4:18pm
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**7,36,58,100,109,142,156,184,233,261,274**;Jun 20, 1997;Build 6
ELSIG ; Sign rec
+1 NEW TIULST,TIUSLST,TIURJCT,TIUES,TIUI,X,X1,Y,TIUDAARY,TIUCHNG
+2 IF '$DATA(TIUPRM0)
DO SETPARM^TIULE
+3 IF $PIECE(TIUPRM0,U,2)'>0
WRITE !,"Electronic signature not yet enabled."
HANG 3
GOTO ELSIGX
+4 IF '$DATA(VALMY)
DO EN^VALM2(XQORNOD(0))
+5 SET TIUI=0
IF $DATA(VALMY)>9
DO CLEAR^VALM1
+6 FOR
SET TIUI=$ORDER(VALMY(TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:1
+7 NEW TIU0,TIU12,TIUSTAT,TIUEVNT,TIUTYPE,TIUPOP,TIU15,TIUDPRM
+8 NEW ASK,SIGNER,COSIGNER,XTRASGNR,TIUDATA,TIUDA,RSTRCTD
+9 SET (ASK,TIUPOP)=0
+10 SET TIUDATA=$GET(^TMP("TIURIDX",$JOB,TIUI))
+11 SET TIUDA=$PIECE(TIUDATA,U,2)
SET RSTRCTD=$$DOCRES^TIULRR(TIUDA)
+12 IF RSTRCTD
Begin DoDot:2
+13 ; Echo denial message
WRITE !!,$CHAR(7),"Ok, no harm done...",!
+14 ; pause
IF $$READ^TIUU("EA","RETURN to continue...")
End DoDot:2
QUIT
+15 SET TIU0=$GET(^TIU(8925,+TIUDA,0))
SET TIU12=$GET(^(12))
SET TIU15=$GET(^(15))
+16 SET SIGNER=$SELECT(+$PIECE(TIU12,U,4):$PIECE(TIU12,U,4),1:$PIECE(TIU12,U,2))
+17 SET COSIGNER=$PIECE(TIU12,U,8)
+18 IF (DUZ'=SIGNER)
IF (DUZ'=COSIGNER)
SET XTRASGNR=+$ORDER(^TIU(8925.7,"AE",+TIUDA,+DUZ,0))
+19 SET TIUSTAT=+$PIECE(TIU0,U,5)
+20 SET TIUTYPE=$$PNAME^TIULC1(+TIU0)
+21 SET TIUEVNT=$SELECT(TIUSTAT'>5:"SIGNATURE",+$GET(XTRASGNR):"SIGNATURE",1:"COSIGNATURE")
+22 DO DOCPRM^TIULC1(+TIU0,.TIUDPRM,TIUDA)
+23 SET ASK=$$CANDO^TIULP(TIUDA,TIUEVNT)
+24 IF +ASK>0
Begin DoDot:2
+25 LOCK +^TIU(8925,+TIUDA):1
+26 IF '$TEST
SET ASK="0^ Another user is editing this entry."
End DoDot:2
+27 IF +ASK'>0
IF $PIECE(ASK,U,2)]""
Begin DoDot:2
+28 DO FULL^VALM1
+29 WRITE !!,"Item #",TIUI,": ",$PIECE(ASK,U,2),!
KILL VALMY(TIUI)
+30 WRITE !,"Removed from signature list.",!
+31 IF $$READ^TIUU("FOA","Press RETURN to continue...")
End DoDot:2
IF 1
+32 IF '$TEST
Begin DoDot:2
+33 ;If document is a clinical procedures title AND (P184) this is not an additional signature, check if clinical
+34 ;procedure fields are required. If the fields are required, prompt for
+35 ;them and don't permit the user to sign unless the fields are defined.
+36 IF '$GET(XTRASGNR)
IF +$$ISA^TIULX(+TIU0,+$$CLASS^TIUCP)
IF $$REQCPF^TIULP(+$PIECE($GET(^TIU(8925,+TIUDA,14)),U,5))
Begin DoDot:3
+37 NEW TIUCPFLD
+38 WRITE !!,"Item #",TIUI,": ",TIUTYPE," for "
+39 WRITE $$PTNAME^TIULC1($PIECE(TIU0,U,2))," will need Procedure Summary Code and Date/Time Performed..."
+40 IF $GET(^TIU(8925,+TIUDA,702))
IF $PIECE(^(702),U)]""
IF $PIECE(^(702),U,2)]""
SET TIUCPFLD=1
QUIT
+41 SET TIUCPFLD=$$ASKCPF^TIURS(TIUDA)
+42 IF +TIUCPFLD'>0
Begin DoDot:4
+43 SET TIUPOP=1
+44 WRITE !!,"Item #",TIUI,": MUST have a Procedure Summary Code and Date/Time Performed",!,"before you may sign."
+45 WRITE !!,"Removed from signature list.",!
+46 IF $$READ^TIUU("FOA","Press RETURN to continue...")
End DoDot:4
End DoDot:3
IF +TIUPOP
QUIT
+47 ; VMP/RJT - *233
+48 IF $SELECT(+$$REQCOSIG^TIULP(+TIU0,+TIUDA,DUZ):1,+$PIECE(TIU15,U,6):1,1:0)
IF (+$PIECE(TIU12,U,8)'>0)
IF '+$GET(XTRASGNR)
Begin DoDot:3
+49 NEW COSIGNER
+50 WRITE !!,"Item #",TIUI,": ",TIUTYPE," for "
+51 WRITE $$PTNAME^TIULC1($PIECE(TIU0,U,2))," will need cosignature..."
+52 SET COSIGNER=$$ASKCSNR^TIURS(TIUDA,DUZ)
+53 IF +COSIGNER'>0
Begin DoDot:4
+54 SET TIUPOP=1
+55 WRITE !!,"Item #",TIUI,": MUST have a cosigner, before you may sign."
+56 WRITE !!,"Removed from signature list.",!
+57 IF $$READ^TIUU("FOA","Press RETURN to continue...")
End DoDot:4
End DoDot:3
IF +TIUPOP
QUIT
+58 ; TIU*1.0*274 DJH Do not allow notes without any text to be signed
+59 IF $$EMPTYDOC^TIULF(+TIUDA)
Begin DoDot:3
+60 WRITE !!,"Item #",TIUI,": This note contains no text and cannot be signed."
+61 WRITE !!,"Removed from signature list.",!
+62 IF $$READ^TIUU("FOA","Press RETURN to continue...")
End DoDot:3
QUIT
+63 NEW TIU,TIUY
+64 DO EN^VALM("TIU SIGN/COSIGN")
End DoDot:2
End DoDot:1
+65 IF $DATA(TIUSLST)'>9
Begin DoDot:1
+66 SET VALMSG="** Signature List Empty...Nothing signed. **"
End DoDot:1
GOTO ELSIGX
+67 IF $DATA(TIUSLST)>9
Begin DoDot:1
+68 NEW TIUIO
+69 SET TIUES=$$ASKSIG^TIULA1
+70 IF '+TIUES
SET VALMSG="** Nothing Signed. **"
DO FIXLSTNW^TIULM
QUIT
+71 DO FULL^VALM1
+72 DO MULTIPRN(.TIUSLST,.TIUIO)
+73 SET TIUI=0
FOR
SET TIUI=$ORDER(TIUSLST(TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:2
+74 NEW TIUPY,XTRASGNR
+75 SET TIUDATA=$GET(^TMP("TIURIDX",$JOB,TIUI))
SET TIUDA=$PIECE(TIUDATA,U,2)
+76 SET TIUDAARY(TIUI)=TIUDA
+77 SET TIULST=$GET(TIULST)_$SELECT($GET(TIULST)]"":",",1:"")_TIUI
+78 SET XTRASGNR=+$PIECE(TIUSLST(TIUI),U,3)
+79 IF +$GET(XTRASGNR)
DO ADDSIG^TIURS1(TIUDA,XTRASGNR)
+80 IF '+$GET(XTRASGNR)
DO ES^TIURS(TIUDA,TIUES)
+81 IF +TIUSLST(TIUI)
IF (TIUIO]"")
DO RPC^TIUPD(.TIUPY,TIUDA,TIUIO,$PIECE(TIUSLST(TIUI),U,2))
End DoDot:2
+82 DO FULL^VALM1
End DoDot:1
ELSIGX IF $GET(TIUCHNG("ADDM"))!$GET(TIUCHNG("DELETE"))
SET TIUCHNG("RBLD")=1
+1 IF '$TEST
SET TIUCHNG("UPDATE")=1
+2 MERGE TIUVALMY=VALMY
DO UPRBLD^TIURL(.TIUCHNG,.TIUVALMY)
KILL VALMY,TIUVALMY
+3 SET VALMBCK="R"
+4 DO VMSG($GET(TIULST),.TIUDAARY,"signed")
+5 QUIT
VMSG(TIULST,TIUDAARY,ACTION) ; Set VALMSG for messagebar, bold changed items
+1 NEW TIUI,LINENO,ACTFIRST
+2 SET ACTFIRST=$SELECT(ACTION="Encounter Data Edited":1,ACTION="Signers identified/edited":1,ACTION="Title changed":1,1:0)
+3 IF TIULST']""
Begin DoDot:1
+4 IF ACTFIRST
SET VALMSG="** No changes made. **"
QUIT
+5 SET VALMSG="** Nothing "_ACTION_". **"
End DoDot:1
QUIT
+6 IF ACTION="copied"
SET ACTION="copied; See end of list"
+7 SET TIULST=$$NEWLST(TIULST,.TIUDAARY)
+8 IF TIULST]""
Begin DoDot:1
+9 IF ACTFIRST
Begin DoDot:2
+10 SET VALMSG="** "_ACTION_" for item"_$SELECT($LENGTH(TIULST,",")>1:"s ",$LENGTH(TIULST,"-")>1:"s ",1:" ")_TIULST_". **"
End DoDot:2
QUIT
+11 SET VALMSG="** Item"_$SELECT($LENGTH(TIULST,",")>1:"s ",$LENGTH(TIULST,"-")>1:"s ",1:" ")_TIULST_" "_ACTION_". **"
End DoDot:1
+12 IF TIULST']""
Begin DoDot:1
+13 IF ACTFIRST
Begin DoDot:2
+14 SET VALMSG="** "_ACTION_"; item(s) no longer in list. **"
End DoDot:2
QUIT
+15 SET VALMSG="** Item"_$SELECT($LENGTH(TIULST,",")>1:"s ",$LENGTH(TIULST,"-")>1:"s ",1:" ")_TIULST_" "_ACTION_", no longer in list. **"
+16 ;S VALMSG="** Item(s) "_ACTION_", no longer in list. **"
End DoDot:1
+17 IF $GET(^TMP("TIUR",$JOB,"RTN"))="TIUROR"
QUIT
+18 FOR TIUI=1:1
SET LINENO=$PIECE(TIULST,", ",TIUI)
IF 'LINENO
QUIT
Begin DoDot:1
+19 DO CNTRL^VALM10(LINENO,1,$GET(VALM("RM")),IOINHI,IOINORM)
End DoDot:1
+20 QUIT
NEWLST(TIULST,TIUDAARY) ; Return TIULST with updated item numbers
+1 NEW TIUI,TIULNO,TIUDA,TIUNLNO,TIUNLST
+2 SET TIUNLST=""
+3 FOR TIUI=1:1
SET TIULNO=$PIECE(TIULST,",",TIUI)
IF 'TIULNO
QUIT
Begin DoDot:1
+4 SET TIUDA=TIUDAARY(TIULNO)
SET TIUNLNO=$ORDER(^TMP("TIUR",$JOB,"IEN",TIUDA,0))
+5 IF TIUNLNO
SET TIUNLST=$GET(TIUNLST)_$SELECT($GET(TIUNLST)]"":", ",1:"")_TIUNLNO
End DoDot:1
+6 QUIT TIUNLST
+7 ;
MULTIPRN(TIUSLST,TIUIO) ; ask device
+1 NEW TIUI,TIUASK,TIUION,TIUPOK,IO,TIUPLIST,TIUSCRN
SET (TIUI,TIUPOK)=0
+2 FOR
SET TIUI=$ORDER(TIUSLST(TIUI))
IF TIUI'>0!+TIUPOK
QUIT
IF +TIUSLST(TIUI)
SET TIUPOK=1
+3 IF '+TIUPOK
SET TIUIO=""
QUIT
+4 SET TIUPLIST=$$LIST(.TIUSLST)
+5 WRITE !!,"Please specify the device for printing item"
+6 WRITE $SELECT(TIUPLIST[",":"s",TIUPLIST["-":"s",1:""),": ",TIUPLIST,!!
+7 SET TIUSCRN="I $L($G(^%ZIS(1,+Y,""TYPE""))),("";HFS;MT;BAR;VTRM;RES;CHAN;IMPC;""'[("";""_^(""TYPE"")_"";""))"
+8 SET TIUION=$$DEVICE^TIUDEV(.TIUIO,"LAST","N",TIUSCRN,"Q")
+9 IF '$LENGTH(TIUION)
SET TIUIO=""
+10 DO ^%ZISC
+11 QUIT
LIST(LIST) ; build print list
+1 NEW TIUY,TIUI
SET TIUI=0
+2 FOR
SET TIUI=$ORDER(LIST(TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:1
+3 IF +LIST(TIUI)
SET TIUY=$GET(TIUY)_$SELECT($GET(TIUY)]"":", ",1:"")_TIUI
End DoDot:1
+4 QUIT $GET(TIUY)
+5 ;
ADDSIG(TIUDA,DA) ; Apply extra signatures to a document
+1 NEW DIE,DR
+2 SET DIE=8925.7
+3 SET DR=".04////"_$$NOW^TIULC_";.05////"_DUZ_";.06///^S X=$$SIGNAME^TIULS("_DUZ_");.07///^S X=$$SIGTITL^TIULS("_DUZ_");.08////E"
+4 DO ^DIE
+5 DO SEND^TIUALRT(TIUDA)
+6 QUIT
CNVPOST ; Change Titles/Convert Postings
+1 NEW TIUI,TIULST,Y,TIUVIEW,TIUCHNG,TIUDAARY,DIROUT
+2 IF $GET(TIUGLINK)
WRITE !,"Please finish attaching the interdisciplinary note before changing title.",!
HANG 3
QUIT
+3 IF '$DATA(VALMY)
DO EN^VALM2(XQORNOD(0))
+4 SET TIUI=0
+5 IF +$ORDER(VALMY(0))
DO FULL^VALM1
+6 FOR
SET TIUI=$ORDER(VALMY(TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:1
+7 NEW TIU,TIUDA,DFN,TIUDATA,VALMY,XQORM,TIUVIEW,RSTRCTD
+8 SET TIUDATA=$GET(^TMP("TIURIDX",$JOB,TIUI))
+9 SET TIUDA=+$PIECE(TIUDATA,U,2)
SET RSTRCTD=$$DOCRES^TIULRR(TIUDA)
+10 IF RSTRCTD
Begin DoDot:2
+11 ; Echo denial message
WRITE !!,$CHAR(7),"Ok, no harm done...",!
+12 ; pause
IF $$READ^TIUU("EA","RETURN to continue...")
End DoDot:2
QUIT
+13 SET TIUVIEW=$$CANDO^TIULP(TIUDA,"VIEW")
+14 ; Exclude records user can't view
IF +TIUVIEW'>0
Begin DoDot:2
+15 ; Echo denial message
WRITE !!,$CHAR(7),$PIECE(TIUVIEW,U,2),!
+16 ; pause
IF $$READ^TIUU("EA","RETURN to continue...")
End DoDot:2
QUIT
+17 SET TIUCHNG=0
+18 DO EN^VALM("TIU CHANGE TITLE")
+19 SET TIUDAARY(TIUI)=TIUDA
+20 IF +$GET(TIUCHNG)
SET TIULST=$GET(TIULST)_$SELECT($GET(TIULST)]"":",",1:"")_TIUI
End DoDot:1
IF $DATA(DIROUT)
QUIT
+21 ; -- Update list: --
+22 SET TIUCHNG("UPDATE")=1
MERGE TIUVALMY=VALMY
+23 DO UPRBLD^TIURL(.TIUCHNG,.TIUVALMY)
KILL VALMY,TIUVALMY
+24 SET VALMBCK="R"
+25 DO VMSG($GET(TIULST),.TIUDAARY,"Title changed")
+26 QUIT
CNVPOST1 ; Convert Single Posting to another title
+1 NEW TIUD0,DIE,DR,TIUTITL,CHKSUM,TIUCHTTL,TIUCLSS,TIUCON,TIUQUIT
+2 NEW DA,X,Y
+3 ;261
NEW TIUCHNGD
+4 ; Added TIUCON for **142
+5 SET TIUD0=$GET(^TIU(8925,TIUDA,0))
SET TIUCHNG=0
+6 ; Added TIUNOCS for **142
+7 DO FULL^VALM1
+8 IF +TIUD0=81
SET TIUCHTTL="0^You may not change the TITLE of an ADDENDUM."
+9 IF '$DATA(TIUCHTTL)
SET TIUCHTTL=$$CANDO^TIULP(TIUDA,"CHANGE TITLE")
+10 ;**100
IF +TIUCHTTL
IF $$DADORKID^TIUGBR(TIUDA)
SET TIUCHTTL="0^Interdisciplinary entries must be detached before changing titles."
+11 IF +TIUCHTTL'>0
Begin DoDot:1
+12 ; Echo denial
WRITE !!,$CHAR(7),$PIECE(TIUCHTTL,U,2),!
+13 ; pause
IF $$READ^TIUU("EA","RETURN to continue...")
End DoDot:1
QUIT
+14 LOCK +^TIU(8925,TIUDA,0):1
+15 IF '$TEST
Begin DoDot:1
+16 ; Echo denial
WRITE !!?5,$CHAR(7),"Another user is editing this entry.",!
+17 ; pause
IF $$READ^TIUU("EA","RETURN to continue...")
End DoDot:1
QUIT
+18 SET TIUTITL=$$ASKTITLE^TIULA3(+$$CLINDOC^TIULC1(+TIUD0,TIUDA),+TIUD0)
+19 SET TIUCLSS=$$CLASS^TIUCNSLT()
+20 SET TIUCON=+$$ISA^TIULX(TIUTITL,TIUCLSS)
+21 IF TIUCON=1
IF +TIUD0'=TIUTITL
DO CHANGE^TIUCNSLT(TIUDA,"",.TIUNOCS)
+22 IF $GET(TIUNOCS)=-1
Begin DoDot:1
+23 ; **142
IF $$READ^TIUU("EA","Press RETURN to continue...")
End DoDot:1
GOTO POST1Q
+24 ;*184->
+25 DO CONSCT^TIUCNSLT(TIUDA,+TIUD0,TIUTITL)
+26 DO PRFCT^TIUPRF1(+TIUD0,TIUTITL,TIUDA)
+27 ;<-*184
+28 IF $GET(TIUQUIT)=1
GOTO POST1Q
+29 ;261
DO WTRMARK^TIURB3(TIUDA,TIUTITL,.TIUCHNGD)
IF $GET(TIUQUIT)=1
GOTO POST1Q
+30 IF 'TIUCHNGD
DO TLDIE(TIUDA,TIUTITL)
+31 IF +$GET(^TIU(8925,+TIUDA,0))'=+TIUD0
SET TIUCHNG=1
+32 SET CHKSUM=+$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")")
+33 DO AUDIT^TIUEDI1(TIUDA,CHKSUM,CHKSUM)
POST1Q ;clean up, linetag put in with *171
+1 LOCK -^TIU(8925,TIUDA,0)
+2 KILL TIUNOCS
+3 QUIT
+4 ;
TLDIE(DA,TIUTITL) ; Change title of DA to TIUTITL
+1 NEW DIE,DR
SET DIE=8925
+2 SET DR=".01////^S X="_TIUTITL_";.04////^S X="_$$DOCCLASS^TIULC1(TIUTITL)
+3 DO ^DIE
+4 QUIT
