- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIURS1 9850 printed Feb 19, 2025@00:12:02 Page 2
- 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