SCAPMR6 ;ALB/REW/PDR - Team Reassignment APIs:APPTTM ; 5 Jul 1995
;;5.3;Scheduling;**148,157**;AUG 13, 1993
;
; --------------------------- MAIN -------------------------------------
ACPTRATM(DFNA,SCTMTO,SCTMFRM,SCOTH,SCFIELDA,SCACT,SCERR,SCNEWTM,SCOLDTM,SCBADTM) ; list of patients RE-assigned to a team (404.42)
; input: as per ACPTTM (above with the following change:)
; DFNA = is the name of a patient array (e.g. $N(^TMP(SCJOB,"SC PATIENT LIST")))
; there is at least one scpt(dfn)="" defined
; SCTMTO = pointer to "TO" team file
; SCTMFRM = pointer to "FROM" team file - PDR 7/98
; SCOTH = array of other parameters e.g. SCOTH("SIZELIM")
; SCFIELDA = List of array of fields and values in 404.42
; SCACT = Date filed (NOW)
; SCERR = Name of error message var
; SCNEWTM = Subset of DFNA that was NEWLY assigned to Team [returned]
; SCOLDTM = Subset of DFNA that was already assigned -Team [returned]
; SCBADTP = Subset of DFNA that was NOT assigned to Team [returned]
; Note: The above three arrays return data in a user determined array
; output: Count of Patients:
; 1 2 3 4
; total assigned^newly assigned^assigned prior^not assigned
N DFN,SCNEWCNT,SCOLDCNT,SCBADCNT,SCX,SCNOMAIL,SCERR,FASIEN
S SCNOMAIL=1
S (SCNEWCNT,SCOLDCNT,SCBADCNT)=0
S DFN=0
F S DFN=$O(@DFNA@(DFN)) Q:'DFN D
. S FASIEN=@DFNA@(DFN) ; get the "FROM" team assignment
. S SCX=$$ACPTTM^SCRPMTA(DFN,SCTMTO,.SCFIELDA,.SCACT,FASIEN,.SCERR)
. ; SCX = ien of 404.42^new?
. IF $P(SCX,U,2) D ;newly assigned to TO Team
.. ;S ^TMP("PDR",$J,"NEW",DFN)=""
.. S SCNEWCNT=SCNEWCNT+1
.. S @SCNEWTM@(DFN)=+SCX ;scnewtm
. IF $P(SCX,U,1)&('$P(SCX,U,2)) D ;already assigned to TO team
.. ;S ^TMP("PDR",$J,"OLD",DFN)=""
.. S SCOLDCNT=SCOLDCNT+1
.. S @SCOLDTM@(DFN)=+SCX
. IF 'SCX D ; Unable to reassign to new team, so don't discharge from old team
.. ;S ^TMP("PDR",$J,"BAD",DFN)=""
.. S @SCBADTM@(DFN)=$P(SCX,U,3)
.. S SCBADCNT=SCBADCNT+1
K SCNOMAIL
; Send out mail notices only if there are failures to reassign
I SCBADCNT D MAILLST^SCMRTMM(SCTMTO,.SCADDFLD,DT,.SCBADTM) ; report only on unable to assign
Q (SCNEWCNT+SCOLDCNT)_U_SCBADCNT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMR6 2316 printed Nov 22, 2024@17:48:21 Page 2
SCAPMR6 ;ALB/REW/PDR - Team Reassignment APIs:APPTTM ; 5 Jul 1995
+1 ;;5.3;Scheduling;**148,157**;AUG 13, 1993
+2 ;
+3 ; --------------------------- MAIN -------------------------------------
ACPTRATM(DFNA,SCTMTO,SCTMFRM,SCOTH,SCFIELDA,SCACT,SCERR,SCNEWTM,SCOLDTM,SCBADTM) ; list of patients RE-assigned to a team (404.42)
+1 ; input: as per ACPTTM (above with the following change:)
+2 ; DFNA = is the name of a patient array (e.g. $N(^TMP(SCJOB,"SC PATIENT LIST")))
+3 ; there is at least one scpt(dfn)="" defined
+4 ; SCTMTO = pointer to "TO" team file
+5 ; SCTMFRM = pointer to "FROM" team file - PDR 7/98
+6 ; SCOTH = array of other parameters e.g. SCOTH("SIZELIM")
+7 ; SCFIELDA = List of array of fields and values in 404.42
+8 ; SCACT = Date filed (NOW)
+9 ; SCERR = Name of error message var
+10 ; SCNEWTM = Subset of DFNA that was NEWLY assigned to Team [returned]
+11 ; SCOLDTM = Subset of DFNA that was already assigned -Team [returned]
+12 ; SCBADTP = Subset of DFNA that was NOT assigned to Team [returned]
+13 ; Note: The above three arrays return data in a user determined array
+14 ; output: Count of Patients:
+15 ; 1 2 3 4
+16 ; total assigned^newly assigned^assigned prior^not assigned
+17 NEW DFN,SCNEWCNT,SCOLDCNT,SCBADCNT,SCX,SCNOMAIL,SCERR,FASIEN
+18 SET SCNOMAIL=1
+19 SET (SCNEWCNT,SCOLDCNT,SCBADCNT)=0
+20 SET DFN=0
+21 FOR
SET DFN=$ORDER(@DFNA@(DFN))
if 'DFN
QUIT
Begin DoDot:1
+22 ; get the "FROM" team assignment
SET FASIEN=@DFNA@(DFN)
+23 SET SCX=$$ACPTTM^SCRPMTA(DFN,SCTMTO,.SCFIELDA,.SCACT,FASIEN,.SCERR)
+24 ; SCX = ien of 404.42^new?
+25 ;newly assigned to TO Team
IF $PIECE(SCX,U,2)
Begin DoDot:2
+26 ;S ^TMP("PDR",$J,"NEW",DFN)=""
+27 SET SCNEWCNT=SCNEWCNT+1
+28 ;scnewtm
SET @SCNEWTM@(DFN)=+SCX
End DoDot:2
+29 ;already assigned to TO team
IF $PIECE(SCX,U,1)&('$PIECE(SCX,U,2))
Begin DoDot:2
+30 ;S ^TMP("PDR",$J,"OLD",DFN)=""
+31 SET SCOLDCNT=SCOLDCNT+1
+32 SET @SCOLDTM@(DFN)=+SCX
End DoDot:2
+33 ; Unable to reassign to new team, so don't discharge from old team
IF 'SCX
Begin DoDot:2
+34 ;S ^TMP("PDR",$J,"BAD",DFN)=""
+35 SET @SCBADTM@(DFN)=$PIECE(SCX,U,3)
+36 SET SCBADCNT=SCBADCNT+1
End DoDot:2
End DoDot:1
+37 KILL SCNOMAIL
+38 ; Send out mail notices only if there are failures to reassign
+39 ; report only on unable to assign
IF SCBADCNT
DO MAILLST^SCMRTMM(SCTMTO,.SCADDFLD,DT,.SCBADTM)
+40 QUIT (SCNEWCNT+SCOLDCNT)_U_SCBADCNT
+41 ;
