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

SCMCTMM.m

Go to the documentation of this file. 
  1. SCMCTMM ;ALB/REW - Patient Team Changes MailMessages ; 26 Mar 1996
  1.  ;;5.3;Scheduling;**41,45,87,100,130,177**;AUG 13, 1993
  1.  ;1
  1. MAIL ;Do Patient Team Changes MailMan Message
  1.  ; - called by SCMC PT TEAM CHANGES MAIL MESSAGE protocol
  1.  G:$G(SCNOMAIL) END  ;- flag can be set to stop message generation
  1.  N XMDUZ,XMY,XMSUB,XMTEXT,VA,VAERR,XMZ,Y,SCX,ZTQUEUED
  1.  N SCTMAR,SCSTAT,DFN,SCNODE,SCY,SCSPACE,SCPAD,SCPHONE,SCB,SCE,SCB2,SCE2,SCTMDT,SCTMXM,SCPTNM,SCLNCNT
  1.  S ZTQUEUED=1
  1.  S $P(SCSPACE," ",80)=""
  1.  ;   SCTMAR - ARRAY OF TEAMS (before & after)
  1.  S:SCTMB4 SCTMAR(SCTMB4)=""
  1.  S:SCTMAF SCTMAR(SCTMAF)=""
  1.  IF 'SCTMAF D
  1.  .S SCSTAT="DELETED",SCB=$P(SCTMB4,U,2),SCE=$S($P(SCPTTMB4,U,9):$P(SCPTTMB4,U,9),1:DT)
  1.  IF 'SCTMB4 D
  1.  .S SCSTAT="NEW",SCB=$P(SCTMAF,U,2),SCE=$S($P(SCPTTMAF,U,9):$P(SCPTTMAF,U,9),1:DT)
  1.  IF SCTMB4&SCTMAF D
  1.  .S SCSTAT="CHANGED"
  1.  .S SCB=$P(SCTMB4,U,2),SCE=$S($P(SCPTTMB4,U,9):$P(SCPTTMB4,U,9),1:DT)
  1.  .S SCB2=$P(SCTMAF,U,2),SCE2=$S($P(SCPTTMAF,U,9):$P(SCPTTMAF,U,9),1:DT)
  1.  .S SCTMDT("BEGIN")=$S(SCB<SCB2:SCB,1:SCB2)
  1.  .S SCTMDT("END")=$S(SCE>SCE2:SCE,1:SCE2)
  1.  .S SCTMDT("INCL")=0
  1.  IF SCSTAT="NEW"!(SCSTAT="DELETED") D
  1.  .S SCTMDT("BEGIN")=SCB
  1.  .S SCTMDT("END")=SCE
  1.  .S SCTMDT("INCL")=0
  1.  S DFN=$S(SCSTAT="DELETED":+SCPTTMB4,1:+SCPTTMAF)
  1.  ;set xmy array for practitioners in positions receiving tmchg notices
  1.  G:'$$PCMMXMY^SCAPMC25(3,DFN,"SCTMAR","SCTMDT",0) END
  1.  D:'$G(DGQUIET) EN^DDIOL("Sending "_SCSTAT_" Patient-Team Assignment Message")
  1.  D PID^VADPT6
  1.  S SCPTNM=$P(^DPT(DFN,0),U,1)
  1.  S XMSUB=SCSTAT_" PATIENT-TEAM ASSIGNMENT for Patient ("_$E(SCPTNM,1)_$G(VA("BID"))_")",XMTEXT="^TMP($J,""SCTMXM"",",SCLNCNT=0
  1.  IF SCSTAT="NEW" D
  1.  .D SETLN("Current Patient Team Data:")
  1.  .D SETLN("==========================")
  1.  .F SCX=1:1:14 D
  1.  ..D SETLN($$TEXT(404.42,SCPTTMAF,SCX,SCSPACE,1))
  1.  IF SCSTAT="DELETED" D
  1.  .D SETLN("Previous Patient Team Data:")
  1.  .D SETLN("===========================")
  1.  .F SCX=1:1:14 S SCFLD=SCX*.01 D
  1.  ..D SETLN($$TEXT(404.42,SCPTTMB4,SCX,SCSPACE,1))
  1.  IF SCSTAT="CHANGED" D
  1.  .D SETLN("Fields: "_$E(SCSPACE,1,15)_"Previous Data:             Current Patient Data:")
  1.  .D SETLN("=======================================================================")
  1.  .F SCX=1:1:14 S SCFLD=SCX*.01 D
  1.  ..N SCLAB2,SCY,SCZ
  1.  ..S SCY=$$TEXT(404.42,SCPTTMB4,SCX,SCSPACE,1)
  1.  ..S:'$L(SCY) SCLAB2=2
  1.  ..S SCZ=$$TEXT(404.42,SCPTTMAF,SCX,SCSPACE,+$G(SCLAB2))
  1.  ..D:$L(SCY)!($L(SCZ)) SETLN(SCY_$E(SCSPACE,1,(50-$L(SCY)))_SCZ)
  1.  S SCLNCNT=$$PCMAIL^SCMCMM(DFN,"^TMP($J,""SCTMXM"")",DT)
  1.  S XMDUZ=$G(DUZ,.5)
  1.  S XMY(XMDUZ)=""
  1.  D ^XMD
  1. END K ^TMP($J,"SCTMXM")
  1.  Q
  1.  ;
  1. SETLN(TEXT) ;
  1.  Q:$G(TEXT)=""
  1.  ; increments SCLNCNT, adds text to sctmxm(sclncnt)
  1.  S SCLNCNT=SCLNCNT+1
  1.  S ^TMP($J,"SCTMXM",SCLNCNT)=TEXT
  1.  Q
  1.  ;
  1. TEXT(SCFILE,SCNODE,SCPC,SCSPACE,SCLAB) ;returns fldname & external value
  1.  ;returns fldname & external value
  1.  ;   Note- Only works for non wp fields of standard numbering conventions
  1.  ;   SCFLILE =FILENUM
  1.  ;   SCNODE  = 0 NODE
  1.  ;   SCPC    = piece of node
  1.  ;   SCSPACE = 80 SPACES
  1.  ;   SCLAB = 1 if print field name
  1.  N SCX,SCINT,SCFLD
  1.  S SCX=""
  1.  S SCINT=$P(SCNODE,U,SCPC)
  1.  G:SCINT="" QTTXT
  1.  S SCFLD=SCPC*.01
  1.  ;;;
  1.  IF $G(SCLAB) D
  1.  .S SCX=$$DDNAME(SCFILE,SCFLD)_":"
  1.  .S:$G(SCLAB)=1 SCX=SCX_$E(SCSPACE,1,(23-$L(SCX)))
  1.  .S:$G(SCLAB)=2 SCX=SCX_$E(SCSPACE,1,(50-$L(SCX)))
  1.  S:SCINT]"" SCX=SCX_$$EXTERNAL^DILFD(SCFILE,SCFLD,"",SCINT)
  1.  ;adding SSN to the end of name for alpha 177
  1.  I $P(SCX,":",1)="PATIENT" S SCX=SCX_"  ("_$G(VA("PID"))_")"
  1. QTTXT Q SCX
  1.  ;
  1. DDNAME(FILE,FIELD) ;return the fieldname
  1.  N SCX
  1.  D FIELD^DID(FILE,FIELD,"","LABEL","SCX")
  1.  Q $G(SCX("LABEL"))
  1.  ;
  1. MAILLST(SCTM,SCFIELDA,SCDATE,SCNEWTM,SCOLDTM,SCBADTM) ;
  1.  ; Input:
  1.  ;    SCTM     - Pointer to Team File (#404.51)
  1.  ;    SCFIELDA - Field array with internal values
  1.  ;    SCDATE   - Effective Date
  1.  ;    SCNEWTM  - DFN array of newly assigned to team
  1.  ;    SCOLDTM  - DFN array of previously assigned to team
  1.  ;    SCBADTM  - DFN array of patients unassignable to team
  1.  ;
  1.  G:$G(SCNOMAIL) QTMULT  ;- flag can be set to stop message generation
  1.  G:'$D(SCNEWTM) QTMULT
  1.  G:'$O(@SCNEWTM@(0)) QTMULT  ;if no new assignments
  1.  N XMDUZ,XMY,XMSUB,XMTEXT,VA,VAERR,XMZ,Y,ZTQUEUED
  1.  N SCTMNM,DFN,SCOK,SCPTNM,SCFLD,SCNODE,SCNDX,SCSPACE,SCE,SCB,SCTMDT,SCDELTEM
  1.  S ZTQUEUED=1
  1.  S SCDELTEM=1 ;ok to delete tmp global
  1.  IF $D(SCFIELDA) D
  1.  .IF $D(SCFIELDA(.02)) S SCB=SCFIELDA(.02)
  1.  .IF $D(SCFIELDA(.09)) S SCE=SCFIELDA(.09)
  1.  S SCB=$G(SCB,DT)
  1.  S SCE=$G(SCE,DT)
  1.  S $P(SCSPACE," ",80)=""
  1.  S SCTMDT("BEGIN")=$S(SCB<SCDATE:SCB,1:SCDATE)
  1.  S SCTMDT("END")=$S(SCE>SCDATE:SCE,1:SCDATE)
  1.  S SCTMDT("INCL")=0
  1.  S SCTMNM=$P($G(^SCTM(404.51,+SCTM,0)),U,1)
  1.  S XMSUB="Multiple PATIENT-TEAM ASSIGNMENT for "_SCTMNM,XMTEXT="^TMP($J,""SCTMXM"",",SCLNCNT=0
  1.  D:'$G(DGQUIET) EN^DDIOL("Sending Multiple Patient-Team Assignment Message")
  1.  S SCOK=1
  1.  S SCTMNM=$P($G(^SCTM(404.51,+SCTM,0)),U,1)
  1.  D SETLN("Team:                  "_SCTMNM)
  1.  S Y=SCDATE X ^DD("DD")
  1.  D SETLN("Effective Date:        "_Y)
  1.  D SETLN(" ")
  1.  IF $D(SCFIELDA) D
  1.  .F SCNDX=1:1:14 S SCFLD=SCNDX*.01 IF $D(SCFIELDA(SCFLD)) D
  1.  ..S $P(SCNODE,U,SCNDX)=SCFIELDA(SCFLD)
  1.  ..D SETLN($$TEXT(404.42,SCNODE,SCNDX,SCSPACE,1))
  1.  D SETLN(" ")
  1.  D SETLN("There has been a new team assignment for the following patients:")
  1.  S DFN=0
  1.  F  S DFN=$O(@SCNEWTM@(DFN)) Q:'DFN  D
  1.  .S:$$PCMMXMY^SCAPMC25(3,DFN,,"SCTMDT",0) SCOK=0
  1.  .D PID^VADPT6
  1.  .S SCPTNM=$P(^DPT(DFN,0),U,1)
  1.  .S ^TMP("SCTM MAIL LST",$J,SCTM,1,DFN)=("    "_SCPTNM_" ("_$G(VA("PID"))_")")
  1.  .S ^TMP("SCTM MAIL LST",$J,SCTM,1,"B",SCPTNM,DFN)=""
  1.  S SCPTNM=""
  1.  F  S SCPTNM=$O(^TMP("SCTM MAIL LST",$J,SCTM,1,"B",SCPTNM)) Q:SCPTNM']""  D
  1.  .S DFN=0
  1.  .F  S DFN=$O(^TMP("SCTM MAIL LST",$J,SCTM,1,"B",SCPTNM,DFN)) Q:'DFN  D
  1.  ..S SCDETAIL=$G(^TMP("SCTM MAIL LST",$J,SCTM,1,DFN)) Q:SCDETAIL']""  D SETLN(SCDETAIL)
  1. BAD IF $S('$D(SCBADTM):0,1:$O(@SCBADTM@(0))) D
  1.  .D SETLN(" ")
  1.  .D SETLN("There has been NO new team assignment for the following patients:")
  1.  .S DFN=0
  1.  .F  S DFN=$O(@SCBADTM@(DFN)) Q:'DFN  D
  1.  ..S:$$PCMMXMY^SCAPMC25(3,DFN,,"SCTMDT",0) SCOK=0
  1.  ..S SCPTNM=$P(^DPT(DFN,0),U,1)
  1.  ..D PID^VADPT6
  1.  ..S ^TMP("SCTM MAIL LST",$J,SCTM,2,DFN)=("    "_SCPTNM_" ("_$G(VA("PID"))_")")
  1.  ..S ^TMP("SCTM MAIL LST",$J,SCTM,2,"B",SCPTNM,DFN)=""
  1.  .S SCPTNM=""
  1.  .F  S SCPTNM=$O(^TMP("SCTM MAIL LST",$J,SCTM,2,"B",SCPTNM)) Q:SCPTNM']""  D
  1.  ..S DFN=0
  1.  ..F  S DFN=$O(^TMP("SCTM MAIL LST",$J,SCTM,2,"B",SCPTNM,DFN)) Q:'DFN  D
  1.  ...S SCDETAIL=$G(^TMP("SCTM MAIL LST",$J,SCTM,2,DFN)) Q:SCDETAIL']""  D SETLN(SCDETAIL)
  1.  S XMDUZ=$G(DUZ,.5)
  1.  D ^XMD
  1. QTMULT K:$G(SCDELTEM) ^TMP("SCTM MAIL LST",$J,SCTM)
  1.  K ^TMP($J,"SCTMXM")
  1.  Q