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

TIULC1.m

Go to the documentation of this file. 
  1. TIULC1 ; SLC/JER - More computational functions ;11/01/03
  1.  ;;1.0;TEXT INTEGRATION UTILITIES;**3,4,40,49,100,131,113,112**;Jun 20, 1997
  1.  ; External References
  1.  ; DBIA 2324  $$ISA^USRLM
  1.  ; Any patch which makes ANY changes to this rtn must include a
  1.  ;note in the patch desc reminding sites to update the Imaging
  1.  ;Gateway.  See IA # 3622.
  1.  ; IN ADDITION, if changes are made to components used by Imaging, 
  1.  ;namely PNAME, backward compatibility may not be enough. If
  1.  ;changes call additional rtns, TIU should consult with Imaging
  1.  ;on need to add additional rtns to list of TIU rtns copied for
  1.  ;Imaging Gateway.
  1.  ;                         ****
  1.  ;
  1. ENCRYPT(X,X1,X2) ; Encrypt Text Strings
  1.  D EN^XUSHSHP
  1.  Q X
  1. DECRYPT(X,X1,X2) ; Decrypt Text Strings
  1.  D DE^XUSHSHP
  1.  Q X
  1. WHOSIGNS(DA) ; Evaluate who should be the expected signer
  1.  N Y,TIU12
  1.  S TIU12=$G(^TIU(8925,+DA,12))
  1.  I $P(TIU12,U,2)'=$P(TIU12,U,9) S Y=$P(TIU12,U,2)
  1.  E  S Y=$P(TIU12,U,9)
  1.  Q Y
  1. WHOCOSIG(DA) ; Evaluate who should be the expected cosigner
  1.  N Y,TIU12
  1.  S TIU12=$G(^TIU(8925,+DA,12))
  1.  I $P(TIU12,U,2)=$P(TIU12,U,9) D
  1.  . I $P(TIU12,U,8)]"" S Y="@"
  1.  . E  S Y=""
  1.  E  S Y=$P(TIU12,U,9)
  1.  Q Y
  1.  ;
  1. HASADDEN(DA,IDKIDFLG) ; Evaluate whether a given record has addenda
  1.  ; **100**:
  1.  ; If +IDKIDFLG, check interdisciplinary kids of DA, as well as DA.
  1.  N TIUI,TIUY,TIUJ,TIUK
  1.  S (TIUI,TIUJ,TIUY)=0
  1.  F  S TIUI=$O(^TIU(8925,"DAD",+DA,TIUI)) Q:+TIUI'>0  D  Q:TIUY
  1.  . I $P($G(^TIU(8925.1,+$G(^TIU(8925,+TIUI,0)),0)),U)["ADDENDUM" S TIUY=1
  1.  I TIUY!'$G(IDKIDFLG) G HASX
  1.  ;**100** Check ID kids for addenda:
  1.  F  S TIUJ=$O(^TIU(8925,"GDAD",+DA,TIUJ)) Q:+TIUJ'>0  D  Q:TIUY
  1.  . S TIUK=0
  1.  . F  S TIUK=$O(^TIU(8925,"DAD",TIUJ,TIUK)) Q:+TIUK'>0  D  Q:TIUY
  1.  . . I $P($G(^TIU(8925.1,+$G(^TIU(8925,+TIUK,0)),0)),U)["ADDENDUM" S TIUY=1
  1. HASX Q TIUY
  1.  ;
  1. ISADDNDM(DA) ; Evaluate whether a given record IS an addendum
  1.  N TIUY S TIUY=0
  1.  I $P($G(^TIU(8925.1,+$G(^TIU(8925,+DA,0)),0)),U)["ADDENDUM",+$P($G(^TIU(8925,+DA,0)),U,6)>0 S TIUY=1
  1.  Q TIUY
  1. PNAME(DA) ; Receives pointer to 8925.1, returns display name of
  1.  ; document class
  1.  N TIUY,TIUMOM S TIUMOM=0
  1.  I +$G(DA)'>0 Q "UNKNOWN"
  1.  S TIUMOM=$O(^TIU(8925.1,"AD",DA,TIUMOM))
  1.  I $P($G(^TIU(8925.1,+DA,0)),U,4)="CO" S TIUMOM=0
  1.  I +$P($G(^TIU(8925.1,+DA,0)),U,9)=0 S TIUMOM=0
  1.  I +TIUMOM>0  D
  1.  . S TIUY=$P($G(^TIU(8925.1,+TIUMOM,0)),U,3)
  1.  . I TIUY']"" S TIUY=$$MIXED^TIULS($P($G(^TIU(8925.1,+TIUMOM,0)),U))
  1.  I +TIUMOM'>0 D
  1.  . S TIUY=$P($G(^TIU(8925.1,+DA,0)),U,3)
  1.  . I TIUY']"" S TIUY=$$MIXED^TIULS($P($G(^TIU(8925.1,+DA,0)),U))
  1.  Q TIUY
  1. ABBREV(DA) ; Get abbreviaton for a document type or class
  1.  Q $P($G(^TIU(8925.1,+DA,0)),U,2)
  1. PERSNAME(USER) ; Receives pointer to 200, returns name field
  1.  N X S X=$$GET1^DIQ(200,USER,.01)
  1.  Q $S($L(X):X,1:"UNKNOWN")
  1. BEEP(USER) ; Get beeper #'s 
  1.  Q $P($G(^VA(200,+USER,.13)),U,7,8)
  1. DOCPRM(TIUTYP,TIUDPRM,TIUDA) ; Get Document Parameters, support inheritance
  1.  N TIUI,TIUDAD
  1.  S (TIUDPRM(0),TIUDPRM(5))=""
  1.  I $P($G(^TIU(8925.1,+TIUTYP,0)),U)["ADDENDUM",+$G(TIUDA) S TIUTYP=+$G(^TIU(8925,+$P($G(^TIU(8925,+TIUDA,0)),U,6),0))
  1.  S TIUI=+$O(^TIU(8925.95,"B",+TIUTYP,0))
  1.  I +TIUI D  Q
  1.  . S TIUDPRM(0)=$G(^TIU(8925.95,+TIUI,0))
  1.  . I +$O(^TIU(8925.95,+TIUI,5,0)) D
  1.  . . N TIUJ S TIUJ=0
  1.  . . F  S TIUJ=$O(^TIU(8925.95,+TIUI,5,TIUJ)) Q:+TIUJ'>0  D
  1.  . . . S $P(TIUDPRM(5),U,TIUJ)=+$G(^TIU(8925.95,+TIUI,5,+TIUJ,0))
  1.  S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
  1.  I +TIUDAD D DOCPRM(TIUDAD,.TIUDPRM)
  1.  Q
  1. POSTFILE(TIUTYP) ; Get Post-filing Code, support inheritance
  1.  N TIUPOST,TIUDAD
  1.  S TIUPOST=$G(^TIU(8925.1,+TIUTYP,4.5))
  1.  I TIUPOST]"" G POSTFILX
  1.  S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
  1.  I +TIUDAD S TIUPOST=$$POSTFILE(TIUDAD)
  1. POSTFILX Q TIUPOST
  1. FIXCODE(TIUTYP) ; Get Error Resolution Code, support inheritance
  1.  N TIUFIX,TIUDAD
  1.  S TIUFIX=$G(^TIU(8925.1,+TIUTYP,4.8))
  1.  I TIUFIX]"" G FIXCODX
  1.  S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
  1.  ; Don't inherit PN code for consults: TIU*1*131
  1.  I +TIUTYP=$$CLASS^TIUCNSLT,TIUDAD=3 G FIXCODX
  1.  I +TIUDAD S TIUFIX=$$FIXCODE(TIUDAD)
  1. FIXCODX Q TIUFIX
  1. DOCCLASS(TIUTYP) ; Given a document type, find its parent document class
  1.  Q +$O(^TIU(8925.1,"AD",+TIUTYP,0))
  1. CLINDOC(TIUTYP,TIUDA) ; Given a document type, find the Clinical Document
  1.  ;                 subclass to which it belongs
  1.  N TIUI,TIUY S (TIUI,TIUY)=0
  1.  I +$G(TIUDA),+$$ISADDNDM(TIUDA) S TIUTYP=+$G(^TIU(8925,+$P($G(^TIU(8925,+TIUDA,0)),U,6),0))
  1.  S TIUI=$O(^TIU(8925.1,"AD",+TIUTYP,TIUI))
  1.  I +TIUI'>0 G CLINDOX
  1.  I TIUI=38 S TIUY=TIUTYP
  1.  I TIUI'=38 S TIUY=$$CLINDOC(TIUI)
  1. CLINDOX Q TIUY
  1. REQVER(TIUTYP,TIUDA) ; Does a given document type require verification
  1.  N TIUDPRM,TIUY
  1.  I +$G(TIUDA),+$$ISADDNDM(TIUDA) S TIUTYP=+$G(^TIU(8925,+$P($G(^TIU(8925,+TIUDA,0)),U,6),0))
  1.  D DOCPRM(TIUTYP,.TIUDPRM)
  1.  I +$P($G(TIUDPRM(0)),U,3) S TIUY=1
  1.  Q +$G(TIUY)
  1. REFDATE(TIU,TIUDICDT) ; Identify Reference date
  1.  N TIURDT
  1.  I +$G(TIU("LDT")) S TIURDT=+$G(TIU("LDT"))_"^0"
  1.  I +$G(TIU("LDT"))'>0 D
  1.  . S TIURDT=$S(+$G(TIUDICDT):+$G(TIUDICDT),1:+$$NOW^TIULC)_"^1"
  1.  . S TIU("LDT")=TIURDT_U_$$DATE^TIULS(TIURDT,"AMTH DD, CCYY@HR:MIN:SEC")
  1.  Q TIURDT
  1. WHATMPL(USER) ; What List Template should a given user get?
  1.  N TIUY
  1.  I +$$ISA^USRLM(USER,"PROVIDER") S TIUY="TIU BROWSE FOR CLINICIAN" G WHAX
  1.  I +$$ISA^USRLM(USER,"MEDICAL RECORDS TECHNICIAN") S TIUY="TIU BROWSE FOR MRT" G WHAX
  1.  I +$$ISA^USRLM(USER,"CHIEF, MIS") S TIUY="TIU BROWSE FOR MGR" G WHAX
  1.  I +$$ISA^USRLM(USER,"MEDICAL STUDENT") S TIUY="TIU BROWSE FOR CLINICIAN" G WHAX
  1.  S TIUY="TIU BROWSE FOR READ ONLY"
  1. WHAX Q TIUY
  1. SUPPVSIT(TIUTYP) ; Evaluate whether to suppress visit matching
  1.  N TIUI,TIUY S TIUY=0
  1.  I +$P($G(^TIU(8925.1,+TIUTYP,3)),U,3) S TIUY=1 G SUPPVSIX
  1.  I $L($P($G(^TIU(8925.1,+TIUTYP,3)),U,3)),($P($G(^(3)),U,3)=0) S TIUY=0 G SUPPVSIX ; ** SLC/JER - NOIS NYC-1298-11472
  1.  S TIUI=0 F  S TIUI=$O(^TIU(8925.1,"AD",+TIUTYP,TIUI)) Q:+TIUI'>0!(+TIUY>0)  D
  1.  . S TIUY=+$$SUPPVSIT(+TIUI)
  1. SUPPVSIX Q TIUY
  1. PTNAME(DFN) ; Resolve Patient Name
  1.  N TIUY S TIUY=$P($G(^DPT(DFN,0)),U)
  1.  S:TIUY']"" TIUY="NAME UNKNOWN"
  1.  Q TIUY
  1. POSTSIGN(TIUTYP) ; Get Post-Signature Code, support inheritance
  1.  N TIUPOST,TIUDAD
  1.  S TIUPOST=$G(^TIU(8925.1,+TIUTYP,4.9))
  1.  I TIUPOST]"" G POSTSIGX
  1.  S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
  1.  I +TIUDAD S TIUPOST=$$POSTSIGN(TIUDAD)
  1. POSTSIGX Q TIUPOST
  1. COMMIT(TIUTYP) ; Get Commitment action, support inheritance
  1.  N TIUCOMM,TIUDAD
  1.  S TIUCOMM=$G(^TIU(8925.1,+TIUTYP,4.1))
  1.  I TIUCOMM]"" G COMMITX
  1.  S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
  1.  I +TIUDAD S TIUCOMM=$$COMMIT(TIUDAD)
  1. COMMITX Q TIUCOMM
  1. RELEASE(TIUTYP) ; Get Release Action, support inheritance
  1.  N TIUREL,TIUDAD
  1.  S TIUREL=$G(^TIU(8925.1,+TIUTYP,4.2))
  1.  I TIUREL]"" G RELEASX
  1.  S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
  1.  I +TIUDAD S TIUREL=$$RELEASE(TIUDAD)
  1. RELEASX Q TIUREL
  1. VERIFY(TIUTYP) ; Get Verification action, support inheritance
  1.  N TIUVER,TIUDAD
  1.  S TIUVER=$G(^TIU(8925.1,+TIUTYP,4.3))
  1.  I TIUVER]"" G VERIFYX
  1.  S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
  1.  I +TIUDAD S TIUVER=$$VERIFY(TIUDAD)
  1. VERIFYX Q TIUVER
  1. DELETE(TIUTYP) ; Get Delete Action, support inheritance
  1.  N TIUDEL,TIUDAD
  1.  S TIUDEL=$G(^TIU(8925.1,+TIUTYP,4.4))
  1.  I TIUDEL]"" G DELETEX
  1.  S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
  1.  I +TIUDAD S TIUDEL=$$DELETE(TIUDAD)
  1. DELETEX Q TIUDEL
  1. REASSIGN(TIUTYP) ; Get Package Reassign Action, support inheritance
  1.  N TIUREASS,TIUDAD
  1.  S TIUREASS=$G(^TIU(8925.1,+TIUTYP,4.45))
  1.  I TIUREASS]"" G REASSIX
  1.  S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
  1.  I +TIUDAD S TIUREASS=$$REASSIGN(TIUDAD)
  1. REASSIX Q TIUREASS
  1. ONBROWSE(TIUTYP)        ; Get OnBrowse Event, support inheritance
  1.  N TIUBRWS,TIUDAD
  1.  S TIUBRWS=$G(^TIU(8925.1,+TIUTYP,6.5))
  1.  I TIUBRWS]"" G ONBRWSX
  1.  S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
  1.  I +TIUDAD S TIUBRWS=$$ONBROWSE(TIUDAD)
  1. ONBRWSX Q TIUBRWS
  1. ONRTRCT(TIUTYP) ; Get OnRetract Event, support inheritance
  1.  N TIURTRCT,TIUDAD
  1.  S TIURTRCT=$G(^TIU(8925.1,+TIUTYP,6.51))
  1.  I TIURTRCT]"" G ONRTRX
  1.  S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
  1.  I +TIUDAD S TIURTRCT=$$ONRTRCT(TIUDAD)
  1. ONRTRX Q TIURTRCT
  1. DIVISION(TIULOC) ; Get Division
  1.  ; Input  -- TIULOC  HOSPITAL LOCATION file (#44) IEN
  1.  ; Output -- TIUIN   INSTITUTION file (#4) IEN^
  1.  ;                   INSTITUTION file (#4) NAME
  1.  N TIUDVHL,TIUSTN,TIUIN
  1.  S TIUDVHL=$P($G(^SC(+TIULOC,0)),U,15)
  1.  I +TIUDVHL D
  1.  . S TIUSTN=$$SITE^VASITE(,TIUDVHL)
  1.  . I $P(TIUSTN,U)>0,($P(TIUSTN,U,2)]"") D
  1.  . . S TIUIN=$P(TIUSTN,U)_U_$P(TIUSTN,U,2)
  1.  I '$G(TIUIN) D
  1.  . S TIUIN=+$G(DUZ(2))_U_$P($$NS^XUAF4(+$G(DUZ(2))),U)
  1.  Q TIUIN