TIUSRVD ; SLC/JER - RPC's for document definition ; 09/12/2003 [6/8/05 8:07am]
 ;;1.0;TEXT INTEGRATION UTILITIES;**1,7,22,47,103,100,115,164,112,186,201,276**;Jun 20, 1997;Build 3
NOTES(TIUY) ; Get list of PN Titles
 
LIST(.TIUY,3)
 
Q
SUMMARY(TIUY) ; Get list of DS Titles
 
LIST(.TIUY,244)
 
Q
LIST(TIUY,CLASS,TYPE,TIUK) ; Get list of document titles
 
TIUDFLT
 
; TIUK is STATIC
 
TIUK=+$G(TIUK)
 
I $G(TYPE)']"" TYPE="DOC"
 ; If the user has a preferred list of titles for the CLASS, get it
 
+$O(^TIU(8925.98,"AC",DUZ,CLASS,0)) PERSLIST(.TIUY,DUZ,CLASS,.TIUK,1)
 
TIUK=+$G(TIUK)+1 TIUY(TIUK)="~LONG LIST"
 
TRAVERSE(.TIUY,CLASS,$G(TYPE),.TIUK)
 
TIUDFLT=$$PERSDOC^TIULE(DUZ,+CLASS)
 
+TIUDFLT TIUK=+$G(TIUK)+1,TIUY(TIUK)="d"_$P(TIUDFLT,U,2)
 
Q
TRAVERSE(TIUY,CLASS,TYPE,TIUK) ; Get all selectable titles for the CLASS
 
I,J,X,CURTYP,Y,TIUI,TIUC,TYPMATCH (TIUC,TIUI)=0
 
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)
 
TYPMATCH=$$TYPMATCH^TIULA1(TYPE,CURTYP)
 
+TYPMATCH TIUK=+$G(TIUK)+1
 
I  S TIUY(TIUK)="i"_+CLASS_U_$$PNAME^TIULC1(+CLASS)
 
I=0 F  S I=$O(^TIU(8925.1,+CLASS,10,I)) Q:+I'>0  D
 
J
 
J=+$G(^TIU(8925.1,+CLASS,10,+I,0)) Q:+J'>0
 . 
TRAVERSE(.TIUY,+J,TYPE,.TIUK)
 
Q
PERSLIST(TIUY,DUZ,CLASS,TIUC,TIUFLG) ; Get personal list for a user
 
TIUI,TIUDA,TIUDFLT,INLST
 
TIUDA=+$O(^TIU(8925.98,"AC",DUZ,CLASS,0))
 
Q:+TIUDA'>0
 
+$G(TIUFLGTIUC=1,TIUY(TIUC)="~SHORT LIST"
 
TIUI=0,TIUC=+$G(TIUC)
 
F  S TIUI=$O(^TIU(8925.98,TIUDA,10,TIUI)) Q:+TIUI'>0  D
 
TIUPL,TIUTNM,TIUDTYP,TIUSEQ
 
TIUPL=$G(^TIU(8925.98,TIUDA,10,TIUI,0))
 . 
TIUDTYP=$P(TIUPL,U)
 . 
I $S(+$$CANENTR^TIULP(TIUDTYP)'>0:1,+$$CANPICK^TIULP(TIUDTYP)'>0:1,1:0) Q
 
TIUTNM=$S($P(TIUPL,U,3)]"":$P(TIUPL,U,3),1:$$PNAME^TIULC1(+TIUDTYP))
 . 
TIUSEQ=+$P(TIUPL,U,2),TIUC=+$G(TIUC)+1
 . 
