Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SROESPR1

SROESPR1.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;** NOTICE: This routine is part of an implementation of a nationally
  1. ;** controlled procedure. Local modifications to this routine
  1. ;** are prohibited.
  1. ;
  1. ; Reference to EXTRACT^TIULQ supported by DBIA #2693
  1. ;
  1. ; This routine was cloned in part or in whole from TIUPRPN1.
  1. PRINT(SRFLAG,SRSPG) ; Print Summary
  1. ; ^TMP("SRPR",$J) is array of records passed by reference
  1. ; SRFLAG=1 --> Chart Copy SRSPG=1 --> Contiguous
  1. ; SRFLAG=0 --> Work Copy SRSPG=0 --> Fresh Page- each note
  1. N SRI,SRJ,SRPAGE,SRFOOT,SRK,SRDA,SRCONT,SRPGRP,SRTYP
  1. N SRPFHDR,SRPFNBR,SROPAGE
  1. S SRFLAG=+$G(SRFLAG),SRSPG=+$G(SRSPG)
  1. S SRI=0 F S SRI=$O(^TMP("SRPR",$J,SRI)) Q:SRI="" D Q:'SRCONT
  1. . N DFN,SR,SRERR
  1. . I SRI["$" S SRPGRP=$P(SRI,"$"),SRPFHDR=$P($P(SRI,";"),"$",2)
  1. . E S SRPFHDR="Surgery Reports"
  1. . I $G(SRPGRP)'=2 S SRSPG=0
  1. . S DFN=$P(SRI,";",2)
  1. . D PAT^SROESPR(.SRFOOT,DFN)
  1. . I +$G(SRSPG) D HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR)
  1. . S SRJ=0 F S SRJ=$O(^TMP("SRPR",$J,SRI,SRJ)) Q:'SRJ D Q:'SRCONT
  1. . . S SRK=0 F S SRK=$O(^TMP("SRPR",$J,SRI,SRJ,SRK)) Q:'SRK D Q:'+$G(SRCONT)
  1. . . . N SRERR1,SRW K SRCONT1 S SRPFNBR=^(SRK)
  1. . . . ; If the document has been deleted, QUIT
  1. . . . D EXTRACT^TIULQ(SRK,"SRW",.SRERR1,".01") I $P($G(SRERR1),"^")=1 S SRCONT=1 Q
  1. . . . I '+$G(SRSPG) D HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR)
  1. . . . S SRDA=SRK
  1. . . . D REPORT(SRDA) Q:'+$G(SRCONT)
  1. . . . I '+$G(SRSPG) K SRCONT1 D SETCONT(1)
  1. . . . I $E(IOST)="C",'$O(^TMP("SRPR",$J,SRI,SRJ,SRK)) S SRCONT=0
  1. . Q:'SRCONT I $E(IOST)="C" S SRCONT=$$STOP^SROESPR2() Q:'SRCONT
  1. . I +$G(SRSPG),$E(IOST)'="C" K SRCONT1 D SETCONT(1)
  1. Q
  1. REPORT(SRDA) ; Report Text
  1. N DIW,DIWF,DIWL,DIWR,DIWT,SRERR,SR,SRI,SRLINE,X,Z,SRY,LOC
  1. K ^TMP("SRLQ",$J)
  1. S SRLINE=0
  1. D EXTRACT^TIULQ(+SRDA,"^TMP(""SRLQ"",$J)",.SRERR,"",SRLINE,1)
  1. I +$G(SRERR) W !,$P(SRERR,U,2) Q
  1. Q:'$D(^TMP("SRLQ",$J))
  1. S SRY=4,SRCONT=1
  1. D SETCONT() Q:'SRCONT
  1. W "NOTE DATED: "
  1. W $$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,1301,"I"),"MM/DD/CCYY HR:MIN")
  1. W ?30,$$UP^XLFSTR(^TMP("SRLQ",$J,SRDA,.01,"E")),!
  1. I +$G(^TMP("SRLQ",$J,SRDA,1205,"I")) D
  1. .S LOC=$G(^TMP("SRLQ",$J,SRDA,1205,"I")) Q:'$D(^SC(LOC,0))
  1. .W $S($P(^SC(LOC,0),U,3)="W":"ADMITTED: ",1:"VISIT: ")
  1. .W $$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,.07,"I"),"MM/DD/CCYY HR:MIN")
  1. .W " ",$G(^TMP("SRLQ",$J,SRDA,1205,"E"))
  1. I ^TMP("SRLQ",$J,SRDA,1701,"E")]"" W !,"SUBJECT: ",^("E"),!
  1. S SRCONT1=1
  1. I $D(^TMP("SRLQ",$J,SRDA,"PROBLEM")) D Q:'SRCONT
  1. .D SETCONT() Q:'SRCONT
  1. .W !,"ASSOCIATED PROBLEMS:"
  1. .N SRI S SRI=0
  1. .F S SRI=$O(^TMP("SRLQ",$J,SRDA,"PROBLEM",SRI)) Q:'SRI D Q:'SRCONT
  1. ..W !,^(SRI,0)
  1. ..D SETCONT() Q:'SRCONT
  1. W !
  1. ;
  1. S SRI=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W")
  1. F S SRI=$O(^TMP("SRLQ",$J,SRDA,"TEXT",SRI)) Q:SRI'>0 D Q:'SRCONT ; D ^DIWW
  1. . D SETCONT() Q:'SRCONT
  1. . S X=^TMP("SRLQ",$J,SRDA,"TEXT",SRI,0) S:X="" X=" " D ^DIWP
  1. D ^DIWW K ^UTILITY($J,"W")
  1. Q:'SRCONT
  1. RPTSIG ; Signature should be on bottom of form, Addenda on Subsequent pages
  1. N AUTHOR,EXPSIGNR,EXPCOSNR,SIGNDATE,SIGNEDBY,SIGNNAME,SIGTITL,SIGNMODE
  1. N COSGDATE,COSGEDBY,COSGNAME,COSGTITL,COSGMODE,SIGCHRT,COSCHRT,SRLINE
  1. S $P(SRLINE,"-",81)=""
  1. S AUTHOR=$G(^TMP("SRLQ",$J,SRDA,1202,"I"))_";"_$G(^("E"))
  1. S EXPSIGNR=$G(^TMP("SRLQ",$J,SRDA,1204,"I"))_";"_$G(^("E"))
  1. S EXPCOSNR=$G(^TMP("SRLQ",$J,SRDA,1208,"I"))_";"_$G(^("E"))
  1. S SIGNDATE=$G(^TMP("SRLQ",$J,SRDA,1501,"I"))
  1. S SIGNEDBY=$G(^TMP("SRLQ",$J,SRDA,1502,"I"))_";"_$G(^("E"))
  1. S SIGNNAME=$G(^TMP("SRLQ",$J,SRDA,1503,"E"))
  1. S SIGTITL=$G(^TMP("SRLQ",$J,SRDA,1504,"E"))
  1. S SIGNMODE=$G(^TMP("SRLQ",$J,SRDA,1505,"I"))_";"_$G(^("E"))
  1. S COSGDATE=$G(^TMP("SRLQ",$J,SRDA,1507,"I"))
  1. S COSGEDBY=$G(^TMP("SRLQ",$J,SRDA,1508,"I"))_";"_$G(^("E"))
  1. S COSGNAME=$G(^TMP("SRLQ",$J,SRDA,1509,"E"))
  1. S COSGTITL=$G(^TMP("SRLQ",$J,SRDA,1510,"E"))
  1. S COSGMODE=$G(^TMP("SRLQ",$J,SRDA,1511,"I"))_";"_$G(^("E"))
  1. S SIGCHRT=$G(^TMP("SRLQ",$J,SRDA,1512,"I"))_";"_$G(^("E"))
  1. S COSCHRT=$G(^TMP("SRLQ",$J,SRDA,1513,"I"))_";"_$G(^("E"))
  1. D SETCONT() Q:'SRCONT W !
  1. D SIGBLK Q:'SRCONT
  1. ADDENDA ; Surgery Reports Addenda
  1. N DIW,DIWF,DIWL,DIWR,DIWT,X,Z,SRI,SRADD
  1. S SRADD=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W")
  1. F S SRADD=$O(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD)) Q:SRADD'>0 D Q:'SRCONT
  1. . S SRY=4 D SETCONT() Q:'SRCONT
  1. . W !!,$$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1301,"I"),"MM/DD/CCYY HR:MIN"),?21,"ADDENDUM"
  1. . W ?41,"STATUS: ",^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,.05,"E")
  1. . S SRI=0
  1. . F S SRI=$O(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,"TEXT",SRI)) Q:SRI'>0 D Q:'SRCONT
  1. . . D SETCONT() Q:'SRCONT
  1. . . S X=^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,"TEXT",SRI,0) S:X="" X=" " D ^DIWP
  1. . D ^DIWW
  1. . D:SRCONT ADDENSIG
  1. K ^UTILITY($J,"W")
  1. ; Write 2 linefeeds between records
  1. Q:'SRCONT W !!
  1. Q
  1. ADDENSIG ;
  1. N AUTHOR,EXPSIGNR,ATTNDING,SIGNDATE,SIGNEDBY,SIGNNAME,SIGNMODE
  1. N COSGDATE,COSGEDBY,COSGNAME,COSGMODE,SRLINE S $P(SRLINE,"-",80)=""
  1. S AUTHOR=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1202,"I"))_";"_$G(^("E"))
  1. S EXPSIGNR=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1204,"I"))_";"_$G(^("E"))
  1. S ATTNDING=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1209,"I"))_";"_$G(^("E"))
  1. S SIGNDATE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1501,"I"))
  1. S SIGNEDBY=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1502,"I"))_";"_$G(^("E"))
  1. S SIGNNAME=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1503,"E"))
  1. S SIGTITL=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1504,"E"))
  1. S SIGNMODE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1505,"I"))_";"_$G(^("E"))
  1. S COSGDATE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1507,"I"))
  1. S COSGEDBY=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1508,"I"))_";"_$G(^("E"))
  1. S COSGNAME=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1509,"E"))
  1. S COSGTITL=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1510,"E"))
  1. S COSGMODE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1511,"I"))_";"_$G(^("E"))
  1. S SRY=11
  1. SIGBLK N SRGROOT S SRGROOT=$NA(^TMP("SRLQ",$J,SRDA))
  1. I '+SIGNDATE D D SETCONT() Q:'SRCONT
  1. .I $$STATUS^SROESUTL(SRDA)'=7 W !,"**DRAFT COPY - DRAFT COPY -- ABOVE NOTE IS UNSIGNED-- DRAFT COPY - DRAFT COPY**"
  1. I SIGNEDBY]"",(+SIGNEDBY'=+AUTHOR) D
  1. . W ?21,"Author: ",$P(AUTHOR,";",2),!
  1. I +SIGNDATE D SETCONT() Q:'SRCONT D
  1. . W ?18,"Signed by:",$S($P(SIGNMODE,";")="C":" /s/ ",1:" /es/ "),?34,$S(SIGNNAME]"":SIGNNAME,1:$P(SIGNEDBY,";",2))
  1. . W !?34,SIGTITL
  1. . I $L(SIGTITL)>30 W !?34
  1. . E W " "
  1. . W $$DATE^SROESPR(+SIGNDATE,"MM/DD/CCYY HR:MIN")
  1. . I '+$G(SRFLAG)!($E(IOST)="C") D
  1. . . I $P($$BEEP^SROESPR(+SIGNEDBY),U) W !?34,"Analog Pager: ",$P($$BEEP^SROESPR(+SIGNEDBY),U)
  1. . . I $P($$BEEP^SROESPR(+SIGNEDBY),U,2) W !?34,"Digital Pager: ",$P($$BEEP^SROESPR(+SIGNEDBY),U,2)
  1. I $G(^TMP("SRLQ",$J,SRDA,.05,"E"))="UNCOSIGNED" D
  1. . W !?34,"**REQUIRES COSIGNATURE**",!
  1. I +SIGCHRT,$P(SIGNMODE,";")="C" D SETCONT() Q:'SRCONT D
  1. . W !?2,"Marked signed on chart by:",?34,$P(SIGCHRT,";",2)
  1. I +$G(SRADD) S SRGROOT=$NA(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD))
  1. I +$D(@SRGROOT@("EXTRASGNR")) D
  1. . N SRI S SRI=0
  1. . D SETCONT() Q:'SRCONT W !?4,"Receipt Acknowledged By:"
  1. . F S SRI=$O(@SRGROOT@("EXTRASGNR",SRI)) Q:'SRI D
  1. . . I +$G(@SRGROOT@("EXTRASGNR",SRI,"DATE"))'>0 Q
  1. . . I SRI>1 D SETCONT() Q:'SRCONT W !
  1. . . W ?29,"/es/ ",$G(@SRGROOT@("EXTRASGNR",SRI,"NAME"))
  1. . . W !?34,$G(@SRGROOT@("EXTRASGNR",SRI,"TITLE"))
  1. . . I $L($G(@SRGROOT@("EXTRASGNR",SRI,"TITLE")))>30 W !?34
  1. . . E W " "
  1. . . W $$DATE^SROESPR($G(@SRGROOT@("EXTRASGNR",SRI,"DATE")),"MM/DD/CCYY HR:MIN")
  1. . . I '+$G(SRFLAG)!($E(IOST)="C") D
  1. . . . N BEEP
  1. . . . S BEEP=$$BEEP^SROESPR(+$G(@SRGROOT@("EXTRASGNR",SRI,"EXTRA")))
  1. . . . I +BEEP W !?34,"Analog Pager: ",$P(BEEP,U)
  1. . . . I +$P(BEEP,U,2) W !?34,"Digital Pager: ",$P(BEEP,U,2)
  1. . K @SRGROOT@("EXTRASGNR")
  1. I +COSGDATE,(+COSGEDBY'=+SIGNEDBY) D SETCONT() Q:'SRCONT D
  1. . W !?16,"Cosigned by:",$S($P(COSGMODE,";")="C":" /s/ ",1:" /es/ "),?34,$S(COSGNAME]"":COSGNAME,1:$P(COSGEDBY,";",2))
  1. . W !?34,COSGTITL," "
  1. . W $$DATE^SROESPR(+COSGDATE,"MM/DD/CCYY HR:MIN")
  1. . I '+$G(SRFLAG)!($E(IOST)="C") D
  1. . . I $P($$BEEP^SROESPR(+COSGEDBY),U) W !?34,"Analog Pager: ",$P($$BEEP^SROESPR(+COSGEDBY),U)
  1. . . I $P($$BEEP^SROESPR(+COSGEDBY),U,2) W !?34,"Digital Pager:",$P($$BEEP^SROESPR(+COSGEDBY),U,2)
  1. I +COSCHRT,$P(COSGMODE,";")="C" D SETCONT() Q:'SRCONT D
  1. . W !,"Marked cosigned on chart by:",?34,$P(COSCHRT,";",2)
  1. W !
  1. K SRCONT1
  1. AMEND ; signature blocks of amender
  1. S SRY=4 D SETCONT() Q:'SRCONT
  1. I +$G(@SRGROOT@(1601,"I")) D
  1. . W !!?12,"Amendment Filed:",?34,$$DATE^SROESPR(@SRGROOT@(1601,"I"),"MM/DD/CCYY HR:MIN")
  1. . I $G(@SRGROOT@(1603,"E"))']"" D
  1. . . W !!?29 F SRI=1:1:40 W "_"
  1. . . W !?29,$$SIGNAME^SROESPR(@SRGROOT@(1602,"I"))
  1. . . W !?29,$$SIGTITL^SROESPR(@SRGROOT@(1602,"I"))
  1. . I $G(@SRGROOT@(1604,"E"))]"" D
  1. . . W !?29,"/es/",?34,@SRGROOT@(1604,"E")
  1. . . W !?34,@SRGROOT@(1605,"E")
  1. Q
  1. SETCONT(SRHEAD) ;Does footer and sets SRCONT
  1. S SRCONT=$$FOOTER^SROESPR2(.SRFOOT,SRFLAG,SRPFNBR,$G(SRHEAD),$G(SRCONT1),SRDA)
  1. Q