TIUROR ;SLC/JER - New PATIENT Review screen ; 9/5/01
;;1.0;TEXT INTEGRATION UTILITIES;**10,86,88,100,123,143**;Jun 20, 1997
; Split rtn into TIUROR & TIUROR1 11/27/00
EN ; -- main entry point for TIU OE/RR REVIEW PN
D EN^VALM("TIU OE/RR REVIEW PN")
Q
;
HDR ; -- header code
N TIUCTXT,TIUPNM,TIUSSN,TIULOC,TIUDOB,TIUHDR,TIUCWAD,TIUDCNT,VADM,VA
N TIUDFN I +$D(@VALMAR@(0))'>0 S VALMQUIT=1 Q
S TIUDFN=+$G(@VALMAR@("DFN"))
S TIUCWAD=$$CWAD^GMRPNOR1(TIUDFN) S:TIUCWAD]"" TIUCWAD="<"_TIUCWAD_">"
S TIUDCNT=$J($S($G(@VALMAR@("CTXT"))="INIT":"Last ",1:"")_+@VALMAR@(0)_" note(s)",16)
S TIUCTXT=$$UP^XLFSTR($$PNAME^TIULC1(@VALMAR@("CLASS")))
S TIUCTXT=$$TITLE^TIUU(TIUCTXT)
S TIUHDR=$$SETSTR^VALM1(TIUCWAD,$G(TIUHDR),1,20)
S TIUHDR=$$SETSTR^VALM1(TIUCTXT,$G(TIUHDR),27,28)
S TIUHDR=$$SETSTR^VALM1(TIUDCNT,$G(TIUHDR),64,16)
S VALMHDR(1)=TIUHDR,TIUHDR=""
S TIUPNM=$$NAME^TIULO(TIUDFN),TIUSSN=$$SSN^TIULO(TIUDFN)
S TIUDOB=$$DOB^TIULO(TIUDFN)_" ("_$$AGE^TIULO(TIUDFN)_")"
S TIULOC=$G(^DPT(+TIUDFN,.1))
S:TIULOC]"" TIULOC=TIULOC_"/"_$G(^DPT(+TIUDFN,.101))
S TIUHDR=$$SETSTR^VALM1(TIUPNM,$G(TIUHDR),1,20)
S TIUHDR=$$SETSTR^VALM1(TIUSSN,$G(TIUHDR),22,11)
S TIUHDR=$$SETSTR^VALM1(TIULOC,$G(TIUHDR),35,20)
S TIUHDR=$$SETSTR^VALM1(TIUDOB,$G(TIUHDR),64,16)
S VALMHDR(2)=TIUHDR
Q
;
INIT(CLASS,CONTEXT,DFN,TIUOCC) ; -- init variables and list array
N TIUR,TIUI,TIUY,TIUPICK,TIUQUIT,TIUCCTXT,TIUDUZ,TIUERLY,TIULATE
N TIUPREF,TIUOCTXT,TIURCTXT,TIUSEQ,TIUDPRM
N DUOUT,DTOUT,DIROUT ;1/8/01
I $G(@VALMAR@("SEQ"))]"" S TIUSEQ=$G(@VALMAR@("SEQ"))
I +$G(@VALMAR@("CTXT")) S TIURCTXT=$G(@VALMAR@("CTXT"))
K @VALMAR,VALMCNT,^TMP("TIURIDX",$J)
K ^TMP("TIUYARRAY",$J) ; TIU*1.0*143
S TIUPREF=$$PERSPRF^TIULE(DUZ)
S TIUSEQ=$G(TIUSEQ,$S($P(TIUPREF,U,4)="A":"A",1:"D"))
S TIUPICK=+$O(^ORD(101,"B","TIU ACTION SELECT LIST ELEMENT",0))
S DFN=$S(+$G(DFN):+$G(DFN),+$G(ORVP):+$G(ORVP),1:+$$PATIENT^TIULA)
I $S($D(DUOUT):1,$D(DTOUT):1,$D(DIROUT):1,+$G(DFN)'>0:1,1:0) S VALMQUIT=1 Q
I +$G(CONTEXT)'=9999,'+$G(TIUOCC) S TIUOCC=$S(+$P(TIUPREF,U,10):+$P(TIUPREF,U,10),1:100)
S ^TMP("TIUR",$J,"RTN")="TIUROR"
I '$O(^TIU(8925,"ACLPT",CLASS,DFN,0)),'$O(^TIU(8925,"ACLAU",CLASS,DUZ,DFN,0)),'$O(^TIU(8925,"ACLEC",CLASS,DUZ,DFN,0)) D Q:$G(CONTEXT)'=9999
. N TIUST
. S TIUST=$S(CONTEXT=2:"UNSIGNED ",CONTEXT=3:"UNCOSIGNED ",1:"SIGNED ")
. S VALMCNT=2,^TMP("TIUR",$J,0)=0
. S ^TMP("TIUR",$J,1,0)=""
. S ^TMP("TIUR",$J,2,0)="No "_TIUST_$$UP^XLFSTR($$PNAME^TIULC1(CLASS))_" Available for "_$$PTNAME^TIULC1(DFN)
. S TIUOCTXT=CONTEXT
. I CONTEXT=4 S TIUOCTXT=TIUOCTXT_U_TIUDUZ
. I CONTEXT=5 S TIUOCTXT=TIUOCTXT_U_+TIUERLY_U_+TIULATE
. S ^TMP("TIUR",$J,"SEQ")=$G(TIUSEQ)
. S ^TMP("TIUR",$J,"CLASS")=CLASS,^("DFN")=DFN,^("CTXT")=TIUOCTXT D HDR
I $G(CONTEXT)=9999 S TIUCCTXT=1,TIUOCC=9999999
; -- Set vars needed for RBLD if user ^s:
S ^TMP("TIUR",$J,"CLASS")=CLASS,^("DFN")=DFN,^("OCC")=TIUOCC,^("CTXT")=+$G(TIURCTXT)
S CONTEXT=$S($G(CONTEXT)=9999:$$ASKCTXT^TIUROR1,+$G(CONTEXT):+$G(CONTEXT),1:1)
; -- 1=Signed 2=Unsigned 3=Uncosigned 4=Signed/Author 5=Signed/Date --
I $S($D(DIROUT):1,$D(DUOUT):1,$D(DTOUT):1,1:0) D RBLD Q
I $S(CONTEXT=1:1,CONTEXT=2:1,CONTEXT=3:1,1:0) S TIUERLY="",TIULATE="",TIUDUZ=DUZ
I CONTEXT=4 D Q:+$G(TIUQUIT)>0
. S TIUERLY="",TIULATE=""
. S TIUDUZ=$S(+$G(TIURCTXT)'=4:+$$AUTHOR^TIULA2(1),+$P(TIURCTXT,U,2)'>0:+$$AUTHOR^TIULA2(1),+$G(TIUCCTXT):+$$AUTHOR^TIULA2(1),1:+$P(TIURCTXT,U,2))
. I $S($D(DUOUT):1,$D(DTOUT):1,$D(DIROUT):1,+$G(TIUDUZ)'>0:1,1:0) S TIUQUIT=1 D RBLD Q ; changed DIRUT to DTOUT. 10/20/00
. S TIUSEQ=$S(+$G(TIUCCTXT):$P($$ASKSEQ^TIULA3(TIUSEQ),U),$G(TIUSEQ)']"":$P($$ASKSEQ^TIULA3(TIUSEQ),U),1:$G(TIUSEQ))
. I $S($D(DIROUT):1,$D(DUOUT):1,$D(DTOUT):1,1:0) S TIUQUIT=1 D RBLD
I CONTEXT=5 D Q:+$G(TIUQUIT)>0
. S TIUDUZ=+$G(DUZ)
. S TIUERLY=$S(+$G(TIURCTXT)'=5:$$EDATE^TIULA("",7,""),+$P(TIURCTXT,U,2)'>0:$$EDATE^TIULA("",7,""),+$G(TIUCCTXT):$$EDATE^TIULA("",7,""),1:+$P(TIURCTXT,U,2))
. I $S($D(DIROUT):1,$D(DUOUT):1,$D(DTOUT):1,1:0) S TIUQUIT=1 D RBLD Q
. S TIUERLY=$P(TIUERLY,U)
. S TIULATE=$S(+$G(TIURCTXT)'=5:$$LDATE^TIULA("",7,""),+$P(TIURCTXT,U,3)'>0:$$LDATE^TIULA("",7,""),+$G(TIUCCTXT):$$LDATE^TIULA("",7,""),1:+$P(TIURCTXT,U,3))
. I $S($D(DIROUT):1,$D(DUOUT):1,$D(DTOUT):1,1:0) S TIUQUIT=1 D RBLD Q
. S TIULATE=$P(TIULATE,U)
. I TIUERLY>TIULATE D SWAP^TIUR(.TIUERLY,.TIULATE)
. I $L(TIULATE,".")=1 D EXPRANGE^TIUR(.TIUERLY,.TIULATE)
. S TIUSEQ=$S(+$G(TIUCCTXT):$P($$ASKSEQ^TIULA3(TIUSEQ),U),$G(TIUSEQ)']"":$P($$ASKSEQ^TIULA3(TIUSEQ),U),1:$G(TIUSEQ))
. I $S($D(DIROUT):1,$D(DUOUT):1,$D(DTOUT):1,1:0) S TIUQUIT=1 D RBLD
I '$G(TIURBLD) W !,"Searching for the progress notes"
N TIUEXPKD
D CONTEXT^TIUSRVLL(.TIUY,CLASS,CONTEXT,DFN,TIUERLY,TIULATE,TIUDUZ,TIUOCC,TIUSEQ,.TIUEXPKD) W "."
; I $D(TIUY)'>9 D Q ; original code
I $D(^TMP("TIUYARRAY",$J))'>9 D Q ; TIU*1.0*143
. N TIUST
. S TIUST=$S(CONTEXT=2:"UNSIGNED ",CONTEXT=3:"UNCOSIGNED ",1:"SIGNED ")
. S VALMCNT=2,^TMP("TIUR",$J,0)=0
. S ^TMP("TIUR",$J,1,0)=""
. S ^TMP("TIUR",$J,2,0)="No "_TIUST_$$UP^XLFSTR($$PNAME^TIULC1(CLASS))_" Available for "_$$PTNAME^TIULC1(DFN)
. S ^TMP("TIUR",$J,"CLASS")=CLASS,^("DFN")=DFN
. S TIUOCTXT=CONTEXT
. I CONTEXT=4 S TIUOCTXT=TIUOCTXT_U_TIUDUZ
. I CONTEXT=5 S TIUOCTXT=TIUOCTXT_U_+TIUERLY_U_+TIULATE
. S ^TMP("TIUR",$J,"SEQ")=$G(TIUSEQ)
. S ^TMP("TIUR",$J,"CTXT")=$S('+$G(TIUCCTXT):"INIT",1:TIUOCTXT) D HDR
S TIUI=""
; F S TIUI=$O(TIUY(TIUI)) Q:TIUI="" D ; original code
F S TIUI=$O(^TMP("TIUYARRAY",$J,TIUI)) Q:TIUI="" D ; TIU*1.0*143
. N AUT,RDT,STAT,TITL,TIUD0,TIUD12,TIUD13,PREFIX
. N TIUGDATA
. S TIUD0=$G(^TIU(8925,+^TMP("TIUYARRAY",$J,TIUI),0)),TIUD12=$G(^(12)),TIUD13=$G(^(13)) ; **
. ; S TIUD0=$G(^TIU(8925,+TIUY(TIUI),0)),TIUD12=$G(^(12)),TIUD13=$G(^(13)) ; original
. S VALMCNT=+$G(VALMCNT)+1 W:(VALMCNT#100'>0) "."
. S TITL=$$PNAME^TIULC1(+TIUD0)
. I TITL="Addendum" S TITL=TITL_" to "_$$PNAME^TIULC1(+$G(^TIU(8925,+$P(TIUD0,U,6),0)))
. ; -- Mark ID note '<' and/or has addendum '+',
. S PREFIX=$$PREFIX^TIULA2(+^TMP("TIUYARRAY",$J,TIUI),0) ; TIU*1.0*143
. ; S PREFIX=$$PREFIX^TIULA2(+TIUY(TIUI),0) ; original
. S TITL=PREFIX_TITL
. S AUT=$$NAME^TIULS($$PERSNAME^TIULC1(+$P(TIUD12,U,2)),"LAST,FI")
. S RDT=$$DATE^TIULS(+TIUD13,"MM/DD/YY HR:MIN")
. S STAT=$$LOW^XLFSTR($P($G(^TIU(8925.6,+$P(TIUD0,U,5),0)),U))
. S TIUR=$$SETFLD^VALM1(VALMCNT,$G(TIUR),"NUMBER")
. S TIUR=$$SETFLD^VALM1(TITL,$G(TIUR),"TITLE")
. S TIUR=$$SETFLD^VALM1(AUT,$G(TIUR),"AUTHOR")
. S TIUR=$$SETFLD^VALM1(RDT,$G(TIUR),"REF DATE")
. S TIUR=$$SETFLD^VALM1(STAT,$G(TIUR),"STATUS")
. S ^TMP("TIUR",$J,VALMCNT,0)=TIUR
. S ^TMP("TIUR",$J,0)=VALMCNT
. S ^TMP("TIURIDX",$J,VALMCNT)=VALMCNT_U_+^TMP("TIUYARRAY",$J,TIUI)_U_PREFIX ; TIU*1.0*143
. ; S ^TMP("TIURIDX",$J,VALMCNT)=VALMCNT_U_+TIUY(TIUI)_U_PREFIX ; original
. S ^TMP("TIUR",$J,"IEN",+^TMP("TIUYARRAY",$J,TIUI),VALMCNT)="" ; TIU*1.0*143
. ; S ^TMP("TIUR",$J,"IEN",+TIUY(TIUI),VALMCNT)="" ;original
. S ^TMP("TIUR",$J,"IDX",VALMCNT,VALMCNT)=""
. ; TIUGDATA = 0 or DA^haskid^IDparent^prmsort:
. S TIUGDATA=$$IDDATA^TIURECL1(+^TMP("TIUYARRAY",$J,TIUI),TIUD0) ; TIU*1.0*143
. ; S TIUGDATA=$$IDDATA^TIURECL1(+TIUY(TIUI),TIUD0) ; original
. I $G(TIUGDATA) S ^TMP("TIUR",$J,"IDDATA",+^TMP("TIUYARRAY",$J,TIUI))=TIUGDATA ; TIU*1.0*143
. ; I $G(TIUGDATA) S ^TMP("TIUR",$J,"IDDATA",+TIUY(TIUI))=TIUGDATA ; original
S ^TMP("TIUR",$J,"#")=TIUPICK_"^1:"_+VALMCNT
S ^TMP("TIUR",$J,"CLASS")=CLASS
S ^TMP("TIUR",$J,"DFN")=DFN
S ^TMP("TIUR",$J,"OCC")=+$G(TIUOCC)
S TIUOCTXT=CONTEXT
I CONTEXT=4 S TIUOCTXT=TIUOCTXT_U_TIUDUZ
I CONTEXT=5 S TIUOCTXT=TIUOCTXT_U_+TIUERLY_U_+TIULATE
S ^TMP("TIUR",$J,"SEQ")=$G(TIUSEQ)
S ^TMP("TIUR",$J,"CTXT")=$S('+$G(TIUCCTXT)&(VALMCNT'<TIUOCC):"INIT",1:TIUOCTXT)
I CONTEXT=1,(+$G(TIUOCC)=9999999) D SAVE^TIUROR1
I +$G(TIUCCTXT),$D(^TMP("TIUR",$J,0)) D HDR
; If first build (not rebuild), expand parents to show kids that
;meet criteria:
I '$G(TIURBLD),$D(TIUEXPKD) D
. D EXPANDKD^TIUR2(.TIUEXPKD,"",CONTEXT)
; K ^TMP("TIUYARRAY",$J) ; TIU*1.0*143
Q
;
EXIT ; -- exit code
D CLEAN^VALM10
K DFN,VALMY,VALMCNT,VALMKEY,^TMP("TIURSAVE",$J)
K ^TMP("TIURIDX",$J)
K TIUGLINK ;**100**
Q
;
RBLD ; -- rebuild list after actions
N TIUEXP,TIURBLD
S TIURBLD=1
I +$O(^TMP("TIUR",$J,"EXPAND",0)) D G RBLDX
. M TIUEXP=^TMP("TIUR",$J,"EXPAND")
. D INIT(+$G(^TMP("TIUR",$J,"CLASS")),+$G(^("CTXT")),+$G(^("DFN")),+$G(^("OCC")))
. D RELOAD^TIUROR1(.TIUEXP)
. D BREATHE^TIUROR1(1)
D INIT(+$G(^TMP("TIUR",$J,"CLASS")),+$G(^("CTXT")),+$G(^("DFN")),+$G(^("OCC")))
;D HDR S VALMBCK="R",VALMBG=1,VALMCNT=+$G(^TMP("TIUR",$J,0))
D HDR S VALMBCK="R",VALMCNT=+$G(^TMP("TIUR",$J,0))
RBLDX I $G(VALMBG)>$G(VALMCNT) S VALMBG=$G(VALMCNT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUROR 8872 printed Jan 18, 2025@03:46:34 Page 2
TIUROR ;SLC/JER - New PATIENT Review screen ; 9/5/01
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**10,86,88,100,123,143**;Jun 20, 1997
+2 ; Split rtn into TIUROR & TIUROR1 11/27/00
EN ; -- main entry point for TIU OE/RR REVIEW PN
+1 DO EN^VALM("TIU OE/RR REVIEW PN")
+2 QUIT
+3 ;
HDR ; -- header code
+1 NEW TIUCTXT,TIUPNM,TIUSSN,TIULOC,TIUDOB,TIUHDR,TIUCWAD,TIUDCNT,VADM,VA
+2 NEW TIUDFN
IF +$DATA(@VALMAR@(0))'>0
SET VALMQUIT=1
QUIT
+3 SET TIUDFN=+$GET(@VALMAR@("DFN"))
+4 SET TIUCWAD=$$CWAD^GMRPNOR1(TIUDFN)
if TIUCWAD]""
SET TIUCWAD="<"_TIUCWAD_">"
+5 SET TIUDCNT=$JUSTIFY($SELECT($GET(@VALMAR@("CTXT"))="INIT":"Last ",1:"")_+@VALMAR@(0)_" note(s)",16)
+6 SET TIUCTXT=$$UP^XLFSTR($$PNAME^TIULC1(@VALMAR@("CLASS")))
+7 SET TIUCTXT=$$TITLE^TIUU(TIUCTXT)
+8 SET TIUHDR=$$SETSTR^VALM1(TIUCWAD,$GET(TIUHDR),1,20)
+9 SET TIUHDR=$$SETSTR^VALM1(TIUCTXT,$GET(TIUHDR),27,28)
+10 SET TIUHDR=$$SETSTR^VALM1(TIUDCNT,$GET(TIUHDR),64,16)
+11 SET VALMHDR(1)=TIUHDR
SET TIUHDR=""
+12 SET TIUPNM=$$NAME^TIULO(TIUDFN)
SET TIUSSN=$$SSN^TIULO(TIUDFN)
+13 SET TIUDOB=$$DOB^TIULO(TIUDFN)_" ("_$$AGE^TIULO(TIUDFN)_")"
+14 SET TIULOC=$GET(^DPT(+TIUDFN,.1))
+15 if TIULOC]""
SET TIULOC=TIULOC_"/"_$GET(^DPT(+TIUDFN,.101))
+16 SET TIUHDR=$$SETSTR^VALM1(TIUPNM,$GET(TIUHDR),1,20)
+17 SET TIUHDR=$$SETSTR^VALM1(TIUSSN,$GET(TIUHDR),22,11)
+18 SET TIUHDR=$$SETSTR^VALM1(TIULOC,$GET(TIUHDR),35,20)
+19 SET TIUHDR=$$SETSTR^VALM1(TIUDOB,$GET(TIUHDR),64,16)
+20 SET VALMHDR(2)=TIUHDR
+21 QUIT
+22 ;
INIT(CLASS,CONTEXT,DFN,TIUOCC) ; -- init variables and list array
+1 NEW TIUR,TIUI,TIUY,TIUPICK,TIUQUIT,TIUCCTXT,TIUDUZ,TIUERLY,TIULATE
+2 NEW TIUPREF,TIUOCTXT,TIURCTXT,TIUSEQ,TIUDPRM
+3 ;1/8/01
NEW DUOUT,DTOUT,DIROUT
+4 IF $GET(@VALMAR@("SEQ"))]""
SET TIUSEQ=$GET(@VALMAR@("SEQ"))
+5 IF +$GET(@VALMAR@("CTXT"))
SET TIURCTXT=$GET(@VALMAR@("CTXT"))
+6 KILL @VALMAR,VALMCNT,^TMP("TIURIDX",$JOB)
+7 ; TIU*1.0*143
KILL ^TMP("TIUYARRAY",$JOB)
+8 SET TIUPREF=$$PERSPRF^TIULE(DUZ)
+9 SET TIUSEQ=$GET(TIUSEQ,$SELECT($PIECE(TIUPREF,U,4)="A":"A",1:"D"))
+10 SET TIUPICK=+$ORDER(^ORD(101,"B","TIU ACTION SELECT LIST ELEMENT",0))
+11 SET DFN=$SELECT(+$GET(DFN):+$GET(DFN),+$GET(ORVP):+$GET(ORVP),1:+$$PATIENT^TIULA)
+12 IF $SELECT($DATA(DUOUT):1,$DATA(DTOUT):1,$DATA(DIROUT):1,+$GET(DFN)'>0:1,1:0)
SET VALMQUIT=1
QUIT
+13 IF +$GET(CONTEXT)'=9999
IF '+$GET(TIUOCC)
SET TIUOCC=$SELECT(+$PIECE(TIUPREF,U,10):+$PIECE(TIUPREF,U,10),1:100)
+14 SET ^TMP("TIUR",$JOB,"RTN")="TIUROR"
+15 IF '$ORDER(^TIU(8925,"ACLPT",CLASS,DFN,0))
IF '$ORDER(^TIU(8925,"ACLAU",CLASS,DUZ,DFN,0))
IF '$ORDER(^TIU(8925,"ACLEC",CLASS,DUZ,DFN,0))
Begin DoDot:1
+16 NEW TIUST
+17 SET TIUST=$SELECT(CONTEXT=2:"UNSIGNED ",CONTEXT=3:"UNCOSIGNED ",1:"SIGNED ")
+18 SET VALMCNT=2
SET ^TMP("TIUR",$JOB,0)=0
+19 SET ^TMP("TIUR",$JOB,1,0)=""
+20 SET ^TMP("TIUR",$JOB,2,0)="No "_TIUST_$$UP^XLFSTR($$PNAME^TIULC1(CLASS))_" Available for "_$$PTNAME^TIULC1(DFN)
+21 SET TIUOCTXT=CONTEXT
+22 IF CONTEXT=4
SET TIUOCTXT=TIUOCTXT_U_TIUDUZ
+23 IF CONTEXT=5
SET TIUOCTXT=TIUOCTXT_U_+TIUERLY_U_+TIULATE
+24 SET ^TMP("TIUR",$JOB,"SEQ")=$GET(TIUSEQ)
+25 SET ^TMP("TIUR",$JOB,"CLASS")=CLASS
SET ^("DFN")=DFN
SET ^("CTXT")=TIUOCTXT
DO HDR
End DoDot:1
if $GET(CONTEXT)'=9999
QUIT
+26 IF $GET(CONTEXT)=9999
SET TIUCCTXT=1
SET TIUOCC=9999999
+27 ; -- Set vars needed for RBLD if user ^s:
+28 SET ^TMP("TIUR",$JOB,"CLASS")=CLASS
SET ^("DFN")=DFN
SET ^("OCC")=TIUOCC
SET ^("CTXT")=+$GET(TIURCTXT)
+29 SET CONTEXT=$SELECT($GET(CONTEXT)=9999:$$ASKCTXT^TIUROR1,+$GET(CONTEXT):+$GET(CONTEXT),1:1)
+30 ; -- 1=Signed 2=Unsigned 3=Uncosigned 4=Signed/Author 5=Signed/Date --
+31 IF $SELECT($DATA(DIROUT):1,$DATA(DUOUT):1,$DATA(DTOUT):1,1:0)
DO RBLD
QUIT
+32 IF $SELECT(CONTEXT=1:1,CONTEXT=2:1,CONTEXT=3:1,1:0)
SET TIUERLY=""
SET TIULATE=""
SET TIUDUZ=DUZ
+33 IF CONTEXT=4
Begin DoDot:1
+34 SET TIUERLY=""
SET TIULATE=""
+35 SET TIUDUZ=$SELECT(+$GET(TIURCTXT)'=4:+$$AUTHOR^TIULA2(1),+$PIECE(TIURCTXT,U,2)'>0:+$$AUTHOR^TIULA2(1),+$GET(TIUCCTXT):+$$AUTHOR^TIULA2(1),1:+$PIECE(TIURCTXT,U,2))
+36 ; changed DIRUT to DTOUT. 10/20/00
IF $SELECT($DATA(DUOUT):1,$DATA(DTOUT):1,$DATA(DIROUT):1,+$GET(TIUDUZ)'>0:1,1:0)
SET TIUQUIT=1
DO RBLD
QUIT
+37 SET TIUSEQ=$SELECT(+$GET(TIUCCTXT):$PIECE($$ASKSEQ^TIULA3(TIUSEQ),U),$GET(TIUSEQ)']"":$PIECE($$ASKSEQ^TIULA3(TIUSEQ),U),1:$GET(TIUSEQ))
+38 IF $SELECT($DATA(DIROUT):1,$DATA(DUOUT):1,$DATA(DTOUT):1,1:0)
SET TIUQUIT=1
DO RBLD
End DoDot:1
if +$GET(TIUQUIT)>0
QUIT
+39 IF CONTEXT=5
Begin DoDot:1
+40 SET TIUDUZ=+$GET(DUZ)
+41 SET TIUERLY=$SELECT(+$GET(TIURCTXT)'=5:$$EDATE^TIULA("",7,""),+$PIECE(TIURCTXT,U,2)'>0:$$EDATE^TIULA("",7,""),+$GET(TIUCCTXT):$$EDATE^TIULA("",7,""),1:+$PIECE(TIURCTXT,U,2))
+42 IF $SELECT($DATA(DIROUT):1,$DATA(DUOUT):1,$DATA(DTOUT):1,1:0)
SET TIUQUIT=1
DO RBLD
QUIT
+43 SET TIUERLY=$PIECE(TIUERLY,U)
+44 SET TIULATE=$SELECT(+$GET(TIURCTXT)'=5:$$LDATE^TIULA("",7,""),+$PIECE(TIURCTXT,U,3)'>0:$$LDATE^TIULA("",7,""),+$GET(TIUCCTXT):$$LDATE^TIULA("",7,""),1:+$PIECE(TIURCTXT,U,3))
+45 IF $SELECT($DATA(DIROUT):1,$DATA(DUOUT):1,$DATA(DTOUT):1,1:0)
SET TIUQUIT=1
DO RBLD
QUIT
+46 SET TIULATE=$PIECE(TIULATE,U)
+47 IF TIUERLY>TIULATE
DO SWAP^TIUR(.TIUERLY,.TIULATE)
+48 IF $LENGTH(TIULATE,".")=1
DO EXPRANGE^TIUR(.TIUERLY,.TIULATE)
+49 SET TIUSEQ=$SELECT(+$GET(TIUCCTXT):$PIECE($$ASKSEQ^TIULA3(TIUSEQ),U),$GET(TIUSEQ)']"":$PIECE($$ASKSEQ^TIULA3(TIUSEQ),U),1:$GET(TIUSEQ))
+50 IF $SELECT($DATA(DIROUT):1,$DATA(DUOUT):1,$DATA(DTOUT):1,1:0)
SET TIUQUIT=1
DO RBLD
End DoDot:1
if +$GET(TIUQUIT)>0
QUIT
+51 IF '$GET(TIURBLD)
WRITE !,"Searching for the progress notes"
+52 NEW TIUEXPKD
+53 DO CONTEXT^TIUSRVLL(.TIUY,CLASS,CONTEXT,DFN,TIUERLY,TIULATE,TIUDUZ,TIUOCC,TIUSEQ,.TIUEXPKD)
WRITE "."
+54 ; I $D(TIUY)'>9 D Q ; original code
+55 ; TIU*1.0*143
IF $DATA(^TMP("TIUYARRAY",$JOB))'>9
Begin DoDot:1
+56 NEW TIUST
+57 SET TIUST=$SELECT(CONTEXT=2:"UNSIGNED ",CONTEXT=3:"UNCOSIGNED ",1:"SIGNED ")
+58 SET VALMCNT=2
SET ^TMP("TIUR",$JOB,0)=0
+59 SET ^TMP("TIUR",$JOB,1,0)=""
+60 SET ^TMP("TIUR",$JOB,2,0)="No "_TIUST_$$UP^XLFSTR($$PNAME^TIULC1(CLASS))_" Available for "_$$PTNAME^TIULC1(DFN)
+61 SET ^TMP("TIUR",$JOB,"CLASS")=CLASS
SET ^("DFN")=DFN
+62 SET TIUOCTXT=CONTEXT
+63 IF CONTEXT=4
SET TIUOCTXT=TIUOCTXT_U_TIUDUZ
+64 IF CONTEXT=5
SET TIUOCTXT=TIUOCTXT_U_+TIUERLY_U_+TIULATE
+65 SET ^TMP("TIUR",$JOB,"SEQ")=$GET(TIUSEQ)
+66 SET ^TMP("TIUR",$JOB,"CTXT")=$SELECT('+$GET(TIUCCTXT):"INIT",1:TIUOCTXT)
DO HDR
End DoDot:1
QUIT
+67 SET TIUI=""
+68 ; F S TIUI=$O(TIUY(TIUI)) Q:TIUI="" D ; original code
+69 ; TIU*1.0*143
FOR
SET TIUI=$ORDER(^TMP("TIUYARRAY",$JOB,TIUI))
if TIUI=""
QUIT
Begin DoDot:1
+70 NEW AUT,RDT,STAT,TITL,TIUD0,TIUD12,TIUD13,PREFIX
+71 NEW TIUGDATA
+72 ; **
SET TIUD0=$GET(^TIU(8925,+^TMP("TIUYARRAY",$JOB,TIUI),0))
SET TIUD12=$GET(^(12))
SET TIUD13=$GET(^(13))
+73 ; S TIUD0=$G(^TIU(8925,+TIUY(TIUI),0)),TIUD12=$G(^(12)),TIUD13=$G(^(13)) ; original
+74 SET VALMCNT=+$GET(VALMCNT)+1
if (VALMCNT#100'>0)
WRITE "."
+75 SET TITL=$$PNAME^TIULC1(+TIUD0)
+76 IF TITL="Addendum"
SET TITL=TITL_" to "_$$PNAME^TIULC1(+$GET(^TIU(8925,+$PIECE(TIUD0,U,6),0)))
+77 ; -- Mark ID note '<' and/or has addendum '+',
+78 ; TIU*1.0*143
SET PREFIX=$$PREFIX^TIULA2(+^TMP("TIUYARRAY",$JOB,TIUI),0)
+79 ; S PREFIX=$$PREFIX^TIULA2(+TIUY(TIUI),0) ; original
+80 SET TITL=PREFIX_TITL
+81 SET AUT=$$NAME^TIULS($$PERSNAME^TIULC1(+$PIECE(TIUD12,U,2)),"LAST,FI")
+82 SET RDT=$$DATE^TIULS(+TIUD13,"MM/DD/YY HR:MIN")
+83 SET STAT=$$LOW^XLFSTR($PIECE($GET(^TIU(8925.6,+$PIECE(TIUD0,U,5),0)),U))
+84 SET TIUR=$$SETFLD^VALM1(VALMCNT,$GET(TIUR),"NUMBER")
+85 SET TIUR=$$SETFLD^VALM1(TITL,$GET(TIUR),"TITLE")
+86 SET TIUR=$$SETFLD^VALM1(AUT,$GET(TIUR),"AUTHOR")
+87 SET TIUR=$$SETFLD^VALM1(RDT,$GET(TIUR),"REF DATE")
+88 SET TIUR=$$SETFLD^VALM1(STAT,$GET(TIUR),"STATUS")
+89 SET ^TMP("TIUR",$JOB,VALMCNT,0)=TIUR
+90 SET ^TMP("TIUR",$JOB,0)=VALMCNT
+91 ; TIU*1.0*143
SET ^TMP("TIURIDX",$JOB,VALMCNT)=VALMCNT_U_+^TMP("TIUYARRAY",$JOB,TIUI)_U_PREFIX
+92 ; S ^TMP("TIURIDX",$J,VALMCNT)=VALMCNT_U_+TIUY(TIUI)_U_PREFIX ; original
+93 ; TIU*1.0*143
SET ^TMP("TIUR",$JOB,"IEN",+^TMP("TIUYARRAY",$JOB,TIUI),VALMCNT)=""
+94 ; S ^TMP("TIUR",$J,"IEN",+TIUY(TIUI),VALMCNT)="" ;original
+95 SET ^TMP("TIUR",$JOB,"IDX",VALMCNT,VALMCNT)=""
+96 ; TIUGDATA = 0 or DA^haskid^IDparent^prmsort:
+97 ; TIU*1.0*143
SET TIUGDATA=$$IDDATA^TIURECL1(+^TMP("TIUYARRAY",$JOB,TIUI),TIUD0)
+98 ; S TIUGDATA=$$IDDATA^TIURECL1(+TIUY(TIUI),TIUD0) ; original
+99 ; TIU*1.0*143
IF $GET(TIUGDATA)
SET ^TMP("TIUR",$JOB,"IDDATA",+^TMP("TIUYARRAY",$JOB,TIUI))=TIUGDATA
+100 ; I $G(TIUGDATA) S ^TMP("TIUR",$J,"IDDATA",+TIUY(TIUI))=TIUGDATA ; original
End DoDot:1
+101 SET ^TMP("TIUR",$JOB,"#")=TIUPICK_"^1:"_+VALMCNT
+102 SET ^TMP("TIUR",$JOB,"CLASS")=CLASS
+103 SET ^TMP("TIUR",$JOB,"DFN")=DFN
+104 SET ^TMP("TIUR",$JOB,"OCC")=+$GET(TIUOCC)
+105 SET TIUOCTXT=CONTEXT
+106 IF CONTEXT=4
SET TIUOCTXT=TIUOCTXT_U_TIUDUZ
+107 IF CONTEXT=5
SET TIUOCTXT=TIUOCTXT_U_+TIUERLY_U_+TIULATE
+108 SET ^TMP("TIUR",$JOB,"SEQ")=$GET(TIUSEQ)
+109 SET ^TMP("TIUR",$JOB,"CTXT")=$SELECT('+$GET(TIUCCTXT)&(VALMCNT'<TIUOCC):"INIT",1:TIUOCTXT)
+110 IF CONTEXT=1
IF (+$GET(TIUOCC)=9999999)
DO SAVE^TIUROR1
+111 IF +$GET(TIUCCTXT)
IF $DATA(^TMP("TIUR",$JOB,0))
DO HDR
+112 ; If first build (not rebuild), expand parents to show kids that
+113 ;meet criteria:
+114 IF '$GET(TIURBLD)
IF $DATA(TIUEXPKD)
Begin DoDot:1
+115 DO EXPANDKD^TIUR2(.TIUEXPKD,"",CONTEXT)
End DoDot:1
+116 ; K ^TMP("TIUYARRAY",$J) ; TIU*1.0*143
+117 QUIT
+118 ;
EXIT ; -- exit code
+1 DO CLEAN^VALM10
+2 KILL DFN,VALMY,VALMCNT,VALMKEY,^TMP("TIURSAVE",$JOB)
+3 KILL ^TMP("TIURIDX",$JOB)
+4 ;**100**
KILL TIUGLINK
+5 QUIT
+6 ;
RBLD ; -- rebuild list after actions
+1 NEW TIUEXP,TIURBLD
+2 SET TIURBLD=1
+3 IF +$ORDER(^TMP("TIUR",$JOB,"EXPAND",0))
Begin DoDot:1
+4 MERGE TIUEXP=^TMP("TIUR",$JOB,"EXPAND")
+5 DO INIT(+$GET(^TMP("TIUR",$JOB,"CLASS")),+$GET(^("CTXT")),+$GET(^("DFN")),+$GET(^("OCC")))
+6 DO RELOAD^TIUROR1(.TIUEXP)
+7 DO BREATHE^TIUROR1(1)
End DoDot:1
GOTO RBLDX
+8 DO INIT(+$GET(^TMP("TIUR",$JOB,"CLASS")),+$GET(^("CTXT")),+$GET(^("DFN")),+$GET(^("OCC")))
+9 ;D HDR S VALMBCK="R",VALMBG=1,VALMCNT=+$G(^TMP("TIUR",$J,0))
+10 DO HDR
SET VALMBCK="R"
SET VALMCNT=+$GET(^TMP("TIUR",$JOB,0))
RBLDX IF $GET(VALMBG)>$GET(VALMCNT)
SET VALMBG=$GET(VALMCNT)
+1 QUIT
