SROESPR1 ;BIR/ADM - SURGERY E-SIG UTILITY ; [ 04/21/04 12:08 PM ]
;;3.0; Surgery ;**100,128,162**;24 Jun 93;Build 4
;
;** NOTICE: This routine is part of an implementation of a nationally
;** controlled procedure. Local modifications to this routine
;** are prohibited.
;
; Reference to EXTRACT^TIULQ supported by DBIA #2693
;
; This routine was cloned in part or in whole from TIUPRPN1.
PRINT(SRFLAG,SRSPG) ; Print Summary
; ^TMP("SRPR",$J) is array of records passed by reference
; SRFLAG=1 --> Chart Copy SRSPG=1 --> Contiguous
; SRFLAG=0 --> Work Copy SRSPG=0 --> Fresh Page- each note
N SRI,SRJ,SRPAGE,SRFOOT,SRK,SRDA,SRCONT,SRPGRP,SRTYP
N SRPFHDR,SRPFNBR,SROPAGE
S SRFLAG=+$G(SRFLAG),SRSPG=+$G(SRSPG)
S SRI=0 F S SRI=$O(^TMP("SRPR",$J,SRI)) Q:SRI="" D Q:'SRCONT
. N DFN,SR,SRERR
. I SRI["$" S SRPGRP=$P(SRI,"$"),SRPFHDR=$P($P(SRI,";"),"$",2)
. E S SRPFHDR="Surgery Reports"
. I $G(SRPGRP)'=2 S SRSPG=0
. S DFN=$P(SRI,";",2)
. D PAT^SROESPR(.SRFOOT,DFN)
. I +$G(SRSPG) D HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR)
. S SRJ=0 F S SRJ=$O(^TMP("SRPR",$J,SRI,SRJ)) Q:'SRJ D Q:'SRCONT
. . S SRK=0 F S SRK=$O(^TMP("SRPR",$J,SRI,SRJ,SRK)) Q:'SRK D Q:'+$G(SRCONT)
. . . N SRERR1,SRW K SRCONT1 S SRPFNBR=^(SRK)
. . . ; If the document has been deleted, QUIT
. . . D EXTRACT^TIULQ(SRK,"SRW",.SRERR1,".01") I $P($G(SRERR1),"^")=1 S SRCONT=1 Q
. . . I '+$G(SRSPG) D HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR)
. . . S SRDA=SRK
. . . D REPORT(SRDA) Q:'+$G(SRCONT)
. . . I '+$G(SRSPG) K SRCONT1 D SETCONT(1)
. . . I $E(IOST)="C",'$O(^TMP("SRPR",$J,SRI,SRJ,SRK)) S SRCONT=0
. Q:'SRCONT I $E(IOST)="C" S SRCONT=$$STOP^SROESPR2() Q:'SRCONT
. I +$G(SRSPG),$E(IOST)'="C" K SRCONT1 D SETCONT(1)
Q
REPORT(SRDA) ; Report Text
N DIW,DIWF,DIWL,DIWR,DIWT,SRERR,SR,SRI,SRLINE,X,Z,SRY,LOC
K ^TMP("SRLQ",$J)
S SRLINE=0
D EXTRACT^TIULQ(+SRDA,"^TMP(""SRLQ"",$J)",.SRERR,"",SRLINE,1)
I +$G(SRERR) W !,$P(SRERR,U,2) Q
Q:'$D(^TMP("SRLQ",$J))
S SRY=4,SRCONT=1
D SETCONT() Q:'SRCONT
W "NOTE DATED: "
W $$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,1301,"I"),"MM/DD/CCYY HR:MIN")
W ?30,$$UP^XLFSTR(^TMP("SRLQ",$J,SRDA,.01,"E")),!
I +$G(^TMP("SRLQ",$J,SRDA,1205,"I")) D
.S LOC=$G(^TMP("SRLQ",$J,SRDA,1205,"I")) Q:'$D(^SC(LOC,0))
.W $S($P(^SC(LOC,0),U,3)="W":"ADMITTED: ",1:"VISIT: ")
.W $$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,.07,"I"),"MM/DD/CCYY HR:MIN")
.W " ",$G(^TMP("SRLQ",$J,SRDA,1205,"E"))
I ^TMP("SRLQ",$J,SRDA,1701,"E")]"" W !,"SUBJECT: ",^("E"),!
S SRCONT1=1
I $D(^TMP("SRLQ",$J,SRDA,"PROBLEM")) D Q:'SRCONT
.D SETCONT() Q:'SRCONT
.W !,"ASSOCIATED PROBLEMS:"
.N SRI S SRI=0
.F S SRI=$O(^TMP("SRLQ",$J,SRDA,"PROBLEM",SRI)) Q:'SRI D Q:'SRCONT
..W !,^(SRI,0)
..D SETCONT() Q:'SRCONT
W !
;
S SRI=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W")
F S SRI=$O(^TMP("SRLQ",$J,SRDA,"TEXT",SRI)) Q:SRI'>0 D Q:'SRCONT ; D ^DIWW
. D SETCONT() Q:'SRCONT
. S X=^TMP("SRLQ",$J,SRDA,"TEXT",SRI,0) S:X="" X=" " D ^DIWP
D ^DIWW K ^UTILITY($J,"W")
Q:'SRCONT
RPTSIG ; Signature should be on bottom of form, Addenda on Subsequent pages
N AUTHOR,EXPSIGNR,EXPCOSNR,SIGNDATE,SIGNEDBY,SIGNNAME,SIGTITL,SIGNMODE
N COSGDATE,COSGEDBY,COSGNAME,COSGTITL,COSGMODE,SIGCHRT,COSCHRT,SRLINE
S $P(SRLINE,"-",81)=""
S AUTHOR=$G(^TMP("SRLQ",$J,SRDA,1202,"I"))_";"_$G(^("E"))
S EXPSIGNR=$G(^TMP("SRLQ",$J,SRDA,1204,"I"))_";"_$G(^("E"))
S EXPCOSNR=$G(^TMP("SRLQ",$J,SRDA,1208,"I"))_";"_$G(^("E"))
S SIGNDATE=$G(^TMP("SRLQ",$J,SRDA,1501,"I"))
S SIGNEDBY=$G(^TMP("SRLQ",$J,SRDA,1502,"I"))_";"_$G(^("E"))
S SIGNNAME=$G(^TMP("SRLQ",$J,SRDA,1503,"E"))
S SIGTITL=$G(^TMP("SRLQ",$J,SRDA,1504,"E"))
S SIGNMODE=$G(^TMP("SRLQ",$J,SRDA,1505,"I"))_";"_$G(^("E"))
S COSGDATE=$G(^TMP("SRLQ",$J,SRDA,1507,"I"))
S COSGEDBY=$G(^TMP("SRLQ",$J,SRDA,1508,"I"))_";"_$G(^("E"))
S COSGNAME=$G(^TMP("SRLQ",$J,SRDA,1509,"E"))
S COSGTITL=$G(^TMP("SRLQ",$J,SRDA,1510,"E"))
S COSGMODE=$G(^TMP("SRLQ",$J,SRDA,1511,"I"))_";"_$G(^("E"))
S SIGCHRT=$G(^TMP("SRLQ",$J,SRDA,1512,"I"))_";"_$G(^("E"))
S COSCHRT=$G(^TMP("SRLQ",$J,SRDA,1513,"I"))_";"_$G(^("E"))
D SETCONT() Q:'SRCONT W !
D SIGBLK Q:'SRCONT
ADDENDA ; Surgery Reports Addenda
N DIW,DIWF,DIWL,DIWR,DIWT,X,Z,SRI,SRADD
S SRADD=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W")
F S SRADD=$O(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD)) Q:SRADD'>0 D Q:'SRCONT
. S SRY=4 D SETCONT() Q:'SRCONT
. W !!,$$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1301,"I"),"MM/DD/CCYY HR:MIN"),?21,"ADDENDUM"
. W ?41,"STATUS: ",^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,.05,"E")
. S SRI=0
. F S SRI=$O(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,"TEXT",SRI)) Q:SRI'>0 D Q:'SRCONT
. . D SETCONT() Q:'SRCONT
. . S X=^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,"TEXT",SRI,0) S:X="" X=" " D ^DIWP
. D ^DIWW
. D:SRCONT ADDENSIG
K ^UTILITY($J,"W")
; Write 2 linefeeds between records
Q:'SRCONT W !!
Q
ADDENSIG ;
N AUTHOR,EXPSIGNR,ATTNDING,SIGNDATE,SIGNEDBY,SIGNNAME,SIGNMODE
N COSGDATE,COSGEDBY,COSGNAME,COSGMODE,SRLINE S $P(SRLINE,"-",80)=""
S AUTHOR=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1202,"I"))_";"_$G(^("E"))
S EXPSIGNR=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1204,"I"))_";"_$G(^("E"))
S ATTNDING=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1209,"I"))_";"_$G(^("E"))
S SIGNDATE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1501,"I"))
S SIGNEDBY=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1502,"I"))_";"_$G(^("E"))
S SIGNNAME=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1503,"E"))
S SIGTITL=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1504,"E"))
S SIGNMODE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1505,"I"))_";"_$G(^("E"))
S COSGDATE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1507,"I"))
S COSGEDBY=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1508,"I"))_";"_$G(^("E"))
S COSGNAME=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1509,"E"))
S COSGTITL=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1510,"E"))
S COSGMODE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1511,"I"))_";"_$G(^("E"))
S SRY=11
SIGBLK N SRGROOT S SRGROOT=$NA(^TMP("SRLQ",$J,SRDA))
I '+SIGNDATE D D SETCONT() Q:'SRCONT
.I $$STATUS^SROESUTL(SRDA)'=7 W !,"**DRAFT COPY - DRAFT COPY -- ABOVE NOTE IS UNSIGNED-- DRAFT COPY - DRAFT COPY**"
I SIGNEDBY]"",(+SIGNEDBY'=+AUTHOR) D
. W ?21,"Author: ",$P(AUTHOR,";",2),!
I +SIGNDATE D SETCONT() Q:'SRCONT D
. W ?18,"Signed by:",$S($P(SIGNMODE,";")="C":" /s/ ",1:" /es/ "),?34,$S(SIGNNAME]"":SIGNNAME,1:$P(SIGNEDBY,";",2))
. W !?34,SIGTITL
. I $L(SIGTITL)>30 W !?34
. E W " "
. W $$DATE^SROESPR(+SIGNDATE,"MM/DD/CCYY HR:MIN")
. I '+$G(SRFLAG)!($E(IOST)="C") D
. . I $P($$BEEP^SROESPR(+SIGNEDBY),U) W !?34,"Analog Pager: ",$P($$BEEP^SROESPR(+SIGNEDBY),U)
. . I $P($$BEEP^SROESPR(+SIGNEDBY),U,2) W !?34,"Digital Pager: ",$P($$BEEP^SROESPR(+SIGNEDBY),U,2)
I $G(^TMP("SRLQ",$J,SRDA,.05,"E"))="UNCOSIGNED" D
. W !?34,"**REQUIRES COSIGNATURE**",!
I +SIGCHRT,$P(SIGNMODE,";")="C" D SETCONT() Q:'SRCONT D
. W !?2,"Marked signed on chart by:",?34,$P(SIGCHRT,";",2)
I +$G(SRADD) S SRGROOT=$NA(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD))
I +$D(@SRGROOT@("EXTRASGNR")) D
. N SRI S SRI=0
. D SETCONT() Q:'SRCONT W !?4,"Receipt Acknowledged By:"
. F S SRI=$O(@SRGROOT@("EXTRASGNR",SRI)) Q:'SRI D
. . I +$G(@SRGROOT@("EXTRASGNR",SRI,"DATE"))'>0 Q
. . I SRI>1 D SETCONT() Q:'SRCONT W !
. . W ?29,"/es/ ",$G(@SRGROOT@("EXTRASGNR",SRI,"NAME"))
. . W !?34,$G(@SRGROOT@("EXTRASGNR",SRI,"TITLE"))
. . I $L($G(@SRGROOT@("EXTRASGNR",SRI,"TITLE")))>30 W !?34
. . E W " "
. . W $$DATE^SROESPR($G(@SRGROOT@("EXTRASGNR",SRI,"DATE")),"MM/DD/CCYY HR:MIN")
. . I '+$G(SRFLAG)!($E(IOST)="C") D
. . . N BEEP
. . . S BEEP=$$BEEP^SROESPR(+$G(@SRGROOT@("EXTRASGNR",SRI,"EXTRA")))
. . . I +BEEP W !?34,"Analog Pager: ",$P(BEEP,U)
. . . I +$P(BEEP,U,2) W !?34,"Digital Pager: ",$P(BEEP,U,2)
. K @SRGROOT@("EXTRASGNR")
I +COSGDATE,(+COSGEDBY'=+SIGNEDBY) D SETCONT() Q:'SRCONT D
. W !?16,"Cosigned by:",$S($P(COSGMODE,";")="C":" /s/ ",1:" /es/ "),?34,$S(COSGNAME]"":COSGNAME,1:$P(COSGEDBY,";",2))
. W !?34,COSGTITL," "
. W $$DATE^SROESPR(+COSGDATE,"MM/DD/CCYY HR:MIN")
. I '+$G(SRFLAG)!($E(IOST)="C") D
. . I $P($$BEEP^SROESPR(+COSGEDBY),U) W !?34,"Analog Pager: ",$P($$BEEP^SROESPR(+COSGEDBY),U)
. . I $P($$BEEP^SROESPR(+COSGEDBY),U,2) W !?34,"Digital Pager:",$P($$BEEP^SROESPR(+COSGEDBY),U,2)
I +COSCHRT,$P(COSGMODE,";")="C" D SETCONT() Q:'SRCONT D
. W !,"Marked cosigned on chart by:",?34,$P(COSCHRT,";",2)
W !
K SRCONT1
AMEND ; signature blocks of amender
S SRY=4 D SETCONT() Q:'SRCONT
I +$G(@SRGROOT@(1601,"I")) D
. W !!?12,"Amendment Filed:",?34,$$DATE^SROESPR(@SRGROOT@(1601,"I"),"MM/DD/CCYY HR:MIN")
. I $G(@SRGROOT@(1603,"E"))']"" D
. . W !!?29 F SRI=1:1:40 W "_"
. . W !?29,$$SIGNAME^SROESPR(@SRGROOT@(1602,"I"))
. . W !?29,$$SIGTITL^SROESPR(@SRGROOT@(1602,"I"))
. I $G(@SRGROOT@(1604,"E"))]"" D
. . W !?29,"/es/",?34,@SRGROOT@(1604,"E")
. . W !?34,@SRGROOT@(1605,"E")
Q
SETCONT(SRHEAD) ;Does footer and sets SRCONT
S SRCONT=$$FOOTER^SROESPR2(.SRFOOT,SRFLAG,SRPFNBR,$G(SRHEAD),$G(SRCONT1),SRDA)
Q
SROESPR1 ;BIR/ADM - SURGERY E-SIG UTILITY ; [ 04/21/04 12:08 PM ]
+1 ;;3.0; Surgery ;**100,128,162**;24 Jun 93;Build 4
+2 ;
+3 ;** NOTICE: This routine is part of an implementation of a nationally
+4 ;** controlled procedure. Local modifications to this routine
+5 ;** are prohibited.
+6 ;
+7 ; Reference to EXTRACT^TIULQ supported by DBIA #2693
+8 ;
+9 ; This routine was cloned in part or in whole from TIUPRPN1.
PRINT(SRFLAG,SRSPG) ; Print Summary
+1 ; ^TMP("SRPR",$J) is array of records passed by reference
+2 ; SRFLAG=1 --> Chart Copy SRSPG=1 --> Contiguous
+3 ; SRFLAG=0 --> Work Copy SRSPG=0 --> Fresh Page- each note
+4 NEW SRI,SRJ,SRPAGE,SRFOOT,SRK,SRDA,SRCONT,SRPGRP,SRTYP
+5 NEW SRPFHDR,SRPFNBR,SROPAGE
+6 SET SRFLAG=+$GET(SRFLAG)
SET SRSPG=+$GET(SRSPG)
+7 SET SRI=0
FOR
SET SRI=$ORDER(^TMP("SRPR",$JOB,SRI))
IF SRI=""
QUIT
Begin DoDot:1
+8 NEW DFN,SR,SRERR
+9 IF SRI["$"
SET SRPGRP=$PIECE(SRI,"$")
SET SRPFHDR=$PIECE($PIECE(SRI,";"),"$",2)
+10 IF '$TEST
SET SRPFHDR="Surgery Reports"
+11 IF $GET(SRPGRP)'=2
SET SRSPG=0
+12 SET DFN=$PIECE(SRI,";",2)
+13 DO PAT^SROESPR(.SRFOOT,DFN)
+14 IF +$GET(SRSPG)
DO HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR)
+15 SET SRJ=0
FOR
SET SRJ=$ORDER(^TMP("SRPR",$JOB,SRI,SRJ))
IF 'SRJ
QUIT
Begin DoDot:2
+16 SET SRK=0
FOR
SET SRK=$ORDER(^TMP("SRPR",$JOB,SRI,SRJ,SRK))
IF 'SRK
QUIT
Begin DoDot:3
+17 NEW SRERR1,SRW
KILL SRCONT1
SET SRPFNBR=^(SRK)
+18 ; If the document has been deleted, QUIT
+19 DO EXTRACT^TIULQ(SRK,"SRW",.SRERR1,".01")
IF $PIECE($GET(SRERR1),"^")=1
SET SRCONT=1
QUIT
+20 IF '+$GET(SRSPG)
DO HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR)
+21 SET SRDA=SRK
+22 DO REPORT(SRDA)
IF '+$GET(SRCONT)
QUIT
+23 IF '+$GET(SRSPG)
KILL SRCONT1
DO SETCONT(1)
+24 IF $EXTRACT(IOST)="C"
IF '$ORDER(^TMP("SRPR",$JOB,SRI,SRJ,SRK))
SET SRCONT=0
End DoDot:3
IF '+$GET(SRCONT)
QUIT
End DoDot:2
IF 'SRCONT
QUIT
+25 IF 'SRCONT
QUIT
IF $EXTRACT(IOST)="C"
SET SRCONT=$$STOP^SROESPR2()
IF 'SRCONT
QUIT
+26 IF +$GET(SRSPG)
IF $EXTRACT(IOST)'="C"
KILL SRCONT1
DO SETCONT(1)
End DoDot:1
IF 'SRCONT
QUIT
+27 QUIT
REPORT(SRDA) ; Report Text
+1 NEW DIW,DIWF,DIWL,DIWR,DIWT,SRERR,SR,SRI,SRLINE,X,Z,SRY,LOC
+2 KILL ^TMP("SRLQ",$JOB)
+3 SET SRLINE=0
+4 DO EXTRACT^TIULQ(+SRDA,"^TMP(""SRLQ"",$J)",.SRERR,"",SRLINE,1)
+5 IF +$GET(SRERR)
WRITE !,$PIECE(SRERR,U,2)
QUIT
+6 IF '$DATA(^TMP("SRLQ",$JOB))
QUIT
+7 SET SRY=4
SET SRCONT=1
+8 DO SETCONT()
IF 'SRCONT
QUIT
+9 WRITE "NOTE DATED: "
+10 WRITE $$DATE^SROESPR(^TMP("SRLQ",$JOB,SRDA,1301,"I"),"MM/DD/CCYY HR:MIN")
+11 WRITE ?30,$$UP^XLFSTR(^TMP("SRLQ",$JOB,SRDA,.01,"E")),!
+12 IF +$GET(^TMP("SRLQ",$JOB,SRDA,1205,"I"))
Begin DoDot:1
+13 SET LOC=$GET(^TMP("SRLQ",$JOB,SRDA,1205,"I"))
IF '$DATA(^SC(LOC,0))
QUIT
+14 WRITE $SELECT($PIECE(^SC(LOC,0),U,3)="W":"ADMITTED: ",1:"VISIT: ")
+15 WRITE $$DATE^SROESPR(^TMP("SRLQ",$JOB,SRDA,.07,"I"),"MM/DD/CCYY HR:MIN")
+16 WRITE " ",$GET(^TMP("SRLQ",$JOB,SRDA,1205,"E"))
End DoDot:1
+17 IF ^TMP("SRLQ",$JOB,SRDA,1701,"E")]""
WRITE !,"SUBJECT: ",^("E"),!
+18 SET SRCONT1=1
+19 IF $DATA(^TMP("SRLQ",$JOB,SRDA,"PROBLEM"))
Begin DoDot:1
+20 DO SETCONT()
IF 'SRCONT
QUIT
+21 WRITE !,"ASSOCIATED PROBLEMS:"
+22 NEW SRI
SET SRI=0
+23 FOR
SET SRI=$ORDER(^TMP("SRLQ",$JOB,SRDA,"PROBLEM",SRI))
IF 'SRI
QUIT
Begin DoDot:2
+24 WRITE !,^(SRI,0)
+25 DO SETCONT()
IF 'SRCONT
QUIT
End DoDot:2
IF 'SRCONT
QUIT
End DoDot:1
IF 'SRCONT
QUIT
+26 WRITE !
+27 ;
+28 SET SRI=0
SET DIWF="WN"
SET DIWL=1
SET DIWR=79
KILL ^UTILITY($JOB,"W")
+29 ; D ^DIWW
FOR
SET SRI=$ORDER(^TMP("SRLQ",$JOB,SRDA,"TEXT",SRI))
IF SRI'>0
QUIT
Begin DoDot:1
+30 DO SETCONT()
IF 'SRCONT
QUIT
+31 SET X=^TMP("SRLQ",$JOB,SRDA,"TEXT",SRI,0)
IF X=""
SET X=" "
DO ^DIWP
End DoDot:1
IF 'SRCONT
QUIT
+32 DO ^DIWW
KILL ^UTILITY($JOB,"W")
+33 IF 'SRCONT
QUIT
RPTSIG ; Signature should be on bottom of form, Addenda on Subsequent pages
+1 NEW AUTHOR,EXPSIGNR,EXPCOSNR,SIGNDATE,SIGNEDBY,SIGNNAME,SIGTITL,SIGNMODE
+2 NEW COSGDATE,COSGEDBY,COSGNAME,COSGTITL,COSGMODE,SIGCHRT,COSCHRT,SRLINE
+3 SET $PIECE(SRLINE,"-",81)=""
+4 SET AUTHOR=$GET(^TMP("SRLQ",$JOB,SRDA,1202,"I"))_";"_$GET(^("E"))
+5 SET EXPSIGNR=$GET(^TMP("SRLQ",$JOB,SRDA,1204,"I"))_";"_$GET(^("E"))
+6 SET EXPCOSNR=$GET(^TMP("SRLQ",$JOB,SRDA,1208,"I"))_";"_$GET(^("E"))
+7 SET SIGNDATE=$GET(^TMP("SRLQ",$JOB,SRDA,1501,"I"))
+8 SET SIGNEDBY=$GET(^TMP("SRLQ",$JOB,SRDA,1502,"I"))_";"_$GET(^("E"))
+9 SET SIGNNAME=$GET(^TMP("SRLQ",$JOB,SRDA,1503,"E"))
+10 SET SIGTITL=$GET(^TMP("SRLQ",$JOB,SRDA,1504,"E"))
+11 SET SIGNMODE=$GET(^TMP("SRLQ",$JOB,SRDA,1505,"I"))_";"_$GET(^("E"))
+12 SET COSGDATE=$GET(^TMP("SRLQ",$JOB,SRDA,1507,"I"))
+13 SET COSGEDBY=$GET(^TMP("SRLQ",$JOB,SRDA,1508,"I"))_";"_$GET(^("E"))
+14 SET COSGNAME=$GET(^TMP("SRLQ",$JOB,SRDA,1509,"E"))
+15 SET COSGTITL=$GET(^TMP("SRLQ",$JOB,SRDA,1510,"E"))
+16 SET COSGMODE=$GET(^TMP("SRLQ",$JOB,SRDA,1511,"I"))_";"_$GET(^("E"))
+17 SET SIGCHRT=$GET(^TMP("SRLQ",$JOB,SRDA,1512,"I"))_";"_$GET(^("E"))
+18 SET COSCHRT=$GET(^TMP("SRLQ",$JOB,SRDA,1513,"I"))_";"_$GET(^("E"))
+19 DO SETCONT()
IF 'SRCONT
QUIT
WRITE !
+20 DO SIGBLK
IF 'SRCONT
QUIT
ADDENDA ; Surgery Reports Addenda
+1 NEW DIW,DIWF,DIWL,DIWR,DIWT,X,Z,SRI,SRADD
+2 SET SRADD=0
SET DIWF="WN"
SET DIWL=1
SET DIWR=79
KILL ^UTILITY($JOB,"W")
+3 FOR
SET SRADD=$ORDER(^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD))
IF SRADD'>0
QUIT
Begin DoDot:1
+4 SET SRY=4
DO SETCONT()
IF 'SRCONT
QUIT
+5 WRITE !!,$$DATE^SROESPR(^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD,1301,"I"),"MM/DD/CCYY HR:MIN"),?21,"ADDENDUM"
+6 WRITE ?41,"STATUS: ",^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD,.05,"E")
+7 SET SRI=0
+8 FOR
SET SRI=$ORDER(^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD,"TEXT",SRI))
IF SRI'>0
QUIT
Begin DoDot:2
+9 DO SETCONT()
IF 'SRCONT
QUIT
+10 SET X=^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD,"TEXT",SRI,0)
IF X=""
SET X=" "
DO ^DIWP
End DoDot:2
IF 'SRCONT
QUIT
+11 DO ^DIWW
+12 IF SRCONT
DO ADDENSIG
End DoDot:1
IF 'SRCONT
QUIT
+13 KILL ^UTILITY($JOB,"W")
+14 ; Write 2 linefeeds between records
+15 IF 'SRCONT
QUIT
WRITE !!
+16 QUIT
ADDENSIG ;
+1 NEW AUTHOR,EXPSIGNR,ATTNDING,SIGNDATE,SIGNEDBY,SIGNNAME,SIGNMODE
+2 NEW COSGDATE,COSGEDBY,COSGNAME,COSGMODE,SRLINE
SET $PIECE(SRLINE,"-",80)=""
+3 SET AUTHOR=$GET(^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD,1202,"I"))_";"_$GET(^("E"))
+4 SET EXPSIGNR=$GET(^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD,1204,"I"))_";"_$GET(^("E"))
+5 SET ATTNDING=$GET(^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD,1209,"I"))_";"_$GET(^("E"))
+6 SET SIGNDATE=$GET(^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD,1501,"I"))
+7 SET SIGNEDBY=$GET(^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD,1502,"I"))_";"_$GET(^("E"))
+8 SET SIGNNAME=$GET(^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD,1503,"E"))
+9 SET SIGTITL=$GET(^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD,1504,"E"))
+10 SET SIGNMODE=$GET(^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD,1505,"I"))_";"_$GET(^("E"))
+11 SET COSGDATE=$GET(^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD,1507,"I"))
+12 SET COSGEDBY=$GET(^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD,1508,"I"))_";"_$GET(^("E"))
+13 SET COSGNAME=$GET(^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD,1509,"E"))
+14 SET COSGTITL=$GET(^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD,1510,"E"))
+15 SET COSGMODE=$GET(^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD,1511,"I"))_";"_$GET(^("E"))
+16 SET SRY=11
SIGBLK NEW SRGROOT
SET SRGROOT=$NAME(^TMP("SRLQ",$JOB,SRDA))
+1 IF '+SIGNDATE
Begin DoDot:1
+2 IF $$STATUS^SROESUTL(SRDA)'=7
WRITE !,"**DRAFT COPY - DRAFT COPY -- ABOVE NOTE IS UNSIGNED-- DRAFT COPY - DRAFT COPY**"
End DoDot:1
DO SETCONT()
IF 'SRCONT
QUIT
+3 IF SIGNEDBY]""
IF (+SIGNEDBY'=+AUTHOR)
Begin DoDot:1
+4 WRITE ?21,"Author: ",$PIECE(AUTHOR,";",2),!
End DoDot:1
+5 IF +SIGNDATE
DO SETCONT()
IF 'SRCONT
QUIT
Begin DoDot:1
+6 WRITE ?18,"Signed by:",$SELECT($PIECE(SIGNMODE,";")="C":" /s/ ",1:" /es/ "),?34,$SELECT(SIGNNAME]"":SIGNNAME,1:$PIECE(SIGNEDBY,";",2))
+7 WRITE !?34,SIGTITL
+8 IF $LENGTH(SIGTITL)>30
WRITE !?34
+9 IF '$TEST
WRITE " "
+10 WRITE $$DATE^SROESPR(+SIGNDATE,"MM/DD/CCYY HR:MIN")
+11 IF '+$GET(SRFLAG)!($EXTRACT(IOST)="C")
Begin DoDot:2
+12 IF $PIECE($$BEEP^SROESPR(+SIGNEDBY),U)
WRITE !?34,"Analog Pager: ",$PIECE($$BEEP^SROESPR(+SIGNEDBY),U)
+13 IF $PIECE($$BEEP^SROESPR(+SIGNEDBY),U,2)
WRITE !?34,"Digital Pager: ",$PIECE($$BEEP^SROESPR(+SIGNEDBY),U,2)
End DoDot:2
End DoDot:1
+14 IF $GET(^TMP("SRLQ",$JOB,SRDA,.05,"E"))="UNCOSIGNED"
Begin DoDot:1
+15 WRITE !?34,"**REQUIRES COSIGNATURE**",!
End DoDot:1
+16 IF +SIGCHRT
IF $PIECE(SIGNMODE,";")="C"
DO SETCONT()
IF 'SRCONT
QUIT
Begin DoDot:1
+17 WRITE !?2,"Marked signed on chart by:",?34,$PIECE(SIGCHRT,";",2)
End DoDot:1
+18 IF +$GET(SRADD)
SET SRGROOT=$NAME(^TMP("SRLQ",$JOB,SRDA,"ZADD",SRADD))
+19 IF +$DATA(@SRGROOT@("EXTRASGNR"))
Begin DoDot:1
+20 NEW SRI
SET SRI=0
+21 DO SETCONT()
IF 'SRCONT
QUIT
WRITE !?4,"Receipt Acknowledged By:"
+22 FOR
SET SRI=$ORDER(@SRGROOT@("EXTRASGNR",SRI))
IF 'SRI
QUIT
Begin DoDot:2
+23 IF +$GET(@SRGROOT@("EXTRASGNR",SRI,"DATE"))'>0
QUIT
+24 IF SRI>1
DO SETCONT()
IF 'SRCONT
QUIT
WRITE !
+25 WRITE ?29,"/es/ ",$GET(@SRGROOT@("EXTRASGNR",SRI,"NAME"))
+26 WRITE !?34,$GET(@SRGROOT@("EXTRASGNR",SRI,"TITLE"))
+27 IF $LENGTH($GET(@SRGROOT@("EXTRASGNR",SRI,"TITLE")))>30
WRITE !?34
+28 IF '$TEST
WRITE " "
+29 WRITE $$DATE^SROESPR($GET(@SRGROOT@("EXTRASGNR",SRI,"DATE")),"MM/DD/CCYY HR:MIN")
+30 IF '+$GET(SRFLAG)!($EXTRACT(IOST)="C")
Begin DoDot:3
+31 NEW BEEP
+32 SET BEEP=$$BEEP^SROESPR(+$GET(@SRGROOT@("EXTRASGNR",SRI,"EXTRA")))
+33 IF +BEEP
WRITE !?34,"Analog Pager: ",$PIECE(BEEP,U)
+34 IF +$PIECE(BEEP,U,2)
WRITE !?34,"Digital Pager: ",$PIECE(BEEP,U,2)
End DoDot:3
End DoDot:2
+35 KILL @SRGROOT@("EXTRASGNR")
End DoDot:1
+36 IF +COSGDATE
IF (+COSGEDBY'=+SIGNEDBY)
DO SETCONT()
IF 'SRCONT
QUIT
Begin DoDot:1
+37 WRITE !?16,"Cosigned by:",$SELECT($PIECE(COSGMODE,";")="C":" /s/ ",1:" /es/ "),?34,$SELECT(COSGNAME]"":COSGNAME,1:$PIECE(COSGEDBY,";",2))
+38 WRITE !?34,COSGTITL," "
+39 WRITE $$DATE^SROESPR(+COSGDATE,"MM/DD/CCYY HR:MIN")
+40 IF '+$GET(SRFLAG)!($EXTRACT(IOST)="C")
Begin DoDot:2
+41 IF $PIECE($$BEEP^SROESPR(+COSGEDBY),U)
WRITE !?34,"Analog Pager: ",$PIECE($$BEEP^SROESPR(+COSGEDBY),U)
+42 IF $PIECE($$BEEP^SROESPR(+COSGEDBY),U,2)
WRITE !?34,"Digital Pager:",$PIECE($$BEEP^SROESPR(+COSGEDBY),U,2)
End DoDot:2
End DoDot:1
+43 IF +COSCHRT
IF $PIECE(COSGMODE,";")="C"
DO SETCONT()
IF 'SRCONT
QUIT
Begin DoDot:1
+44 WRITE !,"Marked cosigned on chart by:",?34,$PIECE(COSCHRT,";",2)
End DoDot:1
+45 WRITE !
+46 KILL SRCONT1
AMEND ; signature blocks of amender
+1 SET SRY=4
DO SETCONT()
IF 'SRCONT
QUIT
+2 IF +$GET(@SRGROOT@(1601,"I"))
Begin DoDot:1
+3 WRITE !!?12,"Amendment Filed:",?34,$$DATE^SROESPR(@SRGROOT@(1601,"I"),"MM/DD/CCYY HR:MIN")
+4 IF $GET(@SRGROOT@(1603,"E"))']""
Begin DoDot:2
+5 WRITE !!?29
FOR SRI=1:1:40
WRITE "_"
+6 WRITE !?29,$$SIGNAME^SROESPR(@SRGROOT@(1602,"I"))
+7 WRITE !?29,$$SIGTITL^SROESPR(@SRGROOT@(1602,"I"))
End DoDot:2
+8 IF $GET(@SRGROOT@(1604,"E"))]""
Begin DoDot:2
+9 WRITE !?29,"/es/",?34,@SRGROOT@(1604,"E")
+10 WRITE !?34,@SRGROOT@(1605,"E")
End DoDot:2
End DoDot:1
+11 QUIT
SETCONT(SRHEAD) ;Does footer and sets SRCONT
+1 SET SRCONT=$$FOOTER^SROESPR2(.SRFOOT,SRFLAG,SRPFNBR,$GET(SRHEAD),$GET(SRCONT1),SRDA)
+2 QUIT
