TIUPRDS1 ; SLC/SBW,JER - Print DS Form 10-1000 ;8/15/06 11:01
;;1.0;TEXT INTEGRATION UTILITIES;**55,52,162,211**;Jun 20, 1997;Build 26
PRINT(TIUDA,TIUFLAG) ; Print Summary
; TIUCONT=1 for Continue, 0 for Exit, NULL for Timeout.
; Returned from $$Stop
N TIUADD,TIUPAGE,TIUCOPY,TIUSTAT,TIUCONT,TIUY,TIU,STDTTL
S TIUPAGE=1 D GETTIU^TIULD(.TIU,TIUDA)
I +$G(TIU("LDT")),+$G(TIU("AD#")) D I 1
. N DGPMIFN S DGPMIFN=+$G(TIU("AD#")) D ^DGPMLOS S TIU("DAYS")=X
E S TIU("WARD")=""
I $E(IOST,1,2)="P-",+$G(TIUFLAG) S TIUCOPY=$S(+TIUFLAG=2:"ELECTRONICALLY SIGNED CHART COPY",1:"C H A R T C O P Y")
E S TIUSTAT=$$STATUS^TIULC(TIUDA),TIUCOPY=$S(TIUSTAT="completed":"C O P Y",1:"D R A F T")
W:$E(IOST,1,2)="C-" @IOF D HEADER^TIUPRDS2(TIUDA,.TIU,TIUFLAG,.TIUPAGE)
W !,"DICTATION DATE: ",$P(^TMP("TIULQ",$J,TIUDA,1307,"E"),"@"),?40,"TRANSCRIPTION DATE: ",$P(^TMP("TIULQ",$J,TIUDA,1201,"E"),"@")
W !,"LOCAL TITLE: ",$G(^TMP("TIULQ",$J,TIUDA,.01,"E"))
S STDTTL=$G(^TMP("TIULQ",$J,TIUDA,89261,"E"))
I $L(STDTTL)>1 W !,"STANDARD TITLE: ",STDTTL
W !,"TRANSCRIPTIONIST: ",^TMP("TIULQ",$J,TIUDA,1302,"E")
W:$E(IOST,1,2)'="C-" !!
REPORT ; Report Text
N DIW,DIWF,DIWL,DIWR,DIWT,TIUI,X,Z K ^UTILITY($J,"W")
S TIUI=0,TIUCONT=1,TIUY=6,DIWF="WN",DIWL=1,DIWR=79
F S TIUI=$O(^TMP("TIULQ",$J,TIUDA,"TEXT",TIUI)) Q:TIUI'>0 D Q:'TIUCONT
. D SETCONT() Q:'TIUCONT
. S X=^TMP("TIULQ",$J,TIUDA,"TEXT",TIUI,0) S:X="" X=" " D ^DIWP
D ^DIWW K ^UTILITY($J,"W")
Q:'TIUCONT
AMENDMNT ;If DCS has been amended, next lines are printed.
S TIUY=9 D SETCONT() Q:'TIUCONT
I +$G(^TMP("TIULQ",$J,TIUDA,1601,"I")) D
. W !!,^TMP("TIULQ",$J,TIUDA,1601,"E"),?23,"AMENDMENT FILED:"
. I $G(^TMP("TIULQ",$J,TIUDA,1603,"E"))']"" W !!?23 F TIUI=1:1:40 W "_"
. I $G(^TMP("TIULQ",$J,TIUDA,1604,"E"))]"" D
. . W !?17,"/es/",?23,^TMP("TIULQ",$J,TIUDA,1604,"E")
. . W !?23,$G(^TMP("TIULQ",$J,TIUDA,1605,"E"))
RPTSIG ; Signature should be on bottom of form, Addenda on Subsequent pages
N TIULINE,TIUSBLK,EXPSGNR,ATTNDNG
S EXPSGNR=+$G(^TMP("TIULQ",$J,TIUDA,1204,"I"))
S ATTNDNG=+$G(^TMP("TIULQ",$J,TIUDA,1209,"I"))
D LOADSIG^TIULS1(.TIUSBLK,$NA(^TMP("TIULQ",$J,TIUDA)))
S $P(TIULINE,"-",IOM)=""
S TIUY=TIUSBLK+8 D SETCONT() Q:'TIUCONT
I (IOT'="HFS")!(IOSL<250) F Q:$Y+TIUY>IOSL W ! ;move SIG to pg Bottom
I +$G(TIUFLAG) W !,TIULINE
E W !,"WORK COPY =========== UNOFFICIAL - NOT FOR MEDICAL RECORD ========== DO NOT FILE"
I EXPSGNR'=ATTNDNG W !,"SIGNATURE PHYSICIAN/DENTIST",?39,"SIGNATURE APPROVING PHYSICIAN/DENTIST"
E W !?39,"SIGNATURE APPROVING PHYSICIAN/DENTIST"
W ! S TIUI=0 F S TIUI=$O(TIUSBLK(TIUI)) Q:+TIUI'>0 W !,TIUSBLK(TIUI)
I +$G(TIUFLAG) W !,TIULINE
E W !,"=========================== CONFIDENTIAL INFORMATION ==========================="
ADDENDA ; Discharge Summary Addenda
N DIW,DIWF,DIWL,DIWR,DIWT,X,Z K ^UTILITY($J,"W")
S TIUADD=0,DIWF="WN",DIWL=1,DIWR=79
F S TIUADD=$O(^TMP("TIULQ",$J,TIUDA,"ZADD",TIUADD)) Q:TIUADD'>0 D Q:'TIUCONT
. S TIUY=6 D SETCONT() Q:'TIUCONT
. W !!,$G(^TMP("TIULQ",$J,TIUDA,"ZADD",TIUADD,1201,"E")),?23,"ADDENDUM" ;P162
. W ?39,"STATUS: ",$G(^TMP("TIULQ",$J,TIUDA,"ZADD",TIUADD,.05,"E")) ;P162
. S TIUI=0
. F S TIUI=$O(^TMP("TIULQ",$J,TIUDA,"ZADD",TIUADD,"TEXT",TIUI)) Q:TIUI'>0 D Q:'TIUCONT
. . D SETCONT() Q:'TIUCONT
. . S X=^TMP("TIULQ",$J,TIUDA,"ZADD",TIUADD,"TEXT",TIUI,0) S:X="" X=" " D ^DIWP
. D ^DIWW
. D:TIUCONT ADDENSIG
; Next line moves footer to bottom of page/screen
I TIUCONT,((IOT'="HFS")!(IOSL<250)) S TIUY=6 F Q:$Y+TIUY>IOSL W !
I D SETCONT(1)
K ^UTILITY($J,"W")
Q
ADDENSIG ;
N TIUSBLK,EXPSGNR,ATTNDNG
D LOADSIG^TIULS1(.TIUSBLK,$NA(^TMP("TIULQ",$J,TIUDA,"ZADD",TIUADD)))
S $P(TIULINE,"-",80)=""
S EXPSGNR=$G(^TMP("TIULQ",$J,TIUDA,"ZADD",TIUADD,1204,"I"))
S ATTNDNG=$G(^TMP("TIULQ",$J,TIUDA,"ZADD",TIUADD,1209,"I"))
S TIUY=12 D SETCONT() Q:'TIUCONT
I EXPSGNR'=ATTNDNG W !,"SIGNATURE PHYSICIAN/DENTIST",?39,"SIGNATURE APPROVING PHYSICIAN/DENTIST"
E W !?39,"SIGNATURE APPROVING PHYSICIAN/DENTIST"
W ! S TIUI=0 F S TIUI=$O(TIUSBLK(TIUI)) Q:+TIUI'>0 W !,TIUSBLK(TIUI)
Q
SETCONT(TIUHEAD) ;Does footer and sets TIUCONT
S TIUCONT=$$FOOTER^TIUPRDS2(TIUDA,.TIU,TIUFLAG,.TIUPAGE,TIUCOPY,$G(TIUHEAD))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPRDS1 4264 printed Oct 16, 2024@18:44:11 Page 2
TIUPRDS1 ; SLC/SBW,JER - Print DS Form 10-1000 ;8/15/06 11:01
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**55,52,162,211**;Jun 20, 1997;Build 26
PRINT(TIUDA,TIUFLAG) ; Print Summary
+1 ; TIUCONT=1 for Continue, 0 for Exit, NULL for Timeout.
+2 ; Returned from $$Stop
+3 NEW TIUADD,TIUPAGE,TIUCOPY,TIUSTAT,TIUCONT,TIUY,TIU,STDTTL
+4 SET TIUPAGE=1
DO GETTIU^TIULD(.TIU,TIUDA)
+5 IF +$GET(TIU("LDT"))
IF +$GET(TIU("AD#"))
Begin DoDot:1
+6 NEW DGPMIFN
SET DGPMIFN=+$GET(TIU("AD#"))
DO ^DGPMLOS
SET TIU("DAYS")=X
End DoDot:1
IF 1
+7 IF '$TEST
SET TIU("WARD")=""
+8 IF $EXTRACT(IOST,1,2)="P-"
IF +$GET(TIUFLAG)
SET TIUCOPY=$SELECT(+TIUFLAG=2:"ELECTRONICALLY SIGNED CHART COPY",1:"C H A R T C O P Y")
+9 IF '$TEST
SET TIUSTAT=$$STATUS^TIULC(TIUDA)
SET TIUCOPY=$SELECT(TIUSTAT="completed":"C O P Y",1:"D R A F T")
+10 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
DO HEADER^TIUPRDS2(TIUDA,.TIU,TIUFLAG,.TIUPAGE)
+11 WRITE !,"DICTATION DATE: ",$PIECE(^TMP("TIULQ",$JOB,TIUDA,1307,"E"),"@"),?40,"TRANSCRIPTION DATE: ",$PIECE(^TMP("TIULQ",$JOB,TIUDA,1201,"E"),"@")
+12 WRITE !,"LOCAL TITLE: ",$GET(^TMP("TIULQ",$JOB,TIUDA,.01,"E"))
+13 SET STDTTL=$GET(^TMP("TIULQ",$JOB,TIUDA,89261,"E"))
+14 IF $LENGTH(STDTTL)>1
WRITE !,"STANDARD TITLE: ",STDTTL
+15 WRITE !,"TRANSCRIPTIONIST: ",^TMP("TIULQ",$JOB,TIUDA,1302,"E")
+16 if $EXTRACT(IOST,1,2)'="C-"
WRITE !!
REPORT ; Report Text
+1 NEW DIW,DIWF,DIWL,DIWR,DIWT,TIUI,X,Z
KILL ^UTILITY($JOB,"W")
+2 SET TIUI=0
SET TIUCONT=1
SET TIUY=6
SET DIWF="WN"
SET DIWL=1
SET DIWR=79
+3 FOR
SET TIUI=$ORDER(^TMP("TIULQ",$JOB,TIUDA,"TEXT",TIUI))
if TIUI'>0
QUIT
Begin DoDot:1
+4 DO SETCONT()
if 'TIUCONT
QUIT
+5 SET X=^TMP("TIULQ",$JOB,TIUDA,"TEXT",TIUI,0)
if X=""
SET X=" "
DO ^DIWP
End DoDot:1
if 'TIUCONT
QUIT
+6 DO ^DIWW
KILL ^UTILITY($JOB,"W")
+7 if 'TIUCONT
QUIT
AMENDMNT ;If DCS has been amended, next lines are printed.
+1 SET TIUY=9
DO SETCONT()
if 'TIUCONT
QUIT
+2 IF +$GET(^TMP("TIULQ",$JOB,TIUDA,1601,"I"))
Begin DoDot:1
+3 WRITE !!,^TMP("TIULQ",$JOB,TIUDA,1601,"E"),?23,"AMENDMENT FILED:"
+4 IF $GET(^TMP("TIULQ",$JOB,TIUDA,1603,"E"))']""
WRITE !!?23
FOR TIUI=1:1:40
WRITE "_"
+5 IF $GET(^TMP("TIULQ",$JOB,TIUDA,1604,"E"))]""
Begin DoDot:2
+6 WRITE !?17,"/es/",?23,^TMP("TIULQ",$JOB,TIUDA,1604,"E")
+7 WRITE !?23,$GET(^TMP("TIULQ",$JOB,TIUDA,1605,"E"))
End DoDot:2
End DoDot:1
RPTSIG ; Signature should be on bottom of form, Addenda on Subsequent pages
+1 NEW TIULINE,TIUSBLK,EXPSGNR,ATTNDNG
+2 SET EXPSGNR=+$GET(^TMP("TIULQ",$JOB,TIUDA,1204,"I"))
+3 SET ATTNDNG=+$GET(^TMP("TIULQ",$JOB,TIUDA,1209,"I"))
+4 DO LOADSIG^TIULS1(.TIUSBLK,$NAME(^TMP("TIULQ",$JOB,TIUDA)))
+5 SET $PIECE(TIULINE,"-",IOM)=""
+6 SET TIUY=TIUSBLK+8
DO SETCONT()
if 'TIUCONT
QUIT
+7 ;move SIG to pg Bottom
IF (IOT'="HFS")!(IOSL<250)
FOR
if $Y+TIUY>IOSL
QUIT
WRITE !
+8 IF +$GET(TIUFLAG)
WRITE !,TIULINE
+9 IF '$TEST
WRITE !,"WORK COPY =========== UNOFFICIAL - NOT FOR MEDICAL RECORD ========== DO NOT FILE"
+10 IF EXPSGNR'=ATTNDNG
WRITE !,"SIGNATURE PHYSICIAN/DENTIST",?39,"SIGNATURE APPROVING PHYSICIAN/DENTIST"
+11 IF '$TEST
WRITE !?39,"SIGNATURE APPROVING PHYSICIAN/DENTIST"
+12 WRITE !
SET TIUI=0
FOR
SET TIUI=$ORDER(TIUSBLK(TIUI))
if +TIUI'>0
QUIT
WRITE !,TIUSBLK(TIUI)
+13 IF +$GET(TIUFLAG)
WRITE !,TIULINE
+14 IF '$TEST
WRITE !,"=========================== CONFIDENTIAL INFORMATION ==========================="
ADDENDA ; Discharge Summary Addenda
+1 NEW DIW,DIWF,DIWL,DIWR,DIWT,X,Z
KILL ^UTILITY($JOB,"W")
+2 SET TIUADD=0
SET DIWF="WN"
SET DIWL=1
SET DIWR=79
+3 FOR
SET TIUADD=$ORDER(^TMP("TIULQ",$JOB,TIUDA,"ZADD",TIUADD))
if TIUADD'>0
QUIT
Begin DoDot:1
+4 SET TIUY=6
DO SETCONT()
if 'TIUCONT
QUIT
+5 ;P162
WRITE !!,$GET(^TMP("TIULQ",$JOB,TIUDA,"ZADD",TIUADD,1201,"E")),?23,"ADDENDUM"
+6 ;P162
WRITE ?39,"STATUS: ",$GET(^TMP("TIULQ",$JOB,TIUDA,"ZADD",TIUADD,.05,"E"))
+7 SET TIUI=0
+8 FOR
SET TIUI=$ORDER(^TMP("TIULQ",$JOB,TIUDA,"ZADD",TIUADD,"TEXT",TIUI))
if TIUI'>0
QUIT
Begin DoDot:2
+9 DO SETCONT()
if 'TIUCONT
QUIT
+10 SET X=^TMP("TIULQ",$JOB,TIUDA,"ZADD",TIUADD,"TEXT",TIUI,0)
if X=""
SET X=" "
DO ^DIWP
End DoDot:2
if 'TIUCONT
QUIT
+11 DO ^DIWW
+12 if TIUCONT
DO ADDENSIG
End DoDot:1
if 'TIUCONT
QUIT
+13 ; Next line moves footer to bottom of page/screen
+14 IF TIUCONT
IF ((IOT'="HFS")!(IOSL<250))
SET TIUY=6
FOR
if $Y+TIUY>IOSL
QUIT
WRITE !
+15 IF $TEST
DO SETCONT(1)
+16 KILL ^UTILITY($JOB,"W")
+17 QUIT
ADDENSIG ;
+1 NEW TIUSBLK,EXPSGNR,ATTNDNG
+2 DO LOADSIG^TIULS1(.TIUSBLK,$NAME(^TMP("TIULQ",$JOB,TIUDA,"ZADD",TIUADD)))
+3 SET $PIECE(TIULINE,"-",80)=""
+4 SET EXPSGNR=$GET(^TMP("TIULQ",$JOB,TIUDA,"ZADD",TIUADD,1204,"I"))
+5 SET ATTNDNG=$GET(^TMP("TIULQ",$JOB,TIUDA,"ZADD",TIUADD,1209,"I"))
+6 SET TIUY=12
DO SETCONT()
if 'TIUCONT
QUIT
+7 IF EXPSGNR'=ATTNDNG
WRITE !,"SIGNATURE PHYSICIAN/DENTIST",?39,"SIGNATURE APPROVING PHYSICIAN/DENTIST"
+8 IF '$TEST
WRITE !?39,"SIGNATURE APPROVING PHYSICIAN/DENTIST"
+9 WRITE !
SET TIUI=0
FOR
SET TIUI=$ORDER(TIUSBLK(TIUI))
if +TIUI'>0
QUIT
WRITE !,TIUSBLK(TIUI)
+10 QUIT
SETCONT(TIUHEAD) ;Does footer and sets TIUCONT
+1 SET TIUCONT=$$FOOTER^TIUPRDS2(TIUDA,.TIU,TIUFLAG,.TIUPAGE,TIUCOPY,$GET(TIUHEAD))
+2 QUIT
