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 ---[H[J[2J[HSCAPMR21 1684 printed Sep 23, 2025@20:14:44 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 ;
