source: WorldVistAEHR/trunk/r/HEALTH_SUMMARY-GMTS/GMTSPN2.m@ 619

Last change on this file since 619 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 7.2 KB
Line 
1GMTSPN2 ; SLC/KER - Progress Note Signatures ; 02/27/2002
2 ;;2.7;Health Summary;**45,47,49**;Oct 20, 1995
3 Q
4 ;
5 ; External References
6 ; DBIA 10011 ^DIWP
7 ; DBIA 2056 $$GET1^DIQ
8 ; DBIA 10060 ^VA(200, .137
9 ; DBIA 10060 ^VA(200, .138
10 ;
11WS(X,I) ; Write Signatures
12 Q:$D(GMTSQIT) N GMTSDIC,GMTSIEN,GMTSA,GMTSG S GMTSDIC=$G(X),GMTSIEN=$G(I)
13 Q:'$L(GMTSIEN) Q:$E($P(GMTSDIC,$J,1),1,11)'="^TMP(""TIU""," Q:'$D(@($P(GMTSDIC,",",1,($L(GMTSDIC,",")-1))_")"))
14 Q:'$D(@(GMTSDIC_GMTSIEN_")")) S GMTSDIC=GMTSDIC_GMTSIEN_","
15 D UNS,SOC,SIG,UNC,COC,COS,EXT
16 Q
17UNS ; Unsigned/Draft Copy
18 Q:$D(GMTSQIT) N GMTST S GMTST=$G(@(GMTSDIC_"1501,""I"")")) D:GMTST="" UNSIG
19 Q
20SOC ; Signed on Chart
21 Q:$D(GMTSQIT) N GMTSP,GMTSB S GMTSP=$G(PN("SCHART"))
22 S GMTSB=$G(PN("SCHARTBY")) Q:'$L(GMTSP) Q:'$L(GMTSB)
23 D BL Q:$D(GMTSQIT) D BY(GMTSP,"",GMTSB) Q:$D(GMTSQIT)
24 Q
25SIG ; Signature Block, Name, Title and Date
26 Q:$D(GMTSQIT) N GMTSA,GMTSG,GMTSE,GMTST,GMTSD,GMTSP,GMTSB
27 S GMTSP="Signed by:",GMTSE=$G(@(GMTSDIC_"1505,""I"")"))
28 S GMTSB=$G(PN("SIGBLK")) Q:'$L(GMTSB) S GMTST=$G(PN("STITLE"))
29 S GMTSD=$G(PN("SIGDT")),GMTSA=$$GET1^DIQ(200,+($G(SIGNEDBY)),.137)
30 S GMTSG=$$GET1^DIQ(200,+($G(SIGNEDBY)),.138) D BL Q:$D(GMTSQIT)
31 D BY(GMTSP,GMTSE,GMTSB) Q:$D(GMTSQIT) D SB(GMTST,GMTSD) Q:$D(GMTSQIT)
32 D PG(GMTSA,GMTSG) Q:$D(GMTSQIT)
33 Q
34UNC ; Uncosigned - Requires Cosignature
35 Q:$D(GMTSQIT) N GMTSP,GMTSB
36 S GMTSP=$G(@(GMTSDIC_".05,""E"")")) Q:GMTSP'="UNCOSIGNED"
37 Q:$E($G(GMTSTIUC),1)["D"&('CONEED) D BL Q:$D(GMTSQIT)
38 D CKP^GMTSUP Q:$D(GMTSQIT) W !?27,"** REQUIRES COSIGNATURE **"
39 Q
40COC ; Cosigned on Chart
41 Q:$D(GMTSQIT) N GMTSP,GMTSB
42 S GMTSP=$G(PN("COCHART")),GMTSB=$G(PN("COCHARTBY")) Q:'$L(GMTSP) Q:'$L(GMTSB)
43 Q:$E($G(GMTSTIUC),1)["D"&('CONEED) D BL Q:$D(GMTSQIT) D BY(GMTSP,"",GMTSB)
44 Q
45COS ; Co-Signature Block, Name, Title and Date
46 Q:$D(GMTSQIT) N GMTSA,GMTSG,GMTSE,GMTST,GMTSD,GMTSP,GMTSB
47 S GMTSP="Cosigned by:",GMTSE=$G(@(GMTSDIC_"1511,""I"")")),GMTSB=$G(PN("COBLK")) Q:'$L(GMTSB)
48 S GMTST=$G(PN("COTITLE")),GMTSD=$G(PN("COSDT"))
49 S GMTSA=$$GET1^DIQ(200,+($G(COSGEDBY)),.137),GMTSG=$$GET1^DIQ(200,+($G(COSGEDBY)),.138)
50 Q:$E($G(GMTSTIUC),1)["D"&('CONEED) D BL Q:$D(GMTSQIT)
51 D BY(GMTSP,GMTSE,GMTSB) Q:$D(GMTSQIT) D SB(GMTST,GMTSD) Q:$D(GMTSQIT)
52 D PG(GMTSA,GMTSG)
53 Q
54EXT ; Extra Signatures
55 ; Receipt Acknowledged by:
56 Q:$D(GMTSQIT) I +$O(@(GMTSDIC_"""EXTRASGNR"",0)")) D Q:$D(GMTSQIT)
57 . D BL Q:$D(GMTSQIT) D BY("Receipt Acknowledged by:","","")
58 ; Extra Signature Block, Name, Title and Date
59 N GMTSXTRA S GMTSXTRA=0
60 F S GMTSXTRA=+$O(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_")")) Q:+GMTSXTRA'>0 D Q:$D(GMTSQIT)
61 . N GMTSA,GMTSG,GMTSE,GMTST,GMTSD,GMTSP,GMTSB,GMTSI,GMTSC
62 . S GMTSC=+($G(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_",""DATE"")")))
63 . I GMTSC'>0 W ?27,"* AWAITING SIGNATURE *" D BL Q
64 . S GMTSP="",GMTSE="/es/",GMTSB=$G(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_",""NAME"")")) Q:'$L(GMTSB)
65 . S GMTST=$G(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_",""TITLE"")"))
66 . S GMTSD=$$EDT^GMTSU(GMTSC),GMTSI=+($G(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_",""EXTRA"")")))
67 . S GMTSA=$$GET1^DIQ(200,+($G(GMTSI)),.137),GMTSG=$$GET1^DIQ(200,+($G(GMTSI)),.138)
68 . I +($G(GMTSXTRA))>1 D BL Q:$D(GMTSQIT) D BL Q:$D(GMTSQIT)
69 . D BY(GMTSP,GMTSE,GMTSB) Q:$D(GMTSQIT)
70 . D SB(GMTST,GMTSD) Q:$D(GMTSQIT) D PG(GMTSA,GMTSG) Q:$D(GMTSQIT)
71 Q
72 ;
73UNSIG ; Unsigned Note
74 N GMTS,GMTS1,GMTS2,GMTST,GMTSB S GMTST="< THE ABOVE NOTE IS UNSIGNED >",GMTS=""
75 S $P(GMTS," ",((79-$L(GMTST))\2)\2)=" ",$P(GMTS1," ",((79-$L(GMTST))\2)\2)=" "
76 S GMTS2=GMTS_GMTS1,GMTS1=GMTS1_GMTS,GMTSB=GMTS1_GMTST_GMTS2
77 D CKP^GMTSUP Q:$D(GMTSQIT) W ! D CKP^GMTSUP Q:$D(GMTSQIT) W !,GMTSB
78 D CKP^GMTSUP Q:$D(GMTSQIT) W !,"- DRAFT COPY * DRAFT COPY * DRAFT COPY * DRAFT COPY * DRAFT COPY * DRAFT COPY -"
79 Q
80 ;
81 ; Warnings
82WARN1 ; Beginning of Note
83 N GMTSD,GMTSW S GMTSW=1,GMTSD=0 D DEL1,RETR1 D:GMTSD BL Q
84WARN2 ; End of Note
85 N GMTSD,GMTSW S GMTSW=2,GMTSD=0 D DEL2,RETR2 Q
86DEL1 ; Deleted Note (begin)
87 Q:($G(STATUS)'="DELETED")&($G(PN("STATUS"))'="DELETED")
88 N GMTST,GMTST2 S GMTST="< THE FOLLOWING ENTRY HAS BEEN DELETED >",GMTST2="<<<<< DELETED * DELETED * DELETED * DELETED * DELETED * DELETED >>>>>" D WARN3 Q
89DEL2 ; Deleted Note (end)
90 Q:($G(STATUS)'="DELETED")&($G(PN("STATUS"))'="DELETED")
91 N GMTST,GMTST2 S GMTST="< THE ABOVE ENTRY HAS BEEN DELETED >",GMTST2="<<<<< DELETED * DELETED * DELETED * DELETED * DELETED * DELETED >>>>>" D WARN3 Q
92RETR1 ; Retracted Note (begin)
93 Q:($G(STATUS)'="RETRACTED")&($G(PN("STATUS"))'="RETRACTED")
94 N GMTST,GMTST2 S GMTST="< THE FOLLOWING ENTRY HAS BEEN RETRACTED >",GMTST2="<<<<<< RETRACTED * RETRACTED * RETRACTED * RETRACTED * RETRACTED >>>>>>" D WARN3 Q
95RETR2 ; Retracted Note (end)
96 Q:($G(STATUS)'="RETRACTED")&($G(PN("STATUS"))'="RETRACTED")
97 N GMTST,GMTST2 S GMTST="< THE ABOVE ENTRY HAS BEEN RETRACTED >",GMTST2="<<<<<< RETRACTED * RETRACTED * RETRACTED * RETRACTED * RETRACTED >>>>>>" D WARN3 Q
98WARN3 ; Warning Display (display)
99 N GMTS,GMTS1,GMTS2,GMTSB S GMTS="",GMTST=$G(GMTST),GMTST2=$G(GMTST2) Q:'$L(GMTST) Q:'$L(GMTST2)
100 S $P(GMTS,"<",((79-$L(GMTST))\2)\2)="<"
101 S $P(GMTS1,"<",((79-$L(GMTST))\2)\2)="<",GMTS1=GMTS_GMTS1,GMTS=""
102 S $P(GMTS,">",((79-$L(GMTST))\2)\2)=">"
103 S $P(GMTS2,">",((79-$L(GMTST))\2)\2)=">",GMTS2=GMTS2_GMTS,GMTS=""
104 S GMTSB=GMTS1_GMTST_GMTS2 F Q:$L(GMTSB)'<$L(GMTST2) S GMTSB=GMTSB_">"
105 I +($G(GMTSW))=2 D BL Q:$D(GMTSQIT)
106 I +($G(GMTSW))=1 D CKP^GMTSUP Q:$D(GMTSQIT) W !,GMTSB
107 D CKP^GMTSUP Q:$D(GMTSQIT) W !,GMTST2 S:$D(GMTSD) GMTSD=1
108 I +($G(GMTSW))=2 D CKP^GMTSUP Q:$D(GMTSQIT) W !,GMTSB
109 Q
110 ;
111 ; Miscelaneous
112BY(GMTSH,GMTSE,GMTSN) ; Signed by
113 S GMTSH=$$TRIM($G(GMTSH)),GMTSE=$G(GMTSE),GMTSN=$G(GMTSN) Q:'$L((GMTSH_GMTSN))
114 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=""
115 I $L($$TRIM(GMTSH)) D CKP^GMTSUP Q:$D(GMTSQIT) W !,$J("",(27-$L(GMTSH))),GMTSH
116 W ?27,GMTSE,GMTSN
117 Q
118SB(GMTSB,GMTSD) ; Signature Block
119 K ^UTILITY($J,"W") N X,DIWT,DIWL,DIWR,DIWF,GMTSI
120 S (X,GMTSB)=$G(GMTSB),GMTSD=$G(GMTSD) Q:'$L((GMTSB_GMTSD))
121 S GMTSI=1,DIWL=0,DIWF="C35" D ^DIWP S GMTSB=$$TRIM($G(^UTILITY($J,"W",0,1,0))) K:'$L(GMTSB) ^UTILITY($J,"W")
122 I $L(GMTSD),'$L(GMTSB) K ^UTILITY($J,"W") D CKP^GMTSUP Q:$D(GMTSQIT) W !,?27,GMTSD Q
123 Q:'$L(GMTSB) D CKP^GMTSUP K:$D(GMTSQIT) ^UTILITY($J,"W") Q:$D(GMTSQIT) W !,?27,GMTSB," ",GMTSD
124 F S GMTSI=$O(^UTILITY($J,"W",0,GMTSI)) Q:+GMTSI=0 D Q:$D(GMTSQIT)
125 . S GMTSB=$$TRIM($G(^UTILITY($J,"W",0,GMTSI,0))) Q:'$L(GMTSB)
126 . D CKP^GMTSUP K:$D(GMTSQIT) ^UTILITY($J,"W") Q:$D(GMTSQIT) W !,?27,GMTSB," "
127 K ^UTILITY($J,"W")
128 Q
129PG(GMTSA,GMTSD) ; Pagers
130 N GMTS S GMTS=0,GMTSA=$G(GMTSA),GMTSD=$G(GMTSD) Q:'$L((GMTSA_GMTSD)) Q:(+GMTSA+GMTSD)'>0
131 D CKP^GMTSUP Q:$D(GMTSQIT) W ! I $L(GMTSA),+GMTSA>0 D Q:$D(GMTSQIT)
132 . D CKP^GMTSUP Q:$D(GMTSQIT) W !?34,"Analog Pager: ",GMTSA S GMTS=1
133 I $L(GMTSD),+GMTSD>0 D Q:$D(GMTSQIT)
134 . D CKP^GMTSUP Q:$D(GMTSQIT) W !?33,"Digital Pager: ",GMTSD S GMTS=1
135 Q
136BL ; Blank Line
137 D CKP^GMTSUP Q:$D(GMTSQIT) W ! Q
138TRIM(X) ; Trim Spaces from String
139 S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
140 F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
141 Q X
Note: See TracBrowser for help on using the repository browser.