SCMCBK8 ;bp/cmf - multiple patient assignments mail queue - RPCVersion = 1;;Aug 7, 1998
;;5.3;Scheduling;**148,177,210**;AUG 13, 1993
Q
;
ACPTTP(DFN,SCTP,SCFIELDA,SCACT,SCERR,SCYESTM,SCMAINA) ;add/edit a patient to a position (pt TP assgn - #404.43
; input:
; DFN = pointer to PATIENT file (#2)
; SCTP = pointer to TEAM POSTION file (#404.57)
; SCFIELDA= array of extra field entries - scfielda('fld#')=value
; SCACT = date to activate [default=DT]
; SCERR = array NAME to store error messages.
; [ex. ^TMP("ORXX",$J)]
; SCYESTM = Should team assignment be made, if none active now?[1=YES]
; SCMAINA= array of extra field entries for 404.42 (only if scyestm=1)
;
; Output:
; Returned = ien of 404.43^new?^404.42 ien (new entries only)^new?^Message
; SCERR() = Array of DIALOG file messages(errors) .
; Foramt:
; Subscript: Sequential # from 1 to n
; Piece Description
; 1 IEN of DIALOG file
;
N SCESEQ,SCPARM,SCIEN,SC,HISTPTTP,SCFLD,SCTM,SCPTTMA,SCPTTPA,SCTMFLDA
N SCNEWTP,SCNEWTM,SCAPTDT,SCAPTTPO,SCAPTTPE,SCMESS
N SCLOCK,SCXLOCK,SCX
;
;check/setup variables
I '$$OKDATA^SCAPMC21 S SCMESS=$$S(9) G APTTPQ
;
;bp/cmf 210 new begin
;lock process/dfn/pos
I '$D(^XTMP("SCMC POS ASGN")) D
. S ^XTMP("SCMC POS ASGN",0)=DT_U_DT_U_"POS ASGN PROCESS LOCK"
. Q
;
S SCXLOCK=0
S SCLOCK="^XTMP(""SCMC POS ASGN"",DFN)"
I $D(@SCLOCK) S SCMESS=$$S(15) G APTTPQ
S @SCLOCK=""
S SCXLOCK=1
H 1
;
;stop if active assignment
S SCPTTPA=$$HISTPTTP^SCAPMCU2(DFN,SCTP,SCACT)
I SCPTTPA S SCMESS=$$S(10) G APTTPQ
;bp/cmf 210 new end
;
S SCTM=$P($G(^SCTM(404.57,SCTP,0)),U,2)
S SCAPTDT("BEGIN")=SCACT
S SCAPTDT("END")=3990101
S SCAPTDT("INCL")=0
;
;is patient alive?
I $$DP^SCMCBK6(DFN) S SCMESS=$$S(1) G APTTPQ
;
S SCX=$$OKPREC5^SCMCLK(SCTP,SCACT)
I SCX<1 S SCMESS=$P(SCX,U,2) G APTTPQ
;
;is PC role assignable?
I $$T1(),'$$CHKPC^SCAPMC21(DFN) S SCMESS=$$S(12) G APTTPQ
;
I '$$TPPT^SCAPMC(DFN,"SCAPTDT",,,,,0,"SCAPTTPO","SCAPTTPE") S SCMESS=$$S(13) G APTTPQ
S SCPTTPA=$O(SCAPTTPO("SCTP",SCTM,SCTP,0))
;
;to edit existing entry
I SCPTTPA D G APTTPQ
.S SC($J,404.43,(+SCPTTPA)_",",.03)=SCACT
.I $D(SCFIELDA) D
..S SCFLD=0
..F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
...S SC($J,404.43,(+SCPTTPA)_",",SCFLD)=@SCFIELDA@(SCFLD)
...Q
..Q
.D FILE^DIE("","SC($J)",SCERR)
.Q
;
;needed: patient team assignment for date
S SCPTTMA=+$$HISTPTTM^SCAPMCU2(DFN,SCTM,SCACT)
;
; if flag is set to add patient to team & no pt tm assignment exists
I ('SCPTTMA)&($G(SCYESTM))&($D(SCFIELDA)) D
.S:$D(@SCFIELDA@(.05)) @SCMAINA@(.08)=$G(@SCMAINA@(.08),$S(@SCFIELDA@(.05):1,1:99))
.S:$D(@SCFIELDA@(.06)) @SCMAINA@(.11)=$G(@SCMAINA@(.11),@SCFIELDA@(.06))
.S:$D(@SCFIELDA@(.07)) @SCMAINA@(.12)=$G(@SCMAINA@(.12),@SCFIELDA@(.07))
.S:$D(@SCFIELDA@(.08)) @SCMAINA@(.13)=$G(@SCMAINA@(.13),@SCFIELDA@(.08))
.S:$D(@SCFIELDA@(.09)) @SCMAINA@(.14)=$G(@SCMAINA@(.14),@SCFIELDA@(.09))
.S SCPTTMA=+$$ACPTTM^SCAPMC(DFN,SCTM,.SCMAINA,SCACT,SCERR)
.Q
;
TM I 'SCPTTMA S SCMESS=$$S(14) G APTTPQ
;
I $D(SCFIELDA) D
.S SCFLD=0
.F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
..S SC($J,404.43,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
..Q
.Q
;
S SC($J,404.43,"+1,",.01)=SCPTTMA
S SC($J,404.43,"+1,",.02)=SCTP
S SC($J,404.43,"+1,",.03)=SCACT
N SCTPERR
D UPDATE^DIE("","SC($J)","SCIEN","SCTPERR")
;
I $D(SCTPERR) S SCMESS=$$S(11) K SCIEN
E D
.S SCPTTPA=+$G(SCIEN(1))
.S SCNEWTP=1
.D AFTERTP^SCMCDD1(SCPTTPA)
.Q
;
APTTPQ ;bp/cmf 210 new code begin
I SCXLOCK=1 K @SCLOCK
;bp/cmf 210 new code end
Q +$G(SCPTTPA)_U_+$G(SCNEWTP)_U_+$G(SCPTTMA)_U_+$P($G(SCPTTMA),U,2)_U_$G(SCMESS)
;
T1() Q $S('$D(SCFIELDA):0,'$D(@SCFIELDA@(.05)):0,($G(@SCFIELDA@(.05))=1):1,($G(@SCFIELDA@(.05))=2):1,1:0)
;
S(SCX) Q $$S^SCMCBK6(SCX)
;
ACPTATP(DFNA,SCTP,SCFIELDA,SCACT,SCERR,SCYESTM,SCMAINA,SCNEWTP,SCNEWTM,SCOLDTP,SCBADTP) ;list of patients to a position (pt TP assgn - #404.43 and possibly #404.42
; input: as per ACPTTP (above with the following change:)
; DFNA = is the literal value of a patient array (e.g. "scpt"
; there is at least one scpt(dfn)="" defined
; SCNEWTP = Subset of DFNA that was NEWLY assigned to a Position
; SCNEWTM = Subset of DFNA that was NEWLY assigned to a Team
; SCOLDTP = Subset of DFNA that was already assigned to Position
; SCBADTP = Subset of DFNA that was NOT assigned to Position
; output: Count of Patients (New or Old) assigned to Position
;
N DFN,SCCNT,SCX,SCNOMAIL,SCTOTCNT
S SCNOMAIL=1
S SCCNT=0
S SCTOTCNT=$$PASSCNT^SCMCBK5(DFNA)
I SCTOTCNT=0 G MAIL
S DFN=0
F S DFN=$O(@DFNA@(DFN)) Q:'DFN D
.S SCX=$$ACPTTP(.DFN,.SCTP,.SCFIELDA,.SCACT,.SCERR,.SCYESTM)
.;
.;newly assigned
.I $P(SCX,U,2)=1 D Q
..S SCCNT=SCCNT+1
..S @SCNEWTP@(DFN)=+SCX
..S:$P(SCX,U,4) @SCNEWTM@(DFN)=$P(SCX,U,3)
..Q
.;
.;already assigned
.;I $P(SCX,U,1)&('$P(SCX,U,2)) D
.I +SCX D Q
..S SCCNT=SCCNT+1
..S @SCOLDTP@(DFN)=+SCX
..Q
.;
.;not assigned;;I 'SCX D
.S @SCBADTP@(DFN)=$P(SCX,U,5)
.Q
;
MAIL K SCNOMAIL
D MAILLST^SCMCBK9(SCTP,.SCADDFLD,DT,.SCNEWTP,.SCOLDTP,.SCBADTP,SCTOTCNT)
Q SCCNT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCBK8 5340 printed Sep 23, 2025@20:16:16 Page 2
SCMCBK8 ;bp/cmf - multiple patient assignments mail queue - RPCVersion = 1;;Aug 7, 1998
+1 ;;5.3;Scheduling;**148,177,210**;AUG 13, 1993
+2 QUIT
+3 ;
ACPTTP(DFN,SCTP,SCFIELDA,SCACT,SCERR,SCYESTM,SCMAINA) ;add/edit a patient to a position (pt TP assgn - #404.43
+1 ; input:
+2 ; DFN = pointer to PATIENT file (#2)
+3 ; SCTP = pointer to TEAM POSTION file (#404.57)
+4 ; SCFIELDA= array of extra field entries - scfielda('fld#')=value
+5 ; SCACT = date to activate [default=DT]
+6 ; SCERR = array NAME to store error messages.
+7 ; [ex. ^TMP("ORXX",$J)]
+8 ; SCYESTM = Should team assignment be made, if none active now?[1=YES]
+9 ; SCMAINA= array of extra field entries for 404.42 (only if scyestm=1)
+10 ;
+11 ; Output:
+12 ; Returned = ien of 404.43^new?^404.42 ien (new entries only)^new?^Message
+13 ; SCERR() = Array of DIALOG file messages(errors) .
+14 ; Foramt:
+15 ; Subscript: Sequential # from 1 to n
+16 ; Piece Description
+17 ; 1 IEN of DIALOG file
+18 ;
+19 NEW SCESEQ,SCPARM,SCIEN,SC,HISTPTTP,SCFLD,SCTM,SCPTTMA,SCPTTPA,SCTMFLDA
+20 NEW SCNEWTP,SCNEWTM,SCAPTDT,SCAPTTPO,SCAPTTPE,SCMESS
+21 NEW SCLOCK,SCXLOCK,SCX
+22 ;
+23 ;check/setup variables
+24 IF '$$OKDATA^SCAPMC21
SET SCMESS=$$S(9)
GOTO APTTPQ
+25 ;
+26 ;bp/cmf 210 new begin
+27 ;lock process/dfn/pos
+28 IF '$DATA(^XTMP("SCMC POS ASGN"))
Begin DoDot:1
+29 SET ^XTMP("SCMC POS ASGN",0)=DT_U_DT_U_"POS ASGN PROCESS LOCK"
+30 QUIT
End DoDot:1
+31 ;
+32 SET SCXLOCK=0
+33 SET SCLOCK="^XTMP(""SCMC POS ASGN"",DFN)"
+34 IF $DATA(@SCLOCK)
SET SCMESS=$$S(15)
GOTO APTTPQ
+35 SET @SCLOCK=""
+36 SET SCXLOCK=1
+37 HANG 1
+38 ;
+39 ;stop if active assignment
+40 SET SCPTTPA=$$HISTPTTP^SCAPMCU2(DFN,SCTP,SCACT)
+41 IF SCPTTPA
SET SCMESS=$$S(10)
GOTO APTTPQ
+42 ;bp/cmf 210 new end
+43 ;
+44 SET SCTM=$PIECE($GET(^SCTM(404.57,SCTP,0)),U,2)
+45 SET SCAPTDT("BEGIN")=SCACT
+46 SET SCAPTDT("END")=3990101
+47 SET SCAPTDT("INCL")=0
+48 ;
+49 ;is patient alive?
+50 IF $$DP^SCMCBK6(DFN)
SET SCMESS=$$S(1)
GOTO APTTPQ
+51 ;
+52 SET SCX=$$OKPREC5^SCMCLK(SCTP,SCACT)
+53 IF SCX<1
SET SCMESS=$PIECE(SCX,U,2)
GOTO APTTPQ
+54 ;
+55 ;is PC role assignable?
+56 IF $$T1()
IF '$$CHKPC^SCAPMC21(DFN)
SET SCMESS=$$S(12)
GOTO APTTPQ
+57 ;
+58 IF '$$TPPT^SCAPMC(DFN,"SCAPTDT",,,,,0,"SCAPTTPO","SCAPTTPE")
SET SCMESS=$$S(13)
GOTO APTTPQ
+59 SET SCPTTPA=$ORDER(SCAPTTPO("SCTP",SCTM,SCTP,0))
+60 ;
+61 ;to edit existing entry
+62 IF SCPTTPA
Begin DoDot:1
+63 SET SC($JOB,404.43,(+SCPTTPA)_",",.03)=SCACT
+64 IF $DATA(SCFIELDA)
Begin DoDot:2
+65 SET SCFLD=0
+66 FOR
SET SCFLD=$ORDER(@SCFIELDA@(SCFLD))
if 'SCFLD
QUIT
Begin DoDot:3
+67 SET SC($JOB,404.43,(+SCPTTPA)_",",SCFLD)=@SCFIELDA@(SCFLD)
+68 QUIT
End DoDot:3
+69 QUIT
End DoDot:2
+70 DO FILE^DIE("","SC($J)",SCERR)
+71 QUIT
End DoDot:1
GOTO APTTPQ
+72 ;
+73 ;needed: patient team assignment for date
+74 SET SCPTTMA=+$$HISTPTTM^SCAPMCU2(DFN,SCTM,SCACT)
+75 ;
+76 ; if flag is set to add patient to team & no pt tm assignment exists
+77 IF ('SCPTTMA)&($GET(SCYESTM))&($DATA(SCFIELDA))
Begin DoDot:1
+78 if $DATA(@SCFIELDA@(.05))
SET @SCMAINA@(.08)=$GET(@SCMAINA@(.08),$SELECT(@SCFIELDA@(.05):1,1:99))
+79 if $DATA(@SCFIELDA@(.06))
SET @SCMAINA@(.11)=$GET(@SCMAINA@(.11),@SCFIELDA@(.06))
+80 if $DATA(@SCFIELDA@(.07))
SET @SCMAINA@(.12)=$GET(@SCMAINA@(.12),@SCFIELDA@(.07))
+81 if $DATA(@SCFIELDA@(.08))
SET @SCMAINA@(.13)=$GET(@SCMAINA@(.13),@SCFIELDA@(.08))
+82 if $DATA(@SCFIELDA@(.09))
SET @SCMAINA@(.14)=$GET(@SCMAINA@(.14),@SCFIELDA@(.09))
+83 SET SCPTTMA=+$$ACPTTM^SCAPMC(DFN,SCTM,.SCMAINA,SCACT,SCERR)
+84 QUIT
End DoDot:1
+85 ;
TM IF 'SCPTTMA
SET SCMESS=$$S(14)
GOTO APTTPQ
+1 ;
+2 IF $DATA(SCFIELDA)
Begin DoDot:1
+3 SET SCFLD=0
+4 FOR
SET SCFLD=$ORDER(@SCFIELDA@(SCFLD))
if 'SCFLD
QUIT
Begin DoDot:2
+5 SET SC($JOB,404.43,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
+8 ;
+9 SET SC($JOB,404.43,"+1,",.01)=SCPTTMA
+10 SET SC($JOB,404.43,"+1,",.02)=SCTP
+11 SET SC($JOB,404.43,"+1,",.03)=SCACT
+12 NEW SCTPERR
+13 DO UPDATE^DIE("","SC($J)","SCIEN","SCTPERR")
+14 ;
+15 IF $DATA(SCTPERR)
SET SCMESS=$$S(11)
KILL SCIEN
+16 IF '$TEST
Begin DoDot:1
+17 SET SCPTTPA=+$GET(SCIEN(1))
+18 SET SCNEWTP=1
+19 DO AFTERTP^SCMCDD1(SCPTTPA)
+20 QUIT
End DoDot:1
+21 ;
APTTPQ ;bp/cmf 210 new code begin
+1 IF SCXLOCK=1
KILL @SCLOCK
+2 ;bp/cmf 210 new code end
+3 QUIT +$GET(SCPTTPA)_U_+$GET(SCNEWTP)_U_+$GET(SCPTTMA)_U_+$PIECE($GET(SCPTTMA),U,2)_U_$GET(SCMESS)
+4 ;
T1() QUIT $SELECT('$DATA(SCFIELDA):0,'$DATA(@SCFIELDA@(.05)):0,($GET(@SCFIELDA@(.05))=1):1,($GET(@SCFIELDA@(.05))=2):1,1:0)
+1 ;
S(SCX) QUIT $$S^SCMCBK6(SCX)
+1 ;
ACPTATP(DFNA,SCTP,SCFIELDA,SCACT,SCERR,SCYESTM,SCMAINA,SCNEWTP,SCNEWTM,SCOLDTP,SCBADTP) ;list of patients to a position (pt TP assgn - #404.43 and possibly #404.42
+1 ; input: as per ACPTTP (above with the following change:)
+2 ; DFNA = is the literal value of a patient array (e.g. "scpt"
+3 ; there is at least one scpt(dfn)="" defined
+4 ; SCNEWTP = Subset of DFNA that was NEWLY assigned to a Position
+5 ; SCNEWTM = Subset of DFNA that was NEWLY assigned to a Team
+6 ; SCOLDTP = Subset of DFNA that was already assigned to Position
+7 ; SCBADTP = Subset of DFNA that was NOT assigned to Position
+8 ; output: Count of Patients (New or Old) assigned to Position
+9 ;
+10 NEW DFN,SCCNT,SCX,SCNOMAIL,SCTOTCNT
+11 SET SCNOMAIL=1
+12 SET SCCNT=0
+13 SET SCTOTCNT=$$PASSCNT^SCMCBK5(DFNA)
+14 IF SCTOTCNT=0
GOTO MAIL
+15 SET DFN=0
+16 FOR
SET DFN=$ORDER(@DFNA@(DFN))
if 'DFN
QUIT
Begin DoDot:1
+17 SET SCX=$$ACPTTP(.DFN,.SCTP,.SCFIELDA,.SCACT,.SCERR,.SCYESTM)
+18 ;
+19 ;newly assigned
+20 IF $PIECE(SCX,U,2)=1
Begin DoDot:2
+21 SET SCCNT=SCCNT+1
+22 SET @SCNEWTP@(DFN)=+SCX
+23 if $PIECE(SCX,U,4)
SET @SCNEWTM@(DFN)=$PIECE(SCX,U,3)
+24 QUIT
End DoDot:2
QUIT
+25 ;
+26 ;already assigned
+27 ;I $P(SCX,U,1)&('$P(SCX,U,2)) D
+28 IF +SCX
Begin DoDot:2
+29 SET SCCNT=SCCNT+1
+30 SET @SCOLDTP@(DFN)=+SCX
+31 QUIT
End DoDot:2
QUIT
+32 ;
+33 ;not assigned;;I 'SCX D
+34 SET @SCBADTP@(DFN)=$PIECE(SCX,U,5)
+35 QUIT
End DoDot:1
+36 ;
MAIL KILL SCNOMAIL
+1 DO MAILLST^SCMCBK9(SCTP,.SCADDFLD,DT,.SCNEWTP,.SCOLDTP,.SCBADTP,SCTOTCNT)
+2 QUIT SCCNT
+3 ;
