184 lines
7.3 KiB
Mathematica
184 lines
7.3 KiB
Mathematica
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**;Jun 20, 1997
|
|
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
|
|
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
|
|
. . . . M @TIUNEWR=@TIUOLDR K @TIUOLDR
|
|
. . . . S $P(X,"~@",2)=TIUNEWR
|
|
. . . I X["^" D
|
|
. . . . S TIUOLDG=$P(X,"~@",2),TIUNEWG="^TMP("_"""TIU201"""_","_$J_","_TIUI_")"
|
|
. . . . 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
|