TIUSRVLI ;SLC/JER - Server fns - lists for CPRS;Apr 06, 2021@11:27:11
;;1.0;TEXT INTEGRATION UTILITIES;**108,122,339**;Jun 20, 1997;Build 39
HASDAD(DA) ; Evaluate whether a document has a parent
Q $S(+$P($G(^TIU(8925,+DA,0)),U,6):1,+$G(^TIU(8925,+DA,21)):1,1:0)
;
SETDAD(TIUY,DA,TIUI,FLG) ; Set parent in return array
N DADA,RMVFLG,TIUD0,TIUD21
S FLG=+$G(FLG)
; Exclude components
Q:'+$$ISDOC(DA)
S TIUD0=$G(^TIU(8925,DA,0)),TIUD21=$G(^(21))
S DADA=$S(+$P(TIUD0,U,6):+$P(TIUD0,U,6),+TIUD21:+TIUD21,1:0)
Q:+DADA'>0
Q:+$D(@TIUY@("INDX",DADA))
Q:+$D(^TIU(8925,DADA,0))=0
S RMVFLG=0
I FLG S RMVFLG=$$DOREMOV(.TIUY,DADA)
Q:RMVFLG=1
S TIUI=$S(SEQUENCE="A":+$G(TIUI)-1,1:+$G(TIUI)+1)
S @TIUY@(TIUI)=DADA_U_$$RESOLVE^TIUSRVLO(DADA)
S @TIUY@("INDX",DADA,TIUI)=""
I +$G(SHOWADD) D SETKIDS(.TIUY,DADA,.TIUI,FLG)
I +$$HASDAD(DADA) D SETDAD(.TIUY,DADA,.TIUI,FLG)
Q
;
HASKIDS(DA) ; Evaluate whether a document has children
N TIUY,KIDA S (KIDA,TIUY)=0
; Check for addenda
F S KIDA=$O(^TIU(8925,"DAD",DA,KIDA)) Q:+TIUY!(+KIDA'>0) D
. I '+$$ISCOMP^TIUSRVR1(KIDA) S TIUY=1
I +TIUY G HASKIDX
; Next, look for ID Entries
S TIUY=$S(+$O(^TIU(8925,"GDAD",DA,0)):1,1:0)
HASKIDX Q TIUY
;
SETKIDS(TIUY,DA,TIUI,FLG) ; Set children in return array
N KIDA,RMVFLG
S FLG=+$G(FLG)
S RMVFLG=0
S KIDA=0
; Begin with addenda
F S KIDA=$O(^TIU(8925,"DAD",DA,KIDA)) Q:+KIDA'>0 D Q:RMVFLG=1
. Q:'+$$ISDOC(KIDA)
. Q:+$D(@TIUY@("INDX",KIDA))
. I FLG S RMVFLG=$$DOREMOV(.TIUY,KIDA)
. Q:RMVFLG=1
. S TIUI=$S(SEQUENCE="A":+$G(TIUI)-1,1:+$G(TIUI)+1)
. S @TIUY@(TIUI)=KIDA_U_$$RESOLVE^TIUSRVLO(KIDA)
. S @TIUY@("INDX",KIDA,TIUI)=""
; Next do ID entries
S KIDA=0
F S KIDA=$O(^TIU(8925,"GDAD",DA,KIDA)) Q:+KIDA'>0 D Q:RMVFLG=1
. Q:+$D(@TIUY@("INDX",KIDA))
. I FLG S RMVFLG=$$DOREMOV(.TIUY,KIDA)
. Q:RMVFLG=1
. S TIUI=$S(SEQUENCE="A":+$G(TIUI)-1,1:+$G(TIUI)+1)
. S @TIUY@(TIUI)=KIDA_U_$$RESOLVE^TIUSRVLO(KIDA)
. S @TIUY@("INDX",KIDA,TIUI)=""
. I +$$HASKIDS(KIDA) D SETKIDS(.TIUY,KIDA,.TIUI,FLG)
Q
ISDOC(DA) ; Evaluate whether a given record is a document
N TIUY,TIUTYP
S TIUTYP=+$G(^TIU(8925,DA,0))
S TIUY=$S($P($G(^TIU(8925.1,+TIUTYP,0)),U,4)="DOC":1,1:0)
Q TIUY
GETUND(TIUY,CLASS,DFN,TIME1,TIME2,TIUJ,SEQUENCE) ; Get undictated docs
N TIUTYP,TIUI,DATTIM
D DOCTYPE^TIUSRVL(.TIUTYP,CLASS) Q:+$D(TIUTYP)'>9
S TIUI=0
F S TIUI=$O(TIUTYP(TIUI)) Q:+TIUI'>0 D
. N STATUS
. F STATUS=1:1:2 D
. . S DATTIM=TIME1-.0000001
. . F S DATTIM=$O(^TIU(8925,"APT",DFN,+TIUTYP(TIUI),STATUS,DATTIM)) Q:+DATTIM'>0 D
. . . N TIUDA S TIUDA=0
. . . F S TIUDA=$O(^TIU(8925,"APT",DFN,+TIUTYP(TIUI),STATUS,DATTIM,TIUDA)) Q:+TIUDA'>0 D
. . . . Q:+$D(@TIUY@("INDX",TIUDA))
. . . . S TIUJ=$S(SEQUENCE="A":+$G(TIUJ)-1,1:+$G(TIUJ)+1)
. . . . S @TIUY@(TIUJ)=TIUDA_U_$$RESOLVE^TIUSRVLO(TIUDA)
. . . . S @TIUY@("INDX",TIUDA,TIUJ)=""
Q
DOREMOV(TIUY,DA) ;Check for need to remove previously returned data
; and perform the remove
N RMVFLG,TIUD0,TIUD1301
S RMVFLG=0
S TIUD0=$G(^TIU(8925,DA,0))
S TIUD1301=$P($G(^TIU(8925,DA,13)),U,1)
I +$G(PRVRTNDT)>0 D
. I PRVRTNDT=TIUD1301,TIUIEN>DA Q
. I PRVRTNDT>TIUD1301 Q
. I (('+$P(TIUD0,U))!('+$G(TIUD1301))!('+$P(TIUD0,U,2))!(($P(TIUD0,U,5)<6))) Q
. D RMV(.TIUY,DA)
. S RMVFLG=1
. Q
Q RMVFLG
RMV(TIUY,DA) ; Remove notes previously returned
D RMVDAD(.TIUY,DA)
D RMVKID(.TIUY,DA)
I TIUJ>0 S TIUJ=TIUJ-1
Q
RMVDAD(TIUY,DA) ; Remove parent entries
N CNT,DADA,TIUD0,TIUD21
; Exclude components
Q:'+$$ISDOC(DA)
S TIUD0=$G(^TIU(8925,DA,0)),TIUD21=$G(^(21))
S DADA=$S(+$P(TIUD0,U,6):+$P(TIUD0,U,6),+TIUD21:+TIUD21,1:0)
Q:+DADA'>0
S @TIUY@("INDX",DADA)=""
S CNT=+$O(@TIUY@("INDX",DADA,""))
Q:CNT<1
K @TIUY@(CNT)
I +$G(SHOWADD) D RMVKID(.TIUY,DADA)
I +$$HASDAD(DADA) D RMVDAD(.TIUY,DADA)
Q
RMVKID(TIUY,DA) ; Remove child notes
N CNT,KIDA
S KIDA=0
; Begin with addenda
F S KIDA=$O(^TIU(8925,"DAD",DA,KIDA)) Q:+KIDA'>0 D
. Q:'+$$ISDOC(KIDA)
. S @TIUY@("INDX",KIDA)=""
. S CNT=+$O(@TIUY@("INDX",KIDA,""))
. Q:CNT<1
. K @TIUY@(CNT)
. Q
; Next do ID entries
S KIDA=0
F S KIDA=$O(^TIU(8925,"GDAD",DA,KIDA)) Q:+KIDA'>0 D
. S @TIUY@("INDX",KIDA)=""
. S CNT=+$O(@TIUY@("INDX",KIDA,""))
. Q:CNT<1
. K @TIUY@(CNT)
. I +$$HASKIDS(KIDA) D RMVKID(.TIUY,KIDA)
. Q
Q
RESEQ(TIUY,TIUI) ; Resequence @TIUY@(TIUI) after removal of entries and reset TIUI
N ADD,ARRY,CNT,CNT1,DA,DATA
S ADD=$S(SEQUENCE="D":1,1:-1)
S ARRY=$NA(^TMP("TIURESEQ",$J))
S (CNT,CNT1)=0
F S CNT1=$O(@TIUY@(CNT1),ADD) Q:CNT1="" D
. I +CNT1=0 Q
. S CNT=CNT+ADD
. S @ARRY@(CNT)=$G(@TIUY@(CNT1))
. Q
K @TIUY
M @TIUY=@ARRY
K @ARRY
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUSRVLI 4730 printed Dec 13, 2024@02:45:51 Page 2
TIUSRVLI ;SLC/JER - Server fns - lists for CPRS;Apr 06, 2021@11:27:11
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**108,122,339**;Jun 20, 1997;Build 39
HASDAD(DA) ; Evaluate whether a document has a parent
+1 QUIT $SELECT(+$PIECE($GET(^TIU(8925,+DA,0)),U,6):1,+$GET(^TIU(8925,+DA,21)):1,1:0)
+2 ;
SETDAD(TIUY,DA,TIUI,FLG) ; Set parent in return array
+1 NEW DADA,RMVFLG,TIUD0,TIUD21
+2 SET FLG=+$GET(FLG)
+3 ; Exclude components
+4 if '+$$ISDOC(DA)
QUIT
+5 SET TIUD0=$GET(^TIU(8925,DA,0))
SET TIUD21=$GET(^(21))
+6 SET DADA=$SELECT(+$PIECE(TIUD0,U,6):+$PIECE(TIUD0,U,6),+TIUD21:+TIUD21,1:0)
+7 if +DADA'>0
QUIT
+8 if +$DATA(@TIUY@("INDX",DADA))
QUIT
+9 if +$DATA(^TIU(8925,DADA,0))=0
QUIT
+10 SET RMVFLG=0
+11 IF FLG
SET RMVFLG=$$DOREMOV(.TIUY,DADA)
+12 if RMVFLG=1
QUIT
+13 SET TIUI=$SELECT(SEQUENCE="A":+$GET(TIUI)-1,1:+$GET(TIUI)+1)
+14 SET @TIUY@(TIUI)=DADA_U_$$RESOLVE^TIUSRVLO(DADA)
+15 SET @TIUY@("INDX",DADA,TIUI)=""
+16 IF +$GET(SHOWADD)
DO SETKIDS(.TIUY,DADA,.TIUI,FLG)
+17 IF +$$HASDAD(DADA)
DO SETDAD(.TIUY,DADA,.TIUI,FLG)
+18 QUIT
+19 ;
HASKIDS(DA) ; Evaluate whether a document has children
+1 NEW TIUY,KIDA
SET (KIDA,TIUY)=0
+2 ; Check for addenda
+3 FOR
SET KIDA=$ORDER(^TIU(8925,"DAD",DA,KIDA))
if +TIUY!(+KIDA'>0)
QUIT
Begin DoDot:1
+4 IF '+$$ISCOMP^TIUSRVR1(KIDA)
SET TIUY=1
End DoDot:1
+5 IF +TIUY
GOTO HASKIDX
+6 ; Next, look for ID Entries
+7 SET TIUY=$SELECT(+$ORDER(^TIU(8925,"GDAD",DA,0)):1,1:0)
HASKIDX QUIT TIUY
+1 ;
SETKIDS(TIUY,DA,TIUI,FLG) ; Set children in return array
+1 NEW KIDA,RMVFLG
+2 SET FLG=+$GET(FLG)
+3 SET RMVFLG=0
+4 SET KIDA=0
+5 ; Begin with addenda
+6 FOR
SET KIDA=$ORDER(^TIU(8925,"DAD",DA,KIDA))
if +KIDA'>0
QUIT
Begin DoDot:1
+7 if '+$$ISDOC(KIDA)
QUIT
+8 if +$DATA(@TIUY@("INDX",KIDA))
QUIT
+9 IF FLG
SET RMVFLG=$$DOREMOV(.TIUY,KIDA)
+10 if RMVFLG=1
QUIT
+11 SET TIUI=$SELECT(SEQUENCE="A":+$GET(TIUI)-1,1:+$GET(TIUI)+1)
+12 SET @TIUY@(TIUI)=KIDA_U_$$RESOLVE^TIUSRVLO(KIDA)
+13 SET @TIUY@("INDX",KIDA,TIUI)=""
End DoDot:1
if RMVFLG=1
QUIT
+14 ; Next do ID entries
+15 SET KIDA=0
+16 FOR
SET KIDA=$ORDER(^TIU(8925,"GDAD",DA,KIDA))
if +KIDA'>0
QUIT
Begin DoDot:1
+17 if +$DATA(@TIUY@("INDX",KIDA))
QUIT
+18 IF FLG
SET RMVFLG=$$DOREMOV(.TIUY,KIDA)
+19 if RMVFLG=1
QUIT
+20 SET TIUI=$SELECT(SEQUENCE="A":+$GET(TIUI)-1,1:+$GET(TIUI)+1)
+21 SET @TIUY@(TIUI)=KIDA_U_$$RESOLVE^TIUSRVLO(KIDA)
+22 SET @TIUY@("INDX",KIDA,TIUI)=""
+23 IF +$$HASKIDS(KIDA)
DO SETKIDS(.TIUY,KIDA,.TIUI,FLG)
End DoDot:1
if RMVFLG=1
QUIT
+24 QUIT
ISDOC(DA) ; Evaluate whether a given record is a document
+1 NEW TIUY,TIUTYP
+2 SET TIUTYP=+$GET(^TIU(8925,DA,0))
+3 SET TIUY=$SELECT($PIECE($GET(^TIU(8925.1,+TIUTYP,0)),U,4)="DOC":1,1:0)
+4 QUIT TIUY
GETUND(TIUY,CLASS,DFN,TIME1,TIME2,TIUJ,SEQUENCE) ; Get undictated docs
+1 NEW TIUTYP,TIUI,DATTIM
+2 DO DOCTYPE^TIUSRVL(.TIUTYP,CLASS)
if +$DATA(TIUTYP)'>9
QUIT
+3 SET TIUI=0
+4 FOR
SET TIUI=$ORDER(TIUTYP(TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+5 NEW STATUS
+6 FOR STATUS=1:1:2
Begin DoDot:2
+7 SET DATTIM=TIME1-.0000001
+8 FOR
SET DATTIM=$ORDER(^TIU(8925,"APT",DFN,+TIUTYP(TIUI),STATUS,DATTIM))
if +DATTIM'>0
QUIT
Begin DoDot:3
+9 NEW TIUDA
SET TIUDA=0
+10 FOR
SET TIUDA=$ORDER(^TIU(8925,"APT",DFN,+TIUTYP(TIUI),STATUS,DATTIM,TIUDA))
if +TIUDA'>0
QUIT
Begin DoDot:4
+11 if +$DATA(@TIUY@("INDX",TIUDA))
QUIT
+12 SET TIUJ=$SELECT(SEQUENCE="A":+$GET(TIUJ)-1,1:+$GET(TIUJ)+1)
+13 SET @TIUY@(TIUJ)=TIUDA_U_$$RESOLVE^TIUSRVLO(TIUDA)
+14 SET @TIUY@("INDX",TIUDA,TIUJ)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
DOREMOV(TIUY,DA) ;Check for need to remove previously returned data
+1 ; and perform the remove
+2 NEW RMVFLG,TIUD0,TIUD1301
+3 SET RMVFLG=0
+4 SET TIUD0=$GET(^TIU(8925,DA,0))
+5 SET TIUD1301=$PIECE($GET(^TIU(8925,DA,13)),U,1)
+6 IF +$GET(PRVRTNDT)>0
Begin DoDot:1
+7 IF PRVRTNDT=TIUD1301
IF TIUIEN>DA
QUIT
+8 IF PRVRTNDT>TIUD1301
QUIT
+9 IF (('+$PIECE(TIUD0,U))!('+$GET(TIUD1301))!('+$PIECE(TIUD0,U,2))!(($PIECE(TIUD0,U,5)<6)))
QUIT
+10 DO RMV(.TIUY,DA)
+11 SET RMVFLG=1
+12 QUIT
End DoDot:1
+13 QUIT RMVFLG
RMV(TIUY,DA) ; Remove notes previously returned
+1 DO RMVDAD(.TIUY,DA)
+2 DO RMVKID(.TIUY,DA)
+3 IF TIUJ>0
SET TIUJ=TIUJ-1
+4 QUIT
RMVDAD(TIUY,DA) ; Remove parent entries
+1 NEW CNT,DADA,TIUD0,TIUD21
+2 ; Exclude components
+3 if '+$$ISDOC(DA)
QUIT
+4 SET TIUD0=$GET(^TIU(8925,DA,0))
SET TIUD21=$GET(^(21))
+5 SET DADA=$SELECT(+$PIECE(TIUD0,U,6):+$PIECE(TIUD0,U,6),+TIUD21:+TIUD21,1:0)
+6 if +DADA'>0
QUIT
+7 SET @TIUY@("INDX",DADA)=""
+8 SET CNT=+$ORDER(@TIUY@("INDX",DADA,""))
+9 if CNT<1
QUIT
+10 KILL @TIUY@(CNT)
+11 IF +$GET(SHOWADD)
DO RMVKID(.TIUY,DADA)
+12 IF +$$HASDAD(DADA)
DO RMVDAD(.TIUY,DADA)
+13 QUIT
RMVKID(TIUY,DA) ; Remove child notes
+1 NEW CNT,KIDA
+2 SET KIDA=0
+3 ; Begin with addenda
+4 FOR
SET KIDA=$ORDER(^TIU(8925,"DAD",DA,KIDA))
if +KIDA'>0
QUIT
Begin DoDot:1
+5 if '+$$ISDOC(KIDA)
QUIT
+6 SET @TIUY@("INDX",KIDA)=""
+7 SET CNT=+$ORDER(@TIUY@("INDX",KIDA,""))
+8 if CNT<1
QUIT
+9 KILL @TIUY@(CNT)
+10 QUIT
End DoDot:1
+11 ; Next do ID entries
+12 SET KIDA=0
+13 FOR
SET KIDA=$ORDER(^TIU(8925,"GDAD",DA,KIDA))
if +KIDA'>0
QUIT
Begin DoDot:1
+14 SET @TIUY@("INDX",KIDA)=""
+15 SET CNT=+$ORDER(@TIUY@("INDX",KIDA,""))
+16 if CNT<1
QUIT
+17 KILL @TIUY@(CNT)
+18 IF +$$HASKIDS(KIDA)
DO RMVKID(.TIUY,KIDA)
+19 QUIT
End DoDot:1
+20 QUIT
RESEQ(TIUY,TIUI) ; Resequence @TIUY@(TIUI) after removal of entries and reset TIUI
+1 NEW ADD,ARRY,CNT,CNT1,DA,DATA
+2 SET ADD=$SELECT(SEQUENCE="D":1,1:-1)
+3 SET ARRY=$NAME(^TMP("TIURESEQ",$JOB))
+4 SET (CNT,CNT1)=0
+5 FOR
SET CNT1=$ORDER(@TIUY@(CNT1),ADD)
if CNT1=""
QUIT
Begin DoDot:1
+6 IF +CNT1=0
QUIT
+7 SET CNT=CNT+ADD
+8 SET @ARRY@(CNT)=$GET(@TIUY@(CNT1))
+9 QUIT
End DoDot:1
+10 KILL @TIUY
+11 MERGE @TIUY=@ARRY
+12 KILL @ARRY
+13 QUIT
