Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: TIUSRVD

TIUSRVD.m

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