TIUHL7U2 ; SLC/AJB - TIUHL7 Utilities; March 23, 2005 ; 3/20/17 4:58pm
;;1.0;TEXT INTEGRATION UTILITIES;**200,312**;Jun 20, 1997;Build 3
; Per VA Directive 6402, this routine should not be modified.
Q
MAKEADD(TIUDADD,TIUDA,TIUX,SUPPRESS) ; Create addendum
N DIE,DR,DA,DIC,X,Y,DLAYGO,TIUATYP,TIUCAN,TIUFPRIV,TIU S TIUFPRIV=1
N PTIEN,SUCCESS
S TIUCAN=$$CANDO^TIULP(TIUDA,"MAKE ADDENDUM",$G(PERSON))
I TIUCAN'>0 S TIUDADD=TIUCAN Q
S TIUATYP=+$$WHATITLE^TIUPUTU("ADDENDUM")
S (DIC,DLAYGO)=8925,DIC(0)="L",X=""""_"`"_TIUATYP_""""
D ^DIC
S TIUDADD=+Y
I +Y'>0 S TIUDADD=TIUDADD_"^Could not create addendum." Q
D GETTIU^TIULD(.TIU,TIUDA)
S TIU("DOCTYP")=TIUATYP_U_$$PNAME^TIULC1(TIUATYP)
S PTIEN=$P(^TIU(8925,TIUDA,0),U,2)
D STUFREC^TIUSRVP1(+TIUDADD,.TIUX,PTIEN,+$G(TIUDA),TIUATYP,.TIU)
K ^TIU(8925,+TIUDADD,"TEMP")
M ^TIU(8925,+TIUDADD,"TEMP")=TIUX("TEXT") K TIUX("TEXT")
D SETXT0^TIUSRVP(+TIUDADD)
D FILE^TIUSRVP(.SUCCESS,+TIUDADD,.TIUX,+$G(SUPPRESS))
I +SUCCESS'>0 D DIK^TIURB2(TIUDADD) S TIUDADD="-1^Could not create addendum." Q
I +$O(^TIU(8925,+TIUDADD,"TEMP",0)) D MERGTEXT^TIUEDI1(+TIUDADD,.TIU)
I '+$G(SUPPRESS) D RELEASE^TIUT(+TIUDADD,1)
K ^TIU(8925,+TIUDADD,"TEMP")
Q
DOCPRM(TIUTYP,TIUDPRM,TIUDA) ; Get Document Parameters, support inheritance
N TIUI,TIUDAD
S (TIUDPRM(0),TIUDPRM(5))=""
I $P($G(^TIU(8925.1,+TIUTYP,0)),U)["ADDENDUM",+$G(TIUDA) S TIUTYP=+$G(^TIU(8925,+$P($G(^TIU(8925,+TIUDA,0)),U,6),0))
S TIUI=+$O(^TIU(8925.95,"B",+TIUTYP,0))
I +TIUI D Q
. S TIUDPRM(0)=$G(^TIU(8925.95,+TIUI,0))
. I +$O(^TIU(8925.95,+TIUI,5,0)) D
. . N TIUJ S TIUJ=0
. . F S TIUJ=$O(^TIU(8925.95,+TIUI,5,TIUJ)) Q:+TIUJ'>0 D
. . . S $P(TIUDPRM(5),U,TIUJ)=+$G(^TIU(8925.95,+TIUI,5,+TIUJ,0))
. . S TIUJ=0
. . F S TIUJ=$O(^TIU(8925.95,+TIUI,4,TIUJ)) Q:+TIUJ'>0 D
. . . S $P(TIUDPRM(4),U,TIUJ)=+$G(^TIU(8925.95,+TIUI,4,+TIUJ,0))
S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
I +TIUDAD D DOCPRM(TIUDAD,.TIUDPRM)
Q
ES(DA,TIUES,TIUI,TIUESIG) ; ^DIE call for /es/
N SIGNER,DR,DIE,ESDT,TIUSTAT,TIUSTNOW,COSIGNER,SVCHIEF,CSREQ,TIUPRINT
N CSNEED,TIUTTL,TIUPSIG,TIUDPRM,DAO,TIUSTWAS,TIUSTIS,DAORIG,TIUCHNG
S TIUSTWAS=$P($G(^TIU(8925,DA,0)),U,5) S:'+$G(TIUESIG) TIUESIG=DUZ
D DOCPRM^TIULC1(+$G(^TIU(8925,+DA,0)),.TIUDPRM,DA)
S TIUSTAT=$P($G(^TIU(8925,+DA,0)),U,5),ESDT=$$NOW^TIULC
S SVCHIEF=+$$ISA^USRLM(TIUESIG,"CLINICAL SERVICE CHIEF")
S SIGNER=$P(^TIU(8925,+DA,12),U,4),COSIGNER=$P(^(12),U,8),CSREQ=0
S CSNEED=+$P($G(^TIU(8925,+DA,15)),U,6)
I +CSNEED,(TIUESIG'=COSIGNER),'+$G(SVCHIEF),(TIUSTAT'=6) S CSREQ=1
I TIUSTAT=5 D
. S DR=".05////"_$S(+CSREQ:6,1:7)_";1501////"_ESDT_";1502////"_+TIUESIG
. I '+$G(CSREQ),+CSNEED,$S(TIUESIG=COSIGNER:1,+$G(SVCHIEF):1,1:0) D
. . S DR=DR_";1506////0;1507////"_ESDT_";1508////"_+TIUESIG_";1509///^S X=$P(TIUES,U,2);1510///^S X=$P(TIUES,U,3);1511////E"
I TIUSTAT=6 S DR=".05////7;1506////0;1507////"_ESDT_";1508////"_+TIUESIG
Q:'$D(DR)
;Patch TIU*1.0*312 write removed from next line - W:'$D(XWBOS) "."
S DIE=8925 D ^DIE
I TIUSTAT=5 S DR="1503///^S X=$P(TIUES,U,2);1504///^S X=$P(TIUES,U,3);1505////E"
I TIUSTAT=6 D
. N TIUSBY S DR="",TIUSBY=$P($G(^TIU(8925,+DA,15)),U,2)
. I +TIUSBY>0 S DR="1503///^S X=$$SIGNAME^TIULS("_TIUSBY_");1504///^S X=$$SIGTITL^TIULS("_TIUSBY_");"
. S DR=$G(DR)_"1509///^S X=$P(TIUES,U,2);1510///^S X=$P(TIUES,U,3);1511////E"
;Patch TIU*1.0*312 write removed from next line - W:'$D(XWBOS) "."
S DIE=8925 D ^DIE S:'+$G(TIUCHNG) TIUCHNG=1
D SEND^TIUALRT(DA),SIGNIRT^TIUDIRT(+DA)
S DAORIG=DA
I +$$ISADDNDM^TIULC1(DA) S DA=+$P($G(^TIU(8925,+DA,0)),U,6)
I +$G(CSREQ)'>0 D MAIN^TIUPD(DA,"S") I 1
;If 'Credit Stop Code on Completion' is Yes - *312 clear flag
;Patch TIU*1.0*312 interactive code skipped
I +$P(^TIU(8925,+DA,0),U,11) D REMFLAG^TIUVSIT(+DA)
;PATCH TIU*1.0*312 Skipping the following code. Replaced with the
;above line of code - this routine is not an interactive routine.
;There should be no reason that this is called by interactive
;processing but I've left the code here commented out just in case.
;FYI: ES^TIUHL7U2 was copied from ES^TIURS when it was developed
;I +$P(^TIU(8925,+DA,0),U,11) D
;. ;If workload does not exist, process using TIU's interview otherwise
;. ;process as an edit using PCE's interview
;. I '$$CHKVST^TIUPXAP2(+DA) D I 1
;. . N TIUCONT,TIUPRMT
;. . Q:$D(XWBOS)
;. . I $P(+$P(^TIU(8925,+DA,0),U,7),".")>DT D Q
;. . . W !!
;. . . D QUE^TIUPXAP1
;. . . W:$$READ^TIUU("EA","Press RETURN to continue...") ""
;. . W !!
;. . ;Check if workload should be entered
;. . I $$CHKWKL^TIUPXAP2(+DA,.TIUDPRM) D CREDIT^TIUVSIT(DA)
;. E D
;. . ;Check if workload should be entered
;. . I $$CHKWKL^TIUPXAP2(+DA,.TIUDPRM) D EDTENC^TIUPXAP2(DA)
;. D REMFLAG^TIUVSIT(+DA)
;
;If document does not have a visit and docmt is associated with
;an event type visit or call is invoked by broker, check if
;docmt can be linked to an existing visit or try and create a new
;visit. (P179)
I $D(^TIU(8925,+DA,0)),$P(^(0),U,3)'>0,($P(^(0),U,13)="E"!($$BROKER^XWBLIB)) D
. N D0,DFN,TIU,TIUVSIT
. ;Try to link docmt to an existing visit, quit if successful
. I $$LNKVST^TIUPXAP3(DA,.TIUVSIT) Q
. ;Otherwise set TIU array and DFN to use TIU API which calls PCE
. ;to resolve multiple visits or creates a new visit
. D GETTIU^TIULD(.TIU,DA)
. S DFN=$P($G(^TIU(8925,+DA,0)),U,2)
. D QUE^TIUPXAP1
; post-signature action
N TIUCONS S TIUCONS=-1
D ISCNSLT^TIUCNSLT(.TIUCONS,+$G(^TIU(8925,DA,0)))
I TIUCONS S DA=DAORIG
S TIUSTIS=$P($G(^TIU(8925,DA,0)),U,5)
S TIUTTL=+$G(^TIU(8925,+DA,0)),TIUPSIG=$$POSTSIGN^TIULC1(TIUTTL)
I +$L(TIUPSIG),'+$G(CSREQ) X TIUPSIG
I TIUCONS,TIUSTIS=7,TIUSTWAS<7,$$HASKIDS^TIUSRVLI(DA) D
. N SEQUENCE,TIUKIDS,TIUINT,TIUK
. S SEQUENCE="D",TIUKIDS="TIUKIDS",TIUINT=0,TIUK=0
. D SETKIDS^TIUSRVLI(TIUKIDS,DA,TIUINT)
. F S TIUK=$O(TIUKIDS(TIUK)) Q:'TIUK D
. . I $P(TIUKIDS(TIUK),U,7)="completed" X TIUPSIG
Q
STRIP(X) ; Strip control characters
N I,Y
; First replace TABS w/5 spaces
F I=1:1:$L(X) S:$A(X,I)=9 X=$E(X,1,(I-1))_" "_$E(X,(I+1),$L(X))
; Next, remove control characters
S Y="" F I=1:1:$L(X) S:$A(X,I)>31 Y=Y_$E(X,I)
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUHL7U2 6258 printed Apr 09, 2024@21:46:40 Page 2
TIUHL7U2 ; SLC/AJB - TIUHL7 Utilities; March 23, 2005 ; 3/20/17 4:58pm
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**200,312**;Jun 20, 1997;Build 3
+2 ; Per VA Directive 6402, this routine should not be modified.
+3 QUIT
MAKEADD(TIUDADD,TIUDA,TIUX,SUPPRESS) ; Create addendum
+1 NEW DIE,DR,DA,DIC,X,Y,DLAYGO,TIUATYP,TIUCAN,TIUFPRIV,TIU
SET TIUFPRIV=1
+2 NEW PTIEN,SUCCESS
+3 SET TIUCAN=$$CANDO^TIULP(TIUDA,"MAKE ADDENDUM",$GET(PERSON))
+4 IF TIUCAN'>0
SET TIUDADD=TIUCAN
QUIT
+5 SET TIUATYP=+$$WHATITLE^TIUPUTU("ADDENDUM")
+6 SET (DIC,DLAYGO)=8925
SET DIC(0)="L"
SET X=""""_"`"_TIUATYP_""""
+7 DO ^DIC
+8 SET TIUDADD=+Y
+9 IF +Y'>0
SET TIUDADD=TIUDADD_"^Could not create addendum."
QUIT
+10 DO GETTIU^TIULD(.TIU,TIUDA)
+11 SET TIU("DOCTYP")=TIUATYP_U_$$PNAME^TIULC1(TIUATYP)
+12 SET PTIEN=$PIECE(^TIU(8925,TIUDA,0),U,2)
+13 DO STUFREC^TIUSRVP1(+TIUDADD,.TIUX,PTIEN,+$GET(TIUDA),TIUATYP,.TIU)
+14 KILL ^TIU(8925,+TIUDADD,"TEMP")
+15 MERGE ^TIU(8925,+TIUDADD,"TEMP")=TIUX("TEXT")
KILL TIUX("TEXT")
+16 DO SETXT0^TIUSRVP(+TIUDADD)
+17 DO FILE^TIUSRVP(.SUCCESS,+TIUDADD,.TIUX,+$GET(SUPPRESS))
+18 IF +SUCCESS'>0
DO DIK^TIURB2(TIUDADD)
SET TIUDADD="-1^Could not create addendum."
QUIT
+19 IF +$ORDER(^TIU(8925,+TIUDADD,"TEMP",0))
DO MERGTEXT^TIUEDI1(+TIUDADD,.TIU)
+20 IF '+$GET(SUPPRESS)
DO RELEASE^TIUT(+TIUDADD,1)
+21 KILL ^TIU(8925,+TIUDADD,"TEMP")
+22 QUIT
DOCPRM(TIUTYP,TIUDPRM,TIUDA) ; Get Document Parameters, support inheritance
+1 NEW TIUI,TIUDAD
+2 SET (TIUDPRM(0),TIUDPRM(5))=""
+3 IF $PIECE($GET(^TIU(8925.1,+TIUTYP,0)),U)["ADDENDUM"
IF +$GET(TIUDA)
SET TIUTYP=+$GET(^TIU(8925,+$PIECE($GET(^TIU(8925,+TIUDA,0)),U,6),0))
+4 SET TIUI=+$ORDER(^TIU(8925.95,"B",+TIUTYP,0))
+5 IF +TIUI
Begin DoDot:1
+6 SET TIUDPRM(0)=$GET(^TIU(8925.95,+TIUI,0))
+7 IF +$ORDER(^TIU(8925.95,+TIUI,5,0))
Begin DoDot:2
+8 NEW TIUJ
SET TIUJ=0
+9 FOR
SET TIUJ=$ORDER(^TIU(8925.95,+TIUI,5,TIUJ))
if +TIUJ'>0
QUIT
Begin DoDot:3
+10 SET $PIECE(TIUDPRM(5),U,TIUJ)=+$GET(^TIU(8925.95,+TIUI,5,+TIUJ,0))
End DoDot:3
+11 SET TIUJ=0
+12 FOR
SET TIUJ=$ORDER(^TIU(8925.95,+TIUI,4,TIUJ))
if +TIUJ'>0
QUIT
Begin DoDot:3
+13 SET $PIECE(TIUDPRM(4),U,TIUJ)=+$GET(^TIU(8925.95,+TIUI,4,+TIUJ,0))
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+14 SET TIUDAD=$ORDER(^TIU(8925.1,"AD",+TIUTYP,0))
+15 IF +TIUDAD
DO DOCPRM(TIUDAD,.TIUDPRM)
+16 QUIT
ES(DA,TIUES,TIUI,TIUESIG) ; ^DIE call for /es/
+1 NEW SIGNER,DR,DIE,ESDT,TIUSTAT,TIUSTNOW,COSIGNER,SVCHIEF,CSREQ,TIUPRINT
+2 NEW CSNEED,TIUTTL,TIUPSIG,TIUDPRM,DAO,TIUSTWAS,TIUSTIS,DAORIG,TIUCHNG
+3 SET TIUSTWAS=$PIECE($GET(^TIU(8925,DA,0)),U,5)
if '+$GET(TIUESIG)
SET TIUESIG=DUZ
+4 DO DOCPRM^TIULC1(+$GET(^TIU(8925,+DA,0)),.TIUDPRM,DA)
+5 SET TIUSTAT=$PIECE($GET(^TIU(8925,+DA,0)),U,5)
SET ESDT=$$NOW^TIULC
+6 SET SVCHIEF=+$$ISA^USRLM(TIUESIG,"CLINICAL SERVICE CHIEF")
+7 SET SIGNER=$PIECE(^TIU(8925,+DA,12),U,4)
SET COSIGNER=$PIECE(^(12),U,8)
SET CSREQ=0
+8 SET CSNEED=+$PIECE($GET(^TIU(8925,+DA,15)),U,6)
+9 IF +CSNEED
IF (TIUESIG'=COSIGNER)
IF '+$GET(SVCHIEF)
IF (TIUSTAT'=6)
SET CSREQ=1
+10 IF TIUSTAT=5
Begin DoDot:1
+11 SET DR=".05////"_$SELECT(+CSREQ:6,1:7)_";1501////"_ESDT_";1502////"_+TIUESIG
+12 IF '+$GET(CSREQ)
IF +CSNEED
IF $SELECT(TIUESIG=COSIGNER:1,+$GET(SVCHIEF):1,1:0)
Begin DoDot:2
+13 SET DR=DR_";1506////0;1507////"_ESDT_";1508////"_+TIUESIG_";1509///^S X=$P(TIUES,U,2);1510///^S X=$P(TIUES,U,3);1511////E"
End DoDot:2
End DoDot:1
+14 IF TIUSTAT=6
SET DR=".05////7;1506////0;1507////"_ESDT_";1508////"_+TIUESIG
+15 if '$DATA(DR)
QUIT
+16 ;Patch TIU*1.0*312 write removed from next line - W:'$D(XWBOS) "."
+17 SET DIE=8925
DO ^DIE
+18 IF TIUSTAT=5
SET DR="1503///^S X=$P(TIUES,U,2);1504///^S X=$P(TIUES,U,3);1505////E"
+19 IF TIUSTAT=6
Begin DoDot:1
+20 NEW TIUSBY
SET DR=""
SET TIUSBY=$PIECE($GET(^TIU(8925,+DA,15)),U,2)
+21 IF +TIUSBY>0
SET DR="1503///^S X=$$SIGNAME^TIULS("_TIUSBY_");1504///^S X=$$SIGTITL^TIULS("_TIUSBY_");"
+22 SET DR=$GET(DR)_"1509///^S X=$P(TIUES,U,2);1510///^S X=$P(TIUES,U,3);1511////E"
End DoDot:1
+23 ;Patch TIU*1.0*312 write removed from next line - W:'$D(XWBOS) "."
+24 SET DIE=8925
DO ^DIE
if '+$GET(TIUCHNG)
SET TIUCHNG=1
+25 DO SEND^TIUALRT(DA)
DO SIGNIRT^TIUDIRT(+DA)
+26 SET DAORIG=DA
+27 IF +$$ISADDNDM^TIULC1(DA)
SET DA=+$PIECE($GET(^TIU(8925,+DA,0)),U,6)
+28 IF +$GET(CSREQ)'>0
DO MAIN^TIUPD(DA,"S")
IF 1
+29 ;If 'Credit Stop Code on Completion' is Yes - *312 clear flag
+30 ;Patch TIU*1.0*312 interactive code skipped
+31 IF +$PIECE(^TIU(8925,+DA,0),U,11)
DO REMFLAG^TIUVSIT(+DA)
+32 ;PATCH TIU*1.0*312 Skipping the following code. Replaced with the
+33 ;above line of code - this routine is not an interactive routine.
+34 ;There should be no reason that this is called by interactive
+35 ;processing but I've left the code here commented out just in case.
+36 ;FYI: ES^TIUHL7U2 was copied from ES^TIURS when it was developed
+37 ;I +$P(^TIU(8925,+DA,0),U,11) D
+38 ;. ;If workload does not exist, process using TIU's interview otherwise
+39 ;. ;process as an edit using PCE's interview
+40 ;. I '$$CHKVST^TIUPXAP2(+DA) D I 1
+41 ;. . N TIUCONT,TIUPRMT
+42 ;. . Q:$D(XWBOS)
+43 ;. . I $P(+$P(^TIU(8925,+DA,0),U,7),".")>DT D Q
+44 ;. . . W !!
+45 ;. . . D QUE^TIUPXAP1
+46 ;. . . W:$$READ^TIUU("EA","Press RETURN to continue...") ""
+47 ;. . W !!
+48 ;. . ;Check if workload should be entered
+49 ;. . I $$CHKWKL^TIUPXAP2(+DA,.TIUDPRM) D CREDIT^TIUVSIT(DA)
+50 ;. E D
+51 ;. . ;Check if workload should be entered
+52 ;. . I $$CHKWKL^TIUPXAP2(+DA,.TIUDPRM) D EDTENC^TIUPXAP2(DA)
+53 ;. D REMFLAG^TIUVSIT(+DA)
+54 ;
+55 ;If document does not have a visit and docmt is associated with
+56 ;an event type visit or call is invoked by broker, check if
+57 ;docmt can be linked to an existing visit or try and create a new
+58 ;visit. (P179)
+59 IF $DATA(^TIU(8925,+DA,0))
IF $PIECE(^(0),U,3)'>0
IF ($PIECE(^(0),U,13)="E"!($$BROKER^XWBLIB))
Begin DoDot:1
+60 NEW D0,DFN,TIU,TIUVSIT
+61 ;Try to link docmt to an existing visit, quit if successful
+62 IF $$LNKVST^TIUPXAP3(DA,.TIUVSIT)
QUIT
+63 ;Otherwise set TIU array and DFN to use TIU API which calls PCE
+64 ;to resolve multiple visits or creates a new visit
+65 DO GETTIU^TIULD(.TIU,DA)
+66 SET DFN=$PIECE($GET(^TIU(8925,+DA,0)),U,2)
+67 DO QUE^TIUPXAP1
End DoDot:1
+68 ; post-signature action
+69 NEW TIUCONS
SET TIUCONS=-1
+70 DO ISCNSLT^TIUCNSLT(.TIUCONS,+$GET(^TIU(8925,DA,0)))
+71 IF TIUCONS
SET DA=DAORIG
+72 SET TIUSTIS=$PIECE($GET(^TIU(8925,DA,0)),U,5)
+73 SET TIUTTL=+$GET(^TIU(8925,+DA,0))
SET TIUPSIG=$$POSTSIGN^TIULC1(TIUTTL)
+74 IF +$LENGTH(TIUPSIG)
IF '+$GET(CSREQ)
XECUTE TIUPSIG
+75 IF TIUCONS
IF TIUSTIS=7
IF TIUSTWAS<7
IF $$HASKIDS^TIUSRVLI(DA)
Begin DoDot:1
+76 NEW SEQUENCE,TIUKIDS,TIUINT,TIUK
+77 SET SEQUENCE="D"
SET TIUKIDS="TIUKIDS"
SET TIUINT=0
SET TIUK=0
+78 DO SETKIDS^TIUSRVLI(TIUKIDS,DA,TIUINT)
+79 FOR
SET TIUK=$ORDER(TIUKIDS(TIUK))
if 'TIUK
QUIT
Begin DoDot:2
+80 IF $PIECE(TIUKIDS(TIUK),U,7)="completed"
XECUTE TIUPSIG
End DoDot:2
End DoDot:1
+81 QUIT
STRIP(X) ; Strip control characters
+1 NEW I,Y
+2 ; First replace TABS w/5 spaces
+3 FOR I=1:1:$LENGTH(X)
if $ASCII(X,I)=9
SET X=$EXTRACT(X,1,(I-1))_" "_$EXTRACT(X,(I+1),$LENGTH(X))
+4 ; Next, remove control characters
+5 SET Y=""
FOR I=1:1:$LENGTH(X)
if $ASCII(X,I)>31
SET Y=Y_$EXTRACT(X,I)
+6 QUIT Y
