- 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 Apr 23, 2025@18:58:08 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
