Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: TIUSRVLL

TIUSRVLL.m

Go to the documentation of this file. 
  1. 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
  1. LIST(TIUY,CLASS,DFN,EARLY,LATE) ; Build List user can select from to browse
  1.  N TIUCNT,TIUDT,TIUI,TIUJ,TIUK,TIUP,TIUQ,TIUREC,TIUPRM0,TIUPRM1
  1.  N TIUPRM3,TIUT,TIUTP,XREF,TIUS,TIUCONT,TIUSTAT,TIUTYPE
  1.  I '$D(TIUPRM0) D SETPARM^TIULE
  1.  S EARLY=9999999-+$G(EARLY),TIUCNT=0
  1.  S (TIUI,LATE)=9999999-$S(+$G(LATE):+$G(LATE),1:3333333)
  1.  F  S TIUI=$O(^TIU(8925,"APTCL",DFN,CLASS,TIUI)) Q:+TIUI'>0!(+TIUI>EARLY)  D GATHER(.TIUY,DFN,CLASS,TIUI)
  1.  Q
  1. GATHER(TIUY,DFN,CLASS,TIUI) ; Find/sort records for the list to browse
  1.  N TIUDA
  1.  S TIUDA=0
  1.  F  S TIUDA=$O(^TIU(8925,"APTCL",DFN,CLASS,TIUI,TIUDA)) Q:+TIUDA'>0  D
  1.  . I ($P(TIUPRM0,U,6)="S"),(+$$CANDO^TIULP(TIUDA,"VIEW")'>0) Q
  1.  . I +$G(^TIU(8925,+TIUDA,0))'>0 K ^TIU(8925,"APTCL",DFN,CLASS,TIUI,TIUDA) Q
  1.  . I +$G(^TIU(8925,+TIUDA,0))=81,(+$P($G(^(0)),U,5)>5) Q
  1.  . S TIUCNT=+$G(TIUCNT)+1
  1.  . S ^TMP("TIUYLIST",$J,TIUCNT)=TIUDA,TIUY=TIUCNT ; TIU*1.0*143
  1.  . ; S TIUY(TIUCNT)=TIUDA,TIUY=TIUCNT ; pre-143 code
  1.  Q
  1.  ;
  1. CONTEXT(TIUY,CLASS,CONTEXT,DFN,EARLY,LATE,PERSON,OCCLIM,SEQUENCE,TIUEXPKD) ; main
  1.  ; --- Call with:  TIUY     - Return array, pass by reference
  1.  ;                 CLASS    - Pointer to TIU DOCUMENT DEFINITION #8925.1
  1.  ;                 CONTEXT  - 1=All Signed (by PT),
  1.  ;                          - 2="Unsigned (by PT&(AUTHOR!TANSCRIBER))
  1.  ;                          - 3="Uncosigned (by PT&EXPECTED COSIGNER
  1.  ;                          - 4="Signed notes (by PT&selected author)
  1.  ;                          - 5="Signed notes (by PT&date range)
  1.  ;                 DFN      - Pointer to Patient (#2)
  1.  ;                [EARLY]   - FM date/time to begin search
  1.  ;                [LATE]    - FM date/time to end search
  1.  ;                [PERSON]  - Pointer to file 200 (DUZ if not passed)
  1.  ;                [OCCLIM]  - Occurrence Limit (optional)
  1.  ;               [SEQUENCE] - "A"=ascending (Regular date/time) (dflt)
  1.  ;                          - "D"=descending (Reverse date/time)
  1.  ;               [TIUEXPKD] - Return array, pass by ref.
  1.  ;                            TIUEXPKD(IFN)="", where we will expand IFN
  1.  ;                            so ID kids/adda that meet criteria are
  1.  ;                            displayed under it.
  1.  K TIUY S TIUY=0
  1.  I $G(CONTEXT)'>0 Q
  1.  I $G(CLASS)'>0 Q
  1.  S:+$G(EARLY)'>0 EARLY=0
  1.  S:+$G(LATE)'>0 LATE=5000000
  1.  S:+$G(PERSON)'>0 PERSON=DUZ
  1.  S:$G(SEQUENCE)']"" SEQUENCE="D"
  1.  S:+$G(OCCLIM)'>0 OCCLIM=9999999
  1.  S DFN=+$G(DFN)
  1.  S EARLY=9999999-EARLY,LATE=9999999-LATE ; CHANGE TO REVERSE DATES
  1.  ; --------------------
  1.  I CONTEXT=1!(CONTEXT=5) D  Q
  1.  . D ACLPT(.TIUY,CLASS,DFN,LATE,EARLY,OCCLIM,SEQUENCE)
  1.  ; --------------------
  1.  I CONTEXT=2 D  Q
  1.  . I DFN>0 D  Q
  1.  . . D ACLAU(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
  1.  . 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)
  1.  ; --------------------
  1.  I CONTEXT=3 D  Q
  1.  . I DFN>0 D  Q
  1.  . . D ACLEC(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
  1.  . 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)
  1.  ; --------------------
  1.  I CONTEXT=4 D  Q
  1.  . I DFN>0 D  Q
  1.  . . ;VMP OIFO BAY PINES;ELR;TIU*1.0*194 REMOVED EXECUTION OF ACLSB & ADDED APTCL
  1.  . . ;D ACLSB(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
  1.  . . D APTCL^TIUSRVLL(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE)
  1.  . F  S DFN=$O(^TIU(8925,"APTCL",DFN)) Q:DFN'>0  D APTCL^TIUSRVLP(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE)
  1.  . ;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)
  1.  Q
  1.  ;
  1. ACLPT(ARRAY,CLASS,DFN,TIME1,TIME2,OCCLIM,SEQUENCE) ; Signed,
  1.  ;by patient, [& date].
  1.  N DATTIM,DA,ROOT,TIUORDER
  1.  K ^TMP("TIUREPLACE",$J)
  1.  S ROOT=$NA(^TIU(8925,"ACLPT",CLASS,DFN))
  1.  S DATTIM=TIME1-.0000001
  1.  ; Since date/time is inverted, set subscripts forward for descending:
  1.  S TIUORDER=$S(SEQUENCE="D":1,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
  1.  . F DA=0:0 S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0  D
  1.  . . I +$G(^TIU(8925,+DA,0))'>0 K @ROOT@(DATTIM,DA) Q
  1.  . . I +^TIU(8925,+DA,0)=81 Q
  1.  . . ; -- Set records into ^TMP("TIUREPLACE",$J),
  1.  . . ;    replacing kids w parents:
  1.  . . D REPLACE(DA,DATTIM)
  1.  ; B 1
  1.  D SETARRY(.ARRAY,TIUORDER)
  1.  K ^TMP("TIUREPLACE",$J)
  1.  Q
  1.  ;
  1. SETARRY(ARRAY,TIUORDER) ; Set ARRAY(SUB)=DA, which is passed
  1.  ;back to CONTEXT.  ARRAY holds the right records, in the right order
  1.  ;for the List Template list.
  1.  ; TIUORDER=1 or -1: Set ARRAY subscripts forward 1,2 etc., or
  1.  ;backward -1,-2, etc.
  1.  ; Requires ^TMP("TIUREPLACE",$J),
  1.  ;with ID kids or adda replaced by parents.
  1.  ; B 1
  1.  N DATTIM,TIUDA,SUB
  1.  S DATTIM=0
  1.  S SUB=0
  1.  F  S DATTIM=$O(^TMP("TIUREPLACE",$J,DATTIM)) Q:'DATTIM  D
  1.  . S TIUDA=0
  1.  . F  S TIUDA=$O(^TMP("TIUREPLACE",$J,DATTIM,TIUDA)) Q:'TIUDA  D
  1.  . . S SUB=SUB+TIUORDER
  1.  . . S ^TMP("TIUYARRAY",$J,SUB)=TIUDA ; TIU*1.0*143
  1.  . . ; S ARRAY(SUB)=TIUDA ; original code
  1.  Q
  1.  ;
  1. REPLACE(TIUDA,DATTIM,EXPAND,FORGETAD) ; Populate ^TMP("TIUREPLACE",$J) with
  1.  ;records that meet criteria, replacing ID kids or addenda with
  1.  ;their parents.
  1.  ; Requires TIUDA, DATTIM;
  1.  ; opt flag FORGETAD - if 1, don't add note to the expand list
  1.  ;merely because of an addendum.  Used in search by title.
  1.  ; Passes back array EXPAND.
  1.  ; Sort by ref date/time
  1.  N IDPRNT,ADDMPRNT,ADDMGPNT,PDATTIM,GPDATTIM
  1.  S IDPRNT=+$G(^TIU(8925,TIUDA,21)) ; ID parent
  1.  I '$D(^TIU(8925,IDPRNT,0)) S IDPRNT=0
  1.  I IDPRNT S PDATTIM=+^TIU(8925,IDPRNT,13),PDATTIM=9999999-PDATTIM
  1.  S ADDMPRNT=+$P(^TIU(8925,TIUDA,0),U,6) ; assume TIUDA is not component
  1.  I '$D(^TIU(8925,ADDMPRNT,0)) S ADDMPRNT=0
  1.  I ADDMPRNT S PDATTIM=+^TIU(8925,ADDMPRNT,13),PDATTIM=9999999-PDATTIM
  1.  ; -- If TIUDA is not an ID kid, not addm, just put it
  1.  ;    in array and quit: --
  1.  S EXPAND=+$G(EXPAND)
  1.  I 'IDPRNT,'ADDMPRNT D  Q
  1.  . Q:$D(^TMP("TIUREPLACE",$J,DATTIM,TIUDA))
  1.  . S ^TMP("TIUREPLACE",$J,DATTIM,TIUDA)=""
  1.  . S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
  1.  ; -- If TIUDA is an ID kid, put its parent in array:
  1.  I IDPRNT D  Q
  1.  . I '$D(EXPAND(IDPRNT)) S EXPAND(IDPRNT)="",EXPAND=EXPAND+1
  1.  . Q:$D(^TMP("TIUREPLACE",$J,PDATTIM,IDPRNT))
  1.  . S ^TMP("TIUREPLACE",$J,PDATTIM,IDPRNT)=""
  1.  . S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
  1.  ; -- If TIUDA is an addendum, put its parent/gprnt in array:
  1.  I ADDMPRNT D  Q
  1.  . I '$G(FORGETAD),'$D(EXPAND(ADDMPRNT)) S EXPAND(ADDMPRNT)="",EXPAND=EXPAND+1
  1.  . S ADDMGPNT=+$G(^TIU(8925,ADDMPRNT,21))
  1.  . I '$D(^TIU(8925,ADDMGPNT,0)) S ADDMGPNT=0
  1.  . I ADDMGPNT D  I 1
  1.  . . S GPDATTIM=+^TIU(8925,ADDMGPNT,13),GPDATTIM=9999999-GPDATTIM
  1.  . . I '$D(EXPAND(ADDMGPNT)) S EXPAND(ADDMGPNT)="",EXPAND=EXPAND+1
  1.  . . Q:$D(^TMP("TIUREPLACE",$J,GPDATTIM,ADDMGPNT))
  1.  . . S ^TMP("TIUREPLACE",$J,GPDATTIM,ADDMGPNT)=""
  1.  . . S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
  1.  . E  D
  1.  . . Q:$D(^TMP("TIUREPLACE",$J,PDATTIM,ADDMPRNT))
  1.  . . S ^TMP("TIUREPLACE",$J,PDATTIM,ADDMPRNT)=""
  1.  . . S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
  1.  Q
  1. ACLAU(ARRAY,CLASS,AUTHOR,DFN,TIME1,TIME2,SEQUENCE,TIUEXPKD) ; Unsigned
  1.  N DATTIM,DA,ROOT,TIUORDER
  1.  K ^TMP("TIUREPLACE",$J)
  1.  S ROOT=$NA(^TIU(8925,"ACLAU",CLASS,AUTHOR,DFN))
  1.  S DATTIM=TIME1-.0000001
  1.  S TIUORDER=$S(SEQUENCE="D":1,1:-1)
  1.  F  S DATTIM=$O(@ROOT@(DATTIM)) Q:DATTIM'>0!(DATTIM>TIME2)  D
  1.  . S DA=0 F  S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0  D
  1.  . . I +$P($G(^TIU(8925,DA,0)),U,5)>6 K @ROOT@(DATTIM,DA) Q
  1.  . . I +$G(^TIU(8925,DA,0))'>0 K @ROOT@(DATTIM,DA) Q
  1.  . . ; Don't include ID kids or parents in top level of list;
  1.  . . ; Do expand kids
  1.  . . D REPLACE(DA,DATTIM,.TIUEXPKD)
  1.  D SETARRY(.ARRAY,TIUORDER)
  1.  K ^TMP("TIUREPLACE",$J)
  1.  Q
  1. ACLEC(ARRAY,CLASS,EXCOSIGN,DFN,TIME1,TIME2,SEQUENCE,TIUEXPKD) ; Uncosigned
  1.  N DATTIM,DA,ROOT,TIUORDER
  1.  K ^TMP("TIUREPLACE",$J)
  1.  S ROOT=$NA(^TIU(8925,"ACLEC",CLASS,EXCOSIGN,DFN))
  1.  S DATTIM=TIME1-.0000001
  1.  S TIUORDER=$S(SEQUENCE="D":1,1:-1)
  1.  F  S DATTIM=$O(@ROOT@(DATTIM)) Q:DATTIM'>0!(DATTIM>TIME2)  D
  1.  . S DA=0 F  S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0  D
  1.  . . I +$G(^TIU(8925,DA,0))'>0 K @ROOT@(DATTIM,DA)
  1.  . . D REPLACE(DA,DATTIM,.TIUEXPKD)
  1.  D SETARRY(.ARRAY,TIUORDER)
  1.  K ^TMP("TIUREPLACE",$J)
  1.  Q
  1. ACLSB(ARRAY,CLASS,SIGNEDBY,DFN,TIME1,TIME2,SEQUENCE,TIUEXPKD) ; Signed, by author
  1.  N DATTIM,DA,ROOT,TIUORDER
  1.  K ^TMP("TIUREPLACE",$J)
  1.  S ROOT=$NA(^TIU(8925,"ACLSB",CLASS,SIGNEDBY,DFN))
  1.  S DATTIM=TIME1-.0000001
  1.  S TIUORDER=$S(SEQUENCE="D":1,1:-1)
  1.  F  S DATTIM=$O(@ROOT@(DATTIM)) Q:DATTIM'>0!(DATTIM>TIME2)  D
  1.  . S DA=0 F  S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0  D
  1.  . . I +$G(^TIU(8925,DA,0))'>0 K @ROOT@(DATTIM,DA)
  1.  . . D REPLACE(DA,DATTIM,.TIUEXPKD)
  1.  D SETARRY(.ARRAY,TIUORDER)
  1.  K ^TMP("TIUREPLACE",$J)
  1.  Q
  1.  ;VMP OIFO BAY PINES;ELR;TIU*1.0*194 ADDED NEXT TAG
  1. APTCL(ARRAY,CLASS,TIUAUTH,DFN,TIME1,TIME2,SEQUENCE,TIUEXPKD) ; Signed, by author
  1.  N DATTIM,DA,ROOT,TIUORDER,TIUS12,TIUS15
  1.  K ^TMP("TIUREPLACE",$J)
  1.  S ROOT=$NA(^TIU(8925,"APTCL",DFN,CLASS))
  1.  S DATTIM=TIME1-.0000001
  1.  S TIUORDER=$S(SEQUENCE="D":1,1:-1)
  1.  F  S DATTIM=$O(@ROOT@(DATTIM)) Q:DATTIM'>0!(DATTIM>TIME2)  D
  1.  . S DA=0 F  S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0  D
  1.  . . I +$G(^TIU(8925,DA,0))'>0 K @ROOT@(DATTIM,DA)
  1.  . . S TIUS12=$G(^TIU(8925,DA,12))
  1.  . . Q:+$P(TIUS12,U,2)'=TIUAUTH         ;See if this is the authors note
  1.  . . S TIUS15=$G(^TIU(8925,DA,15))
  1.  . . Q:+$P(TIUS15,U,2)'>0                 ;See if signed
  1.  . . D REPLACE(DA,DATTIM,.TIUEXPKD)
  1.  D SETARRY(.ARRAY,TIUORDER)
  1.  K ^TMP("TIUREPLACE",$J)
  1.  Q