SCMCBK5 ;bp/cmf - multiple patient assignments mail queue - RPCVersion = 1 ;;Aug 7, 1998
;;5.3;Scheduling;**148,177**;AUG 13, 1993
Q
;
ACPTTM(DFN,SCTM,SCFIELDA,SCACT,SCERR) ;add a patient to a team (pt tm assgn - #404.42
; input:
; DFN = pointer to PATIENT file (#2)
; SCTM = pointer to TEAM file (#404.51)
; SCFIELDA= array of additional fields to be added
; SCACT = date to activate [default=DT]
; SCERR = array NAME to store error messages.
; [ex. ^TMP("ORXX",$J)]
;
; Output:
; Returned = ien of 404.42 - 0 if none after^new?^Message
;
N SCPTTM,SCESEQ,SCPARM,SCIEN,SC,SCFLD,SCNEWTM,SCMESS,SCX
;
;check/setup variables
I '$$OKDATA^SCAPMC6() S SCMESS=$$S(9) G APTTMQ
;
;is patient deceased?
I $$DP^SCMCBK6(DFN) S SCMESS=$$S(1) G APTTMQ
;
;can PC assignment be made?
I $$T1() D I 'SCX S SCMESS=$P(SCX,U,2) G APTTMQ
.S SCX=$$OKPTTMPC^SCMCBK6(DFN,SCTM,SCACT)
.; ;like $$OKPTTMPC^SCMCTMU2(...
.Q
;
;is pt already assignmed to team?
S SCPTTM=$$PTTMACT^SCAPMC6(DFN,SCTM,SCACT,.SCERR)
I SCPTTM S SCMESS=$$S(10) G APTTMQ
;
I $D(SCFIELDA) D
.S SCFLD=0
.F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
..S SC($J,404.42,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
..Q
.Q
;
S SC($J,404.42,"+1,",.01)=DFN
S SC($J,404.42,"+1,",.02)=SCACT
S SC($J,404.42,"+1,",.03)=SCTM
N SCTMERR
D UPDATE^DIE("","SC($J)","SCIEN","SCTMERR")
;
I $D(SCTMERR) S SCMESS=$$S(11) K SCIEN
E D
.S SCPTTM=$G(SCIEN(1))
.S SCNEWTM=1
.D AFTERTM^SCMCDD1(SCPTTM)
.Q
;
APTTMQ Q +$G(SCPTTM)_U_+$G(SCNEWTM)_U_$G(SCMESS)
;
T1() Q $S('$D(SCFIELDA):0,('($D(@SCFIELDA@(.08))#2)):0,($G(@SCFIELDA@(.08))=1):1,1:0)
;
S(SCX) Q $$S^SCMCBK6(SCX)
;
ACPTATM(DFNA,SCTM,SCFIELDA,SCACT,SCERR,SCNEWTM,SCOLDTM,SCBADTM) ;list of patients assigned to a team (404.42)
; input: as per ACPTTM (above with the following change:)
; DFNA = is the literal value of a patient array (e.g. "scpt"
; there is at least one scpt(dfn)="" defined
; 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,SCTOTCNT,SCX,SCNOMAIL
S SCNOMAIL=1
S (SCNEWCNT,SCOLDCNT,SCBADCNT)=0
S SCTOTCNT=$$PASSCNT(DFNA)
I SCTOTCNT=0 G MAIL
;
S DFN=0
F S DFN=$O(@DFNA@(DFN)) Q:'DFN D
.S SCX=$$ACPTTM(.DFN,.SCTM,.SCFIELDA,.SCACT,.SCERR)
.;
.;newly assigned
.I $P(SCX,U,2)=1 D Q
..S SCNEWCNT=SCNEWCNT+1
..S @SCNEWTM@(DFN)=+SCX
..Q
.;
.;already assigned
.I +SCX D Q
..;;;I $P(SCX,U,1)&('$P(SCX,U,2)) D Q
..S SCOLDCNT=SCOLDCNT+1
..S @SCOLDTM@(DFN)=+SCX
..Q
.;
.;not assigned ;;;I 'SCX D
.S @SCBADTM@(DFN)=$P(SCX,U,3)
.S SCBADCNT=SCBADCNT+1
.Q
;
MAIL K SCNOMAIL
D MAILLST^SCMCBK7(SCTM,.SCADDFLD,DT,.SCNEWTM,.SCOLDTM,.SCBADTM,SCTOTCNT)
Q (SCNEWCNT+SCOLDCNT)_U_SCNEWCNT_U_SCOLDCNT_U_SCBADCNT
;
PASSCNT(DFNA) ;count total patients passed to queue
;input: DFNA=tmp array location
;output: count
;
N SCX,DFN
S (SCX,DFN)=0
F S DFN=$O(@DFNA@(DFN)) Q:'DFN S SCX=SCX+1
Q SCX
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCBK5 3444 printed Apr 09, 2024@22:02:54 Page 2
SCMCBK5 ;bp/cmf - multiple patient assignments mail queue - RPCVersion = 1 ;;Aug 7, 1998
+1 ;;5.3;Scheduling;**148,177**;AUG 13, 1993
+2 QUIT
+3 ;
ACPTTM(DFN,SCTM,SCFIELDA,SCACT,SCERR) ;add a patient to a team (pt tm assgn - #404.42
+1 ; input:
+2 ; DFN = pointer to PATIENT file (#2)
+3 ; SCTM = pointer to TEAM file (#404.51)
+4 ; SCFIELDA= array of additional fields to be added
+5 ; SCACT = date to activate [default=DT]
+6 ; SCERR = array NAME to store error messages.
+7 ; [ex. ^TMP("ORXX",$J)]
+8 ;
+9 ; Output:
+10 ; Returned = ien of 404.42 - 0 if none after^new?^Message
+11 ;
+12 NEW SCPTTM,SCESEQ,SCPARM,SCIEN,SC,SCFLD,SCNEWTM,SCMESS,SCX
+13 ;
+14 ;check/setup variables
+15 IF '$$OKDATA^SCAPMC6()
SET SCMESS=$$S(9)
GOTO APTTMQ
+16 ;
+17 ;is patient deceased?
+18 IF $$DP^SCMCBK6(DFN)
SET SCMESS=$$S(1)
GOTO APTTMQ
+19 ;
+20 ;can PC assignment be made?
+21 IF $$T1()
Begin DoDot:1
+22 SET SCX=$$OKPTTMPC^SCMCBK6(DFN,SCTM,SCACT)
+23 ; ;like $$OKPTTMPC^SCMCTMU2(...
+24 QUIT
End DoDot:1
IF 'SCX
SET SCMESS=$PIECE(SCX,U,2)
GOTO APTTMQ
+25 ;
+26 ;is pt already assignmed to team?
+27 SET SCPTTM=$$PTTMACT^SCAPMC6(DFN,SCTM,SCACT,.SCERR)
+28 IF SCPTTM
SET SCMESS=$$S(10)
GOTO APTTMQ
+29 ;
+30 IF $DATA(SCFIELDA)
Begin DoDot:1
+31 SET SCFLD=0
+32 FOR
SET SCFLD=$ORDER(@SCFIELDA@(SCFLD))
if 'SCFLD
QUIT
Begin DoDot:2
+33 SET SC($JOB,404.42,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
+34 QUIT
End DoDot:2
+35 QUIT
End DoDot:1
+36 ;
+37 SET SC($JOB,404.42,"+1,",.01)=DFN
+38 SET SC($JOB,404.42,"+1,",.02)=SCACT
+39 SET SC($JOB,404.42,"+1,",.03)=SCTM
+40 NEW SCTMERR
+41 DO UPDATE^DIE("","SC($J)","SCIEN","SCTMERR")
+42 ;
+43 IF $DATA(SCTMERR)
SET SCMESS=$$S(11)
KILL SCIEN
+44 IF '$TEST
Begin DoDot:1
+45 SET SCPTTM=$GET(SCIEN(1))
+46 SET SCNEWTM=1
+47 DO AFTERTM^SCMCDD1(SCPTTM)
+48 QUIT
End DoDot:1
+49 ;
APTTMQ QUIT +$GET(SCPTTM)_U_+$GET(SCNEWTM)_U_$GET(SCMESS)
+1 ;
T1() QUIT $SELECT('$DATA(SCFIELDA):0,('($DATA(@SCFIELDA@(.08))#2)):0,($GET(@SCFIELDA@(.08))=1):1,1:0)
+1 ;
S(SCX) QUIT $$S^SCMCBK6(SCX)
+1 ;
ACPTATM(DFNA,SCTM,SCFIELDA,SCACT,SCERR,SCNEWTM,SCOLDTM,SCBADTM) ;list of patients assigned to a team (404.42)
+1 ; input: as per ACPTTM (above with the following change:)
+2 ; DFNA = is the literal value of a patient array (e.g. "scpt"
+3 ; there is at least one scpt(dfn)="" defined
+4 ; SCNEWTM = Subset of DFNA that was NEWLY assigned to Team [returned]
+5 ; SCOLDTM = Subset of DFNA that was already assigned -Team [returned]
+6 ; SCBADTP = Subset of DFNA that was NOT assigned to Team [returned]
+7 ; Note: The above three arrays return data in a user determined array
+8 ;
+9 ; output: Count of Patients:
+10 ; 1 2 3 4
+11 ; total assigned^newly assigned^assigned prior^not assigned
+12 ;
+13 NEW DFN,SCNEWCNT,SCOLDCNT,SCBADCNT,SCTOTCNT,SCX,SCNOMAIL
+14 SET SCNOMAIL=1
+15 SET (SCNEWCNT,SCOLDCNT,SCBADCNT)=0
+16 SET SCTOTCNT=$$PASSCNT(DFNA)
+17 IF SCTOTCNT=0
GOTO MAIL
+18 ;
+19 SET DFN=0
+20 FOR
SET DFN=$ORDER(@DFNA@(DFN))
if 'DFN
QUIT
Begin DoDot:1
+21 SET SCX=$$ACPTTM(.DFN,.SCTM,.SCFIELDA,.SCACT,.SCERR)
+22 ;
+23 ;newly assigned
+24 IF $PIECE(SCX,U,2)=1
Begin DoDot:2
+25 SET SCNEWCNT=SCNEWCNT+1
+26 SET @SCNEWTM@(DFN)=+SCX
+27 QUIT
End DoDot:2
QUIT
+28 ;
+29 ;already assigned
+30 IF +SCX
Begin DoDot:2
+31 ;;;I $P(SCX,U,1)&('$P(SCX,U,2)) D Q
+32 SET SCOLDCNT=SCOLDCNT+1
+33 SET @SCOLDTM@(DFN)=+SCX
+34 QUIT
End DoDot:2
QUIT
+35 ;
+36 ;not assigned ;;;I 'SCX D
+37 SET @SCBADTM@(DFN)=$PIECE(SCX,U,3)
+38 SET SCBADCNT=SCBADCNT+1
+39 QUIT
End DoDot:1
+40 ;
MAIL KILL SCNOMAIL
+1 DO MAILLST^SCMCBK7(SCTM,.SCADDFLD,DT,.SCNEWTM,.SCOLDTM,.SCBADTM,SCTOTCNT)
+2 QUIT (SCNEWCNT+SCOLDCNT)_U_SCNEWCNT_U_SCOLDCNT_U_SCBADCNT
+3 ;
PASSCNT(DFNA) ;count total patients passed to queue
+1 ;input: DFNA=tmp array location
+2 ;output: count
+3 ;
+4 NEW SCX,DFN
+5 SET (SCX,DFN)=0
+6 FOR
SET DFN=$ORDER(@DFNA@(DFN))
if 'DFN
QUIT
SET SCX=SCX+1
+7 QUIT SCX
+8 ;
