- 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 Jan 18, 2025@03:46:52 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