SCMCBK7 ;bp/cmf - multiple patient assignments mail queue - RPCVersion = 1 ;;Aug 6, 1998
;;5.3;Scheduling;**148,177**;AUG 13, 1993
Q
;
MAILLST(SCTM,SCFIELDA,SCDATE,SCNEWTM,SCOLDTM,SCBADTM,SCTOTCNT) ;
; ;like MAILLIST^SCMCTMM(...
; Input:
; SCTM - Pointer to Team File (#404.51)
; SCFIELDA - Field array with internal values
; SCDATE - Effective Date
; SCNEWTM - DFN array of newly assigned to team
; SCOLDTM - DFN array of previously assigned to team
; SCBADTM - DFN array of patients unassignable to team
; SCTOTCNT - Count of DFN array passed to process
;
N XMDUZ,XMY,XMSUB,XMTEXT,VA,VAERR,XMZ,Y,ZTQUEUED
N SCTMNM,DFN,SCOK,SCPTNM,SCFLD,SCNODE,SCNDX,SCSPACE
N SCE,SCB,SCDELTEM,SCJ,SCL,SCDETAIL
;
D PREP1
S SCTMNM=$P($G(^SCTM(404.51,+SCTM,0)),U,1)
S XMSUB=$$S(4)_SCTMNM
S XMTEXT="^TMP($J,""SCTMXM"","
;
S SCTMNM=$P($G(^SCTM(404.51,+SCTM,0)),U,1)
D SETLN($$S(5)_SCTMNM)
D SETLN($$S(6)_$$FMTE^XLFDT(SCDATE))
D SETLN($$S(7)_SCTOTCNT)
D SETLN(" ")
;
I $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^SCMCTMM(404.42,SCNODE,SCNDX,SCSPACE,1))
;
I SCTOTCNT=0 G MAIL
;
NEW I $S('$D(SCNEWTM):0,1:$O(@SCNEWTM@(0))) D BLDLST(1)
;
BAD I $S('$D(SCBADTM):0,1:$O(@SCBADTM@(0))) D BLDLST(2)
;
OLD I $S('$D(SCOLDTM):0,1:$O(@SCOLDTM@(0))) D BLDLST(3)
;
MAIL D SEND(8)
;
QTMULT K:$G(SCDELTEM) ^TMP("SCTM MAIL LST",$J,SCTM)
K ^TMP($J,"SCTMXM")
Q
;
PREP1 S ZTQUEUED=1
S SCDELTEM=1 ;ok to delete tmp global
S $P(SCSPACE," ",80)=""
S SCLNCNT=0
S SCOK=1
Q
;
;
SETLN(TEXT) ;
D SETLN^SCMCTMM(TEXT)
Q
;
SEND(SCX) ;input SCX=points to string to use as sender
;
S XMY(SCMAIL1)=""
S XMDUZ=$$S(SCX)
;S XMDUZ=.5
D ^XMD
Q
;
BLDLST(SCL) ;create text by new/bad/old
;input SCL = for header line, ^tmp, $o
N SCJ
D SETLN(" ")
D SETLN($$S(SCL))
S SCJ="^TMP(""SCTM MAIL LST"","_$J_","_SCTM_","_SCL_")"
S DFN=0
F S DFN=$$O(SCL) Q:'DFN D DTLLST
D SETLST(0)
Q
;
DTLLST ;detail the list
S SCPTNM=$P(^DPT(DFN,0),U,1)
D PID^VADPT6
S SCDETAIL=" "_SCPTNM_" ("_$G(VA("PID"))_")"
I SCL=2 D RJD
S @SCJ@(DFN)=SCDETAIL
S @SCJ@("B",SCPTNM,DFN)=""
Q
;
SETLST(SCX) ;set the list into message
;input: SCX: 0=team assignment, 1=position assignment
S SCPTNM=""
F S SCPTNM=$O(@SCJ@("B",SCPTNM)) Q:SCPTNM']"" D
.S DFN=0
.F S DFN=$O(@SCJ@("B",SCPTNM,DFN)) Q:'DFN D
..S SCDETAIL=$G(@SCJ@(DFN))
..I SCX=0 D SETLN(SCDETAIL) Q
..D SETLN^SCMCTPM(SCDETAIL)
..Q
.Q
Q
;
RJD ;ReJect Detail
;
N SCX
I $D(SCBADTM) S SCX=$P(@SCBADTM@(DFN),U)
E S SCX=$P(@SCBADTP@(DFN),U)
S SCDETAIL=SCDETAIL_" ["_SCX_"]"
Q
;
O(SCL) ;returns next patient in array
Q $S(SCL=1:$O(@SCNEWTM@(DFN)),SCL=2:$O(@SCBADTM@(DFN)),1:$O(@SCOLDTM@(DFN)))
;
S(SCL) ;returns line of text
Q $P($T(T+SCL),";;",2)
;
T ;;
1 ;;There has been a new team assignment for the following patients:
2 ;;There has been NO new team assignment for the following patients:
3 ;;The following patients were already assigned to the target team:
4 ;;Multiple PATIENT-TEAM ASSIGNMENT for ;;
5 ;;Team: ;;
6 ;;Effective Date: ;;
7 ;;Processed: ;;
8 ;;PCMM - Multiple Patient-Team Assignment
9 ;;PCMM - Multiple Patient-Position Assignment
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCBK7 3399 printed Sep 23, 2025@20:16:15 Page 2
SCMCBK7 ;bp/cmf - multiple patient assignments mail queue - RPCVersion = 1 ;;Aug 6, 1998
+1 ;;5.3;Scheduling;**148,177**;AUG 13, 1993
+2 QUIT
+3 ;
MAILLST(SCTM,SCFIELDA,SCDATE,SCNEWTM,SCOLDTM,SCBADTM,SCTOTCNT) ;
+1 ; ;like MAILLIST^SCMCTMM(...
+2 ; Input:
+3 ; SCTM - Pointer to Team File (#404.51)
+4 ; SCFIELDA - Field array with internal values
+5 ; SCDATE - Effective Date
+6 ; SCNEWTM - DFN array of newly assigned to team
+7 ; SCOLDTM - DFN array of previously assigned to team
+8 ; SCBADTM - DFN array of patients unassignable to team
+9 ; SCTOTCNT - Count of DFN array passed to process
+10 ;
+11 NEW XMDUZ,XMY,XMSUB,XMTEXT,VA,VAERR,XMZ,Y,ZTQUEUED
+12 NEW SCTMNM,DFN,SCOK,SCPTNM,SCFLD,SCNODE,SCNDX,SCSPACE
+13 NEW SCE,SCB,SCDELTEM,SCJ,SCL,SCDETAIL
+14 ;
+15 DO PREP1
+16 SET SCTMNM=$PIECE($GET(^SCTM(404.51,+SCTM,0)),U,1)
+17 SET XMSUB=$$S(4)_SCTMNM
+18 SET XMTEXT="^TMP($J,""SCTMXM"","
+19 ;
+20 SET SCTMNM=$PIECE($GET(^SCTM(404.51,+SCTM,0)),U,1)
+21 DO SETLN($$S(5)_SCTMNM)
+22 DO SETLN($$S(6)_$$FMTE^XLFDT(SCDATE))
+23 DO SETLN($$S(7)_SCTOTCNT)
+24 DO SETLN(" ")
+25 ;
+26 IF $DATA(SCFIELDA)
Begin DoDot:1
+27 FOR SCNDX=1:1:14
SET SCFLD=SCNDX*.01
IF $DATA(SCFIELDA(SCFLD))
Begin DoDot:2
+28 SET $PIECE(SCNODE,U,SCNDX)=SCFIELDA(SCFLD)
+29 DO SETLN($$TEXT^SCMCTMM(404.42,SCNODE,SCNDX,SCSPACE,1))
End DoDot:2
End DoDot:1
+30 ;
+31 IF SCTOTCNT=0
GOTO MAIL
+32 ;
NEW IF $SELECT('$DATA(SCNEWTM):0,1:$ORDER(@SCNEWTM@(0)))
DO BLDLST(1)
+1 ;
BAD IF $SELECT('$DATA(SCBADTM):0,1:$ORDER(@SCBADTM@(0)))
DO BLDLST(2)
+1 ;
OLD IF $SELECT('$DATA(SCOLDTM):0,1:$ORDER(@SCOLDTM@(0)))
DO BLDLST(3)
+1 ;
MAIL DO SEND(8)
+1 ;
QTMULT if $GET(SCDELTEM)
KILL ^TMP("SCTM MAIL LST",$JOB,SCTM)
+1 KILL ^TMP($JOB,"SCTMXM")
+2 QUIT
+3 ;
PREP1 SET ZTQUEUED=1
+1 ;ok to delete tmp global
SET SCDELTEM=1
+2 SET $PIECE(SCSPACE," ",80)=""
+3 SET SCLNCNT=0
+4 SET SCOK=1
+5 QUIT
+6 ;
+7 ;
SETLN(TEXT) ;
+1 DO SETLN^SCMCTMM(TEXT)
+2 QUIT
+3 ;
SEND(SCX) ;input SCX=points to string to use as sender
+1 ;
+2 SET XMY(SCMAIL1)=""
+3 SET XMDUZ=$$S(SCX)
+4 ;S XMDUZ=.5
+5 DO ^XMD
+6 QUIT
+7 ;
BLDLST(SCL) ;create text by new/bad/old
+1 ;input SCL = for header line, ^tmp, $o
+2 NEW SCJ
+3 DO SETLN(" ")
+4 DO SETLN($$S(SCL))
+5 SET SCJ="^TMP(""SCTM MAIL LST"","_$JOB_","_SCTM_","_SCL_")"
+6 SET DFN=0
+7 FOR
SET DFN=$$O(SCL)
if 'DFN
QUIT
DO DTLLST
+8 DO SETLST(0)
+9 QUIT
+10 ;
DTLLST ;detail the list
+1 SET SCPTNM=$PIECE(^DPT(DFN,0),U,1)
+2 DO PID^VADPT6
+3 SET SCDETAIL=" "_SCPTNM_" ("_$GET(VA("PID"))_")"
+4 IF SCL=2
DO RJD
+5 SET @SCJ@(DFN)=SCDETAIL
+6 SET @SCJ@("B",SCPTNM,DFN)=""
+7 QUIT
+8 ;
SETLST(SCX) ;set the list into message
+1 ;input: SCX: 0=team assignment, 1=position assignment
+2 SET SCPTNM=""
+3 FOR
SET SCPTNM=$ORDER(@SCJ@("B",SCPTNM))
if SCPTNM']""
QUIT
Begin DoDot:1
+4 SET DFN=0
+5 FOR
SET DFN=$ORDER(@SCJ@("B",SCPTNM,DFN))
if 'DFN
QUIT
Begin DoDot:2
+6 SET SCDETAIL=$GET(@SCJ@(DFN))
+7 IF SCX=0
DO SETLN(SCDETAIL)
QUIT
+8 DO SETLN^SCMCTPM(SCDETAIL)
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
RJD ;ReJect Detail
+1 ;
+2 NEW SCX
+3 IF $DATA(SCBADTM)
SET SCX=$PIECE(@SCBADTM@(DFN),U)
+4 IF '$TEST
SET SCX=$PIECE(@SCBADTP@(DFN),U)
+5 SET SCDETAIL=SCDETAIL_" ["_SCX_"]"
+6 QUIT
+7 ;
O(SCL) ;returns next patient in array
+1 QUIT $SELECT(SCL=1:$ORDER(@SCNEWTM@(DFN)),SCL=2:$ORDER(@SCBADTM@(DFN)),1:$ORDER(@SCOLDTM@(DFN)))
+2 ;
S(SCL) ;returns line of text
+1 QUIT $PIECE($TEXT(T+SCL),";;",2)
+2 ;
T ;;
1 ;;There has been a new team assignment for the following patients:
2 ;;There has been NO new team assignment for the following patients:
3 ;;The following patients were already assigned to the target team:
4 ;;Multiple PATIENT-TEAM ASSIGNMENT for ;;
5 ;;Team: ;;
6 ;;Effective Date: ;;
7 ;;Processed: ;;
8 ;;PCMM - Multiple Patient-Team Assignment
9 ;;PCMM - Multiple Patient-Position Assignment
