TIUASRPT ; SLC/JMH - Review unsigned additional signer Documents by DIVISION ; [12/2/04 11:50am]
;;1.0;TEXT INTEGRATION UTILITIES;**157**;Jun 20, 1997
BEGIN ; Select Division(s), Entry Date Range, Service, Type of Report
N TIUI,TIUSTDT,TIUENDT,TIUSVCS
D SELDIV^TIULA Q:SELDIV'>0
I $D(TIUDI) D
. S TIUI=0 F S TIUI=$O(TIUDI(TIUI)) Q:'TIUI D
. . S TIUDI("ENTRIES")=$G(TIUDI("ENTRIES"))_TIUI_";"
E D
. S TIUDI("ENTRIES")="ALL DIVISIONS"
;
;Ask Date Range, exit if timeout, '^' or no selection
Q:'$$ASKRNG(.TIUSTDT,.TIUENDT)
;
;Select Service, exit if timeout, '^' or no selection
Q:'$$SELSVC^TIULA(.TIUSVCS)
;
N DIR,DIRUT,DTOUT,DUOUT,TIURPT
S DIR(0)="S^F:FULL;S:SUMMARY",DIR("A")="Type of Report"
S DIR("?",1)="Summary lists the number of documents by author's"
S DIR("?",2)="service/section. Full lists detailed document"
S DIR("?",3)="information by author's service/section."
S DIR("?")="Enter ""^"", or a RETURN to quit."
D ^DIR Q:$D(DIRUT) S TIURPT=Y
;
DEV ; Device selection
I TIURPT="F" D
. W !!,"This report should be sent to a 132 Column Device"
S %ZIS="Q" W ! D ^%ZIS I POP K POP G EXIT
I $D(IO("Q")) D G EXIT
. S ZTRTN="BUILD^TIUASRPT"
. S ZTSAVE("TIUDI(")="",ZTSAVE("TIURPT")=""
. S ZTSAVE("TIUSTDT")="",ZTSAVE("TIUENDT")=""
. S ZTSAVE("TIUSVCS")="",ZTSAVE("TIUSVCS(")=""
. S ZTDESC="TIU PENDING ADD. SIGNATURES BY DIV"
. D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled!")
. K ZTSK,ZTDESC,ZTRTN,ZTSAVE,%ZIS,TIUDIV,TIURPT,TIUIFP
. D HOME^%ZIS
U IO D BUILD,^%ZISC
Q
BUILD ; Build list
N TIUIFP,TIUK
K ^TMP("TIUD",$J)
I $D(ZTQUEUED) S ZTREQ="@"
I +$G(TIUDI("ENTRIES")) D
. S TIUK=0 F S TIUK=$O(TIUDI(TIUK)) Q:'TIUK D
. . S TIUIFP=$G(TIUDI(TIUK))
. . D GATHER(TIUIFP,TIUSTDT,TIUENDT,.TIUSVCS)
E D
. S TIUIFP=0
. F S TIUIFP=$O(^TIU(8925,"ADIV",TIUIFP)) Q:+TIUIFP'>0 D
. . D GATHER(TIUIFP,TIUSTDT,TIUENDT,.TIUSVCS)
D PRINT
;
EXIT ; Clean up and exit
K SELDIV,TIUDI,TIUSTDT,TIUENDT,TIUSVCS K ^TMP("TIUD",$J)
Q
GATHER(TIUIFP,TIUSTDT,TIUENDT,TIUSVCS) ; Find records for the list
; Input -- TIUIFP INSTITUTION file (#4) IEN
; (0 = gather all divisions)
; TIUSTDT Start Date
; TIUENDT End Date
; TIUSVCS Service Selection Array
; Output -- None
N TIUDA,TIUJ,TIUS,TIUTP
S TIUTP=TIUSTDT
F S TIUTP=$O(^TIU(8925.7,"AC",TIUTP)) Q:'TIUTP!(TIUTP>(TIUENDT+1)) D
. N TIUIEN S TIUIEN=0
. F S TIUIEN=$O(^TIU(8925.7,"AC",TIUTP,TIUIEN)) Q:'TIUIEN D
. . I $P($G(^TIU(8925,TIUIEN,12)),U,12)'=TIUIFP Q
. . D ADDELMNT(TIUIEN,.TIUSVCS)
Q
;
ADDELMNT(TIUDA,TIUSVCS) ; Add each element to the list
; Input -- TIUDA TIU DOCUMENT file (#8925) IEN
; TIUSVCS Service Selection Array
; Output -- None
N TIUASREC,TIUSVC,TIUEDT,TIUD12,TIUIFP,TIUSTAT
S TIUSTAT=$P($G(^TIU(8925,TIUDA,0)),U,5)
I TIUSTAT>8 Q
S TIUASREC=0
S TIUD12=$G(^TIU(8925,TIUDA,12))
S TIUEDT=+$P(TIUD12,U),TIUIFP=+$P(TIUD12,U,12)
F S TIUASREC=$O(^TIU(8925.7,"B",TIUDA,TIUASREC)) Q:'TIUASREC D
. N TIUAS,TIUASSVC
. S TIUAS=$P(^TIU(8925.7,TIUASREC,0),U,3)
. I 'TIUAS!$P(^TIU(8925.7,TIUASREC,0),U,4) Q
. S TIUASSVC=$$PROVSVC^TIULV(TIUAS)
. I $G(TIUSVCS)="ALL"!($D(TIUSVCS(+TIUASSVC))) D
. . S TIUAS=$$PERSNAME^TIULC1(TIUAS)
. . I $P(TIUASSVC,U,2)]"" S TIUASSVC=$P(TIUASSVC,U,2)
. . E S TIUASSVC="UNKNOWN"
. . I TIUAS'="UNKNOWN" S TIUAS=$$NAME^TIULS(TIUAS,"LAST, FI MI")
. . S ^TMP("TIUD",$J,TIUIFP,TIUASSVC,TIUAS,TIUEDT)=TIUDA
Q
;
PRNT(TIUDA) ; Does document have a parent?
; Input -- TIUDA TIU Document file (#8925) IEN
; Output -- TIUPRNT Null= TIU Document file (#8925) entry does
; not have a parent
; Exists= TIU Document file (#8925) entry is
; an addendum or ID child.
; Value: Parent TIU Document file
; (#8925) IEN
N ADDMPRNT,IDPRNT,TIUPRNT
S TIUPRNT=""
S ADDMPRNT=+$P($G(^TIU(8925,TIUDA,0)),U,6) ; Addm parent
I '$D(^TIU(8925,ADDMPRNT,0)) S ADDMPRNT=0
I ADDMPRNT D
. S TIUPRNT=ADDMPRNT
E D
. S IDPRNT=+$G(^TIU(8925,TIUDA,21)) ; ID parent
. I '$D(^TIU(8925,IDPRNT,0)) S IDPRNT=0
. I IDPRNT D
. . S TIUPRNT=IDPRNT
Q TIUPRNT
;
ASKRNG(STDT,ENDT) ;Prompt for entry date range
; Input -- None
; Output -- 1=Successful and 0=Failure
; STDT Start Date
; ENDT End Date
N DIRUT,DTOUT,DUOUT,Y
W !!,"Please specify an Entry Date Range:",!
S STDT=+$$READ^TIUU("DA^:DT:E"," Start Entry Date: ")
I $D(DIRUT)!(STDT'>0) G ASKRNGQ
S ENDT=+$$READ^TIUU("DA^"_STDT_":DT:E","Ending Entry Date: ")_"."_235959
I $D(DIRUT)!(ENDT'>0) G ASKRNGQ
S Y=1
ASKRNGQ Q +$G(Y)
DHDR(TIUFP,TIUSTDT,TIUENDT) ;
;DIVISION HEADER
N TIUR,TIURNG,TIUINST
S TIUPG=(+$G(TIUPG))+1
D DT^DILF("ET","NOW",.TIUR)
S TIURNG=$$FMTE^XLFDT(TIUSTDT)_" thru "_$$FMTE^XLFDT(TIUENDT)
S TIUINST=$S(TIUIFP:$P($$NS^XUAF4(TIUIFP),U),1:"ALL DIVISIONS")
W @IOF,"Pending Additional Signature Documents for "_TIUINST
W " on "_$$FMTE^XLFDT($$NOW^XLFDT)
W !,?10,TIURNG,?70,"Page: "_+$G(TIUPG)
I TIURPT'="F" D
. W !,"------------------------------------------------------------------------------"
I TIURPT="F" D
. W !,"------------------------------------------------------------------------------------------------------------------------------------"
. W !,"IDENT. SIGNER",?17,"PATIENT",?27,"STATUS",?35,"ENTRY DATE"
. W ?54,"DOCUMENT TITLE",?81,"DOCUMENT IEN"
. W !,"------------------------------------------------------------------------------------------------------------------------------------"
Q
SHDR(TIUSVC) ;
; SERVICE HEADER
W !!?10,"SERVICE: ",TIUSVC
Q
PRINT ;
N TIUPG,TIUIFP,TIUOUT,TIUTOT
S (TIUPG,TIUIFP,TIUOUT,TIUTOT)=0
F S TIUIFP=$O(^TMP("TIUD",$J,TIUIFP)) Q:'TIUIFP!(TIUOUT) D
. N TIUSVC,TIUDCNT
. S (TIUSVC,TIUDCNT)=0
. D DHDR(TIUIFP,TIUSTDT,TIUENDT)
. F S TIUSVC=$O(^TMP("TIUD",$J,TIUIFP,TIUSVC)) Q:TIUSVC=""!(TIUOUT) D
. . N TIUAS,TIUSVCNT
. . S (TIUAS,TIUSVCNT)=0
. . I $Y>(IOSL-5) D ASK Q:TIUOUT D DHDR(TIUIFP,TIUSTDT,TIUENDT)
. . I TIURPT="F" D SHDR(TIUSVC)
. . F S TIUAS=$O(^TMP("TIUD",$J,TIUIFP,TIUSVC,TIUAS)) Q:TIUAS=""!(TIUOUT) D
. . . N TIUEDT
. . . S TIUEDT=""
. . . F S TIUEDT=$O(^TMP("TIUD",$J,TIUIFP,TIUSVC,TIUAS,TIUEDT)) Q:'TIUEDT!(TIUOUT) D
. . . . N TIUDA
. . . . S TIUDA=^TMP("TIUD",$J,TIUIFP,TIUSVC,TIUAS,TIUEDT)
. . . . I TIURPT="F" D PRNTITEM(TIUDA,TIUAS,TIUEDT)
. . . . I $Y>(IOSL-5) D ASK Q:TIUOUT D DHDR(TIUIFP,TIUSTDT,TIUENDT)
. . . . S TIUSVCNT=TIUSVCNT+1,TIUDCNT=TIUDCNT+1
. . W !," Totals for Service ",TIUSVC,": ",?55,TIUSVCNT
. . I $Y>(IOSL-5) D ASK Q:TIUOUT D DHDR(TIUIFP,TIUSTDT,TIUENDT)
. Q:TIUOUT
. N TIUDVSTR S TIUDVSTR=$E($P($$NS^XUAF4(TIUIFP),U),1,25)
. W !,"Totals for Division ",TIUDVSTR,": ",?55,TIUDCNT
. I $O(^TMP("TIUD",$J,TIUIFP)) D ASK Q:TIUOUT
. S TIUTOT=TIUTOT+TIUDCNT
Q:TIUOUT
W !,"Totals for all Divisions: ",?55,TIUTOT
Q
PRNTITEM(TIUDA,TIUAS,TIUEDT) ;
N TIUPRNT,TIUPAT,TIUSTAT,TIUTYP,TIUD0,TIUD12,TIULST4,TIUDATE
S TIUPRNT=$$PRNT(TIUDA)
S TIUD0=$G(^TIU(8925,TIUDA,0))
S TIULST4=$E($$GET1^DIQ(2,$G(TIUPAT),.09),6,9)
S TIUPAT=$$PATPRNT($P($G(TIUD0),U,2))
S TIUSTAT=$P($G(TIUD0),U,5)
S TIUSTAT=$S(TIUSTAT:$E($$EXTERNAL^DILFD(8925,.05,"",TIUSTAT),1,11),1:"UNKNOWN")
S TIUSTAT=$$STATXFER(TIUSTAT)
S TIUTYP=+TIUD0
S TIUTYP=$E($P($G(^TIU(8925.1,TIUTYP,0)),U),1,25)
S TIUDATE=$$FMTE^XLFDT(TIUEDT,2)
W !,TIUAS,?17,$G(TIUPAT),?27," "_TIUSTAT,?35,$G(TIUDATE)
W ?54,$G(TIUTYP),?81,TIUDA
I +$G(TIUPRNT) W " PARENT = "_TIUPRNT
Q
ASK ;
I IO=IO(0),$E(IOST)="C" D
. W ! N DIR,Y S DIR(0)="E" D ^DIR K DIR
. I Y=""!(Y=0) S TIUOUT=1
Q
STATXFER(TIUSTAT) ;format a small status string
I TIUSTAT="COMPLETED"!(TIUSTAT="completed") Q "com"
I TIUSTAT="UNSIGNED"!(TIUSTAT="unsigned") Q "uns"
I TIUSTAT="UNCOSIGNED"!(TIUSTAT="uncosigned") Q "uncos"
I TIUSTAT="UNDICTATED"!(TIUSTAT="undictated") Q "undic"
I TIUSTAT="UNTRANSCRIBED"!(TIUSTAT="untranscribed") Q "untr"
I TIUSTAT="UNRELEASED"!(TIUSTAT="unreleased") Q "unrel"
I TIUSTAT="UNVERIFIED"!(TIUSTAT="unverified") Q "unver"
I TIUSTAT="AMENDED"!(TIUSTAT="amended") Q "amend"
Q "???"
PATPRNT(TIUPAT) ; format patient as initials and then last 6 SSN
N PAT,LST4,INIT
I 'TIUPAT Q ""
S PAT=$$EXTERNAL^DILFD(8925,.02,"",TIUPAT)
S LST4=$E($$GET1^DIQ(2,$G(TIUPAT),.09),4,9)
S INIT=$E($P(PAT,",",2))_$E($P(PAT,","))
Q INIT_LST4
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUASRPT 8586 printed Apr 09, 2024@21:47:44 Page 2
TIUASRPT ; SLC/JMH - Review unsigned additional signer Documents by DIVISION ; [12/2/04 11:50am]
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**157**;Jun 20, 1997
BEGIN ; Select Division(s), Entry Date Range, Service, Type of Report
+1 NEW TIUI,TIUSTDT,TIUENDT,TIUSVCS
+2 DO SELDIV^TIULA
if SELDIV'>0
QUIT
+3 IF $DATA(TIUDI)
Begin DoDot:1
+4 SET TIUI=0
FOR
SET TIUI=$ORDER(TIUDI(TIUI))
if 'TIUI
QUIT
Begin DoDot:2
+5 SET TIUDI("ENTRIES")=$GET(TIUDI("ENTRIES"))_TIUI_";"
End DoDot:2
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET TIUDI("ENTRIES")="ALL DIVISIONS"
End DoDot:1
+8 ;
+9 ;Ask Date Range, exit if timeout, '^' or no selection
+10 if '$$ASKRNG(.TIUSTDT,.TIUENDT)
QUIT
+11 ;
+12 ;Select Service, exit if timeout, '^' or no selection
+13 if '$$SELSVC^TIULA(.TIUSVCS)
QUIT
+14 ;
+15 NEW DIR,DIRUT,DTOUT,DUOUT,TIURPT
+16 SET DIR(0)="S^F:FULL;S:SUMMARY"
SET DIR("A")="Type of Report"
+17 SET DIR("?",1)="Summary lists the number of documents by author's"
+18 SET DIR("?",2)="service/section. Full lists detailed document"
+19 SET DIR("?",3)="information by author's service/section."
+20 SET DIR("?")="Enter ""^"", or a RETURN to quit."
+21 DO ^DIR
if $DATA(DIRUT)
QUIT
SET TIURPT=Y
+22 ;
DEV ; Device selection
+1 IF TIURPT="F"
Begin DoDot:1
+2 WRITE !!,"This report should be sent to a 132 Column Device"
End DoDot:1
+3 SET %ZIS="Q"
WRITE !
DO ^%ZIS
IF POP
KILL POP
GOTO EXIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTRTN="BUILD^TIUASRPT"
+6 SET ZTSAVE("TIUDI(")=""
SET ZTSAVE("TIURPT")=""
+7 SET ZTSAVE("TIUSTDT")=""
SET ZTSAVE("TIUENDT")=""
+8 SET ZTSAVE("TIUSVCS")=""
SET ZTSAVE("TIUSVCS(")=""
+9 SET ZTDESC="TIU PENDING ADD. SIGNATURES BY DIV"
+10 DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"Request Queued!",1:"Request Cancelled!")
+11 KILL ZTSK,ZTDESC,ZTRTN,ZTSAVE,%ZIS,TIUDIV,TIURPT,TIUIFP
+12 DO HOME^%ZIS
End DoDot:1
GOTO EXIT
+13 USE IO
DO BUILD
DO ^%ZISC
+14 QUIT
BUILD ; Build list
+1 NEW TIUIFP,TIUK
+2 KILL ^TMP("TIUD",$JOB)
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 IF +$GET(TIUDI("ENTRIES"))
Begin DoDot:1
+5 SET TIUK=0
FOR
SET TIUK=$ORDER(TIUDI(TIUK))
if 'TIUK
QUIT
Begin DoDot:2
+6 SET TIUIFP=$GET(TIUDI(TIUK))
+7 DO GATHER(TIUIFP,TIUSTDT,TIUENDT,.TIUSVCS)
End DoDot:2
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 SET TIUIFP=0
+10 FOR
SET TIUIFP=$ORDER(^TIU(8925,"ADIV",TIUIFP))
if +TIUIFP'>0
QUIT
Begin DoDot:2
+11 DO GATHER(TIUIFP,TIUSTDT,TIUENDT,.TIUSVCS)
End DoDot:2
End DoDot:1
+12 DO PRINT
+13 ;
EXIT ; Clean up and exit
+1 KILL SELDIV,TIUDI,TIUSTDT,TIUENDT,TIUSVCS
KILL ^TMP("TIUD",$JOB)
+2 QUIT
GATHER(TIUIFP,TIUSTDT,TIUENDT,TIUSVCS) ; Find records for the list
+1 ; Input -- TIUIFP INSTITUTION file (#4) IEN
+2 ; (0 = gather all divisions)
+3 ; TIUSTDT Start Date
+4 ; TIUENDT End Date
+5 ; TIUSVCS Service Selection Array
+6 ; Output -- None
+7 NEW TIUDA,TIUJ,TIUS,TIUTP
+8 SET TIUTP=TIUSTDT
+9 FOR
SET TIUTP=$ORDER(^TIU(8925.7,"AC",TIUTP))
if 'TIUTP!(TIUTP>(TIUENDT+1))
QUIT
Begin DoDot:1
+10 NEW TIUIEN
SET TIUIEN=0
+11 FOR
SET TIUIEN=$ORDER(^TIU(8925.7,"AC",TIUTP,TIUIEN))
if 'TIUIEN
QUIT
Begin DoDot:2
+12 IF $PIECE($GET(^TIU(8925,TIUIEN,12)),U,12)'=TIUIFP
QUIT
+13 DO ADDELMNT(TIUIEN,.TIUSVCS)
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
ADDELMNT(TIUDA,TIUSVCS) ; Add each element to the list
+1 ; Input -- TIUDA TIU DOCUMENT file (#8925) IEN
+2 ; TIUSVCS Service Selection Array
+3 ; Output -- None
+4 NEW TIUASREC,TIUSVC,TIUEDT,TIUD12,TIUIFP,TIUSTAT
+5 SET TIUSTAT=$PIECE($GET(^TIU(8925,TIUDA,0)),U,5)
+6 IF TIUSTAT>8
QUIT
+7 SET TIUASREC=0
+8 SET TIUD12=$GET(^TIU(8925,TIUDA,12))
+9 SET TIUEDT=+$PIECE(TIUD12,U)
SET TIUIFP=+$PIECE(TIUD12,U,12)
+10 FOR
SET TIUASREC=$ORDER(^TIU(8925.7,"B",TIUDA,TIUASREC))
if 'TIUASREC
QUIT
Begin DoDot:1
+11 NEW TIUAS,TIUASSVC
+12 SET TIUAS=$PIECE(^TIU(8925.7,TIUASREC,0),U,3)
+13 IF 'TIUAS!$PIECE(^TIU(8925.7,TIUASREC,0),U,4)
QUIT
+14 SET TIUASSVC=$$PROVSVC^TIULV(TIUAS)
+15 IF $GET(TIUSVCS)="ALL"!($DATA(TIUSVCS(+TIUASSVC)))
Begin DoDot:2
+16 SET TIUAS=$$PERSNAME^TIULC1(TIUAS)
+17 IF $PIECE(TIUASSVC,U,2)]""
SET TIUASSVC=$PIECE(TIUASSVC,U,2)
+18 IF '$TEST
SET TIUASSVC="UNKNOWN"
+19 IF TIUAS'="UNKNOWN"
SET TIUAS=$$NAME^TIULS(TIUAS,"LAST, FI MI")
+20 SET ^TMP("TIUD",$JOB,TIUIFP,TIUASSVC,TIUAS,TIUEDT)=TIUDA
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
PRNT(TIUDA) ; Does document have a parent?
+1 ; Input -- TIUDA TIU Document file (#8925) IEN
+2 ; Output -- TIUPRNT Null= TIU Document file (#8925) entry does
+3 ; not have a parent
+4 ; Exists= TIU Document file (#8925) entry is
+5 ; an addendum or ID child.
+6 ; Value: Parent TIU Document file
+7 ; (#8925) IEN
+8 NEW ADDMPRNT,IDPRNT,TIUPRNT
+9 SET TIUPRNT=""
+10 ; Addm parent
SET ADDMPRNT=+$PIECE($GET(^TIU(8925,TIUDA,0)),U,6)
+11 IF '$DATA(^TIU(8925,ADDMPRNT,0))
SET ADDMPRNT=0
+12 IF ADDMPRNT
Begin DoDot:1
+13 SET TIUPRNT=ADDMPRNT
End DoDot:1
+14 IF '$TEST
Begin DoDot:1
+15 ; ID parent
SET IDPRNT=+$GET(^TIU(8925,TIUDA,21))
+16 IF '$DATA(^TIU(8925,IDPRNT,0))
SET IDPRNT=0
+17 IF IDPRNT
Begin DoDot:2
+18 SET TIUPRNT=IDPRNT
End DoDot:2
End DoDot:1
+19 QUIT TIUPRNT
+20 ;
ASKRNG(STDT,ENDT) ;Prompt for entry date range
+1 ; Input -- None
+2 ; Output -- 1=Successful and 0=Failure
+3 ; STDT Start Date
+4 ; ENDT End Date
+5 NEW DIRUT,DTOUT,DUOUT,Y
+6 WRITE !!,"Please specify an Entry Date Range:",!
+7 SET STDT=+$$READ^TIUU("DA^:DT:E"," Start Entry Date: ")
+8 IF $DATA(DIRUT)!(STDT'>0)
GOTO ASKRNGQ
+9 SET ENDT=+$$READ^TIUU("DA^"_STDT_":DT:E","Ending Entry Date: ")_"."_235959
+10 IF $DATA(DIRUT)!(ENDT'>0)
GOTO ASKRNGQ
+11 SET Y=1
ASKRNGQ QUIT +$GET(Y)
DHDR(TIUFP,TIUSTDT,TIUENDT) ;
+1 ;DIVISION HEADER
+2 NEW TIUR,TIURNG,TIUINST
+3 SET TIUPG=(+$GET(TIUPG))+1
+4 DO DT^DILF("ET","NOW",.TIUR)
+5 SET TIURNG=$$FMTE^XLFDT(TIUSTDT)_" thru "_$$FMTE^XLFDT(TIUENDT)
+6 SET TIUINST=$SELECT(TIUIFP:$PIECE($$NS^XUAF4(TIUIFP),U),1:"ALL DIVISIONS")
+7 WRITE @IOF,"Pending Additional Signature Documents for "_TIUINST
+8 WRITE " on "_$$FMTE^XLFDT($$NOW^XLFDT)
+9 WRITE !,?10,TIURNG,?70,"Page: "_+$GET(TIUPG)
+10 IF TIURPT'="F"
Begin DoDot:1
+11 WRITE !,"------------------------------------------------------------------------------"
End DoDot:1
+12 IF TIURPT="F"
Begin DoDot:1
+13 WRITE !,"------------------------------------------------------------------------------------------------------------------------------------"
+14 WRITE !,"IDENT. SIGNER",?17,"PATIENT",?27,"STATUS",?35,"ENTRY DATE"
+15 WRITE ?54,"DOCUMENT TITLE",?81,"DOCUMENT IEN"
+16 WRITE !,"------------------------------------------------------------------------------------------------------------------------------------"
End DoDot:1
+17 QUIT
SHDR(TIUSVC) ;
+1 ; SERVICE HEADER
+2 WRITE !!?10,"SERVICE: ",TIUSVC
+3 QUIT
PRINT ;
+1 NEW TIUPG,TIUIFP,TIUOUT,TIUTOT
+2 SET (TIUPG,TIUIFP,TIUOUT,TIUTOT)=0
+3 FOR
SET TIUIFP=$ORDER(^TMP("TIUD",$JOB,TIUIFP))
if 'TIUIFP!(TIUOUT)
QUIT
Begin DoDot:1
+4 NEW TIUSVC,TIUDCNT
+5 SET (TIUSVC,TIUDCNT)=0
+6 DO DHDR(TIUIFP,TIUSTDT,TIUENDT)
+7 FOR
SET TIUSVC=$ORDER(^TMP("TIUD",$JOB,TIUIFP,TIUSVC))
if TIUSVC=""!(TIUOUT)
QUIT
Begin DoDot:2
+8 NEW TIUAS,TIUSVCNT
+9 SET (TIUAS,TIUSVCNT)=0
+10 IF $Y>(IOSL-5)
DO ASK
if TIUOUT
QUIT
DO DHDR(TIUIFP,TIUSTDT,TIUENDT)
+11 IF TIURPT="F"
DO SHDR(TIUSVC)
+12 FOR
SET TIUAS=$ORDER(^TMP("TIUD",$JOB,TIUIFP,TIUSVC,TIUAS))
if TIUAS=""!(TIUOUT)
QUIT
Begin DoDot:3
+13 NEW TIUEDT
+14 SET TIUEDT=""
+15 FOR
SET TIUEDT=$ORDER(^TMP("TIUD",$JOB,TIUIFP,TIUSVC,TIUAS,TIUEDT))
if 'TIUEDT!(TIUOUT)
QUIT
Begin DoDot:4
+16 NEW TIUDA
+17 SET TIUDA=^TMP("TIUD",$JOB,TIUIFP,TIUSVC,TIUAS,TIUEDT)
+18 IF TIURPT="F"
DO PRNTITEM(TIUDA,TIUAS,TIUEDT)
+19 IF $Y>(IOSL-5)
DO ASK
if TIUOUT
QUIT
DO DHDR(TIUIFP,TIUSTDT,TIUENDT)
+20 SET TIUSVCNT=TIUSVCNT+1
SET TIUDCNT=TIUDCNT+1
End DoDot:4
End DoDot:3
+21 WRITE !," Totals for Service ",TIUSVC,": ",?55,TIUSVCNT
+22 IF $Y>(IOSL-5)
DO ASK
if TIUOUT
QUIT
DO DHDR(TIUIFP,TIUSTDT,TIUENDT)
End DoDot:2
+23 if TIUOUT
QUIT
+24 NEW TIUDVSTR
SET TIUDVSTR=$EXTRACT($PIECE($$NS^XUAF4(TIUIFP),U),1,25)
+25 WRITE !,"Totals for Division ",TIUDVSTR,": ",?55,TIUDCNT
+26 IF $ORDER(^TMP("TIUD",$JOB,TIUIFP))
DO ASK
if TIUOUT
QUIT
+27 SET TIUTOT=TIUTOT+TIUDCNT
End DoDot:1
+28 if TIUOUT
QUIT
+29 WRITE !,"Totals for all Divisions: ",?55,TIUTOT
+30 QUIT
PRNTITEM(TIUDA,TIUAS,TIUEDT) ;
+1 NEW TIUPRNT,TIUPAT,TIUSTAT,TIUTYP,TIUD0,TIUD12,TIULST4,TIUDATE
+2 SET TIUPRNT=$$PRNT(TIUDA)
+3 SET TIUD0=$GET(^TIU(8925,TIUDA,0))
+4 SET TIULST4=$EXTRACT($$GET1^DIQ(2,$GET(TIUPAT),.09),6,9)
+5 SET TIUPAT=$$PATPRNT($PIECE($GET(TIUD0),U,2))
+6 SET TIUSTAT=$PIECE($GET(TIUD0),U,5)
+7 SET TIUSTAT=$SELECT(TIUSTAT:$EXTRACT($$EXTERNAL^DILFD(8925,.05,"",TIUSTAT),1,11),1:"UNKNOWN")
+8 SET TIUSTAT=$$STATXFER(TIUSTAT)
+9 SET TIUTYP=+TIUD0
+10 SET TIUTYP=$EXTRACT($PIECE($GET(^TIU(8925.1,TIUTYP,0)),U),1,25)
+11 SET TIUDATE=$$FMTE^XLFDT(TIUEDT,2)
+12 WRITE !,TIUAS,?17,$GET(TIUPAT),?27," "_TIUSTAT,?35,$GET(TIUDATE)
+13 WRITE ?54,$GET(TIUTYP),?81,TIUDA
+14 IF +$GET(TIUPRNT)
WRITE " PARENT = "_TIUPRNT
+15 QUIT
ASK ;
+1 IF IO=IO(0)
IF $EXTRACT(IOST)="C"
Begin DoDot:1
+2 WRITE !
NEW DIR,Y
SET DIR(0)="E"
DO ^DIR
KILL DIR
+3 IF Y=""!(Y=0)
SET TIUOUT=1
End DoDot:1
+4 QUIT
STATXFER(TIUSTAT) ;format a small status string
+1 IF TIUSTAT="COMPLETED"!(TIUSTAT="completed")
QUIT "com"
+2 IF TIUSTAT="UNSIGNED"!(TIUSTAT="unsigned")
QUIT "uns"
+3 IF TIUSTAT="UNCOSIGNED"!(TIUSTAT="uncosigned")
QUIT "uncos"
+4 IF TIUSTAT="UNDICTATED"!(TIUSTAT="undictated")
QUIT "undic"
+5 IF TIUSTAT="UNTRANSCRIBED"!(TIUSTAT="untranscribed")
QUIT "untr"
+6 IF TIUSTAT="UNRELEASED"!(TIUSTAT="unreleased")
QUIT "unrel"
+7 IF TIUSTAT="UNVERIFIED"!(TIUSTAT="unverified")
QUIT "unver"
+8 IF TIUSTAT="AMENDED"!(TIUSTAT="amended")
QUIT "amend"
+9 QUIT "???"
PATPRNT(TIUPAT) ; format patient as initials and then last 6 SSN
+1 NEW PAT,LST4,INIT
+2 IF 'TIUPAT
QUIT ""
+3 SET PAT=$$EXTERNAL^DILFD(8925,.02,"",TIUPAT)
+4 SET LST4=$EXTRACT($$GET1^DIQ(2,$GET(TIUPAT),.09),4,9)
+5 SET INIT=$EXTRACT($PIECE(PAT,",",2))_$EXTRACT($PIECE(PAT,","))
+6 QUIT INIT_LST4
