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

TIURECL1.m

Go to the documentation of this file.
  1. TIURECL1 ; SLC/PKR,JER - Expand/collapse LM views ;5/8/03
  1. ;;1.0;TEXT INTEGRATION UTILITIES;**100,113**;Jun 20, 1997
  1. ; 7/6 Split TIURECL into TIURECL & TIURECL1, move RESOLVE to TIURECL1
  1. ; 7/10 Move INSID, INSADD, VEXREQ, ISSUB to TIURECL1
  1. ; 9/7 Move INSKIDS, INSADD, & associated modules to TIURECL2
  1. ;=======================================================================
  1. ISSUB(CLASS1,CLASS2,LEVEL) ;Return true if CLASS2 is sub to CLASS1.
  1. N IND,ISSUB
  1. I LEVEL(CLASS1)'<LEVEL(CLASS2) Q 0
  1. ;Check sublevel links between class1 and class2
  1. S ISSUB=1
  1. F IND=(CLASS1+1):1:(CLASS2-1) D
  1. . I LEVEL(IND)=1 D Q
  1. .. S ISSUB=0
  1. Q ISSUB
  1. ;
  1. ;======================================================================
  1. VEXREQ(VALMY) ;Check for valid expand/contract requests.
  1. ; A list of documents to expand/contract is invalid if any docmt
  1. ;is a sub docmt of another docmt on the list.
  1. N END,START
  1. S START=$O(VALMY(""))
  1. S END=$O(VALMY(""),-1)
  1. I START=END Q 1
  1. ;
  1. N ACTION,ACTIND,ACTJND,CIND,CN,IND,JND,LEVEL,MSG,TEXT,VALID
  1. ;Build the level list.
  1. F IND=START:1:END D
  1. . S LEVEL(IND)=$L(@VALMAR@(IND,0),"|")
  1. S VALID=1
  1. S IND=""
  1. F S IND=$O(VALMY(IND)) Q:+IND'>0 D
  1. . S TEXT(IND)=$G(@VALMAR@(IND,0))
  1. . S ACTIND=$S(TEXT(IND)["+":"+ ",TEXT(IND)["-":"-",1:"")
  1. . I ACTIND="" Q
  1. . S ACTION(IND)=$S(TEXT(IND)["+":"expand ",TEXT(IND)["-":"collapse ",1:"")
  1. . S JND=IND
  1. . F S JND=$O(VALMY(JND)) Q:+JND'>0 D
  1. .. S TEXT(JND)=$G(@VALMAR@(JND,0))
  1. .. S ACTJND=$S(TEXT(JND)["+":"+",TEXT(JND)["-":"-",1:"")
  1. .. I ACTJND="" Q
  1. .. S ACTION(JND)=$S(TEXT(JND)["+":"expand ",TEXT(JND)["-":"collapse ",1:"")
  1. .. I $$ISSUB(IND,JND,.LEVEL) D
  1. ... I ACTION(IND)'=ACTION(JND) D Q
  1. .... S CIND(IND)=$P(^TMP("TIURIDX",$J,IND),U,2)
  1. .... S CN(IND)=$P(^TIU(8925,CIND(IND),0),U,1)
  1. .... S CIND(JND)=$P(^TMP("TIURIDX",$J,JND),U,2)
  1. .... S CN(JND)=$P(^TIU(8925,CIND(JND),0),U,1)
  1. .... I '+$G(HUSH) D
  1. ..... S MSG="You cannot "_ACTION(IND)_CN(IND)_" and "_ACTION(JND)_CN(JND)
  1. ..... D MSG^VALM10(MSG)
  1. ..... H 4
  1. .... S VALID=0
  1. Q VALID
  1. ;======================================================================
  1. IDDATA(TIUDA,TIUD0,TIUD21) ; Return TIUGDATA:
  1. ; TIUGDATA = 0 or
  1. ; = TIUDA^haskid^IDparent^prmsort, where
  1. ; TIUDA = note DA
  1. ; haskid = 1 if note has ID kid, else 0
  1. ; IDparent = parent DA if note has ID parent, else 0
  1. ; prmsort = 'TITLE' if entries ordered by title, else 'REFDT'
  1. ;Note: TIUGDATA is nonzero if note is POSSIBLE DAD, or dad, or kid.
  1. ; Requires TIUDA; TIUD0 & TIUD21 are optional
  1. N HASIDKID,POSSPRNT,TIUDPRM,PRMSORT,TIUGDATA
  1. I '$G(TIUD0) S TIUD0=^TIU(8925,TIUDA,0)
  1. I '$D(TIUD21) S TIUD21=+$G(^TIU(8925,TIUDA,21))
  1. S (TIUGDATA,POSSPRNT)=0
  1. S HASIDKID=$$HASIDKID^TIUGBR(TIUDA)
  1. I 'TIUD21,'HASIDKID S POSSPRNT=$$POSSPRNT^TIULP(+TIUD0) ;has bus rules
  1. I TIUD21!HASIDKID!POSSPRNT D
  1. . I 'TIUD21 D I 1
  1. . . D DOCPRM^TIULC1(+TIUD0,.TIUDPRM)
  1. . . S PRMSORT=$S($P($G(TIUDPRM(0)),U,18):"TITLE",1:"REFDT")
  1. . E S PRMSORT=""
  1. . S TIUGDATA=TIUDA_U_HASIDKID_U_TIUD21_U_PRMSORT
  1. Q TIUGDATA
  1. ;
  1. RESOLVE(DA,TSTART,FIRSTPFX,XIDDATA) ; Get document data for insertion
  1. ; Receives DA, TSTART, FIRSTPFX
  1. ; FIRSTPFX = $$INSPFIX of parent of inserted document.
  1. ; Returns line TSTART.
  1. ; Receives XIDDATA by ref, finds it, and passes it back.
  1. N DIC,DIQ,DR,TIUR,PT,MOM,ADT,DDT,LCT,AUT,AMD,EDT,SDT,XDT,RMD,TIULST4
  1. N TIUP,TIUD0,TIUD12,TIUD13,TIUD15,TIULI,STATX,DOC,TIUY,TIUI,TIUFLDS
  1. N PREFIX,GETTL,GETPT,TIUD21,INSTA,TIUSTN
  1. I '$D(^TIU(8925,DA,0)) S TIUY="Record #"_DA_" is missing." G RESOLVEX
  1. S TIUD0=$G(^TIU(8925,+DA,0)),TIUD12=$G(^TIU(8925,+DA,12))
  1. S TIUD13=$G(^TIU(8925,+DA,13)),TIUD15=$G(^TIU(8925,+DA,15))
  1. S TIUD21=$G(^TIU(8925,+DA,21))
  1. S XIDDATA=$$IDDATA(DA,TIUD0,TIUD21)
  1. S PREFIX=$$PREFIX^TIULA2(DA),PREFIX=FIRSTPFX_PREFIX
  1. S GETTL=$$GETTL(TIUD0,PREFIX)
  1. ; Most screens have docmt title in 1st column, but some have pat nm:
  1. S DOC=$S($D(VALMDDF("PATIENT NAME")):$P(GETTL,U),1:$P(GETTL,U,2)_$P(GETTL,U))
  1. S TIUFLDS("DOCUMENT TYPE")="DOC"
  1. S TIUFLDS("TITLE")="DOC"
  1. S GETPT=$$GETPT(TIUD0,PREFIX)
  1. S TIULI=$E(GETPT)
  1. S PT=$P(GETPT,U,2)_$P(GETPT,U)
  1. S TIUFLDS("PATIENT NAME")="PT"
  1. S TIULST4=$E($P($G(^DPT(+$P(TIUD0,U,2),0)),U,9),6,9)
  1. S TIULST4="("_TIULI_TIULST4_")"
  1. S TIUFLDS("LAST I/LAST 4")="TIULST4"
  1. S ADT=$$DATE^TIULS($P(TIUD0,U,7),"MM/DD/YY")
  1. S TIUFLDS("ADMISSION DATE")="ADT"
  1. S DDT=$$DATE^TIULS($P(TIUD0,U,8),"MM/DD/YY"),LCT=$P(TIUD0,U,10)
  1. S TIUFLDS("DISCH DATE")="DDT"
  1. S TIUFLDS("LINE COUNT")="AMD"
  1. S AMD=$$PERSNAME^TIULC1($P(TIUD12,U,8)) S:AMD="UNKNOWN" AMD=""
  1. S AUT=$$PERSNAME^TIULC1($P(TIUD12,U,2)) S:AUT="UNKNOWN" AUT=""
  1. S AMD=$$NAME^TIULS(AMD,"LAST, FI MI")
  1. S TIUFLDS("ATTENDING")="AMD"
  1. S TIUFLDS("COSIGNER")="AMD"
  1. I $D(^TMP("TIUR",$J,"CTXT")) S AUT=$$NAME^TIULS(AUT,"LAST,FI") I 1
  1. E S AUT=$$NAME^TIULS(AUT,"LAST, FI MI")
  1. S TIUFLDS("AUTHOR")="AUT"
  1. I $D(^TMP("TIUR",$J,"CTXT")) S EDT=$$DATE^TIULS($P(TIUD13,U),"MM/DD/YY HR:MIN") I 1
  1. E S EDT=$$DATE^TIULS($P(TIUD13,U),"MM/DD/YY")
  1. S TIUFLDS("REF DATE")="EDT"
  1. S XDT=$$DATE^TIULS($P(TIUD13,U,7),"MM/DD/YY")
  1. S TIUFLDS("DICT DATE")="XDT"
  1. S SDT=$S(+$P(TIUD15,U,7):+$P(TIUD15,U,7),+$P(TIUD0,U,5)'<7:+$P(TIUD15,U),1:"")
  1. S SDT=$$DATE^TIULS(SDT,"MM/DD/YY")
  1. S TIUFLDS("SIG DATE")="SDT"
  1. S STATX=$$LOW^XLFSTR($P($G(^TIU(8925.6,+$P(TIUD0,U,5),0)),U))
  1. S TIUFLDS("STATUS")="STATX"
  1. S INSTA=""
  1. I +$P(TIUD12,U,12)>0 D
  1. . S TIUSTN=$$NS^XUAF4($P(TIUD12,U,12))
  1. . I $P(TIUSTN,U,2)]"" S INSTA=$P(TIUSTN,U,2)
  1. S INSTA=$E(INSTA,1,8)
  1. S TIUFLDS("DIVISION")="INSTA"
  1. S (TIUI,TIUY)=""
  1. S TIUY=$$SETFLD^VALM1(TSTART,TIUY,"NUMBER")
  1. F S TIUI=$O(TIUFLDS(TIUI)) Q:TIUI="" D
  1. . S:$D(VALMDDF(TIUI)) TIUY=$$SETFLD^VALM1(@TIUFLDS(TIUI),TIUY,TIUI)
  1. RESOLVEX Q TIUY
  1. ;
  1. GETPT(TIUD0,PREFIX) ; Get patient column data; put updated prefix data
  1. ;in second ^ piece
  1. ; Receives TIUDO, PREFIX.
  1. ; Returns (patient col data)^PREFIX
  1. N TIUY
  1. S TIUY=$$NAME^TIULS($$PTNAME^TIULC1($P(TIUD0,U,2)),"LAST,FI MI")
  1. I $D(PREFIX) S TIUY=TIUY_U_PREFIX
  1. Q TIUY
  1. ;
  1. GETTL(TIUD0,PREFIX) ; Get title column data; put updated prefix
  1. ;data in second ^ piece.
  1. ; Receives TIUDO, PREFIX.
  1. ; Returns (title col data)^PREFIX
  1. N TIUY
  1. S TIUY=$$PNAME^TIULC1(+TIUD0)
  1. I TIUY="Addendum" S TIUY="Addendum to "_$$PNAME^TIULC1(+$G(^TIU(8925,+$P(TIUD0,U,6),0)))
  1. I $D(PREFIX) S TIUY=TIUY_U_PREFIX
  1. Q TIUY
  1. ;
  1. SETTLPT(STRING,DA,PREFIX) ; Set field TITLE or PATIENT into string,
  1. ;with prefix as first chars of string.
  1. ; Receives STRING, DA, PREFIX:
  1. ; PREFIX = beginning chars of title/pt column, up to but not
  1. ; including title/pt itself.
  1. ; Returns STRING.
  1. N PT,DOC,TIUD0
  1. S TIUD0=^TIU(8925,DA,0)
  1. I $D(VALMDDF("PATIENT NAME")) D I 1
  1. . S PT=$$GETPT(TIUD0,PREFIX)
  1. . S PT=$P(PT,U,2)_$P(PT,U)
  1. . S STRING=$$SETFLD^VALM1(PT,STRING,"PATIENT NAME")
  1. E D
  1. . S DOC=$$GETTL(TIUD0,PREFIX)
  1. . S DOC=$P(DOC,U,2)_$P(DOC,U)
  1. . S STRING=$$SETFLD^VALM1(DOC,STRING,"TITLE")
  1. Q STRING