GMTSPN2 ; SLC/KER - Progress Note Signatures ; 8/1/06 4:24pm
;;2.7;Health Summary;**45,47,49,82,107**;Oct 20, 1995;Build 3
Q
;
; External References
; DBIA 10011 ^DIWP
; DBIA 2056 $$GET1^DIQ
; DBIA 10060 ^VA(200, .137
; DBIA 10060 ^VA(200, .138
; DBIA 4081 ^TIU(8925, 1606
; DBIA 4081 ^TIU(8925, 1613
;
WS(X,I) ; Write Signatures
Q:$D(GMTSQIT) N GMTSDIC,GMTSIEN,GMTSA,GMTSG S GMTSDIC=$G(X),GMTSIEN=$G(I)
Q:'$L(GMTSIEN) Q:$E($P(GMTSDIC,$J,1),1,11)'="^TMP(""TIU""," Q:'$D(@($P(GMTSDIC,",",1,($L(GMTSDIC,",")-1))_")"))
Q:'$D(@(GMTSDIC_GMTSIEN_")")) S GMTSDIC=GMTSDIC_GMTSIEN_","
D UNS,SOC,SIG,UNC,COC,COS,EXT
Q
UNS ; Unsigned/Draft Copy
Q:$D(GMTSQIT) N GMTST S GMTST=$G(@(GMTSDIC_"1501,""I"")"))
I GMTST=""&($$GET1^DIQ(8925,GMTSIEN,1613,"I")="S") S GMTST=$$GET1^DIQ(8925,GMTSIEN,1606,"I") ; p.107 do not mark as unsigned if document has administrative closure date
D:GMTST="" UNSIG
Q
SOC ; Signed on Chart
Q:$D(GMTSQIT) N GMTSP,GMTSB S GMTSP=$G(PN("SCHART"))
S GMTSB=$G(PN("SCHARTBY")) Q:'$L(GMTSP) Q:'$L(GMTSB)
D BL Q:$D(GMTSQIT) D BY(GMTSP,"",GMTSB) Q:$D(GMTSQIT)
Q
SIG ; Signature Block, Name, Title and Date
Q:$D(GMTSQIT) N GMTSA,GMTSG,GMTSE,GMTST,GMTSD,GMTSP,GMTSB
S GMTSP="Signed by:",GMTSE=$G(@(GMTSDIC_"1505,""I"")"))
S GMTSB=$G(PN("SIGBLK")) Q:'$L(GMTSB) S GMTST=$G(PN("STITLE"))
S GMTSD=$G(PN("SIGDT")),GMTSA=$$GET1^DIQ(200,+($G(SIGNEDBY)),.137)
S GMTSG=$$GET1^DIQ(200,+($G(SIGNEDBY)),.138) D BL Q:$D(GMTSQIT)
D BY(GMTSP,GMTSE,GMTSB) Q:$D(GMTSQIT) D SB(GMTST,GMTSD) Q:$D(GMTSQIT)
D PG(GMTSA,GMTSG) Q:$D(GMTSQIT)
Q
UNC ; Uncosigned - Requires Cosignature
Q:$D(GMTSQIT) N GMTSP,GMTSB
S GMTSP=$G(@(GMTSDIC_".05,""E"")")) Q:GMTSP'="UNCOSIGNED"
Q:$E($G(GMTSTIUC),1)["D"&('CONEED) D BL Q:$D(GMTSQIT)
D CKP^GMTSUP Q:$D(GMTSQIT) W !?27,"** REQUIRES COSIGNATURE **"
Q
COC ; Cosigned on Chart
Q:$D(GMTSQIT) N GMTSP,GMTSB
S GMTSP=$G(PN("COCHART")),GMTSB=$G(PN("COCHARTBY")) Q:'$L(GMTSP) Q:'$L(GMTSB)
Q:$E($G(GMTSTIUC),1)["D"&('CONEED) D BL Q:$D(GMTSQIT) D BY(GMTSP,"",GMTSB)
Q
COS ; Co-Signature Block, Name, Title and Date
Q:$D(GMTSQIT) N GMTSA,GMTSG,GMTSE,GMTST,GMTSD,GMTSP,GMTSB
S GMTSP="Cosigned by:",GMTSE=$G(@(GMTSDIC_"1511,""I"")")),GMTSB=$G(PN("COBLK")) Q:'$L(GMTSB)
S GMTST=$G(PN("COTITLE")),GMTSD=$G(PN("COSDT"))
S GMTSA=$$GET1^DIQ(200,+($G(COSGEDBY)),.137),GMTSG=$$GET1^DIQ(200,+($G(COSGEDBY)),.138)
Q:$E($G(GMTSTIUC),1)["D"&('CONEED) D BL Q:$D(GMTSQIT)
D BY(GMTSP,GMTSE,GMTSB) Q:$D(GMTSQIT) D SB(GMTST,GMTSD) Q:$D(GMTSQIT)
D PG(GMTSA,GMTSG)
Q
EXT ; Extra Signatures
; Receipt Acknowledged by:
Q:$D(GMTSQIT) I +$O(@(GMTSDIC_"""EXTRASGNR"",0)")) D Q:$D(GMTSQIT)
. D BL Q:$D(GMTSQIT) D BY("Receipt Acknowledged by:","","")
; Extra Signature Block, Name, Title and Date
N GMTSXTRA S GMTSXTRA=0
F S GMTSXTRA=+$O(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_")")) Q:+GMTSXTRA'>0 D Q:$D(GMTSQIT)
. N GMTSA,GMTSG,GMTSE,GMTST,GMTSD,GMTSP,GMTSB,GMTSI,GMTSC
. S GMTSC=+($G(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_",""DATE"")")))
. I GMTSC'>0 W ?27,"* AWAITING SIGNATURE *" D BL Q
. S GMTSP="",GMTSE="/es/",GMTSB=$G(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_",""NAME"")")) Q:'$L(GMTSB)
. S GMTST=$G(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_",""TITLE"")"))
. S GMTSD=$$EDT^GMTSU(GMTSC),GMTSI=+($G(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_",""EXTRA"")")))
. S GMTSA=$$GET1^DIQ(200,+($G(GMTSI)),.137),GMTSG=$$GET1^DIQ(200,+($G(GMTSI)),.138)
. I +($G(GMTSXTRA))>1 D BL Q:$D(GMTSQIT) D BL Q:$D(GMTSQIT)
. D BY(GMTSP,GMTSE,GMTSB) Q:$D(GMTSQIT)
. D SB(GMTST,GMTSD) Q:$D(GMTSQIT) D PG(GMTSA,GMTSG) Q:$D(GMTSQIT)
Q
;
UNSIG ; Unsigned Note
N GMTS,GMTS1,GMTS2,GMTST,GMTSB S GMTST="< THE ABOVE NOTE IS UNSIGNED >",GMTS=""
S $P(GMTS," ",((79-$L(GMTST))\2)\2)=" ",$P(GMTS1," ",((79-$L(GMTST))\2)\2)=" "
S GMTS2=GMTS_GMTS1,GMTS1=GMTS1_GMTS,GMTSB=GMTS1_GMTST_GMTS2
D CKP^GMTSUP Q:$D(GMTSQIT) W ! D CKP^GMTSUP Q:$D(GMTSQIT) W !,GMTSB
D CKP^GMTSUP Q:$D(GMTSQIT) W !,"- DRAFT COPY * DRAFT COPY * DRAFT COPY * DRAFT COPY * DRAFT COPY * DRAFT COPY -"
Q
;
; Warnings
WARN1 ; Beginning of Note
N GMTSD,GMTSW S GMTSW=1,GMTSD=0 D DEL1,RETR1 D:GMTSD BL Q
WARN2 ; End of Note
N GMTSD,GMTSW S GMTSW=2,GMTSD=0 D DEL2,RETR2 Q
DEL1 ; Deleted Note (begin)
Q:($G(STATUS)'="DELETED")&($G(PN("STATUS"))'="DELETED")
N GMTST,GMTST2 S GMTST="< THE FOLLOWING ENTRY HAS BEEN DELETED >",GMTST2="<<<<< DELETED * DELETED * DELETED * DELETED * DELETED * DELETED >>>>>" D WARN3 Q
DEL2 ; Deleted Note (end)
Q:($G(STATUS)'="DELETED")&($G(PN("STATUS"))'="DELETED")
N GMTST,GMTST2 S GMTST="< THE ABOVE ENTRY HAS BEEN DELETED >",GMTST2="<<<<< DELETED * DELETED * DELETED * DELETED * DELETED * DELETED >>>>>" D WARN3 Q
RETR1 ; Retracted Note (begin)
Q:($G(STATUS)'="RETRACTED")&($G(PN("STATUS"))'="RETRACTED")
N GMTST,GMTST2 S GMTST="< THE FOLLOWING ENTRY HAS BEEN RETRACTED >",GMTST2="<<<<<< RETRACTED * RETRACTED * RETRACTED * RETRACTED * RETRACTED >>>>>>" D WARN3 Q
RETR2 ; Retracted Note (end)
Q:($G(STATUS)'="RETRACTED")&($G(PN("STATUS"))'="RETRACTED")
N GMTST,GMTST2 S GMTST="< THE ABOVE ENTRY HAS BEEN RETRACTED >",GMTST2="<<<<<< RETRACTED * RETRACTED * RETRACTED * RETRACTED * RETRACTED >>>>>>" D WARN3 Q
WARN3 ; Warning Display (display)
N GMTS,GMTS1,GMTS2,GMTSB S GMTS="",GMTST=$G(GMTST),GMTST2=$G(GMTST2) Q:'$L(GMTST) Q:'$L(GMTST2)
S $P(GMTS,"<",((79-$L(GMTST))\2)\2)="<"
S $P(GMTS1,"<",((79-$L(GMTST))\2)\2)="<",GMTS1=GMTS_GMTS1,GMTS=""
S $P(GMTS,">",((79-$L(GMTST))\2)\2)=">"
S $P(GMTS2,">",((79-$L(GMTST))\2)\2)=">",GMTS2=GMTS2_GMTS,GMTS=""
S GMTSB=GMTS1_GMTST_GMTS2 F Q:$L(GMTSB)'<$L(GMTST2) S GMTSB=GMTSB_">"
I +($G(GMTSW))=2 D BL Q:$D(GMTSQIT)
I +($G(GMTSW))=1 D CKP^GMTSUP Q:$D(GMTSQIT) W !,GMTSB
D CKP^GMTSUP Q:$D(GMTSQIT) W !,GMTST2 S:$D(GMTSD) GMTSD=1
I +($G(GMTSW))=2 D CKP^GMTSUP Q:$D(GMTSQIT) W !,GMTSB
Q
;
; Miscelaneous
BY(GMTSH,GMTSE,GMTSN) ; Signed by
S GMTSH=$$TRIM($G(GMTSH)),GMTSE=$G(GMTSE),GMTSN=$G(GMTSN) Q:'$L((GMTSH_GMTSN))
S:$L(GMTSH) GMTSH=GMTSH_" " S GMTSE=$S(GMTSE="E":"/es/ ",GMTSE["/es/":"/es/ ",1:"") S:GMTSN="."&(GMTSH[" by:") GMTSH=$P(GMTSH," by:",1)_".",GMTSN="" S:GMTSN="." GMTSN=""
I $L($$TRIM(GMTSH)) D CKP^GMTSUP Q:$D(GMTSQIT) W !,$J("",(27-$L(GMTSH))),GMTSH
W ?27,GMTSE,GMTSN
Q
SB(GMTSB,GMTSD) ; Signature Block
K ^UTILITY($J,"W") N X,DIWT,DIWL,DIWR,DIWF,GMTSI
S (X,GMTSB)=$G(GMTSB),GMTSD=$G(GMTSD) Q:'$L((GMTSB_GMTSD))
S GMTSI=1,DIWL=0,DIWF="C51" D ^DIWP S GMTSB=$$TRIM($G(^UTILITY($J,"W",0,1,0))) K:'$L(GMTSB) ^UTILITY($J,"W")
I $L(GMTSD),'$L(GMTSB) K ^UTILITY($J,"W") D CKP^GMTSUP Q:$D(GMTSQIT) W !,?27,GMTSD Q
Q:'$L(GMTSB) D CKP^GMTSUP K:$D(GMTSQIT) ^UTILITY($J,"W") Q:$D(GMTSQIT) W !,?27,GMTSB,!,?27,GMTSD
K ^UTILITY($J,"W")
Q
PG(GMTSA,GMTSD) ; Pagers
N GMTS S GMTS=0,GMTSA=$G(GMTSA),GMTSD=$G(GMTSD) Q:'$L((GMTSA_GMTSD)) Q:(+GMTSA+GMTSD)'>0
D CKP^GMTSUP Q:$D(GMTSQIT) W ! I $L(GMTSA),+GMTSA>0 D Q:$D(GMTSQIT)
. D CKP^GMTSUP Q:$D(GMTSQIT) W !?34,"Analog Pager: ",GMTSA S GMTS=1
I $L(GMTSD),+GMTSD>0 D Q:$D(GMTSQIT)
. D CKP^GMTSUP Q:$D(GMTSQIT) W !?33,"Digital Pager: ",GMTSD S GMTS=1
Q
BL ; Blank Line
D CKP^GMTSUP Q:$D(GMTSQIT) W ! Q
TRIM(X) ; Trim Spaces from String
S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSPN2 7583 printed Oct 16, 2024@18:00:08 Page 2
GMTSPN2 ; SLC/KER - Progress Note Signatures ; 8/1/06 4:24pm
+1 ;;2.7;Health Summary;**45,47,49,82,107**;Oct 20, 1995;Build 3
+2 QUIT
+3 ;
+4 ; External References
+5 ; DBIA 10011 ^DIWP
+6 ; DBIA 2056 $$GET1^DIQ
+7 ; DBIA 10060 ^VA(200, .137
+8 ; DBIA 10060 ^VA(200, .138
+9 ; DBIA 4081 ^TIU(8925, 1606
+10 ; DBIA 4081 ^TIU(8925, 1613
+11 ;
WS(X,I) ; Write Signatures
+1 if $DATA(GMTSQIT)
QUIT
NEW GMTSDIC,GMTSIEN,GMTSA,GMTSG
SET GMTSDIC=$GET(X)
SET GMTSIEN=$GET(I)
+2 if '$LENGTH(GMTSIEN)
QUIT
if $EXTRACT($PIECE(GMTSDIC,$JOB,1),1,11)'="^TMP(""TIU"","
QUIT
if '$DATA(@($PIECE(GMTSDIC,",",1,($LENGTH(GMTSDIC,",")-1))_")"))
QUIT
+3 if '$DATA(@(GMTSDIC_GMTSIEN_")"))
QUIT
SET GMTSDIC=GMTSDIC_GMTSIEN_","
+4 DO UNS
DO SOC
DO SIG
DO UNC
DO COC
DO COS
DO EXT
+5 QUIT
UNS ; Unsigned/Draft Copy
+1 if $DATA(GMTSQIT)
QUIT
NEW GMTST
SET GMTST=$GET(@(GMTSDIC_"1501,""I"")"))
+2 ; p.107 do not mark as unsigned if document has administrative closure date
IF GMTST=""&($$GET1^DIQ(8925,GMTSIEN,1613,"I")="S")
SET GMTST=$$GET1^DIQ(8925,GMTSIEN,1606,"I")
+3 if GMTST=""
DO UNSIG
+4 QUIT
SOC ; Signed on Chart
+1 if $DATA(GMTSQIT)
QUIT
NEW GMTSP,GMTSB
SET GMTSP=$GET(PN("SCHART"))
+2 SET GMTSB=$GET(PN("SCHARTBY"))
if '$LENGTH(GMTSP)
QUIT
if '$LENGTH(GMTSB)
QUIT
+3 DO BL
if $DATA(GMTSQIT)
QUIT
DO BY(GMTSP,"",GMTSB)
if $DATA(GMTSQIT)
QUIT
+4 QUIT
SIG ; Signature Block, Name, Title and Date
+1 if $DATA(GMTSQIT)
QUIT
NEW GMTSA,GMTSG,GMTSE,GMTST,GMTSD,GMTSP,GMTSB
+2 SET GMTSP="Signed by:"
SET GMTSE=$GET(@(GMTSDIC_"1505,""I"")"))
+3 SET GMTSB=$GET(PN("SIGBLK"))
if '$LENGTH(GMTSB)
QUIT
SET GMTST=$GET(PN("STITLE"))
+4 SET GMTSD=$GET(PN("SIGDT"))
SET GMTSA=$$GET1^DIQ(200,+($GET(SIGNEDBY)),.137)
+5 SET GMTSG=$$GET1^DIQ(200,+($GET(SIGNEDBY)),.138)
DO BL
if $DATA(GMTSQIT)
QUIT
+6 DO BY(GMTSP,GMTSE,GMTSB)
if $DATA(GMTSQIT)
QUIT
DO SB(GMTST,GMTSD)
if $DATA(GMTSQIT)
QUIT
+7 DO PG(GMTSA,GMTSG)
if $DATA(GMTSQIT)
QUIT
+8 QUIT
UNC ; Uncosigned - Requires Cosignature
+1 if $DATA(GMTSQIT)
QUIT
NEW GMTSP,GMTSB
+2 SET GMTSP=$GET(@(GMTSDIC_".05,""E"")"))
if GMTSP'="UNCOSIGNED"
QUIT
+3 if $EXTRACT($GET(GMTSTIUC),1)["D"&('CONEED)
QUIT
DO BL
if $DATA(GMTSQIT)
QUIT
+4 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !?27,"** REQUIRES COSIGNATURE **"
+5 QUIT
COC ; Cosigned on Chart
+1 if $DATA(GMTSQIT)
QUIT
NEW GMTSP,GMTSB
+2 SET GMTSP=$GET(PN("COCHART"))
SET GMTSB=$GET(PN("COCHARTBY"))
if '$LENGTH(GMTSP)
QUIT
if '$LENGTH(GMTSB)
QUIT
+3 if $EXTRACT($GET(GMTSTIUC),1)["D"&('CONEED)
QUIT
DO BL
if $DATA(GMTSQIT)
QUIT
DO BY(GMTSP,"",GMTSB)
+4 QUIT
COS ; Co-Signature Block, Name, Title and Date
+1 if $DATA(GMTSQIT)
QUIT
NEW GMTSA,GMTSG,GMTSE,GMTST,GMTSD,GMTSP,GMTSB
+2 SET GMTSP="Cosigned by:"
SET GMTSE=$GET(@(GMTSDIC_"1511,""I"")"))
SET GMTSB=$GET(PN("COBLK"))
if '$LENGTH(GMTSB)
QUIT
+3 SET GMTST=$GET(PN("COTITLE"))
SET GMTSD=$GET(PN("COSDT"))
+4 SET GMTSA=$$GET1^DIQ(200,+($GET(COSGEDBY)),.137)
SET GMTSG=$$GET1^DIQ(200,+($GET(COSGEDBY)),.138)
+5 if $EXTRACT($GET(GMTSTIUC),1)["D"&('CONEED)
QUIT
DO BL
if $DATA(GMTSQIT)
QUIT
+6 DO BY(GMTSP,GMTSE,GMTSB)
if $DATA(GMTSQIT)
QUIT
DO SB(GMTST,GMTSD)
if $DATA(GMTSQIT)
QUIT
+7 DO PG(GMTSA,GMTSG)
+8 QUIT
EXT ; Extra Signatures
+1 ; Receipt Acknowledged by:
+2 if $DATA(GMTSQIT)
QUIT
IF +$ORDER(@(GMTSDIC_"""EXTRASGNR"",0)"))
Begin DoDot:1
+3 DO BL
if $DATA(GMTSQIT)
QUIT
DO BY("Receipt Acknowledged by:","","")
End DoDot:1
if $DATA(GMTSQIT)
QUIT
+4 ; Extra Signature Block, Name, Title and Date
+5 NEW GMTSXTRA
SET GMTSXTRA=0
+6 FOR
SET GMTSXTRA=+$ORDER(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_")"))
if +GMTSXTRA'>0
QUIT
Begin DoDot:1
+7 NEW GMTSA,GMTSG,GMTSE,GMTST,GMTSD,GMTSP,GMTSB,GMTSI,GMTSC
+8 SET GMTSC=+($GET(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_",""DATE"")")))
+9 IF GMTSC'>0
WRITE ?27,"* AWAITING SIGNATURE *"
DO BL
QUIT
+10 SET GMTSP=""
SET GMTSE="/es/"
SET GMTSB=$GET(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_",""NAME"")"))
if '$LENGTH(GMTSB)
QUIT
+11 SET GMTST=$GET(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_",""TITLE"")"))
+12 SET GMTSD=$$EDT^GMTSU(GMTSC)
SET GMTSI=+($GET(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_",""EXTRA"")")))
+13 SET GMTSA=$$GET1^DIQ(200,+($GET(GMTSI)),.137)
SET GMTSG=$$GET1^DIQ(200,+($GET(GMTSI)),.138)
+14 IF +($GET(GMTSXTRA))>1
DO BL
if $DATA(GMTSQIT)
QUIT
DO BL
if $DATA(GMTSQIT)
QUIT
+15 DO BY(GMTSP,GMTSE,GMTSB)
if $DATA(GMTSQIT)
QUIT
+16 DO SB(GMTST,GMTSD)
if $DATA(GMTSQIT)
QUIT
DO PG(GMTSA,GMTSG)
if $DATA(GMTSQIT)
QUIT
End DoDot:1
if $DATA(GMTSQIT)
QUIT
+17 QUIT
+18 ;
UNSIG ; Unsigned Note
+1 NEW GMTS,GMTS1,GMTS2,GMTST,GMTSB
SET GMTST="< THE ABOVE NOTE IS UNSIGNED >"
SET GMTS=""
+2 SET $PIECE(GMTS," ",((79-$LENGTH(GMTST))\2)\2)=" "
SET $PIECE(GMTS1," ",((79-$LENGTH(GMTST))\2)\2)=" "
+3 SET GMTS2=GMTS_GMTS1
SET GMTS1=GMTS1_GMTS
SET GMTSB=GMTS1_GMTST_GMTS2
+4 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !,GMTSB
+5 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !,"- DRAFT COPY * DRAFT COPY * DRAFT COPY * DRAFT COPY * DRAFT COPY * DRAFT COPY -"
+6 QUIT
+7 ;
+8 ; Warnings
WARN1 ; Beginning of Note
+1 NEW GMTSD,GMTSW
SET GMTSW=1
SET GMTSD=0
DO DEL1
DO RETR1
if GMTSD
DO BL
QUIT
WARN2 ; End of Note
+1 NEW GMTSD,GMTSW
SET GMTSW=2
SET GMTSD=0
DO DEL2
DO RETR2
QUIT
DEL1 ; Deleted Note (begin)
+1 if ($GET(STATUS)'="DELETED")&($GET(PN("STATUS"))'="DELETED")
QUIT
+2 NEW GMTST,GMTST2
SET GMTST="< THE FOLLOWING ENTRY HAS BEEN DELETED >"
SET GMTST2="<<<<< DELETED * DELETED * DELETED * DELETED * DELETED * DELETED >>>>>"
DO WARN3
QUIT
DEL2 ; Deleted Note (end)
+1 if ($GET(STATUS)'="DELETED")&($GET(PN("STATUS"))'="DELETED")
QUIT
+2 NEW GMTST,GMTST2
SET GMTST="< THE ABOVE ENTRY HAS BEEN DELETED >"
SET GMTST2="<<<<< DELETED * DELETED * DELETED * DELETED * DELETED * DELETED >>>>>"
DO WARN3
QUIT
RETR1 ; Retracted Note (begin)
+1 if ($GET(STATUS)'="RETRACTED")&($GET(PN("STATUS"))'="RETRACTED")
QUIT
+2 NEW GMTST,GMTST2
SET GMTST="< THE FOLLOWING ENTRY HAS BEEN RETRACTED >"
SET GMTST2="<<<<<< RETRACTED * RETRACTED * RETRACTED * RETRACTED * RETRACTED >>>>>>"
DO WARN3
QUIT
RETR2 ; Retracted Note (end)
+1 if ($GET(STATUS)'="RETRACTED")&($GET(PN("STATUS"))'="RETRACTED")
QUIT
+2 NEW GMTST,GMTST2
SET GMTST="< THE ABOVE ENTRY HAS BEEN RETRACTED >"
SET GMTST2="<<<<<< RETRACTED * RETRACTED * RETRACTED * RETRACTED * RETRACTED >>>>>>"
DO WARN3
QUIT
WARN3 ; Warning Display (display)
+1 NEW GMTS,GMTS1,GMTS2,GMTSB
SET GMTS=""
SET GMTST=$GET(GMTST)
SET GMTST2=$GET(GMTST2)
if '$LENGTH(GMTST)
QUIT
if '$LENGTH(GMTST2)
QUIT
+2 SET $PIECE(GMTS,"<",((79-$LENGTH(GMTST))\2)\2)="<"
+3 SET $PIECE(GMTS1,"<",((79-$LENGTH(GMTST))\2)\2)="<"
SET GMTS1=GMTS_GMTS1
SET GMTS=""
+4 SET $PIECE(GMTS,">",((79-$LENGTH(GMTST))\2)\2)=">"
+5 SET $PIECE(GMTS2,">",((79-$LENGTH(GMTST))\2)\2)=">"
SET GMTS2=GMTS2_GMTS
SET GMTS=""
+6 SET GMTSB=GMTS1_GMTST_GMTS2
FOR
if $LENGTH(GMTSB)'<$LENGTH(GMTST2)
QUIT
SET GMTSB=GMTSB_">"
+7 IF +($GET(GMTSW))=2
DO BL
if $DATA(GMTSQIT)
QUIT
+8 IF +($GET(GMTSW))=1
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !,GMTSB
+9 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !,GMTST2
if $DATA(GMTSD)
SET GMTSD=1
+10 IF +($GET(GMTSW))=2
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !,GMTSB
+11 QUIT
+12 ;
+13 ; Miscelaneous
BY(GMTSH,GMTSE,GMTSN) ; Signed by
+1 SET GMTSH=$$TRIM($GET(GMTSH))
SET GMTSE=$GET(GMTSE)
SET GMTSN=$GET(GMTSN)
if '$LENGTH((GMTSH_GMTSN))
QUIT
+2 if $LENGTH(GMTSH)
SET GMTSH=GMTSH_" "
SET GMTSE=$SELECT(GMTSE="E":"/es/ ",GMTSE["/es/":"/es/ ",1:"")
if GMTSN="."&(GMTSH[" by
SET GMTSH=$PIECE(GMTSH," by:",1)_"."
SET GMTSN=""
if GMTSN="."
SET GMTSN=""
+3 IF $LENGTH($$TRIM(GMTSH))
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !,$JUSTIFY("",(27-$LENGTH(GMTSH))),GMTSH
+4 WRITE ?27,GMTSE,GMTSN
+5 QUIT
SB(GMTSB,GMTSD) ; Signature Block
+1 KILL ^UTILITY($JOB,"W")
NEW X,DIWT,DIWL,DIWR,DIWF,GMTSI
+2 SET (X,GMTSB)=$GET(GMTSB)
SET GMTSD=$GET(GMTSD)
if '$LENGTH((GMTSB_GMTSD))
QUIT
+3 SET GMTSI=1
SET DIWL=0
SET DIWF="C51"
DO ^DIWP
SET GMTSB=$$TRIM($GET(^UTILITY($JOB,"W",0,1,0)))
if '$LENGTH(GMTSB)
KILL ^UTILITY($JOB,"W")
+4 IF $LENGTH(GMTSD)
IF '$LENGTH(GMTSB)
KILL ^UTILITY($JOB,"W")
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !,?27,GMTSD
QUIT
+5 if '$LENGTH(GMTSB)
QUIT
DO CKP^GMTSUP
if $DATA(GMTSQIT)
KILL ^UTILITY($JOB,"W")
if $DATA(GMTSQIT)
QUIT
WRITE !,?27,GMTSB,!,?27,GMTSD
+6 KILL ^UTILITY($JOB,"W")
+7 QUIT
PG(GMTSA,GMTSD) ; Pagers
+1 NEW GMTS
SET GMTS=0
SET GMTSA=$GET(GMTSA)
SET GMTSD=$GET(GMTSD)
if '$LENGTH((GMTSA_GMTSD))
QUIT
if (+GMTSA+GMTSD)'>0
QUIT
+2 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !
IF $LENGTH(GMTSA)
IF +GMTSA>0
Begin DoDot:1
+3 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !?34,"Analog Pager: ",GMTSA
SET GMTS=1
End DoDot:1
if $DATA(GMTSQIT)
QUIT
+4 IF $LENGTH(GMTSD)
IF +GMTSD>0
Begin DoDot:1
+5 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !?33,"Digital Pager: ",GMTSD
SET GMTS=1
End DoDot:1
if $DATA(GMTSQIT)
QUIT
+6 QUIT
BL ; Blank Line
+1 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !
QUIT
TRIM(X) ; Trim Spaces from String
+1 SET X=$GET(X)
FOR
if $EXTRACT(X,1)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
if $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 QUIT X
