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

GMTSPN2.m

Go to the documentation of this file. 
  1. GMTSPN2 ; SLC/KER - Progress Note Signatures           ; 8/1/06 4:24pm
  1.  ;;2.7;Health Summary;**45,47,49,82**;Oct 20, 1995;Build 21
  1.  Q
  1.  ;                          
  1.  ; External References
  1.  ;   DBIA 10011  ^DIWP
  1.  ;   DBIA  2056  $$GET1^DIQ
  1.  ;   DBIA 10060  ^VA(200, .137
  1.  ;   DBIA 10060  ^VA(200, .138
  1.  ;                     
  1. WS(X,I) ; Write Signatures 
  1.  Q:$D(GMTSQIT)  N GMTSDIC,GMTSIEN,GMTSA,GMTSG S GMTSDIC=$G(X),GMTSIEN=$G(I)
  1.  Q:'$L(GMTSIEN)  Q:$E($P(GMTSDIC,$J,1),1,11)'="^TMP(""TIU"","  Q:'$D(@($P(GMTSDIC,",",1,($L(GMTSDIC,",")-1))_")"))
  1.  Q:'$D(@(GMTSDIC_GMTSIEN_")"))  S GMTSDIC=GMTSDIC_GMTSIEN_","
  1.  D UNS,SOC,SIG,UNC,COC,COS,EXT
  1.  Q
  1. UNS ;   Unsigned/Draft Copy
  1.  Q:$D(GMTSQIT)  N GMTST S GMTST=$G(@(GMTSDIC_"1501,""I"")")) D:GMTST="" UNSIG
  1.  Q
  1. SOC ;   Signed on Chart
  1.  Q:$D(GMTSQIT)  N GMTSP,GMTSB S GMTSP=$G(PN("SCHART"))
  1.  S GMTSB=$G(PN("SCHARTBY")) Q:'$L(GMTSP)  Q:'$L(GMTSB)
  1.  D BL Q:$D(GMTSQIT)  D BY(GMTSP,"",GMTSB) Q:$D(GMTSQIT)
  1.  Q
  1. SIG ;   Signature Block, Name, Title and Date
  1.  Q:$D(GMTSQIT)  N GMTSA,GMTSG,GMTSE,GMTST,GMTSD,GMTSP,GMTSB
  1.  S GMTSP="Signed by:",GMTSE=$G(@(GMTSDIC_"1505,""I"")"))
  1.  S GMTSB=$G(PN("SIGBLK")) Q:'$L(GMTSB)  S GMTST=$G(PN("STITLE"))
  1.  S GMTSD=$G(PN("SIGDT")),GMTSA=$$GET1^DIQ(200,+($G(SIGNEDBY)),.137)
  1.  S GMTSG=$$GET1^DIQ(200,+($G(SIGNEDBY)),.138) D BL Q:$D(GMTSQIT)
  1.  D BY(GMTSP,GMTSE,GMTSB) Q:$D(GMTSQIT)  D SB(GMTST,GMTSD) Q:$D(GMTSQIT)
  1.  D PG(GMTSA,GMTSG) Q:$D(GMTSQIT)
  1.  Q
  1. UNC ;   Uncosigned - Requires Cosignature
  1.  Q:$D(GMTSQIT)  N GMTSP,GMTSB
  1.  S GMTSP=$G(@(GMTSDIC_".05,""E"")")) Q:GMTSP'="UNCOSIGNED"
  1.  Q:$E($G(GMTSTIUC),1)["D"&('CONEED)  D BL Q:$D(GMTSQIT)
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W !?27,"** REQUIRES COSIGNATURE **"
  1.  Q
  1. COC ;   Cosigned on Chart
  1.  Q:$D(GMTSQIT)  N GMTSP,GMTSB
  1.  S GMTSP=$G(PN("COCHART")),GMTSB=$G(PN("COCHARTBY")) Q:'$L(GMTSP)  Q:'$L(GMTSB)
  1.  Q:$E($G(GMTSTIUC),1)["D"&('CONEED)  D BL Q:$D(GMTSQIT)  D BY(GMTSP,"",GMTSB)
  1.  Q
  1. COS ;   Co-Signature Block, Name, Title and Date
  1.  Q:$D(GMTSQIT)  N GMTSA,GMTSG,GMTSE,GMTST,GMTSD,GMTSP,GMTSB
  1.  S GMTSP="Cosigned by:",GMTSE=$G(@(GMTSDIC_"1511,""I"")")),GMTSB=$G(PN("COBLK")) Q:'$L(GMTSB)
  1.  S GMTST=$G(PN("COTITLE")),GMTSD=$G(PN("COSDT"))
  1.  S GMTSA=$$GET1^DIQ(200,+($G(COSGEDBY)),.137),GMTSG=$$GET1^DIQ(200,+($G(COSGEDBY)),.138)
  1.  Q:$E($G(GMTSTIUC),1)["D"&('CONEED)  D BL Q:$D(GMTSQIT)
  1.  D BY(GMTSP,GMTSE,GMTSB) Q:$D(GMTSQIT)  D SB(GMTST,GMTSD) Q:$D(GMTSQIT)
  1.  D PG(GMTSA,GMTSG)
  1.  Q
  1. EXT ;   Extra Signatures
  1.  ;     Receipt Acknowledged by:
  1.  Q:$D(GMTSQIT)  I +$O(@(GMTSDIC_"""EXTRASGNR"",0)")) D  Q:$D(GMTSQIT)
  1.  . D BL Q:$D(GMTSQIT)  D BY("Receipt Acknowledged by:","","")
  1.  ;     Extra Signature Block, Name, Title and Date
  1.  N GMTSXTRA S GMTSXTRA=0
  1.  F  S GMTSXTRA=+$O(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_")")) Q:+GMTSXTRA'>0  D  Q:$D(GMTSQIT)
  1.  . N GMTSA,GMTSG,GMTSE,GMTST,GMTSD,GMTSP,GMTSB,GMTSI,GMTSC
  1.  . S GMTSC=+($G(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_",""DATE"")")))
  1.  . I GMTSC'>0 W ?27,"* AWAITING SIGNATURE *" D BL Q
  1.  . S GMTSP="",GMTSE="/es/",GMTSB=$G(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_",""NAME"")")) Q:'$L(GMTSB)
  1.  . S GMTST=$G(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_",""TITLE"")"))
  1.  . S GMTSD=$$EDT^GMTSU(GMTSC),GMTSI=+($G(@(GMTSDIC_"""EXTRASGNR"","_GMTSXTRA_",""EXTRA"")")))
  1.  . S GMTSA=$$GET1^DIQ(200,+($G(GMTSI)),.137),GMTSG=$$GET1^DIQ(200,+($G(GMTSI)),.138)
  1.  . I +($G(GMTSXTRA))>1 D BL Q:$D(GMTSQIT)  D BL Q:$D(GMTSQIT)
  1.  . D BY(GMTSP,GMTSE,GMTSB) Q:$D(GMTSQIT)
  1.  . D SB(GMTST,GMTSD) Q:$D(GMTSQIT)  D PG(GMTSA,GMTSG) Q:$D(GMTSQIT)
  1.  Q
  1.  ;                      
  1. UNSIG ; Unsigned Note
  1.  N GMTS,GMTS1,GMTS2,GMTST,GMTSB S GMTST="<  THE ABOVE NOTE IS UNSIGNED  >",GMTS=""
  1.  S $P(GMTS," ",((79-$L(GMTST))\2)\2)=" ",$P(GMTS1," ",((79-$L(GMTST))\2)\2)=" "
  1.  S GMTS2=GMTS_GMTS1,GMTS1=GMTS1_GMTS,GMTSB=GMTS1_GMTST_GMTS2
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W ! D CKP^GMTSUP Q:$D(GMTSQIT)  W !,GMTSB
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W !,"- DRAFT COPY * DRAFT COPY * DRAFT COPY * DRAFT COPY * DRAFT COPY * DRAFT COPY -"
  1.  Q
  1.  ;                        
  1.  ; Warnings
  1. WARN1 ;   Beginning of Note
  1.  N GMTSD,GMTSW S GMTSW=1,GMTSD=0 D DEL1,RETR1 D:GMTSD BL Q
  1. WARN2 ;   End of Note
  1.  N GMTSD,GMTSW S GMTSW=2,GMTSD=0 D DEL2,RETR2 Q
  1. DEL1 ;     Deleted Note (begin)
  1.  Q:($G(STATUS)'="DELETED")&($G(PN("STATUS"))'="DELETED")
  1.  N GMTST,GMTST2 S GMTST="<  THE FOLLOWING ENTRY HAS BEEN DELETED >",GMTST2="<<<<< DELETED  *  DELETED  *  DELETED  *  DELETED  *  DELETED  *  DELETED >>>>>" D WARN3 Q
  1. DEL2 ;     Deleted Note (end)
  1.  Q:($G(STATUS)'="DELETED")&($G(PN("STATUS"))'="DELETED")
  1.  N GMTST,GMTST2 S GMTST="<  THE ABOVE ENTRY HAS BEEN DELETED >",GMTST2="<<<<< DELETED  *  DELETED  *  DELETED  *  DELETED  *  DELETED  *  DELETED >>>>>" D WARN3 Q
  1. RETR1 ;     Retracted Note (begin)
  1.  Q:($G(STATUS)'="RETRACTED")&($G(PN("STATUS"))'="RETRACTED")
  1.  N GMTST,GMTST2 S GMTST="<  THE FOLLOWING ENTRY HAS BEEN RETRACTED >",GMTST2="<<<<<< RETRACTED  *  RETRACTED  *  RETRACTED  *  RETRACTED  *  RETRACTED >>>>>>" D WARN3 Q
  1. RETR2 ;     Retracted Note (end)
  1.  Q:($G(STATUS)'="RETRACTED")&($G(PN("STATUS"))'="RETRACTED")
  1.  N GMTST,GMTST2 S GMTST="<  THE ABOVE ENTRY HAS BEEN RETRACTED >",GMTST2="<<<<<< RETRACTED  *  RETRACTED  *  RETRACTED  *  RETRACTED  *  RETRACTED >>>>>>" D WARN3 Q
  1. WARN3 ;   Warning Display (display)
  1.  N GMTS,GMTS1,GMTS2,GMTSB S GMTS="",GMTST=$G(GMTST),GMTST2=$G(GMTST2) Q:'$L(GMTST)  Q:'$L(GMTST2)
  1.  S $P(GMTS,"<",((79-$L(GMTST))\2)\2)="<"
  1.  S $P(GMTS1,"<",((79-$L(GMTST))\2)\2)="<",GMTS1=GMTS_GMTS1,GMTS=""
  1.  S $P(GMTS,">",((79-$L(GMTST))\2)\2)=">"
  1.  S $P(GMTS2,">",((79-$L(GMTST))\2)\2)=">",GMTS2=GMTS2_GMTS,GMTS=""
  1.  S GMTSB=GMTS1_GMTST_GMTS2 F  Q:$L(GMTSB)'<$L(GMTST2)  S GMTSB=GMTSB_">"
  1.  I +($G(GMTSW))=2 D BL Q:$D(GMTSQIT)
  1.  I +($G(GMTSW))=1 D CKP^GMTSUP Q:$D(GMTSQIT)  W !,GMTSB
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W !,GMTST2 S:$D(GMTSD) GMTSD=1
  1.  I +($G(GMTSW))=2 D CKP^GMTSUP Q:$D(GMTSQIT)  W !,GMTSB
  1.  Q
  1.  ;                   
  1.  ; Miscelaneous
  1. BY(GMTSH,GMTSE,GMTSN) ; Signed by
  1.  S GMTSH=$$TRIM($G(GMTSH)),GMTSE=$G(GMTSE),GMTSN=$G(GMTSN) Q:'$L((GMTSH_GMTSN))
  1.  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=""
  1.  I $L($$TRIM(GMTSH)) D CKP^GMTSUP Q:$D(GMTSQIT)  W !,$J("",(27-$L(GMTSH))),GMTSH
  1.  W ?27,GMTSE,GMTSN
  1.  Q
  1. SB(GMTSB,GMTSD) ; Signature Block
  1.  K ^UTILITY($J,"W") N X,DIWT,DIWL,DIWR,DIWF,GMTSI
  1.  S (X,GMTSB)=$G(GMTSB),GMTSD=$G(GMTSD) Q:'$L((GMTSB_GMTSD))
  1.  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")
  1.  I $L(GMTSD),'$L(GMTSB) K ^UTILITY($J,"W") D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?27,GMTSD Q
  1.  Q:'$L(GMTSB)  D CKP^GMTSUP K:$D(GMTSQIT) ^UTILITY($J,"W") Q:$D(GMTSQIT)  W !,?27,GMTSB,!,?27,GMTSD
  1.  K ^UTILITY($J,"W")
  1.  Q
  1. PG(GMTSA,GMTSD) ; Pagers
  1.  N GMTS S GMTS=0,GMTSA=$G(GMTSA),GMTSD=$G(GMTSD) Q:'$L((GMTSA_GMTSD))  Q:(+GMTSA+GMTSD)'>0
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W ! I $L(GMTSA),+GMTSA>0 D  Q:$D(GMTSQIT)
  1.  . D CKP^GMTSUP Q:$D(GMTSQIT)  W !?34,"Analog Pager:  ",GMTSA S GMTS=1
  1.  I $L(GMTSD),+GMTSD>0 D  Q:$D(GMTSQIT)
  1.  . D CKP^GMTSUP Q:$D(GMTSQIT)  W !?33,"Digital Pager:  ",GMTSD S GMTS=1
  1.  Q
  1. BL ;   Blank Line
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W ! Q
  1. TRIM(X) ;   Trim Spaces from String
  1.  S X=$G(X) F  Q:$E(X,1)'=" "  S X=$E(X,2,$L(X))
  1.  F  Q:$E(X,$L(X))'=" "  S X=$E(X,1,($L(X)-1))
  1.  Q X