TIUSRVD ;SLC/JER - RPC's for Document Definition ;04/13/17 13:52
;;1.0;TEXT INTEGRATION UTILITIES;**1,7,22,47,103,100,115,164,112,186,201,276,290**;Jun 20, 1997;Build 548
NOTES(TIUY) ; Get list of PN Titles
D LIST(.TIUY,3)
Q
SUMMARY(TIUY) ; Get list of DS Titles
D LIST(.TIUY,244)
Q
LIST(TIUY,CLASS,TYPE,TIUK) ; Get list of document titles
N TIUDFLT
; TIUK is STATIC
S TIUK=+$G(TIUK)
I $G(TYPE)']"" S TYPE="DOC"
; If the user has a preferred list of titles for the CLASS, get it
I +$O(^TIU(8925.98,"AC",DUZ,CLASS,0)) D PERSLIST(.TIUY,DUZ,CLASS,.TIUK,1)
S TIUK=+$G(TIUK)+1 S TIUY(TIUK)="~LONG LIST"
D TRAVERSE(.TIUY,CLASS,$G(TYPE),.TIUK)
S TIUDFLT=$$PERSDOC^TIULE(DUZ,+CLASS)
I +TIUDFLT S TIUK=+$G(TIUK)+1,TIUY(TIUK)="d"_$P(TIUDFLT,U,2)
Q
TRAVERSE(TIUY,CLASS,TYPE,TIUK) ; Get all selectable titles for the CLASS
N I,J,X,CURTYP,Y,TIUI,TIUC,TYPMATCH S (TIUC,TIUI)=0
S TIUK=+$G(TIUK)
I $S(+$$CANENTR^TIULP(CLASS)'>0:1,+$$CANPICK^TIULP(CLASS)'>0:1,1:0) Q
S CURTYP=$P(^TIU(8925.1,+CLASS,0),U,4)
S TYPMATCH=$$TYPMATCH^TIULA1(TYPE,CURTYP)
I +TYPMATCH S TIUK=+$G(TIUK)+1
I S TIUY(TIUK)="i"_+CLASS_U_$$PNAME^TIULC1(+CLASS)
S I=0 F S I=$O(^TIU(8925.1,+CLASS,10,I)) Q:+I'>0 D
. N J
. S J=+$G(^TIU(8925.1,+CLASS,10,+I,0)) Q:+J'>0
. D TRAVERSE(.TIUY,+J,TYPE,.TIUK)
Q
PERSLIST(TIUY,DUZ,CLASS,TIUC,TIUFLG) ; Get personal list for a user
N TIUI,TIUDA,TIUDFLT,INLST
S TIUDA=+$O(^TIU(8925.98,"AC",DUZ,CLASS,0))
Q:+TIUDA'>0
I +$G(TIUFLG) S TIUC=1,TIUY(TIUC)="~SHORT LIST"
S TIUI=0,TIUC=+$G(TIUC)
F S TIUI=$O(^TIU(8925.98,TIUDA,10,TIUI)) Q:+TIUI'>0 D
. N TIUPL,TIUTNM,TIUDTYP,TIUSEQ
. S TIUPL=$G(^TIU(8925.98,TIUDA,10,TIUI,0))
. S TIUDTYP=$P(TIUPL,U)
. I $S(+$$CANENTR^TIULP(TIUDTYP)'>0:1,+$$CANPICK^TIULP(TIUDTYP)'>0:1,1:0) Q
. S TIUTNM=$S($P(TIUPL,U,3)]"":$P(TIUPL,U,3),1:$$PNAME^TIULC1(+TIUDTYP))
. S TIUSEQ=+$P(TIUPL,U,2),TIUC=+$G(TIUC)+1
. S TIUSEQ=$S(+TIUSEQ:$S('$D(TIUY(TIUSEQ)):TIUSEQ,1:(TIUSEQ+1)),1:TIUC)
. S TIUY(TIUSEQ)="i"_TIUDTYP_U_TIUTNM,TIUC=+TIUSEQ
I +$G(TIUFLG) Q
S TIUDFLT=$$PERSDOC^TIULE(DUZ,+CLASS)
S (TIUI,TIUC)=0
F S TIUI=$O(TIUY(TIUI)) Q:+TIUI'>0 D
. S TIUC=TIUI
. I +TIUDFLT,($P($G(TIUY(TIUI)),U)=("i"_+TIUDFLT)) S $P(TIUDFLT,U,2)=$P(TIUY(TIUI),U,2),INLST=TIUI
I +TIUDFLT D
. ;if default isn't in list, append it as an item
. I '$G(INLST) S TIUC=+$G(TIUC)+1,TIUY(TIUC)="i"_TIUDFLT
. ;otherwise, just append as default
. S TIUC=+$G(TIUC)+1,TIUY(TIUC)="d"_TIUDFLT
Q
BLRSHELL(TIUY,TITLE,DFN,VSTR) ; Shell for boilerplate RPC
K ^TMP("TIUBOIL",$J)
D BLRPLT(.TIUY,TITLE,DFN,$G(VSTR))
K ^TMP("TIUBOIL",$J,0)
Q
BLRPLT(TIUY,TITLE,DFN,VSTR,ROOT) ; Load/Execute the Boilerplate for TITLE
; or ROOT
N TIU,TIUI,TIUJ,TIUK,TIUL,VADM,VAIN,VA,VAERR S TIUI=0
;**276** - Do not load boilerplate if template linked
N TIUNODE,TIULINK I $G(TITLE) S TIUNODE="",TIULINK=+TITLE_";TIU(8925.1," D GETLINK^TIUSRVT1(.TIUNODE,TIULINK) Q:$P($G(TIUNODE),U)]""
S:'$D(TIUY) TIUY=$NA(^TMP("TIUBOIL",$J))
S:'$D(ROOT) ROOT=$NA(^TIU(8925.1,+TITLE,"DFLT")) ; **47**
I $L($G(VSTR)) D PATVADPT^TIULV(.TIU,DFN,"",$G(VSTR)) ; **47**
S TIUJ=+$P($G(^TMP("TIUBOIL",$J,0)),U,3)+1
; --- Set component header ---
I ROOT["^TIU(8925.1," D
. S ^TMP("TIUBOIL",$J,TIUJ,0)=$S($P($G(^TIU(8925.1,+TITLE,0)),U,4)="CO":$P(^TIU(8925.1,+TITLE,0),U)_": ",1:"")
I +TIUJ=1,($G(^TMP("TIUBOIL",$J,TIUJ,0))']"") K ^TMP("TIUBOIL",$J,TIUJ,0) S TIUJ=0
S ^TMP("TIUBOIL",$J,0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
F S TIUI=$O(@ROOT@(TIUI)) Q:+TIUI'>0 D
. S TIUJ=TIUJ+1,X=$G(@ROOT@(TIUI,0))
. I $L($T(DOLMLINE^TIUSRVF1)),'$D(XWBOS),(X["{FLD:") S X=$$DOLMLINE^TIUSRVF1(X)
. I X["|" S X=$$BOIL(X,TIUJ)
. I X["~@" D INSMULT(X,"^TMP(""TIUBOIL"",$J)",.TIUJ) I 1
. E S ^TMP("TIUBOIL",$J,TIUJ,0)=X
. S ^TMP("TIUBOIL",$J,0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
I ROOT["^TIU(8925.1,",+$O(^TIU(8925.1,+TITLE,10,0)) D
. N TIUFITEM,TIUI D ITEMS^TIUFLT(+TITLE)
. S TIUI=0 F S TIUI=$O(TIUFITEM(TIUI)) Q:+TIUI'>0 D
. . S TIUL=+$G(TIUFITEM(+TIUI)) D BLRPLT(.TIUY,TIUL,DFN,$G(VSTR))
Q
BOIL(LINE,COUNT) ; Execute Boilerplates
N TIUNEWG,TIUNEWR,TIUOLDG,TIUOLDR
N TIUI,DIC,X,Y,TIUFPRIV S TIUFPRIV=1
S DIC=8925.1,DIC(0)="FMXZ"
S DIC("S")="I $P($G(^TIU(8925.1,+Y,0)),U,4)=""O"""
F TIUI=2:2:$L(LINE,"|") S X=$P(LINE,"|",TIUI) D
. D ^DIC
. I +Y'>0 S X="The OBJECT "_X_" was NOT found...Contact IRM."
. I +Y>0 D
. . I $D(^TIU(8925.1,+Y,9)),+$$CANXEC(+Y) X ^(9) S:X["~@" X=$$APPEND(X) I 1
. . E S X="The OBJECT "_X_" is INACTIVE...Contact IRM."
. . I X["~@" D
. . . I X'["^" D
. . . . S TIUOLDR=$P(X,"~@",2),TIUNEWR=TIUOLDR_TIUI
. . . . K @TIUNEWR
. . . . M @TIUNEWR=@TIUOLDR K @TIUOLDR
. . . . S $P(X,"~@",2)=TIUNEWR
. . . I X["^" D
. . . . S TIUOLDG=$P(X,"~@",2),TIUNEWG="^TMP("_"""TIU201"""_","_$J_","_TIUI_")"
. . . . K @TIUNEWG
. . . . M @TIUNEWG=@TIUOLDG K @TIUOLDG
. . . . S $P(X,"~@",2)=TIUNEWG
. S LINE=$$REPLACE(LINE,X,TIUI)
Q $TR(LINE,"|","")
CANXEC(TIUODA) ; Evaluate Object Status
N TIUOST,TIUY S TIUOST=+$P($G(^TIU(8925.1,+TIUODA,0)),U,7)
S TIUY=$S(TIUOST=11:1,+$G(NOSAVE):1,1:0)
Q +$G(TIUY)
APPEND(X) ;
N TIUXL S TIUXL=$L(X)
I $E(X,TIUXL-1,TIUXL)'="~@" S X=X_"~@"
Q X
REPLACE(LINE,X,TIUI) ; Replace the TIUIth object in LINE w/X
S $P(LINE,"|",TIUI)=X
Q LINE
INSMULT(LINE,TARGET,TIULCNT) ; Mult-valued results
N TIUPC,TIULGTH
; TIU*1*164 ;
S TIULGTH=73 ; 2 replacements of 73 below for TIULGTH
S:$$BROKER^XWBLIB TIULGTH=80
F TIUPC=2:2:$L(LINE,"~@") D
. N TIUI,TIULINE,TIUX,TIUSRC,TIUSCNT,TIUTAIL
. S TIUSRC=$P(LINE,"~@",TIUPC)
. S TIUTAIL=$P(LINE,"~@",TIUPC+1)
. S TIULINE=$P(LINE,"~@",(TIUPC-1)),(TIUI,TIUSCNT)=0
. I $E(TIULINE)=" ",(TIUPC>2) S $E(TIULINE)=""
. F S TIUI=$O(@TIUSRC@(TIUI)) Q:+TIUI'>0 D
. . N TIUSLINE
. . S TIUSCNT=TIUSCNT+1
. . S TIUSLINE=$G(@TIUSRC@(TIUI,0))
. . S:'+$O(@TIUSRC@(TIUI))&(TIUPC+2>$L(LINE,"~@")) TIUSLINE=TIUSLINE_TIUTAIL
. . I TIUSCNT=1,($L(TIULINE_TIUSLINE)>TIULGTH) D Q
. . . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
. . . S @TARGET@(TIULCNT,0)=TIULINE
. . . S TIULCNT=TIULCNT+1
. . . S @TARGET@(TIULCNT,0)=TIUSLINE
. . I TIUSCNT=1,($L(TIULINE_TIUSLINE)'>TIULGTH) D Q
. . . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
. . . S @TARGET@(TIULCNT,0)=TIULINE_TIUSLINE
. . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
. . S @TARGET@(TIULCNT,0)=$G(TIUSLINE)
. K @TIUSRC
Q
LNGCNSLT(Y,FROM,DIR) ; Handle long list of titles for CONSULTS
N CLASS S CLASS=+$$CLASS^TIUCNSLT Q:+CLASS'>0
D LONGLIST(.Y,CLASS,$G(FROM),$G(DIR,1))
Q
LNGSURG(Y,FROM,DIR,CLNAME) ; long list SURGICAL REPORT titles
; CLNAME = "SURGICAL REPORTS" or "PROCEDURE REPORTS (NON-O.R.)"
; depending on context
N CLASS S CLNAME=$S($G(CLNAME)]"":CLNAME,1:"OPERATION REPORTS")
S CLASS=$$CLASS^TIUSROI(CLNAME) Q:+CLASS'>0
D LONGLIST(.Y,CLASS,$G(FROM),$G(DIR,1))
Q
LONGLIST(Y,CLASS,FROM,DIR,IDNOTE) ; long list of titles for a class
; .Y=returned list, CLASS=ptr to class in 8925.1, FROM=text to $O from,
; DIR=$O direction, IDNOTE=flag to indicate selection for ID Entry
N I,DA,CNT S I=0,CNT=44,DIR=$G(DIR,1)
F Q:I'<CNT S FROM=$O(^TIU(8925.1,"ACL",CLASS,FROM),DIR) Q:FROM="" D
. S DA=0
. F Q:I'<CNT S DA=$O(^TIU(8925.1,"ACL",CLASS,FROM,DA)) Q:+DA'>0 D
. . I $S(+$$CANENTR^TIULP(DA)'>0:1,+$$CANPICK^TIULP(DA)'>0:1,1:0) Q
. . I +$L($T(CANLINK^TIULP)),+$G(IDNOTE),(+$$CANLINK^TIULP(DA)'>0) Q
. . S I=I+1,Y(I)=DA_"^"_FROM
Q
CNSLCLAS(Y) ; RPC to identify class CONSULTS
S Y=$$CLASS^TIUCNSLT
Q
SURGCLAS(Y,CLNAME) ; RPC to identify class
; CLNAME = "SURGICAL REPORTS" or "PROCEDURE REPORTS (NON-O.R.)"
S CLNAME=$G(CLNAME,"SURGICAL REPORTS")
S Y=$$CLASS^TIUSROI(CLNAME)
Q
CANLINK(Y,TIUTTL) ; Wrap call to $$CANLINK^TIULP
S Y=$$CANLINK^TIULP(TIUTTL)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUSRVD 7866 printed Oct 16, 2024@18:46:18 Page 2
TIUSRVD ;SLC/JER - RPC's for Document Definition ;04/13/17 13:52
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1,7,22,47,103,100,115,164,112,186,201,276,290**;Jun 20, 1997;Build 548
NOTES(TIUY) ; Get list of PN Titles
+1 DO LIST(.TIUY,3)
+2 QUIT
SUMMARY(TIUY) ; Get list of DS Titles
+1 DO LIST(.TIUY,244)
+2 QUIT
LIST(TIUY,CLASS,TYPE,TIUK) ; Get list of document titles
+1 NEW TIUDFLT
+2 ; TIUK is STATIC
+3 SET TIUK=+$GET(TIUK)
+4 IF $GET(TYPE)']""
SET TYPE="DOC"
+5 ; If the user has a preferred list of titles for the CLASS, get it
+6 IF +$ORDER(^TIU(8925.98,"AC",DUZ,CLASS,0))
DO PERSLIST(.TIUY,DUZ,CLASS,.TIUK,1)
+7 SET TIUK=+$GET(TIUK)+1
SET TIUY(TIUK)="~LONG LIST"
+8 DO TRAVERSE(.TIUY,CLASS,$GET(TYPE),.TIUK)
+9 SET TIUDFLT=$$PERSDOC^TIULE(DUZ,+CLASS)
+10 IF +TIUDFLT
SET TIUK=+$GET(TIUK)+1
SET TIUY(TIUK)="d"_$PIECE(TIUDFLT,U,2)
+11 QUIT
TRAVERSE(TIUY,CLASS,TYPE,TIUK) ; Get all selectable titles for the CLASS
+1 NEW I,J,X,CURTYP,Y,TIUI,TIUC,TYPMATCH
SET (TIUC,TIUI)=0
+2 SET TIUK=+$GET(TIUK)
+3 IF $SELECT(+$$CANENTR^TIULP(CLASS)'>0:1,+$$CANPICK^TIULP(CLASS)'>0:1,1:0)
QUIT
+4 SET CURTYP=$PIECE(^TIU(8925.1,+CLASS,0),U,4)
+5 SET TYPMATCH=$$TYPMATCH^TIULA1(TYPE,CURTYP)
+6 IF +TYPMATCH
SET TIUK=+$GET(TIUK)+1
+7 IF $TEST
SET TIUY(TIUK)="i"_+CLASS_U_$$PNAME^TIULC1(+CLASS)
+8 SET I=0
FOR
SET I=$ORDER(^TIU(8925.1,+CLASS,10,I))
if +I'>0
QUIT
Begin DoDot:1
+9 NEW J
+10 SET J=+$GET(^TIU(8925.1,+CLASS,10,+I,0))
if +J'>0
QUIT
+11 DO TRAVERSE(.TIUY,+J,TYPE,.TIUK)
End DoDot:1
+12 QUIT
PERSLIST(TIUY,DUZ,CLASS,TIUC,TIUFLG) ; Get personal list for a user
+1 NEW TIUI,TIUDA,TIUDFLT,INLST
+2 SET TIUDA=+$ORDER(^TIU(8925.98,"AC",DUZ,CLASS,0))
+3 if +TIUDA'>0
QUIT
+4 IF +$GET(TIUFLG)
SET TIUC=1
SET TIUY(TIUC)="~SHORT LIST"
+5 SET TIUI=0
SET TIUC=+$GET(TIUC)
+6 FOR
SET TIUI=$ORDER(^TIU(8925.98,TIUDA,10,TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+7 NEW TIUPL,TIUTNM,TIUDTYP,TIUSEQ
+8 SET TIUPL=$GET(^TIU(8925.98,TIUDA,10,TIUI,0))
+9 SET TIUDTYP=$PIECE(TIUPL,U)
+10 IF $SELECT(+$$CANENTR^TIULP(TIUDTYP)'>0:1,+$$CANPICK^TIULP(TIUDTYP)'>0:1,1:0)
QUIT
+11 SET TIUTNM=$SELECT($PIECE(TIUPL,U,3)]"":$PIECE(TIUPL,U,3),1:$$PNAME^TIULC1(+TIUDTYP))
+12 SET TIUSEQ=+$PIECE(TIUPL,U,2)
SET TIUC=+$GET(TIUC)+1
+13 SET TIUSEQ=$SELECT(+TIUSEQ:$SELECT('$DATA(TIUY(TIUSEQ)):TIUSEQ,1:(TIUSEQ+1)),1:TIUC)
+14 SET TIUY(TIUSEQ)="i"_TIUDTYP_U_TIUTNM
SET TIUC=+TIUSEQ
End DoDot:1
+15 IF +$GET(TIUFLG)
QUIT
+16 SET TIUDFLT=$$PERSDOC^TIULE(DUZ,+CLASS)
+17 SET (TIUI,TIUC)=0
+18 FOR
SET TIUI=$ORDER(TIUY(TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+19 SET TIUC=TIUI
+20 IF +TIUDFLT
IF ($PIECE($GET(TIUY(TIUI)),U)=("i"_+TIUDFLT))
SET $PIECE(TIUDFLT,U,2)=$PIECE(TIUY(TIUI),U,2)
SET INLST=TIUI
End DoDot:1
+21 IF +TIUDFLT
Begin DoDot:1
+22 ;if default isn't in list, append it as an item
+23 IF '$GET(INLST)
SET TIUC=+$GET(TIUC)+1
SET TIUY(TIUC)="i"_TIUDFLT
+24 ;otherwise, just append as default
+25 SET TIUC=+$GET(TIUC)+1
SET TIUY(TIUC)="d"_TIUDFLT
End DoDot:1
+26 QUIT
BLRSHELL(TIUY,TITLE,DFN,VSTR) ; Shell for boilerplate RPC
+1 KILL ^TMP("TIUBOIL",$JOB)
+2 DO BLRPLT(.TIUY,TITLE,DFN,$GET(VSTR))
+3 KILL ^TMP("TIUBOIL",$JOB,0)
+4 QUIT
BLRPLT(TIUY,TITLE,DFN,VSTR,ROOT) ; Load/Execute the Boilerplate for TITLE
+1 ; or ROOT
+2 NEW TIU,TIUI,TIUJ,TIUK,TIUL,VADM,VAIN,VA,VAERR
SET TIUI=0
+3 ;**276** - Do not load boilerplate if template linked
+4 NEW TIUNODE,TIULINK
IF $GET(TITLE)
SET TIUNODE=""
SET TIULINK=+TITLE_";TIU(8925.1,"
DO GETLINK^TIUSRVT1(.TIUNODE,TIULINK)
if $PIECE($GET(TIUNODE),U)]""
QUIT
+5 if '$DATA(TIUY)
SET TIUY=$NAME(^TMP("TIUBOIL",$JOB))
+6 ; **47**
if '$DATA(ROOT)
SET ROOT=$NAME(^TIU(8925.1,+TITLE,"DFLT"))
+7 ; **47**
IF $LENGTH($GET(VSTR))
DO PATVADPT^TIULV(.TIU,DFN,"",$GET(VSTR))
+8 SET TIUJ=+$PIECE($GET(^TMP("TIUBOIL",$JOB,0)),U,3)+1
+9 ; --- Set component header ---
+10 IF ROOT["^TIU(8925.1,"
Begin DoDot:1
+11 SET ^TMP("TIUBOIL",$JOB,TIUJ,0)=$SELECT($PIECE($GET(^TIU(8925.1,+TITLE,0)),U,4)="CO":$PIECE(^TIU(8925.1,+TITLE,0),U)_": ",1:"")
End DoDot:1
+12 IF +TIUJ=1
IF ($GET(^TMP("TIUBOIL",$JOB,TIUJ,0))']"")
KILL ^TMP("TIUBOIL",$JOB,TIUJ,0)
SET TIUJ=0
+13 SET ^TMP("TIUBOIL",$JOB,0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
+14 FOR
SET TIUI=$ORDER(@ROOT@(TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+15 SET TIUJ=TIUJ+1
SET X=$GET(@ROOT@(TIUI,0))
+16 IF $LENGTH($TEXT(DOLMLINE^TIUSRVF1))
IF '$DATA(XWBOS)
IF (X["{FLD:")
SET X=$$DOLMLINE^TIUSRVF1(X)
+17 IF X["|"
SET X=$$BOIL(X,TIUJ)
+18 IF X["~@"
DO INSMULT(X,"^TMP(""TIUBOIL"",$J)",.TIUJ)
IF 1
+19 IF '$TEST
SET ^TMP("TIUBOIL",$JOB,TIUJ,0)=X
+20 SET ^TMP("TIUBOIL",$JOB,0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
End DoDot:1
+21 IF ROOT["^TIU(8925.1,"
IF +$ORDER(^TIU(8925.1,+TITLE,10,0))
Begin DoDot:1
+22 NEW TIUFITEM,TIUI
DO ITEMS^TIUFLT(+TITLE)
+23 SET TIUI=0
FOR
SET TIUI=$ORDER(TIUFITEM(TIUI))
if +TIUI'>0
QUIT
Begin DoDot:2
+24 SET TIUL=+$GET(TIUFITEM(+TIUI))
DO BLRPLT(.TIUY,TIUL,DFN,$GET(VSTR))
End DoDot:2
End DoDot:1
+25 QUIT
BOIL(LINE,COUNT) ; Execute Boilerplates
+1 NEW TIUNEWG,TIUNEWR,TIUOLDG,TIUOLDR
+2 NEW TIUI,DIC,X,Y,TIUFPRIV
SET TIUFPRIV=1
+3 SET DIC=8925.1
SET DIC(0)="FMXZ"
+4 SET DIC("S")="I $P($G(^TIU(8925.1,+Y,0)),U,4)=""O"""
+5 FOR TIUI=2:2:$LENGTH(LINE,"|")
SET X=$PIECE(LINE,"|",TIUI)
Begin DoDot:1
+6 DO ^DIC
+7 IF +Y'>0
SET X="The OBJECT "_X_" was NOT found...Contact IRM."
+8 IF +Y>0
Begin DoDot:2
+9 IF $DATA(^TIU(8925.1,+Y,9))
IF +$$CANXEC(+Y)
XECUTE ^(9)
if X["~@"
SET X=$$APPEND(X)
IF 1
+10 IF '$TEST
SET X="The OBJECT "_X_" is INACTIVE...Contact IRM."
+11 IF X["~@"
Begin DoDot:3
+12 IF X'["^"
Begin DoDot:4
+13 SET TIUOLDR=$PIECE(X,"~@",2)
SET TIUNEWR=TIUOLDR_TIUI
+14 KILL @TIUNEWR
+15 MERGE @TIUNEWR=@TIUOLDR
KILL @TIUOLDR
+16 SET $PIECE(X,"~@",2)=TIUNEWR
End DoDot:4
+17 IF X["^"
Begin DoDot:4
+18 SET TIUOLDG=$PIECE(X,"~@",2)
SET TIUNEWG="^TMP("_"""TIU201"""_","_$JOB_","_TIUI_")"
+19 KILL @TIUNEWG
+20 MERGE @TIUNEWG=@TIUOLDG
KILL @TIUOLDG
+21 SET $PIECE(X,"~@",2)=TIUNEWG
End DoDot:4
End DoDot:3
End DoDot:2
+22 SET LINE=$$REPLACE(LINE,X,TIUI)
End DoDot:1
+23 QUIT $TRANSLATE(LINE,"|","")
CANXEC(TIUODA) ; Evaluate Object Status
+1 NEW TIUOST,TIUY
SET TIUOST=+$PIECE($GET(^TIU(8925.1,+TIUODA,0)),U,7)
+2 SET TIUY=$SELECT(TIUOST=11:1,+$GET(NOSAVE):1,1:0)
+3 QUIT +$GET(TIUY)
APPEND(X) ;
+1 NEW TIUXL
SET TIUXL=$LENGTH(X)
+2 IF $EXTRACT(X,TIUXL-1,TIUXL)'="~@"
SET X=X_"~@"
+3 QUIT X
REPLACE(LINE,X,TIUI) ; Replace the TIUIth object in LINE w/X
+1 SET $PIECE(LINE,"|",TIUI)=X
+2 QUIT LINE
INSMULT(LINE,TARGET,TIULCNT) ; Mult-valued results
+1 NEW TIUPC,TIULGTH
+2 ; TIU*1*164 ;
+3 ; 2 replacements of 73 below for TIULGTH
SET TIULGTH=73
+4 if $$BROKER^XWBLIB
SET TIULGTH=80
+5 FOR TIUPC=2:2:$LENGTH(LINE,"~@")
Begin DoDot:1
+6 NEW TIUI,TIULINE,TIUX,TIUSRC,TIUSCNT,TIUTAIL
+7 SET TIUSRC=$PIECE(LINE,"~@",TIUPC)
+8 SET TIUTAIL=$PIECE(LINE,"~@",TIUPC+1)
+9 SET TIULINE=$PIECE(LINE,"~@",(TIUPC-1))
SET (TIUI,TIUSCNT)=0
+10 IF $EXTRACT(TIULINE)=" "
IF (TIUPC>2)
SET $EXTRACT(TIULINE)=""
+11 FOR
SET TIUI=$ORDER(@TIUSRC@(TIUI))
if +TIUI'>0
QUIT
Begin DoDot:2
+12 NEW TIUSLINE
+13 SET TIUSCNT=TIUSCNT+1
+14 SET TIUSLINE=$GET(@TIUSRC@(TIUI,0))
+15 if '+$ORDER(@TIUSRC@(TIUI))&(TIUPC+2>$LENGTH(LINE,"~@"))
SET TIUSLINE=TIUSLINE_TIUTAIL
+16 IF TIUSCNT=1
IF ($LENGTH(TIULINE_TIUSLINE)>TIULGTH)
Begin DoDot:3
+17 if $DATA(@TARGET@(TIULCNT,0))
SET TIULCNT=TIULCNT+1
+18 SET @TARGET@(TIULCNT,0)=TIULINE
+19 SET TIULCNT=TIULCNT+1
+20 SET @TARGET@(TIULCNT,0)=TIUSLINE
End DoDot:3
QUIT
+21 IF TIUSCNT=1
IF ($LENGTH(TIULINE_TIUSLINE)'>TIULGTH)
Begin DoDot:3
+22 if $DATA(@TARGET@(TIULCNT,0))
SET TIULCNT=TIULCNT+1
+23 SET @TARGET@(TIULCNT,0)=TIULINE_TIUSLINE
End DoDot:3
QUIT
+24 if $DATA(@TARGET@(TIULCNT,0))
SET TIULCNT=TIULCNT+1
+25 SET @TARGET@(TIULCNT,0)=$GET(TIUSLINE)
End DoDot:2
+26 KILL @TIUSRC
End DoDot:1
+27 QUIT
LNGCNSLT(Y,FROM,DIR) ; Handle long list of titles for CONSULTS
+1 NEW CLASS
SET CLASS=+$$CLASS^TIUCNSLT
if +CLASS'>0
QUIT
+2 DO LONGLIST(.Y,CLASS,$GET(FROM),$GET(DIR,1))
+3 QUIT
LNGSURG(Y,FROM,DIR,CLNAME) ; long list SURGICAL REPORT titles
+1 ; CLNAME = "SURGICAL REPORTS" or "PROCEDURE REPORTS (NON-O.R.)"
+2 ; depending on context
+3 NEW CLASS
SET CLNAME=$SELECT($GET(CLNAME)]"":CLNAME,1:"OPERATION REPORTS")
+4 SET CLASS=$$CLASS^TIUSROI(CLNAME)
if +CLASS'>0
QUIT
+5 DO LONGLIST(.Y,CLASS,$GET(FROM),$GET(DIR,1))
+6 QUIT
LONGLIST(Y,CLASS,FROM,DIR,IDNOTE) ; long list of titles for a class
+1 ; .Y=returned list, CLASS=ptr to class in 8925.1, FROM=text to $O from,
+2 ; DIR=$O direction, IDNOTE=flag to indicate selection for ID Entry
+3 NEW I,DA,CNT
SET I=0
SET CNT=44
SET DIR=$GET(DIR,1)
+4 FOR
if I'<CNT
QUIT
SET FROM=$ORDER(^TIU(8925.1,"ACL",CLASS,FROM),DIR)
if FROM=""
QUIT
Begin DoDot:1
+5 SET DA=0
+6 FOR
if I'<CNT
QUIT
SET DA=$ORDER(^TIU(8925.1,"ACL",CLASS,FROM,DA))
if +DA'>0
QUIT
Begin DoDot:2
+7 IF $SELECT(+$$CANENTR^TIULP(DA)'>0:1,+$$CANPICK^TIULP(DA)'>0:1,1:0)
QUIT
+8 IF +$LENGTH($TEXT(CANLINK^TIULP))
IF +$GET(IDNOTE)
IF (+$$CANLINK^TIULP(DA)'>0)
QUIT
+9 SET I=I+1
SET Y(I)=DA_"^"_FROM
End DoDot:2
End DoDot:1
+10 QUIT
CNSLCLAS(Y) ; RPC to identify class CONSULTS
+1 SET Y=$$CLASS^TIUCNSLT
+2 QUIT
SURGCLAS(Y,CLNAME) ; RPC to identify class
+1 ; CLNAME = "SURGICAL REPORTS" or "PROCEDURE REPORTS (NON-O.R.)"
+2 SET CLNAME=$GET(CLNAME,"SURGICAL REPORTS")
+3 SET Y=$$CLASS^TIUSROI(CLNAME)
+4 QUIT
CANLINK(Y,TIUTTL) ; Wrap call to $$CANLINK^TIULP
+1 SET Y=$$CANLINK^TIULP(TIUTTL)
+2 QUIT
