- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROESPR1 9088 printed Feb 19, 2025@00:10:07 Page 2
- 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