SCMCCV ;ALB/REW - PCMM Conversion of Patient File Fields ; 1 Feb 1996
;;5.3;Scheduling;**41**;AUG 13, 1993
EN ;
; Variables:
; SCASSIGN: 1=Make Patient Assignments if unambiguous (0=No,default)
; SCDT: Date to make assignments (Default=DT)
; SCYESTM: 1=Make Pt Tm as well as Pt Posit Assmnts,default(0=No)
; SCNOPRPT 1=Don't print patient-detail lines
;
N SCOK,DFN,SCPCNODE,SCLIST,SCTMPLST,SCHISTAR,SCASSIGN,SCYESTM,SCTM,Y,SCSTOP,SCPAGE,SCNOPRPT,SCTEAMAR,SCNOW,SCSUB
N SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS
IF '$$OKASK D MESS("Search aborted","!?5") G QTEN
IF '$D(IO("Q")) D
.U IO
.D REP
.D ^%ZISC
ELSE D
.F X="SCASSIGN","SCYESTM","SCDT","SCNOPRPT" S ZTSAVE(X)=""
.S Y=$$QUE("SC Patient-Team/Practitioner"_$S('SCASSIGN:"Report Only",1:"Report and Assignment"),"REP^SCMCCV")
QTEN Q
;
OKASK() ;
N SCOK,DIR
;do you want to assign or just get a report?
S DIR(0)="Y"
S DIR("B")="NO"
S DIR("A")="Do you want to assign patients right now?"
S DIR("A",1)=""
S DIR("A",2)=""
S DIR("A",3)=" YES = Assign Patients to Teams and Team Positions"
S DIR("A",4)=" NO = Just print report to see how things would be"
D ^DIR
IF $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S SCOK=0 G QTASK
S SCASSIGN=Y
;do you want to omit printing patients?
S DIR(0)="Y"
S DIR("B")="YES"
S DIR("A")="Do you want to omit printing patients?"
S DIR("A",1)=""
S DIR("A",2)=""
S DIR("A",3)=" NO = Print detail line for each patient that is assignable"
S DIR("A",4)=" YES = Just print Team & Practitioner information"
D ^DIR
IF $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S SCOK=0 G QTASK
S SCNOPRPT=Y
IF '$D(SCASSIGN) S SCASSIGN=0
IF '$D(SCDT) S SCDT=DT
IF '$D(SCYESTM) S SCYESTM=1
S SCOK=$$GETDEV
QTASK Q SCOK
;
REP ;non-interactive portion
Q:$$FIRST^SCMCRU ;check for task end
IF '$$OKINIT() G QTEN
D MESS(" ..Ok")
IF '$$OKBUILD G QRP
D MESS(" ..Ok")
IF '$$OKREPORT G QRP
D MESS(" ..Ok")
IF '$$OKCLEAN G QRP
D MESS(" ..Ok")
QRP Q
;
OKINIT() ;
N SCOK
S SCOK=1
D MESS(">>> Checking Programmer Variables:","!,?5")
IF +$G(DUZ)'>0!($G(U)'="^")!('$D(DT)) D Q 0
. S XPDABORT=1
. D MESS("You must first initialize Programmer Environment by running ^XUP")
. S SCOK=0
S SCLIST="SCTMPLST"
D INIT^SCAPMCU1(.SCOK)
D NOW^%DTC
S SCNOW=%
S SCHISTAR(.05)=1 ;pc practitioner
S SCHISTAR(.06)=DUZ ;user entering
S SCHISTAR(.07)=SCNOW ;date entered
S SCTEAMAR(.08)=1 ;pc team
S SCTEAMAR(.11)=DUZ ;user
S SCTEAMAR(.12)=SCNOW ;date enter=now
Q SCOK
;
OKBUILD() ;
N SCOK
S SCOK=1
D MESS(">>> Looping through PC Nodes of PATIENT File","!,?5")
S DFN=0
F S DFN=$O(^DPT(DFN)) Q:'DFN S SCPCNODE=$G(^DPT(DFN,"PC")) IF SCPCNODE]"" D D:'(DFN#100) MESS(".")
.S ^TMP("SCMC",$J,"TMPRPT",+$P(SCPCNODE,U,2),+$P(SCPCNODE,U,1),DFN)=""
Q SCOK
;
OKREPORT() ;
N SCOK,SCTM,SCPR,SCTMNODE
S SCOK=1
D MESS(">>> Producing PATIENT File PC Report","!?5")
D MESS(" Checking Team/Practitioner Assignments:","!?10")
S SCTM=0
F S SCTM=$O(^TMP("SCMC",$J,"TMPRPT",SCTM)) Q:'SCTM!$G(SCSTOP) D
.S SCTMNODE=$G(^SCTM(404.51,SCTM,0))
.D MESS(">>>Team: "_$$DISPTM(SCTM),"!!?10")
.IF '$$OKTEAM(SCTM,SCDT) D
..S SCOK=0
..;D MESS("Problem(s) with Practitioner Assignments","!?15")
Q SCOK
;
OKTEAM(SCTM,SCDT) ;return 1 if exactly 1 posit for each team assignment
;needs 'tmp('scmc',$j,'tmpr' array defined
;return count of positions pract is assigned to to team
N SCOK,SC200,SCTMND,SCFLD,SCF
S SCOK=1
S SCTMND=$G(^SCTM(404.51,+$G(SCTM),0))
F SCFLD=3,6,7 IF '$P(SCTMND,U,SCFLD) D ;check required fields
.S SCOK=0
.S SCF=$$DDNAME^SCMCRU(404.51,(SCFLD*.01))
.D MESS(SCF_" (#"_(SCFLD*.01)_") of Team required. Enter via PCMM ","!?20")
G:'SCOK QTOKTM
S SCOK=$$ACTTM^SCMCTMU(SCTM,SCDT)
IF 'SCOK D G QTOKTM
.N SCX
.S SCX=$D(^SCTM(404.58,SCTM,"AIDT",SCTM))
.D:'SCX MESS(" Never activated - Edit via PCMM")
.D:SCX MESS(" Not active on "_SCDT)
IF SCOK<0 D G QTOKTM
.D MESS(" Error in setup")
IF $D(^TMP("SCMC",$J,"TMPRPT",SCTM,0)) D
.D MESS("Team Assignment Only","!?15")
.D:'SCNOPRPT MESS("Patients to be assigned to this team:","!?20")
.S DFN=0 F S DFN=$O(^TMP("SCMC",$J,"TMPRPT",SCTM,0,DFN)) Q:'DFN D
..D MESS($$DISPPT(DFN),"!?25")
..S SCX=$$NMPCTM^SCAPMCU2(DFN,SCDT,1)
..D:SCX&(+SCX=SCTM)&('SCNOPRPT) MESS("Already assigned","!?27")
..D:SCX&(+SCX'=SCTM)&('SCNOPRPT) MESS("Previously assigned to "_$P(SCX,U,2),"!?27")
..Q:SCX
..D:$G(SCASSIGN) PCUPDTM(DFN)
.D:$G(SCASSIGN) MAILLST^SCMCTMM(SCTM,"SCTEAMAR",SCDT,"^TMP(""SCMC"",$J,""NEWTM"",SCTM)")
.F SCSUB="NEWTM","BADTM" K ^TMP("SCMC",$J,SCSUB,SCTM)
S SC200=0
F S SC200=$O(^TMP("SCMC",$J,"TMPRPT",SCTM,SC200)) Q:'SC200 D
.N SCTMPLST,SCCNT,SCTP,SCX,DFN
.D MESS("Practitioner: "_$$DISP200(SC200),"!?15")
.IF '$D(^VA(200,SC200,0)) D
..S SCOK=0
..D MESS("Bad Practitioner Assignment"_$S(SCNOPRPT:"",1:" for the following patient(s):"),"!?15")
..S DFN=0 F S DFN=$O(^TMP("SCMC",$J,"TMPRPT",SCTM,SC200,DFN)) Q:'DFN D
...D MESS($$DISPPT(DFN),"!?25")
.ELSE D
.S:'$$TPPR^SCAPMC(SC200,"SCDTS",,,"SCTMPLST($J)",.SCERR) SCOK=0
.S SCXTP=0 F SCCNT=0:1 S SCXTP=$O(SCTMPLST($J,"SCTP",SCTM,SCXTP)) Q:'SCXTP S SCTP=SCXTP D MESS("Position: "_$$DISPTP(SCTP),"!?17")
.;if no team-position assignments for pract
.IF 'SCCNT D
..S SCOK=0
..D MESS("is assigned to "_SCCNT_" positions on team","!?20")
..D MESS("you need to assign him/her to a position on the team","!?20")
..S ^TMP("SCMC",$J,"NO_TP",SCTM,SC200)=""
.;if exactly one practitioner assignment to team
.IF SCCNT=1 D
..D:'SCNOPRPT MESS("Patients to be assigned to this position:","!?20")
..S DFN=0 F S DFN=$O(^TMP("SCMC",$J,"TMPRPT",SCTM,SC200,DFN)) Q:'DFN D
...D MESS($$DISPPT(DFN),"!?25")
...S SCX=$$NMPCTP^SCAPMCU2(DFN,SCDT,1)
...D:SCX&(+SCX=SCTP)&('SCNOPRPT) MESS("Already assigned","!?27")
...D:SCX&(+SCX'=SCTP)&('SCNOPRPT) MESS("Previously assigned to "_$P(SCX,U,2),"!?27")
...Q:SCX
...D:$G(SCASSIGN) PCUPD(DFN)
..D:$G(SCASSIGN) MAILLST^SCMCTPM(SCTP,"SCHISTAR",SCDT,"^TMP(""SCMC"",$J,""NEWTP"",SCTP)","^TMP(""SCMC"",$J,""OLDTP"",SCTP)","^TMP(""SCMC"",$J,""BADTP"",SCTP)")
..D:$G(SCASSIGN) MAILLST^SCMCTMM(SCTM,"SCTEAMAR",SCDT,"^TMP(""SCMC"",$J,""NEWTM"",SCTM)")
..F SCSUB="NEWTP","OLDTP","BADTP" K ^TMP("SCMC",$J,SCSUB,SCTP)
..K ^TMP("SCMC",$J,"NEWTM",SCTM)
.;if multiple positin assignments for team for pract
.IF SCCNT>1 D
..S SCOK=0
..D MESS("Practitioner is assigned to "_SCCNT_" positions on team","!?20")
..D MESS("because there is more than one position for this team","!?20")
..D MESS("and practitioner, there will be no patient assignments","!?20")
..S SCTP=0 F S SCTP=$O(SCTMPLST($J,SCTM,SCTP)) Q:'SCTP S ^TMP("SCMC",$J,"MULT_TP",SCTM,SC200,SCTP)=""
.IF SCCNT=1 S ^TMP("SCMC",$J,"ONE_TP",SCTM,SC200,SCTP)=""
QTOKTM Q SCOK
;
PCUPD(DFN) ;
N SCX,SCNOMAIL
S SCNOMAIL=1
;This is NOT a stand-alone procedure
S SCX=$$ACPTTP^SCAPMC(DFN,SCTP,"SCHISTAR",SCDT,.SCERR,SCYESTM)
IF SCX D
.D MESS("File #404.43 ien = "_+SCX,"!?30")
.IF $P(SCX,U,2) D
..D MESS(" New Entry")
..S ^TMP("SCMC",$J,"NEWTP",SCTP,DFN)=""
..IF $P(SCX,U,4) D
...D MESS(" Team Assignment Made. IEN="_$P(SCX,U,3),"!?30")
...S ^TMP("SCMC",$J,"NEWTM",SCTM,DFN)=""
.ELSE D
..D MESS(" Already Assigned")
..S ^TMP("SCMC",$J,"OLDTP",SCTP,DFN)=""
ELSE D
.D MESS(" - NOT saved")
.S ^TMP("SCMC",$J,"BADTP",+$G(SCTP),DFN)=""
.D:('$P(SCX,U,2))&('$P(SCX,U,4))&('$P(SCX,U,3)) MESS("No Patient Team Assignment","!?30")
Q
;
PCUPDTM(DFN) ;
N SCX,SCNOMAIL
S SCNOMAIL=1
;This is NOT a stand-alone procedure
S SCX=$$ACPTTM^SCAPMC(DFN,SCTM,"SCTEAMAR",SCDT,.SCERR)
IF SCX D
.D MESS("File #404.42 ien = "_+SCX,"!?30")
.IF $P(SCX,U,2) D
..D MESS(" New Entry")
..S ^TMP("SCMC",$J,"NEWTM",SCTM,DFN)=""
ELSE D
.D MESS(" - NOT saved")
.S ^TMP("SCMC",$J,"BADTM",+$G(SCTM),DFN)=""
Q
;
OKCLEAN() ;
D MESS(">>> Cleaning up ^TMP(""SCMC"" global","!?5")
N SCOK
S SCOK=1
;K ^TMP("SCMC",$J)
Q SCOK
;
DISP200(SC200) ;
Q $P($G(^VA(200,SC200,0)),U,1)_" [#"_SC200_"]"
;
DISPTP(SCTP) ;
Q $P($G(^SCTM(404.57,SCTP,0)),U,1)_" [#"_SCTP_"]"
;
DISPTM(SCTM) ;
Q $P($G(^SCTM(404.51,SCTM,0)),U,1)_" [#"_SCTM_"]"
;
DISPPT(DFN) ;
Q $S(SCNOPRPT:"",1:$E($P($G(^DPT(DFN,0)),U,1),1,21)_" [SSN#:"_$P($G(^DPT(DFN,0)),U,9)_"]")
;
MESS(TEXT,FORMAT) ;
Q:$G(SCSTOP)!($G(TEXT)="")
S FORMAT=$G(FORMAT,"?5")
D OUT^SCMCRU(TEXT,FORMAT)
Q
;
GETDEV() ;
N SCOK
S SCOK=0
S %ZIS="PMQ" D ^%ZIS G:POP QTGDV
S SCOK=1
QTGDV Q (SCOK)
;
QUE(NAME,START) ;
; Needed: ZTSAVE array
; NAME = description
; START = starting point of routine
S ZTDESC=NAME,ZTRTN=START
D ^%ZTLOAD W:$D(ZTSK) !,"TASK #",ZTSK
D HOME^%ZIS K IO("Q")
Q ZTSK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCCV 8868 printed Oct 16, 2024@18:40:35 Page 2
SCMCCV ;ALB/REW - PCMM Conversion of Patient File Fields ; 1 Feb 1996
+1 ;;5.3;Scheduling;**41**;AUG 13, 1993
EN ;
+1 ; Variables:
+2 ; SCASSIGN: 1=Make Patient Assignments if unambiguous (0=No,default)
+3 ; SCDT: Date to make assignments (Default=DT)
+4 ; SCYESTM: 1=Make Pt Tm as well as Pt Posit Assmnts,default(0=No)
+5 ; SCNOPRPT 1=Don't print patient-detail lines
+6 ;
+7 NEW SCOK,DFN,SCPCNODE,SCLIST,SCTMPLST,SCHISTAR,SCASSIGN,SCYESTM,SCTM,Y,SCSTOP,SCPAGE,SCNOPRPT,SCTEAMAR,SCNOW,SCSUB
+8 NEW SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS
+9 IF '$$OKASK
DO MESS("Search aborted","!?5")
GOTO QTEN
+10 IF '$DATA(IO("Q"))
Begin DoDot:1
+11 USE IO
+12 DO REP
+13 DO ^%ZISC
End DoDot:1
+14 IF '$TEST
Begin DoDot:1
+15 FOR X="SCASSIGN","SCYESTM","SCDT","SCNOPRPT"
SET ZTSAVE(X)=""
+16 SET Y=$$QUE("SC Patient-Team/Practitioner"_$SELECT('SCASSIGN:"Report Only",1:"Report and Assignment"),"REP^SCMCCV")
End DoDot:1
QTEN QUIT
+1 ;
OKASK() ;
+1 NEW SCOK,DIR
+2 ;do you want to assign or just get a report?
+3 SET DIR(0)="Y"
+4 SET DIR("B")="NO"
+5 SET DIR("A")="Do you want to assign patients right now?"
+6 SET DIR("A",1)=""
+7 SET DIR("A",2)=""
+8 SET DIR("A",3)=" YES = Assign Patients to Teams and Team Positions"
+9 SET DIR("A",4)=" NO = Just print report to see how things would be"
+10 DO ^DIR
+11 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET SCOK=0
GOTO QTASK
+12 SET SCASSIGN=Y
+13 ;do you want to omit printing patients?
+14 SET DIR(0)="Y"
+15 SET DIR("B")="YES"
+16 SET DIR("A")="Do you want to omit printing patients?"
+17 SET DIR("A",1)=""
+18 SET DIR("A",2)=""
+19 SET DIR("A",3)=" NO = Print detail line for each patient that is assignable"
+20 SET DIR("A",4)=" YES = Just print Team & Practitioner information"
+21 DO ^DIR
+22 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET SCOK=0
GOTO QTASK
+23 SET SCNOPRPT=Y
+24 IF '$DATA(SCASSIGN)
SET SCASSIGN=0
+25 IF '$DATA(SCDT)
SET SCDT=DT
+26 IF '$DATA(SCYESTM)
SET SCYESTM=1
+27 SET SCOK=$$GETDEV
QTASK QUIT SCOK
+1 ;
REP ;non-interactive portion
+1 ;check for task end
if $$FIRST^SCMCRU
QUIT
+2 IF '$$OKINIT()
GOTO QTEN
+3 DO MESS(" ..Ok")
+4 IF '$$OKBUILD
GOTO QRP
+5 DO MESS(" ..Ok")
+6 IF '$$OKREPORT
GOTO QRP
+7 DO MESS(" ..Ok")
+8 IF '$$OKCLEAN
GOTO QRP
+9 DO MESS(" ..Ok")
QRP QUIT
+1 ;
OKINIT() ;
+1 NEW SCOK
+2 SET SCOK=1
+3 DO MESS(">>> Checking Programmer Variables:","!,?5")
+4 IF +$GET(DUZ)'>0!($GET(U)'="^")!('$DATA(DT))
Begin DoDot:1
+5 SET XPDABORT=1
+6 DO MESS("You must first initialize Programmer Environment by running ^XUP")
+7 SET SCOK=0
End DoDot:1
QUIT 0
+8 SET SCLIST="SCTMPLST"
+9 DO INIT^SCAPMCU1(.SCOK)
+10 DO NOW^%DTC
+11 SET SCNOW=%
+12 ;pc practitioner
SET SCHISTAR(.05)=1
+13 ;user entering
SET SCHISTAR(.06)=DUZ
+14 ;date entered
SET SCHISTAR(.07)=SCNOW
+15 ;pc team
SET SCTEAMAR(.08)=1
+16 ;user
SET SCTEAMAR(.11)=DUZ
+17 ;date enter=now
SET SCTEAMAR(.12)=SCNOW
+18 QUIT SCOK
+19 ;
OKBUILD() ;
+1 NEW SCOK
+2 SET SCOK=1
+3 DO MESS(">>> Looping through PC Nodes of PATIENT File","!,?5")
+4 SET DFN=0
+5 FOR
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
SET SCPCNODE=$GET(^DPT(DFN,"PC"))
IF SCPCNODE]""
Begin DoDot:1
+6 SET ^TMP("SCMC",$JOB,"TMPRPT",+$PIECE(SCPCNODE,U,2),+$PIECE(SCPCNODE,U,1),DFN)=""
End DoDot:1
if '(DFN#100)
DO MESS(".")
+7 QUIT SCOK
+8 ;
OKREPORT() ;
+1 NEW SCOK,SCTM,SCPR,SCTMNODE
+2 SET SCOK=1
+3 DO MESS(">>> Producing PATIENT File PC Report","!?5")
+4 DO MESS(" Checking Team/Practitioner Assignments:","!?10")
+5 SET SCTM=0
+6 FOR
SET SCTM=$ORDER(^TMP("SCMC",$JOB,"TMPRPT",SCTM))
if 'SCTM!$GET(SCSTOP)
QUIT
Begin DoDot:1
+7 SET SCTMNODE=$GET(^SCTM(404.51,SCTM,0))
+8 DO MESS(">>>Team: "_$$DISPTM(SCTM),"!!?10")
+9 IF '$$OKTEAM(SCTM,SCDT)
Begin DoDot:2
+10 SET SCOK=0
+11 ;D MESS("Problem(s) with Practitioner Assignments","!?15")
End DoDot:2
End DoDot:1
+12 QUIT SCOK
+13 ;
OKTEAM(SCTM,SCDT) ;return 1 if exactly 1 posit for each team assignment
+1 ;needs 'tmp('scmc',$j,'tmpr' array defined
+2 ;return count of positions pract is assigned to to team
+3 NEW SCOK,SC200,SCTMND,SCFLD,SCF
+4 SET SCOK=1
+5 SET SCTMND=$GET(^SCTM(404.51,+$GET(SCTM),0))
+6 ;check required fields
FOR SCFLD=3,6,7
IF '$PIECE(SCTMND,U,SCFLD)
Begin DoDot:1
+7 SET SCOK=0
+8 SET SCF=$$DDNAME^SCMCRU(404.51,(SCFLD*.01))
+9 DO MESS(SCF_" (#"_(SCFLD*.01)_") of Team required. Enter via PCMM ","!?20")
End DoDot:1
+10 if 'SCOK
GOTO QTOKTM
+11 SET SCOK=$$ACTTM^SCMCTMU(SCTM,SCDT)
+12 IF 'SCOK
Begin DoDot:1
+13 NEW SCX
+14 SET SCX=$DATA(^SCTM(404.58,SCTM,"AIDT",SCTM))
+15 if 'SCX
DO MESS(" Never activated - Edit via PCMM")
+16 if SCX
DO MESS(" Not active on "_SCDT)
End DoDot:1
GOTO QTOKTM
+17 IF SCOK<0
Begin DoDot:1
+18 DO MESS(" Error in setup")
End DoDot:1
GOTO QTOKTM
+19 IF $DATA(^TMP("SCMC",$JOB,"TMPRPT",SCTM,0))
Begin DoDot:1
+20 DO MESS("Team Assignment Only","!?15")
+21 if 'SCNOPRPT
DO MESS("Patients to be assigned to this team:","!?20")
+22 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCMC",$JOB,"TMPRPT",SCTM,0,DFN))
if 'DFN
QUIT
Begin DoDot:2
+23 DO MESS($$DISPPT(DFN),"!?25")
+24 SET SCX=$$NMPCTM^SCAPMCU2(DFN,SCDT,1)
+25 if SCX&(+SCX=SCTM)&('SCNOPRPT)
DO MESS("Already assigned","!?27")
+26 if SCX&(+SCX'=SCTM)&('SCNOPRPT)
DO MESS("Previously assigned to "_$PIECE(SCX,U,2),"!?27")
+27 if SCX
QUIT
+28 if $GET(SCASSIGN)
DO PCUPDTM(DFN)
End DoDot:2
+29 if $GET(SCASSIGN)
DO MAILLST^SCMCTMM(SCTM,"SCTEAMAR",SCDT,"^TMP(""SCMC"",$J,""NEWTM"",SCTM)")
+30 FOR SCSUB="NEWTM","BADTM"
KILL ^TMP("SCMC",$JOB,SCSUB,SCTM)
End DoDot:1
+31 SET SC200=0
+32 FOR
SET SC200=$ORDER(^TMP("SCMC",$JOB,"TMPRPT",SCTM,SC200))
if 'SC200
QUIT
Begin DoDot:1
+33 NEW SCTMPLST,SCCNT,SCTP,SCX,DFN
+34 DO MESS("Practitioner: "_$$DISP200(SC200),"!?15")
+35 IF '$DATA(^VA(200,SC200,0))
Begin DoDot:2
+36 SET SCOK=0
+37 DO MESS("Bad Practitioner Assignment"_$SELECT(SCNOPRPT:"",1:" for the following patient(s):"),"!?15")
+38 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCMC",$JOB,"TMPRPT",SCTM,SC200,DFN))
if 'DFN
QUIT
Begin DoDot:3
+39 DO MESS($$DISPPT(DFN),"!?25")
End DoDot:3
End DoDot:2
+40 IF '$TEST
Begin DoDot:2
End DoDot:2
+41 if '$$TPPR^SCAPMC(SC200,"SCDTS",,,"SCTMPLST($J)",.SCERR)
SET SCOK=0
+42 SET SCXTP=0
FOR SCCNT=0:1
SET SCXTP=$ORDER(SCTMPLST($JOB,"SCTP",SCTM,SCXTP))
if 'SCXTP
QUIT
SET SCTP=SCXTP
DO MESS("Position: "_$$DISPTP(SCTP),"!?17")
+43 ;if no team-position assignments for pract
+44 IF 'SCCNT
Begin DoDot:2
+45 SET SCOK=0
+46 DO MESS("is assigned to "_SCCNT_" positions on team","!?20")
+47 DO MESS("you need to assign him/her to a position on the team","!?20")
+48 SET ^TMP("SCMC",$JOB,"NO_TP",SCTM,SC200)=""
End DoDot:2
+49 ;if exactly one practitioner assignment to team
+50 IF SCCNT=1
Begin DoDot:2
+51 if 'SCNOPRPT
DO MESS("Patients to be assigned to this position:","!?20")
+52 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCMC",$JOB,"TMPRPT",SCTM,SC200,DFN))
if 'DFN
QUIT
Begin DoDot:3
+53 DO MESS($$DISPPT(DFN),"!?25")
+54 SET SCX=$$NMPCTP^SCAPMCU2(DFN,SCDT,1)
+55 if SCX&(+SCX=SCTP)&('SCNOPRPT)
DO MESS("Already assigned","!?27")
+56 if SCX&(+SCX'=SCTP)&('SCNOPRPT)
DO MESS("Previously assigned to "_$PIECE(SCX,U,2),"!?27")
+57 if SCX
QUIT
+58 if $GET(SCASSIGN)
DO PCUPD(DFN)
End DoDot:3
+59 if $GET(SCASSIGN)
DO MAILLST^SCMCTPM(SCTP,"SCHISTAR",SCDT,"^TMP(""SCMC"",$J,""NEWTP"",SCTP)","^TMP(""SCMC"",$J,""OLDTP"",SCTP)","^TMP(""SCMC"",$J,""BADTP"",SCTP)")
+60 if $GET(SCASSIGN)
DO MAILLST^SCMCTMM(SCTM,"SCTEAMAR",SCDT,"^TMP(""SCMC"",$J,""NEWTM"",SCTM)")
+61 FOR SCSUB="NEWTP","OLDTP","BADTP"
KILL ^TMP("SCMC",$JOB,SCSUB,SCTP)
+62 KILL ^TMP("SCMC",$JOB,"NEWTM",SCTM)
End DoDot:2
+63 ;if multiple positin assignments for team for pract
+64 IF SCCNT>1
Begin DoDot:2
+65 SET SCOK=0
+66 DO MESS("Practitioner is assigned to "_SCCNT_" positions on team","!?20")
+67 DO MESS("because there is more than one position for this team","!?20")
+68 DO MESS("and practitioner, there will be no patient assignments","!?20")
+69 SET SCTP=0
FOR
SET SCTP=$ORDER(SCTMPLST($JOB,SCTM,SCTP))
if 'SCTP
QUIT
SET ^TMP("SCMC",$JOB,"MULT_TP",SCTM,SC200,SCTP)=""
End DoDot:2
+70 IF SCCNT=1
SET ^TMP("SCMC",$JOB,"ONE_TP",SCTM,SC200,SCTP)=""
End DoDot:1
QTOKTM QUIT SCOK
+1 ;
PCUPD(DFN) ;
+1 NEW SCX,SCNOMAIL
+2 SET SCNOMAIL=1
+3 ;This is NOT a stand-alone procedure
+4 SET SCX=$$ACPTTP^SCAPMC(DFN,SCTP,"SCHISTAR",SCDT,.SCERR,SCYESTM)
+5 IF SCX
Begin DoDot:1
+6 DO MESS("File #404.43 ien = "_+SCX,"!?30")
+7 IF $PIECE(SCX,U,2)
Begin DoDot:2
+8 DO MESS(" New Entry")
+9 SET ^TMP("SCMC",$JOB,"NEWTP",SCTP,DFN)=""
+10 IF $PIECE(SCX,U,4)
Begin DoDot:3
+11 DO MESS(" Team Assignment Made. IEN="_$PIECE(SCX,U,3),"!?30")
+12 SET ^TMP("SCMC",$JOB,"NEWTM",SCTM,DFN)=""
End DoDot:3
End DoDot:2
+13 IF '$TEST
Begin DoDot:2
+14 DO MESS(" Already Assigned")
+15 SET ^TMP("SCMC",$JOB,"OLDTP",SCTP,DFN)=""
End DoDot:2
End DoDot:1
+16 IF '$TEST
Begin DoDot:1
+17 DO MESS(" - NOT saved")
+18 SET ^TMP("SCMC",$JOB,"BADTP",+$GET(SCTP),DFN)=""
+19 if ('$PIECE(SCX,U,2))&('$PIECE(SCX,U,4))&('$PIECE(SCX,U,3))
DO MESS("No Patient Team Assignment","!?30")
End DoDot:1
+20 QUIT
+21 ;
PCUPDTM(DFN) ;
+1 NEW SCX,SCNOMAIL
+2 SET SCNOMAIL=1
+3 ;This is NOT a stand-alone procedure
+4 SET SCX=$$ACPTTM^SCAPMC(DFN,SCTM,"SCTEAMAR",SCDT,.SCERR)
+5 IF SCX
Begin DoDot:1
+6 DO MESS("File #404.42 ien = "_+SCX,"!?30")
+7 IF $PIECE(SCX,U,2)
Begin DoDot:2
+8 DO MESS(" New Entry")
+9 SET ^TMP("SCMC",$JOB,"NEWTM",SCTM,DFN)=""
End DoDot:2
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 DO MESS(" - NOT saved")
+12 SET ^TMP("SCMC",$JOB,"BADTM",+$GET(SCTM),DFN)=""
End DoDot:1
+13 QUIT
+14 ;
OKCLEAN() ;
+1 DO MESS(">>> Cleaning up ^TMP(""SCMC"" global","!?5")
+2 NEW SCOK
+3 SET SCOK=1
+4 ;K ^TMP("SCMC",$J)
+5 QUIT SCOK
+6 ;
DISP200(SC200) ;
+1 QUIT $PIECE($GET(^VA(200,SC200,0)),U,1)_" [#"_SC200_"]"
+2 ;
DISPTP(SCTP) ;
+1 QUIT $PIECE($GET(^SCTM(404.57,SCTP,0)),U,1)_" [#"_SCTP_"]"
+2 ;
DISPTM(SCTM) ;
+1 QUIT $PIECE($GET(^SCTM(404.51,SCTM,0)),U,1)_" [#"_SCTM_"]"
+2 ;
DISPPT(DFN) ;
+1 QUIT $SELECT(SCNOPRPT:"",1:$EXTRACT($PIECE($GET(^DPT(DFN,0)),U,1),1,21)_" [SSN#:"_$PIECE($GET(^DPT(DFN,0)),U,9)_"]")
+2 ;
MESS(TEXT,FORMAT) ;
+1 if $GET(SCSTOP)!($GET(TEXT)="")
QUIT
+2 SET FORMAT=$GET(FORMAT,"?5")
+3 DO OUT^SCMCRU(TEXT,FORMAT)
+4 QUIT
+5 ;
GETDEV() ;
+1 NEW SCOK
+2 SET SCOK=0
+3 SET %ZIS="PMQ"
DO ^%ZIS
if POP
GOTO QTGDV
+4 SET SCOK=1
QTGDV QUIT (SCOK)
+1 ;
QUE(NAME,START) ;
+1 ; Needed: ZTSAVE array
+2 ; NAME = description
+3 ; START = starting point of routine
+4 SET ZTDESC=NAME
SET ZTRTN=START
+5 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"TASK #",ZTSK
+6 DO HOME^%ZIS
KILL IO("Q")
+7 QUIT ZTSK
