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

TIUEDI4.m

Go to the documentation of this file. 
  1. TIUEDI4 ; SLC/JER - Enter/Edit a Document ;31-Dec-2012 14:43;DU
  1.  ;;1.0;TEXT INTEGRATION UTILITIES;**100,109,1001,216,1011**;Jun 20, 1997;Build 13
  1.  ;new rtn in TSC, created feb 2 from TIUEDIT
  1.  ; 2/2: Moved LOADDFLT, BOIL, CANXEC, REPLACE, INSMULT to TIUEDI4
  1.  ; 2/3 moved DIE, TEXTEDIT from TIUEDIT to TIUEDI4
  1.  ; 3/2 moved SETTL, GETVST, ASKOK from TIUEDIT to TIUEDI4
  1.  ;
  1.  ;IHS/ITSC/LJF 02/26/2003  add call to edit visit
  1.  ;                         removed space at end of global ref
  1.  ;                         fix incremental lock code in DIE subroutine
  1.  ;IHS/ITSC/LJF 01/12/2005  PATCH 1001 - New'ed DA under BOIL so INSMULT would have it to use
  1.  ;
  1. SETTL(TIUTYP,TIUCLASS,TIUTITLE) ; Set array TIUTYP w/ title info
  1.  ;  e.g. TIUTYP(1) = 1^113^CRISIS, where 113 is IFN of CRISIS title,
  1.  ;          TIUTYP = 1 if gotten from TIUTITLE
  1.  ;          TIUTYP = 113 if gotten from user
  1.  ; Requires TIUCLASS
  1.  ; Receives TIUTITLE - optional = Title DA or Title Name or DA^Name
  1.  N TIUDFLT
  1.  ; -- Get title from TIUTITLE if it's there: --
  1.  I $G(TIUTITLE)]"",$S(+$G(NOSAVE):1,+$P(TIUTITLE,U,2):1,1:0) D  I 1
  1.  . S TIUTYP=1,TIUTITLE=$P(TIUTITLE,U)
  1.  . S TIUTYP(1)=1_U_$S(+$G(TIUTITLE)>0:+$G(TIUTITLE),1:+$O(^TIU(8925.1,"B",TIUTITLE,0)))
  1.  . S $P(TIUTYP(1),U,3)=$$PNAME^TIULC1(+$P(TIUTYP(1),U,2))
  1.  ; -- If not, ask user: --
  1.  E  D
  1.  . S TIUDFLT="LAST" ; use user's preferred list of docmts
  1.  . D DOCSPICK^TIULA2(.TIUTYP,TIUCLASS,"1A",TIUDFLT,"","+$$CANPICK^TIULP(+Y),+$$CANENTR^TIULP(+Y)")
  1.  I +$G(TIUTYP)'>0 S TIUOUT=1 Q
  1.  S TIUTYP=+$P($G(TIUTYP(1)),U,2)
  1.  Q
  1.  ;
  1. GETVST(DFN,TIUTYP,TIU,EVNTFLAG) ; Get visit, set array TIU
  1.  ; -- If no eventflag & don't suppress visit, then execute
  1.  ;    visit linkage method: --
  1.  ; Requires DFN
  1.  ; Requires simple variable TIUTYP = title DA
  1.  ; Optional EVNTFLAG
  1.  ; Returns array TIU
  1.  N TIUVSUPP,TIULMETH
  1.  S TIUVSUPP=0
  1.  I '$G(EVNTFLAG) S TIUVSUPP=+$$SUPPVSIT^TIULC1(TIUTYP)
  1.  ; -- execute visit linkage method for TIUTYP --
  1.  I 'TIUVSUPP,'$G(EVNTFLAG) D  I 1
  1.  . S TIULMETH=$$GETLMETH^TIUEDI1(TIUTYP)
  1.  . I '$L(TIULMETH) D  S TIUOUT=1 Q
  1.  . . W !,$C(7),"No Visit Linkage Method defined for "
  1.  . . W $$PNAME^TIULC1(TIUTYP),".",!,"Please contact IRM..."
  1.  . ; -- TIULMETH for PN: D ENPN^TIUVSIT(.TIU,.DFN,1) --
  1.  . X TIULMETH
  1.  ; -- else create new historical "E" visit: --
  1.  E  D EVENT^TIUSRVP1(.TIU,DFN)
  1.  I $S($D(DIROUT):1,$D(DTOUT):1,1:0) S TIUQUIT=1 Q
  1.  I '$D(TIU("VSTR")) D
  1.  . W !,$C(7),"Patient & Visit required." H 2
  1.  Q
  1.  ;
  1. ASKOK(TIUTYP,TIU,TIUBY,TIUASK) ; X Validation method.
  1.  ; Receives and returns array TIU, simple var TIUTYP, [array TIUBY]
  1.  ; Sets TIUASK = answer, = 0 for not OK or 1 for OK
  1.  N TIUVMETH
  1.  S TIUVMETH=$$GETVMETH^TIUEDI1(TIUTYP)
  1.  I '$L(TIUVMETH) D  S TIUOUT=1 Q
  1.  . W !,$C(7),"No Validation Method defined for "
  1.  . W $$PNAME^TIULC1(TIUTYP),".",!,"Please contact IRM..."
  1.  ; -- TIUVMETH for PN: S TIUASK=$$CHEKPN^TIULD(.TIU,.TIUBY) --
  1.  X TIUVMETH
  1.  ; -- If finish without a visit, then quit: --
  1.  I '$D(TIU("VSTR")) D
  1.  . W !,$C(7),"Patient & Visit required." H 2
  1.  I $G(TIU("VISIT")) D VEDIT^BTIUED("")  ;IHS/ITSC/LJF 02/26/2003 add visit edit call
  1.  Q
  1.  ;
  1. DIE(DA,TIUQUIT,TIUCHNG) ; Invoke ^DIE
  1.  N Y,DIE,DR
  1.  I '$D(TIUPREF) S TIUPREF=$$PERSPRF^TIULE(DUZ)
  1.  L +^TIU(8925,+DA):1
  1.  E  D  Q
  1.  . W !!?5,$C(7),"Another user is editing this entry.",! S TIUQUIT=2
  1.  . I $$READ^TIUU("FOA","Press RETURN to continue...") W ""
  1.  S ^TIU(8925,"ASAVE",DUZ,DA)=""
  1.  S DR=$$GETTMPL^TIUEDI1(+$P(^TIU(8925,+DA,0),U))
  1.  I DR']"" W !?5,$C(7),"No Edit template defined for ",$$PNAME^TIULC1(+$P(^TIU(8925,+DA,0),U)),! S TIUQUIT=2 Q
  1.  S DIE=8925 D ^DIE
  1.  I $D(Y)!($D(DTOUT)) S TIUQUIT=1
  1.  ;I +$G(TIUQUIT)>0,+$G(TIUNEW)>0 Q                  ;IHS/ITSC/LJF 02/26/2003
  1.  I +$G(TIUQUIT)>0,+$G(TIUNEW)>0 D DIEQ Q   ;IHS/ITSC/LJF 02/26/2003
  1.  D:+$G(TIUQUIT) UPDTIRT^TIUDIRT(.TIU,DA),SEND^TIUALRT(DA)
  1.  ;Q:+$G(TIUQUIT)            ;IHS/ITSC/LJF 02/26/2003
  1.  I +$G(TIUQUIT) D DIEQ Q    ;IHS/ITSC/LJF 02/26/2003
  1.  D TEXTEDIT(DA,.TIUCHNG)
  1.  ;I +$G(^TIU(8925,DA,0))'>0 S TIUQUIT=2 Q         ;IHS/ITSC/LJF 02/26/2003
  1.  I +$G(^TIU(8925,DA,0))'>0 S TIUQUIT=2 D DIEQ Q   ;IHS/ITSC/LJF 02/26/2003
  1.  S DR=".05///"_$$STATUS^TIULC(DA),DIE=8925 D ^DIE
  1.  D UPDTIRT^TIUDIRT(.TIU,DA),SEND^TIUALRT(DA)
  1. DIEQ ;IHS/ITSC/LJF 02/26/2003 added line label
  1.  L -^TIU(8925,+DA)
  1.  Q
  1. TEXTEDIT(DA,TIUCMMT,TIUCHNG) ; Call DIWE
  1.  N DIC,DIWE,DIWESUB,DIWPT,DR,DWHD,DWI,DWLC,DWLR,DWLW,DWO,DWPK,DDWRW
  1.  N TIUCKSM0,TIUCKSM1,TIUESNM,TIUESBLK
  1.  S TIUESNM=$$DECRYPT^TIULC1($P($G(^TIU(8925,DA,15)),U,3),1,$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEXT"")"))
  1.  S TIUESBLK=$$DECRYPT^TIULC1($P($G(^TIU(8925,DA,15)),U,4),1,$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEXT"")"))
  1.  W !!,"Calling text editor, please wait..." H 1
  1.  X:$L($G(TIUPRM3)) TIUPRM3
  1.  D BUFFER^TIUEDIU(DA) ; Load edit buffer to protect original from booboos
  1.  S TIUCKSM0=$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEMP"")")
  1.  I $D(^TIU(8925,+DA,"TEXT"))'>9 D LOADDFLT(DA,+$P(TIUTYP(1),U,2))
  1.  S DIWESUB="Patient: "_$G(TIU("PNM")),DIC="^TIU(8925,"_+DA_",""TEMP"","
  1.  I $G(VALMAR)="^TMP(""TIUVIEW"",$J)",(+$G(VALMBG)>5),(+$G(VALMBG)'>(+$P($G(^TIU(8925,+DA,"TEXT",0)),U,3)+4)) S DDWRW=+$G(VALMBG)-4
  1.  S DWPK=1,DWLW=74 D EN^DIWE
  1.  ; DELETE if NOSAVE
  1.  I +$G(NOSAVE) D DELETE^TIUEDIT(DA,0) S TIUQUIT=2 Q
  1.  ; Save edit buffer
  1.  S TIUCKSM1=$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEMP"")")
  1.  I TIUCKSM0'=TIUCKSM1 D  I 1
  1.  . D COMMIT^TIUEDIU(DA),AUDIT^TIUEDI1(DA,TIUCKSM0,TIUCKSM1)
  1.  . S TIUCHNG=1
  1.  . ; re-file /es/-block
  1.  . I $L(TIUESNM) D
  1.  . . S DR="1503///^S X=TIUESNM;1504///^S X=TIUESBLK",DIE=8925
  1.  . . D ^DIE
  1.  E  W !,"No changes made..." D COMMIT^TIUEDIU(DA,1) S TIUCHNG=0
  1.  S DIE=8925,DR=".1///"_$$LINECNT^TIULC(DA) D ^DIE
  1.  Q
  1.  ;
  1. LOADDFLT(DA,TIUTYP) ; Load bp text
  1.  N TIUI,TIUJ,TIUK,TIUL S TIUI=0
  1.  S TIUJ=+$P($G(^TIU(8925,+DA,"TEMP",0)),U,3)+1
  1.  ; - Set comp hdr -
  1.  S ^TIU(8925,+DA,"TEMP",TIUJ,0)=$S($P($G(^TIU(8925.1,+TIUTYP,0)),U,4)="CO":$P(^TIU(8925.1,+TIUTYP,0),U)_":   ",1:"")
  1.  I +TIUJ=1,($G(^TIU(8925,+DA,"TEMP",TIUJ,0))']"") K ^TIU(8925,+DA,"TEMP",TIUJ,0) S TIUJ=0
  1.  S ^TIU(8925,+DA,"TEMP",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
  1.  F  S TIUI=$O(^TIU(8925.1,+TIUTYP,"DFLT",TIUI)) Q:+TIUI'>0  D
  1.  . S TIUJ=TIUJ+1,X=$G(^TIU(8925.1,+TIUTYP,"DFLT",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,"^TIU(8925,"_+DA_",""TEMP"")",.TIUJ) I 1
  1.  . E  S ^TIU(8925,+DA,"TEMP",TIUJ,0)=X
  1.  . S ^TIU(8925,+DA,"TEMP",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
  1.  I +$O(^TIU(8925.1,+TIUTYP,10,0)) D
  1.  . N TIUFITEM,TIUI
  1.  . D ITEMS^TIUFLT(+TIUTYP)
  1.  . S TIUI=0 F  S TIUI=$O(TIUFITEM(TIUI)) Q:+TIUI'>0  D
  1.  . . S TIUL=+$G(TIUFITEM(+TIUI)) D LOADDFLT(DA,TIUL)
  1.  Q
  1. BOIL(LINE,COUNT) ; execute objects
  1.  N TIUI,DIC,X,Y,TIUFPRIV S TIUFPRIV=1
  1.  NEW DA   ;IHS/ITSC/LJF 01/12/2005 can kill DA which INSMULT needs
  1.  N TIUOLDR,TIUNEWR,TIUOLDG,TIUNEWG
  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.  . . . . 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.  . . . . M @TIUNEWG=@TIUOLDG
  1.  . . . . S $P(X,"~@",2)=TIUNEWG
  1.  . S LINE=$$REPLACE(LINE,X,TIUI)
  1.  Q $TR(LINE,"|","")
  1. CANXEC(TIUODA) ; Eval Obj 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. REPLACE(LINE,X,TIUI) ; Replace TIUIth object in LINE
  1.  S $P(LINE,"|",TIUI)=X
  1.  Q LINE
  1. INSMULT(LINE,TARGET,TIULCNT) ; Mult-valued results
  1.  N TIUPC
  1.  F TIUPC=2:2:$L(LINE,"~@") D
  1.  . N TIUI,TIULINE,TIUX,TIUSRC,TIUSCNT,TIUTAIL
  1.  . S TIUSRC=$P(LINE,"~@",TIUPC)
  1.  . S TIUSRC=$TR(TIUSRC," ","")  ;IHS/ITSC/LJF 02/26/2003 PATCH 1001 remove space at end of global ref
  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)>73) 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)'>73) 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. APPEND(X) ;
  1.  N TIUXL S TIUXL=$L(X)
  1.  I $E(X,TIUXL-1,TIUXL)'="~@" S X=X_"~@"
  1.  Q X