SCMRTMM ;ALB/REW/PDR - Patient Team Multiple Reasssignment MailMessages ; 17 JUL 98
;;5.3;Scheduling;**148,157**;AUG 13, 1993
;
SETLN(TEXT) ;
Q:$G(TEXT)=""
; increments SCLNCNT, adds text to sctmxm(sclncnt)
S SCLNCNT=SCLNCNT+1
S ^TMP($J,"SCTMXM",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(SCFILE,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
;
DDNAME(FILE,FIELD) ;return the fieldname
N SCX
D FIELD^DID(FILE,FIELD,"","LABEL","SCX")
Q $G(SCX("LABEL"))
;
MAILLST(SCTM,SCFIELDA,SCDATE,SCBADTM) ; Reports only reassignment failures
; Input:
; SCTM - Pointer to Team File (#404.51)
; SCFIELDA - Field array with internal values
; SCDATE - Effective Date
; SCBADTM - DFN array of patients unassignable to team
;
G:$G(SCNOMAIL) QTMULT ;- flag can be set to stop message generation
G:'$S('$D(SCBADTM):0,1:$O(@SCBADTM@(0))) QTMULT ; bail out if nothing to print
N XMDUZ,XMY,XMSUB,XMTEXT,VA,VAERR,XMZ,Y,ZTQUEUED
N SCTMNM,DFN,SCOK,SCPTNM,SCFLD,SCNODE,SCNDX,SCSPACE,SCE,SCB,SCTMDT,SCDELTEM
S ZTQUEUED=1
S SCDELTEM=1 ;ok to delete tmp global
IF $D(SCFIELDA) D
. IF $D(SCFIELDA(.02)) S SCB=SCFIELDA(.02)
. IF $D(SCFIELDA(.09)) S SCE=SCFIELDA(.09)
S SCB=$G(SCB,DT)
S SCE=$G(SCE,DT)
S $P(SCSPACE," ",80)=""
S SCTMDT("BEGIN")=$S(SCB<SCDATE:SCB,1:SCDATE)
S SCTMDT("END")=$S(SCE>SCDATE:SCE,1:SCDATE)
S SCTMDT("INCL")=0
S SCTMNM=$P($G(^SCTM(404.51,+SCTM,0)),U,1)
S XMSUB="Multiple PATIENT-TEAM REASSIGNMENT FAILURES for "_SCTMNM,XMTEXT="^TMP($J,""SCTMXM"",",SCLNCNT=0
D:'$G(DGQUIET) EN^DDIOL("Sending Multiple Patient-Team Reassignment Failures Message")
S SCOK=1
S SCTMNM=$P($G(^SCTM(404.51,+SCTM,0)),U,1)
D SETLN("Team: "_SCTMNM)
S Y=SCDATE X ^DD("DD")
D SETLN("Effective Date: "_Y)
D SETLN(" ")
IF $D(SCFIELDA) D
. F SCNDX=1:1:14 S SCFLD=SCNDX*.01 IF $D(SCFIELDA(SCFLD)) D
.. S $P(SCNODE,U,SCNDX)=SCFIELDA(SCFLD)
.. D SETLN($$TEXT(404.42,SCNODE,SCNDX,SCSPACE,1))
D SETLN(" ")
BAD ; Guts of message
D SETLN(" ")
D SETLN("There has been NO new team reassignment for the following patients:")
S DFN=0
F S DFN=$O(@SCBADTM@(DFN)) Q:'DFN D
. ;;;S:$$PCMMXMY^SCAPMC25(3,DFN,,"SCTMDT",0) SCOK=0
. S SCPTNM=$P(^DPT(DFN,0),U,1)
. D PID^VADPT6
. S ^TMP("SCTM MAIL LST",$J,SCTM,2,DFN)=(" "_SCPTNM_" ("_$G(VA("PID"))_")")_":"
. S ^TMP("SCTM MAIL LST",$J,SCTM,3,DFN)=" "_@SCBADTM@(DFN)
. S ^TMP("SCTM MAIL LST",$J,SCTM,2,"B",SCPTNM,DFN)=""
S SCPTNM=""
F S SCPTNM=$O(^TMP("SCTM MAIL LST",$J,SCTM,2,"B",SCPTNM)) Q:SCPTNM']"" D
. S DFN=0
. F S DFN=$O(^TMP("SCTM MAIL LST",$J,SCTM,2,"B",SCPTNM,DFN)) Q:'DFN D
.. S SCDETAIL=$G(^TMP("SCTM MAIL LST",$J,SCTM,2,DFN)) Q:SCDETAIL']"" D SETLN(SCDETAIL)
.. S SCDETAIL=$G(^TMP("SCTM MAIL LST",$J,SCTM,3,DFN)) Q:SCDETAIL']"" D SETLN(SCDETAIL)
S XMDUZ="PCMM Reassignment"
K XMY S XMY(DUZ)=""
S SCX=$O(^SD(404.91,"B",0))_","
I +SCX S XMY("G."_$$GET1^DIQ(404.91,SCX,804))=""
D ^XMD
QTMULT ;
K:$G(SCDELTEM) ^TMP("SCTM MAIL LST",$J,SCTM)
K ^TMP($J,"SCTMXM")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMRTMM 3644 printed Apr 09, 2024@21:54:48 Page 2
SCMRTMM ;ALB/REW/PDR - Patient Team Multiple Reasssignment MailMessages ; 17 JUL 98
+1 ;;5.3;Scheduling;**148,157**;AUG 13, 1993
+2 ;
SETLN(TEXT) ;
+1 if $GET(TEXT)=""
QUIT
+2 ; increments SCLNCNT, adds text to sctmxm(sclncnt)
+3 SET SCLNCNT=SCLNCNT+1
+4 SET ^TMP($JOB,"SCTMXM",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(SCFILE,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
+1 ;
DDNAME(FILE,FIELD) ;return the fieldname
+1 NEW SCX
+2 DO FIELD^DID(FILE,FIELD,"","LABEL","SCX")
+3 QUIT $GET(SCX("LABEL"))
+4 ;
MAILLST(SCTM,SCFIELDA,SCDATE,SCBADTM) ; Reports only reassignment failures
+1 ; Input:
+2 ; SCTM - Pointer to Team File (#404.51)
+3 ; SCFIELDA - Field array with internal values
+4 ; SCDATE - Effective Date
+5 ; SCBADTM - DFN array of patients unassignable to team
+6 ;
+7 ;- flag can be set to stop message generation
if $GET(SCNOMAIL)
GOTO QTMULT
+8 ; bail out if nothing to print
if '$SELECT('$DATA(SCBADTM)
GOTO QTMULT
+9 NEW XMDUZ,XMY,XMSUB,XMTEXT,VA,VAERR,XMZ,Y,ZTQUEUED
+10 NEW SCTMNM,DFN,SCOK,SCPTNM,SCFLD,SCNODE,SCNDX,SCSPACE,SCE,SCB,SCTMDT,SCDELTEM
+11 SET ZTQUEUED=1
+12 ;ok to delete tmp global
SET SCDELTEM=1
+13 IF $DATA(SCFIELDA)
Begin DoDot:1
+14 IF $DATA(SCFIELDA(.02))
SET SCB=SCFIELDA(.02)
+15 IF $DATA(SCFIELDA(.09))
SET SCE=SCFIELDA(.09)
End DoDot:1
+16 SET SCB=$GET(SCB,DT)
+17 SET SCE=$GET(SCE,DT)
+18 SET $PIECE(SCSPACE," ",80)=""
+19 SET SCTMDT("BEGIN")=$SELECT(SCB<SCDATE:SCB,1:SCDATE)
+20 SET SCTMDT("END")=$SELECT(SCE>SCDATE:SCE,1:SCDATE)
+21 SET SCTMDT("INCL")=0
+22 SET SCTMNM=$PIECE($GET(^SCTM(404.51,+SCTM,0)),U,1)
+23 SET XMSUB="Multiple PATIENT-TEAM REASSIGNMENT FAILURES for "_SCTMNM
SET XMTEXT="^TMP($J,""SCTMXM"","
SET SCLNCNT=0
+24 if '$GET(DGQUIET)
DO EN^DDIOL("Sending Multiple Patient-Team Reassignment Failures Message")
+25 SET SCOK=1
+26 SET SCTMNM=$PIECE($GET(^SCTM(404.51,+SCTM,0)),U,1)
+27 DO SETLN("Team: "_SCTMNM)
+28 SET Y=SCDATE
XECUTE ^DD("DD")
+29 DO SETLN("Effective Date: "_Y)
+30 DO SETLN(" ")
+31 IF $DATA(SCFIELDA)
Begin DoDot:1
+32 FOR SCNDX=1:1:14
SET SCFLD=SCNDX*.01
IF $DATA(SCFIELDA(SCFLD))
Begin DoDot:2
+33 SET $PIECE(SCNODE,U,SCNDX)=SCFIELDA(SCFLD)
+34 DO SETLN($$TEXT(404.42,SCNODE,SCNDX,SCSPACE,1))
End DoDot:2
End DoDot:1
+35 DO SETLN(" ")
BAD ; Guts of message
+1 DO SETLN(" ")
+2 DO SETLN("There has been NO new team reassignment for the following patients:")
+3 SET DFN=0
+4 FOR
SET DFN=$ORDER(@SCBADTM@(DFN))
if 'DFN
QUIT
Begin DoDot:1
+5 ;;;S:$$PCMMXMY^SCAPMC25(3,DFN,,"SCTMDT",0) SCOK=0
+6 SET SCPTNM=$PIECE(^DPT(DFN,0),U,1)
+7 DO PID^VADPT6
+8 SET ^TMP("SCTM MAIL LST",$JOB,SCTM,2,DFN)=(" "_SCPTNM_" ("_$GET(VA("PID"))_")")_":"
+9 SET ^TMP("SCTM MAIL LST",$JOB,SCTM,3,DFN)=" "_@SCBADTM@(DFN)
+10 SET ^TMP("SCTM MAIL LST",$JOB,SCTM,2,"B",SCPTNM,DFN)=""
End DoDot:1
+11 SET SCPTNM=""
+12 FOR
SET SCPTNM=$ORDER(^TMP("SCTM MAIL LST",$JOB,SCTM,2,"B",SCPTNM))
if SCPTNM']""
QUIT
Begin DoDot:1
+13 SET DFN=0
+14 FOR
SET DFN=$ORDER(^TMP("SCTM MAIL LST",$JOB,SCTM,2,"B",SCPTNM,DFN))
if 'DFN
QUIT
Begin DoDot:2
+15 SET SCDETAIL=$GET(^TMP("SCTM MAIL LST",$JOB,SCTM,2,DFN))
if SCDETAIL']""
QUIT
DO SETLN(SCDETAIL)
+16 SET SCDETAIL=$GET(^TMP("SCTM MAIL LST",$JOB,SCTM,3,DFN))
if SCDETAIL']""
QUIT
DO SETLN(SCDETAIL)
End DoDot:2
End DoDot:1
+17 SET XMDUZ="PCMM Reassignment"
+18 KILL XMY
SET XMY(DUZ)=""
+19 SET SCX=$ORDER(^SD(404.91,"B",0))_","
+20 IF +SCX
SET XMY("G."_$$GET1^DIQ(404.91,SCX,804))=""
+21 DO ^XMD
QTMULT ;
+1 if $GET(SCDELTEM)
KILL ^TMP("SCTM MAIL LST",$JOB,SCTM)
+2 KILL ^TMP($JOB,"SCTMXM")
+3 QUIT
