TIUSRVLL ; SLC/JER - Server functions for LOCAL lists ;7/16/01
;;1.0;TEXT INTEGRATION UTILITIES;**1,100,121,143,194**;Jun 20, 1997
LIST(TIUY,CLASS,DFN,EARLY,LATE) ; Build List user can select from to browse
N TIUCNT,TIUDT,TIUI,TIUJ,TIUK,TIUP,TIUQ,TIUREC,TIUPRM0,TIUPRM1
N TIUPRM3,TIUT,TIUTP,XREF,TIUS,TIUCONT,TIUSTAT,TIUTYPE
I '$D(TIUPRM0) D SETPARM^TIULE
S EARLY=9999999-+$G(EARLY),TIUCNT=0
S (TIUI,LATE)=9999999-$S(+$G(LATE):+$G(LATE),1:3333333)
F S TIUI=$O(^TIU(8925,"APTCL",DFN,CLASS,TIUI)) Q:+TIUI'>0!(+TIUI>EARLY) D GATHER(.TIUY,DFN,CLASS,TIUI)
Q
GATHER(TIUY,DFN,CLASS,TIUI) ; Find/sort records for the list to browse
N TIUDA
S TIUDA=0
F S TIUDA=$O(^TIU(8925,"APTCL",DFN,CLASS,TIUI,TIUDA)) Q:+TIUDA'>0 D
. I ($P(TIUPRM0,U,6)="S"),(+$$CANDO^TIULP(TIUDA,"VIEW")'>0) Q
. I +$G(^TIU(8925,+TIUDA,0))'>0 K ^TIU(8925,"APTCL",DFN,CLASS,TIUI,TIUDA) Q
. I +$G(^TIU(8925,+TIUDA,0))=81,(+$P($G(^(0)),U,5)>5) Q
. S TIUCNT=+$G(TIUCNT)+1
. S ^TMP("TIUYLIST",$J,TIUCNT)=TIUDA,TIUY=TIUCNT ; TIU*1.0*143
. ; S TIUY(TIUCNT)=TIUDA,TIUY=TIUCNT ; pre-143 code
Q
;
CONTEXT(TIUY,CLASS,CONTEXT,DFN,EARLY,LATE,PERSON,OCCLIM,SEQUENCE,TIUEXPKD) ; main
; --- Call with: TIUY - Return array, pass by reference
; CLASS - Pointer to TIU DOCUMENT DEFINITION #8925.1
; CONTEXT - 1=All Signed (by PT),
; - 2="Unsigned (by PT&(AUTHOR!TANSCRIBER))
; - 3="Uncosigned (by PT&EXPECTED COSIGNER
; - 4="Signed notes (by PT&selected author)
; - 5="Signed notes (by PT&date range)
; DFN - Pointer to Patient (#2)
; [EARLY] - FM date/time to begin search
; [LATE] - FM date/time to end search
; [PERSON] - Pointer to file 200 (DUZ if not passed)
; [OCCLIM] - Occurrence Limit (optional)
; [SEQUENCE] - "A"=ascending (Regular date/time) (dflt)
; - "D"=descending (Reverse date/time)
; [TIUEXPKD] - Return array, pass by ref.
; TIUEXPKD(IFN)="", where we will expand IFN
; so ID kids/adda that meet criteria are
; displayed under it.
K TIUY S TIUY=0
I $G(CONTEXT)'>0 Q
I $G(CLASS)'>0 Q
S:+$G(EARLY)'>0 EARLY=0
S:+$G(LATE)'>0 LATE=5000000
S:+$G(PERSON)'>0 PERSON=DUZ
S:$G(SEQUENCE)']"" SEQUENCE="D"
S:+$G(OCCLIM)'>0 OCCLIM=9999999
S DFN=+$G(DFN)
S EARLY=9999999-EARLY,LATE=9999999-LATE ; CHANGE TO REVERSE DATES
; --------------------
I CONTEXT=1!(CONTEXT=5) D Q
. D ACLPT(.TIUY,CLASS,DFN,LATE,EARLY,OCCLIM,SEQUENCE)
; --------------------
I CONTEXT=2 D Q
. I DFN>0 D Q
. . D ACLAU(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
. F DFN=0:0 S DFN=$O(^TIU(8925,"ACLAU",CLASS,PERSON,DFN)) Q:DFN'>0 D ACLAU(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
; --------------------
I CONTEXT=3 D Q
. I DFN>0 D Q
. . D ACLEC(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
. F DFN=0:0 S DFN=$O(^TIU(8925,"ACLEC",CLASS,PERSON,DFN)) Q:DFN'>0 D ACLEC(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
; --------------------
I CONTEXT=4 D Q
. I DFN>0 D Q
. . ;VMP OIFO BAY PINES;ELR;TIU*1.0*194 REMOVED EXECUTION OF ACLSB & ADDED APTCL
. . ;D ACLSB(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
. . D APTCL^TIUSRVLL(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE)
. F S DFN=$O(^TIU(8925,"APTCL",DFN)) Q:DFN'>0 D APTCL^TIUSRVLP(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE)
. ;F DFN=0:0 S DFN=$O(^TIU(8925,"ACLSB",CLASS,PERSON,DFN)) Q:DFN'>0 D ACLSB(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
Q
;
ACLPT(ARRAY,CLASS,DFN,TIME1,TIME2,OCCLIM,SEQUENCE) ; Signed,
;by patient, [& date].
N DATTIM,DA,ROOT,TIUORDER
K ^TMP("TIUREPLACE",$J)
S ROOT=$NA(^TIU(8925,"ACLPT",CLASS,DFN))
S DATTIM=TIME1-.0000001
; Since date/time is inverted, set subscripts forward for descending:
S TIUORDER=$S(SEQUENCE="D":1,1:-1)
F S DATTIM=$O(@ROOT@(DATTIM)) Q:$S(+DATTIM'>0:1,+DATTIM>TIME2:1,+$G(^TMP("TIUREPLACE",$J))'<OCCLIM:1,1:0) D
. F DA=0:0 S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0 D
. . I +$G(^TIU(8925,+DA,0))'>0 K @ROOT@(DATTIM,DA) Q
. . I +^TIU(8925,+DA,0)=81 Q
. . ; -- Set records into ^TMP("TIUREPLACE",$J),
. . ; replacing kids w parents:
. . D REPLACE(DA,DATTIM)
; B 1
D SETARRY(.ARRAY,TIUORDER)
K ^TMP("TIUREPLACE",$J)
Q
;
SETARRY(ARRAY,TIUORDER) ; Set ARRAY(SUB)=DA, which is passed
;back to CONTEXT. ARRAY holds the right records, in the right order
;for the List Template list.
; TIUORDER=1 or -1: Set ARRAY subscripts forward 1,2 etc., or
;backward -1,-2, etc.
; Requires ^TMP("TIUREPLACE",$J),
;with ID kids or adda replaced by parents.
; B 1
N DATTIM,TIUDA,SUB
S DATTIM=0
S SUB=0
F S DATTIM=$O(^TMP("TIUREPLACE",$J,DATTIM)) Q:'DATTIM D
. S TIUDA=0
. F S TIUDA=$O(^TMP("TIUREPLACE",$J,DATTIM,TIUDA)) Q:'TIUDA D
. . S SUB=SUB+TIUORDER
. . S ^TMP("TIUYARRAY",$J,SUB)=TIUDA ; TIU*1.0*143
. . ; S ARRAY(SUB)=TIUDA ; original code
Q
;
REPLACE(TIUDA,DATTIM,EXPAND,FORGETAD) ; Populate ^TMP("TIUREPLACE",$J) with
;records that meet criteria, replacing ID kids or addenda with
;their parents.
; Requires TIUDA, DATTIM;
; opt flag FORGETAD - if 1, don't add note to the expand list
;merely because of an addendum. Used in search by title.
; Passes back array EXPAND.
; Sort by ref date/time
N IDPRNT,ADDMPRNT,ADDMGPNT,PDATTIM,GPDATTIM
S IDPRNT=+$G(^TIU(8925,TIUDA,21)) ; ID parent
I '$D(^TIU(8925,IDPRNT,0)) S IDPRNT=0
I IDPRNT S PDATTIM=+^TIU(8925,IDPRNT,13),PDATTIM=9999999-PDATTIM
S ADDMPRNT=+$P(^TIU(8925,TIUDA,0),U,6) ; assume TIUDA is not component
I '$D(^TIU(8925,ADDMPRNT,0)) S ADDMPRNT=0
I ADDMPRNT S PDATTIM=+^TIU(8925,ADDMPRNT,13),PDATTIM=9999999-PDATTIM
; -- If TIUDA is not an ID kid, not addm, just put it
; in array and quit: --
S EXPAND=+$G(EXPAND)
I 'IDPRNT,'ADDMPRNT D Q
. Q:$D(^TMP("TIUREPLACE",$J,DATTIM,TIUDA))
. S ^TMP("TIUREPLACE",$J,DATTIM,TIUDA)=""
. S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
; -- If TIUDA is an ID kid, put its parent in array:
I IDPRNT D Q
. I '$D(EXPAND(IDPRNT)) S EXPAND(IDPRNT)="",EXPAND=EXPAND+1
. Q:$D(^TMP("TIUREPLACE",$J,PDATTIM,IDPRNT))
. S ^TMP("TIUREPLACE",$J,PDATTIM,IDPRNT)=""
. S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
; -- If TIUDA is an addendum, put its parent/gprnt in array:
I ADDMPRNT D Q
. I '$G(FORGETAD),'$D(EXPAND(ADDMPRNT)) S EXPAND(ADDMPRNT)="",EXPAND=EXPAND+1
. S ADDMGPNT=+$G(^TIU(8925,ADDMPRNT,21))
. I '$D(^TIU(8925,ADDMGPNT,0)) S ADDMGPNT=0
. I ADDMGPNT D I 1
. . S GPDATTIM=+^TIU(8925,ADDMGPNT,13),GPDATTIM=9999999-GPDATTIM
. . I '$D(EXPAND(ADDMGPNT)) S EXPAND(ADDMGPNT)="",EXPAND=EXPAND+1
. . Q:$D(^TMP("TIUREPLACE",$J,GPDATTIM,ADDMGPNT))
. . S ^TMP("TIUREPLACE",$J,GPDATTIM,ADDMGPNT)=""
. . S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
. E D
. . Q:$D(^TMP("TIUREPLACE",$J,PDATTIM,ADDMPRNT))
. . S ^TMP("TIUREPLACE",$J,PDATTIM,ADDMPRNT)=""
. . S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
Q
ACLAU(ARRAY,CLASS,AUTHOR,DFN,TIME1,TIME2,SEQUENCE,TIUEXPKD) ; Unsigned
N DATTIM,DA,ROOT,TIUORDER
K ^TMP("TIUREPLACE",$J)
S ROOT=$NA(^TIU(8925,"ACLAU",CLASS,AUTHOR,DFN))
S DATTIM=TIME1-.0000001
S TIUORDER=$S(SEQUENCE="D":1,1:-1)
F S DATTIM=$O(@ROOT@(DATTIM)) Q:DATTIM'>0!(DATTIM>TIME2) D
. S DA=0 F S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0 D
. . I +$P($G(^TIU(8925,DA,0)),U,5)>6 K @ROOT@(DATTIM,DA) Q
. . I +$G(^TIU(8925,DA,0))'>0 K @ROOT@(DATTIM,DA) Q
. . ; Don't include ID kids or parents in top level of list;
. . ; Do expand kids
. . D REPLACE(DA,DATTIM,.TIUEXPKD)
D SETARRY(.ARRAY,TIUORDER)
K ^TMP("TIUREPLACE",$J)
Q
ACLEC(ARRAY,CLASS,EXCOSIGN,DFN,TIME1,TIME2,SEQUENCE,TIUEXPKD) ; Uncosigned
N DATTIM,DA,ROOT,TIUORDER
K ^TMP("TIUREPLACE",$J)
S ROOT=$NA(^TIU(8925,"ACLEC",CLASS,EXCOSIGN,DFN))
S DATTIM=TIME1-.0000001
S TIUORDER=$S(SEQUENCE="D":1,1:-1)
F S DATTIM=$O(@ROOT@(DATTIM)) Q:DATTIM'>0!(DATTIM>TIME2) D
. S DA=0 F S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0 D
. . I +$G(^TIU(8925,DA,0))'>0 K @ROOT@(DATTIM,DA)
. . D REPLACE(DA,DATTIM,.TIUEXPKD)
D SETARRY(.ARRAY,TIUORDER)
K ^TMP("TIUREPLACE",$J)
Q
ACLSB(ARRAY,CLASS,SIGNEDBY,DFN,TIME1,TIME2,SEQUENCE,TIUEXPKD) ; Signed, by author
N DATTIM,DA,ROOT,TIUORDER
K ^TMP("TIUREPLACE",$J)
S ROOT=$NA(^TIU(8925,"ACLSB",CLASS,SIGNEDBY,DFN))
S DATTIM=TIME1-.0000001
S TIUORDER=$S(SEQUENCE="D":1,1:-1)
F S DATTIM=$O(@ROOT@(DATTIM)) Q:DATTIM'>0!(DATTIM>TIME2) D
. S DA=0 F S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0 D
. . I +$G(^TIU(8925,DA,0))'>0 K @ROOT@(DATTIM,DA)
. . D REPLACE(DA,DATTIM,.TIUEXPKD)
D SETARRY(.ARRAY,TIUORDER)
K ^TMP("TIUREPLACE",$J)
Q
;VMP OIFO BAY PINES;ELR;TIU*1.0*194 ADDED NEXT TAG
APTCL(ARRAY,CLASS,TIUAUTH,DFN,TIME1,TIME2,SEQUENCE,TIUEXPKD) ; Signed, by author
N DATTIM,DA,ROOT,TIUORDER,TIUS12,TIUS15
K ^TMP("TIUREPLACE",$J)
S ROOT=$NA(^TIU(8925,"APTCL",DFN,CLASS))
S DATTIM=TIME1-.0000001
S TIUORDER=$S(SEQUENCE="D":1,1:-1)
F S DATTIM=$O(@ROOT@(DATTIM)) Q:DATTIM'>0!(DATTIM>TIME2) D
. S DA=0 F S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0 D
. . I +$G(^TIU(8925,DA,0))'>0 K @ROOT@(DATTIM,DA)
. . S TIUS12=$G(^TIU(8925,DA,12))
. . Q:+$P(TIUS12,U,2)'=TIUAUTH ;See if this is the authors note
. . S TIUS15=$G(^TIU(8925,DA,15))
. . Q:+$P(TIUS15,U,2)'>0 ;See if signed
. . D REPLACE(DA,DATTIM,.TIUEXPKD)
D SETARRY(.ARRAY,TIUORDER)
K ^TMP("TIUREPLACE",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUSRVLL 9718 printed Oct 16, 2024@18:46:27 Page 2
TIUSRVLL ; SLC/JER - Server functions for LOCAL lists ;7/16/01
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1,100,121,143,194**;Jun 20, 1997
LIST(TIUY,CLASS,DFN,EARLY,LATE) ; Build List user can select from to browse
+1 NEW TIUCNT,TIUDT,TIUI,TIUJ,TIUK,TIUP,TIUQ,TIUREC,TIUPRM0,TIUPRM1
+2 NEW TIUPRM3,TIUT,TIUTP,XREF,TIUS,TIUCONT,TIUSTAT,TIUTYPE
+3 IF '$DATA(TIUPRM0)
DO SETPARM^TIULE
+4 SET EARLY=9999999-+$GET(EARLY)
SET TIUCNT=0
+5 SET (TIUI,LATE)=9999999-$SELECT(+$GET(LATE):+$GET(LATE),1:3333333)
+6 FOR
SET TIUI=$ORDER(^TIU(8925,"APTCL",DFN,CLASS,TIUI))
if +TIUI'>0!(+TIUI>EARLY)
QUIT
DO GATHER(.TIUY,DFN,CLASS,TIUI)
+7 QUIT
GATHER(TIUY,DFN,CLASS,TIUI) ; Find/sort records for the list to browse
+1 NEW TIUDA
+2 SET TIUDA=0
+3 FOR
SET TIUDA=$ORDER(^TIU(8925,"APTCL",DFN,CLASS,TIUI,TIUDA))
if +TIUDA'>0
QUIT
Begin DoDot:1
+4 IF ($PIECE(TIUPRM0,U,6)="S")
IF (+$$CANDO^TIULP(TIUDA,"VIEW")'>0)
QUIT
+5 IF +$GET(^TIU(8925,+TIUDA,0))'>0
KILL ^TIU(8925,"APTCL",DFN,CLASS,TIUI,TIUDA)
QUIT
+6 IF +$GET(^TIU(8925,+TIUDA,0))=81
IF (+$PIECE($GET(^(0)),U,5)>5)
QUIT
+7 SET TIUCNT=+$GET(TIUCNT)+1
+8 ; TIU*1.0*143
SET ^TMP("TIUYLIST",$JOB,TIUCNT)=TIUDA
SET TIUY=TIUCNT
+9 ; S TIUY(TIUCNT)=TIUDA,TIUY=TIUCNT ; pre-143 code
End DoDot:1
+10 QUIT
+11 ;
CONTEXT(TIUY,CLASS,CONTEXT,DFN,EARLY,LATE,PERSON,OCCLIM,SEQUENCE,TIUEXPKD) ; main
+1 ; --- Call with: TIUY - Return array, pass by reference
+2 ; CLASS - Pointer to TIU DOCUMENT DEFINITION #8925.1
+3 ; CONTEXT - 1=All Signed (by PT),
+4 ; - 2="Unsigned (by PT&(AUTHOR!TANSCRIBER))
+5 ; - 3="Uncosigned (by PT&EXPECTED COSIGNER
+6 ; - 4="Signed notes (by PT&selected author)
+7 ; - 5="Signed notes (by PT&date range)
+8 ; DFN - Pointer to Patient (#2)
+9 ; [EARLY] - FM date/time to begin search
+10 ; [LATE] - FM date/time to end search
+11 ; [PERSON] - Pointer to file 200 (DUZ if not passed)
+12 ; [OCCLIM] - Occurrence Limit (optional)
+13 ; [SEQUENCE] - "A"=ascending (Regular date/time) (dflt)
+14 ; - "D"=descending (Reverse date/time)
+15 ; [TIUEXPKD] - Return array, pass by ref.
+16 ; TIUEXPKD(IFN)="", where we will expand IFN
+17 ; so ID kids/adda that meet criteria are
+18 ; displayed under it.
+19 KILL TIUY
SET TIUY=0
+20 IF $GET(CONTEXT)'>0
QUIT
+21 IF $GET(CLASS)'>0
QUIT
+22 if +$GET(EARLY)'>0
SET EARLY=0
+23 if +$GET(LATE)'>0
SET LATE=5000000
+24 if +$GET(PERSON)'>0
SET PERSON=DUZ
+25 if $GET(SEQUENCE)']""
SET SEQUENCE="D"
+26 if +$GET(OCCLIM)'>0
SET OCCLIM=9999999
+27 SET DFN=+$GET(DFN)
+28 ; CHANGE TO REVERSE DATES
SET EARLY=9999999-EARLY
SET LATE=9999999-LATE
+29 ; --------------------
+30 IF CONTEXT=1!(CONTEXT=5)
Begin DoDot:1
+31 DO ACLPT(.TIUY,CLASS,DFN,LATE,EARLY,OCCLIM,SEQUENCE)
End DoDot:1
QUIT
+32 ; --------------------
+33 IF CONTEXT=2
Begin DoDot:1
+34 IF DFN>0
Begin DoDot:2
+35 DO ACLAU(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
End DoDot:2
QUIT
+36 FOR DFN=0:0
SET DFN=$ORDER(^TIU(8925,"ACLAU",CLASS,PERSON,DFN))
if DFN'>0
QUIT
DO ACLAU(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
End DoDot:1
QUIT
+37 ; --------------------
+38 IF CONTEXT=3
Begin DoDot:1
+39 IF DFN>0
Begin DoDot:2
+40 DO ACLEC(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
End DoDot:2
QUIT
+41 FOR DFN=0:0
SET DFN=$ORDER(^TIU(8925,"ACLEC",CLASS,PERSON,DFN))
if DFN'>0
QUIT
DO ACLEC(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
End DoDot:1
QUIT
+42 ; --------------------
+43 IF CONTEXT=4
Begin DoDot:1
+44 IF DFN>0
Begin DoDot:2
+45 ;VMP OIFO BAY PINES;ELR;TIU*1.0*194 REMOVED EXECUTION OF ACLSB & ADDED APTCL
+46 ;D ACLSB(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
+47 DO APTCL^TIUSRVLL(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE)
End DoDot:2
QUIT
+48 FOR
SET DFN=$ORDER(^TIU(8925,"APTCL",DFN))
if DFN'>0
QUIT
DO APTCL^TIUSRVLP(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE)
+49 ;F DFN=0:0 S DFN=$O(^TIU(8925,"ACLSB",CLASS,PERSON,DFN)) Q:DFN'>0 D ACLSB(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
End DoDot:1
QUIT
+50 QUIT
+51 ;
ACLPT(ARRAY,CLASS,DFN,TIME1,TIME2,OCCLIM,SEQUENCE) ; Signed,
+1 ;by patient, [& date].
+2 NEW DATTIM,DA,ROOT,TIUORDER
+3 KILL ^TMP("TIUREPLACE",$JOB)
+4 SET ROOT=$NAME(^TIU(8925,"ACLPT",CLASS,DFN))
+5 SET DATTIM=TIME1-.0000001
+6 ; Since date/time is inverted, set subscripts forward for descending:
+7 SET TIUORDER=$SELECT(SEQUENCE="D":1,1:-1)
+8 FOR
SET DATTIM=$ORDER(@ROOT@(DATTIM))
if $SELECT(+DATTIM'>0
QUIT
Begin DoDot:1
+9 FOR DA=0:0
SET DA=$ORDER(@ROOT@(DATTIM,DA))
if DA'>0
QUIT
Begin DoDot:2
+10 IF +$GET(^TIU(8925,+DA,0))'>0
KILL @ROOT@(DATTIM,DA)
QUIT
+11 IF +^TIU(8925,+DA,0)=81
QUIT
+12 ; -- Set records into ^TMP("TIUREPLACE",$J),
+13 ; replacing kids w parents:
+14 DO REPLACE(DA,DATTIM)
End DoDot:2
End DoDot:1
+15 ; B 1
+16 DO SETARRY(.ARRAY,TIUORDER)
+17 KILL ^TMP("TIUREPLACE",$JOB)
+18 QUIT
+19 ;
SETARRY(ARRAY,TIUORDER) ; Set ARRAY(SUB)=DA, which is passed
+1 ;back to CONTEXT. ARRAY holds the right records, in the right order
+2 ;for the List Template list.
+3 ; TIUORDER=1 or -1: Set ARRAY subscripts forward 1,2 etc., or
+4 ;backward -1,-2, etc.
+5 ; Requires ^TMP("TIUREPLACE",$J),
+6 ;with ID kids or adda replaced by parents.
+7 ; B 1
+8 NEW DATTIM,TIUDA,SUB
+9 SET DATTIM=0
+10 SET SUB=0
+11 FOR
SET DATTIM=$ORDER(^TMP("TIUREPLACE",$JOB,DATTIM))
if 'DATTIM
QUIT
Begin DoDot:1
+12 SET TIUDA=0
+13 FOR
SET TIUDA=$ORDER(^TMP("TIUREPLACE",$JOB,DATTIM,TIUDA))
if 'TIUDA
QUIT
Begin DoDot:2
+14 SET SUB=SUB+TIUORDER
+15 ; TIU*1.0*143
SET ^TMP("TIUYARRAY",$JOB,SUB)=TIUDA
+16 ; S ARRAY(SUB)=TIUDA ; original code
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
REPLACE(TIUDA,DATTIM,EXPAND,FORGETAD) ; Populate ^TMP("TIUREPLACE",$J) with
+1 ;records that meet criteria, replacing ID kids or addenda with
+2 ;their parents.
+3 ; Requires TIUDA, DATTIM;
+4 ; opt flag FORGETAD - if 1, don't add note to the expand list
+5 ;merely because of an addendum. Used in search by title.
+6 ; Passes back array EXPAND.
+7 ; Sort by ref date/time
+8 NEW IDPRNT,ADDMPRNT,ADDMGPNT,PDATTIM,GPDATTIM
+9 ; ID parent
SET IDPRNT=+$GET(^TIU(8925,TIUDA,21))
+10 IF '$DATA(^TIU(8925,IDPRNT,0))
SET IDPRNT=0
+11 IF IDPRNT
SET PDATTIM=+^TIU(8925,IDPRNT,13)
SET PDATTIM=9999999-PDATTIM
+12 ; assume TIUDA is not component
SET ADDMPRNT=+$PIECE(^TIU(8925,TIUDA,0),U,6)
+13 IF '$DATA(^TIU(8925,ADDMPRNT,0))
SET ADDMPRNT=0
+14 IF ADDMPRNT
SET PDATTIM=+^TIU(8925,ADDMPRNT,13)
SET PDATTIM=9999999-PDATTIM
+15 ; -- If TIUDA is not an ID kid, not addm, just put it
+16 ; in array and quit: --
+17 SET EXPAND=+$GET(EXPAND)
+18 IF 'IDPRNT
IF 'ADDMPRNT
Begin DoDot:1
+19 if $DATA(^TMP("TIUREPLACE",$JOB,DATTIM,TIUDA))
QUIT
+20 SET ^TMP("TIUREPLACE",$JOB,DATTIM,TIUDA)=""
+21 SET ^TMP("TIUREPLACE",$JOB)=$GET(^TMP("TIUREPLACE",$JOB))+1
End DoDot:1
QUIT
+22 ; -- If TIUDA is an ID kid, put its parent in array:
+23 IF IDPRNT
Begin DoDot:1
+24 IF '$DATA(EXPAND(IDPRNT))
SET EXPAND(IDPRNT)=""
SET EXPAND=EXPAND+1
+25 if $DATA(^TMP("TIUREPLACE",$JOB,PDATTIM,IDPRNT))
QUIT
+26 SET ^TMP("TIUREPLACE",$JOB,PDATTIM,IDPRNT)=""
+27 SET ^TMP("TIUREPLACE",$JOB)=$GET(^TMP("TIUREPLACE",$JOB))+1
End DoDot:1
QUIT
+28 ; -- If TIUDA is an addendum, put its parent/gprnt in array:
+29 IF ADDMPRNT
Begin DoDot:1
+30 IF '$GET(FORGETAD)
IF '$DATA(EXPAND(ADDMPRNT))
SET EXPAND(ADDMPRNT)=""
SET EXPAND=EXPAND+1
+31 SET ADDMGPNT=+$GET(^TIU(8925,ADDMPRNT,21))
+32 IF '$DATA(^TIU(8925,ADDMGPNT,0))
SET ADDMGPNT=0
+33 IF ADDMGPNT
Begin DoDot:2
+34 SET GPDATTIM=+^TIU(8925,ADDMGPNT,13)
SET GPDATTIM=9999999-GPDATTIM
+35 IF '$DATA(EXPAND(ADDMGPNT))
SET EXPAND(ADDMGPNT)=""
SET EXPAND=EXPAND+1
+36 if $DATA(^TMP("TIUREPLACE",$JOB,GPDATTIM,ADDMGPNT))
QUIT
+37 SET ^TMP("TIUREPLACE",$JOB,GPDATTIM,ADDMGPNT)=""
+38 SET ^TMP("TIUREPLACE",$JOB)=$GET(^TMP("TIUREPLACE",$JOB))+1
End DoDot:2
IF 1
+39 IF '$TEST
Begin DoDot:2
+40 if $DATA(^TMP("TIUREPLACE",$JOB,PDATTIM,ADDMPRNT))
QUIT
+41 SET ^TMP("TIUREPLACE",$JOB,PDATTIM,ADDMPRNT)=""
+42 SET ^TMP("TIUREPLACE",$JOB)=$GET(^TMP("TIUREPLACE",$JOB))+1
End DoDot:2
End DoDot:1
QUIT
+43 QUIT
ACLAU(ARRAY,CLASS,AUTHOR,DFN,TIME1,TIME2,SEQUENCE,TIUEXPKD) ; Unsigned
+1 NEW DATTIM,DA,ROOT,TIUORDER
+2 KILL ^TMP("TIUREPLACE",$JOB)
+3 SET ROOT=$NAME(^TIU(8925,"ACLAU",CLASS,AUTHOR,DFN))
+4 SET DATTIM=TIME1-.0000001
+5 SET TIUORDER=$SELECT(SEQUENCE="D":1,1:-1)
+6 FOR
SET DATTIM=$ORDER(@ROOT@(DATTIM))
if DATTIM'>0!(DATTIM>TIME2)
QUIT
Begin DoDot:1
+7 SET DA=0
FOR
SET DA=$ORDER(@ROOT@(DATTIM,DA))
if DA'>0
QUIT
Begin DoDot:2
+8 IF +$PIECE($GET(^TIU(8925,DA,0)),U,5)>6
KILL @ROOT@(DATTIM,DA)
QUIT
+9 IF +$GET(^TIU(8925,DA,0))'>0
KILL @ROOT@(DATTIM,DA)
QUIT
+10 ; Don't include ID kids or parents in top level of list;
+11 ; Do expand kids
+12 DO REPLACE(DA,DATTIM,.TIUEXPKD)
End DoDot:2
End DoDot:1
+13 DO SETARRY(.ARRAY,TIUORDER)
+14 KILL ^TMP("TIUREPLACE",$JOB)
+15 QUIT
ACLEC(ARRAY,CLASS,EXCOSIGN,DFN,TIME1,TIME2,SEQUENCE,TIUEXPKD) ; Uncosigned
+1 NEW DATTIM,DA,ROOT,TIUORDER
+2 KILL ^TMP("TIUREPLACE",$JOB)
+3 SET ROOT=$NAME(^TIU(8925,"ACLEC",CLASS,EXCOSIGN,DFN))
+4 SET DATTIM=TIME1-.0000001
+5 SET TIUORDER=$SELECT(SEQUENCE="D":1,1:-1)
+6 FOR
SET DATTIM=$ORDER(@ROOT@(DATTIM))
if DATTIM'>0!(DATTIM>TIME2)
QUIT
Begin DoDot:1
+7 SET DA=0
FOR
SET DA=$ORDER(@ROOT@(DATTIM,DA))
if DA'>0
QUIT
Begin DoDot:2
+8 IF +$GET(^TIU(8925,DA,0))'>0
KILL @ROOT@(DATTIM,DA)
+9 DO REPLACE(DA,DATTIM,.TIUEXPKD)
End DoDot:2
End DoDot:1
+10 DO SETARRY(.ARRAY,TIUORDER)
+11 KILL ^TMP("TIUREPLACE",$JOB)
+12 QUIT
ACLSB(ARRAY,CLASS,SIGNEDBY,DFN,TIME1,TIME2,SEQUENCE,TIUEXPKD) ; Signed, by author
+1 NEW DATTIM,DA,ROOT,TIUORDER
+2 KILL ^TMP("TIUREPLACE",$JOB)
+3 SET ROOT=$NAME(^TIU(8925,"ACLSB",CLASS,SIGNEDBY,DFN))
+4 SET DATTIM=TIME1-.0000001
+5 SET TIUORDER=$SELECT(SEQUENCE="D":1,1:-1)
+6 FOR
SET DATTIM=$ORDER(@ROOT@(DATTIM))
if DATTIM'>0!(DATTIM>TIME2)
QUIT
Begin DoDot:1
+7 SET DA=0
FOR
SET DA=$ORDER(@ROOT@(DATTIM,DA))
if DA'>0
QUIT
Begin DoDot:2
+8 IF +$GET(^TIU(8925,DA,0))'>0
KILL @ROOT@(DATTIM,DA)
+9 DO REPLACE(DA,DATTIM,.TIUEXPKD)
End DoDot:2
End DoDot:1
+10 DO SETARRY(.ARRAY,TIUORDER)
+11 KILL ^TMP("TIUREPLACE",$JOB)
+12 QUIT
+13 ;VMP OIFO BAY PINES;ELR;TIU*1.0*194 ADDED NEXT TAG
APTCL(ARRAY,CLASS,TIUAUTH,DFN,TIME1,TIME2,SEQUENCE,TIUEXPKD) ; Signed, by author
+1 NEW DATTIM,DA,ROOT,TIUORDER,TIUS12,TIUS15
+2 KILL ^TMP("TIUREPLACE",$JOB)
+3 SET ROOT=$NAME(^TIU(8925,"APTCL",DFN,CLASS))
+4 SET DATTIM=TIME1-.0000001
+5 SET TIUORDER=$SELECT(SEQUENCE="D":1,1:-1)
+6 FOR
SET DATTIM=$ORDER(@ROOT@(DATTIM))
if DATTIM'>0!(DATTIM>TIME2)
QUIT
Begin DoDot:1
+7 SET DA=0
FOR
SET DA=$ORDER(@ROOT@(DATTIM,DA))
if DA'>0
QUIT
Begin DoDot:2
+8 IF +$GET(^TIU(8925,DA,0))'>0
KILL @ROOT@(DATTIM,DA)
+9 SET TIUS12=$GET(^TIU(8925,DA,12))
+10 ;See if this is the authors note
if +$PIECE(TIUS12,U,2)'=TIUAUTH
QUIT
+11 SET TIUS15=$GET(^TIU(8925,DA,15))
+12 ;See if signed
if +$PIECE(TIUS15,U,2)'>0
QUIT
+13 DO REPLACE(DA,DATTIM,.TIUEXPKD)
End DoDot:2
End DoDot:1
+14 DO SETARRY(.ARRAY,TIUORDER)
+15 KILL ^TMP("TIUREPLACE",$JOB)
+16 QUIT
