SCAPMR21.m

SCAPMR21        ;ALB/REW/PDR - Position Reasignment ; AUG 1998

 ;;5.3;Scheduling;**148,157**;AUG 13, 1993

 ;

ACPTATP(DFNA,SCTPTO,SCTPFRM,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: 

 ;    DFNA    = is the literal value of a patient array (e.g. "scpt"

 ;              there is at least one scpt(dfn)="" defined

 ;    SCTPTO  = IEN of Position reasigned "to" ptr to 404.57

 ;    SCTPFRM = IEN of position reasigned "from" ptr to 404.57

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

 S SCNOMAIL=1

 S SCCNT=0

 S DFN=0

 F  S DFN=$O(@DFNA@(DFN)) Q:'DFN  D

 . S FASIEN=@DFNA@(DFN) ; get the "FROM" position Assignment

 . S SCX=$$ACPTTP^SCRPMPSP(.DFN,.SCTPTO,.SCFIELDA,.SCACT,FASIEN,SCERR,.SCYESTM,"SCMAIN")

 . ;  SCX = ien of 404.43^new?^404.42 ien (new entries only)^new?

 . IF $P(SCX,U,2) D  ;newly assigned

 .. S SCCNT=SCCNT+1

 .. S @SCNEWTP@(DFN)=+SCX   ;scnewtp

 .. S:$P(SCX,U,4) @SCNEWTM@(DFN)=$P(SCX,U,3)  ;scnewtm

 . IF $P(SCX,U,1)&('$P(SCX,U,2)) D  ;old

 .. S SCCNT=SCCNT+1

 .. S @SCOLDTP@(DFN)=+SCX

 . IF 'SCX D

 .. S @SCBADTP@(DFN)=$P(SCX,U,5)

 K SCNOMAIL

 ;D MAILLST^SCMCTPM(SCTPTO,.SCADDFLD,DT,.SCNEWTP,.SCOLDTP,.SCBADTP)

 D MAILLST^SCMRTPM(SCTPTO,.SCADDFLD,DT,.SCBADTP,SCTPFRM) ; report errors only

 Q SCCNT

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---SCAPMR21   1684     printed  Apr 09, 2024@21:56:57                                                                                                                                                                                                    Page 2

SCAPMR21  ;ALB/REW/PDR - Position Reasignment ; AUG 1998

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

 +2       ;

ACPTATP(DFNA,SCTPTO,SCTPFRM,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: 

 +2       ;    DFNA    = is the literal value of a patient array (e.g. "scpt"

 +3       ;              there is at least one scpt(dfn)="" defined

 +4       ;    SCTPTO  = IEN of Position reasigned "to" ptr to 404.57

 +5       ;    SCTPFRM = IEN of position reasigned "from" ptr to 404.57

 +6       ;    SCNEWTP = Subset of DFNA that was NEWLY assigned to a Position

 +7       ;    SCNEWTM = Subset of DFNA that was NEWLY assigned to a Team

 +8       ;    SCOLDTP = Subset of DFNA that was already assigned to Position

 +9       ;    SCBADTP = Subset of DFNA that was NOT assigned to Position

 +10      ; output: Count of Patients (New or Old) assigned to Position

 +11       NEW DFN,SCCNT,SCX,SCNOMAIL,FASIEN

 +12       SET SCNOMAIL=1

 +13       SET SCCNT=0

 +14       SET DFN=0

 +15       FOR 

               SET DFN=$ORDER(@DFNA@(DFN))

               if 'DFN

                   QUIT 

               Begin DoDot:1

 +16      ; get the "FROM" position Assignment

                   SET FASIEN=@DFNA@(DFN)

 +17               SET SCX=$$ACPTTP^SCRPMPSP(.DFN,.SCTPTO,.SCFIELDA,.SCACT,FASIEN,SCERR,.SCYESTM,"SCMAIN")

 +18      ;  SCX = ien of 404.43^new?^404.42 ien (new entries only)^new?

 +19      ;newly assigned

                   IF $PIECE(SCX,U,2)

                       Begin DoDot:2

 +20                       SET SCCNT=SCCNT+1

 +21      ;scnewtp

                           SET @SCNEWTP@(DFN)=+SCX

 +22      ;scnewtm

                           if $PIECE(SCX,U,4)

                               SET @SCNEWTM@(DFN)=$PIECE(SCX,U,3)

                       End DoDot:2

 +23      ;old

                   IF $PIECE(SCX,U,1)&('$PIECE(SCX,U,2))

                       Begin DoDot:2

 +24                       SET SCCNT=SCCNT+1

 +25                       SET @SCOLDTP@(DFN)=+SCX

                       End DoDot:2

 +26               IF 'SCX

                       Begin DoDot:2

 +27                       SET @SCBADTP@(DFN)=$PIECE(SCX,U,5)

                       End DoDot:2

               End DoDot:1

 +28       KILL SCNOMAIL

 +29      ;D MAILLST^SCMCTPM(SCTPTO,.SCADDFLD,DT,.SCNEWTP,.SCOLDTP,.SCBADTP)

 +30      ; report errors only

           DO MAILLST^SCMRTPM(SCTPTO,.SCADDFLD,DT,.SCBADTP,SCTPFRM)

 +31       QUIT SCCNT

 +32      ;