- 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 Mar 13, 2025@21:44:54 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
