SCMCBK ;ALB/SCK - Broker Utilities for multiple patient assignments; 4/8/96 ; 11/30/11 4:23pm
;;5.3;Scheduling;**41,51,148,157,177,205,564**;AUG 13, 1993;Build 8
;
Q
;
PTCLBLD(SCOK,SC) ; Build patient list for a selected clinic
; 'SC BLD PAT CLN LIST'
;
D NEWVAR^SCMCBK1
D CHK^SCUTBK
D TMP^SCUTBK
;
D PARSE^SCMCBK1(.SC)
;
I SCPOS'="" S SCOK=$$PTCLBRTP^SCAPMC26(.SCCLN,.SCPOS,"SCDTRNG")
E S SCOK=$$PTCLBR^SCAPMC26(.SCCLN,.SCTEAM,"SCDTRNG")
K ^TMP("SCMC",$J,"EXCLUDE PT")
G:SCOK=0 PTCLNQ
;
M ^TMP($J,"SC PCMM IN")=^TMP(SCOK,"SCCLPT")
K ^TMP(SCOK,"SCCLPT")
;
D ALPHA^SCAPMCU2("^TMP($J,""SC PCMM IN"")","^TMP($J,""SCCLPT"")")
;
S SCOK=$J_U_^TMP($J,"SC PCMM IN",0)
;
PTCLNQ D CLRVAR^SCMCBK1
Q
;
PTSCBLD(SCOK,SC) ; Build patient list for selected stop code
; 'SC BLD PAT SCDE LIST'
;
D NEWVAR^SCMCBK1
;
D CHK^SCUTBK
D TMP^SCUTBK
;
D PARSE^SCMCBK1(.SC)
;
K ^TMP($J,"SCSCDE")
;
; Build exclude list
S BLOCK=$S(SCPOS'="":"BLKPOS",1:"BLKTM")
S SCBLOCK=$S(SCPOS'="":SCPOS,1:SCTEAM)
D @BLOCK
;
IF 'SCOK1 S SCOK="0^0^0^0" G PTSCQ
;
S SCOK=0
S SCOK=$$PTST^SCAPMC27(SCSCDE,"SCDTRNG",SCNUM,.SCLOC,"SCERMSG",SCMORE)
K ^TMP("SCMC",$J,"EXCLUDE PT")
;
M ^TMP($J,"SC PCMM IN")=@SCLOC
S I1=$G(^TMP($J,"SC PCMM IN",0))
F I=1:1:I1 S ^TMP($J,"PCMM TMP",I)=$G(^TMP($J,"SC PCMM IN",I))
;
D ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCSCDE"")")
S SCOK=$J_U_+I1_U_SCOK
;
PTSCQ D CLRVAR^SCMCBK1
Q
;
PTTMBLD(SCOK,SC) ; Build a list of patients for a selected team and return the $J of the TMP globall
; where the list is stored.
; ' SC BLD PAT TM LIST '
;
D NEWVAR^SCMCBK1
D CHK^SCUTBK
D TMP^SCUTBK
;
D PARSE^SCMCBK1(.SC)
K ^TMP($J,"SCTEAM")
;
; Build exclude list
S SCOK=0
S BLOCK=$S(SCPOS'="":"BLKPOS",1:"BLKTM")
S SCBLOCK=$S(SCPOS'="":SCPOS,1:SCTEAM)
D @BLOCK
;
S SCOK=$$PTTM^SCAPMC2(SCFRMTM,"SCDTRNG",.SCLOC,"SCERMSG")
K ^TMP("SCMC",$J,"EXCLUDE PT")
M ^TMP($J,"SC PCMM IN")=@SCLOC
;
S I="" F S I=$O(^TMP($J,"SC PCMM IN",I)) Q:'I D
. S ^TMP($J,"PCMM TMP",I)=^TMP($J,"SC PCMM IN",I)
;
D ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCTEAM"")")
S I1="" F S I1=$O(^TMP($J,"SCTEAM",I1)) Q:'I1 S I=I1
;
S SCOK=$J_U_+I_U_SCOK
;
D CLRVAR^SCMCBK1
Q
;
PTPSBLD(SCOK,SC) ;
; ' SC BLD PAT POS LIST '
;
D NEWVAR^SCMCBK1
D CHK^SCUTBK
D TMP^SCUTBK
;
D PARSE^SCMCBK1(.SC)
;
K ^TMP($J,"SCPOS")
;
; Build exclude list
S BLOCK=$S(SCPOS'="":"BLKPOS",1:"BLKTM")
S SCBLOCK=$S(SCPOS'="":SCPOS,1:SCTEAM)
D @BLOCK
;
S SCOK=0
;
S SCOK=$$PTTP^SCAPMC11(SCFRMPOS,"SCDTRNG",.SCLOC,.SCERMSG)
K ^TMP("SCMC",$J,"EXCLUDE PT")
M ^TMP($J,"SC PCMM IN")=@SCLOC
;
S I1=$G(^TMP($J,"SC PCMM IN",0))
F I=1:1:I1 S ^TMP($J,"PCMM TMP",I)=$G(^TMP($J,"SC PCMM IN",I))
D ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCPOS"")")
S SCOK=$J_U_+I1_U_SCOK
;
;IF '+$G(^TMP($J,"SCPOS",0)) D S SCOK=$J_U_SCOK
;. S I="" F S I=$O(^TMP($J,"SCPOS",I)) Q:'I S SCOK=I
;
D CLRVAR^SCMCBK1
Q
;
PTAPBLD(SCOK,SC) ; Build patient list for selected appointment range.
; ' SC BLD PAT APT LIST '
;
;SD/564-this build includes modification as follows:
;- patients already assigned to another PC team then evaluated team SCTEAM are excluded
;- patients previously assigned and unassigned to evaluated position are included
;
;N SCCLN,SCTEAM,SCDTRNG,SCLOC,SCERMSG,SCNUM,SCCOUNT,SCMORE,SCOK1,SCER2,SCOUT,SCBLOCK
;
D NEWVAR^SCMCBK1
D CHK^SCUTBK
D TMP^SCUTBK
;
D PARSE^SCMCBK1(.SC)
;
K ^TMP($J,"SCCLN")
;
; Build exclude list
S BLOCK=$S(SCPOS'="":"BLKPOS",1:"BLKTM")
S SCBLOCK=$S(SCPOS'="":SCPOS,1:SCTEAM)
D @BLOCK
;
IF 'SCOK1 S SCOK="0^0^0^0" G PTAPQ
S SCOK=0
S SCOK=$$PTAP^SCAPMC28(SCCLN,"SCDTRNG",SCNUM,.SCLOC,"SCERMSG",SCMORE)
;
;identify excluded to be included if unassigned from evaluated position-sd/564
N SCTMP S SCTMP=$G(^TMP("SC TMP LIST",$J,0))
N SS S SS=$G(^TMP("SCMC",$J,"EXCLUDE PT",0))
N SDFN,XX F XX=1:1:SS S SDFN=+$G(^TMP("SCMC",$J,"EXCLUDE PT",XX)) D
.N SCI S SCI=^TMP("SCMC",$J,"EXCLUDE PT",XX) D
..N SCII S SCII=$P(SCI,U,5) I SCII>0&(SCII<(DT+1)) D
...;PROCEED ONLY WITH THE CURRENT MONTH ASSIGNMENT
...N SCAS S SCAS=$P(SCI,U,4) I SCAS>0 I $E(DT,1,5)'=$E(SCAS,1,5) Q
...N SCPOS S SCPOS=$P(SCI,U,3) I SCPOS>0 I $P(^SCPT(404.43,SCPOS,0),U,2)'=$G(SC("POSITION")) Q
...N SCN,SCS S SCN=$P(SCI,U,2),SCS=$P(SCI,U,6)
...S SCTMP=SCTMP+1
...S ^TMP("SC TMP LIST",$J,SCTMP)=SDFN_U_SCN_U_SC("CLINIC")_U_U_SCS
...S ^TMP("SC TMP LIST",$J,"SCPTAP",SDFN,SCTMP)=""
S ^TMP("SC TMP LIST",$J,0)=SCTMP
;
K ^TMP("SCMC",$J,"EXCLUDE PT")
;
;eliminate patients if assigned to another PC team-SD/564
N DFN S DFN="" F S DFN=$O(^TMP("SC TMP LIST",$J,"SCPTAP",DFN)) Q:DFN="" D
.N SCEX S SCEX=$$GETPC^SCAPMCU2(DFN) ;call to get patient's PC assignment
.N NSAS S NSAS=$P(SCEX,U,2) I +SCEX>0!(NSAS>0&(NSAS'=SCTEAM)) D
..N SCN S SCN=$O(^TMP("SC TMP LIST",$J,"SCPTAP",DFN,""))
..K ^TMP("SC TMP LIST",$J,"SCPTAP",DFN)
..K ^TMP("SC TMP LIST",$J,SCN)
..S ^TMP("SC TMP LIST",$J,0)=^TMP("SC TMP LIST",$J,0)-1
;
M ^TMP($J,"SC PCMM IN")=@SCLOC
S I1=$G(^TMP($J,"SC PCMM IN",0))
;reindex entries in ^TMP global list - SD/564
N SCC S SCC=0 F I=1:1:I1 S SCC=$O(^TMP($J,"SC PCMM IN",SCC)) D
.S ^TMP($J,"PCMM TMP",I)=^TMP($J,"SC PCMM IN",SCC)
;
D ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCAPP"")")
S SCOK=$J_U_I1_U_SCOK
;
D CLRVAR^SCMCBK1
PTAPQ Q
;
PTGET(SCDATA,SC) ; Return a block of patients to the client
; 'SC GET PAT BLOCK'
;
; SCJOB = $J for the ^TMP global
; SCJOBID = The second subscript id for the ^TMP global
; SCSTART = Beginning entry number for the block retrieval in the ^TMP global
; SCEND = The ending entry number for the block retrieval
; SCLAST = The last entry number in the ^TMP global
;
N SCJOB,SCSTART,SCEND,I,SCLAST,SCJOBID
;
D CHK^SCUTBK
D TMP^SCUTBK
;
D PARSE^SCMCBK1(.SC)
;
F I=SCSTART:1:SCEND Q:'$G(^TMP(SCJOB,SCJOBID,I),0) D
. S SCDATA(I)=^TMP(SCJOB,SCJOBID,I)
I SCEND>SCLAST K ^TMP(SCJOB,SCJOBID)
;
D CLRVAR^SCMCBK1
Q
;
PTLSTBLD(SCOK,SCVAL) ; Build the list of patients to be assigned in the ^TMP($J,"SC PATIENT LIST",DFN) global
; 'SC BLD PAT LIST'
;
N SCJOB,SCDFN
;
D CHK^SCUTBK
D TMP^SCUTBK
;
S SCOK=0
I SCVAL["Start" D G PTBLDQ
.S SCOK=$J
.K ^TMP(SCOK,"SC PATIENT LIST")
;
S SCJOB=$P(SCVAL,U,1)
S SCDFN=$P(SCVAL,U,2)
S ^TMP(SCJOB,"SC PATIENT LIST",SCDFN)=""
S SCOK=1
PTBLDQ Q
;
PTFILE(SCOK,SC) ; File the patient assignments in the ^TMP($J,"SC TEAM ASSIGN",SCDFN) global
; 'SC FILE PAT TM ASGN'
;
;205 remove;I XWBAPVER=177 D QUEUED^SCMCBK4(1) Q
;205 remove;I $$VPROGMR^SCUTBK3()'=1 Q
; pre 177 code follows....
I XWBAPVER=1 D QUEUED^SCMCBK4(1) Q
;
N SCADDFLD,SCTEAM,SCFILE,SCJOB,SCNEW,SCOLD,SCBAD,SCERMSG,SCX,SCDTVAR
;
D CHK^SCUTBK
D TMP^SCUTBK
;
D PARSE^SCMCBK1(.SC)
G:+$G(SCJOB)=0 FILEQ
;
;
S SCADDFLD(.08)=$G(SC("TYPE"),99)
S SCADDFLD(.1)=$G(SC("RESTRICT"),0)
S SCADDFLD(.11)=DUZ
S SCADDFLD(.12)=DT
;
S SCX=$$ACPTATM^SCAPMC6("^TMP(SCJOB,""SC PATIENT LIST"")",SCTEAM,"SCADDFLD",SCDTVAR,"SCERMSG","SCNEW","SCOLD","SCBAD")
D BAD^SCMCBK1(.SCBAD,.SCOLD,.SCOK)
S SCOK(.1)=SCX
;
K ^TMP(SCJOB,"SC PATIENT LIST")
;
D CLRVAR^SCMCBK1
FILEQ Q
;
POSFILE(SCOK,SC) ; File the patient assignments in the ^TMP($J,"SC PATIENT LIST") global
; ' SC FILE PAT POS ASGN '
;
;205 remove;I XWBAPVER=177 D QUEUED^SCMCBK4(2) Q
;205 remove;I $$VPROGMR^SCUTBK3()'=1 Q
; pre 177 code follows...
I XWBAPVER=1 D QUEUED^SCMCBK4(2) Q
;
N SCADDFLD,SCTEAM,SCFILE,SCJOB,SCNEW,SCOLD,SCBAD,SCERMSG,SCX,SCPOS,SCDTVAR,SCMAFLD,SCADTM,SCNEW1
;
D CHK^SCUTBK
D TMP^SCUTBK
;
D PARSE^SCMCBK1(.SC)
G:+$G(SCJOB)=0 FILEQ
S SCADTM=1
;
S SCADDFLD(.05)=$G(SC("TYPE"),0)
S SCADDFLD(.06)=DUZ
S SCADDFLD(.07)=DT
;
S SCX=$$ACPTATP^SCAPMC21("^TMP(SCJOB,""SC PATIENT LIST"")",SCPOS,"SCADDFLD",SCDTVAR,"SCERMSG",SCADTM,"","SCNEW","SCNEW1","SCOLD","SCBAD")
;
D BAD2^SCMCBK1(.SCBAD,.SCOLD,.SCOK)
S SCOK(.1)=SCX
K ^TMP(SCJOB,"SC PATIENT LIST")
;
D CLRVAR^SCMCBK1
Q
;
BLKPOS ;
N SCX
S SCX=$G(SCDTRNG("END"))
S SCDTRNG("END")=3990101 ;check forever
S SCOK1=$$PTTP^SCAPMC(SCBLOCK,"SCDTRNG","^TMP(""SCMC"",$J,""EXCLUDE PT"")","SCER2")
S SCDTRNG("END")=SCX
Q
;
BLKTM ;
N SCX
S SCX=$G(SCDTRNG("END"))
S SCDTRNG("END")=3990101 ;check forever
S SCOK1=$$PTTM^SCAPMC(SCBLOCK,"SCDTRNG","^TMP(""SCMC"",$J,""EXCLUDE PT"")","SCER2")
S SCDTRNG("END")=SCX
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCBK 8690 printed Nov 22, 2024@17:49:47 Page 2
SCMCBK ;ALB/SCK - Broker Utilities for multiple patient assignments; 4/8/96 ; 11/30/11 4:23pm
+1 ;;5.3;Scheduling;**41,51,148,157,177,205,564**;AUG 13, 1993;Build 8
+2 ;
+3 QUIT
+4 ;
PTCLBLD(SCOK,SC) ; Build patient list for a selected clinic
+1 ; 'SC BLD PAT CLN LIST'
+2 ;
+3 DO NEWVAR^SCMCBK1
+4 DO CHK^SCUTBK
+5 DO TMP^SCUTBK
+6 ;
+7 DO PARSE^SCMCBK1(.SC)
+8 ;
+9 IF SCPOS'=""
SET SCOK=$$PTCLBRTP^SCAPMC26(.SCCLN,.SCPOS,"SCDTRNG")
+10 IF '$TEST
SET SCOK=$$PTCLBR^SCAPMC26(.SCCLN,.SCTEAM,"SCDTRNG")
+11 KILL ^TMP("SCMC",$JOB,"EXCLUDE PT")
+12 if SCOK=0
GOTO PTCLNQ
+13 ;
+14 MERGE ^TMP($JOB,"SC PCMM IN")=^TMP(SCOK,"SCCLPT")
+15 KILL ^TMP(SCOK,"SCCLPT")
+16 ;
+17 DO ALPHA^SCAPMCU2("^TMP($J,""SC PCMM IN"")","^TMP($J,""SCCLPT"")")
+18 ;
+19 SET SCOK=$JOB_U_^TMP($JOB,"SC PCMM IN",0)
+20 ;
PTCLNQ DO CLRVAR^SCMCBK1
+1 QUIT
+2 ;
PTSCBLD(SCOK,SC) ; Build patient list for selected stop code
+1 ; 'SC BLD PAT SCDE LIST'
+2 ;
+3 DO NEWVAR^SCMCBK1
+4 ;
+5 DO CHK^SCUTBK
+6 DO TMP^SCUTBK
+7 ;
+8 DO PARSE^SCMCBK1(.SC)
+9 ;
+10 KILL ^TMP($JOB,"SCSCDE")
+11 ;
+12 ; Build exclude list
+13 SET BLOCK=$SELECT(SCPOS'="":"BLKPOS",1:"BLKTM")
+14 SET SCBLOCK=$SELECT(SCPOS'="":SCPOS,1:SCTEAM)
+15 DO @BLOCK
+16 ;
+17 IF 'SCOK1
SET SCOK="0^0^0^0"
GOTO PTSCQ
+18 ;
+19 SET SCOK=0
+20 SET SCOK=$$PTST^SCAPMC27(SCSCDE,"SCDTRNG",SCNUM,.SCLOC,"SCERMSG",SCMORE)
+21 KILL ^TMP("SCMC",$JOB,"EXCLUDE PT")
+22 ;
+23 MERGE ^TMP($JOB,"SC PCMM IN")=@SCLOC
+24 SET I1=$GET(^TMP($JOB,"SC PCMM IN",0))
+25 FOR I=1:1:I1
SET ^TMP($JOB,"PCMM TMP",I)=$GET(^TMP($JOB,"SC PCMM IN",I))
+26 ;
+27 DO ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCSCDE"")")
+28 SET SCOK=$JOB_U_+I1_U_SCOK
+29 ;
PTSCQ DO CLRVAR^SCMCBK1
+1 QUIT
+2 ;
PTTMBLD(SCOK,SC) ; Build a list of patients for a selected team and return the $J of the TMP globall
+1 ; where the list is stored.
+2 ; ' SC BLD PAT TM LIST '
+3 ;
+4 DO NEWVAR^SCMCBK1
+5 DO CHK^SCUTBK
+6 DO TMP^SCUTBK
+7 ;
+8 DO PARSE^SCMCBK1(.SC)
+9 KILL ^TMP($JOB,"SCTEAM")
+10 ;
+11 ; Build exclude list
+12 SET SCOK=0
+13 SET BLOCK=$SELECT(SCPOS'="":"BLKPOS",1:"BLKTM")
+14 SET SCBLOCK=$SELECT(SCPOS'="":SCPOS,1:SCTEAM)
+15 DO @BLOCK
+16 ;
+17 SET SCOK=$$PTTM^SCAPMC2(SCFRMTM,"SCDTRNG",.SCLOC,"SCERMSG")
+18 KILL ^TMP("SCMC",$JOB,"EXCLUDE PT")
+19 MERGE ^TMP($JOB,"SC PCMM IN")=@SCLOC
+20 ;
+21 SET I=""
FOR
SET I=$ORDER(^TMP($JOB,"SC PCMM IN",I))
if 'I
QUIT
Begin DoDot:1
+22 SET ^TMP($JOB,"PCMM TMP",I)=^TMP($JOB,"SC PCMM IN",I)
End DoDot:1
+23 ;
+24 DO ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCTEAM"")")
+25 SET I1=""
FOR
SET I1=$ORDER(^TMP($JOB,"SCTEAM",I1))
if 'I1
QUIT
SET I=I1
+26 ;
+27 SET SCOK=$JOB_U_+I_U_SCOK
+28 ;
+29 DO CLRVAR^SCMCBK1
+30 QUIT
+31 ;
PTPSBLD(SCOK,SC) ;
+1 ; ' SC BLD PAT POS LIST '
+2 ;
+3 DO NEWVAR^SCMCBK1
+4 DO CHK^SCUTBK
+5 DO TMP^SCUTBK
+6 ;
+7 DO PARSE^SCMCBK1(.SC)
+8 ;
+9 KILL ^TMP($JOB,"SCPOS")
+10 ;
+11 ; Build exclude list
+12 SET BLOCK=$SELECT(SCPOS'="":"BLKPOS",1:"BLKTM")
+13 SET SCBLOCK=$SELECT(SCPOS'="":SCPOS,1:SCTEAM)
+14 DO @BLOCK
+15 ;
+16 SET SCOK=0
+17 ;
+18 SET SCOK=$$PTTP^SCAPMC11(SCFRMPOS,"SCDTRNG",.SCLOC,.SCERMSG)
+19 KILL ^TMP("SCMC",$JOB,"EXCLUDE PT")
+20 MERGE ^TMP($JOB,"SC PCMM IN")=@SCLOC
+21 ;
+22 SET I1=$GET(^TMP($JOB,"SC PCMM IN",0))
+23 FOR I=1:1:I1
SET ^TMP($JOB,"PCMM TMP",I)=$GET(^TMP($JOB,"SC PCMM IN",I))
+24 DO ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCPOS"")")
+25 SET SCOK=$JOB_U_+I1_U_SCOK
+26 ;
+27 ;IF '+$G(^TMP($J,"SCPOS",0)) D S SCOK=$J_U_SCOK
+28 ;. S I="" F S I=$O(^TMP($J,"SCPOS",I)) Q:'I S SCOK=I
+29 ;
+30 DO CLRVAR^SCMCBK1
+31 QUIT
+32 ;
PTAPBLD(SCOK,SC) ; Build patient list for selected appointment range.
+1 ; ' SC BLD PAT APT LIST '
+2 ;
+3 ;SD/564-this build includes modification as follows:
+4 ;- patients already assigned to another PC team then evaluated team SCTEAM are excluded
+5 ;- patients previously assigned and unassigned to evaluated position are included
+6 ;
+7 ;N SCCLN,SCTEAM,SCDTRNG,SCLOC,SCERMSG,SCNUM,SCCOUNT,SCMORE,SCOK1,SCER2,SCOUT,SCBLOCK
+8 ;
+9 DO NEWVAR^SCMCBK1
+10 DO CHK^SCUTBK
+11 DO TMP^SCUTBK
+12 ;
+13 DO PARSE^SCMCBK1(.SC)
+14 ;
+15 KILL ^TMP($JOB,"SCCLN")
+16 ;
+17 ; Build exclude list
+18 SET BLOCK=$SELECT(SCPOS'="":"BLKPOS",1:"BLKTM")
+19 SET SCBLOCK=$SELECT(SCPOS'="":SCPOS,1:SCTEAM)
+20 DO @BLOCK
+21 ;
+22 IF 'SCOK1
SET SCOK="0^0^0^0"
GOTO PTAPQ
+23 SET SCOK=0
+24 SET SCOK=$$PTAP^SCAPMC28(SCCLN,"SCDTRNG",SCNUM,.SCLOC,"SCERMSG",SCMORE)
+25 ;
+26 ;identify excluded to be included if unassigned from evaluated position-sd/564
+27 NEW SCTMP
SET SCTMP=$GET(^TMP("SC TMP LIST",$JOB,0))
+28 NEW SS
SET SS=$GET(^TMP("SCMC",$JOB,"EXCLUDE PT",0))
+29 NEW SDFN,XX
FOR XX=1:1:SS
SET SDFN=+$GET(^TMP("SCMC",$JOB,"EXCLUDE PT",XX))
Begin DoDot:1
+30 NEW SCI
SET SCI=^TMP("SCMC",$JOB,"EXCLUDE PT",XX)
Begin DoDot:2
+31 NEW SCII
SET SCII=$PIECE(SCI,U,5)
IF SCII>0&(SCII<(DT+1))
Begin DoDot:3
+32 ;PROCEED ONLY WITH THE CURRENT MONTH ASSIGNMENT
+33 NEW SCAS
SET SCAS=$PIECE(SCI,U,4)
IF SCAS>0
IF $EXTRACT(DT,1,5)'=$EXTRACT(SCAS,1,5)
QUIT
+34 NEW SCPOS
SET SCPOS=$PIECE(SCI,U,3)
IF SCPOS>0
IF $PIECE(^SCPT(404.43,SCPOS,0),U,2)'=$GET(SC("POSITION"))
QUIT
+35 NEW SCN,SCS
SET SCN=$PIECE(SCI,U,2)
SET SCS=$PIECE(SCI,U,6)
+36 SET SCTMP=SCTMP+1
+37 SET ^TMP("SC TMP LIST",$JOB,SCTMP)=SDFN_U_SCN_U_SC("CLINIC")_U_U_SCS
+38 SET ^TMP("SC TMP LIST",$JOB,"SCPTAP",SDFN,SCTMP)=""
End DoDot:3
End DoDot:2
End DoDot:1
+39 SET ^TMP("SC TMP LIST",$JOB,0)=SCTMP
+40 ;
+41 KILL ^TMP("SCMC",$JOB,"EXCLUDE PT")
+42 ;
+43 ;eliminate patients if assigned to another PC team-SD/564
+44 NEW DFN
SET DFN=""
FOR
SET DFN=$ORDER(^TMP("SC TMP LIST",$JOB,"SCPTAP",DFN))
if DFN=""
QUIT
Begin DoDot:1
+45 ;call to get patient's PC assignment
NEW SCEX
SET SCEX=$$GETPC^SCAPMCU2(DFN)
+46 NEW NSAS
SET NSAS=$PIECE(SCEX,U,2)
IF +SCEX>0!(NSAS>0&(NSAS'=SCTEAM))
Begin DoDot:2
+47 NEW SCN
SET SCN=$ORDER(^TMP("SC TMP LIST",$JOB,"SCPTAP",DFN,""))
+48 KILL ^TMP("SC TMP LIST",$JOB,"SCPTAP",DFN)
+49 KILL ^TMP("SC TMP LIST",$JOB,SCN)
+50 SET ^TMP("SC TMP LIST",$JOB,0)=^TMP("SC TMP LIST",$JOB,0)-1
End DoDot:2
End DoDot:1
+51 ;
+52 MERGE ^TMP($JOB,"SC PCMM IN")=@SCLOC
+53 SET I1=$GET(^TMP($JOB,"SC PCMM IN",0))
+54 ;reindex entries in ^TMP global list - SD/564
+55 NEW SCC
SET SCC=0
FOR I=1:1:I1
SET SCC=$ORDER(^TMP($JOB,"SC PCMM IN",SCC))
Begin DoDot:1
+56 SET ^TMP($JOB,"PCMM TMP",I)=^TMP($JOB,"SC PCMM IN",SCC)
End DoDot:1
+57 ;
+58 DO ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCAPP"")")
+59 SET SCOK=$JOB_U_I1_U_SCOK
+60 ;
+61 DO CLRVAR^SCMCBK1
PTAPQ QUIT
+1 ;
PTGET(SCDATA,SC) ; Return a block of patients to the client
+1 ; 'SC GET PAT BLOCK'
+2 ;
+3 ; SCJOB = $J for the ^TMP global
+4 ; SCJOBID = The second subscript id for the ^TMP global
+5 ; SCSTART = Beginning entry number for the block retrieval in the ^TMP global
+6 ; SCEND = The ending entry number for the block retrieval
+7 ; SCLAST = The last entry number in the ^TMP global
+8 ;
+9 NEW SCJOB,SCSTART,SCEND,I,SCLAST,SCJOBID
+10 ;
+11 DO CHK^SCUTBK
+12 DO TMP^SCUTBK
+13 ;
+14 DO PARSE^SCMCBK1(.SC)
+15 ;
+16 FOR I=SCSTART:1:SCEND
if '$GET(^TMP(SCJOB,SCJOBID,I),0)
QUIT
Begin DoDot:1
+17 SET SCDATA(I)=^TMP(SCJOB,SCJOBID,I)
End DoDot:1
+18 IF SCEND>SCLAST
KILL ^TMP(SCJOB,SCJOBID)
+19 ;
+20 DO CLRVAR^SCMCBK1
+21 QUIT
+22 ;
PTLSTBLD(SCOK,SCVAL) ; Build the list of patients to be assigned in the ^TMP($J,"SC PATIENT LIST",DFN) global
+1 ; 'SC BLD PAT LIST'
+2 ;
+3 NEW SCJOB,SCDFN
+4 ;
+5 DO CHK^SCUTBK
+6 DO TMP^SCUTBK
+7 ;
+8 SET SCOK=0
+9 IF SCVAL["Start"
Begin DoDot:1
+10 SET SCOK=$JOB
+11 KILL ^TMP(SCOK,"SC PATIENT LIST")
End DoDot:1
GOTO PTBLDQ
+12 ;
+13 SET SCJOB=$PIECE(SCVAL,U,1)
+14 SET SCDFN=$PIECE(SCVAL,U,2)
+15 SET ^TMP(SCJOB,"SC PATIENT LIST",SCDFN)=""
+16 SET SCOK=1
PTBLDQ QUIT
+1 ;
PTFILE(SCOK,SC) ; File the patient assignments in the ^TMP($J,"SC TEAM ASSIGN",SCDFN) global
+1 ; 'SC FILE PAT TM ASGN'
+2 ;
+3 ;205 remove;I XWBAPVER=177 D QUEUED^SCMCBK4(1) Q
+4 ;205 remove;I $$VPROGMR^SCUTBK3()'=1 Q
+5 ; pre 177 code follows....
+6 IF XWBAPVER=1
DO QUEUED^SCMCBK4(1)
QUIT
+7 ;
+8 NEW SCADDFLD,SCTEAM,SCFILE,SCJOB,SCNEW,SCOLD,SCBAD,SCERMSG,SCX,SCDTVAR
+9 ;
+10 DO CHK^SCUTBK
+11 DO TMP^SCUTBK
+12 ;
+13 DO PARSE^SCMCBK1(.SC)
+14 if +$GET(SCJOB)=0
GOTO FILEQ
+15 ;
+16 ;
+17 SET SCADDFLD(.08)=$GET(SC("TYPE"),99)
+18 SET SCADDFLD(.1)=$GET(SC("RESTRICT"),0)
+19 SET SCADDFLD(.11)=DUZ
+20 SET SCADDFLD(.12)=DT
+21 ;
+22 SET SCX=$$ACPTATM^SCAPMC6("^TMP(SCJOB,""SC PATIENT LIST"")",SCTEAM,"SCADDFLD",SCDTVAR,"SCERMSG","SCNEW","SCOLD","SCBAD")
+23 DO BAD^SCMCBK1(.SCBAD,.SCOLD,.SCOK)
+24 SET SCOK(.1)=SCX
+25 ;
+26 KILL ^TMP(SCJOB,"SC PATIENT LIST")
+27 ;
+28 DO CLRVAR^SCMCBK1
FILEQ QUIT
+1 ;
POSFILE(SCOK,SC) ; File the patient assignments in the ^TMP($J,"SC PATIENT LIST") global
+1 ; ' SC FILE PAT POS ASGN '
+2 ;
+3 ;205 remove;I XWBAPVER=177 D QUEUED^SCMCBK4(2) Q
+4 ;205 remove;I $$VPROGMR^SCUTBK3()'=1 Q
+5 ; pre 177 code follows...
+6 IF XWBAPVER=1
DO QUEUED^SCMCBK4(2)
QUIT
+7 ;
+8 NEW SCADDFLD,SCTEAM,SCFILE,SCJOB,SCNEW,SCOLD,SCBAD,SCERMSG,SCX,SCPOS,SCDTVAR,SCMAFLD,SCADTM,SCNEW1
+9 ;
+10 DO CHK^SCUTBK
+11 DO TMP^SCUTBK
+12 ;
+13 DO PARSE^SCMCBK1(.SC)
+14 if +$GET(SCJOB)=0
GOTO FILEQ
+15 SET SCADTM=1
+16 ;
+17 SET SCADDFLD(.05)=$GET(SC("TYPE"),0)
+18 SET SCADDFLD(.06)=DUZ
+19 SET SCADDFLD(.07)=DT
+20 ;
+21 SET SCX=$$ACPTATP^SCAPMC21("^TMP(SCJOB,""SC PATIENT LIST"")",SCPOS,"SCADDFLD",SCDTVAR,"SCERMSG",SCADTM,"","SCNEW","SCNEW1","SCOLD","SCBAD")
+22 ;
+23 DO BAD2^SCMCBK1(.SCBAD,.SCOLD,.SCOK)
+24 SET SCOK(.1)=SCX
+25 KILL ^TMP(SCJOB,"SC PATIENT LIST")
+26 ;
+27 DO CLRVAR^SCMCBK1
+28 QUIT
+29 ;
BLKPOS ;
+1 NEW SCX
+2 SET SCX=$GET(SCDTRNG("END"))
+3 ;check forever
SET SCDTRNG("END")=3990101
+4 SET SCOK1=$$PTTP^SCAPMC(SCBLOCK,"SCDTRNG","^TMP(""SCMC"",$J,""EXCLUDE PT"")","SCER2")
+5 SET SCDTRNG("END")=SCX
+6 QUIT
+7 ;
BLKTM ;
+1 NEW SCX
+2 SET SCX=$GET(SCDTRNG("END"))
+3 ;check forever
SET SCDTRNG("END")=3990101
+4 SET SCOK1=$$PTTM^SCAPMC(SCBLOCK,"SCDTRNG","^TMP(""SCMC"",$J,""EXCLUDE PT"")","SCER2")
+5 SET SCDTRNG("END")=SCX
+6 QUIT
+7 ;
