- TIURPTTL ; SLC/JER - Review Documents by PATIENT & TITLE ;2/26/01
- ;;1.0;TEXT INTEGRATION UTILITIES;**100,286**;Jun 20, 1997;Build 10
- ;;Per VA Directive 6402, this routine should not be modified
- ; 12/5/00 split rtn w GATHER, PUTLIST, ADDELMNT to new rtn TIURPTT1
- ;
- MAKELIST(TIUCLASS) ; Get Search Criteria
- N DFN,TIUI,SCREEN,STATUS,TIUTYP,TIUSTAT,TIUEDFLT,TIUDCL,TIUQUIT
- N STATWORD,STATIFN,NOWFLAG
- STATUS S STATUS=$$SELSTAT^TIULA(.TIUSTAT,"F","ALL")
- I +STATUS<0 S VALMQUIT=1 Q
- S TIUI=0
- F S TIUI=$O(TIUSTAT(TIUI)) Q:'TIUI D
- . S STATIFN=$O(^TIU(8925.6,"B",$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3)),0))
- . Q:'STATIFN
- . S STATUS("IFNS")=$G(STATUS("IFNS"))_STATIFN_";"
- S TIUI=1,STATWORD=$$UPPER^TIULS($P(TIUSTAT(1),U,3))
- I +$G(TIUSTAT(4))'>0 F S TIUI=$O(TIUSTAT(TIUI)) Q:+TIUI'>0 D
- . S STATWORD=STATWORD_$S(TIUI=+TIUSTAT(1):" & ",1:", ")_$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3))
- I +$G(TIUSTAT(4))>0 S STATWORD=$S($P(TIUSTAT(4),U,4)="ALL":"ALL",1:STATWORD_", OTHER")
- S STATUS("WORDS")=STATWORD
- PATIENT ; Select Patient
- S DFN=$S(+$G(ORVP):+$G(ORVP),1:+$$PATIENT^TIULA)
- I +DFN'>0 S VALMQUIT=1 Q
- DOCTYPE ; Select Document Type(s)
- N TIUDCL
- D TITLPICK^TIULA3(.TIUTYP,TIUCLASS)
- I +$D(TIUQUIT) S VALMQUIT=1 Q
- I +$G(TIUTYP)'>0,'$D(TIUQUIK) G STATUS
- SCREEN ;
- N TIUNAME
- S TIUNAME=$P($G(^VA(200,+DUZ,0)),U)
- S SCREEN=1,SCREEN(1)="APT^"_DFN
- D CHECKADD(.TIUTYP)
- ERLY S TIUEDFLT=$S(TIUCLASS=3:"T-2",TIUCLASS=244:"T-30",1:"T-7")
- S TIUEDT=$S($D(TIUQUIK):1,1:$P($$EDATE^TIULA("Reference","",TIUEDFLT),U))
- I +$G(DIROUT) S VALMQUIT=1 Q
- I TIUEDT'>0 G SCREEN
- S TIULDT=$S($D(TIUQUIK):9999999,1:$P($$LDATE^TIULA("Reference"),U))
- I +$G(DIROUT) S VALMQUIT=1 Q
- I TIULDT'>0 G ERLY
- I TIUEDT>TIULDT D SWAP^TIUR(.TIUEDT,.TIULDT)
- I $L(TIULDT,".")=1 D EXPRANGE^TIUR(.TIUEDT,.TIULDT)
- ; -- Reset late date to NOW on rebuild:
- ; TIU*1.0*286 djh
- S NOWFLAG=$$FMDIFF^XLFDT($$NOW^XLFDT,TIULDT,2)<60
- I '$G(TIURBLD) W !,"Searching for the documents."
- D BUILD(TIUCLASS,.STATUS,.TIUTYP,.SCREEN,TIUEDT,TIULDT,NOWFLAG)
- ; -- If changed view while attaching ID note, update video for note: --
- I $G(TIUGLINK) D RESTOREG^TIULM(.TIUGLINK)
- Q
- CHECKADD(TYPES) ; Checks whether Addendum is included in the list of types
- N TIUI,HIT S (TIUI,HIT)=0
- F S TIUI=$O(TYPES(TIUI)) Q:+TIUI'>0!+HIT I $$UP^XLFSTR(TYPES(TIUI))["ADDENDUM" S HIT=1
- I +HIT'>0 S TYPES(TYPES+1)=+TYPES(TYPES)+1_U_"81^Addendum^NOT PICKED",TYPES=TYPES+1
- Q
- BUILD(TIUCLASS,STATUS,TYPES,SCREEN,EARLY,LATE,NOWFLAG) ; Build List
- N TIUCNT,TIUDT,TIUI,TIUJ,TIUK,TIUQ,TIUIFN,TIUREC
- N XREF,TIUS,TIUPREF
- S TIUPREF=$$PERSPRF^TIULE(DUZ),(TIUK,VALMCNT)=0
- K ^TMP("TIUR",$J),^TMP("TIURIDX",$J),^TMP("TIUI",$J),^TMP("TIUTYP",$J)
- ; If user entered NOW at first build, update NOW for rebuild;
- ; Save data in ^TMP("TIURIDX",$J,0) for rebuild:
- I $G(TIURBLD),$G(NOWFLAG) S LATE=$$NOW^XLFDT
- S ^TMP("TIURIDX",$J,0)=+EARLY_U_+LATE_U_$G(STATUS("IFNS"))_U_NOWFLAG
- ; Save docmt types in ^TMP("TIUTYP",$J) for rebuild:
- M ^TMP("TIUTYP",$J)=TYPES
- S ^TMP("TIUR",$J,"RTN")="TIURPTTL"
- I '$D(TIUPRM0)!'$D(TIUPRM0) D SETPARM^TIULE
- S EARLY=9999999-+$G(EARLY),LATE=9999999-$S(+$G(LATE):+$G(LATE),1:3333333)
- F S TIUK=$O(SCREEN(TIUK)) Q:TIUK'>0 D
- . S XREF=$P(SCREEN(TIUK),U)
- . I XREF'="ASUB" D
- . . S TIUI=$S(XREF'="APRB":$P(SCREEN(TIUK),U,2),1:$$UPPER^TIULS($P(SCREEN(TIUK),U,3)))
- . . D GATHER^TIURPTT1(TIUI,TIUPREF,TIUCLASS,STATUS("IFNS"),EARLY,LATE,XREF)
- . I XREF="ASUB" D
- . . S TIUI=$O(^TIU(8925,XREF,$P(SCREEN(TIUK),U,2)),-1)
- . . F S TIUI=$O(^TIU(8925,XREF,TIUI)) Q:TIUI=""!(TIUI'[$P(SCREEN(TIUK),U,2)) D GATHER^TIURPTT1(TIUI,TIUPREF,TIUCLASS,STATUS("IFNS"),EARLY,LATE,XREF)
- D PUTLIST^TIURPTT1(TIUPREF,TIUCLASS,.STATUS,.SCREEN)
- Q
- CLEAN ; Clean up your mess!
- K ^TMP("TIUR",$J),^TMP("TIURIDX",$J) D CLEAN^VALM10
- K VALMY,^TMP("TIUTYP",$J)
- Q
- ;
- RBLD ; Rebuild list after actions 11/30/00
- N TIUEXP,TIUR0,TIURIDX0,TIUSCRN,TMP,TIUEDT,TIULDT,TIUSTAT
- N TIURBLD,TIUI,TIUCLASS,TIUTYP,NOWFLAG
- S TIURBLD=1
- D FIXLSTNW^TIULM ;restore video for elements added to end of list
- I +$O(^TMP("TIUR",$J,"EXPAND",0)) D
- . M TIUEXP=^TMP("TIUR",$J,"EXPAND")
- M TIUTYP=^TMP("TIUTYP",$J)
- S TIUR0=^TMP("TIUR",$J,0),TIURIDX0=^TMP("TIURIDX",$J,0)
- S TIUSCRN=$P(TIUR0,U,3,99),TIUCLASS=^TMP("TIUR",$J,"CLASS")
- S TIUI=1
- F S TMP=$P(TIUSCRN,";",TIUI) Q:TMP="" D
- . S TIUSCRN(TIUI)=TMP,TIUI=TIUI+1
- S TIUSCRN=$L(TIUSCRN,";")
- S STATUS("WORDS")=$P(TIUR0,U,2)
- S STATUS("IFNS")=$P(TIURIDX0,U,3)
- S TIUEDT=$P(TIURIDX0,U),TIULDT=$P(TIURIDX0,U,2),NOWFLAG=+$P(TIURIDX0,U,4)
- D BUILD(TIUCLASS,.STATUS,.TIUTYP,.TIUSCRN,TIUEDT,TIULDT,NOWFLAG)
- ; Reexpand previously expanded items:
- D RELOAD^TIUROR1(.TIUEXP)
- D BREATHE^TIUROR1(1)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIURPTTL 4740 printed Feb 19, 2025@00:12 Page 2
- TIURPTTL ; SLC/JER - Review Documents by PATIENT & TITLE ;2/26/01
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**100,286**;Jun 20, 1997;Build 10
- +2 ;;Per VA Directive 6402, this routine should not be modified
- +3 ; 12/5/00 split rtn w GATHER, PUTLIST, ADDELMNT to new rtn TIURPTT1
- +4 ;
- MAKELIST(TIUCLASS) ; Get Search Criteria
- +1 NEW DFN,TIUI,SCREEN,STATUS,TIUTYP,TIUSTAT,TIUEDFLT,TIUDCL,TIUQUIT
- +2 NEW STATWORD,STATIFN,NOWFLAG
- STATUS SET STATUS=$$SELSTAT^TIULA(.TIUSTAT,"F","ALL")
- +1 IF +STATUS<0
- SET VALMQUIT=1
- QUIT
- +2 SET TIUI=0
- +3 FOR
- SET TIUI=$ORDER(TIUSTAT(TIUI))
- if 'TIUI
- QUIT
- Begin DoDot:1
- +4 SET STATIFN=$ORDER(^TIU(8925.6,"B",$$UPPER^TIULS($PIECE(TIUSTAT(TIUI),U,3)),0))
- +5 if 'STATIFN
- QUIT
- +6 SET STATUS("IFNS")=$GET(STATUS("IFNS"))_STATIFN_";"
- End DoDot:1
- +7 SET TIUI=1
- SET STATWORD=$$UPPER^TIULS($PIECE(TIUSTAT(1),U,3))
- +8 IF +$GET(TIUSTAT(4))'>0
- FOR
- SET TIUI=$ORDER(TIUSTAT(TIUI))
- if +TIUI'>0
- QUIT
- Begin DoDot:1
- +9 SET STATWORD=STATWORD_$SELECT(TIUI=+TIUSTAT(1):" & ",1:", ")_$$UPPER^TIULS($PIECE(TIUSTAT(TIUI),U,3))
- End DoDot:1
- +10 IF +$GET(TIUSTAT(4))>0
- SET STATWORD=$SELECT($PIECE(TIUSTAT(4),U,4)="ALL":"ALL",1:STATWORD_", OTHER")
- +11 SET STATUS("WORDS")=STATWORD
- PATIENT ; Select Patient
- +1 SET DFN=$SELECT(+$GET(ORVP):+$GET(ORVP),1:+$$PATIENT^TIULA)
- +2 IF +DFN'>0
- SET VALMQUIT=1
- QUIT
- DOCTYPE ; Select Document Type(s)
- +1 NEW TIUDCL
- +2 DO TITLPICK^TIULA3(.TIUTYP,TIUCLASS)
- +3 IF +$DATA(TIUQUIT)
- SET VALMQUIT=1
- QUIT
- +4 IF +$GET(TIUTYP)'>0
- IF '$DATA(TIUQUIK)
- GOTO STATUS
- SCREEN ;
- +1 NEW TIUNAME
- +2 SET TIUNAME=$PIECE($GET(^VA(200,+DUZ,0)),U)
- +3 SET SCREEN=1
- SET SCREEN(1)="APT^"_DFN
- +4 DO CHECKADD(.TIUTYP)
- ERLY SET TIUEDFLT=$SELECT(TIUCLASS=3:"T-2",TIUCLASS=244:"T-30",1:"T-7")
- +1 SET TIUEDT=$SELECT($DATA(TIUQUIK):1,1:$PIECE($$EDATE^TIULA("Reference","",TIUEDFLT),U))
- +2 IF +$GET(DIROUT)
- SET VALMQUIT=1
- QUIT
- +3 IF TIUEDT'>0
- GOTO SCREEN
- +4 SET TIULDT=$SELECT($DATA(TIUQUIK):9999999,1:$PIECE($$LDATE^TIULA("Reference"),U))
- +5 IF +$GET(DIROUT)
- SET VALMQUIT=1
- QUIT
- +6 IF TIULDT'>0
- GOTO ERLY
- +7 IF TIUEDT>TIULDT
- DO SWAP^TIUR(.TIUEDT,.TIULDT)
- +8 IF $LENGTH(TIULDT,".")=1
- DO EXPRANGE^TIUR(.TIUEDT,.TIULDT)
- +9 ; -- Reset late date to NOW on rebuild:
- +10 ; TIU*1.0*286 djh
- +11 SET NOWFLAG=$$FMDIFF^XLFDT($$NOW^XLFDT,TIULDT,2)<60
- +12 IF '$GET(TIURBLD)
- WRITE !,"Searching for the documents."
- +13 DO BUILD(TIUCLASS,.STATUS,.TIUTYP,.SCREEN,TIUEDT,TIULDT,NOWFLAG)
- +14 ; -- If changed view while attaching ID note, update video for note: --
- +15 IF $GET(TIUGLINK)
- DO RESTOREG^TIULM(.TIUGLINK)
- +16 QUIT
- CHECKADD(TYPES) ; Checks whether Addendum is included in the list of types
- +1 NEW TIUI,HIT
- SET (TIUI,HIT)=0
- +2 FOR
- SET TIUI=$ORDER(TYPES(TIUI))
- if +TIUI'>0!+HIT
- QUIT
- IF $$UP^XLFSTR(TYPES(TIUI))["ADDENDUM"
- SET HIT=1
- +3 IF +HIT'>0
- SET TYPES(TYPES+1)=+TYPES(TYPES)+1_U_"81^Addendum^NOT PICKED"
- SET TYPES=TYPES+1
- +4 QUIT
- BUILD(TIUCLASS,STATUS,TYPES,SCREEN,EARLY,LATE,NOWFLAG) ; Build List
- +1 NEW TIUCNT,TIUDT,TIUI,TIUJ,TIUK,TIUQ,TIUIFN,TIUREC
- +2 NEW XREF,TIUS,TIUPREF
- +3 SET TIUPREF=$$PERSPRF^TIULE(DUZ)
- SET (TIUK,VALMCNT)=0
- +4 KILL ^TMP("TIUR",$JOB),^TMP("TIURIDX",$JOB),^TMP("TIUI",$JOB),^TMP("TIUTYP",$JOB)
- +5 ; If user entered NOW at first build, update NOW for rebuild;
- +6 ; Save data in ^TMP("TIURIDX",$J,0) for rebuild:
- +7 IF $GET(TIURBLD)
- IF $GET(NOWFLAG)
- SET LATE=$$NOW^XLFDT
- +8 SET ^TMP("TIURIDX",$JOB,0)=+EARLY_U_+LATE_U_$GET(STATUS("IFNS"))_U_NOWFLAG
- +9 ; Save docmt types in ^TMP("TIUTYP",$J) for rebuild:
- +10 MERGE ^TMP("TIUTYP",$JOB)=TYPES
- +11 SET ^TMP("TIUR",$JOB,"RTN")="TIURPTTL"
- +12 IF '$DATA(TIUPRM0)!'$DATA(TIUPRM0)
- DO SETPARM^TIULE
- +13 SET EARLY=9999999-+$GET(EARLY)
- SET LATE=9999999-$SELECT(+$GET(LATE):+$GET(LATE),1:3333333)
- +14 FOR
- SET TIUK=$ORDER(SCREEN(TIUK))
- if TIUK'>0
- QUIT
- Begin DoDot:1
- +15 SET XREF=$PIECE(SCREEN(TIUK),U)
- +16 IF XREF'="ASUB"
- Begin DoDot:2
- +17 SET TIUI=$SELECT(XREF'="APRB":$PIECE(SCREEN(TIUK),U,2),1:$$UPPER^TIULS($PIECE(SCREEN(TIUK),U,3)))
- +18 DO GATHER^TIURPTT1(TIUI,TIUPREF,TIUCLASS,STATUS("IFNS"),EARLY,LATE,XREF)
- End DoDot:2
- +19 IF XREF="ASUB"
- Begin DoDot:2
- +20 SET TIUI=$ORDER(^TIU(8925,XREF,$PIECE(SCREEN(TIUK),U,2)),-1)
- +21 FOR
- SET TIUI=$ORDER(^TIU(8925,XREF,TIUI))
- if TIUI=""!(TIUI'[$PIECE(SCREEN(TIUK),U,2))
- QUIT
- DO GATHER^TIURPTT1(TIUI,TIUPREF,TIUCLASS,STATUS("IFNS"),EARLY,LATE,XREF)
- End DoDot:2
- End DoDot:1
- +22 DO PUTLIST^TIURPTT1(TIUPREF,TIUCLASS,.STATUS,.SCREEN)
- +23 QUIT
- CLEAN ; Clean up your mess!
- +1 KILL ^TMP("TIUR",$JOB),^TMP("TIURIDX",$JOB)
- DO CLEAN^VALM10
- +2 KILL VALMY,^TMP("TIUTYP",$JOB)
- +3 QUIT
- +4 ;
- RBLD ; Rebuild list after actions 11/30/00
- +1 NEW TIUEXP,TIUR0,TIURIDX0,TIUSCRN,TMP,TIUEDT,TIULDT,TIUSTAT
- +2 NEW TIURBLD,TIUI,TIUCLASS,TIUTYP,NOWFLAG
- +3 SET TIURBLD=1
- +4 ;restore video for elements added to end of list
- DO FIXLSTNW^TIULM
- +5 IF +$ORDER(^TMP("TIUR",$JOB,"EXPAND",0))
- Begin DoDot:1
- +6 MERGE TIUEXP=^TMP("TIUR",$JOB,"EXPAND")
- End DoDot:1
- +7 MERGE TIUTYP=^TMP("TIUTYP",$JOB)
- +8 SET TIUR0=^TMP("TIUR",$JOB,0)
- SET TIURIDX0=^TMP("TIURIDX",$JOB,0)
- +9 SET TIUSCRN=$PIECE(TIUR0,U,3,99)
- SET TIUCLASS=^TMP("TIUR",$JOB,"CLASS")
- +10 SET TIUI=1
- +11 FOR
- SET TMP=$PIECE(TIUSCRN,";",TIUI)
- if TMP=""
- QUIT
- Begin DoDot:1
- +12 SET TIUSCRN(TIUI)=TMP
- SET TIUI=TIUI+1
- End DoDot:1
- +13 SET TIUSCRN=$LENGTH(TIUSCRN,";")
- +14 SET STATUS("WORDS")=$PIECE(TIUR0,U,2)
- +15 SET STATUS("IFNS")=$PIECE(TIURIDX0,U,3)
- +16 SET TIUEDT=$PIECE(TIURIDX0,U)
- SET TIULDT=$PIECE(TIURIDX0,U,2)
- SET NOWFLAG=+$PIECE(TIURIDX0,U,4)
- +17 DO BUILD(TIUCLASS,.STATUS,.TIUTYP,.TIUSCRN,TIUEDT,TIULDT,NOWFLAG)
- +18 ; Reexpand previously expanded items:
- +19 DO RELOAD^TIUROR1(.TIUEXP)
- +20 DO BREATHE^TIUROR1(1)
- +21 QUIT