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

TIURM1.m

Go to the documentation of this file. 
  1. TIURM1 ; SLC/JER - MIS Document Review ; 8/23/12 1:27pm
  1.  ;;1.0;TEXT INTEGRATION UTILITIES;**100,113,271,288**;Jun 20, 1997;Build 4
  1.  ;Per VHA Directive 2004-038, this routine should not be modified
  1. GATHER(TIUPREF,CLASS,STATIFNS,EARLY,LATE,DIVIFNS) ; Find/sort
  1.  ;records for the list
  1.  N TIUDA,TIUSFLD,TIUI,TIUQ
  1.  S TIUSFLD=$P(TIUPREF,U,3)
  1.  S TIUSFLD=$S(TIUSFLD="P":".02",TIUSFLD="D":".01",TIUSFLD="S":".05",TIUSFLD="C":"1507",TIUSFLD="A":"1202",TIUSFLD="E":"1208",1:"1301")
  1.  S TIUI=EARLY F  S TIUI=$O(^TIU(8925,"F",TIUI)) Q:+TIUI'>0!(+TIUI>LATE)  D
  1.  . S TIUDA=0
  1.  . F  S TIUDA=$O(^TIU(8925,"F",TIUI,TIUDA)) Q:+TIUDA'>0  D
  1.  . . ; Consider adding view check here
  1.  . . I '$$INTYPES(TIUDA) Q
  1.  . . I '$$INSTATUS(TIUDA,STATIFNS) Q
  1.  . . I +$G(DIVIFNS("ENTRIES")),'$$ININST(TIUDA,.DIVIFNS) Q
  1.  . . S TIUQ=$$RESOLVE^TIUR1(TIUDA,TIUSFLD)
  1.  . . S ^TMP("TIUI",$J,TIUQ,(9999999-TIUI),TIUDA)=""
  1.  Q
  1.  ;
  1. INTYPES(TIUDA) ; Evaluates whether a record is among the selected types
  1.  N TIUI,TIUTYP,TIUY,TIUPICKS,TIUDTYP
  1.  ; *288 set selected types into TIUPICKS array
  1.  S TIUI=0 F  S TIUI=$O(^TMP("TIUTYP",$J,TIUI)) Q:+TIUI'>0  D
  1.  . S TIUY=$P(^TMP("TIUTYP",$J,TIUI),U,2)
  1.  . ;OMIT addendum if it was NOT PICKED
  1.  . Q:TIUY=81&($P(^TMP("TIUTYP",$J,TIUI),U,4)="NOT PICKED")
  1.  . S:TIUY TIUPICKS(TIUY)=1
  1.  S TIUTYP=+$G(^TIU(8925,+TIUDA,0)),TIUDTYP=0
  1.  ; look for parent type when addendum is not picked 
  1.  I '+$G(TIUPICKS(81))&TIUTYP=81 S TIUDTYP=+$G(^TIU(8925,+$P($G(^TIU(8925,+TIUDA,0)),U,6),0))
  1.  S TIUY=$S(TIUDTYP:+$G(TIUPICKS(TIUDTYP)),1:+$G(TIUPICKS(TIUTYP)))
  1.  Q TIUY
  1.  ;
  1. INSTATUS(TIUDA,STATIFNS) ; Evaluates whether a record
  1.  ;is among the selected statuses
  1.  N TIUS,TIUSTAT,TIUSTATE,TIUY S TIUY=0
  1.  S TIUSTATE=+$P($G(^TIU(8925,+TIUDA,0)),U,5)
  1.  S TIUS=1 F  S TIUSTAT=$P(STATIFNS,";",TIUS) Q:'TIUSTAT!TIUY  D
  1.  . S TIUS=TIUS+1
  1.  . I TIUSTAT=TIUSTATE S TIUY=1
  1.  Q TIUY
  1. ININST(TIUDA,TIUDI) ; Evaluates whether a TIU DOCUMENT record
  1.  ; is among the selected divisions
  1.  ; Input -- TIUDA    TIU DOCUMENT file (#8925) IEN
  1.  ;       -- TIUDI(   i.e. TIUDI(file #40.8 IEN)=Institution file
  1.  ;                                           pointer for file #40.8 entry
  1.  ; Output - TIUY     0= record not in selected division
  1.  ;                   1= record in selected division
  1.  N TIUIFP,TIUI,TIUINST,TIUY S TIUY=0
  1.  S TIUINST=+$P($G(^TIU(8925,+TIUDA,12)),U,12)
  1.  S TIUI=0 F  S TIUI=$O(TIUDI(TIUI)) Q:'TIUI!TIUY  D
  1.  . S TIUIFP=$G(TIUDI(TIUI))
  1.  . I TIUIFP=TIUINST S TIUY=1
  1.  Q TIUY
  1.  ;
  1. PUTLIST(TIUPREF,TIUCLASS,STATUS,DIVIFNS) ; Expands list elements for LM Template
  1.  N TIUJ,TIUQ,TIUDA,TIUPICK,TIUORDER,TIUEXPKD,TIUSFLD
  1.  S VALMCNT=0
  1.  S TIUSFLD=$P(TIUPREF,U,3)
  1.  S TIUSFLD=$S(TIUSFLD="P":".02",TIUSFLD="D":".01",TIUSFLD="S":".05",TIUSFLD="C":"1507",TIUSFLD="A":"1202",TIUSFLD="E":"1208",1:"1301")
  1.  S TIUORDER=$S($P(TIUPREF,U,4)="A":1,1:-1)
  1.  S TIUPICK=+$O(^ORD(101,"B","TIU ACTION SELECT LIST ELEMENT",0))
  1.  S TIUQ="" F  S TIUQ=$O(^TMP("TIUI",$J,TIUQ)) Q:TIUQ']""  D
  1.  . S TIUJ=0 F  S TIUJ=$O(^TMP("TIUI",$J,TIUQ,TIUJ)) Q:+TIUJ'>0  D
  1.  . . S TIUDA=0
  1.  . . F  S TIUDA=$O(^TMP("TIUI",$J,TIUQ,TIUJ,TIUDA)) Q:'TIUDA  D
  1.  . . . D REPLACE^TIUR2(TIUDA,TIUQ,TIUSFLD,TIUJ,.TIUEXPKD)
  1.  D SETLIST(TIUORDER,.VALMCNT)
  1.  S ^TMP("TIUR",$J,0)=+$G(VALMCNT)_U_STATUS("WORDS")
  1.  S ^TMP("TIUR",$J,"CLASS")=TIUCLASS
  1.  S ^TMP("TIUR",$J,"#")=TIUPICK_"^1:"_+$G(VALMCNT)
  1.  M ^TMP("TIUR",$J,"DIV")=DIVIFNS
  1.  I $D(VALMHDR)>9 D HDR^TIURMH
  1.  I +$G(VALMCNT)'>0 D
  1.  . S ^TMP("TIUR",$J,1,0)="",VALMCNT=2
  1.  . S ^TMP("TIUR",$J,2,0)="     No records found to satisfy search criteria."
  1.  . S ^TMP("TIUR",$J,"IDX",1,0)="" ; User can't select lines 1 or 2
  1.  . S ^TMP("TIUR",$J,"IDX",2,0)=""
  1.  ; -- Expand to show kids that fit:
  1.  I '$G(TIURBLD),$D(TIUEXPKD) D EXPANDKD^TIUR2(.STATUS,.TIUEXPKD)
  1.  Q
  1. SETLIST(TIUORDER,VALMCNT) ; Set items from ^TMP("TIUI",$J) into
  1.  ;List Template list
  1.  N SORTVAL,TIUDTM,TIUDA
  1.  S SORTVAL=""
  1.  F  S SORTVAL=$O(^TMP("TIUI",$J,SORTVAL),TIUORDER) Q:SORTVAL=""  D
  1.  . S TIUDTM=0
  1.  . F  S TIUDTM=$O(^TMP("TIUI",$J,SORTVAL,TIUDTM)) Q:'TIUDTM  D
  1.  . . S TIUDA=0
  1.  . . F  S TIUDA=$O(^TMP("TIUI",$J,SORTVAL,TIUDTM,TIUDA)) Q:'TIUDA  D
  1.  . . . D ADDELMNT(TIUDA,.VALMCNT)
  1.  Q
  1.  ;
  1. ADDELMNT(DA,TIUCNT,APPEND) ; Add each element to the list
  1.  N PT,ADT,DDT,AUT,AMD,EDT,LCT,SDT,TIULST4,INSTA,TIUSTN
  1.  N TIUREC,TIUD0,TIUD12,TIUD13,TIUD15,STATX,TIULI,DOC ;P74 newed DOC
  1.  N PREFIX,TIUGDATA
  1.  I '$D(^TIU(8925,TIUDA,0)) Q
  1.  I $G(^TMP("TIUR",$J,2,0))="     No records found to satisfy search criteria." D
  1.  . K ^TMP("TIUR",$J,2),^TMP("TIUR",$J,"IDX",2),^TMP("TIUR",$J,"IDX",1)
  1.  . S TIUCNT=0
  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 DOC=$$PNAME^TIULC1(+TIUD0)
  1.  I DOC="Addendum" S DOC=DOC_" to "_$$PNAME^TIULC1(+$G(^TIU(8925,+$P(TIUD0,U,6),0)))
  1.  S PREFIX=$$PREFIX^TIULA2(TIUDA,0)
  1.  S PT=$$NAME^TIULS($$PTNAME^TIULC1($P(TIUD0,U,2)),"LAST,FI MI")
  1.  S TIULI=$E(PT)
  1.  S PT=PREFIX_PT
  1.  S TIULST4=$E($P($G(^DPT(+$P(TIUD0,U,2),0)),U,9),6,9)
  1.  S TIULST4="("_TIULI_TIULST4_")"
  1.  S ADT=$$DATE^TIULS($P(TIUD0,U,7),"MM/DD/YY")
  1.  S DDT=$$DATE^TIULS($P(TIUD0,U,8),"MM/DD/YY")
  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 AUT=$$NAME^TIULS(AUT,"LAST, FI MI")
  1.  S EDT=$$DATE^TIULS($P(TIUD13,U,7),"MM/DD/YY")
  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 STATX=$P($G(^TIU(8925.6,+$P(TIUD0,U,5),0)),U)
  1.  S LCT=$P(TIUD0,U,10)
  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 TIUCNT=+$G(TIUCNT)+1
  1.  S TIUREC=$$SETFLD^VALM1(TIUCNT,"","NUMBER")
  1.  S TIUREC=$$SETFLD^VALM1(PT,TIUREC,"PATIENT NAME")
  1.  S TIUREC=$$SETFLD^VALM1(TIULST4,TIUREC,"LAST I/LAST 4")
  1.  S TIUREC=$$SETFLD^VALM1(DOC,TIUREC,"DOCUMENT TYPE")
  1.  S TIUREC=$$SETFLD^VALM1(ADT,TIUREC,"ADMISSION DATE")
  1.  S TIUREC=$$SETFLD^VALM1(DDT,TIUREC,"DISCH DATE")
  1.  S TIUREC=$$SETFLD^VALM1(EDT,TIUREC,"DICT DATE")
  1.  S TIUREC=$$SETFLD^VALM1(LCT,TIUREC,"LINE COUNT")
  1.  S TIUREC=$$SETFLD^VALM1($$LOWER^TIULS(STATX),TIUREC,"STATUS")
  1.  S TIUREC=$$SETFLD^VALM1(AUT,TIUREC,"AUTHOR")
  1.  S TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"ATTENDING")
  1.  S TIUREC=$$SETFLD^VALM1(INSTA,TIUREC,"DIVISION")
  1.  S ^TMP("TIUR",$J,TIUCNT,0)=TIUREC
  1.  S ^TMP("TIUR",$J,"IDX",TIUCNT,TIUCNT)="" W "."
  1.  S ^TMP("TIURIDX",$J,TIUCNT)=TIUCNT_U_DA_U_PREFIX
  1.  S ^TMP("TIUR",$J,"IEN",DA,TIUCNT)=""
  1.  S TIUGDATA=$$IDDATA^TIURECL1(DA,TIUD0)
  1.  I TIUGDATA S ^TMP("TIUR",$J,"IDDATA",DA)=TIUGDATA
  1.  I +$G(APPEND) D
  1.  . D RESTORE^VALM10(TIUCNT)
  1.  . D CNTRL^VALM10(TIUCNT,1,$G(VALM("RM")),IOINHI,IOINORM),HDR^TIURMH
  1.  . S VALMSG="** Item #"_TIUCNT_" Added **"
  1.  . S $P(^TMP("TIUR",$J,0),U)=TIUCNT
  1.  . S $P(^TMP("TIUR",$J,"#"),":",2)=TIUCNT
  1.  . S VALMCNT=TIUCNT
  1.  . I $D(VALMHDR)>9 D HDR^TIURMH
  1.  Q