BTIUPRT1 ;IHS/MSC/MGH - Print special header and foot notes;18-Mar-2015 12:30;MGH
;;1.0;TEXT INTEGRATION UTILITIES;**1008,1013**;Jun 20, 1997;Build 33
;Copy of TIUPRPN1 Print SF 509-Progress Notes ;26-Feb-2010 11:59;MGH
;IHS/ITSC/LJF 02/26/2003 added code to check for clinc not defined for visit
PRINT(TIUTYPE,TIUFLAG,TIUSPG) ; Print Document
; ^TMP("TIUPR",$J) is array of records to be printed
; TIUFLAG=1 --> Chart Copy TIUSPG=1 --> Contiguous
; TIUFLAG=0 --> Work Copy TIUSPG=0 --> Fresh Page- each note
; TIUCONT=1 --> Continue printing
; TIUCONT1=1 --> Write "Continue to next/from previous-page" msgs
; TIUPFNBR ---> Print Form # like vice 509
; TIUMISC=TIUFLAG_U_TIUPFNBR_U_TIUDA
N TIUI,TIUJ,TIUPAGE,TIUFOOT,TIUK,TIUDA,TIUCONT,TIUPGRP,TIUTYP
N TIUPFHDR,TIUPFNBR,TIUMISC,TIUCONT1,TIUIDONE,TMP,HEADER,FOOTER
S TIUFLAG=+$G(TIUFLAG),TIUSPG=+$G(TIUSPG)
S TIUCONT=1,TIUCONT1=0
S TIUI=0 F S TIUI=$O(^TMP("TIUPR",$J,TIUI)) Q:TIUI="" D Q:'TIUCONT
. N DFN,TIU
. I TIUI["$" S TIUPGRP=$P(TIUI,"$"),TIUPFHDR=$P($P(TIUI,";"),"$",2)
. E S TIUPFHDR="Progress Notes"
. I $G(TIUPGRP)>2 S TIUSPG=0
. S DFN=$P(TIUI,";",2)
. D PATPN^TIULV(.TIUFOOT,DFN)
. ;IHS/MSC/MGH check for header
.S HEADER=$$CHECK(TIUTYPE,2)
.I +HEADER D
..I $G(TIUSPG) D HEADER^BTIUPRT2(TIUFLAG,TIUCONT1,HEADER,TIUK,DFN)
.E D
..I +$G(TIUSPG) D HEADER^TIUPRPN2(.TIUFOOT,TIUFLAG,.TIUPFHDR,TIUCONT1)
. ; Use TIUJ="" (not TIUJ=0), to print "complete" notes w/o sigdt:
. S TIUJ="" F S TIUJ=$O(^TMP("TIUPR",$J,TIUI,TIUJ)) Q:TIUJ="" D Q:'TIUCONT
. . S TIUK=0 F S TIUK=$O(^TMP("TIUPR",$J,TIUI,TIUJ,TIUK)) Q:'TIUK D Q:'TIUCONT
. . . S TIUCONT1=0 S TIUPFNBR=^TMP("TIUPR",$J,TIUI,TIUJ,TIUK)
. . . ; If the document has been deleted, QUIT
. . . I '$D(^TIU(8925,+TIUK,0)) S TIUCONT=1 Q
. . . N TIUROOT
. . . S HEADER=$$CHECK(TIUTYPE,2)
. . . I +HEADER D
. . . . I '+$G(TIUSPG) D HEADER^BTIUPRT2(TIUFLAG,TIUCONT1,HEADER,TIUK,DFN)
. . . E D
. . . . I '+$G(TIUSPG) D HEADER^TIUPRPN2(.TIUFOOT,TIUFLAG,.TIUPFHDR,TIUCONT1)
. . . S TIUDA=TIUK
. . . S TIUMISC=TIUFLAG_U_TIUPFNBR_U_TIUDA
. . . K ^TMP("TIULQ",$J)
. . . D EXTRACT^TIULQ(+TIUDA,"^TMP(""TIULQ"",$J)",.TIUERR,"","",1)
. . . I +$G(TIUERR) W !,$P(TIUERR,U,2) Q
. . . Q:'$D(^TMP("TIULQ",$J))
. . . S TIUROOT="^TMP(""TIULQ"",$J,"_TIUDA_")"
. . . D REPORT(TIUROOT,.TIUFOOT,TIUMISC,.TIUCONT) Q:'TIUCONT
. . . D IDKIDS(TIUROOT,.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT) Q:'TIUCONT
. . . I '+$G(TIUSPG) S TIUCONT1=0 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,1,$G(TIUROOT),TIUTYPE)
. Q:'TIUCONT
. I $E(IOST)="C" S TIUCONT=$$STOP^TIUPRPN2() Q:'TIUCONT
. I +$G(TIUSPG),$E(IOST)'="C" S TIUCONT1=0 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,1,$G(TIUROOT),TIUTYPE)
Q
;
REPORT(TIUROOT,TIUFOOT,TIUMISC,TIUCONT,TIUIDEND) ; Report Text
; Requires array TIUFOOT, vars TIUMISC, TIUCONT
; Requires TIUROOT =
; ^TMP("TIULQ",$J,NOTEIFN) for parent/stand-alone note, or
; ^TMP("TIULQ",$J,NOTEIFN,"ZADD",ADDMIFN) for addendum, or
; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",KIDSEQ#,IDKIDIFN) for ID kid, or
; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",KIDSEQ#,IDKIDIFN,"ZADD",KIDADDMIFN)
; for ID kid addm.
N DIW,DIWF,DIWL,DIWR,DIWT,TIUERR,TIU,TIUI,X,Z,LOC
N REFDT,TITLE,ADT,HLOC,SUBJ
N TIUDA,TIUCONT1,HASIDKID,HASIDDAD
S TIUDA=$P(TIUMISC,U,3),TIUCONT1=0
S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT),TIUTYPE) Q:'TIUCONT
S HASIDKID=$G(^TMP("TIULQ",$J,TIUDA,"ZZID",0)) ;how many ID kids
S HASIDDAD=$S(TIUROOT["ZZID":1,1:0)
I HASIDKID W "<< Interdisciplinary Note - Begin >>",!
I HASIDDAD W "<< Interdisciplinary Note - Cont. >>",!
W $S('HASIDKID&'HASIDDAD:"NOTE DATED: ",1:"ENTRY DATED: ")
S REFDT=@TIUROOT@(1301,"I")
W $$DATE^TIULS(REFDT,"MM/DD/CCYY HR:MIN")
S TITLE=@TIUROOT@(.01,"E")
W ?30,$$UP^XLFSTR(TITLE),!
S LOC=$G(@TIUROOT@(1205,"I"))
I +LOC D
. ;W $S($P(^SC(LOC,0),U,3)="W":"ADMITTED: ",1:"VISIT: ") ;IHS/ITSC/LJF 02/26/2003
. W $S($P($G(^SC(LOC,0)),U,3)="W":"ADMITTED: ",1:"VISIT: ") ;IHS/ITSC/LJF 02/26/2003 check for null clinic
. S ADT=$G(@TIUROOT@(.07,"I"))
. W $$DATE^TIULS(ADT,"MM/DD/CCYY HR:MIN")
. S HLOC=$G(@TIUROOT@(1205,"E"))
. W " ",HLOC
S SUBJ=$G(@TIUROOT@(1701,"E"))
I SUBJ]"" W !,"SUBJECT: ",^("E"),!
S TIUCONT1=1
I $D(@TIUROOT@("PROBLEM")) D Q:'TIUCONT
. S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT),TIUTYPE) Q:'TIUCONT
. W !,"ASSOCIATED PROBLEMS:"
. N TIUI S TIUI=0
. F S TIUI=$O(@TIUROOT@("PROBLEM",TIUI)) Q:'TIUI D Q:'TIUCONT
..W !,^(TIUI,0)
..S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT),TIUTYPE) Q:'TIUCONT
W !
S TIUI=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W")
F S TIUI=$O(@TIUROOT@("TEXT",TIUI)) Q:TIUI'>0 D Q:'TIUCONT ; D ^DIWW
. S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT),TIUTYPE) Q:'TIUCONT
. S X=@TIUROOT@("TEXT",TIUI,0) S:X="" X=" " D ^DIWP
D ^DIWW K ^UTILITY($J,"W")
Q:'TIUCONT
D GETSIG(TIUROOT,.TIUSIG)
S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT),TIUTYPE) Q:'TIUCONT
W !
D SIGBLK^TIUPRPN8(.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT,.TIUSIG,TIUROOT)
Q:'TIUCONT
ADDENDA ; Fall through and do Addenda of docmt TIUDA
N DIW,DIWF,DIWL,DIWR,DIWT,X,Z,TIUI,TIUADD,ADDMRDT
S TIUADD=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W")
F S TIUADD=$O(@TIUROOT@("ZADD",TIUADD)) Q:TIUADD'>0 D Q:'TIUCONT
. S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT),TIUTYPE) Q:'TIUCONT
. S ADDMRDT=@TIUROOT@("ZADD",TIUADD,1301,"I")
. W !!,$$DATE^TIULS(ADDMRDT,"MM/DD/CCYY HR:MIN"),?21,"ADDENDUM"
. W ?39,"STATUS: ",@TIUROOT@("ZADD",TIUADD,.05,"E") ;P162
. S TIUI=0
. F S TIUI=$O(@TIUROOT@("ZADD",TIUADD,"TEXT",TIUI)) Q:TIUI'>0 D Q:'TIUCONT
. . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT),TIUTYPE) Q:'TIUCONT
. . S X=@TIUROOT@("ZADD",TIUADD,"TEXT",TIUI,0) S:X="" X=" " D ^DIWP
. D ^DIWW
. Q:'TIUCONT
. N TIUADRT
. S TIUADRT=$P(TIUROOT,")")_",""ZADD"","_TIUADD_")"
. D GETSIG(TIUADRT,.TIUSIG)
. D SIGBLK^TIUPRPN8(.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT,.TIUSIG,TIUADRT)
; Need ! in front for amended notes:
I $G(TIUIDEND) W !,"<< Interdisciplinary Note - End >>",!
K ^UTILITY($J,"W")
; Write 2 linefeeds between records
W:TIUCONT !!
Q
;
IDKIDS(TIUROOT,TIUFOOT,TIUMISC,TIUCONT1,TIUCONT) ; Print ID kids
;of docmt TIUDA (each kid does its own addenda)
N TIUL,KIDDA,TIUDA,TIUSORT,TIUIDRT,TIUIDEND
S TIUDA=$P(TIUMISC,U,3),TIUIDEND=0
S TIUL=0
F S TIUL=$O(^TMP("TIULQ",$J,TIUDA,"ZZID",TIUL)) Q:'TIUL D Q:'TIUCONT
. S KIDDA=$O(^TMP("TIULQ",$J,TIUDA,"ZZID",TIUL,0))
. S TIUMISC=TIUFLAG_U_TIUPFNBR_U_KIDDA
. S TIUIDRT="^TMP(""TIULQ"",$J,"_TIUDA_",""ZZID"","_TIUL_","_KIDDA_")"
. I '$O(^TMP("TIULQ",$J,TIUDA,"ZZID",TIUL)) S TIUIDEND=1
. D REPORT(TIUIDRT,.TIUFOOT,TIUMISC,.TIUCONT,TIUIDEND)
Q
;
GETSIG(TIUROOT,TIUSIG) ; Get signature info from TIULQ global;
; Set info into TIUSIG array **100**
; Requires array name TIUROOT; passes back array TIUSIG
; TIUROOT = ^TMP("TIULQ",$J,NOTEIFN) for parent note, or
; ^TMP("TIULQ",$J,NOTEIFN,"ZADD",ADDMIFN) for addendum, or
; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",IDKIDIFN) for ID kid.
; Signature should be on bottom of form, Addenda on Subsequent pages
N TIULINE S $P(TIULINE,"-",81)=""
S TIUSIG("AUTHOR")=$G(@TIUROOT@(1202,"I"))_";"_$G(^("E"))
S TIUSIG("EXPSIGNR")=$G(@TIUROOT@(1204,"I"))_";"_$G(^("E"))
S TIUSIG("EXPCOSNR")=$G(@TIUROOT@(1208,"I"))_";"_$G(^("E"))
S TIUSIG("SIGNDATE")=$G(@TIUROOT@(1501,"I"))
S TIUSIG("SIGNEDBY")=$G(@TIUROOT@(1502,"I"))_";"_$G(^("E"))
S TIUSIG("SIGNNAME")=$G(@TIUROOT@(1503,"E"))
S TIUSIG("SIGTITL")=$G(@TIUROOT@(1504,"E"))
S TIUSIG("SIGNMODE")=$G(@TIUROOT@(1505,"I"))_";"_$G(^("E"))
S TIUSIG("COSGDATE")=$G(@TIUROOT@(1507,"I"))
S TIUSIG("COSGEDBY")=$G(@TIUROOT@(1508,"I"))_";"_$G(^("E"))
S TIUSIG("COSGNAME")=$G(@TIUROOT@(1509,"E"))
S TIUSIG("COSGTITL")=$G(@TIUROOT@(1510,"E"))
S TIUSIG("COSGMODE")=$G(@TIUROOT@(1511,"I"))_";"_$G(^("E"))
S TIUSIG("SIGCHRT")=$G(@TIUROOT@(1512,"I"))_";"_$G(^("E"))
S TIUSIG("COSCHRT")=$G(@TIUROOT@(1513,"I"))_";"_$G(^("E"))
; -- P182 Set Admin Clos Date:
;IHS/MSC/MGH added in 1013
S TIUSIG("ADMINCDT")=$G(@TIUROOT@(1606,"I"))_";"_$G(^("E"))
Q
CHECK(TIUTITLE,TEMPLATE) ;See if there is a header for this note title
N IEN,TIEN,DIV,TITLE
S TIEN=""
S DIV="" S DIV=$O(^DG(40.8,"AD",DUZ(2),DIV)) Q:DIV="" D
.S TITLE=TIUTITLE,IEN=""
.S IEN=$O(^TIU(8925.94,DIV,9999999.11,"B",TITLE,IEN)) Q:IEN="" D
..S TIEN=$P($G(^TIU(8925.94,DIV,9999999.11,IEN,0)),U,TEMPLATE)
Q TIEN
;
SETCONT(TIUFOOT,TIUMISC,TIUCONT1,TIUHEAD,TIUROOT,TIUTYPE) ;Does footer
;and returns TIUCONT
; Requires array TIUFOOT, vars TIUMISC,TIUCONT1; optional TIUHEAD
; Optional TIUROOT
;Check for special footer
N X
S FOOTER=$$CHECK(TIUTYPE,3)
I +FOOTER S X=$$FOOTER^BTIUPRT2(TIUMISC,TIUCONT1,TIUHEAD,$G(TIUROOT),FOOTER,TIUK,DFN)
E S X=$$FOOTER^TIUPRPN2(.TIUFOOT,TIUMISC,TIUCONT1,TIUHEAD,$G(TIUROOT))
Q X
BTIUPRT1 ;IHS/MSC/MGH - Print special header and foot notes;18-Mar-2015 12:30;MGH
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1008,1013**;Jun 20, 1997;Build 33
+2 ;Copy of TIUPRPN1 Print SF 509-Progress Notes ;26-Feb-2010 11:59;MGH
+3 ;IHS/ITSC/LJF 02/26/2003 added code to check for clinc not defined for visit
PRINT(TIUTYPE,TIUFLAG,TIUSPG) ; Print Document
+1 ; ^TMP("TIUPR",$J) is array of records to be printed
+2 ; TIUFLAG=1 --> Chart Copy TIUSPG=1 --> Contiguous
+3 ; TIUFLAG=0 --> Work Copy TIUSPG=0 --> Fresh Page- each note
+4 ; TIUCONT=1 --> Continue printing
+5 ; TIUCONT1=1 --> Write "Continue to next/from previous-page" msgs
+6 ; TIUPFNBR ---> Print Form # like vice 509
+7 ; TIUMISC=TIUFLAG_U_TIUPFNBR_U_TIUDA
+8 NEW TIUI,TIUJ,TIUPAGE,TIUFOOT,TIUK,TIUDA,TIUCONT,TIUPGRP,TIUTYP
+9 NEW TIUPFHDR,TIUPFNBR,TIUMISC,TIUCONT1,TIUIDONE,TMP,HEADER,FOOTER
+10 SET TIUFLAG=+$GET(TIUFLAG)
SET TIUSPG=+$GET(TIUSPG)
+11 SET TIUCONT=1
SET TIUCONT1=0
+12 SET TIUI=0
FOR
SET TIUI=$ORDER(^TMP("TIUPR",$JOB,TIUI))
IF TIUI=""
QUIT
Begin DoDot:1
+13 NEW DFN,TIU
+14 IF TIUI["$"
SET TIUPGRP=$PIECE(TIUI,"$")
SET TIUPFHDR=$PIECE($PIECE(TIUI,";"),"$",2)
+15 IF '$TEST
SET TIUPFHDR="Progress Notes"
+16 IF $GET(TIUPGRP)>2
SET TIUSPG=0
+17 SET DFN=$PIECE(TIUI,";",2)
+18 DO PATPN^TIULV(.TIUFOOT,DFN)
+19 ;IHS/MSC/MGH check for header
+20 SET HEADER=$$CHECK(TIUTYPE,2)
+21 IF +HEADER
Begin DoDot:2
+22 IF $GET(TIUSPG)
DO HEADER^BTIUPRT2(TIUFLAG,TIUCONT1,HEADER,TIUK,DFN)
End DoDot:2
+23 IF '$TEST
Begin DoDot:2
+24 IF +$GET(TIUSPG)
DO HEADER^TIUPRPN2(.TIUFOOT,TIUFLAG,.TIUPFHDR,TIUCONT1)
End DoDot:2
+25 ; Use TIUJ="" (not TIUJ=0), to print "complete" notes w/o sigdt:
+26 SET TIUJ=""
FOR
SET TIUJ=$ORDER(^TMP("TIUPR",$JOB,TIUI,TIUJ))
IF TIUJ=""
QUIT
Begin DoDot:2
+27 SET TIUK=0
FOR
SET TIUK=$ORDER(^TMP("TIUPR",$JOB,TIUI,TIUJ,TIUK))
IF 'TIUK
QUIT
Begin DoDot:3
+28 SET TIUCONT1=0
SET TIUPFNBR=^TMP("TIUPR",$JOB,TIUI,TIUJ,TIUK)
+29 ; If the document has been deleted, QUIT
+30 IF '$DATA(^TIU(8925,+TIUK,0))
SET TIUCONT=1
QUIT
+31 NEW TIUROOT
+32 SET HEADER=$$CHECK(TIUTYPE,2)
+33 IF +HEADER
Begin DoDot:4
+34 IF '+$GET(TIUSPG)
DO HEADER^BTIUPRT2(TIUFLAG,TIUCONT1,HEADER,TIUK,DFN)
End DoDot:4
+35 IF '$TEST
Begin DoDot:4
+36 IF '+$GET(TIUSPG)
DO HEADER^TIUPRPN2(.TIUFOOT,TIUFLAG,.TIUPFHDR,TIUCONT1)
End DoDot:4
+37 SET TIUDA=TIUK
+38 SET TIUMISC=TIUFLAG_U_TIUPFNBR_U_TIUDA
+39 KILL ^TMP("TIULQ",$JOB)
+40 DO EXTRACT^TIULQ(+TIUDA,"^TMP(""TIULQ"",$J)",.TIUERR,"","",1)
+41 IF +$GET(TIUERR)
WRITE !,$PIECE(TIUERR,U,2)
QUIT
+42 IF '$DATA(^TMP("TIULQ",$JOB))
QUIT
+43 SET TIUROOT="^TMP(""TIULQ"",$J,"_TIUDA_")"
+44 DO REPORT(TIUROOT,.TIUFOOT,TIUMISC,.TIUCONT)
IF 'TIUCONT
QUIT
+45 DO IDKIDS(TIUROOT,.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT)
IF 'TIUCONT
QUIT
+46 IF '+$GET(TIUSPG)
SET TIUCONT1=0
SET TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,1,$GET(TIUROOT),TIUTYPE)
End DoDot:3
IF 'TIUCONT
QUIT
End DoDot:2
IF 'TIUCONT
QUIT
+47 IF 'TIUCONT
QUIT
+48 IF $EXTRACT(IOST)="C"
SET TIUCONT=$$STOP^TIUPRPN2()
IF 'TIUCONT
QUIT
+49 IF +$GET(TIUSPG)
IF $EXTRACT(IOST)'="C"
SET TIUCONT1=0
SET TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,1,$GET(TIUROOT),TIUTYPE)
End DoDot:1
IF 'TIUCONT
QUIT
+50 QUIT
+51 ;
REPORT(TIUROOT,TIUFOOT,TIUMISC,TIUCONT,TIUIDEND) ; Report Text
+1 ; Requires array TIUFOOT, vars TIUMISC, TIUCONT
+2 ; Requires TIUROOT =
+3 ; ^TMP("TIULQ",$J,NOTEIFN) for parent/stand-alone note, or
+4 ; ^TMP("TIULQ",$J,NOTEIFN,"ZADD",ADDMIFN) for addendum, or
+5 ; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",KIDSEQ#,IDKIDIFN) for ID kid, or
+6 ; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",KIDSEQ#,IDKIDIFN,"ZADD",KIDADDMIFN)
+7 ; for ID kid addm.
+8 NEW DIW,DIWF,DIWL,DIWR,DIWT,TIUERR,TIU,TIUI,X,Z,LOC
+9 NEW REFDT,TITLE,ADT,HLOC,SUBJ
+10 NEW TIUDA,TIUCONT1,HASIDKID,HASIDDAD
+11 SET TIUDA=$PIECE(TIUMISC,U,3)
SET TIUCONT1=0
+12 SET TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$GET(TIUROOT),TIUTYPE)
IF 'TIUCONT
QUIT
+13 ;how many ID kids
SET HASIDKID=$GET(^TMP("TIULQ",$JOB,TIUDA,"ZZID",0))
+14 SET HASIDDAD=$SELECT(TIUROOT["ZZID":1,1:0)
+15 IF HASIDKID
WRITE "<< Interdisciplinary Note - Begin >>",!
+16 IF HASIDDAD
WRITE "<< Interdisciplinary Note - Cont. >>",!
+17 WRITE $SELECT('HASIDKID&'HASIDDAD:"NOTE DATED: ",1:"ENTRY DATED: ")
+18 SET REFDT=@TIUROOT@(1301,"I")
+19 WRITE $$DATE^TIULS(REFDT,"MM/DD/CCYY HR:MIN")
+20 SET TITLE=@TIUROOT@(.01,"E")
+21 WRITE ?30,$$UP^XLFSTR(TITLE),!
+22 SET LOC=$GET(@TIUROOT@(1205,"I"))
+23 IF +LOC
Begin DoDot:1
+24 ;W $S($P(^SC(LOC,0),U,3)="W":"ADMITTED: ",1:"VISIT: ") ;IHS/ITSC/LJF 02/26/2003
+25 ;IHS/ITSC/LJF 02/26/2003 check for null clinic
WRITE $SELECT($PIECE($GET(^SC(LOC,0)),U,3)="W":"ADMITTED: ",1:"VISIT: ")
+26 SET ADT=$GET(@TIUROOT@(.07,"I"))
+27 WRITE $$DATE^TIULS(ADT,"MM/DD/CCYY HR:MIN")
+28 SET HLOC=$GET(@TIUROOT@(1205,"E"))
+29 WRITE " ",HLOC
End DoDot:1
+30 SET SUBJ=$GET(@TIUROOT@(1701,"E"))
+31 IF SUBJ]""
WRITE !,"SUBJECT: ",^("E"),!
+32 SET TIUCONT1=1
+33 IF $DATA(@TIUROOT@("PROBLEM"))
Begin DoDot:1
+34 SET TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$GET(TIUROOT),TIUTYPE)
IF 'TIUCONT
QUIT
+35 WRITE !,"ASSOCIATED PROBLEMS:"
+36 NEW TIUI
SET TIUI=0
+37 FOR
SET TIUI=$ORDER(@TIUROOT@("PROBLEM",TIUI))
IF 'TIUI
QUIT
Begin DoDot:2
+38 WRITE !,^(TIUI,0)
+39 SET TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$GET(TIUROOT),TIUTYPE)
IF 'TIUCONT
QUIT
End DoDot:2
IF 'TIUCONT
QUIT
End DoDot:1
IF 'TIUCONT
QUIT
+40 WRITE !
+41 SET TIUI=0
SET DIWF="WN"
SET DIWL=1
SET DIWR=79
KILL ^UTILITY($JOB,"W")
+42 ; D ^DIWW
FOR
SET TIUI=$ORDER(@TIUROOT@("TEXT",TIUI))
IF TIUI'>0
QUIT
Begin DoDot:1
+43 SET TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$GET(TIUROOT),TIUTYPE)
IF 'TIUCONT
QUIT
+44 SET X=@TIUROOT@("TEXT",TIUI,0)
IF X=""
SET X=" "
DO ^DIWP
End DoDot:1
IF 'TIUCONT
QUIT
+45 DO ^DIWW
KILL ^UTILITY($JOB,"W")
+46 IF 'TIUCONT
QUIT
+47 DO GETSIG(TIUROOT,.TIUSIG)
+48 SET TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$GET(TIUROOT),TIUTYPE)
IF 'TIUCONT
QUIT
+49 WRITE !
+50 DO SIGBLK^TIUPRPN8(.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT,.TIUSIG,TIUROOT)
+51 IF 'TIUCONT
QUIT
ADDENDA ; Fall through and do Addenda of docmt TIUDA
+1 NEW DIW,DIWF,DIWL,DIWR,DIWT,X,Z,TIUI,TIUADD,ADDMRDT
+2 SET TIUADD=0
SET DIWF="WN"
SET DIWL=1
SET DIWR=79
KILL ^UTILITY($JOB,"W")
+3 FOR
SET TIUADD=$ORDER(@TIUROOT@("ZADD",TIUADD))
IF TIUADD'>0
QUIT
Begin DoDot:1
+4 SET TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$GET(TIUROOT),TIUTYPE)
IF 'TIUCONT
QUIT
+5 SET ADDMRDT=@TIUROOT@("ZADD",TIUADD,1301,"I")
+6 WRITE !!,$$DATE^TIULS(ADDMRDT,"MM/DD/CCYY HR:MIN"),?21,"ADDENDUM"
+7 ;P162
WRITE ?39,"STATUS: ",@TIUROOT@("ZADD",TIUADD,.05,"E")
+8 SET TIUI=0
+9 FOR
SET TIUI=$ORDER(@TIUROOT@("ZADD",TIUADD,"TEXT",TIUI))
IF TIUI'>0
QUIT
Begin DoDot:2
+10 SET TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$GET(TIUROOT),TIUTYPE)
IF 'TIUCONT
QUIT
+11 SET X=@TIUROOT@("ZADD",TIUADD,"TEXT",TIUI,0)
IF X=""
SET X=" "
DO ^DIWP
End DoDot:2
IF 'TIUCONT
QUIT
+12 DO ^DIWW
+13 IF 'TIUCONT
QUIT
+14 NEW TIUADRT
+15 SET TIUADRT=$PIECE(TIUROOT,")")_",""ZADD"","_TIUADD_")"
+16 DO GETSIG(TIUADRT,.TIUSIG)
+17 DO SIGBLK^TIUPRPN8(.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT,.TIUSIG,TIUADRT)
End DoDot:1
IF 'TIUCONT
QUIT
+18 ; Need ! in front for amended notes:
+19 IF $GET(TIUIDEND)
WRITE !,"<< Interdisciplinary Note - End >>",!
+20 KILL ^UTILITY($JOB,"W")
+21 ; Write 2 linefeeds between records
+22 IF TIUCONT
WRITE !!
+23 QUIT
+24 ;
IDKIDS(TIUROOT,TIUFOOT,TIUMISC,TIUCONT1,TIUCONT) ; Print ID kids
+1 ;of docmt TIUDA (each kid does its own addenda)
+2 NEW TIUL,KIDDA,TIUDA,TIUSORT,TIUIDRT,TIUIDEND
+3 SET TIUDA=$PIECE(TIUMISC,U,3)
SET TIUIDEND=0
+4 SET TIUL=0
+5 FOR
SET TIUL=$ORDER(^TMP("TIULQ",$JOB,TIUDA,"ZZID",TIUL))
IF 'TIUL
QUIT
Begin DoDot:1
+6 SET KIDDA=$ORDER(^TMP("TIULQ",$JOB,TIUDA,"ZZID",TIUL,0))
+7 SET TIUMISC=TIUFLAG_U_TIUPFNBR_U_KIDDA
+8 SET TIUIDRT="^TMP(""TIULQ"",$J,"_TIUDA_",""ZZID"","_TIUL_","_KIDDA_")"
+9 IF '$ORDER(^TMP("TIULQ",$JOB,TIUDA,"ZZID",TIUL))
SET TIUIDEND=1
+10 DO REPORT(TIUIDRT,.TIUFOOT,TIUMISC,.TIUCONT,TIUIDEND)
End DoDot:1
IF 'TIUCONT
QUIT
+11 QUIT
+12 ;
GETSIG(TIUROOT,TIUSIG) ; Get signature info from TIULQ global;
+1 ; Set info into TIUSIG array **100**
+2 ; Requires array name TIUROOT; passes back array TIUSIG
+3 ; TIUROOT = ^TMP("TIULQ",$J,NOTEIFN) for parent note, or
+4 ; ^TMP("TIULQ",$J,NOTEIFN,"ZADD",ADDMIFN) for addendum, or
+5 ; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",IDKIDIFN) for ID kid.
+6 ; Signature should be on bottom of form, Addenda on Subsequent pages
+7 NEW TIULINE
SET $PIECE(TIULINE,"-",81)=""
+8 SET TIUSIG("AUTHOR")=$GET(@TIUROOT@(1202,"I"))_";"_$GET(^("E"))
+9 SET TIUSIG("EXPSIGNR")=$GET(@TIUROOT@(1204,"I"))_";"_$GET(^("E"))
+10 SET TIUSIG("EXPCOSNR")=$GET(@TIUROOT@(1208,"I"))_";"_$GET(^("E"))
+11 SET TIUSIG("SIGNDATE")=$GET(@TIUROOT@(1501,"I"))
+12 SET TIUSIG("SIGNEDBY")=$GET(@TIUROOT@(1502,"I"))_";"_$GET(^("E"))
+13 SET TIUSIG("SIGNNAME")=$GET(@TIUROOT@(1503,"E"))
+14 SET TIUSIG("SIGTITL")=$GET(@TIUROOT@(1504,"E"))
+15 SET TIUSIG("SIGNMODE")=$GET(@TIUROOT@(1505,"I"))_";"_$GET(^("E"))
+16 SET TIUSIG("COSGDATE")=$GET(@TIUROOT@(1507,"I"))
+17 SET TIUSIG("COSGEDBY")=$GET(@TIUROOT@(1508,"I"))_";"_$GET(^("E"))
+18 SET TIUSIG("COSGNAME")=$GET(@TIUROOT@(1509,"E"))
+19 SET TIUSIG("COSGTITL")=$GET(@TIUROOT@(1510,"E"))
+20 SET TIUSIG("COSGMODE")=$GET(@TIUROOT@(1511,"I"))_";"_$GET(^("E"))
+21 SET TIUSIG("SIGCHRT")=$GET(@TIUROOT@(1512,"I"))_";"_$GET(^("E"))
+22 SET TIUSIG("COSCHRT")=$GET(@TIUROOT@(1513,"I"))_";"_$GET(^("E"))
+23 ; -- P182 Set Admin Clos Date:
+24 ;IHS/MSC/MGH added in 1013
+25 SET TIUSIG("ADMINCDT")=$GET(@TIUROOT@(1606,"I"))_";"_$GET(^("E"))
+26 QUIT
CHECK(TIUTITLE,TEMPLATE) ;See if there is a header for this note title
+1 NEW IEN,TIEN,DIV,TITLE
+2 SET TIEN=""
+3 SET DIV=""
SET DIV=$ORDER(^DG(40.8,"AD",DUZ(2),DIV))
IF DIV=""
QUIT
Begin DoDot:1
+4 SET TITLE=TIUTITLE
SET IEN=""
+5 SET IEN=$ORDER(^TIU(8925.94,DIV,9999999.11,"B",TITLE,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+6 SET TIEN=$PIECE($GET(^TIU(8925.94,DIV,9999999.11,IEN,0)),U,TEMPLATE)
End DoDot:2
End DoDot:1
+7 QUIT TIEN
+8 ;
SETCONT(TIUFOOT,TIUMISC,TIUCONT1,TIUHEAD,TIUROOT,TIUTYPE) ;Does footer
+1 ;and returns TIUCONT
+2 ; Requires array TIUFOOT, vars TIUMISC,TIUCONT1; optional TIUHEAD
+3 ; Optional TIUROOT
+4 ;Check for special footer
+5 NEW X
+6 SET FOOTER=$$CHECK(TIUTYPE,3)
+7 IF +FOOTER
SET X=$$FOOTER^BTIUPRT2(TIUMISC,TIUCONT1,TIUHEAD,$GET(TIUROOT),FOOTER,TIUK,DFN)
+8 IF '$TEST
SET X=$$FOOTER^TIUPRPN2(.TIUFOOT,TIUMISC,TIUCONT1,TIUHEAD,$GET(TIUROOT))
+9 QUIT X
