- 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 Mar 13, 2025@21:43:19 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 ;
