- 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 Feb 19, 2025@00:11:52 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