TIURPN ; SLC/JER - QUICK Review BY PATIENT ;2/28/01
;;1.0;TEXT INTEGRATION UTILITIES;**100**;Jun 20, 1997
EN(TIUCLASS,DFN) ; Entry point for build code
N DIRUT,DTOUT,DUOUT,TIUI,SCREEN,STATUS,TIUTYP,TIUSTAT,TIUEDFLT,TIUDCL
N TIUDPRMT,TIUPICT,TIUOUT
K DIROUT
S TIUEDT=$$FMADD^XLFDT(DT,$S($D(^DPT(DFN,.1))'>0:-180,1:-30))
S TIULDT=+$$NOW^XLFDT
W !,"Searching for the documents."
D BUILD(TIUCLASS,DFN,TIUEDT,TIULDT)
Q
BUILD(CLASS,DFN,EARLY,LATE) ; Build List
N TIUCNT,TIUDT,TIUI,TIUJ,TIUK,TIUP,TIUQ,TIUDA,TIUREC
N TIUT,TIUTP,XREF,TIUS,TIUPREF,TIUPICK
S (TIUK,VALMCNT)=0
K ^TMP("TIUR",$J),^TMP("TIURIDX",$J)
S EARLY=9999999-+$G(EARLY),LATE=9999999-+$G(LATE)
S TIUJ=LATE
S TIUPICK=+$O(^ORD(101,"B","TIU ACTION SELECT LIST ELEMENT",0))
F S TIUJ=$O(^TIU(8925,"APTCL",DFN,CLASS,TIUJ)) Q:+TIUJ'>0!(+TIUJ>EARLY) D
. S TIUDA=0
. F S TIUDA=$O(^TIU(8925,"APTCL",DFN,CLASS,TIUJ,TIUDA)) Q:+TIUDA'>0 D
. . D ADDELMNT(TIUDA,.TIUCNT)
S ^TMP("TIUR",$J,0)=+$G(TIUCNT)_U_"ALL^APT^"_DFN
S ^TMP("TIUR",$J,0)=^TMP("TIUR",$J,0)_U_$P(^DPT(DFN,0),U)
S ^TMP("TIUR",$J,"CLASS")=TIUCLASS
S ^TMP("TIUR",$J,"#")=TIUPICK_"^1:"_+$G(TIUCNT)
I $D(VALMHDR)>9 D HDR^TIURH
S VALMCNT=+$G(TIUCNT)
I +$G(TIUCNT)'>0 D
. S ^TMP("TIUR",$J,1,0)="",VALMCNT=2
. S ^TMP("TIUR",$J,2,0)=" No records found to satisfy search criteria."
Q
ADDELMNT(DA,TIUCNT) ; Add each element to the list
N DIC,DIQ,DR,TIUR,PT,MOM,ADT,DDT,LCT,AUT,AMD,EDT,SDT,XDT,RMD,TIULST4
N TIUP,TIUREC,TIUD0,TIUD12,TIUD13,TIUD15,TIULI,STATX,DOC,IDKIDFLG
I '$D(^TIU(8925,DA,0)) Q
I $G(^TMP("TIUR",$J,2,0))=" No records found to satisfy search criteria." D
. K ^TMP("TIUR",$J,2),^TMP("TIUR",$J,"IDX",2),^TMP("TIUR",$J,"IDX",1) S TIUCNT=0
S TIUD0=$G(^TIU(8925,+DA,0)),TIUD12=$G(^TIU(8925,+DA,12))
S TIUD13=$G(^TIU(8925,+DA,13)),TIUD15=$G(^TIU(8925,+DA,15))
I +TIUD0=81,(+$P(TIUD0,U,5)>5) Q
S DOC=$$PNAME^TIULC1(+TIUD0)
I DOC="Addendum" S DOC=DOC_" to "_$$PNAME^TIULC1(+$G(^TIU(8925,+$P(TIUD0,U,6),0)))
S PT=$$NAME^TIULS($$PTNAME^TIULC1($P(TIUD0,U,2)),"LAST,FI MI")
S TIULI=$E(PT),IDKIDFLG=1
I +$O(^TIU(8925,"DAD",+DA,0)),$$HASADDEN^TIULC1(DA,IDKIDFLG) S PT="+ "_PT ;**100**
S TIUP=$$URGENCY(+DA)
S:TIUP=1 PT=$S(PT["+":"*",1:"* ")_PT
S TIULST4=$E($P($G(^DPT(+$P(TIUD0,U,2),0)),U,9),6,9)
S TIULST4="("_TIULI_TIULST4_")"
S ADT=$$DATE^TIULS($P(TIUD0,U,7),"MM/DD/YY")
S DDT=$$DATE^TIULS($P(TIUD0,U,8),"MM/DD/YY")
S AMD=$$PERSNAME^TIULC1($P(TIUD12,U,8)) S:AMD="UNKNOWN" AMD=""
S AUT=$$PERSNAME^TIULC1($P(TIUD12,U,2)) S:AUT="UNKNOWN" AUT=""
S AMD=$$NAME^TIULS(AMD,"LAST,FI MI")
S AUT=$$NAME^TIULS(AUT,"LAST,FI MI")
S EDT=$$DATE^TIULS($P(TIUD13,U),"MM/DD/YY")
S SDT=$S(+$P(TIUD15,U,7):+$P(TIUD15,U,7),+$P(TIUD0,U,5)'<7:+$P(TIUD15,U),1:"")
S SDT=$$DATE^TIULS(SDT,"MM/DD/YY")
S STATX=$P($G(^TIU(8925.6,+$P(TIUD0,U,5),0)),U)
S TIUCNT=+$G(TIUCNT)+1
S TIUREC=$$SETFLD^VALM1(TIUCNT,"","NUMBER")
S TIUREC=$$SETFLD^VALM1(PT,TIUREC,"PATIENT NAME")
S TIUREC=$$SETFLD^VALM1(TIULST4,TIUREC,"LAST I/LAST 4")
S TIUREC=$$SETFLD^VALM1(DOC,TIUREC,"DOCUMENT TYPE")
S TIUREC=$$SETFLD^VALM1(EDT,TIUREC,"REF DATE")
S TIUREC=$$SETFLD^VALM1(SDT,TIUREC,"SIG DATE")
S TIUREC=$$SETFLD^VALM1($$LOWER^TIULS(STATX),TIUREC,"STATUS")
S TIUREC=$$SETFLD^VALM1(AUT,TIUREC,"AUTHOR")
S TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"COSIGNER")
S ^TMP("TIUR",$J,TIUCNT,0)=TIUREC
S ^TMP("TIUR",$J,"IDX",TIUCNT,TIUCNT)="" W:TIUCNT#10'>0 "."
S ^TMP("TIURIDX",$J,TIUCNT)=TIUCNT_U_DA
S VALMCNT=TIUCNT
Q
CLEAN ; Clean up your mess!
K ^TMP("TIUR",$J),^TMP("TIURIDX",$J) D CLEAN^VALM10
K VALMY
Q
URGENCY(TIUDA) ; What is the urgency of the current document
N TIUY,TIUD0,TIUDSTAT,TIUDURG
S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUDSTAT=$P(TIUD0,U,5)
S TIUDURG=$P(TIUD0,U,9)
S TIUY=$S(TIUDSTAT<7:$S(TIUDURG="P":1,1:2),1:3)
Q TIUY
TIURPN ; SLC/JER - QUICK Review BY PATIENT ;2/28/01
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**100**;Jun 20, 1997
EN(TIUCLASS,DFN) ; Entry point for build code
+1 NEW DIRUT,DTOUT,DUOUT,TIUI,SCREEN,STATUS,TIUTYP,TIUSTAT,TIUEDFLT,TIUDCL
+2 NEW TIUDPRMT,TIUPICT,TIUOUT
+3 KILL DIROUT
+4 SET TIUEDT=$$FMADD^XLFDT(DT,$SELECT($DATA(^DPT(DFN,.1))'>0:-180,1:-30))
+5 SET TIULDT=+$$NOW^XLFDT
+6 WRITE !,"Searching for the documents."
+7 DO BUILD(TIUCLASS,DFN,TIUEDT,TIULDT)
+8 QUIT
BUILD(CLASS,DFN,EARLY,LATE) ; Build List
+1 NEW TIUCNT,TIUDT,TIUI,TIUJ,TIUK,TIUP,TIUQ,TIUDA,TIUREC
+2 NEW TIUT,TIUTP,XREF,TIUS,TIUPREF,TIUPICK
+3 SET (TIUK,VALMCNT)=0
+4 KILL ^TMP("TIUR",$JOB),^TMP("TIURIDX",$JOB)
+5 SET EARLY=9999999-+$GET(EARLY)
SET LATE=9999999-+$GET(LATE)
+6 SET TIUJ=LATE
+7 SET TIUPICK=+$ORDER(^ORD(101,"B","TIU ACTION SELECT LIST ELEMENT",0))
+8 FOR
SET TIUJ=$ORDER(^TIU(8925,"APTCL",DFN,CLASS,TIUJ))
IF +TIUJ'>0!(+TIUJ>EARLY)
QUIT
Begin DoDot:1
+9 SET TIUDA=0
+10 FOR
SET TIUDA=$ORDER(^TIU(8925,"APTCL",DFN,CLASS,TIUJ,TIUDA))
IF +TIUDA'>0
QUIT
Begin DoDot:2
+11 DO ADDELMNT(TIUDA,.TIUCNT)
End DoDot:2
End DoDot:1
+12 SET ^TMP("TIUR",$JOB,0)=+$GET(TIUCNT)_U_"ALL^APT^"_DFN
+13 SET ^TMP("TIUR",$JOB,0)=^TMP("TIUR",$JOB,0)_U_$PIECE(^DPT(DFN,0),U)
+14 SET ^TMP("TIUR",$JOB,"CLASS")=TIUCLASS
+15 SET ^TMP("TIUR",$JOB,"#")=TIUPICK_"^1:"_+$GET(TIUCNT)
+16 IF $DATA(VALMHDR)>9
DO HDR^TIURH
+17 SET VALMCNT=+$GET(TIUCNT)
+18 IF +$GET(TIUCNT)'>0
Begin DoDot:1
+19 SET ^TMP("TIUR",$JOB,1,0)=""
SET VALMCNT=2
+20 SET ^TMP("TIUR",$JOB,2,0)=" No records found to satisfy search criteria."
End DoDot:1
+21 QUIT
ADDELMNT(DA,TIUCNT) ; Add each element to the list
+1 NEW DIC,DIQ,DR,TIUR,PT,MOM,ADT,DDT,LCT,AUT,AMD,EDT,SDT,XDT,RMD,TIULST4
+2 NEW TIUP,TIUREC,TIUD0,TIUD12,TIUD13,TIUD15,TIULI,STATX,DOC,IDKIDFLG
+3 IF '$DATA(^TIU(8925,DA,0))
QUIT
+4 IF $GET(^TMP("TIUR",$JOB,2,0))=" No records found to satisfy search criteria."
Begin DoDot:1
+5 KILL ^TMP("TIUR",$JOB,2),^TMP("TIUR",$JOB,"IDX",2),^TMP("TIUR",$JOB,"IDX",1)
SET TIUCNT=0
End DoDot:1
+6 SET TIUD0=$GET(^TIU(8925,+DA,0))
SET TIUD12=$GET(^TIU(8925,+DA,12))
+7 SET TIUD13=$GET(^TIU(8925,+DA,13))
SET TIUD15=$GET(^TIU(8925,+DA,15))
+8 IF +TIUD0=81
IF (+$PIECE(TIUD0,U,5)>5)
QUIT
+9 SET DOC=$$PNAME^TIULC1(+TIUD0)
+10 IF DOC="Addendum"
SET DOC=DOC_" to "_$$PNAME^TIULC1(+$GET(^TIU(8925,+$PIECE(TIUD0,U,6),0)))
+11 SET PT=$$NAME^TIULS($$PTNAME^TIULC1($PIECE(TIUD0,U,2)),"LAST,FI MI")
+12 SET TIULI=$EXTRACT(PT)
SET IDKIDFLG=1
+13 ;**100**
IF +$ORDER(^TIU(8925,"DAD",+DA,0))
IF $$HASADDEN^TIULC1(DA,IDKIDFLG)
SET PT="+ "_PT
+14 SET TIUP=$$URGENCY(+DA)
+15 IF TIUP=1
SET PT=$SELECT(PT["+":"*",1:"* ")_PT
+16 SET TIULST4=$EXTRACT($PIECE($GET(^DPT(+$PIECE(TIUD0,U,2),0)),U,9),6,9)
+17 SET TIULST4="("_TIULI_TIULST4_")"
+18 SET ADT=$$DATE^TIULS($PIECE(TIUD0,U,7),"MM/DD/YY")
+19 SET DDT=$$DATE^TIULS($PIECE(TIUD0,U,8),"MM/DD/YY")
+20 SET AMD=$$PERSNAME^TIULC1($PIECE(TIUD12,U,8))
IF AMD="UNKNOWN"
SET AMD=""
+21 SET AUT=$$PERSNAME^TIULC1($PIECE(TIUD12,U,2))
IF AUT="UNKNOWN"
SET AUT=""
+22 SET AMD=$$NAME^TIULS(AMD,"LAST,FI MI")
+23 SET AUT=$$NAME^TIULS(AUT,"LAST,FI MI")
+24 SET EDT=$$DATE^TIULS($PIECE(TIUD13,U),"MM/DD/YY")
+25 SET SDT=$SELECT(+$PIECE(TIUD15,U,7):+$PIECE(TIUD15,U,7),+$PIECE(TIUD0,U,5)'<7:+$PIECE(TIUD15,U),1:"")
+26 SET SDT=$$DATE^TIULS(SDT,"MM/DD/YY")
+27 SET STATX=$PIECE($GET(^TIU(8925.6,+$PIECE(TIUD0,U,5),0)),U)
+28 SET TIUCNT=+$GET(TIUCNT)+1
+29 SET TIUREC=$$SETFLD^VALM1(TIUCNT,"","NUMBER")
+30 SET TIUREC=$$SETFLD^VALM1(PT,TIUREC,"PATIENT NAME")
+31 SET TIUREC=$$SETFLD^VALM1(TIULST4,TIUREC,"LAST I/LAST 4")
+32 SET TIUREC=$$SETFLD^VALM1(DOC,TIUREC,"DOCUMENT TYPE")
+33 SET TIUREC=$$SETFLD^VALM1(EDT,TIUREC,"REF DATE")
+34 SET TIUREC=$$SETFLD^VALM1(SDT,TIUREC,"SIG DATE")
+35 SET TIUREC=$$SETFLD^VALM1($$LOWER^TIULS(STATX),TIUREC,"STATUS")
+36 SET TIUREC=$$SETFLD^VALM1(AUT,TIUREC,"AUTHOR")
+37 SET TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"COSIGNER")
+38 SET ^TMP("TIUR",$JOB,TIUCNT,0)=TIUREC
+39 SET ^TMP("TIUR",$JOB,"IDX",TIUCNT,TIUCNT)=""
IF TIUCNT#10'>0
WRITE "."
+40 SET ^TMP("TIURIDX",$JOB,TIUCNT)=TIUCNT_U_DA
+41 SET VALMCNT=TIUCNT
+42 QUIT
CLEAN ; Clean up your mess!
+1 KILL ^TMP("TIUR",$JOB),^TMP("TIURIDX",$JOB)
DO CLEAN^VALM10
+2 KILL VALMY
+3 QUIT
URGENCY(TIUDA) ; What is the urgency of the current document
+1 NEW TIUY,TIUD0,TIUDSTAT,TIUDURG
+2 SET TIUD0=$GET(^TIU(8925,+TIUDA,0))
SET TIUDSTAT=$PIECE(TIUD0,U,5)
+3 SET TIUDURG=$PIECE(TIUD0,U,9)
+4 SET TIUY=$SELECT(TIUDSTAT<7:$SELECT(TIUDURG="P":1,1:2),1:3)
+5 QUIT TIUY
