- 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