TIUSEQ=$S(+TIUSEQ:$S('$D(TIUY(TIUSEQ)):TIUSEQ,1:(TIUSEQ+1)),1:TIUC)
 . 
TIUY(TIUSEQ)="i"_TIUDTYP_U_TIUTNM,TIUC=+TIUSEQ
 
+$G(TIUFLGQ
 S 
TIUDFLT=$$PERSDOC^TIULE(DUZ,+CLASS)
 
(TIUI,TIUC)=0
 
F  S TIUI=$O(TIUY(TIUI)) Q:+TIUI'>0  D
 
TIUC=TIUI
 
+TIUDFLT,($P($G(TIUY(TIUI)),U)=("i"_+TIUDFLT)) S $P(TIUDFLT,U,2)=$P(TIUY(TIUI),U,2),INLST=TIUI
 
+TIUDFLT D
 
;if default isn't in list, append it as an item
 
'$G(INLSTTIUC=+$G(TIUC)+1,TIUY(TIUC)="i"_TIUDFLT
 
;otherwise, just append as default
 
TIUC=+$G(TIUC)+1,TIUY(TIUC)="d"_TIUDFLT
 
Q
BLRSHELL(TIUY,TITLE,DFN,VSTR) ; Shell for boilerplate RPC
 
^TMP("TIUBOIL",$J)
 
BLRPLT(.TIUY,TITLE,DFN,$G(VSTR))
 
^TMP("TIUBOIL",$J,0)
 
Q
BLRPLT(TIUY,TITLE,DFN,VSTR,ROOT) ; Load/Execute the Boilerplate for TITLE
 ;                                 or ROOT
 
TIU,TIUI,TIUJ,TIUK,TIUL,VADM,VAIN,VA,VAERR TIUI=0
 
;**276** - Do not load boilerplate if template linked
 
TIUNODE,TIULINK I $G(TITLETIUNODE="",TIULINK=+TITLE_";TIU(8925.1," GETLINK^TIUSRVT1(.TIUNODE,TIULINKQ:$P($G(TIUNODE),U)]""
 
S:'$D(TIUYTIUY=$NA(^TMP("TIUBOIL",$J))
 
S:'$D(ROOTROOT=$NA(^TIU(8925.1,+TITLE,"DFLT")) ; **47**
 
I $L($G(VSTR)) PATVADPT^TIULV(.TIU,DFN,"",$G(VSTR)) ; **47**
 
TIUJ=+$P($G(^TMP("TIUBOIL",$J,0)),U,3)+1
 
; --- Set component header ---
 
ROOT["^TIU(8925.1," D
 
^TMP("TIUBOIL",$J,TIUJ,0)=$S($P($G(^TIU(8925.1,+TITLE,0)),U,4)="CO":$P(^TIU(8925.1,+TITLE,0),U)_":   ",1:"")
 
+TIUJ=1,($G(^TMP("TIUBOIL",$J,TIUJ,0))']""^TMP("TIUBOIL",$J,TIUJ,0) TIUJ=0
 
^TMP("TIUBOIL",$J,0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
 
F  S TIUI=$O(@ROOT@(TIUI)) Q:+TIUI'>0  D
 
TIUJ=TIUJ+1,X=$G(@ROOT@(TIUI,0))
 . 
I $L($T(DOLMLINE^TIUSRVF1)),'$D(XWBOS),(X["{FLD:"X=$$DOLMLINE^TIUSRVF1(X)
 . 
X["|" X=$$BOIL(X,TIUJ)
 . 
X["~@" INSMULT(X,"^TMP(""TIUBOIL"",$J)",.TIUJ1
 . 
E  S ^TMP("TIUBOIL",$J,TIUJ,0)=X
 
^TMP("TIUBOIL",$J,0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
 
ROOT["^TIU(8925.1,",+$O(^TIU(8925.1,+TITLE,10,0)) D
 
TIUFITEM,TIUI ITEMS^TIUFLT(+TITLE)
 . 
TIUI=0 F  S TIUI=$O(TIUFITEM(TIUI)) Q:+TIUI'>0  D
 
. . TIUL=+$G(TIUFITEM(+TIUI)) BLRPLT(.TIUY,TIUL,DFN,$G(VSTR))
 
Q
BOIL(LINE,COUNT) ; Execute Boilerplates
 
TIUNEWG,TIUNEWR,TIUOLDG,TIUOLDR
 
TIUI,DIC,X,Y,TIUFPRIV TIUFPRIV=1
 
DIC=8925.1,DIC(0)="FMXZ"
 
DIC("S")="I $P($G(^TIU(8925.1,+Y,0)),U,4)=""O"""
 
TIUI=2:2:$L(LINE,"|"X=$P(LINE,"|",TIUID
 
^DIC
 . 
+Y'>0 X="The OBJECT "_X_" was NOT found...Contact IRM."
 
+Y>0 D
 
. . I $D(^TIU(8925.1,+Y,9)),+$$CANXEC(+Y^(9) S:X["~@" X=$$APPEND(X1
 . . 
E  S X="The OBJECT "_X_" is INACTIVE...Contact IRM."
 
. . X["~@" D
 
. . . X'["^" D
 
. . . . TIUOLDR=$P(X,"~@",2),TIUNEWR=TIUOLDR_TIUI
 
. . . . @TIUNEWR=@TIUOLDR @TIUOLDR
 
. . . . S $P(X,"~@",2)=TIUNEWR
 
. . . X["^" D
 
. . . . TIUOLDG=$P(X,"~@",2),TIUNEWG="^TMP("_"""TIU201"""_","_$J_","_TIUI_")"
 
. . . . @TIUNEWG=@TIUOLDG @TIUOLDG
 
. . . . S $P(X,"~@",2)=TIUNEWG
 
LINE=$$REPLACE(LINE,X,TIUI)
 
Q $TR(LINE,"|","")
CANXEC(TIUODA) ; Evaluate Object Status
 
TIUOST,TIUY TIUOST=+$P($G(^TIU(8925.1,+TIUODA,0)),U,7)
 
TIUY=$S(TIUOST=11:1,+$G(NOSAVE):1,1:0)
 
+$G(TIUY)
APPEND(X) ;
 
TIUXL TIUXL=$L(X)
 
I $E(X,TIUXL-1,TIUXL)'="~@" X=X_"~@"
 
X
REPLACE(LINE,X,TIUI) ; Replace the TIUIth object in LINE w/X
 
S $P(LINE,"|",TIUI)=X
 
LINE
INSMULT(LINE,TARGET,TIULCNT) ; Mult-valued results
 
TIUPC,TIULGTH
 
; TIU*1*164 ;
 
TIULGTH=73 ; 2 replacements of 73 below for TIULGTH
 
S:$$BROKER^XWBLIB TIULGTH=80
 
TIUPC=2:2:$L(LINE,"~@"D
 
TIUI,TIULINE,TIUX,TIUSRC,TIUSCNT,TIUTAIL
 
TIUSRC=$P(LINE,"~@",TIUPC)
 . 
TIUTAIL=$P(LINE,"~@",TIUPC+1)
 . 
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
 
. . TIUSLINE
 
. . TIUSCNT=TIUSCNT+1
 . . 
TIUSLINE=$G(@TIUSRC@(TIUI,0))
 . . 
S:'+$O(@TIUSRC@(TIUI))&(TIUPC+2>$L(LINE,"~@")) TIUSLINE=TIUSLINE_TIUTAIL
 
. . TIUSCNT=1,($L(TIULINE_TIUSLINE)>TIULGTHD  Q
 
. . . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
 . . . 
@TARGET@(TIULCNT,0)=TIULINE
 
. . . TIULCNT=TIULCNT+1
 . . . 
@TARGET@(TIULCNT,0)=TIUSLINE
 
. . TIUSCNT=1,($L(TIULINE_TIUSLINE)'>TIULGTHD  Q
 
. . . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
 . . . 
@TARGET@(TIULCNT,0)=TIULINE_TIUSLINE
 
. . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
 . . 
@TARGET@(TIULCNT,0)=$G(TIUSLINE)
 . 
@TIUSRC
 
Q
LNGCNSLT(Y,FROM,DIR) ; Handle long list of titles for CONSULTS
 
CLASS CLASS=+$$CLASS^TIUCNSLT Q:+CLASS'>0
 
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
 
CLASS CLNAME=$S($G(CLNAME)]"":CLNAME,1:"OPERATION REPORTS")
 
CLASS=$$CLASS^TIUSROI(CLNAMEQ:+CLASS'>0
 
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
 
I,DA,CNT I=0,CNT=44,DIR=$G(DIR,1)
 
F  Q:I'<CNT  FROM=$O(^TIU(8925.1,"ACL",CLASS,FROM),DIRQ:FROM=""  D
 
DA=0
 . 
F  Q:I'<CNT  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
 
. . +$L($T(CANLINK^TIULP)),+$G(IDNOTE),(+$$CANLINK^TIULP(DA)'>0) Q
 
. . I=I+1,Y(I)=DA_"^"_FROM
 
Q
CNSLCLAS(Y) ; RPC to identify class CONSULTS
 
Y=$$CLASS^TIUCNSLT
 
Q
SURGCLAS(Y,CLNAME) ; RPC to identify class 
 ; CLNAME = "SURGICAL REPORTS" or "PROCEDURE REPORTS (NON-O.R.)"
 
CLNAME=$G(CLNAME,"SURGICAL REPORTS")
 
Y=$$CLASS^TIUSROI(CLNAME)
 
Q
CANLINK(Y,TIUTTL)       ; Wrap call to $$CANLINK^TIULP
 
Y=$$CANLINK^TIULP(TIUTTL)
 
Q