TIURM1 ; SLC/JER - MIS Document Review ; 8/23/12 1:27pm
;;1.0;TEXT INTEGRATION UTILITIES;**100,113,271,288**;Jun 20, 1997;Build 4
;Per VHA Directive 2004-038, this routine should not be modified
GATHER(TIUPREF,CLASS,STATIFNS,EARLY,LATE,DIVIFNS) ; Find/sort
;records for the list
N TIUDA,TIUSFLD,TIUI,TIUQ
S TIUSFLD=$P(TIUPREF,U,3)
S TIUSFLD=$S(TIUSFLD="P":".02",TIUSFLD="D":".01",TIUSFLD="S":".05",TIUSFLD="C":"1507",TIUSFLD="A":"1202",TIUSFLD="E":"1208",1:"1301")
S TIUI=EARLY F S TIUI=$O(^TIU(8925,"F",TIUI)) Q:+TIUI'>0!(+TIUI>LATE) D
. S TIUDA=0
. F S TIUDA=$O(^TIU(8925,"F",TIUI,TIUDA)) Q:+TIUDA'>0 D
. . ; Consider adding view check here
. . I '$$INTYPES(TIUDA) Q
. . I '$$INSTATUS(TIUDA,STATIFNS) Q
. . I +$G(DIVIFNS("ENTRIES")),'$$ININST(TIUDA,.DIVIFNS) Q
. . S TIUQ=$$RESOLVE^TIUR1(TIUDA,TIUSFLD)
. . S ^TMP("TIUI",$J,TIUQ,(9999999-TIUI),TIUDA)=""
Q
;
INTYPES(TIUDA) ; Evaluates whether a record is among the selected types
N TIUI,TIUTYP,TIUY,TIUPICKS,TIUDTYP
; *288 set selected types into TIUPICKS array
S TIUI=0 F S TIUI=$O(^TMP("TIUTYP",$J,TIUI)) Q:+TIUI'>0 D
. S TIUY=$P(^TMP("TIUTYP",$J,TIUI),U,2)
. ;OMIT addendum if it was NOT PICKED
. Q:TIUY=81&($P(^TMP("TIUTYP",$J,TIUI),U,4)="NOT PICKED")
. S:TIUY TIUPICKS(TIUY)=1
S TIUTYP=+$G(^TIU(8925,+TIUDA,0)),TIUDTYP=0
; look for parent type when addendum is not picked
I '+$G(TIUPICKS(81))&TIUTYP=81 S TIUDTYP=+$G(^TIU(8925,+$P($G(^TIU(8925,+TIUDA,0)),U,6),0))
S TIUY=$S(TIUDTYP:+$G(TIUPICKS(TIUDTYP)),1:+$G(TIUPICKS(TIUTYP)))
Q TIUY
;
INSTATUS(TIUDA,STATIFNS) ; Evaluates whether a record
;is among the selected statuses
N TIUS,TIUSTAT,TIUSTATE,TIUY S TIUY=0
S TIUSTATE=+$P($G(^TIU(8925,+TIUDA,0)),U,5)
S TIUS=1 F S TIUSTAT=$P(STATIFNS,";",TIUS) Q:'TIUSTAT!TIUY D
. S TIUS=TIUS+1
. I TIUSTAT=TIUSTATE S TIUY=1
Q TIUY
ININST(TIUDA,TIUDI) ; Evaluates whether a TIU DOCUMENT record
; is among the selected divisions
; Input -- TIUDA TIU DOCUMENT file (#8925) IEN
; -- TIUDI( i.e. TIUDI(file #40.8 IEN)=Institution file
; pointer for file #40.8 entry
; Output - TIUY 0= record not in selected division
; 1= record in selected division
N TIUIFP,TIUI,TIUINST,TIUY S TIUY=0
S TIUINST=+$P($G(^TIU(8925,+TIUDA,12)),U,12)
S TIUI=0 F S TIUI=$O(TIUDI(TIUI)) Q:'TIUI!TIUY D
. S TIUIFP=$G(TIUDI(TIUI))
. I TIUIFP=TIUINST S TIUY=1
Q TIUY
;
PUTLIST(TIUPREF,TIUCLASS,STATUS,DIVIFNS) ; Expands list elements for LM Template
N TIUJ,TIUQ,TIUDA,TIUPICK,TIUORDER,TIUEXPKD,TIUSFLD
S VALMCNT=0
S TIUSFLD=$P(TIUPREF,U,3)
S TIUSFLD=$S(TIUSFLD="P":".02",TIUSFLD="D":".01",TIUSFLD="S":".05",TIUSFLD="C":"1507",TIUSFLD="A":"1202",TIUSFLD="E":"1208",1:"1301")
S TIUORDER=$S($P(TIUPREF,U,4)="A":1,1:-1)
S TIUPICK=+$O(^ORD(101,"B","TIU ACTION SELECT LIST ELEMENT",0))
S TIUQ="" F S TIUQ=$O(^TMP("TIUI",$J,TIUQ)) Q:TIUQ']"" D
. S TIUJ=0 F S TIUJ=$O(^TMP("TIUI",$J,TIUQ,TIUJ)) Q:+TIUJ'>0 D
. . S TIUDA=0
. . F S TIUDA=$O(^TMP("TIUI",$J,TIUQ,TIUJ,TIUDA)) Q:'TIUDA D
. . . D REPLACE^TIUR2(TIUDA,TIUQ,TIUSFLD,TIUJ,.TIUEXPKD)
D SETLIST(TIUORDER,.VALMCNT)
S ^TMP("TIUR",$J,0)=+$G(VALMCNT)_U_STATUS("WORDS")
S ^TMP("TIUR",$J,"CLASS")=TIUCLASS
S ^TMP("TIUR",$J,"#")=TIUPICK_"^1:"_+$G(VALMCNT)
M ^TMP("TIUR",$J,"DIV")=DIVIFNS
I $D(VALMHDR)>9 D HDR^TIURMH
I +$G(VALMCNT)'>0 D
. S ^TMP("TIUR",$J,1,0)="",VALMCNT=2
. S ^TMP("TIUR",$J,2,0)=" No records found to satisfy search criteria."
. S ^TMP("TIUR",$J,"IDX",1,0)="" ; User can't select lines 1 or 2
. S ^TMP("TIUR",$J,"IDX",2,0)=""
; -- Expand to show kids that fit:
I '$G(TIURBLD),$D(TIUEXPKD) D EXPANDKD^TIUR2(.STATUS,.TIUEXPKD)
Q
SETLIST(TIUORDER,VALMCNT) ; Set items from ^TMP("TIUI",$J) into
;List Template list
N SORTVAL,TIUDTM,TIUDA
S SORTVAL=""
F S SORTVAL=$O(^TMP("TIUI",$J,SORTVAL),TIUORDER) Q:SORTVAL="" D
. S TIUDTM=0
. F S TIUDTM=$O(^TMP("TIUI",$J,SORTVAL,TIUDTM)) Q:'TIUDTM D
. . S TIUDA=0
. . F S TIUDA=$O(^TMP("TIUI",$J,SORTVAL,TIUDTM,TIUDA)) Q:'TIUDA D
. . . D ADDELMNT(TIUDA,.VALMCNT)
Q
;
ADDELMNT(DA,TIUCNT,APPEND) ; Add each element to the list
N PT,ADT,DDT,AUT,AMD,EDT,LCT,SDT,TIULST4,INSTA,TIUSTN
N TIUREC,TIUD0,TIUD12,TIUD13,TIUD15,STATX,TIULI,DOC ;P74 newed DOC
N PREFIX,TIUGDATA
I '$D(^TIU(8925,TIUDA,0)) Q
I $G(^TMP("TIUR",$J,2,0))=" No records found to satisfy search criteria." D
. K ^TMP("TIUR",$J,2),^TMP("TIUR",$J,"IDX",2),^TMP("TIUR",$J,"IDX",1)
. S TIUCNT=0
S TIUD0=$G(^TIU(8925,+DA,0)),TIUD12=$G(^TIU(8925,+DA,12))
S TIUD13=$G(^TIU(8925,+DA,13)),TIUD15=$G(^TIU(8925,+DA,15))
S DOC=$$PNAME^TIULC1(+TIUD0)
I DOC="Addendum" S DOC=DOC_" to "_$$PNAME^TIULC1(+$G(^TIU(8925,+$P(TIUD0,U,6),0)))
S PREFIX=$$PREFIX^TIULA2(TIUDA,0)
S PT=$$NAME^TIULS($$PTNAME^TIULC1($P(TIUD0,U,2)),"LAST,FI MI")
S TIULI=$E(PT)
S PT=PREFIX_PT
S TIULST4=$E($P($G(^DPT(+$P(TIUD0,U,2),0)),U,9),6,9)
S TIULST4="("_TIULI_TIULST4_")"
S ADT=$$DATE^TIULS($P(TIUD0,U,7),"MM/DD/YY")
S DDT=$$DATE^TIULS($P(TIUD0,U,8),"MM/DD/YY")
S AMD=$$PERSNAME^TIULC1($P(TIUD12,U,8)) S:AMD="UNKNOWN" AMD=""
S AUT=$$PERSNAME^TIULC1($P(TIUD12,U,2)) S:AUT="UNKNOWN" AUT=""
S AMD=$$NAME^TIULS(AMD,"LAST, FI MI")
S AUT=$$NAME^TIULS(AUT,"LAST, FI MI")
S EDT=$$DATE^TIULS($P(TIUD13,U,7),"MM/DD/YY")
S SDT=$S(+$P(TIUD15,U,7):+$P(TIUD15,U,7),+$P(TIUD0,U,5)'<7:+$P(TIUD15,U),1:"")
S SDT=$$DATE^TIULS(SDT,"MM/DD/YY")
S STATX=$P($G(^TIU(8925.6,+$P(TIUD0,U,5),0)),U)
S LCT=$P(TIUD0,U,10)
S INSTA=""
I +$P(TIUD12,U,12)>0 D
. S TIUSTN=$$NS^XUAF4($P(TIUD12,U,12))
. I $P(TIUSTN,U,2)]"" S INSTA=$P(TIUSTN,U,2)
S INSTA=$E(INSTA,1,8)
S TIUCNT=+$G(TIUCNT)+1
S TIUREC=$$SETFLD^VALM1(TIUCNT,"","NUMBER")
S TIUREC=$$SETFLD^VALM1(PT,TIUREC,"PATIENT NAME")
S TIUREC=$$SETFLD^VALM1(TIULST4,TIUREC,"LAST I/LAST 4")
S TIUREC=$$SETFLD^VALM1(DOC,TIUREC,"DOCUMENT TYPE")
S TIUREC=$$SETFLD^VALM1(ADT,TIUREC,"ADMISSION DATE")
S TIUREC=$$SETFLD^VALM1(DDT,TIUREC,"DISCH DATE")
S TIUREC=$$SETFLD^VALM1(EDT,TIUREC,"DICT DATE")
S TIUREC=$$SETFLD^VALM1(LCT,TIUREC,"LINE COUNT")
S TIUREC=$$SETFLD^VALM1($$LOWER^TIULS(STATX),TIUREC,"STATUS")
S TIUREC=$$SETFLD^VALM1(AUT,TIUREC,"AUTHOR")
S TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"ATTENDING")
S TIUREC=$$SETFLD^VALM1(INSTA,TIUREC,"DIVISION")
S ^TMP("TIUR",$J,TIUCNT,0)=TIUREC
S ^TMP("TIUR",$J,"IDX",TIUCNT,TIUCNT)="" W "."
S ^TMP("TIURIDX",$J,TIUCNT)=TIUCNT_U_DA_U_PREFIX
S ^TMP("TIUR",$J,"IEN",DA,TIUCNT)=""
S TIUGDATA=$$IDDATA^TIURECL1(DA,TIUD0)
I TIUGDATA S ^TMP("TIUR",$J,"IDDATA",DA)=TIUGDATA
I +$G(APPEND) D
. D RESTORE^VALM10(TIUCNT)
. D CNTRL^VALM10(TIUCNT,1,$G(VALM("RM")),IOINHI,IOINORM),HDR^TIURMH
. S VALMSG="** Item #"_TIUCNT_" Added **"
. S $P(^TMP("TIUR",$J,0),U)=TIUCNT
. S $P(^TMP("TIUR",$J,"#"),":",2)=TIUCNT
. S VALMCNT=TIUCNT
. I $D(VALMHDR)>9 D HDR^TIURMH
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIURM1 6937 printed Dec 13, 2024@02:45:23 Page 2
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
+2 ;Per VHA Directive 2004-038, this routine should not be modified
GATHER(TIUPREF,CLASS,STATIFNS,EARLY,LATE,DIVIFNS) ; Find/sort
+1 ;records for the list
+2 NEW TIUDA,TIUSFLD,TIUI,TIUQ
+3 SET TIUSFLD=$PIECE(TIUPREF,U,3)
+4 SET TIUSFLD=$SELECT(TIUSFLD="P":".02",TIUSFLD="D":".01",TIUSFLD="S":".05",TIUSFLD="C":"1507",TIUSFLD="A":"1202",TIUSFLD="E":"1208",1:"1301")
+5 SET TIUI=EARLY
FOR
SET TIUI=$ORDER(^TIU(8925,"F",TIUI))
if +TIUI'>0!(+TIUI>LATE)
QUIT
Begin DoDot:1
+6 SET TIUDA=0
+7 FOR
SET TIUDA=$ORDER(^TIU(8925,"F",TIUI,TIUDA))
if +TIUDA'>0
QUIT
Begin DoDot:2
+8 ; Consider adding view check here
+9 IF '$$INTYPES(TIUDA)
QUIT
+10 IF '$$INSTATUS(TIUDA,STATIFNS)
QUIT
+11 IF +$GET(DIVIFNS("ENTRIES"))
IF '$$ININST(TIUDA,.DIVIFNS)
QUIT
+12 SET TIUQ=$$RESOLVE^TIUR1(TIUDA,TIUSFLD)
+13 SET ^TMP("TIUI",$JOB,TIUQ,(9999999-TIUI),TIUDA)=""
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
INTYPES(TIUDA) ; Evaluates whether a record is among the selected types
+1 NEW TIUI,TIUTYP,TIUY,TIUPICKS,TIUDTYP
+2 ; *288 set selected types into TIUPICKS array
+3 SET TIUI=0
FOR
SET TIUI=$ORDER(^TMP("TIUTYP",$JOB,TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+4 SET TIUY=$PIECE(^TMP("TIUTYP",$JOB,TIUI),U,2)
+5 ;OMIT addendum if it was NOT PICKED
+6 if TIUY=81&($PIECE(^TMP("TIUTYP",$JOB,TIUI),U,4)="NOT PICKED")
QUIT
+7 if TIUY
SET TIUPICKS(TIUY)=1
End DoDot:1
+8 SET TIUTYP=+$GET(^TIU(8925,+TIUDA,0))
SET TIUDTYP=0
+9 ; look for parent type when addendum is not picked
+10 IF '+$GET(TIUPICKS(81))&TIUTYP=81
SET TIUDTYP=+$GET(^TIU(8925,+$PIECE($GET(^TIU(8925,+TIUDA,0)),U,6),0))
+11 SET TIUY=$SELECT(TIUDTYP:+$GET(TIUPICKS(TIUDTYP)),1:+$GET(TIUPICKS(TIUTYP)))
+12 QUIT TIUY
+13 ;
INSTATUS(TIUDA,STATIFNS) ; Evaluates whether a record
+1 ;is among the selected statuses
+2 NEW TIUS,TIUSTAT,TIUSTATE,TIUY
SET TIUY=0
+3 SET TIUSTATE=+$PIECE($GET(^TIU(8925,+TIUDA,0)),U,5)
+4 SET TIUS=1
FOR
SET TIUSTAT=$PIECE(STATIFNS,";",TIUS)
if 'TIUSTAT!TIUY
QUIT
Begin DoDot:1
+5 SET TIUS=TIUS+1
+6 IF TIUSTAT=TIUSTATE
SET TIUY=1
End DoDot:1
+7 QUIT TIUY
ININST(TIUDA,TIUDI) ; Evaluates whether a TIU DOCUMENT record
+1 ; is among the selected divisions
+2 ; Input -- TIUDA TIU DOCUMENT file (#8925) IEN
+3 ; -- TIUDI( i.e. TIUDI(file #40.8 IEN)=Institution file
+4 ; pointer for file #40.8 entry
+5 ; Output - TIUY 0= record not in selected division
+6 ; 1= record in selected division
+7 NEW TIUIFP,TIUI,TIUINST,TIUY
SET TIUY=0
+8 SET TIUINST=+$PIECE($GET(^TIU(8925,+TIUDA,12)),U,12)
+9 SET TIUI=0
FOR
SET TIUI=$ORDER(TIUDI(TIUI))
if 'TIUI!TIUY
QUIT
Begin DoDot:1
+10 SET TIUIFP=$GET(TIUDI(TIUI))
+11 IF TIUIFP=TIUINST
SET TIUY=1
End DoDot:1
+12 QUIT TIUY
+13 ;
PUTLIST(TIUPREF,TIUCLASS,STATUS,DIVIFNS) ; Expands list elements for LM Template
+1 NEW TIUJ,TIUQ,TIUDA,TIUPICK,TIUORDER,TIUEXPKD,TIUSFLD
+2 SET VALMCNT=0
+3 SET TIUSFLD=$PIECE(TIUPREF,U,3)
+4 SET TIUSFLD=$SELECT(TIUSFLD="P":".02",TIUSFLD="D":".01",TIUSFLD="S":".05",TIUSFLD="C":"1507",TIUSFLD="A":"1202",TIUSFLD="E":"1208",1:"1301")
+5 SET TIUORDER=$SELECT($PIECE(TIUPREF,U,4)="A":1,1:-1)
+6 SET TIUPICK=+$ORDER(^ORD(101,"B","TIU ACTION SELECT LIST ELEMENT",0))
+7 SET TIUQ=""
FOR
SET TIUQ=$ORDER(^TMP("TIUI",$JOB,TIUQ))
if TIUQ']""
QUIT
Begin DoDot:1
+8 SET TIUJ=0
FOR
SET TIUJ=$ORDER(^TMP("TIUI",$JOB,TIUQ,TIUJ))
if +TIUJ'>0
QUIT
Begin DoDot:2
+9 SET TIUDA=0
+10 FOR
SET TIUDA=$ORDER(^TMP("TIUI",$JOB,TIUQ,TIUJ,TIUDA))
if 'TIUDA
QUIT
Begin DoDot:3
+11 DO REPLACE^TIUR2(TIUDA,TIUQ,TIUSFLD,TIUJ,.TIUEXPKD)
End DoDot:3
End DoDot:2
End DoDot:1
+12 DO SETLIST(TIUORDER,.VALMCNT)
+13 SET ^TMP("TIUR",$JOB,0)=+$GET(VALMCNT)_U_STATUS("WORDS")
+14 SET ^TMP("TIUR",$JOB,"CLASS")=TIUCLASS
+15 SET ^TMP("TIUR",$JOB,"#")=TIUPICK_"^1:"_+$GET(VALMCNT)
+16 MERGE ^TMP("TIUR",$JOB,"DIV")=DIVIFNS
+17 IF $DATA(VALMHDR)>9
DO HDR^TIURMH
+18 IF +$GET(VALMCNT)'>0
Begin DoDot:1
+19 SET ^TMP("TIUR",$JOB,1,0)=""
SET VALMCNT=2
+20 SET ^TMP("TIUR",$JOB,2,0)=" No records found to satisfy search criteria."
+21 ; User can't select lines 1 or 2
SET ^TMP("TIUR",$JOB,"IDX",1,0)=""
+22 SET ^TMP("TIUR",$JOB,"IDX",2,0)=""
End DoDot:1
+23 ; -- Expand to show kids that fit:
+24 IF '$GET(TIURBLD)
IF $DATA(TIUEXPKD)
DO EXPANDKD^TIUR2(.STATUS,.TIUEXPKD)
+25 QUIT
SETLIST(TIUORDER,VALMCNT) ; Set items from ^TMP("TIUI",$J) into
+1 ;List Template list
+2 NEW SORTVAL,TIUDTM,TIUDA
+3 SET SORTVAL=""
+4 FOR
SET SORTVAL=$ORDER(^TMP("TIUI",$JOB,SORTVAL),TIUORDER)
if SORTVAL=""
QUIT
Begin DoDot:1
+5 SET TIUDTM=0
+6 FOR
SET TIUDTM=$ORDER(^TMP("TIUI",$JOB,SORTVAL,TIUDTM))
if 'TIUDTM
QUIT
Begin DoDot:2
+7 SET TIUDA=0
+8 FOR
SET TIUDA=$ORDER(^TMP("TIUI",$JOB,SORTVAL,TIUDTM,TIUDA))
if 'TIUDA
QUIT
Begin DoDot:3
+9 DO ADDELMNT(TIUDA,.VALMCNT)
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
ADDELMNT(DA,TIUCNT,APPEND) ; Add each element to the list
+1 NEW PT,ADT,DDT,AUT,AMD,EDT,LCT,SDT,TIULST4,INSTA,TIUSTN
+2 ;P74 newed DOC
NEW TIUREC,TIUD0,TIUD12,TIUD13,TIUD15,STATX,TIULI,DOC
+3 NEW PREFIX,TIUGDATA
+4 IF '$DATA(^TIU(8925,TIUDA,0))
QUIT
+5 IF $GET(^TMP("TIUR",$JOB,2,0))=" No records found to satisfy search criteria."
Begin DoDot:1
+6 KILL ^TMP("TIUR",$JOB,2),^TMP("TIUR",$JOB,"IDX",2),^TMP("TIUR",$JOB,"IDX",1)
+7 SET TIUCNT=0
End DoDot:1
+8 SET TIUD0=$GET(^TIU(8925,+DA,0))
SET TIUD12=$GET(^TIU(8925,+DA,12))
+9 SET TIUD13=$GET(^TIU(8925,+DA,13))
SET TIUD15=$GET(^TIU(8925,+DA,15))
+10 SET DOC=$$PNAME^TIULC1(+TIUD0)
+11 IF DOC="Addendum"
SET DOC=DOC_" to "_$$PNAME^TIULC1(+$GET(^TIU(8925,+$PIECE(TIUD0,U,6),0)))
+12 SET PREFIX=$$PREFIX^TIULA2(TIUDA,0)
+13 SET PT=$$NAME^TIULS($$PTNAME^TIULC1($PIECE(TIUD0,U,2)),"LAST,FI MI")
+14 SET TIULI=$EXTRACT(PT)
+15 SET PT=PREFIX_PT
+16 SET TIULST4=$EXTRACT($PIECE($GET(^DPT(+$PIECE(TIUD0,U,2),0)),U,9),6,9)
+17 SET TIULST4="("_TIULI_TIULST4_")"
+18 SET ADT=$$DATE^TIULS($PIECE(TIUD0,U,7),"MM/DD/YY")
+19 SET DDT=$$DATE^TIULS($PIECE(TIUD0,U,8),"MM/DD/YY")
+20 SET AMD=$$PERSNAME^TIULC1($PIECE(TIUD12,U,8))
if AMD="UNKNOWN"
SET AMD=""
+21 SET AUT=$$PERSNAME^TIULC1($PIECE(TIUD12,U,2))
if AUT="UNKNOWN"
SET AUT=""
+22 SET AMD=$$NAME^TIULS(AMD,"LAST, FI MI")
+23 SET AUT=$$NAME^TIULS(AUT,"LAST, FI MI")
+24 SET EDT=$$DATE^TIULS($PIECE(TIUD13,U,7),"MM/DD/YY")
+25 SET SDT=$SELECT(+$PIECE(TIUD15,U,7):+$PIECE(TIUD15,U,7),+$PIECE(TIUD0,U,5)'<7:+$PIECE(TIUD15,U),1:"")
+26 SET SDT=$$DATE^TIULS(SDT,"MM/DD/YY")
+27 SET STATX=$PIECE($GET(^TIU(8925.6,+$PIECE(TIUD0,U,5),0)),U)
+28 SET LCT=$PIECE(TIUD0,U,10)
+29 SET INSTA=""
+30 IF +$PIECE(TIUD12,U,12)>0
Begin DoDot:1
+31 SET TIUSTN=$$NS^XUAF4($PIECE(TIUD12,U,12))
+32 IF $PIECE(TIUSTN,U,2)]""
SET INSTA=$PIECE(TIUSTN,U,2)
End DoDot:1
+33 SET INSTA=$EXTRACT(INSTA,1,8)
+34 SET TIUCNT=+$GET(TIUCNT)+1
+35 SET TIUREC=$$SETFLD^VALM1(TIUCNT,"","NUMBER")
+36 SET TIUREC=$$SETFLD^VALM1(PT,TIUREC,"PATIENT NAME")
+37 SET TIUREC=$$SETFLD^VALM1(TIULST4,TIUREC,"LAST I/LAST 4")
+38 SET TIUREC=$$SETFLD^VALM1(DOC,TIUREC,"DOCUMENT TYPE")
+39 SET TIUREC=$$SETFLD^VALM1(ADT,TIUREC,"ADMISSION DATE")
+40 SET TIUREC=$$SETFLD^VALM1(DDT,TIUREC,"DISCH DATE")
+41 SET TIUREC=$$SETFLD^VALM1(EDT,TIUREC,"DICT DATE")
+42 SET TIUREC=$$SETFLD^VALM1(LCT,TIUREC,"LINE COUNT")
+43 SET TIUREC=$$SETFLD^VALM1($$LOWER^TIULS(STATX),TIUREC,"STATUS")
+44 SET TIUREC=$$SETFLD^VALM1(AUT,TIUREC,"AUTHOR")
+45 SET TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"ATTENDING")
+46 SET TIUREC=$$SETFLD^VALM1(INSTA,TIUREC,"DIVISION")
+47 SET ^TMP("TIUR",$JOB,TIUCNT,0)=TIUREC
+48 SET ^TMP("TIUR",$JOB,"IDX",TIUCNT,TIUCNT)=""
WRITE "."
+49 SET ^TMP("TIURIDX",$JOB,TIUCNT)=TIUCNT_U_DA_U_PREFIX
+50 SET ^TMP("TIUR",$JOB,"IEN",DA,TIUCNT)=""
+51 SET TIUGDATA=$$IDDATA^TIURECL1(DA,TIUD0)
+52 IF TIUGDATA
SET ^TMP("TIUR",$JOB,"IDDATA",DA)=TIUGDATA
+53 IF +$GET(APPEND)
Begin DoDot:1
+54 DO RESTORE^VALM10(TIUCNT)
+55 DO CNTRL^VALM10(TIUCNT,1,$GET(VALM("RM")),IOINHI,IOINORM)
DO HDR^TIURMH
+56 SET VALMSG="** Item #"_TIUCNT_" Added **"
+57 SET $PIECE(^TMP("TIUR",$JOB,0),U)=TIUCNT
+58 SET $PIECE(^TMP("TIUR",$JOB,"#"),":",2)=TIUCNT
+59 SET VALMCNT=TIUCNT
+60 IF $DATA(VALMHDR)>9
DO HDR^TIURMH
End DoDot:1
+61 QUIT
