SCAPMR6.m

SCAPMR6 ;ALB/REW/PDR - Team Reassignment APIs:APPTTM ; 5 Jul 1995

 ;;5.3;Scheduling;**148,157,1015**;AUG 13, 1993;Build 21

 ;

 ; --------------------------- 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

 ;

SCAPMR6   ;ALB/REW/PDR - Team Reassignment APIs:APPTTM ; 5 Jul 1995

 +1       ;;5.3;Scheduling;**148,157,1015**;AUG 13, 1993;Build 21

 +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      ;