SCMCCON ;ALB/REW - Patient Consult MailMessages ; 26 Mar 1996
;;5.3;Scheduling;**41,87,100,130**;AUG 13, 1993
;1
MAIL(DFN,SCCLNM,ENORAP,DATE,SCTMCNA) ;Do Patient Team Changes MailMan Message
; DFN - ien to PATIENT File
; SCCLNM - Name of Clinic
; ENORAP - Enrollment or Appointment? 1=Enrollment, 2=Appointment
; DATE - Date of interest, Default =DT
; SCTMCNA- Array of teams affected
;
; - called by SCMC PT TEAM CHANGES MAIL MESSAGE protocol
G:$G(SCNOMAIL) END ;- flag can be set to stop message generation
N XMDUZ,XMY,XMSUB,XMTEXT,VA,VAERR,XMZ,Y,SCCNXM
N SCTMAR,SCSTAT,SCNODE,SCY,SCSPACE,SCCNDTS,SCSTAT,SCTM
S SCCNDTS("BEGIN")=DATE,SCCNDTS("END")=DATE
S SCSTAT=$S(ENORAP=1:"Enrollment",(ENORAP=2):"Appointment",1:"")
S $P(SCSPACE," ",80)=""
; SCTMAR - ARRAY OF TEAMS (before & after)
;set xmy array for practitioners in positions receiving consult notices
G:'$$PCMMXMY^SCAPMC25(4,DFN,SCTMCNA,"SCCMDTS",0) END
D:'$G(DGQUIET) EN^DDIOL("Sending Patient-Consult "_SCSTAT_" Message")
D PID^VADPT6
S SCPTNM=$P(^DPT(DFN,0),U,1)
S XMSUB=SCSTAT_" PATIENT-CLINIC "_SCSTAT_" for Patient ("_$E(SCPTNM,1)_VA("BID")_")",XMTEXT="SCCNXM(",SCLNCNT=0
D SETLN("This notice is sent because:")
D SETLN(" The patient had an "_SCSTAT_" to "_$G(SCCLNM)_" and")
D SETLN(" has restricted consults due to the following team assignment(s):")
S SCTM=0
F S SCTM=$O(@SCTMCNA@(SCTM)) Q:'SCTM D
.D SETLN(" "_@SCTMCNA@(SCTM))
S SCLNCNT=$$PCMAIL^SCMCMM(DFN,"SCCNXM",DT)
S XMDUZ=$G(DUZ,.5)
S XMY(XMDUZ)=""
D ^XMD
END ;
Q
;
SETLN(TEXT) ;
Q:$G(TEXT)=""
; increments SCLNCNT, adds text to sccnxm(sclncnt)
S SCLNCNT=SCLNCNT+1
S SCCNXM(SCLNCNT)=TEXT
Q
;
TEXT(SCFILE,SCNODE,SCPC,SCSPACE,SCLAB) ;returns fldname & external value
;returns fldname & external value
; Note- Only works for non wp fields of standard numbering conventions
; SCFLILE =FILENUM
; SCNODE = 0 NODE
; SCPC = piece of node
; SCSPACE = 80 SPACES
; SCLAB = 1 if print field name
N SCX,SCINT,SCFLD
S SCX=""
S SCINT=$P(SCNODE,U,SCPC)
G:SCINT="" QTTXT
S SCFLD=SCPC*.01
;;;
IF $G(SCLAB) D
.S SCX=$$DDNAME^SCMCTMM(SCFLD)_":"
.S:$G(SCLAB)=1 SCX=SCX_$E(SCSPACE,1,(23-$L(SCX)))
.S:$G(SCLAB)=2 SCX=SCX_$E(SCSPACE,1,(50-$L(SCX)))
S:SCINT]"" SCX=SCX_$$EXTERNAL^DILFD(SCFILE,SCFLD,"",SCINT)
QTTXT Q SCX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCCON 2388 printed Apr 09, 2024@21:52:34 Page 2
SCMCCON ;ALB/REW - Patient Consult MailMessages ; 26 Mar 1996
+1 ;;5.3;Scheduling;**41,87,100,130**;AUG 13, 1993
+2 ;1
MAIL(DFN,SCCLNM,ENORAP,DATE,SCTMCNA) ;Do Patient Team Changes MailMan Message
+1 ; DFN - ien to PATIENT File
+2 ; SCCLNM - Name of Clinic
+3 ; ENORAP - Enrollment or Appointment? 1=Enrollment, 2=Appointment
+4 ; DATE - Date of interest, Default =DT
+5 ; SCTMCNA- Array of teams affected
+6 ;
+7 ; - called by SCMC PT TEAM CHANGES MAIL MESSAGE protocol
+8 ;- flag can be set to stop message generation
if $GET(SCNOMAIL)
GOTO END
+9 NEW XMDUZ,XMY,XMSUB,XMTEXT,VA,VAERR,XMZ,Y,SCCNXM
+10 NEW SCTMAR,SCSTAT,SCNODE,SCY,SCSPACE,SCCNDTS,SCSTAT,SCTM
+11 SET SCCNDTS("BEGIN")=DATE
SET SCCNDTS("END")=DATE
+12 SET SCSTAT=$SELECT(ENORAP=1:"Enrollment",(ENORAP=2):"Appointment",1:"")
+13 SET $PIECE(SCSPACE," ",80)=""
+14 ; SCTMAR - ARRAY OF TEAMS (before & after)
+15 ;set xmy array for practitioners in positions receiving consult notices
+16 if '$$PCMMXMY^SCAPMC25(4,DFN,SCTMCNA,"SCCMDTS",0)
GOTO END
+17 if '$GET(DGQUIET)
DO EN^DDIOL("Sending Patient-Consult "_SCSTAT_" Message")
+18 DO PID^VADPT6
+19 SET SCPTNM=$PIECE(^DPT(DFN,0),U,1)
+20 SET XMSUB=SCSTAT_" PATIENT-CLINIC "_SCSTAT_" for Patient ("_$EXTRACT(SCPTNM,1)_VA("BID")_")"
SET XMTEXT="SCCNXM("
SET SCLNCNT=0
+21 DO SETLN("This notice is sent because:")
+22 DO SETLN(" The patient had an "_SCSTAT_" to "_$GET(SCCLNM)_" and")
+23 DO SETLN(" has restricted consults due to the following team assignment(s):")
+24 SET SCTM=0
+25 FOR
SET SCTM=$ORDER(@SCTMCNA@(SCTM))
if 'SCTM
QUIT
Begin DoDot:1
+26 DO SETLN(" "_@SCTMCNA@(SCTM))
End DoDot:1
+27 SET SCLNCNT=$$PCMAIL^SCMCMM(DFN,"SCCNXM",DT)
+28 SET XMDUZ=$GET(DUZ,.5)
+29 SET XMY(XMDUZ)=""
+30 DO ^XMD
END ;
+1 QUIT
+2 ;
SETLN(TEXT) ;
+1 if $GET(TEXT)=""
QUIT
+2 ; increments SCLNCNT, adds text to sccnxm(sclncnt)
+3 SET SCLNCNT=SCLNCNT+1
+4 SET SCCNXM(SCLNCNT)=TEXT
+5 QUIT
+6 ;
TEXT(SCFILE,SCNODE,SCPC,SCSPACE,SCLAB) ;returns fldname & external value
+1 ;returns fldname & external value
+2 ; Note- Only works for non wp fields of standard numbering conventions
+3 ; SCFLILE =FILENUM
+4 ; SCNODE = 0 NODE
+5 ; SCPC = piece of node
+6 ; SCSPACE = 80 SPACES
+7 ; SCLAB = 1 if print field name
+8 NEW SCX,SCINT,SCFLD
+9 SET SCX=""
+10 SET SCINT=$PIECE(SCNODE,U,SCPC)
+11 if SCINT=""
GOTO QTTXT
+12 SET SCFLD=SCPC*.01
+13 ;;;
+14 IF $GET(SCLAB)
Begin DoDot:1
+15 SET SCX=$$DDNAME^SCMCTMM(SCFLD)_":"
+16 if $GET(SCLAB)=1
SET SCX=SCX_$EXTRACT(SCSPACE,1,(23-$LENGTH(SCX)))
+17 if $GET(SCLAB)=2
SET SCX=SCX_$EXTRACT(SCSPACE,1,(50-$LENGTH(SCX)))
End DoDot:1
+18 if SCINT]""
SET SCX=SCX_$$EXTERNAL^DILFD(SCFILE,SCFLD,"",SCINT)
QTTXT QUIT SCX
